| 1 |
- #' Univariate and bivariate visualizations+ #' Scatterplot and Regression Model |
||
| 6 |
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' @param regressor (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 7 |
- #' Variable names selected to plot along the x-axis by default. Variable can be numeric, factor or character.+ #' Regressor variables from an incoming dataset with filtering and selecting. |
||
| 8 |
- #' No empty selections are allowed!+ #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 9 |
- #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' Response variables from an incoming dataset with filtering and selecting. |
||
| 10 |
- #' Variable names selected to plot along the y-axis by default. Variable can be numeric, factor or character.+ #' @param alpha optional, (`numeric`) If scalar then the plot points will have a fixed opacity. If a |
||
| 11 |
- #' @param use_density optional, (`logical`) value for whether density (`TRUE`) is plotted or+ #' slider should be presented to adjust the plot point opacity dynamically then it can be a vector of |
||
| 12 |
- #' frequency (`FALSE`). Defaults to frequency (`FALSE`).+ #' length three with `c(value, min, max)`. |
||
| 13 |
- #' @param row_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' @param size optional, (`numeric`) If scalar then the plot point sizes will have a fixed size |
||
| 14 |
- #' Variables for row facetting.+ #' If a slider should be presented to adjust the plot point sizes dynamically then it can be a |
||
| 15 |
- #' @param col_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' vector of length three with `c(value, min, max)`. |
||
| 16 |
- #' Variables for col facetting.+ #' @param default_outlier_label optional, (`character`) The default column selected to label outliers. |
||
| 17 |
- #' @param facet optional, (`logical`) to specify whether the facet encodings `ui` elements are toggled+ #' @param default_plot_type optional, (`numeric`) Defaults to Response vs Regressor. |
||
| 18 |
- #' on and shown to the user by default. Defaults to `TRUE` if either `row_facet` or `column_facet`+ #' 1. Response vs Regressor |
||
| 19 |
- #' are supplied.+ #' 2. Residuals vs Fitted |
||
| 20 |
- #' @param color_settings (`logical`) Whether coloring, filling and size should be applied+ #' 3. Normal Q-Q |
||
| 21 |
- #' and `UI` tool offered to the user.+ #' 4. Scale-Location |
||
| 22 |
- #' @param color optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' 5. Cook's distance |
||
| 23 |
- #' Variables selected for the outline color inside the coloring settings.+ #' 6. Residuals vs Leverage |
||
| 24 |
- #' It will be applied when `color_settings` is set to `TRUE`.+ #' 7. Cook's dist vs Leverage |
||
| 25 |
- #' @param fill optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' |
||
| 26 |
- #' Variables selected for the fill color inside the coloring settings.+ #' @templateVar ggnames `r regression_names` |
||
| 27 |
- #' It will be applied when `color_settings` is set to `TRUE`.+ #' @template ggplot2_args_multi |
||
| 28 |
- #' @param size optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' |
||
| 29 |
- #' Variables selected for the size of `geom_point` plots inside the coloring settings.+ #' @note For more examples, please see the vignette "Using regression plots" via |
||
| 30 |
- #' It will be applied when `color_settings` is set to `TRUE`.+ #' `vignette("using-regression-plots", package = "teal.modules.general")`.
|
||
| 31 |
- #' @param free_x_scales optional, (`logical`) Whether X scaling shall be changeable.+ #' @export |
||
| 32 |
- #' Does not allow scaling to be changed by default (`FALSE`).+ #' |
||
| 33 |
- #' @param free_y_scales optional, (`logical`) Whether Y scaling shall be changeable.+ #' @examples |
||
| 34 |
- #' Does not allow scaling to be changed by default (`FALSE`).+ #' # Regression graphs from selected response variable (BMRKR1) and |
||
| 35 |
- #' @param swap_axes optional, (`logical`) Whether to swap X and Y axes. Defaults to `FALSE`.+ #' # selected regressors (AGE) |
||
| 37 |
- #' @details+ #' ADSL <- teal.modules.general::rADSL |
||
| 38 |
- #' This is a general module to visualize 1 & 2 dimensional data.+ #' |
||
| 39 |
- #'+ #' app <- teal::init( |
||
| 40 |
- #' @note+ #' data = teal.data::cdisc_data( |
||
| 41 |
- #' For more examples, please see the vignette "Using bivariate plot" via+ #' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
|
||
| 42 |
- #' `vignette("using-bivariate-plot", package = "teal.modules.general")`.
+ #' check = TRUE |
||
| 43 |
- #'+ #' ), |
||
| 44 |
- #' @export+ #' modules = teal::modules( |
||
| 45 |
- #'+ #' teal.modules.general::tm_a_regression( |
||
| 46 |
- #' @examples+ #' label = "Regression", |
||
| 47 |
- #' # Bivariate plot of selected variable (AGE) against selected (SEX)+ #' response = teal.transform::data_extract_spec( |
||
| 48 |
- #' ADSL <- teal.modules.general::rADSL+ #' dataname = "ADSL", |
||
| 49 |
- #'+ #' select = teal.transform::select_spec( |
||
| 50 |
- #' app <- teal::init(+ #' label = "Select variable:", |
||
| 51 |
- #' data = teal.data::cdisc_data(+ #' choices = "BMRKR1", |
||
| 52 |
- #' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
+ #' selected = "BMRKR1", |
||
| 53 |
- #' check = TRUE+ #' multiple = FALSE, |
||
| 54 |
- #' ),+ #' fixed = TRUE |
||
| 55 |
- #' modules = teal::modules(+ #' ) |
||
| 56 |
- #' teal.modules.general::tm_g_bivariate(+ #' ), |
||
| 57 |
- #' x = teal.transform::data_extract_spec(+ #' regressor = teal.transform::data_extract_spec( |
||
| 60 |
- #' label = "Select variable:",+ #' label = "Select variables:", |
||
| 61 |
- #' choices = teal.transform::variable_choices(ADSL),+ #' choices = teal.transform::variable_choices(ADSL, c("AGE", "SEX", "RACE")),
|
||
| 63 |
- #' fixed = FALSE+ #' multiple = TRUE, |
||
| 64 |
- #' )+ #' fixed = FALSE |
||
| 65 |
- #' ),+ #' ) |
||
| 66 |
- #' y = teal.transform::data_extract_spec(+ #' ), |
||
| 67 |
- #' dataname = "ADSL",+ #' ggplot2_args = teal.widgets::ggplot2_args( |
||
| 68 |
- #' select = teal.transform::select_spec(+ #' labs = list(subtitle = "Plot generated by Regression Module") |
||
| 69 |
- #' label = "Select variable:",+ #' ) |
||
| 70 |
- #' choices = teal.transform::variable_choices(ADSL),+ #' ) |
||
| 71 |
- #' selected = "SEX",+ #' ) |
||
| 72 |
- #' multiple = FALSE,+ #' ) |
||
| 73 |
- #' fixed = FALSE+ #' if (interactive()) {
|
||
| 74 |
- #' )+ #' shinyApp(app$ui, app$server) |
||
| 75 |
- #' ),+ #' } |
||
| 76 |
- #' row_facet = teal.transform::data_extract_spec(+ tm_a_regression <- function(label = "Regression Analysis", |
||
| 77 |
- #' dataname = "ADSL",+ regressor, |
||
| 78 |
- #' select = teal.transform::select_spec(+ response, |
||
| 79 |
- #' label = "Select variable:",+ plot_height = c(600, 200, 2000), |
||
| 80 |
- #' choices = teal.transform::variable_choices(ADSL),+ plot_width = NULL, |
||
| 81 |
- #' selected = "ARM",+ alpha = c(1, 0, 1), |
||
| 82 |
- #' fixed = FALSE+ size = c(2, 1, 8), |
||
| 83 |
- #' )+ ggtheme = c( |
||
| 84 |
- #' ),+ "gray", "bw", "linedraw", "light", "dark", |
||
| 85 |
- #' col_facet = teal.transform::data_extract_spec(+ "minimal", "classic", "void", "test" |
||
| 86 |
- #' dataname = "ADSL",+ ), |
||
| 87 |
- #' select = teal.transform::select_spec(+ ggplot2_args = teal.widgets::ggplot2_args(), |
||
| 88 |
- #' label = "Select variable:",+ pre_output = NULL, |
||
| 89 |
- #' choices = teal.transform::variable_choices(ADSL),+ post_output = NULL, |
||
| 90 |
- #' selected = "COUNTRY",+ default_plot_type = 1, |
||
| 91 |
- #' fixed = FALSE+ default_outlier_label = "USUBJID") {
|
||
| 92 | -+ | ! |
- #' )+ logger::log_info("Initializing tm_a_regression")
|
| 93 | -+ | ! |
- #' ),+ if (inherits(regressor, "data_extract_spec")) regressor <- list(regressor) |
| 94 | -+ | ! |
- #' ggplot2_args = teal.widgets::ggplot2_args(+ if (inherits(response, "data_extract_spec")) response <- list(response) |
| 95 | -+ | ! |
- #' labs = list(subtitle = "Plot generated by Bivariate Module")+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
| 96 |
- #' )+ |
||
| 97 | -+ | ! |
- #' )+ checkmate::assert_string(label) |
| 98 | -+ | ! |
- #' )+ checkmate::assert_list(response, types = "data_extract_spec") |
| 99 | -+ | ! |
- #' )+ if (!all(vapply(response, function(x) !(x$select$multiple), logical(1)))) {
|
| 100 | -+ | ! |
- #' if (interactive()) {
+ stop("'response' should not allow multiple selection")
|
| 101 |
- #' shinyApp(app$ui, app$server)+ } |
||
| 102 | -+ | ! |
- #' }+ checkmate::assert_list(regressor, types = "data_extract_spec") |
| 103 | -+ | ! |
- tm_g_bivariate <- function(label = "Bivariate Plots",+ ggtheme <- match.arg(ggtheme) |
| 104 | -+ | ! |
- x,+ checkmate::assert_string(default_outlier_label) |
| 105 | -+ | ! |
- y,+ plot_choices <- c( |
| 106 | -+ | ! |
- row_facet = NULL,+ "Response vs Regressor", "Residuals vs Fitted", "Normal Q-Q", "Scale-Location", |
| 107 | -+ | ! |
- col_facet = NULL,+ "Cook's distance", "Residuals vs Leverage", "Cook's dist vs Leverage" |
| 108 |
- facet = !is.null(row_facet) || !is.null(col_facet),+ ) |
||
| 109 | -+ | ! |
- color = NULL,+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
| 110 | -+ | ! |
- fill = NULL,+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
| 111 | -+ | ! |
- size = NULL,+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 112 | -+ | ! |
- use_density = FALSE,+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 113 | -+ | ! |
- color_settings = FALSE,+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 114 | -+ | ! |
- free_x_scales = FALSE,+ checkmate::assert_numeric( |
| 115 | -+ | ! |
- free_y_scales = FALSE,+ plot_width[1], |
| 116 | -+ | ! |
- plot_height = c(600, 200, 2000),+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 117 |
- plot_width = NULL,+ ) |
||
| 118 |
- rotate_xaxis_labels = FALSE,+ |
||
| 119 |
- swap_axes = FALSE,+ # Send ui args |
||
| 120 | -+ | ! |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
+ args <- as.list(environment()) |
| 121 | -+ | ! |
- ggplot2_args = teal.widgets::ggplot2_args(),+ args[["plot_choices"]] <- plot_choices |
| 122 | -+ | ! |
- pre_output = NULL,+ data_extract_list <- list( |
| 123 | -+ | ! |
- post_output = NULL) {
+ regressor = regressor, |
| 124 | ! |
- logger::log_info("Initializing tm_g_bivariate")
+ response = response |
|
| 125 | -! | +
- if (inherits(x, "data_extract_spec")) x <- list(x)+ ) |
|
| 126 | -! | +
- if (inherits(y, "data_extract_spec")) y <- list(y)+ |
|
| 127 | ! |
- if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)+ module( |
|
| 128 | ! |
- if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)+ label = label, |
|
| 129 | ! |
- if (inherits(color, "data_extract_spec")) color <- list(color)+ server = srv_a_regression, |
|
| 130 | ! |
- if (inherits(fill, "data_extract_spec")) fill <- list(fill)+ ui = ui_a_regression, |
|
| 131 | ! |
- if (inherits(size, "data_extract_spec")) size <- list(size)+ ui_args = args, |
|
| 132 | -+ | ! |
-
+ server_args = c( |
| 133 | ! |
- checkmate::assert_list(x, types = "data_extract_spec")+ data_extract_list, |
|
| 134 | ! |
- if (!all(vapply(x, function(x) !x$select$multiple, logical(1)))) {
+ list( |
|
| 135 | ! |
- stop("'x' should not allow multiple selection")
+ plot_height = plot_height, |
|
| 136 | -+ | ! |
- }+ plot_width = plot_width, |
| 137 | ! |
- checkmate::assert_list(y, types = "data_extract_spec")+ default_outlier_label = default_outlier_label, |
|
| 138 | ! |
- if (!all(vapply(y, function(x) !x$select$multiple, logical(1)))) {
+ ggplot2_args = ggplot2_args |
|
| 139 | -! | +
- stop("'y' should not allow multiple selection")
+ ) |
|
| 140 |
- }+ ), |
||
| 141 | ! |
- checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
|
| 142 | -! | +
- if (!all(vapply(row_facet, function(x) !x$select$multiple, logical(1)))) {
+ ) |
|
| 143 | -! | +
- stop("'row_facet' should not allow multiple selection")
+ } |
|
| 144 |
- }+ |
||
| 145 | -! | +
- checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)+ ui_a_regression <- function(id, ...) {
|
|
| 146 | ! |
- if (!all(vapply(col_facet, function(x) !x$select$multiple, logical(1)))) {
+ ns <- NS(id) |
|
| 147 | ! |
- stop("'col_facet' should not allow multiple selection")
+ args <- list(...) |
|
| 148 | -+ | ! |
- }+ is_single_dataset_value <- teal.transform::is_single_dataset(args$regressor, args$response) |
| 149 | -! | +
- checkmate::assert_list(color, types = "data_extract_spec", null.ok = TRUE)+ |
|
| 150 | ! |
- if (!all(vapply(color, function(x) !x$select$multiple, logical(1)))) {
+ teal.widgets::standard_layout( |
|
| 151 | ! |
- stop("'color' should not allow multiple selection")
+ output = teal.widgets::white_small_well(tags$div( |
|
| 152 | -+ | ! |
- }+ teal.widgets::plot_with_settings_ui(id = ns("myplot")),
|
| 153 | ! |
- checkmate::assert_list(fill, types = "data_extract_spec", null.ok = TRUE)+ tags$div(verbatimTextOutput(ns("text")))
|
|
| 154 | -! | +
- if (!all(vapply(fill, function(x) !x$select$multiple, logical(1)))) {
+ )), |
|
| 155 | ! |
- stop("'fill' should not allow multiple selection")
+ encoding = div( |
|
| 156 |
- }+ ### Reporter |
||
| 157 | ! |
- checkmate::assert_list(size, types = "data_extract_spec", null.ok = TRUE)+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 158 | -! | +
- if (!all(vapply(size, function(x) !x$select$multiple, logical(1)))) {
+ ### |
|
| 159 | ! |
- stop("'size' should not allow multiple selection")
+ tags$label("Encodings", class = "text-primary"),
|
|
| 160 | -+ | ! |
- }+ teal.transform::datanames_input(args[c("response", "regressor")]),
|
| 161 | -+ | ! |
-
+ teal.transform::data_extract_ui( |
| 162 | ! |
- ggtheme <- match.arg(ggtheme)+ id = ns("response"),
|
|
| 163 | ! |
- checkmate::assert_string(label)+ label = "Response variable", |
|
| 164 | ! |
- checkmate::assert_flag(use_density)+ data_extract_spec = args$response, |
|
| 165 | ! |
- checkmate::assert_flag(color_settings)+ is_single_dataset = is_single_dataset_value |
|
| 166 | -! | +
- checkmate::assert_flag(free_x_scales)+ ), |
|
| 167 | ! |
- checkmate::assert_flag(free_y_scales)+ teal.transform::data_extract_ui( |
|
| 168 | ! |
- checkmate::assert_flag(rotate_xaxis_labels)+ id = ns("regressor"),
|
|
| 169 | ! |
- checkmate::assert_flag(swap_axes)+ label = "Regressor variables", |
|
| 170 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ data_extract_spec = args$regressor, |
|
| 171 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ is_single_dataset = is_single_dataset_value |
|
| 172 | -! | +
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ ), |
|
| 173 | ! |
- checkmate::assert_numeric(+ radioButtons( |
|
| 174 | ! |
- plot_width[1],+ ns("plot_type"),
|
|
| 175 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ label = "Plot type:", |
|
| 176 | -+ | ! |
- )+ choices = args$plot_choices, |
| 177 | ! |
- checkmate::assert_class(ggplot2_args, "ggplot2_args")+ selected = args$plot_choices[args$default_plot_type] |
|
| 178 |
-
+ ), |
||
| 179 | ! |
- if (color_settings) {
+ checkboxInput(ns("show_outlier"), label = "Display outlier labels", value = TRUE),
|
|
| 180 | ! |
- if (is.null(color)) {
+ conditionalPanel( |
|
| 181 | ! |
- color <- x+ condition = "input['show_outlier']", |
|
| 182 | ! |
- color[[1]]$select <- teal.transform::select_spec(choices = color[[1]]$select$choices, selected = NULL)+ ns = ns, |
|
| 183 | -+ | ! |
- }+ teal.widgets::optionalSliderInput( |
| 184 | ! |
- if (is.null(fill)) {
+ ns("outlier"),
|
|
| 185 | ! |
- fill <- x+ div( |
|
| 186 | ! |
- fill[[1]]$select <- teal.transform::select_spec(choices = fill[[1]]$select$choices, selected = NULL)+ class = "teal-tooltip", |
|
| 187 | -+ | ! |
- }+ tagList( |
| 188 | ! |
- if (is.null(size)) {
+ "Outlier definition:", |
|
| 189 | ! |
- size <- x+ icon("circle-info"),
|
|
| 190 | ! |
- size[[1]]$select <- teal.transform::select_spec(choices = size[[1]]$select$choices, selected = NULL)+ span( |
|
| 191 | -+ | ! |
- }+ class = "tooltiptext", |
| 192 | -+ | ! |
- } else {
+ paste( |
| 193 | ! |
- if (!is.null(c(color, fill, size))) {
+ "Use the slider to choose the cut-off value to define outliers.", |
|
| 194 | ! |
- stop("'color_settings' argument needs to be set to TRUE if 'color', 'fill', and/or 'size' is/are supplied.")
+ "Points with a Cook's distance greater than", |
|
| 195 | -+ | ! |
- }+ "the value on the slider times the mean of the Cook's distance of the dataset will have labels." |
| 196 |
- }+ ) |
||
| 197 |
-
+ ) |
||
| 198 | -! | +
- args <- as.list(environment())+ ) |
|
| 199 |
-
+ ), |
||
| 200 | ! |
- data_extract_list <- list(+ min = 1, max = 10, value = 9, ticks = FALSE, step = .1 |
|
| 201 | -! | +
- x = x,+ ), |
|
| 202 | ! |
- y = y,+ teal.widgets::optionalSelectInput( |
|
| 203 | ! |
- row_facet = row_facet,+ ns("label_var"),
|
|
| 204 | ! |
- col_facet = col_facet,+ multiple = FALSE, |
|
| 205 | ! |
- color_settings = color_settings,+ label = "Outlier label" |
|
| 206 | -! | +
- color = color,+ ) |
|
| 207 | -! | +
- fill = fill,+ ), |
|
| 208 | ! |
- size = size+ teal.widgets::panel_group( |
|
| 209 | -+ | ! |
- )+ teal.widgets::panel_item( |
| 210 | -+ | ! |
-
+ title = "Plot settings", |
| 211 | ! |
- module(+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
|
|
| 212 | ! |
- label = label,+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE),
|
|
| 213 | ! |
- server = srv_g_bivariate,+ selectInput( |
|
| 214 | ! |
- ui = ui_g_bivariate,+ inputId = ns("ggtheme"),
|
|
| 215 | ! |
- ui_args = args,+ label = "Theme (by ggplot):", |
|
| 216 | ! |
- server_args = c(+ choices = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
|
|
| 217 | ! |
- data_extract_list,+ selected = args$ggtheme, |
|
| 218 | ! |
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)+ multiple = FALSE |
|
| 219 |
- ),+ ) |
||
| 220 | -! | +
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ ) |
|
| 221 |
- )+ ) |
||
| 222 |
- }+ ), |
||
| 223 | -+ | ! |
-
+ forms = tagList( |
| 224 | -+ | ! |
- ui_g_bivariate <- function(id, ...) {
+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
|
| 225 | ! |
- args <- list(...)+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 226 | -! | +
- is_single_dataset_value <- teal.transform::is_single_dataset(+ ), |
|
| 227 | ! |
- args$x, args$y, args$row_facet, args$col_facet, args$color, args$fill, args$size+ pre_output = args$pre_output, |
|
| 228 | -+ | ! |
- )+ post_output = args$post_output |
| 229 |
-
+ ) |
||
| 230 | -! | +
- ns <- NS(id)+ } |
|
| 231 | -! | +
- teal.widgets::standard_layout(+ |
|
| 232 | -! | +
- output = teal.widgets::white_small_well(+ |
|
| 233 | -! | +
- tags$div(teal.widgets::plot_with_settings_ui(id = ns("myplot")))
+ srv_a_regression <- function(id, |
|
| 234 |
- ),+ data, |
||
| 235 | -! | +
- encoding = div(+ reporter, |
|
| 236 |
- ### Reporter+ filter_panel_api, |
||
| 237 | -! | +
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ response, |
|
| 238 |
- ###+ regressor, |
||
| 239 | -! | +
- tags$label("Encodings", class = "text-primary"),
+ plot_height, |
|
| 240 | -! | +
- teal.transform::datanames_input(args[c("x", "y", "row_facet", "col_facet", "color", "fill", "size")]),
+ plot_width, |
|
| 241 | -! | +
- teal.transform::data_extract_ui(+ ggplot2_args, |
|
| 242 | -! | +
- id = ns("x"),
+ default_outlier_label) {
|
|
| 243 | ! |
- label = "X variable",+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 244 | ! |
- data_extract_spec = args$x,+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 245 | ! |
- is_single_dataset = is_single_dataset_value+ checkmate::assert_class(data, "tdata") |
|
| 246 | -+ | ! |
- ),+ moduleServer(id, function(input, output, session) {
|
| 247 | ! |
- teal.transform::data_extract_ui(+ rule_rvr1 <- function(value) {
|
|
| 248 | ! |
- id = ns("y"),
+ if (isTRUE(input$plot_type == "Response vs Regressor")) {
|
|
| 249 | ! |
- label = "Y variable",+ if (length(value) > 1L) {
|
|
| 250 | ! |
- data_extract_spec = args$y,+ "This plot can only have one regressor." |
|
| 251 | -! | +
- is_single_dataset = is_single_dataset_value+ } |
|
| 252 |
- ),+ } |
||
| 253 | -! | +
- conditionalPanel(+ } |
|
| 254 | ! |
- condition =+ rule_rvr2 <- function(other) {
|
|
| 255 | ! |
- "$(\"button[data-id*='-x-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ||+ function(value) {
|
|
| 256 | ! |
- $(\"button[data-id*='-y-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ",+ if (isTRUE(input$plot_type == "Response vs Regressor")) {
|
|
| 257 | ! |
- shinyWidgets::radioGroupButtons(+ otherval <- selector_list()[[other]]()$select |
|
| 258 | ! |
- inputId = ns("use_density"),
+ if (isTRUE(value == otherval)) {
|
|
| 259 | ! |
- label = NULL,+ "Response and Regressor must be different." |
|
| 260 | -! | +
- choices = c("frequency", "density"),
+ } |
|
| 261 | -! | +
- selected = ifelse(args$use_density, "density", "frequency"),+ } |
|
| 262 | -! | +
- justified = TRUE+ } |
|
| 263 |
- )+ } |
||
| 264 |
- ),+ |
||
| 265 | ! |
- if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
+ selector_list <- teal.transform::data_extract_multiple_srv( |
|
| 266 | ! |
- div(+ data_extract = list(response = response, regressor = regressor), |
|
| 267 | ! |
- class = "data-extract-box",+ datasets = data, |
|
| 268 | ! |
- tags$label("Facetting"),
+ select_validation_rule = list( |
|
| 269 | ! |
- shinyWidgets::switchInput(inputId = ns("facetting"), value = args$facet, size = "mini"),
+ regressor = shinyvalidate::compose_rules( |
|
| 270 | ! |
- conditionalPanel(+ shinyvalidate::sv_required("At least one regressor should be selected."),
|
|
| 271 | ! |
- condition = paste0("input['", ns("facetting"), "']"),
+ rule_rvr1, |
|
| 272 | ! |
- div(+ rule_rvr2("response")
|
|
| 273 | -! | +
- if (!is.null(args$row_facet)) {
+ ), |
|
| 274 | ! |
- teal.transform::data_extract_ui(+ response = shinyvalidate::compose_rules( |
|
| 275 | ! |
- id = ns("row_facet"),
+ shinyvalidate::sv_required("At least one response should be selected."),
|
|
| 276 | ! |
- label = "Row facetting variable",+ rule_rvr2("regressor")
|
|
| 277 | -! | +
- data_extract_spec = args$row_facet,+ ) |
|
| 278 | -! | +
- is_single_dataset = is_single_dataset_value+ ) |
|
| 279 |
- )+ ) |
||
| 280 |
- },+ |
||
| 281 | ! |
- if (!is.null(args$col_facet)) {
+ iv_r <- reactive({
|
|
| 282 | ! |
- teal.transform::data_extract_ui(+ iv <- shinyvalidate::InputValidator$new() |
|
| 283 | ! |
- id = ns("col_facet"),
+ teal.transform::compose_and_enable_validators(iv, selector_list) |
|
| 284 | -! | +
- label = "Column facetting variable",+ }) |
|
| 285 | -! | +
- data_extract_spec = args$col_facet,+ |
|
| 286 | ! |
- is_single_dataset = is_single_dataset_value+ iv_out <- shinyvalidate::InputValidator$new() |
|
| 287 | -+ | ! |
- )+ iv_out$condition(~ isTRUE(input$show_outlier)) |
| 288 | -+ | ! |
- },+ iv_out$add_rule("label_var", shinyvalidate::sv_required("Please provide an `Outlier label` variable"))
|
| 289 | ! |
- checkboxInput(ns("free_x_scales"), "free x scales", value = args$free_x_scales),
+ iv_out$enable() |
|
| 290 | -! | +
- checkboxInput(ns("free_y_scales"), "free y scales", value = args$free_y_scales)
+
|
|
| 291 | -+ | ! |
- )+ anl_merged_input <- teal.transform::merge_expression_srv( |
| 292 | -+ | ! |
- )+ selector_list = selector_list, |
| 293 | -+ | ! |
- )+ datasets = data, |
| 294 | -+ | ! |
- },+ join_keys = get_join_keys(data) |
| 295 | -! | +
- if (args$color_settings) {
+ ) |
|
| 296 |
- # Put a grey border around the coloring settings+ |
||
| 297 | ! |
- div(+ regression_var <- reactive({
|
|
| 298 | ! |
- class = "data-extract-box",+ teal::validate_inputs(iv_r()) |
|
| 299 | -! | +
- tags$label("Color settings"),
+
|
|
| 300 | ! |
- shinyWidgets::switchInput(inputId = ns("coloring"), value = TRUE, size = "mini"),
+ list( |
|
| 301 | ! |
- conditionalPanel(+ response = as.vector(anl_merged_input()$columns_source$response), |
|
| 302 | ! |
- condition = paste0("input['", ns("coloring"), "']"),
+ regressor = as.vector(anl_merged_input()$columns_source$regressor) |
|
| 303 | -! | +
- div(+ ) |
|
| 304 | -! | +
- teal.transform::data_extract_ui(+ }) |
|
| 305 | -! | +
- id = ns("color"),
+
|
|
| 306 | ! |
- label = "Outline color by variable",+ anl_merged_q <- reactive({
|
|
| 307 | ! |
- data_extract_spec = args$color,+ req(anl_merged_input()) |
|
| 308 | ! |
- is_single_dataset = is_single_dataset_value+ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% |
|
| 309 | -+ | ! |
- ),+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
| 310 | -! | +
- teal.transform::data_extract_ui(+ }) |
|
| 311 | -! | +
- id = ns("fill"),
+
|
|
| 312 | -! | +
- label = "Fill color by variable",+ # sets qenv object and populates it with data merge call and fit expression |
|
| 313 | ! |
- data_extract_spec = args$fill,+ fit_r <- reactive({
|
|
| 314 | ! |
- is_single_dataset = is_single_dataset_value+ ANL <- anl_merged_q()[["ANL"]] # nolint |
|
| 315 | -+ | ! |
- ),+ teal::validate_has_data(ANL, 10) |
| 316 | -! | +
- div(+ |
|
| 317 | ! |
- id = ns("size_settings"),
+ validate(need(is.numeric(ANL[regression_var()$response][[1]]), "Response variable should be numeric.")) |
|
| 318 | -! | +
- teal.transform::data_extract_ui(+ |
|
| 319 | ! |
- id = ns("size"),
+ teal::validate_has_data( |
|
| 320 | ! |
- label = "Size of points by variable (only if x and y are numeric)",+ ANL[, c(regression_var()$response, regression_var()$regressor)], 10, |
|
| 321 | ! |
- data_extract_spec = args$size,+ complete = TRUE, allow_inf = FALSE |
|
| 322 | -! | +
- is_single_dataset = is_single_dataset_value+ ) |
|
| 323 |
- )+ |
||
| 324 | -+ | ! |
- )+ form <- stats::as.formula( |
| 325 | -+ | ! |
- )+ paste( |
| 326 | -+ | ! |
- )+ regression_var()$response, |
| 327 | -+ | ! |
- )+ paste( |
| 328 | -+ | ! |
- },+ regression_var()$regressor, |
| 329 | ! |
- teal.widgets::panel_group(+ collapse = " + " |
|
| 330 | -! | +
- teal.widgets::panel_item(+ ), |
|
| 331 | ! |
- title = "Plot settings",+ sep = " ~ " |
|
| 332 | -! | +
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
+ ) |
|
| 333 | -! | +
- checkboxInput(ns("swap_axes"), "Swap axes", value = args$swap_axes),
+ ) |
|
| 334 | -! | +
- selectInput(+ |
|
| 335 | ! |
- inputId = ns("ggtheme"),
+ if (input$show_outlier) {
|
|
| 336 | ! |
- label = "Theme (by ggplot):",+ opts <- teal.transform::variable_choices(ANL) |
|
| 337 | ! |
- choices = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
+ selected <- if (!is.null(isolate(input$label_var)) && isolate(input$label_var) %in% as.character(opts)) {
|
|
| 338 | ! |
- selected = args$ggtheme,+ isolate(input$label_var) |
|
| 339 | -! | +
- multiple = FALSE+ } else {
|
|
| 340 | -+ | ! |
- ),+ if (length(opts[as.character(opts) == default_outlier_label]) == 0) {
|
| 341 | ! |
- sliderInput(+ opts[[1]] |
|
| 342 | -! | +
- ns("alpha"), "Opacity Scatterplot:",
+ } else {
|
|
| 343 | ! |
- min = 0, max = 1,+ opts[as.character(opts) == default_outlier_label] |
|
| 344 | -! | +
- step = .05, value = .5, ticks = FALSE+ } |
|
| 345 |
- ),+ } |
||
| 346 | ! |
- sliderInput(+ teal.widgets::updateOptionalSelectInput( |
|
| 347 | ! |
- ns("fixed_size"), "Scatterplot point size:",
+ session = session, |
|
| 348 | ! |
- min = 1, max = 8,+ inputId = "label_var", |
|
| 349 | ! |
- step = 1, value = 2, ticks = FALSE+ choices = opts, |
|
| 350 | -+ | ! |
- ),+ selected = selected |
| 351 | -! | +
- checkboxInput(ns("add_lines"), "Add lines"),
+ ) |
|
| 352 |
- )+ |
||
| 353 | -+ | ! |
- )+ data <- fortify(stats::lm(form, data = ANL)) |
| 354 | -+ | ! |
- ),+ cooksd <- data$.cooksd[!is.nan(data$.cooksd)] |
| 355 | ! |
- forms = tagList(+ max_outlier <- max(ceiling(max(cooksd) / mean(cooksd)), 2) |
|
| 356 | ! |
- teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"),
+ cur_outlier <- isolate(input$outlier) |
|
| 357 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ updateSliderInput( |
|
| 358 | -+ | ! |
- ),+ session = session, |
| 359 | ! |
- pre_output = args$pre_output,+ inputId = "outlier", |
|
| 360 | ! |
- post_output = args$post_output+ min = 1, |
|
| 361 | -+ | ! |
- )+ max = max_outlier, |
| 362 | -+ | ! |
- }+ value = if (cur_outlier < max_outlier) cur_outlier else max_outlier * .9 |
| 363 |
-
+ ) |
||
| 364 |
-
+ } |
||
| 365 |
- srv_g_bivariate <- function(id,+ |
||
| 366 | -+ | ! |
- data,+ anl_merged_q() %>% |
| 367 | -+ | ! |
- reporter,+ teal.code::eval_code(substitute(fit <- stats::lm(form, data = ANL), env = list(form = form))) %>% |
| 368 | -+ | ! |
- filter_panel_api,+ teal.code::eval_code(quote({
|
| 369 | -+ | ! |
- x,+ for (regressor in names(fit$contrasts)) {
|
| 370 | -+ | ! |
- y,+ alts <- paste0(levels(ANL[[regressor]]), collapse = "|") |
| 371 | -+ | ! |
- row_facet,+ names(fit$coefficients) <- gsub( |
| 372 | -+ | ! |
- col_facet,+ paste0("^(", regressor, ")(", alts, ")$"), paste0("\\1", ": ", "\\2"), names(fit$coefficients)
|
| 373 |
- color_settings = FALSE,+ ) |
||
| 374 |
- color,+ } |
||
| 375 |
- fill,+ })) %>% |
||
| 376 | -+ | ! |
- size,+ teal.code::eval_code(quote(summary(fit))) |
| 377 |
- plot_height,+ }) |
||
| 378 |
- plot_width,+ |
||
| 379 | -+ | ! |
- ggplot2_args) {
+ label_col <- reactive({
|
| 380 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ teal::validate_inputs(iv_out) |
|
| 381 | -! | +
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ |
|
| 382 | ! |
- checkmate::assert_class(data, "tdata")+ substitute( |
|
| 383 | ! |
- moduleServer(id, function(input, output, session) {
+ expr = dplyr::if_else( |
|
| 384 | ! |
- data_extract <- list(+ data$.cooksd > outliers * mean(data$.cooksd, na.rm = TRUE), |
|
| 385 | ! |
- x = x, y = y, row_facet = row_facet, col_facet = col_facet,+ as.character(stats::na.omit(ANL)[[label_var]]), |
|
| 386 | -! | +
- color = color, fill = fill, size = size+ "" |
|
| 387 |
- )+ ) %>% |
||
| 388 | -+ | ! |
-
+ dplyr::if_else(is.na(.), "cooksd == NaN", .), |
| 389 | ! |
- rule_var <- function(other) {
+ env = list(outliers = input$outlier, label_var = input$label_var) |
|
| 390 | -! | +
- function(value) {
+ ) |
|
| 391 | -! | +
- othervalue <- selector_list()[[other]]()$select+ }) |
|
| 392 | -! | +
- if (length(value) == 0L && length(othervalue) == 0L) {
+
|
|
| 393 | ! |
- "Please select at least one of x-variable or y-variable"+ outlier_label <- reactive({
|
|
| 394 | -+ | ! |
- }+ substitute( |
| 395 | -+ | ! |
- }+ expr = geom_text(label = label_col, hjust = 0, vjust = 1, color = "red"), |
| 396 | -+ | ! |
- }+ env = list(label_col = label_col()) |
| 397 | -! | +
- rule_diff <- function(other) {
+ ) |
|
| 398 | -! | +
- function(value) {
+ }) |
|
| 399 | -! | +
- othervalue <- selector_list()[[other]]()[["select"]]+ |
|
| 400 | ! |
- if (!is.null(othervalue)) {
+ output_q <- reactive({
|
|
| 401 | ! |
- if (identical(value, othervalue)) {
+ alpha <- input$alpha # nolint |
|
| 402 | ! |
- "Row and column facetting variables must be different."+ size <- input$size # nolint |
|
| 403 | -+ | ! |
- }+ ggtheme <- input$ggtheme # nolint |
| 404 | -+ | ! |
- }+ input_type <- input$plot_type |
| 405 | -+ | ! |
- }+ show_outlier <- input$show_outlier |
| 406 |
- }+ |
||
| 407 | -+ | ! |
-
+ teal::validate_inputs(iv_r()) |
| 408 | -! | +
- selector_list <- teal.transform::data_extract_multiple_srv(+ |
|
| 409 | ! |
- data_extract = data_extract,+ plot_type_0 <- function() {
|
|
| 410 | ! |
- datasets = data,+ fit <- fit_r()[["fit"]] |
|
| 411 | ! |
- select_validation_rule = list(+ ANL <- anl_merged_q()[["ANL"]] # nolint |
|
| 412 | -! | +
- x = rule_var("y"),
+
|
|
| 413 | ! |
- y = rule_var("x"),
+ stopifnot(ncol(fit$model) == 2) |
|
| 414 | -! | +
- row_facet = shinyvalidate::compose_rules(+ |
|
| 415 | ! |
- shinyvalidate::sv_optional(),+ if (!is.factor(ANL[[regression_var()$regressor]])) {
|
|
| 416 | ! |
- rule_diff("col_facet")
+ shinyjs::show("size")
|
|
| 417 | -+ | ! |
- ),+ shinyjs::show("alpha")
|
| 418 | ! |
- col_facet = shinyvalidate::compose_rules(+ plot <- substitute( |
|
| 419 | ! |
- shinyvalidate::sv_optional(),+ env = list( |
|
| 420 | ! |
- rule_diff("row_facet")
+ regressor = regression_var()$regressor, |
|
| 421 | -+ | ! |
- )+ response = regression_var()$response, |
| 422 | -+ | ! |
- )+ size = size, |
| 423 | -+ | ! |
- )+ alpha = alpha |
| 424 |
-
+ ), |
||
| 425 | ! |
- iv_r <- reactive({
+ expr = ggplot( |
|
| 426 | ! |
- iv_facet <- shinyvalidate::InputValidator$new()+ fit$model[, 2:1], |
|
| 427 | ! |
- iv_child <- teal.transform::compose_and_enable_validators(iv_facet, selector_list,+ aes_string(regressor, response) |
|
| 428 | -! | +
- validator_names = c("row_facet", "col_facet")
+ ) + |
|
| 429 | -+ | ! |
- )+ geom_point(size = size, alpha = alpha) + |
| 430 | ! |
- iv_child$condition(~ isTRUE(input$facetting))+ stat_smooth( |
|
| 431 | -+ | ! |
-
+ method = "lm", |
| 432 | ! |
- iv <- shinyvalidate::InputValidator$new()+ formula = y ~ x, |
|
| 433 | ! |
- iv$add_validator(iv_child)+ se = FALSE |
|
| 434 | -! | +
- teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = c("x", "y"))
+ ) |
|
| 435 |
- })+ ) |
||
| 436 | -+ | ! |
-
+ if (show_outlier) {
|
| 437 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ plot <- substitute( |
|
| 438 | ! |
- selector_list = selector_list,+ expr = plot + outlier_label, |
|
| 439 | ! |
- datasets = data,+ env = list(plot = plot, outlier_label = outlier_label()) |
|
| 440 | -! | +
- join_keys = get_join_keys(data)+ ) |
|
| 441 |
- )+ } |
||
| 442 |
-
+ } else {
|
||
| 443 | ! |
- anl_merged_q <- reactive({
+ shinyjs::hide("size")
|
|
| 444 | ! |
- req(anl_merged_input())+ shinyjs::hide("alpha")
|
|
| 445 | ! |
- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>%+ plot <- substitute( |
|
| 446 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ expr = ggplot(fit$model[, 2:1], aes_string(regressor, response)) + |
|
| 447 | -+ | ! |
- })+ geom_boxplot(), |
| 448 | -+ | ! |
-
+ env = list(regressor = regression_var()$regressor, response = regression_var()$response) |
| 449 | -! | +
- merged <- list(+ ) |
|
| 450 | ! |
- anl_input_r = anl_merged_input,+ if (show_outlier) {
|
|
| 451 | ! |
- anl_q_r = anl_merged_q+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) |
|
| 452 |
- )+ } |
||
| 453 |
-
+ } |
||
| 454 | -! | +
- output_q <- reactive({
+
|
|
| 455 | ! |
- teal::validate_inputs(iv_r())+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 456 | -+ | ! |
-
+ teal.widgets::resolve_ggplot2_args( |
| 457 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint+ user_plot = ggplot2_args[["Response vs Regressor"]], |
|
| 458 | ! |
- teal::validate_has_data(ANL, 3)+ user_default = ggplot2_args$default, |
|
| 459 | -+ | ! |
-
+ module_plot = teal.widgets::ggplot2_args( |
| 460 | ! |
- x_col_vec <- as.vector(merged$anl_input_r()$columns_source$x)+ labs = list( |
|
| 461 | ! |
- x_name <- `if`(is.null(x_col_vec), character(0), x_col_vec)+ title = "Response vs Regressor", |
|
| 462 | ! |
- y_col_vec <- as.vector(merged$anl_input_r()$columns_source$y)+ x = varname_w_label(regression_var()$regressor, ANL), |
|
| 463 | ! |
- y_name <- `if`(is.null(y_col_vec), character(0), y_col_vec)+ y = varname_w_label(regression_var()$response, ANL) |
|
| 464 |
-
+ ), |
||
| 465 | ! |
- row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet)+ theme = list() |
|
| 466 | -! | +
- col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet)+ ) |
|
| 467 | -! | +
- color_name <- if ("color" %in% names(merged$anl_input_r()$columns_source)) {
+ ), |
|
| 468 | ! |
- as.vector(merged$anl_input_r()$columns_source$color)+ ggtheme = ggtheme |
|
| 469 |
- } else {
+ ) |
||
| 470 | -! | +
- character(0)+ |
|
| 471 | -+ | ! |
- }+ teal.code::eval_code( |
| 472 | ! |
- fill_name <- if ("fill" %in% names(merged$anl_input_r()$columns_source)) {
+ fit_r(), |
|
| 473 | ! |
- as.vector(merged$anl_input_r()$columns_source$fill)+ substitute( |
|
| 474 | -+ | ! |
- } else {
+ expr = {
|
| 475 | ! |
- character(0)+ class(fit$residuals) <- NULL |
|
| 476 | -+ | ! |
- }+ data <- fortify(fit) |
| 477 | ! |
- size_name <- if ("size" %in% names(merged$anl_input_r()$columns_source)) {
+ g <- plot |
|
| 478 | ! |
- as.vector(merged$anl_input_r()$columns_source$size)+ print(g) |
|
| 479 |
- } else {
+ }, |
||
| 480 | ! |
- character(0)+ env = list( |
|
| 481 | -+ | ! |
- }+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
| 482 |
-
+ ) |
||
| 483 | -! | +
- use_density <- input$use_density == "density"+ ) |
|
| 484 | -! | +
- free_x_scales <- input$free_x_scales+ ) |
|
| 485 | -! | +
- free_y_scales <- input$free_y_scales+ } |
|
| 486 | -! | +
- ggtheme <- input$ggtheme+ |
|
| 487 | ! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ plot_base <- function() {
|
|
| 488 | ! |
- swap_axes <- input$swap_axes+ base_fit <- fit_r() |
|
| 489 | -+ | ! |
-
+ teal.code::eval_code( |
| 490 | ! |
- is_scatterplot <- all(vapply(ANL[c(x_name, y_name)], is.numeric, logical(1))) &&+ base_fit, |
|
| 491 | ! |
- length(x_name) > 0 && length(y_name) > 0+ quote({
|
|
| 492 | -+ | ! |
-
+ class(fit$residuals) <- NULL |
| 493 | -! | +
- if (is_scatterplot) {
+
|
|
| 494 | ! |
- shinyjs::show("alpha")
+ data <- ggplot2::fortify(fit) |
|
| 495 | -! | +
- alpha <- input$alpha # nolint+ |
|
| 496 | ! |
- shinyjs::show("add_lines")
+ smooth <- function(x, y) {
|
|
| 497 | -+ | ! |
-
+ as.data.frame(stats::lowess(x, y, f = 2 / 3, iter = 3)) |
| 498 | -! | +
- if (color_settings && input$coloring) {
+ } |
|
| 499 | -! | +
- shinyjs::hide("fixed_size")
+
|
|
| 500 | ! |
- shinyjs::show("size_settings")
+ smoothy_aes <- ggplot2::aes_string(x = "x", y = "y") |
|
| 501 | -! | +
- size <- NULL+ |
|
| 502 | -+ | ! |
- } else {
+ reg_form <- deparse(fit$call[[2]]) |
| 503 | -! | +
- shinyjs::show("fixed_size")
+ }) |
|
| 504 | -! | +
- size <- input$fixed_size+ ) |
|
| 505 |
- }+ } |
||
| 506 |
- } else {
+
|
||
| 507 | ! |
- shinyjs::hide("add_lines")
+ plot_type_1 <- function(plot_base) {
|
|
| 508 | ! |
- updateCheckboxInput(session, "add_lines", value = FALSE)+ shinyjs::show("size")
|
|
| 509 | ! |
- shinyjs::hide("alpha")
+ shinyjs::show("alpha")
|
|
| 510 | ! |
- shinyjs::hide("fixed_size")
+ plot <- substitute( |
|
| 511 | ! |
- shinyjs::hide("size_settings")
+ expr = ggplot(data = data, aes(.fitted, .resid)) + |
|
| 512 | ! |
- alpha <- 1+ geom_point(size = size, alpha = alpha) + |
|
| 513 | ! |
- size <- NULL+ geom_hline(yintercept = 0, linetype = "dashed", size = 1) + |
|
| 514 | -+ | ! |
- }+ geom_line(data = smoothy, mapping = smoothy_aes), |
| 515 | -+ | ! |
-
+ env = list(size = size, alpha = alpha) |
| 516 |
-
+ ) |
||
| 517 | ! |
- teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE)+ if (show_outlier) {
|
|
| 518 | -+ | ! |
-
+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) |
| 519 | -! | +
- cl <- bivariate_plot_call(+ } |
|
| 520 | -! | +
- data_name = "ANL",+ |
|
| 521 | ! |
- x = x_name,+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 522 | ! |
- y = y_name,+ teal.widgets::resolve_ggplot2_args( |
|
| 523 | ! |
- x_class = ifelse(!identical(x_name, character(0)), class(ANL[[x_name]]), "NULL"),+ user_plot = ggplot2_args[["Residuals vs Fitted"]], |
|
| 524 | ! |
- y_class = ifelse(!identical(y_name, character(0)), class(ANL[[y_name]]), "NULL"),+ user_default = ggplot2_args$default, |
|
| 525 | ! |
- x_label = varname_w_label(x_name, ANL),+ module_plot = teal.widgets::ggplot2_args( |
|
| 526 | ! |
- y_label = varname_w_label(y_name, ANL),+ labs = list( |
|
| 527 | ! |
- freq = !use_density,+ x = quote(paste0("Fitted values\nlm(", reg_form, ")")),
|
|
| 528 | ! |
- theme = ggtheme,+ y = "Residuals", |
|
| 529 | ! |
- rotate_xaxis_labels = rotate_xaxis_labels,+ title = "Residuals vs Fitted" |
|
| 530 | -! | +
- swap_axes = swap_axes,+ ) |
|
| 531 | -! | +
- alpha = alpha,+ ) |
|
| 532 | -! | +
- size = size,+ ), |
|
| 533 | ! |
- ggplot2_args = ggplot2_args+ ggtheme = ggtheme |
|
| 534 |
- )+ ) |
||
| 536 | ! |
- facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name)))+ teal.code::eval_code( |
|
| 537 | -+ | ! |
-
+ plot_base, |
| 538 | ! |
- if (facetting) {
+ substitute( |
|
| 539 | ! |
- facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name, free_x_scales, free_y_scales)+ expr = {
|
|
| 540 | -+ | ! |
-
+ smoothy <- smooth(data$.fitted, data$.resid) |
| 541 | ! |
- if (!is.null(facet_cl)) {
+ g <- plot |
|
| 542 | ! |
- cl <- call("+", cl, facet_cl)
+ print(g) |
|
| 543 |
- }+ }, |
||
| 544 | -+ | ! |
- }+ env = list( |
| 545 | -+ | ! |
-
+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
| 546 | -! | +
- if (input$add_lines) {
+ ) |
|
| 547 | -! | +
- cl <- call("+", cl, quote(geom_line(size = 1)))
+ ) |
|
| 548 |
- }+ ) |
||
| 549 |
-
+ } |
||
| 550 | -! | +
- coloring_cl <- NULL+ |
|
| 551 | ! |
- if (color_settings) {
+ plot_type_2 <- function(plot_base) {
|
|
| 552 | ! |
- if (input$coloring) {
+ shinyjs::show("size")
|
|
| 553 | ! |
- coloring_cl <- coloring_ggplot_call(+ shinyjs::show("alpha")
|
|
| 554 | ! |
- colour = color_name,+ plot <- substitute( |
|
| 555 | ! |
- fill = fill_name,+ expr = ggplot(data = data, aes(sample = .stdresid)) + |
|
| 556 | ! |
- size = size_name,+ stat_qq(size = size, alpha = alpha) + |
|
| 557 | ! |
- is_point = any(grepl("geom_point", cl %>% deparse()))
+ geom_abline(linetype = "dashed"), |
|
| 558 | -+ | ! |
- )+ env = list(size = size, alpha = alpha) |
| 559 | -! | +
- legend_lbls <- substitute(+ ) |
|
| 560 | ! |
- expr = labs(color = color_name, fill = fill_name, size = size_name),+ if (show_outlier) {
|
|
| 561 | ! |
- env = list(+ plot <- substitute( |
|
| 562 | ! |
- color_name = varname_w_label(color_name, ANL),+ expr = plot + |
|
| 563 | ! |
- fill_name = varname_w_label(fill_name, ANL),+ stat_qq( |
|
| 564 | ! |
- size_name = varname_w_label(size_name, ANL)+ geom = "text", |
|
| 565 | -+ | ! |
- )+ label = label_col %>% |
| 566 | -+ | ! |
- )+ data.frame(label = .) %>% |
| 567 | -+ | ! |
- }+ dplyr::filter(label != "cooksd == NaN") %>% |
| 568 | ! |
- if (!is.null(coloring_cl)) {
+ unlist(), |
|
| 569 | ! |
- cl <- call("+", call("+", cl, coloring_cl), legend_lbls)
+ hjust = 0, |
|
| 570 | -+ | ! |
- }+ vjust = 1, |
| 571 | -+ | ! |
- }+ color = "red" |
| 572 |
-
+ ), |
||
| 573 | -+ | ! |
- # Add labels to facets+ env = list(plot = plot, label_col = label_col()) |
| 574 | -! | +
- nulled_row_facet_name <- varname_w_label(row_facet_name, ANL)+ ) |
|
| 575 | -! | +
- nulled_col_facet_name <- varname_w_label(col_facet_name, ANL)+ } |
|
| 576 | -! | +
- without_facet <- (is.null(nulled_row_facet_name) && is.null(nulled_col_facet_name)) || !facetting+ |
|
| 577 | -+ | ! |
-
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 578 | ! |
- print_call <- if (without_facet) {
+ teal.widgets::resolve_ggplot2_args( |
|
| 579 | ! |
- quote(print(p))+ user_plot = ggplot2_args[["Normal Q-Q"]], |
|
| 580 | -+ | ! |
- } else {
+ user_default = ggplot2_args$default, |
| 581 | ! |
- substitute(+ module_plot = teal.widgets::ggplot2_args( |
|
| 582 | ! |
- expr = {
+ labs = list( |
|
| 583 | -+ | ! |
- # Add facetting labels+ x = quote(paste0("Theoretical Quantiles\nlm(", reg_form, ")")),
|
| 584 | -+ | ! |
- # optional: grid.newpage() #nolintr+ y = "Standardized residuals", |
| 585 | ! |
- p <- add_facet_labels(p, xfacet_label = nulled_col_facet_name, yfacet_label = nulled_row_facet_name)+ title = "Normal Q-Q" |
|
| 586 | -! | +
- grid::grid.newpage()+ ) |
|
| 587 | -! | +
- grid::grid.draw(p)+ ) |
|
| 588 |
- },+ ), |
||
| 589 | ! |
- env = list(nulled_col_facet_name = nulled_col_facet_name, nulled_row_facet_name = nulled_row_facet_name)+ ggtheme = ggtheme |
|
| 591 |
- }+ |
||
| 592 | -+ | ! |
-
+ teal.code::eval_code( |
| 593 | ! |
- teal.code::eval_code(merged$anl_q_r(), substitute(expr = p <- cl, env = list(cl = cl))) %>%+ plot_base, |
|
| 594 | ! |
- teal.code::eval_code(print_call)+ substitute( |
|
| 595 | -+ | ! |
- })+ expr = {
|
| 596 | -+ | ! |
-
+ g <- plot |
| 597 | ! |
- plot_r <- shiny::reactive({
+ print(g) |
|
| 598 | -! | +
- output_q()[["p"]]+ }, |
|
| 599 | -+ | ! |
- })+ env = list( |
| 600 | -+ | ! |
-
+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
| 601 | -! | +
- pws <- teal.widgets::plot_with_settings_srv(+ ) |
|
| 602 | -! | +
- id = "myplot",+ ) |
|
| 603 | -! | +
- plot_r = plot_r,+ ) |
|
| 604 | -! | +
- height = plot_height,+ } |
|
| 605 | -! | +
- width = plot_width+ |
|
| 606 | -+ | ! |
- )+ plot_type_3 <- function(plot_base) {
|
| 607 | -+ | ! |
-
+ shinyjs::show("size")
|
| 608 | ! |
- teal.widgets::verbatim_popup_srv(+ shinyjs::show("alpha")
|
|
| 609 | ! |
- id = "warning",+ plot <- substitute( |
|
| 610 | ! |
- verbatim_content = reactive(teal.code::get_warnings(output_q())),+ expr = ggplot(data = data, aes(.fitted, sqrt(abs(.stdresid)))) + |
|
| 611 | ! |
- title = "Warning",+ geom_point(size = size, alpha = alpha) + |
|
| 612 | ! |
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ geom_line(data = smoothy, mapping = smoothy_aes), |
|
| 613 | -+ | ! |
- )+ env = list(size = size, alpha = alpha) |
| 614 |
-
+ ) |
||
| 615 | ! |
- teal.widgets::verbatim_popup_srv(+ if (show_outlier) {
|
|
| 616 | ! |
- id = "rcode",+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) |
|
| 617 | -! | +
- verbatim_content = reactive(teal.code::get_code(output_q())),+ } |
|
| 618 | -! | +
- title = "Bivariate Plot"+ |
|
| 619 | -+ | ! |
- )+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 620 | -+ | ! |
-
+ teal.widgets::resolve_ggplot2_args( |
| 621 | -+ | ! |
- ### REPORTER+ user_plot = ggplot2_args[["Scale-Location"]], |
| 622 | ! |
- if (with_reporter) {
+ user_default = ggplot2_args$default, |
|
| 623 | ! |
- card_fun <- function(comment) {
+ module_plot = teal.widgets::ggplot2_args( |
|
| 624 | ! |
- card <- teal::TealReportCard$new()+ labs = list( |
|
| 625 | ! |
- card$set_name("Bivariate Plot")
+ x = quote(paste0("Fitted values\nlm(", reg_form, ")")),
|
|
| 626 | ! |
- card$append_text("Bivariate Plot", "header2")
+ y = quote(expression(sqrt(abs(`Standardized residuals`)))), |
|
| 627 | ! |
- if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ title = "Scale-Location" |
|
| 628 | -! | +
- card$append_text("Plot", "header3")
+ ) |
|
| 629 | -! | +
- card$append_plot(plot_r(), dim = pws$dim())+ ) |
|
| 630 | -! | +
- if (!comment == "") {
+ ), |
|
| 631 | ! |
- card$append_text("Comment", "header3")
+ ggtheme = ggtheme |
|
| 632 | -! | +
- card$append_text(comment)+ ) |
|
| 633 |
- }+ |
||
| 634 | ! |
- card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n"))+ teal.code::eval_code( |
|
| 635 | ! |
- card+ plot_base, |
|
| 636 | -+ | ! |
- }+ substitute( |
| 637 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ expr = {
|
|
| 638 | -+ | ! |
- }+ smoothy <- smooth(data$.fitted, sqrt(abs(data$.stdresid))) |
| 639 | -+ | ! |
- ###+ g <- plot |
| 640 | -+ | ! |
- })+ print(g) |
| 641 |
- }+ }, |
||
| 642 | -+ | ! |
-
+ env = list( |
| 643 | -+ | ! |
-
+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
| 644 |
- #' Get Substituted ggplot call+ ) |
||
| 645 |
- #'+ ) |
||
| 646 |
- #' @noRd+ ) |
||
| 647 |
- #'+ } |
||
| 648 |
- #' @examples+ |
||
| 649 | -+ | ! |
- #'+ plot_type_4 <- function(plot_base) {
|
| 650 | -+ | ! |
- #' bivariate_plot_call("ANL", "BAGE", "RACE", "numeric", "factor")
+ shinyjs::hide("size")
|
| 651 | -+ | ! |
- #' bivariate_plot_call("ANL", "BAGE", character(0), "numeric", "NULL")
+ shinyjs::show("alpha")
|
| 652 | -+ | ! |
- bivariate_plot_call <- function(data_name,+ plot <- substitute( |
| 653 | -+ | ! |
- x = character(0),+ expr = ggplot(data = data, aes(seq_along(.cooksd), .cooksd)) + |
| 654 | -+ | ! |
- y = character(0),+ geom_col(alpha = alpha), |
| 655 | -+ | ! |
- x_class = "NULL",+ env = list(alpha = alpha) |
| 656 |
- y_class = "NULL",+ ) |
||
| 657 | -+ | ! |
- x_label = NULL,+ if (show_outlier) {
|
| 658 | -+ | ! |
- y_label = NULL,+ plot <- substitute( |
| 659 | -+ | ! |
- freq = TRUE,+ expr = plot + |
| 660 | -+ | ! |
- theme = "gray",+ geom_hline( |
| 661 | -+ | ! |
- rotate_xaxis_labels = FALSE,+ yintercept = c( |
| 662 | -+ | ! |
- swap_axes = FALSE,+ outlier * mean(data$.cooksd, na.rm = TRUE), |
| 663 | -+ | ! |
- alpha = double(0),+ mean(data$.cooksd, na.rm = TRUE) |
| 664 |
- size = 2,+ ), |
||
| 665 | -+ | ! |
- ggplot2_args = teal.widgets::ggplot2_args()) {
+ color = "red", |
| 666 | ! |
- supported_types <- c("NULL", "numeric", "integer", "factor", "character", "logical")
+ linetype = "dashed" |
|
| 667 | -! | +
- validate(need(x_class %in% supported_types, paste0("Data type '", x_class, "' is not supported.")))
+ ) + |
|
| 668 | ! |
- validate(need(y_class %in% supported_types, paste0("Data type '", y_class, "' is not supported.")))
+ geom_text( |
|
| 669 | -+ | ! |
-
+ aes( |
| 670 | -+ | ! |
-
+ x = 0, |
| 671 | ! |
- if (identical(x, character(0))) {
+ y = mean(data$.cooksd, na.rm = TRUE), |
|
| 672 | ! |
- x <- x_label <- "-"+ label = paste("mu", "=", round(mean(data$.cooksd, na.rm = TRUE), 4)),
|
|
| 673 | -+ | ! |
- } else {
+ vjust = -1, |
| 674 | ! |
- x <- if (is.call(x)) x else as.name(x)+ hjust = 0, |
|
| 675 | -+ | ! |
- }+ color = "red", |
| 676 | ! |
- if (identical(y, character(0))) {
+ angle = 90 |
|
| 677 | -! | +
- y <- y_label <- "-"+ ), |
|
| 678 | -+ | ! |
- } else {
+ parse = TRUE, |
| 679 | ! |
- y <- if (is.call(y)) y else as.name(y)+ show.legend = FALSE |
|
| 680 |
- }+ ) + |
||
| 681 | -+ | ! |
-
+ outlier_label, |
| 682 | ! |
- cl <- bivariate_ggplot_call(+ env = list(plot = plot, outlier = input$outlier, outlier_label = outlier_label()) |
|
| 683 | -! | +
- x_class = x_class,+ ) |
|
| 684 | -! | +
- y_class = y_class,+ } |
|
| 685 | -! | +
- freq = freq,+ |
|
| 686 | ! |
- theme = theme,+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 687 | ! |
- rotate_xaxis_labels = rotate_xaxis_labels,+ teal.widgets::resolve_ggplot2_args( |
|
| 688 | ! |
- swap_axes = swap_axes,+ user_plot = ggplot2_args[["Cook's distance"]], |
|
| 689 | ! |
- alpha = alpha,+ user_default = ggplot2_args$default, |
|
| 690 | ! |
- size = size,+ module_plot = teal.widgets::ggplot2_args( |
|
| 691 | ! |
- ggplot2_args = ggplot2_args,+ labs = list( |
|
| 692 | ! |
- x = x,+ x = quote(paste0("Obs. number\nlm(", reg_form, ")")),
|
|
| 693 | ! |
- y = y,+ y = "Cook's distance", |
|
| 694 | ! |
- xlab = x_label,+ title = "Cook's distance" |
|
| 695 | -! | +
- ylab = y_label,+ ) |
|
| 696 | -! | +
- data_name = data_name+ ) |
|
| 697 |
- )+ ), |
||
| 698 | -+ | ! |
- }+ ggtheme = ggtheme |
| 699 |
-
+ ) |
||
| 700 |
- substitute_q <- function(x, env) {
+
|
||
| 701 | ! |
- stopifnot(is.language(x))+ teal.code::eval_code( |
|
| 702 | ! |
- call <- substitute(substitute(x, env), list(x = x))+ plot_base, |
|
| 703 | ! |
- eval(call)+ substitute( |
|
| 704 | -+ | ! |
- }+ expr = {
|
| 705 | -+ | ! |
-
+ g <- plot |
| 706 | -+ | ! |
-
+ print(g) |
| 707 |
- #' Create ggplot part of plot call+ }, |
||
| 708 | -+ | ! |
- #'+ env = list( |
| 709 | -+ | ! |
- #' Due to the type of the x and y variable the plot type is chosen+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
| 710 |
- #'+ ) |
||
| 711 |
- #' @noRd+ ) |
||
| 712 |
- #'+ ) |
||
| 713 |
- #' @examples+ } |
||
| 714 |
- #' bivariate_ggplot_call("numeric", "NULL")
+
|
||
| 715 |
- #' bivariate_ggplot_call("numeric", "NULL", freq = FALSE)
+
|
||
| 716 | -+ | ! |
- #'+ plot_type_5 <- function(plot_base) {
|
| 717 | -+ | ! |
- #' bivariate_ggplot_call("NULL", "numeric")
+ shinyjs::show("size")
|
| 718 | -+ | ! |
- #' bivariate_ggplot_call("NULL", "numeric", freq = FALSE)
+ shinyjs::show("alpha")
|
| 719 | -+ | ! |
- #'+ plot <- substitute( |
| 720 | -+ | ! |
- #' bivariate_ggplot_call("NULL", "factor")
+ expr = ggplot(data = data, aes(.hat, .stdresid)) + |
| 721 | -+ | ! |
- #' bivariate_ggplot_call("NULL", "factor", freq = FALSE)
+ geom_vline( |
| 722 | -+ | ! |
- #'+ size = 1, |
| 723 | -+ | ! |
- #' bivariate_ggplot_call("factor", "NULL")
+ colour = "black", |
| 724 | -+ | ! |
- #' bivariate_ggplot_call("factor", "NULL", freq = FALSE)
+ linetype = "dashed", |
| 725 | -+ | ! |
- #'+ xintercept = 0 |
| 726 |
- #' bivariate_ggplot_call("numeric", "numeric")
+ ) + |
||
| 727 | -+ | ! |
- #' bivariate_ggplot_call("numeric", "factor")
+ geom_hline( |
| 728 | -+ | ! |
- #' bivariate_ggplot_call("factor", "numeric")
+ size = 1, |
| 729 | -+ | ! |
- #' bivariate_ggplot_call("factor", "factor")
+ colour = "black", |
| 730 | -+ | ! |
- bivariate_ggplot_call <- function(x_class = c("NULL", "numeric", "integer", "factor", "character", "logical"),
+ linetype = "dashed", |
| 731 | -+ | ! |
- y_class = c("NULL", "numeric", "integer", "factor", "character", "logical"),
+ yintercept = 0 |
| 732 |
- freq = TRUE,+ ) + |
||
| 733 | -+ | ! |
- theme = "gray",+ geom_point(size = size, alpha = alpha) + |
| 734 | -+ | ! |
- rotate_xaxis_labels = FALSE,+ geom_line(data = smoothy, mapping = smoothy_aes), |
| 735 | -+ | ! |
- swap_axes = FALSE,+ env = list(size = size, alpha = alpha) |
| 736 |
- size = double(0),+ ) |
||
| 737 | -+ | ! |
- alpha = double(0),+ if (show_outlier) {
|
| 738 | -+ | ! |
- x = NULL,+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) |
| 739 |
- y = NULL,+ } |
||
| 740 |
- xlab = "-",+ |
||
| 741 | -+ | ! |
- ylab = "-",+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 742 | -+ | ! |
- data_name = "ANL",+ teal.widgets::resolve_ggplot2_args( |
| 743 | -+ | ! |
- ggplot2_args = teal.widgets::ggplot2_args()) {
+ user_plot = ggplot2_args[["Residuals vs Leverage"]], |
| 744 | -42x | +! |
- x_class <- match.arg(x_class)+ user_default = ggplot2_args$default, |
| 745 | -42x | +! |
- y_class <- match.arg(y_class)+ module_plot = teal.widgets::ggplot2_args( |
| 746 | -+ | ! |
-
+ labs = list( |
| 747 | -42x | +! |
- if (x_class %in% c("character", "logical")) {
+ x = quote(paste0("Standardized residuals\nlm(", reg_form, ")")),
|
| 748 | -12x | +! |
- x_class <- "factor"+ y = "Leverage", |
| 749 | -+ | ! |
- }+ title = "Residuals vs Leverage" |
| 750 | -42x | +
- if (x_class %in% c("integer")) {
+ ) |
|
| 751 | -! | +
- x_class <- "numeric"+ ) |
|
| 752 |
- }+ ), |
||
| 753 | -42x | +! |
- if (y_class %in% c("character", "logical")) {
+ ggtheme = ggtheme |
| 754 | -8x | +
- y_class <- "factor"+ ) |
|
| 755 |
- }+ |
||
| 756 | -42x | +! |
- if (y_class %in% c("integer")) {
+ teal.code::eval_code( |
| 757 | ! |
- y_class <- "numeric"+ plot_base, |
|
| 758 | -+ | ! |
- }+ substitute( |
| 759 | -+ | ! |
-
+ expr = {
|
| 760 | -42x | +! |
- if (all(c(x_class, y_class) == "NULL")) {
+ smoothy <- smooth(data$.hat, data$.stdresid) |
| 761 | ! |
- stop("either x or y is required")
+ g <- plot |
|
| 762 | -+ | ! |
- }+ print(g) |
| 763 |
-
+ }, |
||
| 764 | -42x | +! |
- reduce_plot_call <- function(...) {
+ env = list( |
| 765 | -104x | +! |
- args <- Filter(Negate(is.null), list(...))+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
| 766 | -104x | +
- Reduce(function(x, y) call("+", x, y), args)
+ ) |
|
| 767 |
- }+ ) |
||
| 768 |
-
+ ) |
||
| 769 | -42x | +
- plot_call <- substitute(ggplot(data_name), env = list(data_name = as.name(data_name)))+ } |
|
| 771 | -+ | ! |
- # Single data plots+ plot_type_6 <- function(plot_base) {
|
| 772 | -42x | +! |
- if (x_class == "numeric" && y_class == "NULL") {
+ shinyjs::show("size")
|
| 773 | -6x | +! |
- plot_call <- reduce_plot_call(plot_call, substitute(aes(x = xval), env = list(xval = x)))+ shinyjs::show("alpha")
|
| 774 | -+ | ! |
-
+ plot <- substitute( |
| 775 | -6x | +! |
- if (freq) {
+ expr = ggplot(data = data, aes(.hat, .cooksd)) + |
| 776 | -4x | +! |
- plot_call <- reduce_plot_call(+ geom_vline(xintercept = 0, colour = NA) + |
| 777 | -4x | +! |
- plot_call,+ geom_abline( |
| 778 | -4x | +! |
- quote(geom_histogram(bins = 30)),+ slope = seq(0, 3, by = 0.5), |
| 779 | -4x | +! |
- quote(ylab("Frequency"))
+ colour = "black", |
| 780 | -+ | ! |
- )+ linetype = "dashed", |
| 781 | -+ | ! |
- } else {
+ size = 1 |
| 782 | -2x | +
- plot_call <- reduce_plot_call(+ ) + |
|
| 783 | -2x | +! |
- plot_call,+ geom_line(data = smoothy, mapping = smoothy_aes) + |
| 784 | -2x | +! |
- quote(geom_histogram(bins = 30, aes(y = after_stat(density)))),+ geom_point(size = size, alpha = alpha), |
| 785 | -2x | +! |
- quote(geom_density(aes(y = after_stat(density)))),+ env = list(size = size, alpha = alpha) |
| 786 | -2x | +
- quote(ylab("Density"))
+ ) |
|
| 787 | -+ | ! |
- )+ if (show_outlier) {
|
| 788 | -+ | ! |
- }+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) |
| 789 | -36x | +
- } else if (x_class == "NULL" && y_class == "numeric") {
+ } |
|
| 790 | -6x | +
- plot_call <- reduce_plot_call(plot_call, substitute(aes(x = yval), env = list(yval = y)))+ |
|
| 791 | -+ | ! |
-
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 792 | -6x | +! |
- if (freq) {
+ teal.widgets::resolve_ggplot2_args( |
| 793 | -4x | +! |
- plot_call <- reduce_plot_call(+ user_plot = ggplot2_args[["Cook's dist vs Leverage"]], |
| 794 | -4x | +! |
- plot_call,+ user_default = ggplot2_args$default, |
| 795 | -4x | +! |
- quote(geom_histogram(bins = 30)),+ module_plot = teal.widgets::ggplot2_args( |
| 796 | -4x | +! |
- quote(ylab("Frequency"))
+ labs = list( |
| 797 | -+ | ! |
- )+ x = quote(paste0("Leverage\nlm(", reg_form, ")")),
|
| 798 | -+ | ! |
- } else {
+ y = "Cooks's distance", |
| 799 | -2x | +! |
- plot_call <- reduce_plot_call(+ title = "Cook's dist vs Leverage" |
| 800 | -2x | +
- plot_call,+ ) |
|
| 801 | -2x | +
- quote(geom_histogram(bins = 30, aes(y = after_stat(density)))),+ ) |
|
| 802 | -2x | +
- quote(geom_density(aes(y = after_stat(density)))),+ ), |
|
| 803 | -2x | +! |
- quote(ylab("Density"))
+ ggtheme = ggtheme |
| 804 |
- )+ ) |
||
| 805 |
- }+ |
||
| 806 | -30x | +! |
- } else if (x_class == "factor" && y_class == "NULL") {
+ teal.code::eval_code( |
| 807 | -4x | +! |
- plot_call <- reduce_plot_call(plot_call, substitute(aes(x = xval), env = list(xval = x)))+ plot_base, |
| 808 | -+ | ! |
-
+ substitute( |
| 809 | -4x | +! |
- if (freq) {
+ expr = {
|
| 810 | -2x | +! |
- plot_call <- reduce_plot_call(+ smoothy <- smooth(data$.hat, data$.cooksd) |
| 811 | -2x | +! |
- plot_call,+ g <- plot |
| 812 | -2x | +! |
- quote(geom_bar()),+ print(g) |
| 813 | -2x | +
- quote(ylab("Frequency"))
+ }, |
|
| 814 | -+ | ! |
- )+ env = list( |
| 815 | -+ | ! |
- } else {
+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
| 816 | -2x | +
- plot_call <- reduce_plot_call(+ ) |
|
| 817 | -2x | +
- plot_call,+ ) |
|
| 818 | -2x | +
- quote(geom_bar(aes(y = after_stat(prop), group = 1))),+ ) |
|
| 819 | -2x | +
- quote(ylab("Fraction"))
+ } |
|
| 820 |
- )+ |
||
| 821 | -+ | ! |
- }+ qenv <- if (input_type == "Response vs Regressor") {
|
| 822 | -26x | +! |
- } else if (x_class == "NULL" && y_class == "factor") {
+ plot_type_0() |
| 823 | -4x | +
- plot_call <- reduce_plot_call(plot_call, substitute(aes(x = yval), env = list(yval = y)))+ } else {
|
|
| 824 | -+ | ! |
-
+ plot_base_q <- plot_base() |
| 825 | -4x | +! |
- if (freq) {
+ switch(input_type, |
| 826 | -2x | +! |
- plot_call <- reduce_plot_call(+ "Residuals vs Fitted" = plot_base_q %>% plot_type_1(), |
| 827 | -2x | +! |
- plot_call,+ "Normal Q-Q" = plot_base_q %>% plot_type_2(), |
| 828 | -2x | +! |
- quote(geom_bar()),+ "Scale-Location" = plot_base_q %>% plot_type_3(), |
| 829 | -2x | +! |
- quote(ylab("Frequency"))
+ "Cook's distance" = plot_base_q %>% plot_type_4(), |
| 830 | -+ | ! |
- )+ "Residuals vs Leverage" = plot_base_q %>% plot_type_5(), |
| 831 | -+ | ! |
- } else {
+ "Cook's dist vs Leverage" = plot_base_q %>% plot_type_6() |
| 832 | -2x | +
- plot_call <- reduce_plot_call(+ ) |
|
| 833 | -2x | +
- plot_call,+ } |
|
| 834 | -2x | +! |
- quote(geom_bar(aes(y = after_stat(prop), group = 1))),+ qenv |
| 835 | -2x | +
- quote(ylab("Fraction"))
+ }) |
|
| 836 |
- )+ |
||
| 837 |
- }+ |
||
| 838 | -+ | ! |
- # Numeric Plots+ fitted <- reactive(output_q()[["fit"]]) |
| 839 | -22x | +! |
- } else if (x_class == "numeric" && y_class == "numeric") {
+ plot_r <- reactive(output_q()[["g"]]) |
| 840 | -2x | +
- plot_call <- reduce_plot_call(+ |
|
| 841 | -2x | +
- plot_call,+ # Insert the plot into a plot_with_settings module from teal.widgets |
|
| 842 | -2x | +! |
- substitute(aes(x = xval, y = yval), env = list(xval = x, yval = y)),+ pws <- teal.widgets::plot_with_settings_srv( |
| 843 | -+ | ! |
- # pch = 21 for consistent coloring behaviour b/w all geoms (outline and fill properties)+ id = "myplot", |
| 844 | -2x | +! |
- `if`(+ plot_r = plot_r, |
| 845 | -2x | +! |
- !is.null(size),+ height = plot_height, |
| 846 | -2x | +! |
- substitute(+ width = plot_width |
| 847 | -2x | +
- geom_point(alpha = alphaval, size = sizeval, pch = 21),+ ) |
|
| 848 | -2x | +
- env = list(alphaval = alpha, sizeval = size)+ |
|
| 849 | -+ | ! |
- ),+ output$text <- renderText({
|
| 850 | -2x | +! |
- substitute(+ req(iv_r()$is_valid()) |
| 851 | -2x | +! |
- geom_point(alpha = alphaval, pch = 21),+ req(iv_out$is_valid()) |
| 852 | -2x | +! |
- env = list(alphaval = alpha)+ paste(utils::capture.output(summary(teal.code::dev_suppress(fitted())))[-1], |
| 853 | -+ | ! |
- )+ collapse = "\n" |
| 855 |
- )+ }) |
||
| 856 | -20x | +
- } else if ((x_class == "numeric" && y_class == "factor") || (x_class == "factor" && y_class == "numeric")) {
+
|
|
| 857 | -6x | +! |
- plot_call <- reduce_plot_call(+ teal.widgets::verbatim_popup_srv( |
| 858 | -6x | +! |
- plot_call,+ id = "warning", |
| 859 | -6x | +! |
- substitute(aes(x = xval, y = yval), env = list(xval = x, yval = y)),+ verbatim_content = reactive(teal.code::get_warnings(output_q())), |
| 860 | -6x | +! |
- quote(geom_boxplot())+ title = "Warning", |
| 861 | -+ | ! |
- )+ disabled = reactive(is.null(teal.code::get_warnings(output_q()))) |
| 862 |
- # Factor and character plots+ ) |
||
| 863 | -14x | +
- } else if (x_class == "factor" && y_class == "factor") {
+
|
|
| 864 | -14x | +! |
- plot_call <- reduce_plot_call(+ teal.widgets::verbatim_popup_srv( |
| 865 | -14x | +! |
- plot_call,+ id = "rcode", |
| 866 | -14x | +! |
- substitute(+ verbatim_content = reactive(teal.code::get_code(output_q())), |
| 867 | -14x | +! |
- ggmosaic::geom_mosaic(aes(x = ggmosaic::product(xval), fill = yval), na.rm = TRUE),+ title = "R code for the regression plot", |
| 868 | -14x | +
- env = list(xval = x, yval = y)+ ) |
|
| 869 |
- )+ |
||
| 870 |
- )+ ### REPORTER |
||
| 871 | -+ | ! |
- } else {
+ if (with_reporter) {
|
| 872 | ! |
- stop("x y type combination not allowed")
+ card_fun <- function(comment, label) {
|
|
| 873 | -+ | ! |
- }+ card <- teal::report_card_template( |
| 874 | -+ | ! |
-
+ title = "Linear Regression Plot", |
| 875 | -42x | +! |
- labs_base <- if (x_class == "NULL") {
+ label = label, |
| 876 | -10x | +! |
- list(x = substitute(ylab, list(ylab = ylab)))+ with_filter = with_filter, |
| 877 | -42x | +! |
- } else if (y_class == "NULL") {
+ filter_panel_api = filter_panel_api |
| 878 | -10x | +
- list(x = substitute(xlab, list(xlab = xlab)))+ ) |
|
| 879 | -+ | ! |
- } else {
+ card$append_text("Plot", "header3")
|
| 880 | -22x | +! |
- list(+ card$append_plot(plot_r(), dim = pws$dim()) |
| 881 | -22x | +! |
- x = substitute(xlab, list(xlab = xlab)),+ if (!comment == "") {
|
| 882 | -22x | +! |
- y = substitute(ylab, list(ylab = ylab))+ card$append_text("Comment", "header3")
|
| 883 | -+ | ! |
- )+ card$append_text(comment) |
| 884 |
- }+ } |
||
| 885 | -+ | ! |
-
+ card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n")) |
| 886 | -42x | +! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(labs = labs_base)+ card |
| 887 |
-
+ } |
||
| 888 | -42x | +! |
- if (rotate_xaxis_labels) {
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 889 | -! | +
- dev_ggplot2_args$theme <- list(axis.text.x = quote(element_text(angle = 45, hjust = 1)))+ } |
|
| 890 |
- }+ ### |
||
| 891 |
-
+ }) |
||
| 892 | -42x | +
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ } |
|
| 893 | -42x | +
- user_plot = ggplot2_args,+ |
|
| 894 | -42x | +
- module_plot = dev_ggplot2_args+ regression_names <- paste0( |
|
| 895 |
- )+ '"Response vs Regressor", "Residuals vs Fitted", ', |
||
| 896 |
-
+ '"Scale-Location", "Cook\'s distance", "Residuals vs Leverage"", "Cook\'s dist vs Leverage"' |
||
| 897 | -42x | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = theme)+ ) |
| 898 | +1 |
-
+ #' Outliers Module |
|
| 899 | -42x | +||
| 2 | +
- plot_call <- reduce_plot_call(+ #' |
||
| 900 | -42x | +||
| 3 | +
- plot_call,+ #' Module to analyze and identify outliers using different methods |
||
| 901 | -42x | +||
| 4 | +
- parsed_ggplot2_args$labs,+ #' |
||
| 902 | -42x | +||
| 5 | +
- parsed_ggplot2_args$ggtheme,+ #' @inheritParams teal::module |
||
| 903 | -42x | +||
| 6 | +
- parsed_ggplot2_args$theme+ #' @inheritParams shared_params |
||
| 904 | +7 |
- )+ #' |
|
| 905 | +8 |
-
+ #' @param outlier_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 906 | -42x | +||
| 9 | +
- if (swap_axes) {
+ #' variable to consider for the outliers analysis. |
||
| 907 | -! | +||
| 10 | +
- plot_call <- reduce_plot_call(plot_call, quote(coord_flip()))+ #' @param categorical_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 908 | +11 |
- }+ #' categorical factor to split the selected outlier variables on. |
|
| 909 | +12 |
-
+ #' |
|
| 910 | -42x | +||
| 13 | +
- return(plot_call)+ #' @templateVar ggnames "Boxplot","Density Plot","Cumulative Distribution Plot" |
||
| 911 | +14 |
- }+ #' @template ggplot2_args_multi |
|
| 912 | +15 |
-
+ #' |
|
| 913 | +16 |
-
+ #' @export |
|
| 914 | +17 |
- #' Create facet call+ #' |
|
| 915 | +18 | ++ |
+ #' @examples+ |
+
| 19 |
#' |
||
| 916 | +20 |
- #' @noRd+ #' ADSL <- teal.modules.general::rADSL |
|
| 917 | +21 |
#' |
|
| 918 | +22 |
- #' @examples+ #' fact_vars_adsl <- names(Filter(isTRUE, sapply(ADSL, is.factor))) |
|
| 919 | +23 |
- #'+ #' vars <- choices_selected(variable_choices(ADSL, fact_vars_adsl)) |
|
| 920 | +24 |
- #' facet_ggplot_call(LETTERS[1:3])+ #' |
|
| 921 | +25 |
- #' facet_ggplot_call(NULL, LETTERS[23:26])+ #' app <- teal::init( |
|
| 922 | +26 |
- #' facet_ggplot_call(LETTERS[1:3], LETTERS[23:26])+ #' data = teal.data::cdisc_data( |
|
| 923 | +27 |
- facet_ggplot_call <- function(row_facet = character(0),+ #' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
|
|
| 924 | +28 |
- col_facet = character(0),+ #' check = TRUE |
|
| 925 | +29 |
- free_x_scales = FALSE,+ #' ), |
|
| 926 | +30 |
- free_y_scales = FALSE) {
+ #' modules = teal::modules( |
|
| 927 | -! | +||
| 31 | +
- scales <- if (free_x_scales && free_y_scales) {
+ #' teal.modules.general::tm_outliers( |
||
| 928 | -! | +||
| 32 | +
- "free"+ #' outlier_var = list( |
||
| 929 | -! | +||
| 33 | +
- } else if (free_x_scales) {
+ #' teal.transform::data_extract_spec( |
||
| 930 | -! | +||
| 34 | +
- "free_x"+ #' dataname = "ADSL", |
||
| 931 | -! | +||
| 35 | +
- } else if (free_y_scales) {
+ #' select = select_spec( |
||
| 932 | -! | +||
| 36 | +
- "free_y"+ #' label = "Select variable:", |
||
| 933 | +37 |
- } else {
+ #' choices = variable_choices(ADSL, c("AGE", "BMRKR1")),
|
|
| 934 | -! | +||
| 38 | +
- "fixed"+ #' selected = "AGE", |
||
| 935 | +39 |
- }+ #' multiple = FALSE, |
|
| 936 | +40 |
-
+ #' fixed = FALSE |
|
| 937 | -! | +||
| 41 | +
- if (identical(row_facet, character(0)) && identical(col_facet, character(0))) {
+ #' ) |
||
| 938 | -! | +||
| 42 | +
- NULL+ #' ) |
||
| 939 | -! | +||
| 43 | +
- } else if (!identical(row_facet, character(0)) && !identical(col_facet, character(0))) {
+ #' ), |
||
| 940 | -! | +||
| 44 | +
- call(+ #' categorical_var = list( |
||
| 941 | -! | +||
| 45 | +
- "facet_grid",+ #' teal.transform::data_extract_spec( |
||
| 942 | -! | +||
| 46 | +
- rows = call_fun_dots("vars", row_facet),
+ #' dataname = "ADSL", |
||
| 943 | -! | +||
| 47 | +
- cols = call_fun_dots("vars", col_facet),
+ #' filter = teal.transform::filter_spec( |
||
| 944 | -! | +||
| 48 | +
- scales = scales+ #' vars = vars, |
||
| 945 | +49 |
- )+ #' choices = value_choices(ADSL, vars$selected), |
|
| 946 | -! | +||
| 50 | +
- } else if (identical(row_facet, character(0)) && !identical(col_facet, character(0))) {
+ #' selected = value_choices(ADSL, vars$selected), |
||
| 947 | -! | +||
| 51 | +
- call("facet_grid", cols = call_fun_dots("vars", col_facet), scales = scales)
+ #' multiple = TRUE |
||
| 948 | -! | +||
| 52 | +
- } else if (!identical(row_facet, character(0)) && identical(col_facet, character(0))) {
+ #' ) |
||
| 949 | -! | +||
| 53 | +
- call("facet_grid", rows = call_fun_dots("vars", row_facet), scales = scales)
+ #' ) |
||
| 950 | +54 |
- }+ #' ), |
|
| 951 | +55 |
- }+ #' ggplot2_args = list( |
|
| 952 | +56 |
-
+ #' teal.widgets::ggplot2_args( |
|
| 953 | +57 |
- coloring_ggplot_call <- function(colour,+ #' labs = list(subtitle = "Plot generated by Outliers Module") |
|
| 954 | +58 |
- fill,+ #' ) |
|
| 955 | +59 |
- size,+ #' ) |
|
| 956 | +60 |
- is_point = FALSE) {
+ #' ) |
|
| 957 | -15x | +||
| 61 | +
- if (!identical(colour, character(0)) && !identical(fill, character(0)) &&+ #' ) |
||
| 958 | -15x | +||
| 62 | +
- is_point && !identical(size, character(0))) {
+ #' ) |
||
| 959 | -1x | +||
| 63 | +
- substitute(+ #' if (interactive()) {
|
||
| 960 | -1x | +||
| 64 | +
- expr = aes(colour = colour_name, fill = fill_name, size = size_name),+ #' shinyApp(app$ui, app$server) |
||
| 961 | -1x | +||
| 65 | +
- env = list(colour_name = as.name(colour), fill_name = as.name(fill), size_name = as.name(size))+ #' } |
||
| 962 | +66 |
- )+ #' |
|
| 963 | -14x | +||
| 67 | +
- } else if (identical(colour, character(0)) && !identical(fill, character(0)) &&+ tm_outliers <- function(label = "Outliers Module", |
||
| 964 | -14x | +||
| 68 | +
- is_point && identical(size, character(0))) {
+ outlier_var, |
||
| 965 | -1x | +||
| 69 | +
- substitute(expr = aes(fill = fill_name), env = list(fill_name = as.name(fill)))+ categorical_var = NULL, |
||
| 966 | -13x | +||
| 70 | +
- } else if (!identical(colour, character(0)) && !identical(fill, character(0)) &&+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
|
||
| 967 | -13x | +||
| 71 | +
- (!is_point || identical(size, character(0)))) {
+ ggplot2_args = teal.widgets::ggplot2_args(), |
||
| 968 | -3x | +||
| 72 | +
- substitute(+ plot_height = c(600, 200, 2000), |
||
| 969 | -3x | +||
| 73 | +
- expr = aes(colour = colour_name, fill = fill_name),+ plot_width = NULL, |
||
| 970 | -3x | +||
| 74 | +
- env = list(colour_name = as.name(colour), fill_name = as.name(fill))+ pre_output = NULL, |
||
| 971 | +75 |
- )+ post_output = NULL) {
|
|
| 972 | -10x | +||
| 76 | +! |
- } else if (!identical(colour, character(0)) && identical(fill, character(0)) &&+ logger::log_info("Initializing tm_outliers")
|
|
| 973 | -10x | +||
| 77 | +! |
- (!is_point || identical(size, character(0)))) {
+ if (inherits(outlier_var, "data_extract_spec")) outlier_var <- list(outlier_var) |
|
| 974 | -1x | +||
| 78 | +! |
- substitute(expr = aes(colour = colour_name), env = list(colour_name = as.name(colour)))+ if (inherits(categorical_var, "data_extract_spec")) categorical_var <- list(categorical_var) |
|
| 975 | -9x | +||
| 79 | +! |
- } else if (identical(colour, character(0)) && !identical(fill, character(0)) &&+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
|
| 976 | -9x | +||
| 80 | +
- (!is_point || identical(size, character(0)))) {
+
|
||
| 977 | -2x | +||
| 81 | +! |
- substitute(expr = aes(fill = fill_name), env = list(fill_name = as.name(fill)))+ ggtheme <- match.arg(ggtheme) |
|
| 978 | -7x | +||
| 82 | +! |
- } else if (identical(colour, character(0)) && identical(fill, character(0)) &&+ checkmate::assert_string(label) |
|
| 979 | -7x | +||
| 83 | +! |
- is_point && !identical(size, character(0))) {
+ checkmate::assert_list(outlier_var, types = "data_extract_spec") |
|
| 980 | -1x | +||
| 84 | +! |
- substitute(expr = aes(size = size_name), env = list(size_name = as.name(size)))+ checkmate::assert_list(categorical_var, types = "data_extract_spec", null.ok = TRUE) |
|
| 981 | -6x | +||
| 85 | +! |
- } else if (!identical(colour, character(0)) && identical(fill, character(0)) &&+ if (is.list(categorical_var)) {
|
|
| 982 | -6x | +||
| 86 | +! |
- is_point && !identical(size, character(0))) {
+ lapply(categorical_var, function(x) {
|
|
| 983 | -1x | +||
| 87 | +! |
- substitute(+ if (length(x$filter) > 1L) {
|
|
| 984 | -1x | +||
| 88 | +! |
- expr = aes(colour = colour_name, size = size_name),+ stop("tm_outliers: categorical_var data_extract_specs may only specify one filter_spec", call. = FALSE)
|
|
| 985 | -1x | +||
| 89 | +
- env = list(colour_name = as.name(colour), size_name = as.name(size))+ } |
||
| 986 | +90 |
- )+ }) |
|
| 987 | -5x | +||
| 91 | +
- } else if (identical(colour, character(0)) && !identical(fill, character(0)) &&+ } |
||
| 988 | -5x | +||
| 92 | +! |
- is_point && !identical(size, character(0))) {
+ plot_choices <- c("Boxplot", "Density Plot", "Cumulative Distribution Plot")
|
|
| 989 | -1x | +||
| 93 | +! |
- substitute(+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
|
| 990 | -1x | +||
| 94 | +! |
- expr = aes(colour = colour_name, fill = fill_name, size = size_name),+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
|
| 991 | -1x | +||
| 95 | +
- env = list(colour_name = as.name(fill), fill_name = as.name(fill), size_name = as.name(size))+ |
||
| 992 | -+ | ||
| 96 | +! |
- )+ args <- as.list(environment()) |
|
| 993 | +97 |
- } else {
+
|
|
| 994 | -4x | +||
| 98 | +! |
- NULL+ data_extract_list <- list( |
|
| 995 | -+ | ||
| 99 | +! |
- }+ outlier_var = outlier_var, |
|
| 996 | -+ | ||
| 100 | +! |
- }+ categorical_var = categorical_var |
| 1 | +101 |
- #' Scatterplot and Regression Model+ ) |
|
| 2 | +102 |
- #' @md+ |
|
| 3 | -+ | ||
| 103 | +! |
- #'+ module( |
|
| 4 | -+ | ||
| 104 | +! |
- #' @inheritParams teal::module+ label = label, |
|
| 5 | -+ | ||
| 105 | +! |
- #' @inheritParams shared_params+ server = srv_outliers, |
|
| 6 | -+ | ||
| 106 | +! |
- #' @param regressor (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ server_args = c( |
|
| 7 | -+ | ||
| 107 | +! |
- #' Regressor variables from an incoming dataset with filtering and selecting.+ data_extract_list, |
|
| 8 | -+ | ||
| 108 | +! |
- #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args) |
|
| 9 | +109 |
- #' Response variables from an incoming dataset with filtering and selecting.+ ), |
|
| 10 | -+ | ||
| 110 | +! |
- #' @param alpha optional, (`numeric`) If scalar then the plot points will have a fixed opacity. If a+ ui = ui_outliers, |
|
| 11 | -+ | ||
| 111 | +! |
- #' slider should be presented to adjust the plot point opacity dynamically then it can be a vector of+ ui_args = args, |
|
| 12 | -+ | ||
| 112 | +! |
- #' length three with `c(value, min, max)`.+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
|
| 13 | +113 |
- #' @param size optional, (`numeric`) If scalar then the plot point sizes will have a fixed size+ ) |
|
| 14 | +114 |
- #' If a slider should be presented to adjust the plot point sizes dynamically then it can be a+ } |
|
| 15 | +115 |
- #' vector of length three with `c(value, min, max)`.+ |
|
| 16 | +116 |
- #' @param default_outlier_label optional, (`character`) The default column selected to label outliers.+ ui_outliers <- function(id, ...) {
|
|
| 17 | -+ | ||
| 117 | +! |
- #' @param default_plot_type optional, (`numeric`) Defaults to Response vs Regressor.+ args <- list(...) |
|
| 18 | -+ | ||
| 118 | +! |
- #' 1. Response vs Regressor+ ns <- NS(id) |
|
| 19 | -+ | ||
| 119 | +! |
- #' 2. Residuals vs Fitted+ is_single_dataset_value <- teal.transform::is_single_dataset(args$outlier_var, args$categorical_var) |
|
| 20 | +120 |
- #' 3. Normal Q-Q+ |
|
| 21 | -+ | ||
| 121 | +! |
- #' 4. Scale-Location+ teal.widgets::standard_layout( |
|
| 22 | -+ | ||
| 122 | +! |
- #' 5. Cook's distance+ output = teal.widgets::white_small_well( |
|
| 23 | -+ | ||
| 123 | +! |
- #' 6. Residuals vs Leverage+ uiOutput(ns("total_outliers")),
|
|
| 24 | -+ | ||
| 124 | +! |
- #' 7. Cook's dist vs Leverage+ DT::dataTableOutput(ns("summary_table")),
|
|
| 25 | -+ | ||
| 125 | +! |
- #'+ uiOutput(ns("total_missing")),
|
|
| 26 | -+ | ||
| 126 | +! |
- #' @templateVar ggnames `r regression_names`+ br(), hr(), |
|
| 27 | -+ | ||
| 127 | +! |
- #' @template ggplot2_args_multi+ tabsetPanel( |
|
| 28 | -+ | ||
| 128 | +! |
- #'+ id = ns("tabs"),
|
|
| 29 | -+ | ||
| 129 | +! |
- #' @note For more examples, please see the vignette "Using regression plots" via+ tabPanel( |
|
| 30 | -+ | ||
| 130 | +! |
- #' `vignette("using-regression-plots", package = "teal.modules.general")`.
+ "Boxplot", |
|
| 31 | -+ | ||
| 131 | +! |
- #' @export+ teal.widgets::plot_with_settings_ui(id = ns("box_plot"))
|
|
| 32 | +132 |
- #'+ ), |
|
| 33 | -+ | ||
| 133 | +! |
- #' @examples+ tabPanel( |
|
| 34 | -+ | ||
| 134 | +! |
- #' # Regression graphs from selected response variable (BMRKR1) and+ "Density Plot", |
|
| 35 | -+ | ||
| 135 | +! |
- #' # selected regressors (AGE)+ teal.widgets::plot_with_settings_ui(id = ns("density_plot"))
|
|
| 36 | +136 |
- #'+ ), |
|
| 37 | -+ | ||
| 137 | +! |
- #' ADSL <- teal.modules.general::rADSL+ tabPanel( |
|
| 38 | -+ | ||
| 138 | +! |
- #'+ "Cumulative Distribution Plot", |
|
| 39 | -+ | ||
| 139 | +! |
- #' app <- teal::init(+ teal.widgets::plot_with_settings_ui(id = ns("cum_density_plot"))
|
|
| 40 | +140 |
- #' data = teal.data::cdisc_data(+ ) |
|
| 41 | +141 |
- #' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
+ ), |
|
| 42 | -+ | ||
| 142 | +! |
- #' check = TRUE+ br(), hr(), |
|
| 43 | -+ | ||
| 143 | +! |
- #' ),+ uiOutput(ns("table_ui_wrap"))
|
|
| 44 | +144 |
- #' modules = teal::modules(+ ), |
|
| 45 | -+ | ||
| 145 | +! |
- #' teal.modules.general::tm_a_regression(+ encoding = div( |
|
| 46 | +146 |
- #' label = "Regression",+ ### Reporter |
|
| 47 | -+ | ||
| 147 | +! |
- #' response = teal.transform::data_extract_spec(+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 48 | +148 |
- #' dataname = "ADSL",+ ### |
|
| 49 | -+ | ||
| 149 | +! |
- #' select = teal.transform::select_spec(+ tags$label("Encodings", class = "text-primary"),
|
|
| 50 | -+ | ||
| 150 | +! |
- #' label = "Select variable:",+ teal.transform::datanames_input(args[c("outlier_var", "categorical_var")]),
|
|
| 51 | -+ | ||
| 151 | +! |
- #' choices = "BMRKR1",+ teal.transform::data_extract_ui( |
|
| 52 | -+ | ||
| 152 | +! |
- #' selected = "BMRKR1",+ id = ns("outlier_var"),
|
|
| 53 | -+ | ||
| 153 | +! |
- #' multiple = FALSE,+ label = "Variable", |
|
| 54 | -+ | ||
| 154 | +! |
- #' fixed = TRUE+ data_extract_spec = args$outlier_var, |
|
| 55 | -+ | ||
| 155 | +! |
- #' )+ is_single_dataset = is_single_dataset_value |
|
| 56 | +156 |
- #' ),+ ), |
|
| 57 | -+ | ||
| 157 | +! |
- #' regressor = teal.transform::data_extract_spec(+ if (!is.null(args$categorical_var)) {
|
|
| 58 | -+ | ||
| 158 | +! |
- #' dataname = "ADSL",+ teal.transform::data_extract_ui( |
|
| 59 | -+ | ||
| 159 | +! |
- #' select = teal.transform::select_spec(+ id = ns("categorical_var"),
|
|
| 60 | -+ | ||
| 160 | +! |
- #' label = "Select variables:",+ label = "Categorical factor", |
|
| 61 | -+ | ||
| 161 | +! |
- #' choices = teal.transform::variable_choices(ADSL, c("AGE", "SEX", "RACE")),
+ data_extract_spec = args$categorical_var, |
|
| 62 | -+ | ||
| 162 | +! |
- #' selected = "AGE",+ is_single_dataset = is_single_dataset_value |
|
| 63 | +163 |
- #' multiple = TRUE,+ ) |
|
| 64 | +164 |
- #' fixed = FALSE+ }, |
|
| 65 | -+ | ||
| 165 | +! |
- #' )- |
- |
| 66 | -- |
- #' ),- |
- |
| 67 | -- |
- #' ggplot2_args = teal.widgets::ggplot2_args(+ conditionalPanel( |
|
| 68 | -+ | ||
| 166 | +! |
- #' labs = list(subtitle = "Plot generated by Regression Module")+ condition = paste0("input['", ns("tabs"), "'] == 'Boxplot'"),
|
|
| 69 | -+ | ||
| 167 | +! |
- #' )+ teal.widgets::optionalSelectInput( |
|
| 70 | -+ | ||
| 168 | +! |
- #' )+ inputId = ns("boxplot_alts"),
|
|
| 71 | -+ | ||
| 169 | +! |
- #' )+ label = "Plot type", |
|
| 72 | -+ | ||
| 170 | +! |
- #' )+ choices = c("Box plot", "Violin plot"),
|
|
| 73 | -+ | ||
| 171 | +! |
- #' if (interactive()) {
+ selected = "Box plot", |
|
| 74 | -+ | ||
| 172 | +! |
- #' shinyApp(app$ui, app$server)+ multiple = FALSE |
|
| 75 | +173 |
- #' }+ ) |
|
| 76 | +174 |
- tm_a_regression <- function(label = "Regression Analysis",+ ), |
|
| 77 | -+ | ||
| 175 | +! |
- regressor,+ shinyjs::hidden(checkboxInput(ns("split_outliers"), "Define outliers based on group splitting", value = FALSE)),
|
|
| 78 | -+ | ||
| 176 | +! |
- response,+ shinyjs::hidden(checkboxInput(ns("order_by_outlier"), "Re-order categories by outliers [by %]", value = FALSE)),
|
|
| 79 | -+ | ||
| 177 | +! |
- plot_height = c(600, 200, 2000),+ teal.widgets::panel_group( |
|
| 80 | -+ | ||
| 178 | +! |
- plot_width = NULL,+ teal.widgets::panel_item( |
|
| 81 | -+ | ||
| 179 | +! |
- alpha = c(1, 0, 1),+ title = "Method parameters", |
|
| 82 | -+ | ||
| 180 | +! |
- size = c(2, 1, 8),+ collapsed = FALSE, |
|
| 83 | -+ | ||
| 181 | +! |
- ggtheme = c(+ teal.widgets::optionalSelectInput( |
|
| 84 | -+ | ||
| 182 | +! |
- "gray", "bw", "linedraw", "light", "dark",+ inputId = ns("method"),
|
|
| 85 | -+ | ||
| 183 | +! |
- "minimal", "classic", "void", "test"+ label = "Method", |
|
| 86 | -+ | ||
| 184 | +! |
- ),+ choices = c("IQR", "Z-score", "Percentile"),
|
|
| 87 | -+ | ||
| 185 | +! |
- ggplot2_args = teal.widgets::ggplot2_args(),+ selected = "IQR", |
|
| 88 | -+ | ||
| 186 | +! |
- pre_output = NULL,+ multiple = FALSE |
|
| 89 | +187 |
- post_output = NULL,+ ), |
|
| 90 | -+ | ||
| 188 | +! |
- default_plot_type = 1,+ conditionalPanel( |
|
| 91 | -+ | ||
| 189 | +! |
- default_outlier_label = "USUBJID") {
+ condition = |
|
| 92 | +190 | ! |
- logger::log_info("Initializing tm_a_regression")
+ paste0("input['", ns("method"), "'] == 'IQR'"),
|
| 93 | +191 | ! |
- if (inherits(regressor, "data_extract_spec")) regressor <- list(regressor)+ sliderInput( |
| 94 | +192 | ! |
- if (inherits(response, "data_extract_spec")) response <- list(response)+ ns("iqr_slider"),
|
| 95 | +193 | ! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ "Outlier range:", |
| 96 | -+ | ||
| 194 | +! |
-
+ min = 1, |
|
| 97 | +195 | ! |
- checkmate::assert_string(label)+ max = 5, |
| 98 | +196 | ! |
- checkmate::assert_list(response, types = "data_extract_spec")+ value = 3, |
| 99 | +197 | ! |
- if (!all(vapply(response, function(x) !(x$select$multiple), logical(1)))) {
+ step = 0.5 |
| 100 | -! | +||
| 198 | +
- stop("'response' should not allow multiple selection")
+ ) |
||
| 101 | +199 |
- }+ ), |
|
| 102 | +200 | ! |
- checkmate::assert_list(regressor, types = "data_extract_spec")+ conditionalPanel( |
| 103 | +201 | ! |
- ggtheme <- match.arg(ggtheme)+ condition = |
| 104 | +202 | ! |
- checkmate::assert_string(default_outlier_label)+ paste0("input['", ns("method"), "'] == 'Z-score'"),
|
| 105 | +203 | ! |
- plot_choices <- c(+ sliderInput( |
| 106 | +204 | ! |
- "Response vs Regressor", "Residuals vs Fitted", "Normal Q-Q", "Scale-Location",+ ns("zscore_slider"),
|
| 107 | +205 | ! |
- "Cook's distance", "Residuals vs Leverage", "Cook's dist vs Leverage"+ "Outlier range:", |
| 108 | -+ | ||
| 206 | +! |
- )+ min = 1, |
|
| 109 | +207 | ! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ max = 5, |
| 110 | +208 | ! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ value = 3, |
| 111 | +209 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ step = 0.5 |
| 112 | -! | +||
| 210 | +
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ ) |
||
| 113 | -! | +||
| 211 | +
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ ), |
||
| 114 | +212 | ! |
- checkmate::assert_numeric(+ conditionalPanel( |
| 115 | +213 | ! |
- plot_width[1],+ condition = |
| 116 | +214 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ paste0("input['", ns("method"), "'] == 'Percentile'"),
|
| 117 | -+ | ||
| 215 | +! |
- )+ sliderInput( |
|
| 118 | -+ | ||
| 216 | +! |
-
+ ns("percentile_slider"),
|
|
| 119 | -+ | ||
| 217 | +! |
- # Send ui args+ "Outlier range:", |
|
| 120 | +218 | ! |
- args <- as.list(environment())+ min = 0.001, |
| 121 | +219 | ! |
- args[["plot_choices"]] <- plot_choices+ max = 0.5, |
| 122 | +220 | ! |
- data_extract_list <- list(+ value = 0.01, |
| 123 | +221 | ! |
- regressor = regressor,+ step = 0.001+ |
+
| 222 | ++ |
+ )+ |
+ |
| 223 | ++ |
+ ), |
|
| 124 | +224 | ! |
- response = response+ uiOutput(ns("ui_outlier_help"))
|
| 125 | +225 |
- )+ ) |
|
| 126 | +226 |
-
+ ), |
|
| 127 | +227 | ! |
- module(+ teal.widgets::panel_item( |
| 128 | +228 | ! |
- label = label,+ title = "Plot settings", |
| 129 | +229 | ! |
- server = srv_a_regression,+ selectInput( |
| 130 | +230 | ! |
- ui = ui_a_regression,+ inputId = ns("ggtheme"),
|
| 131 | +231 | ! |
- ui_args = args,+ label = "Theme (by ggplot):", |
| 132 | +232 | ! |
- server_args = c(+ choices = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
|
| 133 | +233 | ! |
- data_extract_list,+ selected = args$ggtheme, |
| 134 | +234 | ! |
- list(+ multiple = FALSE |
| 135 | -! | +||
| 235 | +
- plot_height = plot_height,+ )+ |
+ ||
| 236 | ++ |
+ )+ |
+ |
| 237 | ++ |
+ ), |
|
| 136 | +238 | ! |
- plot_width = plot_width,+ forms = tagList( |
| 137 | +239 | ! |
- default_outlier_label = default_outlier_label,+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
|
| 138 | +240 | ! |
- ggplot2_args = ggplot2_args+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
| 139 | +241 |
- )+ ), |
|
| 140 | -+ | ||
| 242 | +! |
- ),+ pre_output = args$pre_output, |
|
| 141 | +243 | ! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ post_output = args$post_output |
| 142 | +244 |
) |
|
| 143 | +245 |
} |
|
| 144 | +246 | ||
| 145 | +247 |
- ui_a_regression <- function(id, ...) {
+ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var, |
|
| 146 | -! | +||
| 248 | +
- ns <- NS(id)+ categorical_var, plot_height, plot_width, ggplot2_args) {
|
||
| 147 | +249 | ! |
- args <- list(...)+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 148 | +250 | ! |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$regressor, args$response)- |
-
| 149 | -- |
-
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 150 | +251 | ! |
- teal.widgets::standard_layout(+ checkmate::assert_class(data, "tdata") |
| 151 | +252 | ! |
- output = teal.widgets::white_small_well(tags$div(+ moduleServer(id, function(input, output, session) {
|
| 152 | +253 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("myplot")),
+ vars <- list(outlier_var = outlier_var, categorical_var = categorical_var) |
| 153 | -! | +||
| 254 | +
- tags$div(verbatimTextOutput(ns("text")))
+
|
||
| 154 | -+ | ||
| 255 | +! |
- )),+ rule_diff <- function(other) {
|
|
| 155 | +256 | ! |
- encoding = div(+ function(value) {
|
| 156 | -+ | ||
| 257 | +! |
- ### Reporter+ othervalue <- tryCatch(selector_list()[[other]]()[["select"]], error = function(e) NULL) |
|
| 157 | +258 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ if (!is.null(othervalue) && identical(othervalue, value)) {
+ |
+
| 259 | +! | +
+ "`Variable` and `Categorical factor` cannot be the same" |
|
| 158 | +260 |
- ###+ }+ |
+ |
| 261 | ++ |
+ }+ |
+ |
| 262 | ++ |
+ }+ |
+ |
| 263 | ++ | + | |
| 159 | +264 | ! |
- tags$label("Encodings", class = "text-primary"),
+ selector_list <- teal.transform::data_extract_multiple_srv( |
| 160 | +265 | ! |
- teal.transform::datanames_input(args[c("response", "regressor")]),
+ data_extract = vars, |
| 161 | +266 | ! |
- teal.transform::data_extract_ui(+ datasets = data, |
| 162 | +267 | ! |
- id = ns("response"),
+ select_validation_rule = list( |
| 163 | +268 | ! |
- label = "Response variable",+ outlier_var = shinyvalidate::compose_rules( |
| 164 | +269 | ! |
- data_extract_spec = args$response,+ shinyvalidate::sv_required("Please select a variable"),
|
| 165 | +270 | ! |
- is_single_dataset = is_single_dataset_value+ rule_diff("categorical_var")
|
| 166 | +271 |
- ),+ ), |
|
| 167 | +272 | ! |
- teal.transform::data_extract_ui(+ categorical_var = rule_diff("outlier_var")
+ |
+
| 273 | ++ |
+ )+ |
+ |
| 274 | ++ |
+ )+ |
+ |
| 275 | ++ | + | |
| 168 | +276 | ! |
- id = ns("regressor"),
+ iv_r <- reactive({
|
| 169 | +277 | ! |
- label = "Regressor variables",+ iv <- shinyvalidate::InputValidator$new() |
| 170 | +278 | ! |
- data_extract_spec = args$regressor,+ iv$add_rule("method", shinyvalidate::sv_required("Please select a method"))
|
| 171 | +279 | ! |
- is_single_dataset = is_single_dataset_value+ iv$add_rule("boxplot_alts", shinyvalidate::sv_required("Please select Plot Type"))
+ |
+
| 280 | +! | +
+ teal.transform::compose_and_enable_validators(iv, selector_list) |
|
| 172 | +281 |
- ),+ }) |
|
| 173 | -! | +||
| 282 | +
- radioButtons(+ |
||
| 174 | +283 | ! |
- ns("plot_type"),
+ reactive_select_input <- reactive({
|
| 175 | +284 | ! |
- label = "Plot type:",+ if (is.null(selector_list()$categorical_var) || length(selector_list()$categorical_var()$select) == 0) {
|
| 176 | +285 | ! |
- choices = args$plot_choices,+ selector_list()[names(selector_list()) != "categorical_var"]+ |
+
| 286 | ++ |
+ } else {
|
|
| 177 | +287 | ! |
- selected = args$plot_choices[args$default_plot_type]+ selector_list() |
| 178 | +288 |
- ),+ } |
|
| 179 | -! | +||
| 289 | +
- checkboxInput(ns("show_outlier"), label = "Display outlier labels", value = TRUE),
+ })+ |
+ ||
| 290 | ++ | + | |
| 180 | +291 | ! |
- conditionalPanel(+ anl_merged_input <- teal.transform::merge_expression_srv( |
| 181 | +292 | ! |
- condition = "input['show_outlier']",+ selector_list = reactive_select_input, |
| 182 | +293 | ! |
- ns = ns,+ datasets = data, |
| 183 | +294 | ! |
- teal.widgets::optionalSliderInput(+ join_keys = get_join_keys(data), |
| 184 | +295 | ! |
- ns("outlier"),
+ merge_function = "dplyr::inner_join"+ |
+
| 296 | ++ |
+ )+ |
+ |
| 297 | ++ | + | |
| 185 | +298 | ! |
- div(+ anl_merged_q <- reactive({
|
| 186 | +299 | ! |
- class = "teal-tooltip",+ req(anl_merged_input()) |
| 187 | +300 | ! |
- tagList(+ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% |
| 188 | +301 | ! |
- "Outlier definition:",+ teal.code::eval_code(as.expression(anl_merged_input()$expr))+ |
+
| 302 | ++ |
+ })+ |
+ |
| 303 | ++ | + | |
| 189 | +304 | ! |
- icon("circle-info"),
+ merged <- list( |
| 190 | +305 | ! |
- span(+ anl_input_r = anl_merged_input, |
| 191 | +306 | ! |
- class = "tooltiptext",+ anl_q_r = anl_merged_q+ |
+
| 307 | ++ |
+ )+ |
+ |
| 308 | ++ | + | |
| 192 | +309 | ! |
- paste(+ n_outlier_missing <- reactive({
|
| 193 | +310 | ! |
- "Use the slider to choose the cut-off value to define outliers.",+ shiny::req(iv_r()$is_valid()) |
| 194 | +311 | ! |
- "Points with a Cook's distance greater than",+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
| 195 | +312 | ! |
- "the value on the slider times the mean of the Cook's distance of the dataset will have labels."+ ANL <- merged$anl_q_r()[["ANL"]] # nolint |
| 196 | -+ | ||
| 313 | +! |
- )+ sum(is.na(ANL[[outlier_var]])) |
|
| 197 | +314 |
- )+ }) |
|
| 198 | +315 |
- )+ |
|
| 199 | +316 |
- ),+ # Used to create outlier table and the dropdown with additional columns |
|
| 200 | +317 | ! |
- min = 1, max = 10, value = 9, ticks = FALSE, step = .1+ dataname_first <- names(data)[[1]] |
| 201 | +318 |
- ),+ |
|
| 202 | +319 | ! |
- teal.widgets::optionalSelectInput(+ common_code_q <- reactive({
|
| 203 | +320 | ! |
- ns("label_var"),
+ shiny::req(iv_r()$is_valid())+ |
+
| 321 | ++ | + | |
| 204 | +322 | ! |
- multiple = FALSE,+ ANL <- merged$anl_q_r()[["ANL"]] # nolint |
| 205 | +323 | ! |
- label = "Outlier label"+ qenv <- merged$anl_q_r() |
| 206 | +324 |
- )+ |
|
| 207 | -+ | ||
| 325 | +! |
- ),+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
|
| 208 | +326 | ! |
- teal.widgets::panel_group(+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
| 209 | +327 | ! |
- teal.widgets::panel_item(+ order_by_outlier <- input$order_by_outlier # nolint |
| 210 | +328 | ! |
- title = "Plot settings",+ method <- input$method |
| 211 | +329 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
+ split_outliers <- input$split_outliers |
| 212 | +330 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE),
+ teal::validate_has_data(+ |
+
| 331 | ++ |
+ # missing values in the categorical variable may be used to form a category of its own |
|
| 213 | +332 | ! |
- selectInput(+ `if`( |
| 214 | +333 | ! |
- inputId = ns("ggtheme"),
+ length(categorical_var) == 0, |
| 215 | +334 | ! |
- label = "Theme (by ggplot):",+ ANL, |
| 216 | +335 | ! |
- choices = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
+ ANL[, names(ANL) != categorical_var]+ |
+
| 336 | ++ |
+ ), |
|
| 217 | +337 | ! |
- selected = args$ggtheme,+ min_nrow = 10, |
| 218 | +338 | ! |
- multiple = FALSE+ complete = TRUE, |
| 219 | -+ | ||
| 339 | +! |
- )+ allow_inf = FALSE |
|
| 220 | +340 |
- )+ )+ |
+ |
| 341 | +! | +
+ validate(need(is.numeric(ANL[[outlier_var]]), "`Variable` is not numeric"))+ |
+ |
| 342 | +! | +
+ validate(need(length(unique(ANL[[outlier_var]])) > 1, "Variable has no variation, i.e. only one unique value")) |
|
| 221 | +343 |
- )+ |
|
| 222 | +344 |
- ),+ # show/hide split_outliers |
|
| 223 | +345 | ! |
- forms = tagList(+ if (length(categorical_var) == 0) {
|
| 224 | +346 | ! |
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+ shinyjs::hide("split_outliers")
|
| 225 | +347 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ if (n_outlier_missing() > 0) {
|
| 226 | -+ | ||
| 348 | +! |
- ),+ qenv <- teal.code::eval_code( |
|
| 227 | +349 | ! |
- pre_output = args$pre_output,+ qenv, |
| 228 | +350 | ! |
- post_output = args$post_output+ substitute( |
| 229 | -+ | ||
| 351 | +! |
- )+ expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)), # nolint |
|
| 230 | -+ | ||
| 352 | +! |
- }+ env = list(outlier_var_name = as.name(outlier_var)) |
|
| 231 | +353 |
-
+ ) |
|
| 232 | +354 |
-
+ ) |
|
| 233 | +355 |
- srv_a_regression <- function(id,+ } |
|
| 234 | -- |
- data,- |
- |
| 235 | +356 |
- reporter,+ } else {
|
|
| 236 | -+ | ||
| 357 | +! |
- filter_panel_api,+ validate(need( |
|
| 237 | -+ | ||
| 358 | +! |
- response,+ is.factor(ANL[[categorical_var]]) || |
|
| 238 | -+ | ||
| 359 | +! |
- regressor,+ is.character(ANL[[categorical_var]]) || |
|
| 239 | -+ | ||
| 360 | +! |
- plot_height,+ is.integer(ANL[[categorical_var]]), |
|
| 240 | -+ | ||
| 361 | +! |
- plot_width,+ "`Categorical factor` must be `factor`, `character`, or `integer`" |
|
| 241 | +362 |
- ggplot2_args,+ )) |
|
| 242 | +363 |
- default_outlier_label) {
+
|
|
| 243 | +364 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ if (n_outlier_missing() > 0) {
|
| 244 | +365 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ qenv <- teal.code::eval_code( |
| 245 | +366 | ! |
- checkmate::assert_class(data, "tdata")+ qenv, |
| 246 | +367 | ! |
- moduleServer(id, function(input, output, session) {
+ substitute( |
| 247 | +368 | ! |
- rule_rvr1 <- function(value) {
+ expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)), # nolint |
| 248 | +369 | ! |
- if (isTRUE(input$plot_type == "Response vs Regressor")) {
+ env = list(outlier_var_name = as.name(outlier_var)) |
| 249 | -! | +||
| 370 | +
- if (length(value) > 1L) {
+ ) |
||
| 250 | -! | +||
| 371 | +
- "This plot can only have one regressor."+ ) |
||
| 251 | +372 |
} |
|
| 373 | +! | +
+ shinyjs::show("split_outliers")
+ |
+ |
| 252 | +374 |
} |
|
| 253 | +375 |
- }+ |
|
| 254 | -! | +||
| 376 | +
- rule_rvr2 <- function(other) {
+ # slider |
||
| 255 | +377 | ! |
- function(value) {
+ outlier_definition_param <- if (method == "IQR") { # nolint
|
| 256 | +378 | ! |
- if (isTRUE(input$plot_type == "Response vs Regressor")) {
+ input$iqr_slider |
| 257 | +379 | ! |
- otherval <- selector_list()[[other]]()$select+ } else if (method == "Z-score") {
|
| 258 | +380 | ! |
- if (isTRUE(value == otherval)) {
+ input$zscore_slider |
| 259 | +381 | ! |
- "Response and Regressor must be different."- |
-
| 260 | -- |
- }+ } else if (method == "Percentile") {
|
|
| 261 | -+ | ||
| 382 | +! |
- }+ input$percentile_slider |
|
| 262 | +383 |
} |
|
| 263 | +384 |
- }+ |
|
| 264 | +385 |
-
+ # this is utils function that converts a %>% NULL %>% b into a %>% b |
|
| 265 | +386 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ remove_pipe_null <- function(x) {
|
| 266 | +387 | ! |
- data_extract = list(response = response, regressor = regressor),+ if (length(x) == 1) {
|
| 267 | +388 | ! |
- datasets = data,+ return(x) |
| 268 | -! | +||
| 389 | +
- select_validation_rule = list(+ } |
||
| 269 | +390 | ! |
- regressor = shinyvalidate::compose_rules(+ if (identical(x[[1]], as.name("%>%")) && is.null(x[[3]])) {
|
| 270 | +391 | ! |
- shinyvalidate::sv_required("At least one regressor should be selected."),
+ return(remove_pipe_null(x[[2]])) |
| 271 | -! | +||
| 392 | +
- rule_rvr1,+ } |
||
| 272 | +393 | ! |
- rule_rvr2("response")
+ return(as.call(c(x[[1]], lapply(x[-1], remove_pipe_null)))) |
| 273 | +394 |
- ),+ } |
|
| 274 | -! | +||
| 395 | +
- response = shinyvalidate::compose_rules(+ |
||
| 275 | +396 | ! |
- shinyvalidate::sv_required("At least one response should be selected."),
+ qenv <- teal.code::eval_code( |
| 276 | +397 | ! |
- rule_rvr2("regressor")
+ qenv, |
| 277 | -+ | ||
| 398 | +! |
- )+ substitute( |
|
| 278 | -+ | ||
| 399 | +! |
- )+ expr = {
|
|
| 279 | -+ | ||
| 400 | +! |
- )+ ANL_OUTLIER <- ANL %>% # nolint |
|
| 280 | -+ | ||
| 401 | +! |
-
+ group_expr %>% # styler: off |
|
| 281 | +402 | ! |
- iv_r <- reactive({
+ dplyr::mutate(is_outlier = {
|
| 282 | +403 | ! |
- iv <- shinyvalidate::InputValidator$new()+ q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75)) |
| 283 | +404 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list)+ iqr <- q1_q3[2] - q1_q3[1] |
| 284 | -+ | ||
| 405 | +! |
- })+ !(outlier_var_name >= q1_q3[1] - 1.5 * iqr & outlier_var_name <= q1_q3[2] + 1.5 * iqr) |
|
| 285 | +406 |
-
+ }) %>% |
|
| 286 | +407 | ! |
- iv_out <- shinyvalidate::InputValidator$new()+ calculate_outliers %>% # styler: off |
| 287 | +408 | ! |
- iv_out$condition(~ isTRUE(input$show_outlier))+ ungroup_expr %>% # styler: off |
| 288 | +409 | ! |
- iv_out$add_rule("label_var", shinyvalidate::sv_required("Please provide an `Outlier label` variable"))
+ dplyr::filter(is_outlier | is_outlier_selected) %>% |
| 289 | +410 | ! |
- iv_out$enable()+ dplyr::select(-is_outlier) |
| 290 | +411 |
-
+ }, |
|
| 291 | +412 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ env = list( |
| 292 | +413 | ! |
- selector_list = selector_list,+ calculate_outliers = if (method == "IQR") {
|
| 293 | +414 | ! |
- datasets = data,+ substitute( |
| 294 | +415 | ! |
- join_keys = get_join_keys(data)+ expr = dplyr::mutate(is_outlier_selected = {
|
| 295 | -+ | ||
| 416 | +! |
- )+ q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75)) |
|
| 296 | -+ | ||
| 417 | +! |
-
+ iqr <- q1_q3[2] - q1_q3[1] |
|
| 297 | +418 | ! |
- regression_var <- reactive({
+ !(outlier_var_name >= q1_q3[1] - outlier_definition_param * iqr & |
| 298 | +419 | ! |
- teal::validate_inputs(iv_r())+ outlier_var_name <= q1_q3[2] + outlier_definition_param * iqr) |
| 299 | +420 |
-
+ }), |
|
| 300 | +421 | ! |
- list(+ env = list( |
| 301 | +422 | ! |
- response = as.vector(anl_merged_input()$columns_source$response),+ outlier_var_name = as.name(outlier_var), |
| 302 | +423 | ! |
- regressor = as.vector(anl_merged_input()$columns_source$regressor)+ outlier_definition_param = outlier_definition_param |
| 303 | +424 |
- )+ ) |
|
| 304 | +425 |
- })+ ) |
|
| 305 | -+ | ||
| 426 | +! |
-
+ } else if (method == "Z-score") {
|
|
| 306 | +427 | ! |
- anl_merged_q <- reactive({
+ substitute( |
| 307 | +428 | ! |
- req(anl_merged_input())+ expr = dplyr::mutate( |
| 308 | +429 | ! |
- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>%+ is_outlier_selected = abs(outlier_var_name - mean(outlier_var_name)) / |
| 309 | +430 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ stats::sd(outlier_var_name) > outlier_definition_param |
| 310 | +431 |
- })+ ),+ |
+ |
| 432 | +! | +
+ env = list(+ |
+ |
| 433 | +! | +
+ outlier_var_name = as.name(outlier_var),+ |
+ |
| 434 | +! | +
+ outlier_definition_param = outlier_definition_param |
|
| 311 | +435 |
-
+ ) |
|
| 312 | +436 |
- # sets qenv object and populates it with data merge call and fit expression+ ) |
|
| 313 | +437 | ! |
- fit_r <- reactive({
+ } else if (method == "Percentile") {
|
| 314 | +438 | ! |
- ANL <- anl_merged_q()[["ANL"]] # nolint+ substitute( |
| 315 | +439 | ! |
- teal::validate_has_data(ANL, 10)+ expr = dplyr::mutate( |
| 316 | -+ | ||
| 440 | +! |
-
+ is_outlier_selected = outlier_var_name < stats::quantile(outlier_var_name, outlier_definition_param) | |
|
| 317 | +441 | ! |
- validate(need(is.numeric(ANL[regression_var()$response][[1]]), "Response variable should be numeric."))+ outlier_var_name > stats::quantile(outlier_var_name, 1 - outlier_definition_param) |
| 318 | +442 |
-
+ ), |
|
| 319 | +443 | ! |
- teal::validate_has_data(+ env = list( |
| 320 | +444 | ! |
- ANL[, c(regression_var()$response, regression_var()$regressor)], 10,+ outlier_var_name = as.name(outlier_var), |
| 321 | +445 | ! |
- complete = TRUE, allow_inf = FALSE+ outlier_definition_param = outlier_definition_param |
| 322 | +446 |
- )+ ) |
|
| 323 | +447 |
-
+ ) |
|
| 324 | -! | +||
| 448 | +
- form <- stats::as.formula(+ }, |
||
| 325 | +449 | ! |
- paste(+ outlier_var_name = as.name(outlier_var), |
| 326 | +450 | ! |
- regression_var()$response,+ group_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
|
| 327 | +451 | ! |
- paste(+ substitute(dplyr::group_by(x), list(x = as.name(categorical_var)))+ |
+
| 452 | ++ |
+ }, |
|
| 328 | +453 | ! |
- regression_var()$regressor,+ ungroup_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
|
| 329 | +454 | ! |
- collapse = " + "+ substitute(dplyr::ungroup()) |
| 330 | +455 |
- ),+ } |
|
| 331 | -! | +||
| 456 | +
- sep = " ~ "+ ) |
||
| 332 | +457 |
- )+ ) %>%+ |
+ |
| 458 | +! | +
+ remove_pipe_null() |
|
| 333 | +459 |
) |
|
| 334 | +460 | ||
| 461 | ++ |
+ # ANL_OUTLIER_EXTENDED is the base table+ |
+ |
| 335 | +462 | ! |
- if (input$show_outlier) {
+ qenv <- teal.code::eval_code( |
| 336 | +463 | ! |
- opts <- teal.transform::variable_choices(ANL)+ qenv, |
| 337 | +464 | ! |
- selected <- if (!is.null(isolate(input$label_var)) && isolate(input$label_var) %in% as.character(opts)) {
+ substitute( |
| 338 | +465 | ! |
- isolate(input$label_var)+ expr = {
|
| 339 | -+ | ||
| 466 | +! |
- } else {
+ ANL_OUTLIER_EXTENDED <- dplyr::left_join( # nolint object_name_linter |
|
| 340 | +467 | ! |
- if (length(opts[as.character(opts) == default_outlier_label]) == 0) {
+ ANL_OUTLIER, |
| 341 | +468 | ! |
- opts[[1]]+ dplyr::select( |
| 342 | -+ | ||
| 469 | +! |
- } else {
+ dataname, |
|
| 343 | +470 | ! |
- opts[as.character(opts) == default_outlier_label]+ dplyr::setdiff(names(dataname), dplyr::setdiff(names(ANL_OUTLIER), join_keys)) |
| 344 | +471 |
- }+ ),+ |
+ |
| 472 | +! | +
+ by = join_keys |
|
| 345 | +473 |
- }+ ) |
|
| 346 | -! | +||
| 474 | +
- teal.widgets::updateOptionalSelectInput(+ }, |
||
| 347 | +475 | ! |
- session = session,+ env = list( |
| 348 | +476 | ! |
- inputId = "label_var",+ dataname = as.name(dataname_first), |
| 349 | +477 | ! |
- choices = opts,+ join_keys = as.character(get_join_keys(data)$get(dataname_first)[[dataname_first]]) |
| 350 | -! | +||
| 478 | +
- selected = selected+ ) |
||
| 351 | +479 |
) |
|
| 352 | +480 |
-
+ ) |
|
| 353 | -! | +||
| 481 | +
- data <- fortify(stats::lm(form, data = ANL))+ |
||
| 354 | +482 | ! |
- cooksd <- data$.cooksd[!is.nan(data$.cooksd)]+ if (length(categorical_var) > 0) {
|
| 355 | +483 | ! |
- max_outlier <- max(ceiling(max(cooksd) / mean(cooksd)), 2)+ qenv <- teal.code::eval_code( |
| 356 | +484 | ! |
- cur_outlier <- isolate(input$outlier)+ qenv, |
| 357 | +485 | ! |
- updateSliderInput(+ substitute( |
| 358 | +486 | ! |
- session = session,+ expr = summary_table_pre <- ANL_OUTLIER %>% |
| 359 | +487 | ! |
- inputId = "outlier",+ dplyr::filter(is_outlier_selected) %>% |
| 360 | +488 | ! |
- min = 1,+ dplyr::select(outlier_var_name, categorical_var_name) %>% |
| 361 | +489 | ! |
- max = max_outlier,+ dplyr::group_by(categorical_var_name) %>% |
| 362 | +490 | ! |
- value = if (cur_outlier < max_outlier) cur_outlier else max_outlier * .9- |
-
| 363 | -- |
- )- |
- |
| 364 | -- |
- }- |
- |
| 365 | -- |
-
+ dplyr::summarise(n_outliers = dplyr::n()) %>% |
|
| 366 | +491 | ! |
- anl_merged_q() %>%+ dplyr::right_join( |
| 367 | +492 | ! |
- teal.code::eval_code(substitute(fit <- stats::lm(form, data = ANL), env = list(form = form))) %>%+ ANL %>% |
| 368 | +493 | ! |
- teal.code::eval_code(quote({
+ dplyr::select(outlier_var_name, categorical_var_name) %>% |
| 369 | +494 | ! |
- for (regressor in names(fit$contrasts)) {
+ dplyr::group_by(categorical_var_name) %>% |
| 370 | +495 | ! |
- alts <- paste0(levels(ANL[[regressor]]), collapse = "|")+ dplyr::summarise( |
| 371 | +496 | ! |
- names(fit$coefficients) <- gsub(+ total_in_cat = dplyr::n(), |
| 372 | +497 | ! |
- paste0("^(", regressor, ")(", alts, ")$"), paste0("\\1", ": ", "\\2"), names(fit$coefficients)
+ n_na = sum(is.na(outlier_var_name) | is.na(categorical_var_name)) |
| 373 | +498 |
- )+ ), |
|
| 374 | -+ | ||
| 499 | +! |
- }+ by = categorical_var |
|
| 375 | +500 |
- })) %>%+ ) %>% |
|
| 376 | -! | +||
| 501 | +
- teal.code::eval_code(quote(summary(fit)))+ # This is important as there may be categorical variables with natural orderings, e.g. AGE. |
||
| 377 | +502 |
- })+ # The plots should be displayed by default in increasing order in these situations. |
|
| 378 | +503 |
-
+ # dplyr::arrange will sort integer, factor, and character data types in the expected way. |
|
| 379 | +504 | ! |
- label_col <- reactive({
+ dplyr::arrange(categorical_var_name) %>% |
| 380 | +505 | ! |
- teal::validate_inputs(iv_out)+ dplyr::mutate( |
| 381 | -+ | ||
| 506 | +! |
-
+ n_outliers = dplyr::if_else(is.na(n_outliers), 0, as.numeric(n_outliers)), |
|
| 382 | +507 | ! |
- substitute(+ display_str = dplyr::if_else( |
| 383 | +508 | ! |
- expr = dplyr::if_else(+ n_outliers > 0, |
| 384 | +509 | ! |
- data$.cooksd > outliers * mean(data$.cooksd, na.rm = TRUE),+ sprintf("%d [%.02f%%]", n_outliers, 100 * n_outliers / total_in_cat),
|
| 385 | +510 | ! |
- as.character(stats::na.omit(ANL)[[label_var]]),+ "0" |
| 386 | +511 |
- ""+ ), |
|
| 387 | -+ | ||
| 512 | +! |
- ) %>%+ display_str_na = dplyr::if_else( |
|
| 388 | +513 | ! |
- dplyr::if_else(is.na(.), "cooksd == NaN", .),+ n_na > 0, |
| 389 | +514 | ! |
- env = list(outliers = input$outlier, label_var = input$label_var)+ sprintf("%d [%.02f%%]", n_na, 100 * n_na / total_in_cat),
|
| 390 | -+ | ||
| 515 | +! |
- )+ "0" |
|
| 391 | +516 |
- })+ ),+ |
+ |
| 517 | +! | +
+ order = seq_along(n_outliers) |
|
| 392 | +518 |
-
+ ), |
|
| 393 | +519 | ! |
- outlier_label <- reactive({
+ env = list( |
| 394 | +520 | ! |
- substitute(+ categorical_var = categorical_var, |
| 395 | +521 | ! |
- expr = geom_text(label = label_col, hjust = 0, vjust = 1, color = "red"),+ categorical_var_name = as.name(categorical_var), |
| 396 | +522 | ! |
- env = list(label_col = label_col())+ outlier_var_name = as.name(outlier_var) |
| 397 | +523 |
- )+ ) |
|
| 398 | +524 |
- })+ ) |
|
| 399 | +525 |
-
+ )+ |
+ |
| 526 | ++ |
+ # now to handle when user chooses to order based on amount of outliers |
|
| 400 | +527 | ! |
- output_q <- reactive({
+ if (order_by_outlier) {
|
| 401 | +528 | ! |
- alpha <- input$alpha # nolint+ qenv <- teal.code::eval_code( |
| 402 | +529 | ! |
- size <- input$size # nolint+ qenv, |
| 403 | +530 | ! |
- ggtheme <- input$ggtheme # nolint+ quote( |
| 404 | +531 | ! |
- input_type <- input$plot_type+ summary_table_pre <- summary_table_pre %>% |
| 405 | +532 | ! |
- show_outlier <- input$show_outlier+ dplyr::arrange(desc(n_outliers / total_in_cat)) %>%+ |
+
| 533 | +! | +
+ dplyr::mutate(order = seq_len(nrow(summary_table_pre))) |
|
| 406 | +534 |
-
+ ) |
|
| 407 | -! | +||
| 535 | +
- teal::validate_inputs(iv_r())+ ) |
||
| 408 | +536 | ++ |
+ }+ |
+
| 537 | |||
| 409 | +538 | ! |
- plot_type_0 <- function() {
+ qenv <- teal.code::eval_code( |
| 410 | +539 | ! |
- fit <- fit_r()[["fit"]]+ qenv, |
| 411 | +540 | ! |
- ANL <- anl_merged_q()[["ANL"]] # nolint+ substitute(+ |
+
| 541 | +! | +
+ expr = {
|
|
| 412 | +542 |
-
+ # In order for geom_rug to work properly when reordering takes place inside facet_grid, |
|
| 413 | -! | +||
| 543 | +
- stopifnot(ncol(fit$model) == 2)+ # all tables must have the column used for reording. |
||
| 414 | +544 |
-
+ # In this case, the column used for reordering is `order`. |
|
| 415 | +545 | ! |
- if (!is.factor(ANL[[regression_var()$regressor]])) {
+ ANL_OUTLIER <- dplyr::left_join( # nolint |
| 416 | +546 | ! |
- shinyjs::show("size")
+ ANL_OUTLIER, |
| 417 | +547 | ! |
- shinyjs::show("alpha")
+ summary_table_pre[, c("order", categorical_var)],
|
| 418 | +548 | ! |
- plot <- substitute(+ by = categorical_var |
| 419 | -! | +||
| 549 | +
- env = list(+ )+ |
+ ||
| 550 | ++ |
+ # so that x axis of plot aligns with columns of summary table, from most outliers to least by percentage |
|
| 420 | +551 | ! |
- regressor = regression_var()$regressor,+ ANL <- ANL %>% # nolint |
| 421 | +552 | ! |
- response = regression_var()$response,+ dplyr::left_join( |
| 422 | +553 | ! |
- size = size,+ dplyr::select(summary_table_pre, categorical_var_name, order), |
| 423 | +554 | ! |
- alpha = alpha+ by = categorical_var |
| 424 | +555 |
- ),+ ) %>% |
|
| 425 | +556 | ! |
- expr = ggplot(+ dplyr::arrange(order) |
| 426 | +557 | ! |
- fit$model[, 2:1],+ summary_table <- summary_table_pre %>% |
| 427 | +558 | ! |
- aes_string(regressor, response)+ dplyr::select( |
| 428 | -- |
- ) ++ | |
| 559 | +! | +
+ categorical_var_name, |
|
| 429 | +560 | ! |
- geom_point(size = size, alpha = alpha) ++ Outliers = display_str, Missings = display_str_na, Total = total_in_cat+ |
+
| 561 | ++ |
+ ) %>% |
|
| 430 | +562 | ! |
- stat_smooth(+ dplyr::mutate_all(as.character) %>% |
| 431 | +563 | ! |
- method = "lm",+ tidyr::pivot_longer(-categorical_var_name) %>% |
| 432 | +564 | ! |
- formula = y ~ x,+ tidyr::pivot_wider(names_from = categorical_var, values_from = value) %>% |
| 433 | +565 | ! |
- se = FALSE+ tibble::column_to_rownames("name")
|
| 434 | -+ | ||
| 566 | +! |
- )+ summary_table |
|
| 435 | +567 |
- )- |
- |
| 436 | -! | -
- if (show_outlier) {
+ }, |
|
| 437 | +568 | ! |
- plot <- substitute(+ env = list( |
| 438 | +569 | ! |
- expr = plot + outlier_label,+ categorical_var = categorical_var, |
| 439 | +570 | ! |
- env = list(plot = plot, outlier_label = outlier_label())+ categorical_var_name = as.name(categorical_var) |
| 440 | +571 |
) |
|
| 441 | +572 |
- }+ ) |
|
| 442 | +573 |
- } else {
+ ) |
|
| 443 | -! | +||
| 574 | +
- shinyjs::hide("size")
+ } |
||
| 444 | -! | +||
| 575 | +
- shinyjs::hide("alpha")
+
|
||
| 445 | +576 | ! |
- plot <- substitute(+ if (length(categorical_var) > 0 && nrow(qenv[["ANL_OUTLIER"]]) > 0) {
|
| 446 | +577 | ! |
- expr = ggplot(fit$model[, 2:1], aes_string(regressor, response)) ++ shinyjs::show("order_by_outlier")
|
| 447 | -! | +||
| 578 | +
- geom_boxplot(),+ } else {
|
||
| 448 | +579 | ! |
- env = list(regressor = regression_var()$regressor, response = regression_var()$response)+ shinyjs::hide("order_by_outlier")
|
| 449 | +580 |
- )+ } |
|
| 450 | -! | +||
| 581 | +
- if (show_outlier) {
+
|
||
| 451 | +582 | ! |
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))- |
-
| 452 | -- |
- }+ qenv |
|
| 453 | +583 |
- }+ }) |
|
| 454 | +584 | ||
| 455 | +585 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ output$summary_table <- DT::renderDataTable( |
| 456 | +586 | ! |
- teal.widgets::resolve_ggplot2_args(+ expr = {
|
| 457 | +587 | ! |
- user_plot = ggplot2_args[["Response vs Regressor"]],+ if (iv_r()$is_valid()) {
|
| 458 | +588 | ! |
- user_default = ggplot2_args$default,+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
| 459 | +589 | ! |
- module_plot = teal.widgets::ggplot2_args(+ if (!is.null(categorical_var)) {
|
| 460 | +590 | ! |
- labs = list(+ DT::datatable( |
| 461 | +591 | ! |
- title = "Response vs Regressor",+ common_code_q()[["summary_table"]], |
| 462 | +592 | ! |
- x = varname_w_label(regression_var()$regressor, ANL),+ options = list( |
| 463 | +593 | ! |
- y = varname_w_label(regression_var()$response, ANL)+ dom = "t", |
| 464 | -+ | ||
| 594 | +! |
- ),+ autoWidth = TRUE, |
|
| 465 | +595 | ! |
- theme = list()+ columnDefs = list(list(width = "200px", targets = "_all")) |
| 466 | +596 |
- )+ ) |
|
| 467 | +597 |
- ),- |
- |
| 468 | -! | -
- ggtheme = ggtheme+ ) |
|
| 469 | +598 |
- )+ } |
|
| 470 | +599 |
-
+ } |
|
| 471 | -! | +||
| 600 | +
- teal.code::eval_code(+ } |
||
| 472 | -! | +||
| 601 | +
- fit_r(),+ ) |
||
| 473 | -! | +||
| 602 | +
- substitute(+ |
||
| 474 | -! | +||
| 603 | +
- expr = {
+ # boxplot/violinplot #nolint |
||
| 475 | +604 | ! |
- class(fit$residuals) <- NULL+ boxplot_q <- reactive({
|
| 476 | +605 | ! |
- data <- fortify(fit)+ req(common_code_q()) |
| 477 | +606 | ! |
- g <- plot+ ANL <- common_code_q()[["ANL"]] # nolint |
| 478 | +607 | ! |
- print(g)+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint |
| 479 | +608 |
- },+ |
|
| 480 | +609 | ! |
- env = list(+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
| 481 | +610 | ! |
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
| 482 | +611 |
- )+ |
|
| 483 | +612 |
- )+ # validation |
|
| 484 | -+ | ||
| 613 | +! |
- )+ teal::validate_has_data(ANL, 1) |
|
| 485 | +614 |
- }+ |
|
| 486 | +615 | - - | -|
| 487 | -! | -
- plot_base <- function() {
+ # boxplot |
|
| 488 | +616 | ! |
- base_fit <- fit_r()+ plot_call <- quote(ANL %>% ggplot()) # nolint |
| 489 | -! | +||
| 617 | +
- teal.code::eval_code(+ |
||
| 490 | +618 | ! |
- base_fit,+ plot_call <- if (input$boxplot_alts == "Box plot") {
|
| 491 | +619 | ! |
- quote({
+ substitute(expr = plot_call + geom_boxplot(outlier.shape = NA), env = list(plot_call = plot_call)) |
| 492 | +620 | ! |
- class(fit$residuals) <- NULL- |
-
| 493 | -- |
-
+ } else if (input$boxplot_alts == "Violin plot") {
|
|
| 494 | +621 | ! |
- data <- ggplot2::fortify(fit)+ substitute(expr = plot_call + geom_violin(), env = list(plot_call = plot_call)) |
| 495 | +622 | - - | -|
| 496 | -! | -
- smooth <- function(x, y) {
+ } else {
|
|
| 497 | +623 | ! |
- as.data.frame(stats::lowess(x, y, f = 2 / 3, iter = 3))+ NULL |
| 498 | +624 |
- }+ } |
|
| 499 | +625 | ||
| 500 | +626 | ! |
- smoothy_aes <- ggplot2::aes_string(x = "x", y = "y")- |
-
| 501 | -- |
-
+ plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
|
|
| 502 | +627 | ! |
- reg_form <- deparse(fit$call[[2]])- |
-
| 503 | -- |
- })+ inner_call <- substitute( |
|
| 504 | -+ | ||
| 628 | +! |
- )+ expr = plot_call + |
|
| 505 | -+ | ||
| 629 | +! |
- }+ aes(x = "Entire dataset", y = outlier_var_name) + |
|
| 506 | -+ | ||
| 630 | +! |
-
+ scale_x_discrete(), |
|
| 507 | +631 | ! |
- plot_type_1 <- function(plot_base) {
+ env = list(plot_call = plot_call, outlier_var_name = as.name(outlier_var)) |
| 508 | -! | +||
| 632 | +
- shinyjs::show("size")
+ ) |
||
| 509 | +633 | ! |
- shinyjs::show("alpha")
+ if (nrow(ANL_OUTLIER) > 0) {
|
| 510 | +634 | ! |
- plot <- substitute(+ substitute( |
| 511 | +635 | ! |
- expr = ggplot(data = data, aes(.fitted, .resid)) ++ expr = inner_call + geom_point( |
| 512 | +636 | ! |
- geom_point(size = size, alpha = alpha) ++ data = ANL_OUTLIER, |
| 513 | +637 | ! |
- geom_hline(yintercept = 0, linetype = "dashed", size = 1) ++ aes(x = "Entire dataset", y = outlier_var_name, color = is_outlier_selected) |
| 514 | -! | +||
| 638 | +
- geom_line(data = smoothy, mapping = smoothy_aes),+ ), |
||
| 515 | +639 | ! |
- env = list(size = size, alpha = alpha)+ env = list(inner_call = inner_call, outlier_var_name = as.name(outlier_var)) |
| 516 | +640 |
- )+ ) |
|
| 517 | -! | +||
| 641 | +
- if (show_outlier) {
+ } else {
|
||
| 518 | +642 | ! |
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))+ inner_call |
| 519 | +643 |
} |
|
| 520 | +644 | - - | -|
| 521 | -! | -
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ } else {
|
|
| 522 | +645 | ! |
- teal.widgets::resolve_ggplot2_args(+ substitute( |
| 523 | +646 | ! |
- user_plot = ggplot2_args[["Residuals vs Fitted"]],+ expr = plot_call + |
| 524 | +647 | ! |
- user_default = ggplot2_args$default,+ aes(y = outlier_var_name, x = reorder(categorical_var_name, order)) + |
| 525 | +648 | ! |
- module_plot = teal.widgets::ggplot2_args(+ xlab(categorical_var) + |
| 526 | +649 | ! |
- labs = list(+ scale_x_discrete() + |
| 527 | +650 | ! |
- x = quote(paste0("Fitted values\nlm(", reg_form, ")")),
+ geom_point( |
| 528 | +651 | ! |
- y = "Residuals",+ data = ANL_OUTLIER, |
| 529 | +652 | ! |
- title = "Residuals vs Fitted"+ aes(x = as.factor(categorical_var_name), y = outlier_var_name, color = is_outlier_selected) |
| 530 | +653 |
- )- |
- |
| 531 | -- |
- )- |
- |
| 532 | -- |
- ),+ ), |
|
| 533 | +654 | ! |
- ggtheme = ggtheme- |
-
| 534 | -- |
- )- |
- |
| 535 | -- |
-
+ env = list( |
|
| 536 | +655 | ! |
- teal.code::eval_code(+ plot_call = plot_call, |
| 537 | +656 | ! |
- plot_base,+ outlier_var_name = as.name(outlier_var), |
| 538 | +657 | ! |
- substitute(+ categorical_var_name = as.name(categorical_var), |
| 539 | +658 | ! |
- expr = {
+ categorical_var = categorical_var |
| 540 | -! | +||
| 659 | +
- smoothy <- smooth(data$.fitted, data$.resid)+ ) |
||
| 541 | -! | +||
| 660 | +
- g <- plot+ ) |
||
| 542 | -! | +||
| 661 | +
- print(g)+ } |
||
| 543 | +662 |
- },+ |
|
| 544 | +663 | ! |
- env = list(+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 545 | +664 | ! |
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
- |
-
| 546 | -- |
- )- |
- |
| 547 | -- |
- )+ labs = list(color = "Is outlier?"), |
|
| 548 | -+ | ||
| 665 | +! |
- )+ theme = list(legend.position = "top") |
|
| 549 | +666 |
- }+ ) |
|
| 550 | +667 | ||
| 551 | +668 | ! |
- plot_type_2 <- function(plot_base) {
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 552 | +669 | ! |
- shinyjs::show("size")
+ user_plot = ggplot2_args[["Boxplot"]], |
| 553 | +670 | ! |
- shinyjs::show("alpha")
+ user_default = ggplot2_args$default, |
| 554 | +671 | ! |
- plot <- substitute(+ module_plot = dev_ggplot2_args |
| 555 | -! | +||
| 672 | +
- expr = ggplot(data = data, aes(sample = .stdresid)) ++ )+ |
+ ||
| 673 | ++ | + | |
| 556 | +674 | ! |
- stat_qq(size = size, alpha = alpha) ++ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 557 | +675 | ! |
- geom_abline(linetype = "dashed"),+ all_ggplot2_args, |
| 558 | +676 | ! |
- env = list(size = size, alpha = alpha)+ ggtheme = input$ggtheme |
| 559 | +677 |
- )- |
- |
| 560 | -! | -
- if (show_outlier) {
+ ) |
|
| 561 | -! | +||
| 678 | +
- plot <- substitute(+ |
||
| 562 | +679 | ! |
- expr = plot ++ teal.code::eval_code( |
| 563 | +680 | ! |
- stat_qq(+ common_code_q(), |
| 564 | +681 | ! |
- geom = "text",+ substitute( |
| 565 | +682 | ! |
- label = label_col %>%+ expr = g <- plot_call + |
| 566 | +683 | ! |
- data.frame(label = .) %>%+ scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
|
| 567 | +684 | ! |
- dplyr::filter(label != "cooksd == NaN") %>%+ labs + ggthemes + themes, |
| 568 | +685 | ! |
- unlist(),+ env = list( |
| 569 | +686 | ! |
- hjust = 0,+ plot_call = plot_call, |
| 570 | +687 | ! |
- vjust = 1,+ labs = parsed_ggplot2_args$labs, |
| 571 | +688 | ! |
- color = "red"- |
-
| 572 | -- |
- ),+ ggthemes = parsed_ggplot2_args$ggtheme, |
|
| 573 | +689 | ! |
- env = list(plot = plot, label_col = label_col())+ themes = parsed_ggplot2_args$theme |
| 574 | +690 |
) |
|
| 575 | +691 |
- }+ ) |
|
| 576 | +692 |
-
+ ) %>% |
|
| 577 | +693 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ teal.code::eval_code(quote(print(g))) |
| 578 | -! | +||
| 694 | +
- teal.widgets::resolve_ggplot2_args(+ }) |
||
| 579 | -! | +||
| 695 | +
- user_plot = ggplot2_args[["Normal Q-Q"]],+ |
||
| 580 | -! | +||
| 696 | +
- user_default = ggplot2_args$default,+ # density plot |
||
| 581 | +697 | ! |
- module_plot = teal.widgets::ggplot2_args(+ density_plot_q <- reactive({
|
| 582 | +698 | ! |
- labs = list(+ ANL <- common_code_q()[["ANL"]] # nolint |
| 583 | +699 | ! |
- x = quote(paste0("Theoretical Quantiles\nlm(", reg_form, ")")),
+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint |
| 584 | -! | +||
| 700 | +
- y = "Standardized residuals",+ |
||
| 585 | +701 | ! |
- title = "Normal Q-Q"+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
| 586 | -+ | ||
| 702 | +! |
- )+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
|
| 587 | +703 |
- )+ |
|
| 588 | +704 |
- ),+ # validation |
|
| 589 | +705 | ! |
- ggtheme = ggtheme+ teal::validate_has_data(ANL, 1) |
| 590 | +706 |
- )+ # plot |
|
| 591 | -+ | ||
| 707 | +! |
-
+ plot_call <- substitute( |
|
| 592 | +708 | ! |
- teal.code::eval_code(+ expr = ANL %>% |
| 593 | +709 | ! |
- plot_base,+ ggplot(aes(x = outlier_var_name)) + |
| 594 | +710 | ! |
- substitute(+ geom_density() + |
| 595 | +711 | ! |
- expr = {
+ geom_rug(data = ANL_OUTLIER, aes(x = outlier_var_name, color = is_outlier_selected)) + |
| 596 | +712 | ! |
- g <- plot+ scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")),
|
| 597 | +713 | ! |
- print(g)+ env = list(outlier_var_name = as.name(outlier_var)) |
| 598 | +714 |
- },+ )+ |
+ |
| 715 | ++ | + | |
| 599 | +716 | ! |
- env = list(+ plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
|
| 600 | +717 | ! |
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ substitute(expr = plot_call, env = list(plot_call = plot_call)) |
| 601 | +718 |
- )+ } else {
|
|
| 602 | -+ | ||
| 719 | +! |
- )+ substitute(+ |
+ |
| 720 | +! | +
+ expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)),+ |
+ |
| 721 | +! | +
+ env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var)) |
|
| 603 | +722 |
) |
|
| 604 | +723 |
} |
|
| 605 | +724 | ||
| 606 | +725 | ! |
- plot_type_3 <- function(plot_base) {
+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 607 | +726 | ! |
- shinyjs::show("size")
+ labs = list(color = "Is outlier?"), |
| 608 | +727 | ! |
- shinyjs::show("alpha")
+ theme = list(legend.position = "top") |
| 609 | -! | +||
| 728 | +
- plot <- substitute(+ )+ |
+ ||
| 729 | ++ | + | |
| 610 | +730 | ! |
- expr = ggplot(data = data, aes(.fitted, sqrt(abs(.stdresid)))) ++ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 611 | +731 | ! |
- geom_point(size = size, alpha = alpha) ++ user_plot = ggplot2_args[["Density Plot"]], |
| 612 | +732 | ! |
- geom_line(data = smoothy, mapping = smoothy_aes),+ user_default = ggplot2_args$default, |
| 613 | +733 | ! |
- env = list(size = size, alpha = alpha)+ module_plot = dev_ggplot2_args |
| 614 | +734 |
- )+ )+ |
+ |
| 735 | ++ | + | |
| 615 | +736 | ! |
- if (show_outlier) {
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 616 | +737 | ! |
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))+ all_ggplot2_args,+ |
+
| 738 | +! | +
+ ggtheme = input$ggtheme |
|
| 617 | +739 |
- }+ ) |
|
| 618 | +740 | ||
| 619 | +741 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ teal.code::eval_code( |
| 620 | +742 | ! |
- teal.widgets::resolve_ggplot2_args(+ common_code_q(), |
| 621 | +743 | ! |
- user_plot = ggplot2_args[["Scale-Location"]],+ substitute( |
| 622 | +744 | ! |
- user_default = ggplot2_args$default,+ expr = g <- plot_call + labs + ggthemes + themes, |
| 623 | +745 | ! |
- module_plot = teal.widgets::ggplot2_args(+ env = list( |
| 624 | +746 | ! |
- labs = list(+ plot_call = plot_call, |
| 625 | +747 | ! |
- x = quote(paste0("Fitted values\nlm(", reg_form, ")")),
+ labs = parsed_ggplot2_args$labs, |
| 626 | +748 | ! |
- y = quote(expression(sqrt(abs(`Standardized residuals`)))),+ themes = parsed_ggplot2_args$theme, |
| 627 | +749 | ! |
- title = "Scale-Location"+ ggthemes = parsed_ggplot2_args$ggtheme |
| 628 | +750 |
- )+ ) |
|
| 629 | +751 |
- )+ ) |
|
| 630 | +752 |
- ),+ ) %>% |
|
| 631 | +753 | ! |
- ggtheme = ggtheme+ teal.code::eval_code(quote(print(g))) |
| 632 | +754 |
- )+ }) |
|
| 633 | +755 | ||
| 634 | -! | -
- teal.code::eval_code(- |
- |
| 635 | -! | +||
| 756 | +
- plot_base,+ # Cumulative distribution plot |
||
| 636 | +757 | ! |
- substitute(+ cumulative_plot_q <- reactive({
|
| 637 | +758 | ! |
- expr = {
+ ANL <- common_code_q()[["ANL"]] # nolint |
| 638 | +759 | ! |
- smoothy <- smooth(data$.fitted, sqrt(abs(data$.stdresid)))+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint |
| 639 | -! | +||
| 760 | +
- g <- plot+ |
||
| 640 | +761 | ! |
- print(g)+ qenv <- common_code_q() |
| 641 | +762 |
- },+ |
|
| 642 | +763 | ! |
- env = list(+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
| 643 | +764 | ! |
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
| 644 | +765 |
- )+ |
|
| 645 | +766 |
- )+ # validation |
|
| 646 | -+ | ||
| 767 | +! |
- )+ teal::validate_has_data(ANL, 1) |
|
| 647 | +768 |
- }+ |
|
| 648 | +769 |
-
+ # plot |
|
| 649 | +770 | ! |
- plot_type_4 <- function(plot_base) {
+ plot_call <- substitute( |
| 650 | +771 | ! |
- shinyjs::hide("size")
+ expr = ANL %>% ggplot(aes(x = outlier_var_name)) + |
| 651 | +772 | ! |
- shinyjs::show("alpha")
+ stat_ecdf(), |
| 652 | +773 | ! |
- plot <- substitute(+ env = list(outlier_var_name = as.name(outlier_var)) |
| 653 | -! | +||
| 774 | +
- expr = ggplot(data = data, aes(seq_along(.cooksd), .cooksd)) ++ ) |
||
| 654 | +775 | ! |
- geom_col(alpha = alpha),+ if (length(categorical_var) == 0) {
|
| 655 | +776 | ! |
- env = list(alpha = alpha)+ qenv <- teal.code::eval_code( |
| 656 | -+ | ||
| 777 | +! |
- )+ qenv, |
|
| 657 | +778 | ! |
- if (show_outlier) {
+ substitute( |
| 658 | +779 | ! |
- plot <- substitute(+ expr = {
|
| 659 | +780 | ! |
- expr = plot ++ ecdf_df <- ANL %>% |
| 660 | +781 | ! |
- geom_hline(+ dplyr::mutate( |
| 661 | +782 | ! |
- yintercept = c(+ y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]]) |
| 662 | -! | +||
| 783 | +
- outlier * mean(data$.cooksd, na.rm = TRUE),+ )+ |
+ ||
| 784 | ++ | + | |
| 663 | +785 | ! |
- mean(data$.cooksd, na.rm = TRUE)+ outlier_points <- dplyr::left_join( |
| 664 | -+ | ||
| 786 | +! |
- ),+ ecdf_df, |
|
| 665 | +787 | ! |
- color = "red",+ ANL_OUTLIER, |
| 666 | +788 | ! |
- linetype = "dashed"+ by = dplyr::setdiff(names(ecdf_df), "y") |
| 667 | +789 |
- ) ++ ) %>% |
|
| 668 | +790 | ! |
- geom_text(+ dplyr::filter(!is.na(is_outlier_selected)) |
| 669 | -! | +||
| 791 | +
- aes(+ }, |
||
| 670 | +792 | ! |
- x = 0,+ env = list(outlier_var = outlier_var) |
| 671 | -! | +||
| 793 | +
- y = mean(data$.cooksd, na.rm = TRUE),+ ) |
||
| 672 | -! | +||
| 794 | +
- label = paste("mu", "=", round(mean(data$.cooksd, na.rm = TRUE), 4)),
+ ) |
||
| 673 | -! | +||
| 795 | +
- vjust = -1,+ } else {
|
||
| 674 | +796 | ! |
- hjust = 0,+ qenv <- teal.code::eval_code( |
| 675 | +797 | ! |
- color = "red",+ qenv, |
| 676 | +798 | ! |
- angle = 90+ substitute( |
| 677 | -+ | ||
| 799 | +! |
- ),+ expr = {
|
|
| 678 | +800 | ! |
- parse = TRUE,+ all_categories <- lapply( |
| 679 | +801 | ! |
- show.legend = FALSE+ unique(ANL[[categorical_var]]), |
| 680 | -+ | ||
| 802 | +! |
- ) ++ function(x) {
|
|
| 681 | +803 | ! |
- outlier_label,+ ANL <- ANL %>% dplyr::filter(get(categorical_var) == x) # nolint |
| 682 | +804 | ! |
- env = list(plot = plot, outlier = input$outlier, outlier_label = outlier_label())+ anl_outlier2 <- ANL_OUTLIER %>% dplyr::filter(get(categorical_var) == x) |
| 683 | -+ | ||
| 805 | +! |
- )+ ecdf_df <- ANL %>% |
|
| 684 | -+ | ||
| 806 | +! |
- }+ dplyr::mutate(y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]])) |
|
| 685 | +807 | ||
| 686 | +808 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ dplyr::left_join( |
| 687 | +809 | ! |
- teal.widgets::resolve_ggplot2_args(+ ecdf_df, |
| 688 | +810 | ! |
- user_plot = ggplot2_args[["Cook's distance"]],+ anl_outlier2, |
| 689 | +811 | ! |
- user_default = ggplot2_args$default,+ by = dplyr::setdiff(names(ecdf_df), "y") |
| 690 | -! | +||
| 812 | +
- module_plot = teal.widgets::ggplot2_args(+ ) %>% |
||
| 691 | +813 | ! |
- labs = list(+ dplyr::filter(!is.na(is_outlier_selected)) |
| 692 | -! | +||
| 814 | +
- x = quote(paste0("Obs. number\nlm(", reg_form, ")")),
+ } |
||
| 693 | -! | +||
| 815 | +
- y = "Cook's distance",+ ) |
||
| 694 | +816 | ! |
- title = "Cook's distance"+ outlier_points <- do.call(rbind, all_categories) |
| 695 | +817 |
- )+ },+ |
+ |
| 818 | +! | +
+ env = list(categorical_var = categorical_var, outlier_var = outlier_var) |
|
| 696 | +819 |
- )+ ) |
|
| 697 | +820 |
- ),+ ) |
|
| 698 | +821 | ! |
- ggtheme = ggtheme+ plot_call <- substitute(+ |
+
| 822 | +! | +
+ expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)),+ |
+ |
| 823 | +! | +
+ env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var)) |
|
| 699 | +824 |
) |
|
| 700 | +825 | ++ |
+ }+ |
+
| 826 | |||
| 701 | +827 | ! |
- teal.code::eval_code(+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 702 | +828 | ! |
- plot_base,+ labs = list(color = "Is outlier?"), |
| 703 | +829 | ! |
- substitute(+ theme = list(legend.position = "top") |
| 704 | -! | +||
| 830 | +
- expr = {
+ ) |
||
| 705 | -! | +||
| 831 | +
- g <- plot+ |
||
| 706 | +832 | ! |
- print(g)+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 707 | -+ | ||
| 833 | +! |
- },+ user_plot = ggplot2_args[["Cumulative Distribution Plot"]], |
|
| 708 | +834 | ! |
- env = list(+ user_default = ggplot2_args$default, |
| 709 | +835 | ! |
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ module_plot = dev_ggplot2_args |
| 710 | +836 |
- )+ ) |
|
| 711 | +837 |
- )+ |
|
| 712 | -+ | ||
| 838 | +! |
- )+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 713 | -+ | ||
| 839 | +! |
- }+ all_ggplot2_args,+ |
+ |
| 840 | +! | +
+ ggtheme = input$ggtheme |
|
| 714 | +841 |
-
+ ) |
|
| 715 | +842 | ||
| 716 | +843 | ! |
- plot_type_5 <- function(plot_base) {
+ teal.code::eval_code( |
| 717 | +844 | ! |
- shinyjs::show("size")
+ qenv, |
| 718 | +845 | ! |
- shinyjs::show("alpha")
+ substitute( |
| 719 | +846 | ! |
- plot <- substitute(+ expr = g <- plot_call + |
| 720 | +847 | ! |
- expr = ggplot(data = data, aes(.hat, .stdresid)) ++ geom_point(data = outlier_points, aes(x = outlier_var_name, y = y, color = is_outlier_selected)) + |
| 721 | +848 | ! |
- geom_vline(+ scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
|
| 722 | +849 | ! |
- size = 1,+ labs + ggthemes + themes, |
| 723 | +850 | ! |
- colour = "black",+ env = list( |
| 724 | +851 | ! |
- linetype = "dashed",+ plot_call = plot_call, |
| 725 | +852 | ! |
- xintercept = 0- |
-
| 726 | -- |
- ) +- |
- |
| 727 | -! | -
- geom_hline(- |
- |
| 728 | -! | -
- size = 1,+ outlier_var_name = as.name(outlier_var), |
|
| 729 | +853 | ! |
- colour = "black",+ labs = parsed_ggplot2_args$labs, |
| 730 | +854 | ! |
- linetype = "dashed",+ themes = parsed_ggplot2_args$theme, |
| 731 | +855 | ! |
- yintercept = 0+ ggthemes = parsed_ggplot2_args$ggtheme |
| 732 | +856 |
- ) +- |
- |
| 733 | -! | -
- geom_point(size = size, alpha = alpha) +- |
- |
| 734 | -! | -
- geom_line(data = smoothy, mapping = smoothy_aes),- |
- |
| 735 | -! | -
- env = list(size = size, alpha = alpha)+ ) |
|
| 736 | +857 |
) |
|
| 737 | -! | +||
| 858 | +
- if (show_outlier) {
+ ) %>% |
||
| 738 | +859 | ! |
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))+ teal.code::eval_code(quote(print(g))) |
| 739 | +860 |
- }+ }) |
|
| 740 | +861 | ||
| 741 | +862 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ final_q <- reactive({
|
| 742 | +863 | ! |
- teal.widgets::resolve_ggplot2_args(+ req(input$tabs) |
| 743 | +864 | ! |
- user_plot = ggplot2_args[["Residuals vs Leverage"]],+ tab_type <- input$tabs |
| 744 | +865 | ! |
- user_default = ggplot2_args$default,+ result_q <- if (tab_type == "Boxplot") {
|
| 745 | +866 | ! |
- module_plot = teal.widgets::ggplot2_args(+ boxplot_q() |
| 746 | +867 | ! |
- labs = list(+ } else if (tab_type == "Density Plot") {
|
| 747 | +868 | ! |
- x = quote(paste0("Standardized residuals\nlm(", reg_form, ")")),
+ density_plot_q() |
| 748 | +869 | ! |
- y = "Leverage",+ } else if (tab_type == "Cumulative Distribution Plot") {
|
| 749 | +870 | ! |
- title = "Residuals vs Leverage"+ cumulative_plot_q() |
| 750 | +871 |
- )+ } |
|
| 751 | +872 |
- )+ # used to display table when running show-r-code code |
|
| 752 | +873 |
- ),- |
- |
| 753 | -! | -
- ggtheme = ggtheme+ # added after the plots so that a change in selected columns doesn't affect |
|
| 754 | +874 |
- )+ # brush selection. |
|
| 755 | -+ | ||
| 875 | +! |
-
+ teal.code::eval_code( |
|
| 756 | +876 | ! |
- teal.code::eval_code(+ result_q, |
| 757 | +877 | ! |
- plot_base,+ substitute( |
| 758 | +878 | ! |
- substitute(+ expr = {
|
| 759 | +879 | ! |
- expr = {
+ columns_index <- union( |
| 760 | +880 | ! |
- smoothy <- smooth(data$.hat, data$.stdresid)+ setdiff(names(ANL_OUTLIER), "is_outlier_selected"), |
| 761 | +881 | ! |
- g <- plot+ table_columns+ |
+
| 882 | ++ |
+ ) |
|
| 762 | +883 | ! |
- print(g)+ ANL_OUTLIER_EXTENDED[ANL_OUTLIER_EXTENDED$is_outlier_selected, columns_index] |
| 763 | +884 |
- },+ }, |
|
| 764 | +885 | ! |
- env = list(+ env = list( |
| 765 | +886 | ! |
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ table_columns = input$table_ui_columns |
| 766 | +887 |
- )+ ) |
|
| 767 | +888 |
- )+ ) |
|
| 768 | +889 |
- )+ ) |
|
| 769 | +890 |
- }+ }) |
|
| 770 | +891 | ||
| 771 | -! | +||
| 892 | +
- plot_type_6 <- function(plot_base) {
+ # slider text |
||
| 772 | +893 | ! |
- shinyjs::show("size")
+ output$ui_outlier_help <- renderUI({
|
| 773 | +894 | ! |
- shinyjs::show("alpha")
+ req(input$method) |
| 774 | +895 | ! |
- plot <- substitute(+ if (input$method == "IQR") {
|
| 775 | +896 | ! |
- expr = ggplot(data = data, aes(.hat, .cooksd)) ++ req(input$iqr_slider) |
| 776 | +897 | ! |
- geom_vline(xintercept = 0, colour = NA) ++ tags$small( |
| 777 | +898 | ! |
- geom_abline(+ withMathJax( |
| 778 | +899 | ! |
- slope = seq(0, 3, by = 0.5),+ helpText( |
| 779 | +900 | ! |
- colour = "black",+ "Outlier data points (\\(x \\lt Q1 - ", input$iqr_slider, "\\times IQR\\) or \\( |
| 780 | +901 | ! |
- linetype = "dashed",+ Q3 + ", input$iqr_slider, "\\times IQR \\lt x\\)) |
| 781 | +902 | ! |
- size = 1+ are displayed in red on the plot and can be visualized in the table below." |
| 782 | +903 |
- ) +- |
- |
| 783 | -! | -
- geom_line(data = smoothy, mapping = smoothy_aes) ++ ), |
|
| 784 | +904 | ! |
- geom_point(size = size, alpha = alpha),+ if (input$split_outliers) {
|
| 785 | +905 | ! |
- env = list(size = size, alpha = alpha)+ withMathJax(helpText("Note: Quantiles are calculated per group."))
|
| 786 | +906 |
- )- |
- |
| 787 | -! | -
- if (show_outlier) {
- |
- |
| 788 | -! | -
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))+ } |
|
| 789 | +907 |
- }+ ) |
|
| 790 | +908 |
-
+ ) |
|
| 791 | +909 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ } else if (input$method == "Z-score") {
|
| 792 | +910 | ! |
- teal.widgets::resolve_ggplot2_args(+ req(input$zscore_slider) |
| 793 | +911 | ! |
- user_plot = ggplot2_args[["Cook's dist vs Leverage"]],+ tags$small( |
| 794 | +912 | ! |
- user_default = ggplot2_args$default,+ withMathJax( |
| 795 | +913 | ! |
- module_plot = teal.widgets::ggplot2_args(+ helpText( |
| 796 | +914 | ! |
- labs = list(+ "Outlier data points (\\(Zscore(x) < -", input$zscore_slider, |
| 797 | +915 | ! |
- x = quote(paste0("Leverage\nlm(", reg_form, ")")),
+ "\\) or \\(", input$zscore_slider, "< Zscore(x) \\))
|
| 798 | +916 | ! |
- y = "Cooks's distance",+ are displayed in red on the plot and can be visualized in the table below."+ |
+
| 917 | ++ |
+ ), |
|
| 799 | +918 | ! |
- title = "Cook's dist vs Leverage"+ if (input$split_outliers) {
|
| 800 | -+ | ||
| 919 | +! |
- )+ withMathJax(helpText(" Note: Z-scores are calculated per group."))
|
|
| 801 | +920 |
- )+ } |
|
| 802 | +921 |
- ),- |
- |
| 803 | -! | -
- ggtheme = ggtheme+ ) |
|
| 804 | +922 |
) |
|
| 805 | -+ | ||
| 923 | +! |
-
+ } else if (input$method == "Percentile") {
|
|
| 806 | +924 | ! |
- teal.code::eval_code(+ req(input$percentile_slider) |
| 807 | +925 | ! |
- plot_base,+ tags$small( |
| 808 | +926 | ! |
- substitute(+ withMathJax( |
| 809 | +927 | ! |
- expr = {
+ helpText( |
| 810 | +928 | ! |
- smoothy <- smooth(data$.hat, data$.cooksd)+ "Outlier/extreme data points (\\( Percentile(x) <", input$percentile_slider, |
| 811 | +929 | ! |
- g <- plot+ "\\) or \\(", 1 - input$percentile_slider, " < Percentile(x) \\))
|
| 812 | +930 | ! |
- print(g)+ are displayed in red on the plot and can be visualized in the table below." |
| 813 | +931 |
- },+ ), |
|
| 814 | +932 | ! |
- env = list(+ if (input$split_outliers) {
|
| 815 | +933 | ! |
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ withMathJax(helpText("Note: Percentiles are calculated per group."))
|
| 816 | +934 |
- )+ } |
|
| 817 | +935 |
) |
|
| 818 | +936 |
) |
|
| 819 | +937 |
} |
|
| 820 | +938 | ++ |
+ })+ |
+
| 939 | |||
| 821 | +940 | ! |
- qenv <- if (input_type == "Response vs Regressor") {
+ boxplot_r <- reactive({
|
| 822 | +941 | ! |
- plot_type_0()+ teal::validate_inputs(iv_r()) |
| 823 | -+ | ||
| 942 | +! |
- } else {
+ boxplot_q()[["g"]] |
|
| 824 | -! | +||
| 943 | +
- plot_base_q <- plot_base()+ }) |
||
| 825 | +944 | ! |
- switch(input_type,+ density_plot_r <- reactive({
|
| 826 | +945 | ! |
- "Residuals vs Fitted" = plot_base_q %>% plot_type_1(),+ teal::validate_inputs(iv_r()) |
| 827 | +946 | ! |
- "Normal Q-Q" = plot_base_q %>% plot_type_2(),+ density_plot_q()[["g"]] |
| 828 | -! | +||
| 947 | +
- "Scale-Location" = plot_base_q %>% plot_type_3(),+ }) |
||
| 829 | +948 | ! |
- "Cook's distance" = plot_base_q %>% plot_type_4(),+ cumulative_plot_r <- reactive({
|
| 830 | +949 | ! |
- "Residuals vs Leverage" = plot_base_q %>% plot_type_5(),+ teal::validate_inputs(iv_r()) |
| 831 | +950 | ! |
- "Cook's dist vs Leverage" = plot_base_q %>% plot_type_6()+ cumulative_plot_q()[["g"]] |
| 832 | +951 |
- )+ }) |
|
| 833 | +952 |
- }+ |
|
| 834 | +953 | ! |
- qenv+ box_pws <- teal.widgets::plot_with_settings_srv( |
| 835 | -+ | ||
| 954 | +! |
- })+ id = "box_plot", |
|
| 836 | -+ | ||
| 955 | +! |
-
+ plot_r = boxplot_r, |
|
| 837 | -+ | ||
| 956 | +! |
-
+ height = plot_height, |
|
| 838 | +957 | ! |
- fitted <- reactive(output_q()[["fit"]])+ width = plot_width, |
| 839 | +958 | ! |
- plot_r <- reactive(output_q()[["g"]])+ brushing = TRUE |
| 840 | +959 |
-
+ ) |
|
| 841 | +960 |
- # Insert the plot into a plot_with_settings module from teal.widgets+ |
|
| 842 | +961 | ! |
- pws <- teal.widgets::plot_with_settings_srv(+ density_pws <- teal.widgets::plot_with_settings_srv( |
| 843 | +962 | ! |
- id = "myplot",+ id = "density_plot", |
| 844 | +963 | ! |
- plot_r = plot_r,+ plot_r = density_plot_r, |
| 845 | +964 | ! |
height = plot_height, |
| 846 | +965 | ! |
- width = plot_width+ width = plot_width,+ |
+
| 966 | +! | +
+ brushing = TRUE |
|
| 847 | +967 |
) |
|
| 848 | +968 | ||
| 849 | +969 | ! |
- output$text <- renderText({
+ cum_density_pws <- teal.widgets::plot_with_settings_srv( |
| 850 | +970 | ! |
- req(iv_r()$is_valid())+ id = "cum_density_plot", |
| 851 | +971 | ! |
- req(iv_out$is_valid())+ plot_r = cumulative_plot_r, |
| 852 | +972 | ! |
- paste(utils::capture.output(summary(teal.code::dev_suppress(fitted())))[-1],+ height = plot_height, |
| 853 | +973 | ! |
- collapse = "\n"+ width = plot_width, |
| 854 | -+ | ||
| 974 | +! |
- )+ brushing = TRUE |
|
| 855 | +975 |
- })+ ) |
|
| 856 | +976 | ||
| 857 | +977 | ! |
- teal.widgets::verbatim_popup_srv(+ choices <- teal.transform::variable_choices(data[[dataname_first]]()) |
| 858 | -! | +||
| 978 | +
- id = "warning",+ |
||
| 859 | +979 | ! |
- verbatim_content = reactive(teal.code::get_warnings(output_q())),+ observeEvent(common_code_q(), {
|
| 860 | +980 | ! |
- title = "Warning",+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint |
| 861 | +981 | ! |
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))- |
-
| 862 | -- |
- )- |
- |
| 863 | -- |
-
+ teal.widgets::updateOptionalSelectInput( |
|
| 864 | +982 | ! |
- teal.widgets::verbatim_popup_srv(+ session, |
| 865 | +983 | ! |
- id = "rcode",+ inputId = "table_ui_columns", |
| 866 | +984 | ! |
- verbatim_content = reactive(teal.code::get_code(output_q())),+ choices = dplyr::setdiff(choices, names(ANL_OUTLIER)), |
| 867 | +985 | ! |
- title = "R code for the regression plot",+ selected = isolate(input$table_ui_columns) |
| 868 | +986 |
- )+ ) |
|
| 869 | +987 |
-
+ }) |
|
| 870 | +988 |
- ### REPORTER+ |
|
| 871 | +989 | ! |
- if (with_reporter) {
+ output$table_ui <- DT::renderDataTable( |
| 872 | +990 | ! |
- card_fun <- function(comment) {
+ expr = {
|
| 873 | +991 | ! |
- card <- teal::TealReportCard$new()+ tab <- input$tabs |
| 874 | +992 | ! |
- card$set_name("Linear Regression Plot")
+ req(tab) # tab is NULL upon app launch, hence will crash without this statement |
| 875 | +993 | ! |
- card$append_text("Linear Regression Plot", "header2")
+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var) |
| 876 | +994 | ! |
- if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ |
+
| 995 | ++ | + | |
| 877 | +996 | ! |
- card$append_text("Plot", "header3")
+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint |
| 878 | +997 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ ANL_OUTLIER_EXTENDED <- common_code_q()[["ANL_OUTLIER_EXTENDED"]] # nolint |
| 879 | +998 | ! |
- if (!comment == "") {
+ ANL <- common_code_q()[["ANL"]] # nolint |
| 880 | +999 | ! |
- card$append_text("Comment", "header3")
+ plot_brush <- if (tab == "Boxplot") {
|
| 881 | +1000 | ! |
- card$append_text(comment)+ boxplot_r() |
| 882 | -+ | ||
| 1001 | +! |
- }+ box_pws$brush() |
|
| 883 | +1002 | ! |
- card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n"))+ } else if (tab == "Density Plot") {
|
| 884 | +1003 | ! |
- card+ density_plot_r() |
| 885 | -+ | ||
| 1004 | +! |
- }+ density_pws$brush() |
|
| 886 | +1005 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ } else if (tab == "Cumulative Distribution Plot") {
|
| 887 | -+ | ||
| 1006 | +! |
- }+ cumulative_plot_r() |
|
| 888 | -+ | ||
| 1007 | +! |
- ###+ cum_density_pws$brush() |
|
| 889 | +1008 |
- })+ } |
|
| 890 | +1009 |
- }+ |
|
| 891 | +1010 |
-
+ # removing unused column ASAP |
|
| 892 | -+ | ||
| 1011 | +! |
- regression_names <- paste0(+ ANL_OUTLIER$order <- ANL$order <- NULL # nolint |
|
| 893 | +1012 |
- '"Response vs Regressor", "Residuals vs Fitted", ',+ |
|
| 894 | -+ | ||
| 1013 | +! |
- '"Scale-Location", "Cook\'s distance", "Residuals vs Leverage"", "Cook\'s dist vs Leverage"'+ display_table <- if (!is.null(plot_brush)) {
|
|
| 895 | -+ | ||
| 1014 | +! |
- )+ if (length(categorical_var) > 0) {
|
| 1 | +1015 |
- #' Outliers Module+ # due to reordering, the x-axis label may be changed to something like "reorder(categorical_var, order)" |
|
| 2 | -+ | ||
| 1016 | +! |
- #'+ if (tab == "Boxplot") {
|
|
| 3 | -+ | ||
| 1017 | +! |
- #' Module to analyze and identify outliers using different methods+ plot_brush$mapping$x <- categorical_var |
|
| 4 | +1018 |
- #'+ } else {
|
|
| 5 | +1019 |
- #' @inheritParams teal::module+ # the other plots use facetting |
|
| 6 | +1020 |
- #' @inheritParams shared_params+ # so it is panelvar1 that gets relabelled to "reorder(categorical_var, order)" |
|
| 7 | -+ | ||
| 1021 | +! |
- #'+ plot_brush$mapping$panelvar1 <- categorical_var |
|
| 8 | +1022 |
- #' @param outlier_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ } |
|
| 9 | +1023 |
- #' variable to consider for the outliers analysis.+ } else {
|
|
| 10 | -+ | ||
| 1024 | +! |
- #' @param categorical_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ if (tab == "Boxplot") {
|
|
| 11 | +1025 |
- #' categorical factor to split the selected outlier variables on.+ # in boxplot with no categorical variable, there is no column in ANL that would correspond to x-axis |
|
| 12 | +1026 |
- #'+ # so a column needs to be inserted with the value "Entire dataset" because that's the label used in plot |
|
| 13 | -+ | ||
| 1027 | +! |
- #' @templateVar ggnames "Boxplot","Density Plot","Cumulative Distribution Plot"+ ANL[[plot_brush$mapping$x]] <- "Entire dataset" # nolint |
|
| 14 | +1028 |
- #' @template ggplot2_args_multi+ } |
|
| 15 | +1029 |
- #'+ } |
|
| 16 | +1030 |
- #' @export+ |
|
| 17 | +1031 |
- #'+ # in density and cumulative plots, ANL does not have a column corresponding to y-axis. |
|
| 18 | +1032 |
- #' @examples+ # so they need to be computed and attached to ANL |
|
| 19 | -+ | ||
| 1033 | +! |
- #'+ if (tab == "Density Plot") {
|
|
| 20 | -+ | ||
| 1034 | +! |
- #' ADSL <- teal.modules.general::rADSL+ plot_brush$mapping$y <- "density" |
|
| 21 | -+ | ||
| 1035 | +! |
- #'+ ANL$density <- plot_brush$ymin # nolint #either ymin or ymax will work |
|
| 22 | -+ | ||
| 1036 | +! |
- #' fact_vars_adsl <- names(Filter(isTRUE, sapply(ADSL, is.factor)))+ } else if (tab == "Cumulative Distribution Plot") {
|
|
| 23 | -+ | ||
| 1037 | +! |
- #' vars <- choices_selected(variable_choices(ADSL, fact_vars_adsl))+ plot_brush$mapping$y <- "cdf" |
|
| 24 | -+ | ||
| 1038 | +! |
- #'+ if (length(categorical_var) > 0) {
|
|
| 25 | -+ | ||
| 1039 | +! |
- #' app <- teal::init(+ ANL <- ANL %>% # nolint |
|
| 26 | -+ | ||
| 1040 | +! |
- #' data = teal.data::cdisc_data(+ dplyr::group_by(!!as.name(plot_brush$mapping$panelvar1)) %>% |
|
| 27 | -+ | ||
| 1041 | +! |
- #' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
+ dplyr::mutate(cdf = stats::ecdf(!!as.name(outlier_var))(!!as.name(outlier_var))) |
|
| 28 | +1042 |
- #' check = TRUE+ } else {
|
|
| 29 | -+ | ||
| 1043 | +! |
- #' ),+ ANL$cdf <- stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]]) # nolint |
|
| 30 | +1044 |
- #' modules = teal::modules(+ } |
|
| 31 | +1045 |
- #' teal.modules.general::tm_outliers(+ } |
|
| 32 | +1046 |
- #' outlier_var = list(+ |
|
| 33 | -+ | ||
| 1047 | +! |
- #' teal.transform::data_extract_spec(+ brushed_rows <- brushedPoints(ANL, plot_brush) |
|
| 34 | -+ | ||
| 1048 | +! |
- #' dataname = "ADSL",+ if (nrow(brushed_rows) > 0) {
|
|
| 35 | +1049 |
- #' select = select_spec(+ # now we need to remove extra column from ANL so that it will have the same columns as ANL_OUTLIER |
|
| 36 | +1050 |
- #' label = "Select variable:",+ # so that dplyr::intersect will work |
|
| 37 | -- |
- #' choices = variable_choices(ADSL, c("AGE", "BMRKR1")),
- |
- |
| 38 | -- |
- #' selected = "AGE",- |
- |
| 39 | -- |
- #' multiple = FALSE,- |
- |
| 40 | -+ | ||
| 1051 | +! |
- #' fixed = FALSE+ if (tab == "Density Plot") {
|
|
| 41 | -+ | ||
| 1052 | +! |
- #' )+ brushed_rows$density <- NULL |
|
| 42 | -+ | ||
| 1053 | +! |
- #' )+ } else if (tab == "Cumulative Distribution Plot") {
|
|
| 43 | -+ | ||
| 1054 | +! |
- #' ),+ brushed_rows$cdf <- NULL |
|
| 44 | -+ | ||
| 1055 | +! |
- #' categorical_var = list(+ } else if (tab == "Boxplot" && length(categorical_var) == 0) {
|
|
| 45 | -+ | ||
| 1056 | +! |
- #' teal.transform::data_extract_spec(+ brushed_rows[[plot_brush$mapping$x]] <- NULL |
|
| 46 | +1057 |
- #' dataname = "ADSL",+ } |
|
| 47 | +1058 |
- #' filter = teal.transform::filter_spec(+ # is_outlier_selected is part of ANL_OUTLIER so needed here |
|
| 48 | -+ | ||
| 1059 | +! |
- #' vars = vars,+ brushed_rows$is_outlier_selected <- TRUE |
|
| 49 | -+ | ||
| 1060 | +! |
- #' choices = value_choices(ADSL, vars$selected),+ dplyr::intersect(ANL_OUTLIER, brushed_rows) |
|
| 50 | +1061 |
- #' selected = value_choices(ADSL, vars$selected),+ } else {
|
|
| 51 | -+ | ||
| 1062 | +! |
- #' multiple = TRUE+ ANL_OUTLIER[0, ] |
|
| 52 | +1063 |
- #' )+ } |
|
| 53 | +1064 |
- #' )+ } else {
|
|
| 54 | -+ | ||
| 1065 | +! |
- #' ),+ ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ] |
|
| 55 | +1066 |
- #' ggplot2_args = list(+ } |
|
| 56 | +1067 |
- #' teal.widgets::ggplot2_args(+ |
|
| 57 | -+ | ||
| 1068 | +! |
- #' labs = list(subtitle = "Plot generated by Outliers Module")+ display_table$is_outlier_selected <- NULL |
|
| 58 | +1069 |
- #' )+ |
|
| 59 | +1070 |
- #' )+ # Extend the brushed ANL_OUTLIER with additional columns |
|
| 60 | -+ | ||
| 1071 | +! |
- #' )+ dplyr::left_join( |
|
| 61 | -+ | ||
| 1072 | +! |
- #' )+ display_table, |
|
| 62 | -+ | ||
| 1073 | +! |
- #' )+ dplyr::select(ANL_OUTLIER_EXTENDED, -"is_outlier_selected"), |
|
| 63 | -+ | ||
| 1074 | +! |
- #' if (interactive()) {
+ by = names(display_table) |
|
| 64 | +1075 |
- #' shinyApp(app$ui, app$server)+ ) %>% |
|
| 65 | -+ | ||
| 1076 | +! |
- #' }+ dplyr::select(union(names(display_table), input$table_ui_columns)) |
|
| 66 | +1077 |
- #'+ }, |
|
| 67 | -+ | ||
| 1078 | +! |
- tm_outliers <- function(label = "Outliers Module",+ options = list( |
|
| 68 | -+ | ||
| 1079 | +! |
- outlier_var,+ searching = FALSE, language = list( |
|
| 69 | -+ | ||
| 1080 | +! |
- categorical_var = NULL,+ zeroRecords = "The brushed area does not contain outlier observations for the currently defined threshold" |
|
| 70 | +1081 |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
+ ), |
|
| 71 | -+ | ||
| 1082 | +! |
- ggplot2_args = teal.widgets::ggplot2_args(),+ pageLength = input$table_ui_rows |
|
| 72 | +1083 |
- plot_height = c(600, 200, 2000),+ ) |
|
| 73 | +1084 |
- plot_width = NULL,+ ) |
|
| 74 | +1085 |
- pre_output = NULL,+ |
|
| 75 | -+ | ||
| 1086 | +! |
- post_output = NULL) {
+ output$total_outliers <- renderUI({
|
|
| 76 | +1087 | ! |
- logger::log_info("Initializing tm_outliers")
+ shiny::req(iv_r()$is_valid()) |
| 77 | +1088 | ! |
- if (inherits(outlier_var, "data_extract_spec")) outlier_var <- list(outlier_var)+ ANL <- merged$anl_q_r()[["ANL"]] # nolint |
| 78 | +1089 | ! |
- if (inherits(categorical_var, "data_extract_spec")) categorical_var <- list(categorical_var)+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint |
| 79 | +1090 | ! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ teal::validate_has_data(ANL, 1) |
| 80 | -+ | ||
| 1091 | +! |
-
+ ANL_OUTLIER_SELECTED <- ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ] # nolint |
|
| 81 | +1092 | ! |
- ggtheme <- match.arg(ggtheme)+ h5( |
| 82 | +1093 | ! |
- checkmate::assert_string(label)+ sprintf( |
| 83 | +1094 | ! |
- checkmate::assert_list(outlier_var, types = "data_extract_spec")+ "%s %d / %d [%.02f%%]", |
| 84 | +1095 | ! |
- checkmate::assert_list(categorical_var, types = "data_extract_spec", null.ok = TRUE)+ "Total number of outlier(s):", |
| 85 | +1096 | ! |
- if (is.list(categorical_var)) {
+ nrow(ANL_OUTLIER_SELECTED), |
| 86 | +1097 | ! |
- lapply(categorical_var, function(x) {
+ nrow(ANL), |
| 87 | +1098 | ! |
- if (length(x$filter) > 1L) {
+ 100 * nrow(ANL_OUTLIER_SELECTED) / nrow(ANL) |
| 88 | -! | +||
| 1099 | +
- stop("tm_outliers: categorical_var data_extract_specs may only specify one filter_spec", call. = FALSE)
+ ) |
||
| 89 | +1100 |
- }+ ) |
|
| 90 | +1101 |
}) |
|
| 91 | +1102 |
- }+ |
|
| 92 | +1103 | ! |
- plot_choices <- c("Boxplot", "Density Plot", "Cumulative Distribution Plot")
+ output$total_missing <- renderUI({
|
| 93 | +1104 | ! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ if (n_outlier_missing() > 0) {
|
| 94 | +1105 | ! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ ANL <- merged$anl_q_r()[["ANL"]] # nolint |
| 95 | -+ | ||
| 1106 | +! |
-
+ helpText( |
|
| 96 | +1107 | ! |
- args <- as.list(environment())+ sprintf( |
| 97 | -+ | ||
| 1108 | +! |
-
+ "%s %d / %d [%.02f%%]", |
|
| 98 | +1109 | ! |
- data_extract_list <- list(+ "Total number of row(s) with missing values:", |
| 99 | +1110 | ! |
- outlier_var = outlier_var,+ n_outlier_missing(), |
| 100 | +1111 | ! |
- categorical_var = categorical_var+ nrow(ANL),+ |
+
| 1112 | +! | +
+ 100 * (n_outlier_missing()) / nrow(ANL) |
|
| 101 | +1113 |
- )+ ) |
|
| 102 | +1114 |
-
+ ) |
|
| 103 | -! | +||
| 1115 | +
- module(+ } |
||
| 104 | -! | +||
| 1116 | +
- label = label,+ }) |
||
| 105 | -! | +||
| 1117 | +
- server = srv_outliers,+ |
||
| 106 | +1118 | ! |
- server_args = c(+ output$table_ui_wrap <- renderUI({
|
| 107 | +1119 | ! |
- data_extract_list,+ shiny::req(iv_r()$is_valid()) |
| 108 | +1120 | ! |
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)- |
-
| 109 | -- |
- ),+ tagList( |
|
| 110 | +1121 | ! |
- ui = ui_outliers,+ teal.widgets::optionalSelectInput( |
| 111 | +1122 | ! |
- ui_args = args,+ inputId = session$ns("table_ui_columns"),
|
| 112 | +1123 | ! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ label = "Choose additional columns", |
| 113 | -+ | ||
| 1124 | +! |
- )+ choices = NULL, |
|
| 114 | -+ | ||
| 1125 | +! |
- }+ selected = NULL, |
|
| 115 | -+ | ||
| 1126 | +! |
-
+ multiple = TRUE |
|
| 116 | +1127 |
- ui_outliers <- function(id, ...) {
+ ), |
|
| 117 | +1128 | ! |
- args <- list(...)+ h4("Outlier Table"),
|
| 118 | +1129 | ! |
- ns <- NS(id)+ teal.widgets::get_dt_rows(session$ns("table_ui"), session$ns("table_ui_rows")),
|
| 119 | +1130 | ! |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$outlier_var, args$categorical_var)+ DT::dataTableOutput(session$ns("table_ui"))
|
| 120 | +1131 |
-
+ ) |
|
| 121 | -! | +||
| 1132 | +
- teal.widgets::standard_layout(+ }) |
||
| 122 | -! | +||
| 1133 | +
- output = teal.widgets::white_small_well(+ |
||
| 123 | +1134 | ! |
- uiOutput(ns("total_outliers")),
+ teal.widgets::verbatim_popup_srv( |
| 124 | +1135 | ! |
- DT::dataTableOutput(ns("summary_table")),
+ id = "warning", |
| 125 | +1136 | ! |
- uiOutput(ns("total_missing")),
+ verbatim_content = reactive(teal.code::get_warnings(final_q())), |
| 126 | +1137 | ! |
- br(), hr(),+ title = "Warning", |
| 127 | +1138 | ! |
- tabsetPanel(- |
-
| 128 | -! | -
- id = ns("tabs"),
- |
- |
| 129 | -! | -
- tabPanel(- |
- |
| 130 | -! | -
- "Boxplot",- |
- |
| 131 | -! | -
- teal.widgets::plot_with_settings_ui(id = ns("box_plot"))
+ disabled = reactive(is.null(teal.code::get_warnings(final_q()))) |
|
| 132 | +1139 |
- ),+ ) |
|
| 133 | -! | +||
| 1140 | +
- tabPanel(+ |
||
| 134 | +1141 | ! |
- "Density Plot",+ teal.widgets::verbatim_popup_srv( |
| 135 | +1142 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("density_plot"))
- |
-
| 136 | -- |
- ),+ id = "rcode", |
|
| 137 | +1143 | ! |
- tabPanel(+ verbatim_content = reactive(teal.code::get_code(final_q())), |
| 138 | +1144 | ! |
- "Cumulative Distribution Plot",+ title = "Show R Code for Outlier" |
| 139 | -! | +||
| 1145 | +
- teal.widgets::plot_with_settings_ui(id = ns("cum_density_plot"))
+ ) |
||
| 140 | +1146 |
- )+ |
|
| 141 | +1147 |
- ),+ ### REPORTER |
|
| 142 | +1148 | ! |
- br(), hr(),+ if (with_reporter) {
|
| 143 | +1149 | ! |
- uiOutput(ns("table_ui_wrap"))
+ card_fun <- function(comment, label) {
|
| 144 | -+ | ||
| 1150 | +! |
- ),+ tab_type <- input$tabs |
|
| 145 | +1151 | ! |
- encoding = div(+ card <- teal::report_card_template( |
| 146 | -+ | ||
| 1152 | +! |
- ### Reporter+ title = paste0("Outliers - ", tab_type),
|
|
| 147 | +1153 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ label = label, |
| 148 | -+ | ||
| 1154 | +! |
- ###+ with_filter = with_filter, |
|
| 149 | +1155 | ! |
- tags$label("Encodings", class = "text-primary"),
+ filter_panel_api = filter_panel_api |
| 150 | -! | +||
| 1156 | +
- teal.transform::datanames_input(args[c("outlier_var", "categorical_var")]),
+ ) |
||
| 151 | +1157 | ! |
- teal.transform::data_extract_ui(+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var) |
| 152 | +1158 | ! |
- id = ns("outlier_var"),
+ if (length(categorical_var) > 0) {
|
| 153 | +1159 | ! |
- label = "Variable",+ summary_table <- common_code_q()[["summary_table"]] |
| 154 | +1160 | ! |
- data_extract_spec = args$outlier_var,+ card$append_text("Summary Table", "header3")
|
| 155 | +1161 | ! |
- is_single_dataset = is_single_dataset_value+ card$append_table(summary_table) |
| 156 | +1162 |
- ),+ } |
|
| 157 | +1163 | ! |
- if (!is.null(args$categorical_var)) {
+ card$append_text("Plot", "header3")
|
| 158 | +1164 | ! |
- teal.transform::data_extract_ui(+ if (tab_type == "Boxplot") {
|
| 159 | +1165 | ! |
- id = ns("categorical_var"),
+ card$append_plot(boxplot_r(), dim = box_pws$dim()) |
| 160 | +1166 | ! |
- label = "Categorical factor",+ } else if (tab_type == "Density Plot") {
|
| 161 | +1167 | ! |
- data_extract_spec = args$categorical_var,+ card$append_plot(density_plot_r(), dim = density_pws$dim()) |
| 162 | +1168 | ! |
- is_single_dataset = is_single_dataset_value+ } else if (tab_type == "Cumulative Distribution Plot") {
|
| 163 | -+ | ||
| 1169 | +! |
- )+ card$append_plot(cumulative_plot_r(), dim = cum_density_pws$dim()) |
|
| 164 | +1170 |
- },+ } |
|
| 165 | +1171 | ! |
- conditionalPanel(+ if (!comment == "") {
|
| 166 | +1172 | ! |
- condition = paste0("input['", ns("tabs"), "'] == 'Boxplot'"),
+ card$append_text("Comment", "header3")
|
| 167 | +1173 | ! |
- teal.widgets::optionalSelectInput(+ card$append_text(comment) |
| 168 | -! | +||
| 1174 | +
- inputId = ns("boxplot_alts"),
+ } |
||
| 169 | +1175 | ! |
- label = "Plot type",+ card$append_src(paste(teal.code::get_code(final_q()), collapse = "\n")) |
| 170 | +1176 | ! |
- choices = c("Box plot", "Violin plot"),
+ card |
| 171 | -! | +||
| 1177 | +
- selected = "Box plot",+ } |
||
| 172 | +1178 | ! |
- multiple = FALSE+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 173 | +1179 |
- )+ } |
|
| 174 | +1180 |
- ),+ ### |
|
| 175 | -! | +||
| 1181 | +
- shinyjs::hidden(checkboxInput(ns("split_outliers"), "Define outliers based on group splitting", value = FALSE)),
+ }) |
||
| 176 | -! | +||
| 1182 | +
- shinyjs::hidden(checkboxInput(ns("order_by_outlier"), "Re-order categories by outliers [by %]", value = FALSE)),
+ } |
||
| 177 | -! | +
| 1 | +
- teal.widgets::panel_group(+ #' Missing data module |
||
| 178 | -! | +||
| 2 | +
- teal.widgets::panel_item(+ #' |
||
| 179 | -! | +||
| 3 | +
- title = "Method parameters",+ #' Present analysis of missing observations and patients. |
||
| 180 | -! | +||
| 4 | +
- collapsed = FALSE,+ #' |
||
| 181 | -! | +||
| 5 | +
- teal.widgets::optionalSelectInput(+ #' @inheritParams teal::module |
||
| 182 | -! | +||
| 6 | +
- inputId = ns("method"),
+ #' @inheritParams shared_params |
||
| 183 | -! | +||
| 7 | +
- label = "Method",+ #' @param parent_dataname (`character(1)`) If this `dataname` exists in then "the by subject"graph is displayed. |
||
| 184 | -! | +||
| 8 | +
- choices = c("IQR", "Z-score", "Percentile"),
+ #' For `CDISC` data. In non `CDISC` data this can be ignored. Defaults to `"ADSL"`. |
||
| 185 | -! | +||
| 9 | +
- selected = "IQR",+ #' @param ggtheme optional, (`character`) `ggplot2` theme to be used by default. |
||
| 186 | -! | +||
| 10 | +
- multiple = FALSE+ #' One of `c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test")`.
|
||
| 187 | +11 |
- ),+ #' Each theme can be chosen by the user during the session. Defaults to `"classic"`. |
|
| 188 | -! | +||
| 12 | +
- conditionalPanel(+ #' |
||
| 189 | -! | +||
| 13 | +
- condition =+ #' @templateVar ggnames "Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject" |
||
| 190 | -! | +||
| 14 | +
- paste0("input['", ns("method"), "'] == 'IQR'"),
+ #' @template ggplot2_args_multi |
||
| 191 | -! | +||
| 15 | +
- sliderInput(+ #' |
||
| 192 | -! | +||
| 16 | +
- ns("iqr_slider"),
+ #' @export |
||
| 193 | -! | +||
| 17 | +
- "Outlier range:",+ #' |
||
| 194 | -! | +||
| 18 | +
- min = 1,+ #' @examples |
||
| 195 | -! | +||
| 19 | +
- max = 5,+ #' library(nestcolor) |
||
| 196 | -! | +||
| 20 | +
- value = 3,+ #' |
||
| 197 | -! | +||
| 21 | +
- step = 0.5+ #' ADSL <- teal.modules.general::rADSL |
||
| 198 | +22 |
- )+ #' ADRS <- teal.modules.general::rADRS |
|
| 199 | +23 |
- ),+ #' |
|
| 200 | -! | +||
| 24 | +
- conditionalPanel(+ #' app <- teal::init( |
||
| 201 | -! | +||
| 25 | +
- condition =+ #' data = teal.data::cdisc_data( |
||
| 202 | -! | +||
| 26 | +
- paste0("input['", ns("method"), "'] == 'Z-score'"),
+ #' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
|
||
| 203 | -! | +||
| 27 | +
- sliderInput(+ #' teal.data::cdisc_dataset("ADRS", ADRS, code = "ADRS <- teal.modules.general::rADRS"),
|
||
| 204 | -! | +||
| 28 | +
- ns("zscore_slider"),
+ #' check = TRUE |
||
| 205 | -! | +||
| 29 | +
- "Outlier range:",+ #' ), |
||
| 206 | -! | +||
| 30 | +
- min = 1,+ #' modules = teal::modules( |
||
| 207 | -! | +||
| 31 | +
- max = 5,+ #' teal.modules.general::tm_missing_data( |
||
| 208 | -! | +||
| 32 | +
- value = 3,+ #' ggplot2_args = list( |
||
| 209 | -! | +||
| 33 | +
- step = 0.5+ #' "Combinations Hist" = teal.widgets::ggplot2_args( |
||
| 210 | +34 |
- )+ #' labs = list(subtitle = "Plot produced by Missing Data Module", caption = NULL) |
|
| 211 | +35 |
- ),- |
- |
| 212 | -! | -
- conditionalPanel(- |
- |
| 213 | -! | -
- condition =- |
- |
| 214 | -! | -
- paste0("input['", ns("method"), "'] == 'Percentile'"),
- |
- |
| 215 | -! | -
- sliderInput(- |
- |
| 216 | -! | -
- ns("percentile_slider"),
+ #' ), |
|
| 217 | -! | +||
| 36 | +
- "Outlier range:",+ #' "Combinations Main" = teal.widgets::ggplot2_args(labs = list(title = NULL)) |
||
| 218 | -! | +||
| 37 | +
- min = 0.001,+ #' ) |
||
| 219 | -! | +||
| 38 | +
- max = 0.5,+ #' ) |
||
| 220 | -! | +||
| 39 | +
- value = 0.01,+ #' ) |
||
| 221 | -! | +||
| 40 | +
- step = 0.001+ #' ) |
||
| 222 | +41 |
- )+ #' if (interactive()) {
|
|
| 223 | +42 |
- ),+ #' shinyApp(app$ui, app$server) |
|
| 224 | -! | +||
| 43 | +
- uiOutput(ns("ui_outlier_help"))
+ #' } |
||
| 225 | +44 |
- )+ tm_missing_data <- function(label = "Missing data", |
|
| 226 | +45 |
- ),+ plot_height = c(600, 400, 5000), |
|
| 227 | -! | +||
| 46 | +
- teal.widgets::panel_item(+ plot_width = NULL, |
||
| 228 | -! | +||
| 47 | +
- title = "Plot settings",+ parent_dataname = "ADSL", |
||
| 229 | -! | +||
| 48 | +
- selectInput(+ ggtheme = c( |
||
| 230 | -! | +||
| 49 | +
- inputId = ns("ggtheme"),
+ "classic", "gray", "bw", "linedraw", |
||
| 231 | -! | +||
| 50 | +
- label = "Theme (by ggplot):",+ "light", "dark", "minimal", "void", "test" |
||
| 232 | -! | +||
| 51 | +
- choices = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
+ ), |
||
| 233 | -! | +||
| 52 | +
- selected = args$ggtheme,+ ggplot2_args = list( |
||
| 234 | -! | +||
| 53 | +
- multiple = FALSE+ "Combinations Hist" = teal.widgets::ggplot2_args(labs = list(caption = NULL)), |
||
| 235 | +54 |
- )+ "Combinations Main" = teal.widgets::ggplot2_args(labs = list(title = NULL)) |
|
| 236 | +55 |
- )+ ), |
|
| 237 | +56 |
- ),+ pre_output = NULL, |
|
| 238 | -! | +||
| 57 | +
- forms = tagList(+ post_output = NULL) {
|
||
| 239 | +58 | ! |
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+ if (!requireNamespace("gridExtra", quietly = TRUE)) {
|
| 240 | +59 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ stop("Cannot load gridExtra - please install the package or restart your session.")
|
| 241 | +60 |
- ),+ } |
|
| 242 | +61 | ! |
- pre_output = args$pre_output,+ if (!requireNamespace("rlang", quietly = TRUE)) {
|
| 243 | +62 | ! |
- post_output = args$post_output+ stop("Cannot load rlang - please install the package or restart your session.")
|
| 244 | +63 |
- )+ } |
|
| 245 | -+ | ||
| 64 | +! |
- }+ logger::log_info("Initializing tm_missing_data")
|
|
| 246 | -+ | ||
| 65 | +! |
-
+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
|
| 247 | +66 |
- srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var,+ |
|
| 248 | -+ | ||
| 67 | +! |
- categorical_var, plot_height, plot_width, ggplot2_args) {
+ checkmate::assert_string(label) |
|
| 249 | +68 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1) |
| 250 | +69 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 251 | +70 | ! |
- checkmate::assert_class(data, "tdata")+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 252 | +71 | ! |
- moduleServer(id, function(input, output, session) {
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 253 | +72 | ! |
- vars <- list(outlier_var = outlier_var, categorical_var = categorical_var)+ checkmate::assert_numeric( |
| 254 | -+ | ||
| 73 | +! |
-
+ plot_width[1], |
|
| 255 | +74 | ! |
- rule_diff <- function(other) {
+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 256 | -! | +||
| 75 | +
- function(value) {
+ ) |
||
| 257 | +76 | ! |
- othervalue <- tryCatch(selector_list()[[other]]()[["select"]], error = function(e) NULL)+ ggtheme <- match.arg(ggtheme) |
| 258 | +77 | ! |
- if (!is.null(othervalue) && identical(othervalue, value)) {
+ plot_choices <- c("Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject")
|
| 259 | +78 | ! |
- "`Variable` and `Categorical factor` cannot be the same"+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
| 260 | -+ | ||
| 79 | +! |
- }+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
|
| 261 | +80 |
- }+ |
|
| 262 | -+ | ||
| 81 | +! |
- }+ module( |
|
| 263 | -+ | ||
| 82 | +! |
-
+ label, |
|
| 264 | +83 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ server = srv_page_missing_data, |
| 265 | +84 | ! |
- data_extract = vars,+ server_args = list( |
| 266 | +85 | ! |
- datasets = data,+ parent_dataname = parent_dataname, plot_height = plot_height, |
| 267 | +86 | ! |
- select_validation_rule = list(+ plot_width = plot_width, ggplot2_args = ggplot2_args+ |
+
| 87 | ++ |
+ ), |
|
| 268 | +88 | ! |
- outlier_var = shinyvalidate::compose_rules(+ ui = ui_page_missing_data, |
| 269 | +89 | ! |
- shinyvalidate::sv_required("Please select a variable"),
+ datanames = "all", |
| 270 | +90 | ! |
- rule_diff("categorical_var")
+ ui_args = list( |
| 271 | -+ | ||
| 91 | +! |
- ),+ parent_dataname = parent_dataname, pre_output = pre_output, |
|
| 272 | +92 | ! |
- categorical_var = rule_diff("outlier_var")
+ post_output = post_output, ggtheme = ggtheme |
| 273 | +93 |
- )+ ) |
|
| 274 | +94 |
- )+ ) |
|
| 275 | +95 |
-
+ } |
|
| 276 | -! | +||
| 96 | +
- iv_r <- reactive({
+
|
||
| 277 | -! | +||
| 97 | +
- iv <- shinyvalidate::InputValidator$new()+ ui_page_missing_data <- function(id, data, parent_dataname, pre_output = NULL, post_output = NULL, ggtheme) {
|
||
| 278 | +98 | ! |
- iv$add_rule("method", shinyvalidate::sv_required("Please select a method"))
+ ns <- NS(id) |
| 279 | +99 | ! |
- iv$add_rule("boxplot_alts", shinyvalidate::sv_required("Please select Plot Type"))
+ datanames <- names(data) |
| 280 | -! | +||
| 100 | +
- teal.transform::compose_and_enable_validators(iv, selector_list)+ |
||
| 281 | -+ | ||
| 101 | +! |
- })+ if_subject_plot <- length(parent_dataname) > 0 && parent_dataname %in% datanames |
|
| 282 | +102 | ||
| 283 | +103 | ! |
- reactive_select_input <- reactive({
+ shiny::tagList( |
| 284 | +104 | ! |
- if (is.null(selector_list()$categorical_var) || length(selector_list()$categorical_var()$select) == 0) {
+ include_css_files("custom"),
|
| 285 | +105 | ! |
- selector_list()[names(selector_list()) != "categorical_var"]+ teal.widgets::standard_layout( |
| 286 | -+ | ||
| 106 | +! |
- } else {
+ output = teal.widgets::white_small_well( |
|
| 287 | +107 | ! |
- selector_list()+ div( |
| 288 | -+ | ||
| 108 | +! |
- }+ class = "flex", |
|
| 289 | -+ | ||
| 109 | +! |
- })+ column( |
|
| 290 | -+ | ||
| 110 | +! |
-
+ width = 12, |
|
| 291 | +111 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ do.call( |
| 292 | +112 | ! |
- selector_list = reactive_select_input,+ tabsetPanel, |
| 293 | +113 | ! |
- datasets = data,+ c( |
| 294 | +114 | ! |
- join_keys = get_join_keys(data),+ id = ns("dataname_tab"),
|
| 295 | +115 | ! |
- merge_function = "dplyr::inner_join"+ lapply( |
| 296 | -+ | ||
| 116 | +! |
- )+ datanames, |
|
| 297 | -+ | ||
| 117 | +! |
-
+ function(x) {
|
|
| 298 | +118 | ! |
- anl_merged_q <- reactive({
+ tabPanel( |
| 299 | +119 | ! |
- req(anl_merged_input())+ title = x, |
| 300 | +120 | ! |
- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>%+ column( |
| 301 | +121 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))- |
-
| 302 | -- |
- })- |
- |
| 303 | -- |
-
+ width = 12, |
|
| 304 | +122 | ! |
- merged <- list(+ div( |
| 305 | +123 | ! |
- anl_input_r = anl_merged_input,+ class = "mt-4", |
| 306 | +124 | ! |
- anl_q_r = anl_merged_q+ ui_missing_data(id = ns(x), by_subject_plot = if_subject_plot) |
| 307 | +125 |
- )+ ) |
|
| 308 | +126 | - - | -|
| 309 | -! | -
- n_outlier_missing <- reactive({
- |
- |
| 310 | -! | -
- shiny::req(iv_r()$is_valid())+ ) |
|
| 311 | -! | +||
| 127 | +
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ ) |
||
| 312 | -! | +||
| 128 | +
- ANL <- merged$anl_q_r()[["ANL"]] # nolint+ } |
||
| 313 | -! | +||
| 129 | +
- sum(is.na(ANL[[outlier_var]]))+ ) |
||
| 314 | +130 |
- })+ ) |
|
| 315 | +131 |
-
+ ) |
|
| 316 | +132 |
- # Used to create outlier table and the dropdown with additional columns+ ) |
|
| 317 | -! | +||
| 133 | +
- dataname_first <- names(data)[[1]]+ ) |
||
| 318 | +134 |
-
+ ), |
|
| 319 | +135 | ! |
- common_code_q <- reactive({
+ encoding = div( |
| 320 | +136 | ! |
- shiny::req(iv_r()$is_valid())+ tagList( |
| 321 | -+ | ||
| 137 | +! |
-
+ lapply( |
|
| 322 | +138 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint+ datanames, |
| 323 | +139 | ! |
- qenv <- merged$anl_q_r()+ function(x) {
|
| 324 | -+ | ||
| 140 | +! |
-
+ conditionalPanel( |
|
| 325 | +141 | ! |
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ is_tab_active_js(ns("dataname_tab"), x),
|
| 326 | +142 | ! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ encoding_missing_data( |
| 327 | +143 | ! |
- order_by_outlier <- input$order_by_outlier # nolint+ id = ns(x), |
| 328 | +144 | ! |
- method <- input$method+ summary_per_patient = if_subject_plot, |
| 329 | +145 | ! |
- split_outliers <- input$split_outliers+ ggtheme = ggtheme, |
| 330 | +146 | ! |
- teal::validate_has_data(+ datanames = datanames |
| 331 | +147 |
- # missing values in the categorical variable may be used to form a category of its own- |
- |
| 332 | -! | -
- `if`(+ ) |
|
| 333 | -! | +||
| 148 | +
- length(categorical_var) == 0,+ ) |
||
| 334 | -! | +||
| 149 | +
- ANL,+ } |
||
| 335 | -! | +||
| 150 | +
- ANL[, names(ANL) != categorical_var]+ ) |
||
| 336 | +151 |
- ),+ ) |
|
| 337 | -! | +||
| 152 | +
- min_nrow = 10,+ ), |
||
| 338 | +153 | ! |
- complete = TRUE,+ forms <- lapply(datanames, function(x) {
|
| 339 | +154 | ! |
- allow_inf = FALSE+ dataname_ns <- NS(ns(x)) |
| 340 | +155 |
- )+ |
|
| 341 | +156 | ! |
- validate(need(is.numeric(ANL[[outlier_var]]), "`Variable` is not numeric"))+ conditionalPanel( |
| 342 | +157 | ! |
- validate(need(length(unique(ANL[[outlier_var]])) > 1, "Variable has no variation, i.e. only one unique value"))+ is_tab_active_js(ns("dataname_tab"), x),
|
| 343 | -+ | ||
| 158 | +! |
-
+ tagList( |
|
| 344 | -+ | ||
| 159 | +! |
- # show/hide split_outliers+ teal.widgets::verbatim_popup_ui(dataname_ns("warning"), "Show Warnings"),
|
|
| 345 | +160 | ! |
- if (length(categorical_var) == 0) {
+ teal.widgets::verbatim_popup_ui(dataname_ns("rcode"), "Show R code")
|
| 346 | -! | +||
| 161 | +
- shinyjs::hide("split_outliers")
+ ) |
||
| 347 | -! | +||
| 162 | +
- if (n_outlier_missing() > 0) {
+ ) |
||
| 348 | -! | +||
| 163 | +
- qenv <- teal.code::eval_code(+ }), |
||
| 349 | +164 | ! |
- qenv,+ pre_output = pre_output, |
| 350 | +165 | ! |
- substitute(+ post_output = post_output |
| 351 | -! | +||
| 166 | +
- expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)), # nolint+ ) |
||
| 352 | -! | +||
| 167 | +
- env = list(outlier_var_name = as.name(outlier_var))+ ) |
||
| 353 | +168 |
- )+ } |
|
| 354 | +169 |
- )+ |
|
| 355 | +170 |
- }+ srv_page_missing_data <- function(id, data, reporter, filter_panel_api, parent_dataname, |
|
| 356 | +171 |
- } else {
+ plot_height, plot_width, ggplot2_args) {
|
|
| 357 | +172 | ! |
- validate(need(+ moduleServer(id, function(input, output, session) {
|
| 358 | +173 | ! |
- is.factor(ANL[[categorical_var]]) ||+ lapply( |
| 359 | +174 | ! |
- is.character(ANL[[categorical_var]]) ||+ names(data), |
| 360 | +175 | ! |
- is.integer(ANL[[categorical_var]]),+ function(x) {
|
| 361 | +176 | ! |
- "`Categorical factor` must be `factor`, `character`, or `integer`"+ srv_missing_data( |
| 362 | -+ | ||
| 177 | +! |
- ))+ id = x, |
|
| 363 | -+ | ||
| 178 | +! |
-
+ data = data, |
|
| 364 | +179 | ! |
- if (n_outlier_missing() > 0) {
+ reporter = reporter, |
| 365 | +180 | ! |
- qenv <- teal.code::eval_code(+ filter_panel_api = filter_panel_api, |
| 366 | +181 | ! |
- qenv,+ dataname = x, |
| 367 | +182 | ! |
- substitute(+ parent_dataname = parent_dataname, |
| 368 | +183 | ! |
- expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)), # nolint+ plot_height = plot_height, |
| 369 | +184 | ! |
- env = list(outlier_var_name = as.name(outlier_var))+ plot_width = plot_width,+ |
+
| 185 | +! | +
+ ggplot2_args = ggplot2_args |
|
| 370 | +186 |
- )+ ) |
|
| 371 | +187 |
- )+ } |
|
| 372 | +188 |
- }+ ) |
|
| 373 | -! | +||
| 189 | +
- shinyjs::show("split_outliers")
+ }) |
||
| 374 | +190 |
- }+ } |
|
| 375 | +191 | ||
| 376 | +192 |
- # slider+ ui_missing_data <- function(id, by_subject_plot = FALSE) {
|
|
| 377 | +193 | ! |
- outlier_definition_param <- if (method == "IQR") { # nolint
+ ns <- NS(id) |
| 378 | -! | +||
| 194 | +
- input$iqr_slider+ |
||
| 379 | +195 | ! |
- } else if (method == "Z-score") {
+ tab_list <- list( |
| 380 | +196 | ! |
- input$zscore_slider+ tabPanel( |
| 381 | +197 | ! |
- } else if (method == "Percentile") {
+ "Summary", |
| 382 | +198 | ! |
- input$percentile_slider- |
-
| 383 | -- |
- }- |
- |
| 384 | -- |
-
+ teal.widgets::plot_with_settings_ui(id = ns("summary_plot")),
|
|
| 385 | -+ | ||
| 199 | +! |
- # this is utils function that converts a %>% NULL %>% b into a %>% b+ helpText( |
|
| 386 | +200 | ! |
- remove_pipe_null <- function(x) {
+ p(paste( |
| 387 | +201 | ! |
- if (length(x) == 1) {
+ 'The "Summary" graph shows the number of missing values per variable (both absolute and percentage),', |
| 388 | +202 | ! |
- return(x)+ "sorted by magnitude." |
| 389 | +203 |
- }+ )), |
|
| 390 | +204 | ! |
- if (identical(x[[1]], as.name("%>%")) && is.null(x[[3]])) {
+ p( |
| 391 | +205 | ! |
- return(remove_pipe_null(x[[2]]))+ 'The "summary per patients" graph is showing how many subjects have at least one missing observation', |
| 392 | -+ | ||
| 206 | +! |
- }+ "for each variable. It will be most useful for panel datasets." |
|
| 393 | -! | +||
| 207 | +
- return(as.call(c(x[[1]], lapply(x[-1], remove_pipe_null))))+ ) |
||
| 394 | +208 |
- }+ ) |
|
| 395 | +209 |
-
+ ), |
|
| 396 | +210 | ! |
- qenv <- teal.code::eval_code(+ tabPanel( |
| 397 | +211 | ! |
- qenv,+ "Combinations", |
| 398 | +212 | ! |
- substitute(+ teal.widgets::plot_with_settings_ui(id = ns("combination_plot")),
|
| 399 | +213 | ! |
- expr = {
+ helpText( |
| 400 | +214 | ! |
- ANL_OUTLIER <- ANL %>% # nolint+ p(paste( |
| 401 | +215 | ! |
- group_expr %>% # styler: off+ 'The "Combinations" graph is used to explore the relationship between the missing data within', |
| 402 | +216 | ! |
- dplyr::mutate(is_outlier = {
+ "different columns of the dataset.", |
| 403 | +217 | ! |
- q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75))+ "It shows the different patterns of missingness in the rows of the data.", |
| 404 | +218 | ! |
- iqr <- q1_q3[2] - q1_q3[1]+ 'For example, suppose that 70 rows of the data have exactly columns "A" and "B" missing.', |
| 405 | +219 | ! |
- !(outlier_var_name >= q1_q3[1] - 1.5 * iqr & outlier_var_name <= q1_q3[2] + 1.5 * iqr)+ "In this case there would be a bar of height 70 in the top graph and",+ |
+
| 220 | +! | +
+ 'the column below this in the second graph would have rows "A" and "B" cells shaded red.' |
|
| 406 | +221 |
- }) %>%+ )), |
|
| 407 | +222 | ! |
- calculate_outliers %>% # styler: off+ p(paste( |
| 408 | +223 | ! |
- ungroup_expr %>% # styler: off+ "Due to the large number of missing data patterns possible, only those with a large set of observations", |
| 409 | +224 | ! |
- dplyr::filter(is_outlier | is_outlier_selected) %>%+ 'are shown in the graph and the "Combination cut-off" slider can be used to adjust the number shown.' |
| 410 | -! | +||
| 225 | +
- dplyr::select(-is_outlier)+ )) |
||
| 411 | +226 |
- },+ ) |
|
| 412 | -! | +||
| 227 | +
- env = list(+ ), |
||
| 413 | +228 | ! |
- calculate_outliers = if (method == "IQR") {
+ tabPanel( |
| 414 | +229 | ! |
- substitute(+ "By Variable Levels", |
| 415 | +230 | ! |
- expr = dplyr::mutate(is_outlier_selected = {
+ teal.widgets::get_dt_rows(ns("levels_table"), ns("levels_table_rows")),
|
| 416 | +231 | ! |
- q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75))+ DT::dataTableOutput(ns("levels_table"))
|
| 417 | -! | +||
| 232 | +
- iqr <- q1_q3[2] - q1_q3[1]+ ) |
||
| 418 | -! | +||
| 233 | +
- !(outlier_var_name >= q1_q3[1] - outlier_definition_param * iqr &+ ) |
||
| 419 | +234 | ! |
- outlier_var_name <= q1_q3[2] + outlier_definition_param * iqr)+ if (isTRUE(by_subject_plot)) {
|
| 420 | -+ | ||
| 235 | +! |
- }),+ tab_list <- append( |
|
| 421 | +236 | ! |
- env = list(+ tab_list, |
| 422 | +237 | ! |
- outlier_var_name = as.name(outlier_var),+ list(tabPanel( |
| 423 | +238 | ! |
- outlier_definition_param = outlier_definition_param+ "Grouped by Subject", |
| 424 | -+ | ||
| 239 | +! |
- )+ teal.widgets::plot_with_settings_ui(id = ns("by_subject_plot")),
|
|
| 425 | -+ | ||
| 240 | +! |
- )+ helpText( |
|
| 426 | +241 | ! |
- } else if (method == "Z-score") {
+ p(paste( |
| 427 | +242 | ! |
- substitute(+ "This graph shows the missingness with respect to subjects rather than individual rows of the", |
| 428 | +243 | ! |
- expr = dplyr::mutate(+ "dataset. Each row represents one dataset variable and each column a single subject. Only subjects", |
| 429 | +244 | ! |
- is_outlier_selected = abs(outlier_var_name - mean(outlier_var_name)) /+ "with at least one record in this dataset are shown. For a given subject, if they have any missing", |
| 430 | +245 | ! |
- stats::sd(outlier_var_name) > outlier_definition_param+ "values of a specific variable then the appropriate cell in the graph is marked as missing." |
| 431 | +246 |
- ),+ )) |
|
| 432 | -! | +||
| 247 | +
- env = list(+ ) |
||
| 433 | -! | +||
| 248 | +
- outlier_var_name = as.name(outlier_var),+ )) |
||
| 434 | -! | +||
| 249 | +
- outlier_definition_param = outlier_definition_param+ ) |
||
| 435 | +250 |
- )+ } |
|
| 436 | +251 |
- )+ |
|
| 437 | +252 | ! |
- } else if (method == "Percentile") {
+ do.call( |
| 438 | +253 | ! |
- substitute(+ tabsetPanel, |
| 439 | +254 | ! |
- expr = dplyr::mutate(+ c( |
| 440 | +255 | ! |
- is_outlier_selected = outlier_var_name < stats::quantile(outlier_var_name, outlier_definition_param) |+ id = ns("summary_type"),
|
| 441 | +256 | ! |
- outlier_var_name > stats::quantile(outlier_var_name, 1 - outlier_definition_param)+ tab_list |
| 442 | +257 |
- ),- |
- |
| 443 | -! | -
- env = list(- |
- |
| 444 | -! | -
- outlier_var_name = as.name(outlier_var),+ ) |
|
| 445 | -! | +||
| 258 | +
- outlier_definition_param = outlier_definition_param+ ) |
||
| 446 | +259 |
- )+ } |
|
| 447 | +260 |
- )+ |
|
| 448 | +261 |
- },+ encoding_missing_data <- function(id, summary_per_patient = FALSE, ggtheme, datanames) {
|
|
| 449 | +262 | ! |
- outlier_var_name = as.name(outlier_var),+ ns <- NS(id) |
| 450 | -! | +||
| 263 | +
- group_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
+
|
||
| 451 | +264 | ! |
- substitute(dplyr::group_by(x), list(x = as.name(categorical_var)))+ tagList( |
| 452 | +265 |
- },- |
- |
| 453 | -! | -
- ungroup_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
+ ### Reporter |
|
| 454 | +266 | ! |
- substitute(dplyr::ungroup())+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 455 | +267 |
- }+ ### |
|
| 456 | -+ | ||
| 268 | +! |
- )+ tags$label("Encodings", class = "text-primary"),
|
|
| 457 | -+ | ||
| 269 | +! |
- ) %>%+ helpText( |
|
| 458 | +270 | ! |
- remove_pipe_null()+ paste0("Dataset", `if`(length(datanames) > 1, "s", ""), ":"),
|
| 459 | -+ | ||
| 271 | +! |
- )+ tags$code(paste(datanames, collapse = ", ")) |
|
| 460 | +272 |
-
+ ), |
|
| 461 | -+ | ||
| 273 | +! |
- # ANL_OUTLIER_EXTENDED is the base table+ uiOutput(ns("variables")),
|
|
| 462 | +274 | ! |
- qenv <- teal.code::eval_code(+ actionButton( |
| 463 | +275 | ! |
- qenv,+ ns("filter_na"),
|
| 464 | +276 | ! |
- substitute(+ span("Select only vars with missings", class = "whitespace-normal"),
|
| 465 | +277 | ! |
- expr = {
+ width = "100%", |
| 466 | +278 | ! |
- ANL_OUTLIER_EXTENDED <- dplyr::left_join( # nolint object_name_linter+ class = "mb-4"+ |
+
| 279 | ++ |
+ ), |
|
| 467 | +280 | ! |
- ANL_OUTLIER,+ conditionalPanel( |
| 468 | +281 | ! |
- dplyr::select(+ is_tab_active_js(ns("summary_type"), "Summary"),
|
| 469 | +282 | ! |
- dataname,+ checkboxInput( |
| 470 | +283 | ! |
- dplyr::setdiff(names(dataname), dplyr::setdiff(names(ANL_OUTLIER), join_keys))+ ns("any_na"),
|
| 471 | -+ | ||
| 284 | +! |
- ),+ div( |
|
| 472 | +285 | ! |
- by = join_keys+ class = "teal-tooltip", |
| 473 | -+ | ||
| 286 | +! |
- )+ tagList( |
|
| 474 | -+ | ||
| 287 | +! |
- },+ "Add **anyna** variable", |
|
| 475 | +288 | ! |
- env = list(+ icon("circle-info"),
|
| 476 | +289 | ! |
- dataname = as.name(dataname_first),+ span( |
| 477 | +290 | ! |
- join_keys = as.character(get_join_keys(data)$get(dataname_first)[[dataname_first]])+ class = "tooltiptext", |
| 478 | -+ | ||
| 291 | +! |
- )+ "Describes the number of observations with at least one missing value in any variable." |
|
| 479 | +292 |
- )+ ) |
|
| 480 | +293 |
- )+ ) |
|
| 481 | +294 | - - | -|
| 482 | -! | -
- if (length(categorical_var) > 0) {
+ ), |
|
| 483 | +295 | ! |
- qenv <- teal.code::eval_code(+ value = FALSE |
| 484 | -! | +||
| 296 | +
- qenv,+ ), |
||
| 485 | +297 | ! |
- substitute(+ if (summary_per_patient) {
|
| 486 | +298 | ! |
- expr = summary_table_pre <- ANL_OUTLIER %>%+ checkboxInput( |
| 487 | +299 | ! |
- dplyr::filter(is_outlier_selected) %>%+ ns("if_patients_plot"),
|
| 488 | +300 | ! |
- dplyr::select(outlier_var_name, categorical_var_name) %>%+ div( |
| 489 | +301 | ! |
- dplyr::group_by(categorical_var_name) %>%+ class = "teal-tooltip", |
| 490 | +302 | ! |
- dplyr::summarise(n_outliers = dplyr::n()) %>%+ tagList( |
| 491 | +303 | ! |
- dplyr::right_join(+ "Add summary per patients", |
| 492 | +304 | ! |
- ANL %>%+ icon("circle-info"),
|
| 493 | +305 | ! |
- dplyr::select(outlier_var_name, categorical_var_name) %>%+ span( |
| 494 | +306 | ! |
- dplyr::group_by(categorical_var_name) %>%+ class = "tooltiptext", |
| 495 | +307 | ! |
- dplyr::summarise(+ paste( |
| 496 | +308 | ! |
- total_in_cat = dplyr::n(),+ "Displays the number of missing values per observation,", |
| 497 | +309 | ! |
- n_na = sum(is.na(outlier_var_name) | is.na(categorical_var_name))+ "where the x-axis is sorted by observation appearance in the table." |
| 498 | -- |
- ),- |
- |
| 499 | -! | -
- by = categorical_var- |
- |
| 500 | +310 |
- ) %>%+ ) |
|
| 501 | +311 |
- # This is important as there may be categorical variables with natural orderings, e.g. AGE.+ ) |
|
| 502 | +312 |
- # The plots should be displayed by default in increasing order in these situations.+ ) |
|
| 503 | +313 |
- # dplyr::arrange will sort integer, factor, and character data types in the expected way.+ ), |
|
| 504 | +314 | ! |
- dplyr::arrange(categorical_var_name) %>%+ value = FALSE |
| 505 | -! | +||
| 315 | +
- dplyr::mutate(+ ) |
||
| 506 | -! | +||
| 316 | +
- n_outliers = dplyr::if_else(is.na(n_outliers), 0, as.numeric(n_outliers)),+ } |
||
| 507 | -! | +||
| 317 | +
- display_str = dplyr::if_else(+ ), |
||
| 508 | +318 | ! |
- n_outliers > 0,+ conditionalPanel( |
| 509 | +319 | ! |
- sprintf("%d [%.02f%%]", n_outliers, 100 * n_outliers / total_in_cat),
+ is_tab_active_js(ns("summary_type"), "Combinations"),
|
| 510 | +320 | ! |
- "0"+ uiOutput(ns("cutoff"))
|
| 511 | +321 |
- ),+ ), |
|
| 512 | +322 | ! |
- display_str_na = dplyr::if_else(+ conditionalPanel( |
| 513 | +323 | ! |
- n_na > 0,+ is_tab_active_js(ns("summary_type"), "By Variable Levels"),
|
| 514 | +324 | ! |
- sprintf("%d [%.02f%%]", n_na, 100 * n_na / total_in_cat),
+ tagList( |
| 515 | +325 | ! |
- "0"+ uiOutput(ns("group_by_var_ui")),
|
| 516 | -+ | ||
| 326 | +! |
- ),+ uiOutput(ns("group_by_vals_ui")),
|
|
| 517 | +327 | ! |
- order = seq_along(n_outliers)+ radioButtons( |
| 518 | -+ | ||
| 328 | +! |
- ),+ ns("count_type"),
|
|
| 519 | +329 | ! |
- env = list(+ label = "Display missing as", |
| 520 | +330 | ! |
- categorical_var = categorical_var,+ choices = c("counts", "proportions"),
|
| 521 | +331 | ! |
- categorical_var_name = as.name(categorical_var),+ selected = "counts", |
| 522 | +332 | ! |
- outlier_var_name = as.name(outlier_var)+ inline = TRUE |
| 523 | +333 |
- )+ ) |
|
| 524 | +334 |
- )+ ) |
|
| 525 | +335 |
- )+ ), |
|
| 526 | -+ | ||
| 336 | +! |
- # now to handle when user chooses to order based on amount of outliers+ teal.widgets::panel_item( |
|
| 527 | +337 | ! |
- if (order_by_outlier) {
+ title = "Plot settings", |
| 528 | +338 | ! |
- qenv <- teal.code::eval_code(+ selectInput( |
| 529 | +339 | ! |
- qenv,+ inputId = ns("ggtheme"),
|
| 530 | +340 | ! |
- quote(+ label = "Theme (by ggplot):", |
| 531 | +341 | ! |
- summary_table_pre <- summary_table_pre %>%+ choices = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
|
| 532 | +342 | ! |
- dplyr::arrange(desc(n_outliers / total_in_cat)) %>%+ selected = ggtheme, |
| 533 | +343 | ! |
- dplyr::mutate(order = seq_len(nrow(summary_table_pre)))+ multiple = FALSE |
| 534 | +344 |
- )+ ) |
|
| 535 | +345 |
- )+ ) |
|
| 536 | +346 |
- }+ ) |
|
| 537 | +347 |
-
+ } |
|
| 538 | -! | +||
| 348 | +
- qenv <- teal.code::eval_code(+ |
||
| 539 | -! | +||
| 349 | +
- qenv,+ srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, parent_dataname, |
||
| 540 | -! | +||
| 350 | +
- substitute(+ plot_height, plot_width, ggplot2_args) {
|
||
| 541 | +351 | ! |
- expr = {
- |
-
| 542 | -- |
- # In order for geom_rug to work properly when reordering takes place inside facet_grid,+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 543 | -+ | ||
| 352 | +! |
- # all tables must have the column used for reording.+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 544 | -+ | ||
| 353 | +! |
- # In this case, the column used for reordering is `order`.+ checkmate::assert_class(data, "tdata") |
|
| 545 | +354 | ! |
- ANL_OUTLIER <- dplyr::left_join( # nolint+ moduleServer(id, function(input, output, session) {
|
| 546 | +355 | ! |
- ANL_OUTLIER,+ prev_group_by_var <- reactiveVal("")
|
| 547 | +356 | ! |
- summary_table_pre[, c("order", categorical_var)],
+ data_r <- data[[dataname]] |
| 548 | +357 | ! |
- by = categorical_var+ data_keys <- reactive(get_join_keys(data)$get(dataname)[[dataname]]) |
| 549 | +358 |
- )+ |
|
| 550 | -+ | ||
| 359 | +! |
- # so that x axis of plot aligns with columns of summary table, from most outliers to least by percentage+ iv_r <- reactive({
|
|
| 551 | +360 | ! |
- ANL <- ANL %>% # nolint+ iv <- shinyvalidate::InputValidator$new() |
| 552 | +361 | ! |
- dplyr::left_join(+ iv$add_rule( |
| 553 | +362 | ! |
- dplyr::select(summary_table_pre, categorical_var_name, order),+ "variables_select", |
| 554 | +363 | ! |
- by = categorical_var+ shinyvalidate::sv_required("At least one reference variable needs to be selected.")
|
| 555 | +364 |
- ) %>%+ ) |
|
| 556 | +365 | ! |
- dplyr::arrange(order)+ iv$add_rule( |
| 557 | +366 | ! |
- summary_table <- summary_table_pre %>%+ "variables_select", |
| 558 | +367 | ! |
- dplyr::select(+ ~ if (length(setdiff((.), data_keys())) < 1) "Please also select non-key columns." |
| 559 | -! | +||
| 368 | +
- categorical_var_name,+ ) |
||
| 560 | +369 | ! |
- Outliers = display_str, Missings = display_str_na, Total = total_in_cat- |
-
| 561 | -- |
- ) %>%+ iv_summary_table <- shinyvalidate::InputValidator$new() |
|
| 562 | +370 | ! |
- dplyr::mutate_all(as.character) %>%+ iv_summary_table$condition(~ isTRUE(input$summary_type == "By Variable Levels")) |
| 563 | +371 | ! |
- tidyr::pivot_longer(-categorical_var_name) %>%+ iv_summary_table$add_rule("count_type", shinyvalidate::sv_required("Please select type of counts"))
|
| 564 | +372 | ! |
- tidyr::pivot_wider(names_from = categorical_var, values_from = value) %>%+ iv_summary_table$add_rule( |
| 565 | +373 | ! |
- tibble::column_to_rownames("name")
+ "group_by_vals", |
| 566 | +374 | ! |
- summary_table+ shinyvalidate::sv_required("Please select both group-by variable and values")
|
| 567 | +375 |
- },+ ) |
|
| 568 | +376 | ! |
- env = list(+ iv_summary_table$add_rule( |
| 569 | +377 | ! |
- categorical_var = categorical_var,+ "group_by_var", |
| 570 | +378 | ! |
- categorical_var_name = as.name(categorical_var)+ ~ if (length(.) > 0 && length(input$variables_select) == 1 && (.) == input$variables_select) {
|
| 571 | -+ | ||
| 379 | +! |
- )+ "If only one reference variable is selected it must not be the grouping variable." |
|
| 572 | +380 |
- )+ } |
|
| 573 | +381 |
- )+ ) |
|
| 574 | -+ | ||
| 382 | +! |
- }+ iv_summary_table$add_rule( |
|
| 575 | -+ | ||
| 383 | +! |
-
+ "variables_select", |
|
| 576 | +384 | ! |
- if (length(categorical_var) > 0 && nrow(qenv[["ANL_OUTLIER"]]) > 0) {
+ ~ if (length(input$group_by_var) > 0 && length(.) == 1 && (.) == input$group_by_var) {
|
| 577 | +385 | ! |
- shinyjs::show("order_by_outlier")
+ "If only one reference variable is selected it must not be the grouping variable." |
| 578 | +386 |
- } else {
+ } |
|
| 579 | -! | +||
| 387 | +
- shinyjs::hide("order_by_outlier")
+ ) |
||
| 580 | -+ | ||
| 388 | +! |
- }+ iv$add_validator(iv_summary_table) |
|
| 581 | -+ | ||
| 389 | +! |
-
+ iv$enable() |
|
| 582 | +390 | ! |
- qenv+ iv |
| 583 | +391 |
}) |
|
| 584 | +392 | ||
| 585 | -! | +||
| 393 | +
- output$summary_table <- DT::renderDataTable(+ |
||
| 586 | +394 | ! |
- expr = {
+ data_parent_keys <- reactive({
|
| 587 | +395 | ! |
- if (iv_r()$is_valid()) {
+ if (length(parent_dataname) > 0 && parent_dataname %in% names(data)) {
|
| 588 | +396 | ! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ keys <- get_join_keys(data)$get(dataname) |
| 589 | +397 | ! |
- if (!is.null(categorical_var)) {
+ if (parent_dataname %in% names(keys)) {
|
| 590 | +398 | ! |
- DT::datatable(+ keys[[parent_dataname]] |
| 591 | -! | +||
| 399 | +
- common_code_q()[["summary_table"]],+ } else {
|
||
| 592 | +400 | ! |
- options = list(+ keys[[dataname]] |
| 593 | -! | +||
| 401 | +
- dom = "t",+ } |
||
| 594 | -! | +||
| 402 | +
- autoWidth = TRUE,+ } else {
|
||
| 595 | +403 | ! |
- columnDefs = list(list(width = "200px", targets = "_all"))+ NULL |
| 596 | +404 |
- )+ } |
|
| 597 | +405 |
- )+ }) |
|
| 598 | +406 |
- }+ |
|
| 599 | -+ | ||
| 407 | +! |
- }+ common_code_q <- reactive({
|
|
| 600 | -- |
- }- |
- |
| 601 | -+ | ||
| 408 | +! |
- )+ teal::validate_inputs(iv_r()) |
|
| 602 | +409 | ||
| 603 | -- |
- # boxplot/violinplot #nolint- |
- |
| 604 | -! | -
- boxplot_q <- reactive({
- |
- |
| 605 | +410 | ! |
- req(common_code_q())+ group_var <- input$group_by_var |
| 606 | +411 | ! |
- ANL <- common_code_q()[["ANL"]] # nolint+ anl <- data_r() |
| 607 | +412 | ! |
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint+ qenv <- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) |
| 608 | +413 | ||
| 609 | +414 | ! |
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ qenv <- if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {
|
| 610 | +415 | ! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ teal.code::eval_code( |
| 611 | -+ | ||
| 416 | +! |
-
+ qenv, |
|
| 612 | -+ | ||
| 417 | +! |
- # validation+ substitute( |
|
| 613 | +418 | ! |
- teal::validate_has_data(ANL, 1)+ expr = ANL <- anl_name[, selected_vars, drop = FALSE], # nolint |
| 614 | -+ | ||
| 419 | +! |
-
+ env = list(anl_name = as.name(dataname), selected_vars = selected_vars()) |
|
| 615 | +420 |
- # boxplot- |
- |
| 616 | -! | -
- plot_call <- quote(ANL %>% ggplot()) # nolint+ ) |
|
| 617 | +421 |
-
+ ) |
|
| 618 | -! | +||
| 422 | +
- plot_call <- if (input$boxplot_alts == "Box plot") {
+ } else {
|
||
| 619 | +423 | ! |
- substitute(expr = plot_call + geom_boxplot(outlier.shape = NA), env = list(plot_call = plot_call))+ teal.code::eval_code( |
| 620 | +424 | ! |
- } else if (input$boxplot_alts == "Violin plot") {
+ qenv, |
| 621 | +425 | ! |
- substitute(expr = plot_call + geom_violin(), env = list(plot_call = plot_call))+ substitute(expr = ANL <- anl_name, env = list(anl_name = as.name(dataname))) # nolint |
| 622 | +426 |
- } else {
- |
- |
| 623 | -! | -
- NULL+ ) |
|
| 624 | +427 |
} |
|
| 625 | +428 | ||
| 626 | +429 | ! |
- plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
+ if (input$summary_type == "By Variable Levels" && !is.null(group_var) && !(group_var %in% selected_vars())) {
|
| 627 | +430 | ! |
- inner_call <- substitute(+ qenv <- teal.code::eval_code( |
| 628 | +431 | ! |
- expr = plot_call ++ qenv, |
| 629 | +432 | ! |
- aes(x = "Entire dataset", y = outlier_var_name) ++ substitute( |
| 630 | +433 | ! |
- scale_x_discrete(),+ expr = ANL[[group_var]] <- anl_name[[group_var]], # nolint |
| 631 | +434 | ! |
- env = list(plot_call = plot_call, outlier_var_name = as.name(outlier_var))+ env = list(group_var = group_var, anl_name = as.name(dataname)) |
| 632 | +435 |
- )- |
- |
| 633 | -! | -
- if (nrow(ANL_OUTLIER) > 0) {
+ ) |
|
| 634 | -! | +||
| 436 | +
- substitute(+ ) |
||
| 635 | -! | +||
| 437 | +
- expr = inner_call + geom_point(+ } |
||
| 636 | -! | +||
| 438 | +
- data = ANL_OUTLIER,+ |
||
| 637 | +439 | ! |
- aes(x = "Entire dataset", y = outlier_var_name, color = is_outlier_selected)+ new_col_name <- "**anyna**" # nolint variable assigned and used |
| 638 | +440 |
- ),+ |
|
| 639 | +441 | ! |
- env = list(inner_call = inner_call, outlier_var_name = as.name(outlier_var))- |
-
| 640 | -- |
- )+ qenv <- teal.code::eval_code( |
|
| 641 | -+ | ||
| 442 | +! |
- } else {
+ qenv, |
|
| 642 | +443 | ! |
- inner_call+ substitute( |
| 643 | -+ | ||
| 444 | +! |
- }+ expr = |
|
| 644 | -+ | ||
| 445 | +! |
- } else {
+ create_cols_labels <- function(cols, just_label = FALSE) {
|
|
| 645 | +446 | ! |
- substitute(+ column_labels <- column_labels_value |
| 646 | +447 | ! |
- expr = plot_call ++ column_labels[is.na(column_labels) | length(column_labels) == 0] <- "" |
| 647 | +448 | ! |
- aes(y = outlier_var_name, x = reorder(categorical_var_name, order)) ++ if (just_label) {
|
| 648 | +449 | ! |
- xlab(categorical_var) ++ labels <- column_labels[cols] |
| 649 | -! | +||
| 450 | +
- scale_x_discrete() ++ } else {
|
||
| 650 | +451 | ! |
- geom_point(+ labels <- ifelse(cols == new_col_name | cols == "", cols, paste0(column_labels[cols], " [", cols, "]")) |
| 651 | -! | +||
| 452 | +
- data = ANL_OUTLIER,+ } |
||
| 652 | +453 | ! |
- aes(x = as.factor(categorical_var_name), y = outlier_var_name, color = is_outlier_selected)+ return(labels) |
| 653 | +454 |
- ),+ }, |
|
| 654 | +455 | ! |
env = list( |
| 655 | +456 | ! |
- plot_call = plot_call,+ new_col_name = new_col_name, |
| 656 | +457 | ! |
- outlier_var_name = as.name(outlier_var),+ column_labels_value = c(var_labels(data_r())[selected_vars()], |
| 657 | +458 | ! |
- categorical_var_name = as.name(categorical_var),+ new_col_name = new_col_name |
| 658 | -! | +||
| 459 | +
- categorical_var = categorical_var+ ) |
||
| 659 | +460 |
) |
|
| 660 | +461 |
) |
|
| 661 | +462 |
- }+ )+ |
+ |
| 463 | +! | +
+ qenv |
|
| 662 | +464 | ++ |
+ })+ |
+
| 465 | |||
| 663 | +466 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ selected_vars <- reactive({
|
| 664 | +467 | ! |
- labs = list(color = "Is outlier?"),+ req(input$variables_select) |
| 665 | +468 | ! |
- theme = list(legend.position = "top")+ keys <- data_keys()+ |
+
| 469 | +! | +
+ vars <- unique(c(keys, input$variables_select))+ |
+ |
| 470 | +! | +
+ vars |
|
| 666 | +471 |
- )+ }) |
|
| 667 | +472 | ||
| 668 | +473 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ vars_summary <- reactive({
|
| 669 | +474 | ! |
- user_plot = ggplot2_args[["Boxplot"]],+ na_count <- data_r() %>% |
| 670 | +475 | ! |
- user_default = ggplot2_args$default,+ sapply(function(x) mean(is.na(x)), USE.NAMES = TRUE) %>% |
| 671 | +476 | ! |
- module_plot = dev_ggplot2_args+ sort(decreasing = TRUE) |
| 672 | +477 |
- )+ |
|
| 673 | -+ | ||
| 478 | +! |
-
+ tibble::tibble( |
|
| 674 | +479 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ key = names(na_count), |
| 675 | +480 | ! |
- all_ggplot2_args,+ value = unname(na_count), |
| 676 | +481 | ! |
- ggtheme = input$ggtheme+ label = cut(na_count, breaks = seq(from = 0, to = 1, by = 0.1), include.lowest = TRUE) |
| 677 | +482 |
) |
|
| 678 | +483 |
-
+ }) |
|
| 679 | -! | +||
| 484 | +
- teal.code::eval_code(+ |
||
| 680 | +485 | ! |
- common_code_q(),+ output$variables <- renderUI({
|
| 681 | +486 | ! |
- substitute(+ choices <- split(x = vars_summary()$key, f = vars_summary()$label, drop = TRUE) %>% rev() |
| 682 | +487 | ! |
- expr = g <- plot_call ++ selected <- choices <- unname(unlist(choices)) |
| 683 | -! | +||
| 488 | +
- scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
+
|
||
| 684 | +489 | ! |
- labs + ggthemes + themes,+ teal.widgets::optionalSelectInput( |
| 685 | +490 | ! |
- env = list(+ session$ns("variables_select"),
|
| 686 | +491 | ! |
- plot_call = plot_call,+ label = "Select variables", |
| 687 | +492 | ! |
- labs = parsed_ggplot2_args$labs,+ label_help = HTML(paste0("Dataset: ", tags$code(dataname))),
|
| 688 | +493 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme,+ choices = teal.transform::variable_choices(data_r(), choices), |
| 689 | +494 | ! |
- themes = parsed_ggplot2_args$theme- |
-
| 690 | -- |
- )+ selected = selected, |
|
| 691 | -+ | ||
| 495 | +! |
- )+ multiple = TRUE |
|
| 692 | +496 |
- ) %>%- |
- |
| 693 | -! | -
- teal.code::eval_code(quote(print(g)))+ ) |
|
| 694 | +497 |
}) |
|
| 695 | +498 | ||
| 696 | -+ | ||
| 499 | +! |
- # density plot+ observeEvent(input$filter_na, {
|
|
| 697 | +500 | ! |
- density_plot_q <- reactive({
+ choices <- vars_summary() %>% |
| 698 | +501 | ! |
- ANL <- common_code_q()[["ANL"]] # nolint+ dplyr::select(!!as.name("key")) %>%
|
| 699 | +502 | ! |
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint+ getElement(name = 1) |
| 700 | +503 | ||
| 701 | +504 | ! |
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ selected <- vars_summary() %>% |
| 702 | +505 | ! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)- |
-
| 703 | -- |
-
+ dplyr::filter(!!as.name("value") > 0) %>%
|
|
| 704 | -+ | ||
| 506 | +! |
- # validation+ dplyr::select(!!as.name("key")) %>%
|
|
| 705 | +507 | ! |
- teal::validate_has_data(ANL, 1)+ getElement(name = 1) |
| 706 | +508 |
- # plot- |
- |
| 707 | -! | -
- plot_call <- substitute(+ |
|
| 708 | +509 | ! |
- expr = ANL %>%+ teal.widgets::updateOptionalSelectInput( |
| 709 | +510 | ! |
- ggplot(aes(x = outlier_var_name)) ++ session = session, |
| 710 | +511 | ! |
- geom_density() ++ inputId = "variables_select", |
| 711 | +512 | ! |
- geom_rug(data = ANL_OUTLIER, aes(x = outlier_var_name, color = is_outlier_selected)) ++ choices = teal.transform::variable_choices(data_r()), |
| 712 | +513 | ! |
- scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")),
+ selected = selected |
| 713 | -! | +||
| 514 | +
- env = list(outlier_var_name = as.name(outlier_var))+ ) |
||
| 714 | +515 |
- )+ }) |
|
| 715 | +516 | ||
| 716 | +517 | ! |
- plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
+ output$group_by_var_ui <- renderUI({
|
| 717 | +518 | ! |
- substitute(expr = plot_call, env = list(plot_call = plot_call))- |
-
| 718 | -- |
- } else {
+ all_choices <- teal.transform::variable_choices(data_r()) |
|
| 719 | +519 | ! |
- substitute(+ cat_choices <- all_choices[!sapply(data_r(), function(x) is.numeric(x) || inherits(x, "POSIXct"))] |
| 720 | +520 | ! |
- expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)),+ validate( |
| 721 | +521 | ! |
- env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var))+ need(cat_choices, "Dataset does not have any non-numeric or non-datetime variables to use to group data with") |
| 722 | +522 |
- )+ ) |
|
| 723 | -+ | ||
| 523 | +! |
- }+ teal.widgets::optionalSelectInput( |
|
| 724 | -+ | ||
| 524 | +! |
-
+ session$ns("group_by_var"),
|
|
| 725 | +525 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ label = "Group by variable", |
| 726 | +526 | ! |
- labs = list(color = "Is outlier?"),+ choices = cat_choices, |
| 727 | +527 | ! |
- theme = list(legend.position = "top")+ selected = `if`( |
| 728 | -+ | ||
| 528 | +! |
- )+ is.null(isolate(input$group_by_var)), |
|
| 729 | -+ | ||
| 529 | +! |
-
+ cat_choices[1], |
|
| 730 | +530 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ isolate(input$group_by_var) |
| 731 | -! | +||
| 531 | +
- user_plot = ggplot2_args[["Density Plot"]],+ ), |
||
| 732 | +532 | ! |
- user_default = ggplot2_args$default,+ multiple = FALSE, |
| 733 | +533 | ! |
- module_plot = dev_ggplot2_args+ label_help = paste0("Dataset: ", dataname)
|
| 734 | +534 |
) |
|
| 735 | +535 |
-
+ }) |
|
| 736 | -! | +||
| 536 | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
||
| 737 | +537 | ! |
- all_ggplot2_args,+ output$group_by_vals_ui <- renderUI({
|
| 738 | +538 | ! |
- ggtheme = input$ggtheme- |
-
| 739 | -- |
- )+ req(input$group_by_var) |
|
| 740 | +539 | ||
| 741 | +540 | ! |
- teal.code::eval_code(+ choices <- teal.transform::value_choices(data_r(), input$group_by_var, input$group_by_var) |
| 742 | +541 | ! |
- common_code_q(),+ prev_choices <- isolate(input$group_by_vals) |
| 743 | -! | +||
| 542 | +
- substitute(+ |
||
| 744 | -! | +||
| 543 | +
- expr = g <- plot_call + labs + ggthemes + themes,+ # determine selected value based on filtered data |
||
| 745 | -! | +||
| 544 | +
- env = list(+ # display those previously selected values that are still available |
||
| 746 | +545 | ! |
- plot_call = plot_call,+ selected <- if (!is.null(prev_choices) && any(prev_choices %in% choices)) {
|
| 747 | +546 | ! |
- labs = parsed_ggplot2_args$labs,+ prev_choices[match(choices[choices %in% prev_choices], prev_choices)] |
| 748 | +547 | ! |
- themes = parsed_ggplot2_args$theme,+ } else if (!is.null(prev_choices) && |
| 749 | +548 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme+ !any(prev_choices %in% choices) && |
| 750 | -+ | ||
| 549 | +! |
- )+ isolate(prev_group_by_var()) == input$group_by_var) {
|
|
| 751 | +550 |
- )+ # if not any previously selected value is available and the grouping variable is the same, |
|
| 752 | +551 |
- ) %>%+ # then display NULL |
|
| 753 | +552 | ! |
- teal.code::eval_code(quote(print(g)))+ NULL |
| 754 | +553 |
- })+ } else {
|
|
| 755 | +554 |
-
+ # if new grouping variable (i.e. not any previously selected value is available), |
|
| 756 | +555 |
- # Cumulative distribution plot+ # then display all choices |
|
| 757 | +556 | ! |
- cumulative_plot_q <- reactive({
+ choices+ |
+
| 557 | ++ |
+ }+ |
+ |
| 558 | ++ | + | |
| 758 | +559 | ! |
- ANL <- common_code_q()[["ANL"]] # nolint+ prev_group_by_var(input$group_by_var) # set current group_by_var |
| 759 | +560 | ! |
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint+ validate(need(length(choices) < 100, "Please select group-by variable with fewer than 100 unique values")) |
| 760 | +561 | ||
| 761 | +562 | ! |
- qenv <- common_code_q()+ teal.widgets::optionalSelectInput( |
| 762 | -+ | ||
| 563 | +! |
-
+ session$ns("group_by_vals"),
|
|
| 763 | +564 | ! |
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ label = "Filter levels", |
| 764 | +565 | ! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ choices = choices, |
| 765 | -+ | ||
| 566 | +! |
-
+ selected = selected, |
|
| 766 | -+ | ||
| 567 | +! |
- # validation+ multiple = TRUE, |
|
| 767 | +568 | ! |
- teal::validate_has_data(ANL, 1)+ label_help = paste0("Dataset: ", dataname)
|
| 768 | +569 |
-
+ ) |
|
| 769 | +570 |
- # plot+ }) |
|
| 770 | -! | +||
| 571 | +
- plot_call <- substitute(+ |
||
| 771 | +572 | ! |
- expr = ANL %>% ggplot(aes(x = outlier_var_name)) ++ summary_plot_q <- reactive({
|
| 772 | +573 | ! |
- stat_ecdf(),+ req(input$summary_type == "Summary") # needed to trigger show r code update on tab change |
| 773 | +574 | ! |
- env = list(outlier_var_name = as.name(outlier_var))+ teal::validate_has_data(data_r(), 1) |
| 774 | +575 |
- )+ |
|
| 775 | +576 | ! |
- if (length(categorical_var) == 0) {
+ qenv <- common_code_q()+ |
+
| 577 | ++ | + | |
| 776 | +578 | ! |
- qenv <- teal.code::eval_code(+ if (input$any_na) {
|
| 777 | +579 | ! |
- qenv,+ new_col_name <- "**anyna**" # nolint (local variable is assigned and used) |
| 778 | +580 | ! |
- substitute(+ qenv <- teal.code::eval_code( |
| 779 | +581 | ! |
- expr = {
+ qenv, |
| 780 | +582 | ! |
- ecdf_df <- ANL %>%+ substitute( |
| 781 | +583 | ! |
- dplyr::mutate(+ expr = ANL[[new_col_name]] <- ifelse(rowSums(is.na(ANL)) > 0, NA, FALSE), # nolint |
| 782 | +584 | ! |
- y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]])+ env = list(new_col_name = new_col_name) |
| 783 | +585 |
- )+ ) |
|
| 784 | +586 |
-
+ ) |
|
| 785 | -! | +||
| 587 | +
- outlier_points <- dplyr::left_join(+ } |
||
| 786 | -! | +||
| 588 | +
- ecdf_df,+ |
||
| 787 | +589 | ! |
- ANL_OUTLIER,+ qenv <- teal.code::eval_code( |
| 788 | +590 | ! |
- by = dplyr::setdiff(names(ecdf_df), "y")- |
-
| 789 | -- |
- ) %>%+ qenv, |
|
| 790 | +591 | ! |
- dplyr::filter(!is.na(is_outlier_selected))- |
-
| 791 | -- |
- },+ substitute( |
|
| 792 | +592 | ! |
- env = list(outlier_var = outlier_var)+ expr = analysis_vars <- setdiff(colnames(ANL), data_keys), |
| 793 | -+ | ||
| 593 | +! |
- )+ env = list(data_keys = data_keys()) |
|
| 794 | +594 |
) |
|
| 795 | +595 |
- } else {
+ ) %>% |
|
| 796 | +596 | ! |
- qenv <- teal.code::eval_code(+ teal.code::eval_code( |
| 797 | +597 | ! |
- qenv,+ substitute( |
| 798 | +598 | ! |
- substitute(+ expr = summary_plot_obs <- data_frame_call[, analysis_vars] %>% |
| 799 | +599 | ! |
- expr = {
+ dplyr::summarise_all(list(function(x) sum(is.na(x)))) %>% |
| 800 | +600 | ! |
- all_categories <- lapply(+ tidyr::pivot_longer(tidyselect::everything(), names_to = "col", values_to = "n_na") %>% |
| 801 | +601 | ! |
- unique(ANL[[categorical_var]]),+ dplyr::mutate(n_not_na = nrow(ANL) - n_na) %>% |
| 802 | +602 | ! |
- function(x) {
+ tidyr::pivot_longer(-col, names_to = "isna", values_to = "n") %>% |
| 803 | +603 | ! |
- ANL <- ANL %>% dplyr::filter(get(categorical_var) == x) # nolint+ dplyr::mutate(isna = isna == "n_na", n_pct = n / nrow(ANL) * 100), |
| 804 | +604 | ! |
- anl_outlier2 <- ANL_OUTLIER %>% dplyr::filter(get(categorical_var) == x)+ env = list(data_frame_call = if (!inherits(data_r(), "tbl_df")) {
|
| 805 | +605 | ! |
- ecdf_df <- ANL %>%+ quote(tibble::as_tibble(ANL))+ |
+
| 606 | ++ |
+ } else {
|
|
| 806 | +607 | ! |
- dplyr::mutate(y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]]))+ quote(ANL) |
| 807 | +608 |
-
+ }) |
|
| 808 | -! | +||
| 609 | +
- dplyr::left_join(+ ) |
||
| 809 | -! | +||
| 610 | +
- ecdf_df,+ ) %>% |
||
| 810 | -! | +||
| 611 | +
- anl_outlier2,+ # x axis ordering according to number of missing values and alphabet |
||
| 811 | +612 | ! |
- by = dplyr::setdiff(names(ecdf_df), "y")+ teal.code::eval_code( |
| 812 | -+ | ||
| 613 | +! |
- ) %>%+ quote( |
|
| 813 | +614 | ! |
- dplyr::filter(!is.na(is_outlier_selected))+ expr = x_levels <- dplyr::filter(summary_plot_obs, isna) %>% |
| 814 | -+ | ||
| 615 | +! |
- }+ dplyr::arrange(n_pct, dplyr::desc(col)) %>% |
|
| 815 | -+ | ||
| 616 | +! |
- )+ dplyr::pull(col) %>% |
|
| 816 | +617 | ! |
- outlier_points <- do.call(rbind, all_categories)+ create_cols_labels() |
| 817 | +618 |
- },+ ) |
|
| 818 | -! | +||
| 619 | +
- env = list(categorical_var = categorical_var, outlier_var = outlier_var)+ ) |
||
| 819 | +620 |
- )+ |
|
| 820 | +621 |
- )+ # always set "**anyna**" level as the last one |
|
| 821 | +622 | ! |
- plot_call <- substitute(+ if (isolate(input$any_na)) {
|
| 822 | +623 | ! |
- expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)),+ qenv <- teal.code::eval_code( |
| 823 | +624 | ! |
- env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var))+ qenv,+ |
+
| 625 | +! | +
+ quote(x_levels <- c(setdiff(x_levels, "**anyna**"), "**anyna**")) |
|
| 824 | +626 |
) |
|
| 825 | +627 |
} |
|
| 826 | +628 | ||
| 827 | +629 | ! |
dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 828 | +630 | ! |
- labs = list(color = "Is outlier?"),+ labs = list(x = "Variable", y = "Missing observations"), |
| 829 | +631 | ! |
- theme = list(legend.position = "top")+ theme = list(legend.position = "bottom", axis.text.x = quote(element_text(angle = 45, hjust = 1))) |
| 830 | +632 |
) |
|
| 831 | +633 | ||
| 832 | +634 | ! |
all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 833 | +635 | ! |
- user_plot = ggplot2_args[["Cumulative Distribution Plot"]],+ user_plot = ggplot2_args[["Summary Obs"]], |
| 834 | +636 | ! |
user_default = ggplot2_args$default, |
| 835 | +637 | ! |
module_plot = dev_ggplot2_args |
| 836 | +638 |
) |
|
| 837 | +639 | ||
| 838 | +640 | ! |
parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 839 | +641 | ! |
all_ggplot2_args, |
| 840 | +642 | ! |
ggtheme = input$ggtheme |
| 841 | +643 |
) |
|
| 842 | +644 | ||
| 843 | +645 | ! |
- teal.code::eval_code(+ qenv <- teal.code::eval_code( |
| 844 | +646 | ! |
qenv, |
| 845 | +647 | ! |
substitute( |
| 846 | +648 | ! |
- expr = g <- plot_call ++ p1 <- summary_plot_obs %>% |
| 847 | +649 | ! |
- geom_point(data = outlier_points, aes(x = outlier_var_name, y = y, color = is_outlier_selected)) ++ ggplot() + |
| 848 | +650 | ! |
- scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
+ aes( |
| 849 | +651 | ! |
- labs + ggthemes + themes,+ x = factor(create_cols_labels(col), levels = x_levels), |
| 850 | +652 | ! |
- env = list(+ y = n_pct, |
| 851 | +653 | ! |
- plot_call = plot_call,+ fill = isna+ |
+
| 654 | ++ |
+ ) + |
|
| 852 | +655 | ! |
- outlier_var_name = as.name(outlier_var),+ geom_bar(position = "fill", stat = "identity") + |
| 853 | +656 | ! |
- labs = parsed_ggplot2_args$labs,+ scale_fill_manual( |
| 854 | +657 | ! |
- themes = parsed_ggplot2_args$theme,+ name = "", |
| 855 | +658 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme+ values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
|
| 856 | -+ | ||
| 659 | +! |
- )+ labels = c("Present", "Missing")
|
|
| 857 | +660 |
- )+ ) + |
|
| 858 | -+ | ||
| 661 | +! |
- ) %>%+ scale_y_continuous(labels = scales::percent_format(), breaks = seq(0, 1, by = 0.1), expand = c(0, 0)) + |
|
| 859 | +662 | ! |
- teal.code::eval_code(quote(print(g)))+ geom_text( |
| 860 | -+ | ||
| 663 | +! |
- })+ aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),
|
|
| 861 | -+ | ||
| 664 | +! |
-
+ hjust = 1, |
|
| 862 | +665 | ! |
- final_q <- reactive({
+ color = "black"+ |
+
| 666 | ++ |
+ ) + |
|
| 863 | +667 | ! |
- req(input$tabs)+ labs + |
| 864 | +668 | ! |
- tab_type <- input$tabs+ ggthemes + |
| 865 | +669 | ! |
- result_q <- if (tab_type == "Boxplot") {
+ themes + |
| 866 | +670 | ! |
- boxplot_q()+ coord_flip(), |
| 867 | +671 | ! |
- } else if (tab_type == "Density Plot") {
+ env = list( |
| 868 | +672 | ! |
- density_plot_q()+ labs = parsed_ggplot2_args$labs, |
| 869 | +673 | ! |
- } else if (tab_type == "Cumulative Distribution Plot") {
+ themes = parsed_ggplot2_args$theme, |
| 870 | +674 | ! |
- cumulative_plot_q()+ ggthemes = parsed_ggplot2_args$ggtheme |
| 871 | +675 |
- }+ ) |
|
| 872 | +676 |
- # used to display table when running show-r-code code+ ) |
|
| 873 | +677 |
- # added after the plots so that a change in selected columns doesn't affect+ ) |
|
| 874 | +678 |
- # brush selection.- |
- |
| 875 | -! | -
- teal.code::eval_code(+ |
|
| 876 | +679 | ! |
- result_q,+ if (isTRUE(input$if_patients_plot)) {
|
| 877 | +680 | ! |
- substitute(+ qenv <- teal.code::eval_code( |
| 878 | +681 | ! |
- expr = {
+ qenv, |
| 879 | +682 | ! |
- columns_index <- union(+ substitute( |
| 880 | +683 | ! |
- setdiff(names(ANL_OUTLIER), "is_outlier_selected"),+ expr = parent_keys <- keys, |
| 881 | +684 | ! |
- table_columns+ env = list(keys = data_parent_keys()) |
| 882 | +685 |
- )- |
- |
| 883 | -! | -
- ANL_OUTLIER_EXTENDED[ANL_OUTLIER_EXTENDED$is_outlier_selected, columns_index]+ ) |
|
| 884 | +686 |
- },- |
- |
| 885 | -! | -
- env = list(+ ) %>% |
|
| 886 | +687 | ! |
- table_columns = input$table_ui_columns- |
-
| 887 | -- |
- )- |
- |
| 888 | -- |
- )- |
- |
| 889 | -- |
- )- |
- |
| 890 | -- |
- })- |
- |
| 891 | -- | - - | -|
| 892 | -- |
- # slider text+ teal.code::eval_code(quote(ndistinct_subjects <- dplyr::n_distinct(ANL[, parent_keys]))) %>% |
|
| 893 | +688 | ! |
- output$ui_outlier_help <- renderUI({
+ teal.code::eval_code( |
| 894 | +689 | ! |
- req(input$method)+ quote( |
| 895 | +690 | ! |
- if (input$method == "IQR") {
+ summary_plot_patients <- ANL[, c(parent_keys, analysis_vars)] %>% |
| 896 | +691 | ! |
- req(input$iqr_slider)+ dplyr::group_by_at(parent_keys) %>% |
| 897 | +692 | ! |
- tags$small(+ dplyr::summarise_all(anyNA) %>% |
| 898 | +693 | ! |
- withMathJax(+ tidyr::pivot_longer(cols = !tidyselect::all_of(parent_keys), names_to = "col", values_to = "anyna") %>% |
| 899 | +694 | ! |
- helpText(+ dplyr::group_by_at(c("col")) %>%
|
| 900 | +695 | ! |
- "Outlier data points (\\(x \\lt Q1 - ", input$iqr_slider, "\\times IQR\\) or \\(+ dplyr::summarise(count_na = sum(anyna)) %>% |
| 901 | +696 | ! |
- Q3 + ", input$iqr_slider, "\\times IQR \\lt x\\))+ dplyr::mutate(count_not_na = ndistinct_subjects - count_na) %>% |
| 902 | +697 | ! |
- are displayed in red on the plot and can be visualized in the table below."- |
-
| 903 | -- |
- ),+ tidyr::pivot_longer(-c(col), names_to = "isna", values_to = "n") %>% |
|
| 904 | +698 | ! |
- if (input$split_outliers) {
+ dplyr::mutate(isna = isna == "count_na", n_pct = n / ndistinct_subjects * 100) %>% |
| 905 | +699 | ! |
- withMathJax(helpText("Note: Quantiles are calculated per group."))
+ dplyr::arrange_at(c("isna", "n"), .funs = dplyr::desc)
|
| 906 | +700 |
- }+ ) |
|
| 907 | +701 |
) |
|
| 908 | +702 |
- )+ |
|
| 909 | +703 | ! |
- } else if (input$method == "Z-score") {
+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 910 | +704 | ! |
- req(input$zscore_slider)+ labs = list(x = "", y = "Missing patients"), |
| 911 | +705 | ! |
- tags$small(+ theme = list( |
| 912 | +706 | ! |
- withMathJax(+ legend.position = "bottom", |
| 913 | +707 | ! |
- helpText(+ axis.text.x = quote(element_text(angle = 45, hjust = 1)), |
| 914 | +708 | ! |
- "Outlier data points (\\(Zscore(x) < -", input$zscore_slider,+ axis.text.y = quote(element_blank()) |
| 915 | -! | +||
| 709 | +
- "\\) or \\(", input$zscore_slider, "< Zscore(x) \\))
+ ) |
||
| 916 | -! | +||
| 710 | +
- are displayed in red on the plot and can be visualized in the table below."+ ) |
||
| 917 | +711 |
- ),+ |
|
| 918 | +712 | ! |
- if (input$split_outliers) {
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 919 | +713 | ! |
- withMathJax(helpText(" Note: Z-scores are calculated per group."))
+ user_plot = ggplot2_args[["Summary Patients"]], |
| 920 | -+ | ||
| 714 | +! |
- }+ user_default = ggplot2_args$default, |
|
| 921 | -+ | ||
| 715 | +! |
- )+ module_plot = dev_ggplot2_args |
|
| 922 | +716 |
) |
|
| 923 | -! | +||
| 717 | +
- } else if (input$method == "Percentile") {
+
|
||
| 924 | +718 | ! |
- req(input$percentile_slider)+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 925 | +719 | ! |
- tags$small(+ all_ggplot2_args, |
| 926 | +720 | ! |
- withMathJax(+ ggtheme = input$ggtheme |
| 927 | -! | +||
| 721 | +
- helpText(+ ) |
||
| 928 | -! | +||
| 722 | +
- "Outlier/extreme data points (\\( Percentile(x) <", input$percentile_slider,+ |
||
| 929 | +723 | ! |
- "\\) or \\(", 1 - input$percentile_slider, " < Percentile(x) \\))
+ qenv <- teal.code::eval_code( |
| 930 | +724 | ! |
- are displayed in red on the plot and can be visualized in the table below."- |
-
| 931 | -- |
- ),+ qenv, |
|
| 932 | +725 | ! |
- if (input$split_outliers) {
+ substitute( |
| 933 | +726 | ! |
- withMathJax(helpText("Note: Percentiles are calculated per group."))
- |
-
| 934 | -- |
- }- |
- |
| 935 | -- |
- )- |
- |
| 936 | -- |
- )- |
- |
| 937 | -- |
- }+ p2 <- summary_plot_patients %>% |
|
| 938 | -+ | ||
| 727 | +! |
- })+ ggplot() + |
|
| 939 | -+ | ||
| 728 | +! |
-
+ aes_( |
|
| 940 | +729 | ! |
- boxplot_r <- reactive({
+ x = ~ factor(create_cols_labels(col), levels = x_levels), |
| 941 | +730 | ! |
- teal::validate_inputs(iv_r())+ y = ~n_pct, |
| 942 | +731 | ! |
- boxplot_q()[["g"]]+ fill = ~isna |
| 943 | +732 |
- })+ ) + |
|
| 944 | +733 | ! |
- density_plot_r <- reactive({
+ geom_bar(alpha = 1, stat = "identity", position = "fill") + |
| 945 | +734 | ! |
- teal::validate_inputs(iv_r())+ scale_y_continuous(labels = scales::percent_format(), breaks = seq(0, 1, by = 0.1), expand = c(0, 0)) + |
| 946 | +735 | ! |
- density_plot_q()[["g"]]- |
-
| 947 | -- |
- })+ scale_fill_manual( |
|
| 948 | +736 | ! |
- cumulative_plot_r <- reactive({
+ name = "", |
| 949 | +737 | ! |
- teal::validate_inputs(iv_r())+ values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
|
| 950 | +738 | ! |
- cumulative_plot_q()[["g"]]- |
-
| 951 | -- |
- })+ labels = c("Present", "Missing")
|
|
| 952 | +739 |
-
+ ) + |
|
| 953 | +740 | ! |
- box_pws <- teal.widgets::plot_with_settings_srv(+ geom_text( |
| 954 | +741 | ! |
- id = "box_plot",+ aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),
|
| 955 | +742 | ! |
- plot_r = boxplot_r,+ hjust = 1, |
| 956 | +743 | ! |
- height = plot_height,+ color = "black" |
| 957 | -! | +||
| 744 | +
- width = plot_width,+ ) + |
||
| 958 | +745 | ! |
- brushing = TRUE+ labs + |
| 959 | -+ | ||
| 746 | +! |
- )+ ggthemes + |
|
| 960 | -+ | ||
| 747 | +! |
-
+ themes + |
|
| 961 | +748 | ! |
- density_pws <- teal.widgets::plot_with_settings_srv(+ coord_flip(), |
| 962 | +749 | ! |
- id = "density_plot",+ env = list( |
| 963 | +750 | ! |
- plot_r = density_plot_r,+ labs = parsed_ggplot2_args$labs, |
| 964 | +751 | ! |
- height = plot_height,+ themes = parsed_ggplot2_args$theme, |
| 965 | +752 | ! |
- width = plot_width,+ ggthemes = parsed_ggplot2_args$ggtheme |
| 966 | -! | +||
| 753 | +
- brushing = TRUE+ ) |
||
| 967 | +754 |
- )+ ) |
|
| 968 | +755 |
-
+ ) %>% |
|
| 969 | +756 | ! |
- cum_density_pws <- teal.widgets::plot_with_settings_srv(+ teal.code::eval_code( |
| 970 | +757 | ! |
- id = "cum_density_plot",+ quote({
|
| 971 | +758 | ! |
- plot_r = cumulative_plot_r,+ g1 <- ggplotGrob(p1) |
| 972 | +759 | ! |
- height = plot_height,+ g2 <- ggplotGrob(p2) |
| 973 | +760 | ! |
- width = plot_width,+ g <- gridExtra::gtable_cbind(g1, g2, size = "first") |
| 974 | +761 | ! |
- brushing = TRUE+ g$heights <- grid::unit.pmax(g1$heights, g2$heights) |
| 975 | -+ | ||
| 762 | +! |
- )+ grid::grid.newpage() |
|
| 976 | +763 | - - | -|
| 977 | -! | -
- choices <- teal.transform::variable_choices(data[[dataname_first]]())+ }) |
|
| 978 | +764 |
-
+ ) |
|
| 979 | -! | +||
| 765 | +
- observeEvent(common_code_q(), {
+ } else {
|
||
| 980 | +766 | ! |
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint+ qenv <- teal.code::eval_code( |
| 981 | +767 | ! |
- teal.widgets::updateOptionalSelectInput(+ qenv, |
| 982 | +768 | ! |
- session,+ quote({
|
| 983 | +769 | ! |
- inputId = "table_ui_columns",+ g <- ggplotGrob(p1) |
| 984 | +770 | ! |
- choices = dplyr::setdiff(choices, names(ANL_OUTLIER)),+ grid::grid.newpage() |
| 985 | -! | +||
| 771 | +
- selected = isolate(input$table_ui_columns)+ }) |
||
| 986 | +772 |
- )+ ) |
|
| 987 | +773 |
- })+ } |
|
| 988 | +774 | ||
| 989 | -! | -
- output$table_ui <- DT::renderDataTable(- |
- |
| 990 | +775 | ! |
- expr = {
+ teal.code::eval_code( |
| 991 | +776 | ! |
- tab <- input$tabs+ qenv, |
| 992 | +777 | ! |
- req(tab) # tab is NULL upon app launch, hence will crash without this statement+ quote(grid::grid.draw(g)) |
| 993 | -! | +||
| 778 | +
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)+ ) |
||
| 994 | -! | +||
| 779 | +
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)+ }) |
||
| 995 | +780 | ||
| 996 | +781 | ! |
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint+ summary_plot_r <- reactive(summary_plot_q()[["g"]]) |
| 997 | -! | +||
| 782 | +
- ANL_OUTLIER_EXTENDED <- common_code_q()[["ANL_OUTLIER_EXTENDED"]] # nolint+ |
||
| 998 | +783 | ! |
- ANL <- common_code_q()[["ANL"]] # nolint+ combination_cutoff_q <- reactive({
|
| 999 | +784 | ! |
- plot_brush <- if (tab == "Boxplot") {
+ req(common_code_q()) |
| 1000 | +785 | ! |
- boxplot_r()+ teal.code::eval_code( |
| 1001 | +786 | ! |
- box_pws$brush()+ common_code_q(), |
| 1002 | +787 | ! |
- } else if (tab == "Density Plot") {
+ quote( |
| 1003 | +788 | ! |
- density_plot_r()+ combination_cutoff <- ANL %>% |
| 1004 | +789 | ! |
- density_pws$brush()+ dplyr::mutate_all(is.na) %>% |
| 1005 | +790 | ! |
- } else if (tab == "Cumulative Distribution Plot") {
+ dplyr::group_by_all() %>% |
| 1006 | +791 | ! |
- cumulative_plot_r()+ dplyr::tally() %>% |
| 1007 | +792 | ! |
- cum_density_pws$brush()+ dplyr::ungroup() |
| 1008 | +793 |
- }+ ) |
|
| 1009 | +794 |
-
+ ) |
|
| 1010 | +795 |
- # removing unused column ASAP- |
- |
| 1011 | -! | -
- ANL_OUTLIER$order <- ANL$order <- NULL # nolint+ }) |
|
| 1012 | +796 | ||
| 1013 | +797 | ! |
- display_table <- if (!is.null(plot_brush)) {
+ output$cutoff <- renderUI({
|
| 1014 | +798 | ! |
- if (length(categorical_var) > 0) {
+ x <- combination_cutoff_q()[["combination_cutoff"]]$n |
| 1015 | +799 |
- # due to reordering, the x-axis label may be changed to something like "reorder(categorical_var, order)"+ |
|
| 1016 | -! | +||
| 800 | +
- if (tab == "Boxplot") {
+ # select 10-th from the top |
||
| 1017 | +801 | ! |
- plot_brush$mapping$x <- categorical_var+ n <- length(x) |
| 1018 | -+ | ||
| 802 | +! |
- } else {
+ idx <- max(1, n - 10) |
|
| 1019 | -+ | ||
| 803 | +! |
- # the other plots use facetting+ prev_value <- isolate(input$combination_cutoff) |
|
| 1020 | -+ | ||
| 804 | +! |
- # so it is panelvar1 that gets relabelled to "reorder(categorical_var, order)"+ value <- `if`( |
|
| 1021 | +805 | ! |
- plot_brush$mapping$panelvar1 <- categorical_var+ is.null(prev_value) || prev_value > max(x) || prev_value < min(x),+ |
+
| 806 | +! | +
+ sort(x, partial = idx)[idx], prev_value |
|
| 1022 | +807 |
- }+ ) |
|
| 1023 | +808 |
- } else {
+
|
|
| 1024 | +809 | ! |
- if (tab == "Boxplot") {
+ teal.widgets::optionalSliderInputValMinMax( |
| 1025 | -+ | ||
| 810 | +! |
- # in boxplot with no categorical variable, there is no column in ANL that would correspond to x-axis+ session$ns("combination_cutoff"),
|
|
| 1026 | -+ | ||
| 811 | +! |
- # so a column needs to be inserted with the value "Entire dataset" because that's the label used in plot+ "Combination cut-off", |
|
| 1027 | +812 | ! |
- ANL[[plot_brush$mapping$x]] <- "Entire dataset" # nolint+ c(value, range(x)) |
| 1028 | +813 |
- }+ ) |
|
| 1029 | +814 |
- }+ }) |
|
| 1030 | +815 | ||
| 1031 | -+ | ||
| 816 | +! |
- # in density and cumulative plots, ANL does not have a column corresponding to y-axis.+ combination_plot_q <- reactive({
|
|
| 1032 | -+ | ||
| 817 | +! |
- # so they need to be computed and attached to ANL+ req(input$summary_type == "Combinations", input$combination_cutoff, combination_cutoff_q()) |
|
| 1033 | +818 | ! |
- if (tab == "Density Plot") {
+ teal::validate_has_data(data_r(), 1) |
| 1034 | -! | +||
| 819 | +
- plot_brush$mapping$y <- "density"+ |
||
| 1035 | +820 | ! |
- ANL$density <- plot_brush$ymin # nolint #either ymin or ymax will work+ qenv <- teal.code::eval_code( |
| 1036 | +821 | ! |
- } else if (tab == "Cumulative Distribution Plot") {
+ combination_cutoff_q(), |
| 1037 | +822 | ! |
- plot_brush$mapping$y <- "cdf"+ substitute( |
| 1038 | +823 | ! |
- if (length(categorical_var) > 0) {
+ expr = data_combination_plot_cutoff <- combination_cutoff %>% |
| 1039 | +824 | ! |
- ANL <- ANL %>% # nolint+ dplyr::filter(n >= combination_cutoff_value) %>% |
| 1040 | +825 | ! |
- dplyr::group_by(!!as.name(plot_brush$mapping$panelvar1)) %>%+ dplyr::mutate(id = rank(-n, ties.method = "first")) %>% |
| 1041 | +826 | ! |
- dplyr::mutate(cdf = stats::ecdf(!!as.name(outlier_var))(!!as.name(outlier_var)))+ tidyr::pivot_longer(-c(n, id), names_to = "key", values_to = "value") %>% |
| 1042 | -+ | ||
| 827 | +! |
- } else {
+ dplyr::arrange(n), |
|
| 1043 | +828 | ! |
- ANL$cdf <- stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]]) # nolint+ env = list(combination_cutoff_value = input$combination_cutoff) |
| 1044 | +829 |
- }+ ) |
|
| 1045 | +830 |
- }+ ) |
|
| 1046 | +831 | ||
| 1047 | -! | +||
| 832 | +
- brushed_rows <- brushedPoints(ANL, plot_brush)+ # find keys in dataset not selected in the UI and remove them from dataset |
||
| 1048 | +833 | ! |
- if (nrow(brushed_rows) > 0) {
+ keys_not_selected <- setdiff(data_keys(), input$variables_select) |
| 1049 | -+ | ||
| 834 | +! |
- # now we need to remove extra column from ANL so that it will have the same columns as ANL_OUTLIER+ if (length(keys_not_selected) > 0) {
|
|
| 1050 | -+ | ||
| 835 | +! |
- # so that dplyr::intersect will work+ qenv <- teal.code::eval_code( |
|
| 1051 | +836 | ! |
- if (tab == "Density Plot") {
+ qenv, |
| 1052 | +837 | ! |
- brushed_rows$density <- NULL+ substitute( |
| 1053 | +838 | ! |
- } else if (tab == "Cumulative Distribution Plot") {
+ expr = data_combination_plot_cutoff <- data_combination_plot_cutoff %>% |
| 1054 | +839 | ! |
- brushed_rows$cdf <- NULL+ dplyr::filter(!key %in% keys_not_selected), |
| 1055 | +840 | ! |
- } else if (tab == "Boxplot" && length(categorical_var) == 0) {
+ env = list(keys_not_selected = keys_not_selected) |
| 1056 | -! | +||
| 841 | +
- brushed_rows[[plot_brush$mapping$x]] <- NULL+ ) |
||
| 1057 | +842 |
- }+ ) |
|
| 1058 | +843 |
- # is_outlier_selected is part of ANL_OUTLIER so needed here+ } |
|
| 1059 | -! | +||
| 844 | +
- brushed_rows$is_outlier_selected <- TRUE+ |
||
| 1060 | +845 | ! |
- dplyr::intersect(ANL_OUTLIER, brushed_rows)+ qenv <- teal.code::eval_code( |
| 1061 | -+ | ||
| 846 | +! |
- } else {
+ qenv, |
|
| 1062 | +847 | ! |
- ANL_OUTLIER[0, ]+ quote( |
| 1063 | -+ | ||
| 848 | +! |
- }+ labels <- data_combination_plot_cutoff %>% |
|
| 1064 | -+ | ||
| 849 | +! |
- } else {
+ dplyr::filter(key == key[[1]]) %>% |
|
| 1065 | +850 | ! |
- ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ]+ getElement(name = 1) |
| 1066 | +851 |
- }+ ) |
|
| 1067 | +852 | - - | -|
| 1068 | -! | -
- display_table$is_outlier_selected <- NULL+ ) |
|
| 1069 | +853 | ||
| 1070 | -+ | ||
| 854 | +! |
- # Extend the brushed ANL_OUTLIER with additional columns+ dev_ggplot2_args1 <- teal.widgets::ggplot2_args( |
|
| 1071 | +855 | ! |
- dplyr::left_join(+ labs = list(x = "", y = ""), |
| 1072 | +856 | ! |
- display_table,+ theme = list( |
| 1073 | +857 | ! |
- dplyr::select(ANL_OUTLIER_EXTENDED, -"is_outlier_selected"),+ legend.position = "bottom", |
| 1074 | +858 | ! |
- by = names(display_table)+ axis.text.x = quote(element_blank()) |
| 1075 | +859 |
- ) %>%+ ) |
|
| 1076 | -! | +||
| 860 | +
- dplyr::select(union(names(display_table), input$table_ui_columns))+ ) |
||
| 1077 | +861 |
- },+ |
|
| 1078 | +862 | ! |
- options = list(+ all_ggplot2_args1 <- teal.widgets::resolve_ggplot2_args( |
| 1079 | +863 | ! |
- searching = FALSE, language = list(+ user_plot = ggplot2_args[["Combinations Hist"]], |
| 1080 | +864 | ! |
- zeroRecords = "The brushed area does not contain outlier observations for the currently defined threshold"- |
-
| 1081 | -- |
- ),+ user_default = ggplot2_args$default, |
|
| 1082 | +865 | ! |
- pageLength = input$table_ui_rows+ module_plot = dev_ggplot2_args1 |
| 1083 | +866 |
) |
|
| 1084 | -- |
- )- |
- |
| 1085 | +867 | ||
| 1086 | -! | -
- output$total_outliers <- renderUI({
- |
- |
| 1087 | +868 | ! |
- shiny::req(iv_r()$is_valid())+ parsed_ggplot2_args1 <- teal.widgets::parse_ggplot2_args( |
| 1088 | +869 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint+ all_ggplot2_args1, |
| 1089 | +870 | ! |
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]] # nolint+ ggtheme = "void" |
| 1090 | -! | +||
| 871 | +
- teal::validate_has_data(ANL, 1)+ ) |
||
| 1091 | -! | +||
| 872 | +
- ANL_OUTLIER_SELECTED <- ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ] # nolint+ |
||
| 1092 | +873 | ! |
- h5(+ dev_ggplot2_args2 <- teal.widgets::ggplot2_args( |
| 1093 | +874 | ! |
- sprintf(+ labs = list(x = "", y = ""), |
| 1094 | +875 | ! |
- "%s %d / %d [%.02f%%]",+ theme = list( |
| 1095 | +876 | ! |
- "Total number of outlier(s):",+ legend.position = "bottom", |
| 1096 | +877 | ! |
- nrow(ANL_OUTLIER_SELECTED),+ axis.text.x = quote(element_blank()), |
| 1097 | +878 | ! |
- nrow(ANL),+ axis.ticks = quote(element_blank()), |
| 1098 | +879 | ! |
- 100 * nrow(ANL_OUTLIER_SELECTED) / nrow(ANL)+ panel.grid.major = quote(element_blank()) |
| 1099 | +880 |
) |
|
| 1100 | +881 |
) |
|
| 1101 | -- |
- })- |
- |
| 1102 | +882 | ||
| 1103 | -! | -
- output$total_missing <- renderUI({
- |
- |
| 1104 | +883 | ! |
- if (n_outlier_missing() > 0) {
+ all_ggplot2_args2 <- teal.widgets::resolve_ggplot2_args( |
| 1105 | +884 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint+ user_plot = ggplot2_args[["Combinations Main"]], |
| 1106 | +885 | ! |
- helpText(+ user_default = ggplot2_args$default, |
| 1107 | +886 | ! |
- sprintf(+ module_plot = dev_ggplot2_args2 |
| 1108 | -! | +||
| 887 | +
- "%s %d / %d [%.02f%%]",+ ) |
||
| 1109 | -! | +||
| 888 | +
- "Total number of row(s) with missing values:",+ |
||
| 1110 | +889 | ! |
- n_outlier_missing(),+ parsed_ggplot2_args2 <- teal.widgets::parse_ggplot2_args( |
| 1111 | +890 | ! |
- nrow(ANL),+ all_ggplot2_args2, |
| 1112 | +891 | ! |
- 100 * (n_outlier_missing()) / nrow(ANL)- |
-
| 1113 | -- |
- )- |
- |
| 1114 | -- |
- )- |
- |
| 1115 | -- |
- }+ ggtheme = input$ggtheme |
|
| 1116 | +892 |
- })+ ) |
|
| 1117 | +893 | ||
| 1118 | +894 | ! |
- output$table_ui_wrap <- renderUI({
+ teal.code::eval_code( |
| 1119 | +895 | ! |
- shiny::req(iv_r()$is_valid())+ qenv, |
| 1120 | +896 | ! |
- tagList(+ substitute( |
| 1121 | +897 | ! |
- teal.widgets::optionalSelectInput(+ expr = {
|
| 1122 | +898 | ! |
- inputId = session$ns("table_ui_columns"),
+ p1 <- data_combination_plot_cutoff %>% |
| 1123 | +899 | ! |
- label = "Choose additional columns",+ dplyr::select(id, n) %>% |
| 1124 | +900 | ! |
- choices = NULL,+ dplyr::distinct() %>% |
| 1125 | +901 | ! |
- selected = NULL,+ ggplot(aes(x = id, y = n)) + |
| 1126 | +902 | ! |
- multiple = TRUE- |
-
| 1127 | -- |
- ),+ geom_bar(stat = "identity", fill = c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]) +
|
|
| 1128 | +903 | ! |
- h4("Outlier Table"),
+ geom_text(aes(label = n), position = position_dodge(width = 0.9), vjust = -0.25) + |
| 1129 | +904 | ! |
- teal.widgets::get_dt_rows(session$ns("table_ui"), session$ns("table_ui_rows")),
+ ylim(c(0, max(data_combination_plot_cutoff$n) * 1.5)) + |
| 1130 | +905 | ! |
- DT::dataTableOutput(session$ns("table_ui"))
+ labs1 + |
| 1131 | -+ | ||
| 906 | +! |
- )+ ggthemes1 + |
|
| 1132 | -+ | ||
| 907 | +! |
- })+ themes1 |
|
| 1133 | +908 | ||
| 1134 | +909 | ! |
- teal.widgets::verbatim_popup_srv(+ graph_number_rows <- length(unique(data_combination_plot_cutoff$id)) |
| 1135 | +910 | ! |
- id = "warning",+ graph_number_cols <- nrow(data_combination_plot_cutoff) / graph_number_rows |
| 1136 | -! | +||
| 911 | +
- verbatim_content = reactive(teal.code::get_warnings(final_q())),+ |
||
| 1137 | +912 | ! |
- title = "Warning",+ p2 <- data_combination_plot_cutoff %>% ggplot() + |
| 1138 | +913 | ! |
- disabled = reactive(is.null(teal.code::get_warnings(final_q())))- |
-
| 1139 | -- |
- )+ aes(x = create_cols_labels(key), y = id - 0.5, fill = value) + |
|
| 1140 | -+ | ||
| 914 | +! |
-
+ geom_tile(alpha = 0.85, height = 0.95) + |
|
| 1141 | +915 | ! |
- teal.widgets::verbatim_popup_srv(+ scale_fill_manual( |
| 1142 | +916 | ! |
- id = "rcode",+ name = "", |
| 1143 | +917 | ! |
- verbatim_content = reactive(teal.code::get_code(final_q())),+ values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
|
| 1144 | +918 | ! |
- title = "Show R Code for Outlier"+ labels = c("Present", "Missing")
|
| 1145 | +919 |
- )+ ) + |
|
| 1146 | -+ | ||
| 920 | +! |
-
+ geom_hline(yintercept = seq_len(1 + graph_number_rows) - 1) + |
|
| 1147 | -+ | ||
| 921 | +! |
- ### REPORTER+ geom_vline(xintercept = seq_len(1 + graph_number_cols) - 0.5, linetype = "dotted") + |
|
| 1148 | +922 | ! |
- if (with_reporter) {
+ coord_flip() + |
| 1149 | +923 | ! |
- card_fun <- function(comment) {
+ labs2 + |
| 1150 | +924 | ! |
- card <- teal::TealReportCard$new()+ ggthemes2 + |
| 1151 | +925 | ! |
- tab_type <- input$tabs+ themes2 |
| 1152 | -! | +||
| 926 | +
- card$set_name(paste0("Outliers - ", tab_type))
+
|
||
| 1153 | +927 | ! |
- card$append_text(tab_type, "header2")+ g1 <- ggplotGrob(p1) |
| 1154 | +928 | ! |
- if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ g2 <- ggplotGrob(p2) |
| 1155 | +929 | ||
| 1156 | -! | -
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)- |
- |
| 1157 | +930 | ! |
- if (length(categorical_var) > 0) {
+ g <- gridExtra::gtable_rbind(g1, g2, size = "last") |
| 1158 | +931 | ! |
- summary_table <- common_code_q()[["summary_table"]]+ g$heights[7] <- grid::unit(0.2, "null") # rescale to get the bar chart smaller |
| 1159 | +932 | ! |
- card$append_text("Summary Table", "header3")
+ grid::grid.newpage() |
| 1160 | +933 | ! |
- card$append_table(summary_table)+ grid::grid.draw(g) |
| 1161 | +934 |
- }+ }, |
|
| 1162 | +935 | ! |
- card$append_text("Plot", "header3")
+ env = list( |
| 1163 | +936 | ! |
- if (tab_type == "Boxplot") {
+ labs1 = parsed_ggplot2_args1$labs, |
| 1164 | +937 | ! |
- card$append_plot(boxplot_r(), dim = box_pws$dim())+ themes1 = parsed_ggplot2_args1$theme, |
| 1165 | +938 | ! |
- } else if (tab_type == "Density Plot") {
+ ggthemes1 = parsed_ggplot2_args1$ggtheme, |
| 1166 | +939 | ! |
- card$append_plot(density_plot_r(), dim = density_pws$dim())+ labs2 = parsed_ggplot2_args2$labs, |
| 1167 | +940 | ! |
- } else if (tab_type == "Cumulative Distribution Plot") {
+ themes2 = parsed_ggplot2_args2$theme, |
| 1168 | +941 | ! |
- card$append_plot(cumulative_plot_r(), dim = cum_density_pws$dim())+ ggthemes2 = parsed_ggplot2_args2$ggtheme |
| 1169 | +942 |
- }+ ) |
|
| 1170 | -! | +||
| 943 | +
- if (!comment == "") {
+ ) |
||
| 1171 | -! | +||
| 944 | +
- card$append_text("Comment", "header3")
+ )+ |
+ ||
| 945 | ++ |
+ })+ |
+ |
| 946 | ++ | + | |
| 1172 | +947 | ! |
- card$append_text(comment)+ combination_plot_r <- reactive(combination_plot_q()[["g"]]) |
| 1173 | +948 |
- }+ |
|
| 1174 | +949 | ! |
- card$append_src(paste(teal.code::get_code(final_q()), collapse = "\n"))+ summary_table_q <- reactive({
|
| 1175 | +950 | ! |
- card+ req( |
| 1176 | -+ | ||
| 951 | +! |
- }+ input$summary_type == "By Variable Levels", # needed to trigger show r code update on tab change |
|
| 1177 | +952 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ common_code_q() |
| 1178 | +953 |
- }+ ) |
|
| 1179 | -+ | ||
| 954 | +! |
- ###+ teal::validate_has_data(data_r(), 1) |
|
| 1180 | +955 |
- })+ |
|
| 1181 | +956 |
- }+ # extract the ANL dataset for use in further validation |
| 1 | -+ | ||
| 957 | +! |
- #' Response Plots+ anl <- common_code_q()[["ANL"]] |
|
| 2 | +958 |
- #' @md+ |
|
| 3 | -+ | ||
| 959 | +! |
- #'+ group_var <- input$group_by_var |
|
| 4 | -+ | ||
| 960 | +! |
- #' @inheritParams teal::module+ validate( |
|
| 5 | -+ | ||
| 961 | +! |
- #' @inheritParams shared_params+ need( |
|
| 6 | -+ | ||
| 962 | +! |
- #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ is.null(group_var) || |
|
| 7 | -+ | ||
| 963 | +! |
- #' Which variable to use as the response. You can define one fixed column by using the+ length(unique(anl[[group_var]])) < 100, |
|
| 8 | -+ | ||
| 964 | +! |
- #' setting `fixed = TRUE` inside the `select_spec`.+ "Please select group-by variable with fewer than 100 unique values" |
|
| 9 | +965 |
- #' `data_extract_spec` must not allow multiple selection in this case.+ ) |
|
| 10 | +966 |
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ ) |
|
| 11 | +967 |
- #' Which variable to use on the X-axis of the response plot. Allow the user to select multiple+ |
|
| 12 | -+ | ||
| 968 | +! |
- #' columns from the `data` allowed in teal.+ group_vals <- input$group_by_vals # nolint (local variable is assigned and used) |
|
| 13 | -+ | ||
| 969 | +! |
- #' `data_extract_spec` must not allow multiple selection in this case.+ variables_select <- input$variables_select |
|
| 14 | -+ | ||
| 970 | +! |
- #' @param row_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ vars <- unique(variables_select, group_var) |
|
| 15 | -+ | ||
| 971 | +! |
- #' Which data columns to use for faceting rows.+ count_type <- input$count_type # nolint (local variable is assigned and used) |
|
| 16 | +972 |
- #' @param col_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
|
| 17 | -+ | ||
| 973 | +! |
- #' Which data to use for faceting columns.+ if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {
|
|
| 18 | -+ | ||
| 974 | +! |
- #' @param coord_flip optional, (`logical`) Whether to flip coordinates between `x` and `response`.+ variables <- selected_vars() # nolint (local variable is assigned and used) |
|
| 19 | +975 |
- #' @param count_labels optional, (`logical`) Whether to show count labels.+ } else {
|
|
| 20 | -+ | ||
| 976 | +! |
- #' Defaults to `TRUE`.+ variables <- colnames(anl) |
|
| 21 | +977 |
- #' @param freq optional, (`logical`) Whether to display frequency (`TRUE`) or density (`FALSE`).+ } |
|
| 22 | +978 |
- #' Defaults to density (`FALSE`).+ |
|
| 23 | -+ | ||
| 979 | +! |
- #'+ summ_fn <- if (input$count_type == "counts") {
|
|
| 24 | -+ | ||
| 980 | +! |
- #' @note For more examples, please see the vignette "Using response plot" via+ function(x) sum(is.na(x)) |
|
| 25 | +981 |
- #' \code{vignette("using-response-plot", package = "teal.modules.general")}.
+ } else {
|
|
| 26 | -+ | ||
| 982 | +! |
- #' @export+ function(x) round(sum(is.na(x)) / length(x), 4) |
|
| 27 | +983 |
- #' @examples+ } |
|
| 28 | +984 |
- #' # Response plot with selected response (BMRKR1) and selected x variable (RACE)+ |
|
| 29 | -+ | ||
| 985 | +! |
- #' library(nestcolor)+ qenv <- common_code_q() |
|
| 30 | +986 |
- #'+ |
|
| 31 | -+ | ||
| 987 | +! |
- #' ADSL <- teal.modules.general::rADSL+ if (!is.null(group_var)) {
|
|
| 32 | -+ | ||
| 988 | +! |
- #'+ qenv <- teal.code::eval_code( |
|
| 33 | -+ | ||
| 989 | +! |
- #' app <- teal::init(+ qenv, |
|
| 34 | -+ | ||
| 990 | +! |
- #' data = teal.data::cdisc_data(+ substitute( |
|
| 35 | -+ | ||
| 991 | +! |
- #' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
+ expr = {
|
|
| 36 | -+ | ||
| 992 | +! |
- #' check = TRUE+ summary_data <- ANL %>% |
|
| 37 | -+ | ||
| 993 | +! |
- #' ),+ dplyr::mutate(group_var_name := forcats::fct_na_value_to_level(as.factor(group_var_name), "NA")) %>% |
|
| 38 | -+ | ||
| 994 | +! |
- #' modules = teal::modules(+ dplyr::group_by_at(group_var) %>% |
|
| 39 | -+ | ||
| 995 | +! |
- #' teal.modules.general::tm_g_response(+ dplyr::filter(group_var_name %in% group_vals) |
|
| 40 | +996 |
- #' label = "Response Plots",+ |
|
| 41 | -+ | ||
| 997 | +! |
- #' response = teal.transform::data_extract_spec(+ count_data <- dplyr::summarise(summary_data, n = dplyr::n()) |
|
| 42 | +998 |
- #' dataname = "ADSL",+ |
|
| 43 | -+ | ||
| 999 | +! |
- #' select = teal.transform::select_spec(+ summary_data <- dplyr::summarise_all(summary_data, summ_fn) %>% |
|
| 44 | -+ | ||
| 1000 | +! |
- #' label = "Select variable:",+ dplyr::mutate(group_var_name := paste0(group_var, ":", group_var_name, "(N=", count_data$n, ")")) %>% |
|
| 45 | -+ | ||
| 1001 | +! |
- #' choices = teal.transform::variable_choices(ADSL, c("BMRKR2", "COUNTRY")),
+ tidyr::pivot_longer(!tidyselect::all_of(group_var), names_to = "Variable", values_to = "out") %>% |
|
| 46 | -+ | ||
| 1002 | +! |
- #' selected = "BMRKR2",+ tidyr::pivot_wider(names_from = group_var, values_from = "out") %>% |
|
| 47 | -+ | ||
| 1003 | +! |
- #' multiple = FALSE,+ dplyr::mutate(`Variable label` = create_cols_labels(Variable, just_label = TRUE), .after = Variable) |
|
| 48 | +1004 |
- #' fixed = FALSE+ }, |
|
| 49 | -+ | ||
| 1005 | +! |
- #' )+ env = list( |
|
| 50 | -+ | ||
| 1006 | +! |
- #' ),+ group_var = group_var, group_var_name = as.name(group_var), group_vals = group_vals, summ_fn = summ_fn |
|
| 51 | +1007 |
- #' x = teal.transform::data_extract_spec(+ ) |
|
| 52 | +1008 |
- #' dataname = "ADSL",+ ) |
|
| 53 | +1009 |
- #' select = teal.transform::select_spec(+ ) |
|
| 54 | +1010 |
- #' label = "Select variable:",+ } else {
|
|
| 55 | -+ | ||
| 1011 | +! |
- #' choices = teal.transform::variable_choices(ADSL, c("SEX", "RACE")),
+ qenv <- teal.code::eval_code( |
|
| 56 | -+ | ||
| 1012 | +! |
- #' selected = "RACE",+ qenv, |
|
| 57 | -+ | ||
| 1013 | +! |
- #' multiple = FALSE,+ substitute( |
|
| 58 | -+ | ||
| 1014 | +! |
- #' fixed = FALSE+ expr = summary_data <- ANL %>% |
|
| 59 | -+ | ||
| 1015 | +! |
- #' )+ dplyr::summarise_all(summ_fn) %>% |
|
| 60 | -+ | ||
| 1016 | +! |
- #' ),+ tidyr::pivot_longer(tidyselect::everything(), |
|
| 61 | -+ | ||
| 1017 | +! |
- #' ggplot2_args = teal.widgets::ggplot2_args(+ names_to = "Variable", |
|
| 62 | -+ | ||
| 1018 | +! |
- #' labs = list(subtitle = "Plot generated by Response Module")+ values_to = paste0("Missing (N=", nrow(ANL), ")")
|
|
| 63 | +1019 |
- #' )+ ) %>% |
|
| 64 | -+ | ||
| 1020 | +! |
- #' )+ dplyr::mutate(`Variable label` = create_cols_labels(Variable), .after = Variable), |
|
| 65 | -+ | ||
| 1021 | +! |
- #' )+ env = list(summ_fn = summ_fn) |
|
| 66 | +1022 |
- #' )+ ) |
|
| 67 | +1023 |
- #' if (interactive()) {
+ ) |
|
| 68 | +1024 |
- #' shinyApp(app$ui, app$server)+ } |
|
| 69 | +1025 |
- #' }+ |
|
| 70 | -+ | ||
| 1026 | +! |
- tm_g_response <- function(label = "Response Plot",+ teal.code::eval_code(qenv, quote(summary_data)) |
|
| 71 | +1027 |
- response,+ }) |
|
| 72 | +1028 |
- x,+ |
|
| 73 | -+ | ||
| 1029 | +! |
- row_facet = NULL,+ summary_table_r <- reactive(summary_table_q()[["summary_data"]]) |
|
| 74 | +1030 |
- col_facet = NULL,+ |
|
| 75 | -+ | ||
| 1031 | +! |
- coord_flip = FALSE,+ by_subject_plot_q <- reactive({
|
|
| 76 | +1032 |
- count_labels = TRUE,+ # needed to trigger show r code update on tab change |
|
| 77 | -+ | ||
| 1033 | +! |
- rotate_xaxis_labels = FALSE,+ req(input$summary_type == "Grouped by Subject", common_code_q()) |
|
| 78 | +1034 |
- freq = FALSE,+ |
|
| 79 | -+ | ||
| 1035 | +! |
- plot_height = c(600, 400, 5000),+ teal::validate_has_data(data_r(), 1) |
|
| 80 | +1036 |
- plot_width = NULL,+ |
|
| 81 | -+ | ||
| 1037 | +! |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
|
| 82 | -+ | ||
| 1038 | +! |
- ggplot2_args = teal.widgets::ggplot2_args(),+ labs = list(x = "", y = ""),+ |
+ |
| 1039 | +! | +
+ theme = list(legend.position = "bottom", axis.text.x = quote(element_blank())) |
|
| 83 | +1040 |
- pre_output = NULL,+ ) |
|
| 84 | +1041 |
- post_output = NULL) {
+
|
|
| 85 | +1042 | ! |
- logger::log_info("Initializing tm_g_response")
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 86 | +1043 | ! |
- if (inherits(response, "data_extract_spec")) response <- list(response)+ user_plot = ggplot2_args[["By Subject"]], |
| 87 | +1044 | ! |
- if (inherits(x, "data_extract_spec")) x <- list(x)+ user_default = ggplot2_args$default, |
| 88 | +1045 | ! |
- if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)+ module_plot = dev_ggplot2_args |
| 89 | -! | +||
| 1046 | +
- if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)+ ) |
||
| 90 | -! | +||
| 1047 | +
- checkmate::assert_string(label)+ |
||
| 91 | +1048 | ! |
- ggtheme <- match.arg(ggtheme)+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 92 | +1049 | ! |
- checkmate::assert_list(response, types = "data_extract_spec")+ all_ggplot2_args, |
| 93 | +1050 | ! |
- if (!all(vapply(response, function(x) !("" %in% x$select$choices), logical(1)))) {
+ ggtheme = input$ggtheme |
| 94 | -! | +||
| 1051 | +
- stop("'response' should not allow empty values")
+ ) |
||
| 95 | +1052 |
- }+ |
|
| 96 | +1053 | ! |
- if (!all(vapply(response, function(x) !x$select$multiple, logical(1)))) {
+ teal.code::eval_code( |
| 97 | +1054 | ! |
- stop("'response' should not allow multiple selection")
- |
-
| 98 | -- |
- }+ common_code_q(), |
|
| 99 | +1055 | ! |
- checkmate::assert_list(x, types = "data_extract_spec")+ substitute( |
| 100 | +1056 | ! |
- if (!all(vapply(x, function(x) !("" %in% x$select$choices), logical(1)))) {
+ expr = parent_keys <- keys, |
| 101 | +1057 | ! |
- stop("'x' should not allow empty values")
+ env = list(keys = data_parent_keys()) |
| 102 | +1058 |
- }+ ) |
|
| 103 | -! | +||
| 1059 | +
- if (!all(vapply(x, function(x) !x$select$multiple, logical(1)))) {
+ ) %>% |
||
| 104 | +1060 | ! |
- stop("'x' should not allow multiple selection")
+ teal.code::eval_code( |
| 105 | -+ | ||
| 1061 | +! |
- }+ substitute( |
|
| 106 | +1062 | ! |
- checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)+ expr = analysis_vars <- setdiff(colnames(ANL), data_keys), |
| 107 | +1063 | ! |
- checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)+ env = list(data_keys = data_keys()) |
| 108 | -! | +||
| 1064 | +
- checkmate::assert_flag(coord_flip)+ ) |
||
| 109 | -! | +||
| 1065 | +
- checkmate::assert_flag(count_labels)+ ) %>% |
||
| 110 | +1066 | ! |
- checkmate::assert_flag(rotate_xaxis_labels)+ teal.code::eval_code( |
| 111 | +1067 | ! |
- checkmate::assert_flag(freq)+ quote({
|
| 112 | +1068 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ summary_plot_patients <- ANL[, c(parent_keys, analysis_vars)] %>% |
| 113 | +1069 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ dplyr::group_by_at(parent_keys) %>% |
| 114 | +1070 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ dplyr::mutate(id = dplyr::cur_group_id()) %>% |
| 115 | +1071 | ! |
- checkmate::assert_numeric(+ dplyr::ungroup() %>% |
| 116 | +1072 | ! |
- plot_width[1],+ dplyr::group_by_at(c(parent_keys, "id")) %>% |
| 117 | +1073 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ dplyr::summarise_all(anyNA) %>% |
| 118 | -+ | ||
| 1074 | +! |
- )+ dplyr::ungroup() |
|
| 119 | +1075 | ||
| 120 | -! | +||
| 1076 | +
- checkmate::assert_class(ggplot2_args, "ggplot2_args")+ # order subjects by decreasing number of missing and then by |
||
| 121 | +1077 |
-
+ # missingness pattern (defined using sha1) |
|
| 122 | +1078 | ! |
- args <- as.list(environment())+ order_subjects <- summary_plot_patients %>% |
| 123 | -+ | ||
| 1079 | +! |
-
+ dplyr::select(-"id", -tidyselect::all_of(parent_keys)) %>% |
|
| 124 | +1080 | ! |
- data_extract_list <- list(+ dplyr::transmute( |
| 125 | +1081 | ! |
- response = response,+ id = dplyr::row_number(), |
| 126 | +1082 | ! |
- x = x,+ number_NA = apply(., 1, sum), |
| 127 | +1083 | ! |
- row_facet = row_facet,+ sha = apply(., 1, rlang::hash)+ |
+
| 1084 | ++ |
+ ) %>% |
|
| 128 | +1085 | ! |
- col_facet = col_facet+ dplyr::arrange(dplyr::desc(number_NA), sha) %>%+ |
+
| 1086 | +! | +
+ getElement(name = "id") |
|
| 129 | +1087 |
- )+ |
|
| 130 | +1088 |
-
+ # order columns by decreasing percent of missing values |
|
| 131 | +1089 | ! |
- module(+ ordered_columns <- summary_plot_patients %>% |
| 132 | +1090 | ! |
- label = label,+ dplyr::select(-"id", -tidyselect::all_of(parent_keys)) %>% |
| 133 | +1091 | ! |
- server = srv_g_response,+ dplyr::summarise( |
| 134 | +1092 | ! |
- ui = ui_g_response,+ column = create_cols_labels(colnames(.)), |
| 135 | +1093 | ! |
- ui_args = args,+ na_count = apply(., MARGIN = 2, FUN = sum), |
| 136 | +1094 | ! |
- server_args = c(+ na_percent = na_count / nrow(.) * 100 |
| 137 | -! | +||
| 1095 | +
- data_extract_list,+ ) %>% |
||
| 138 | +1096 | ! |
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)+ dplyr::arrange(na_percent, dplyr::desc(column)) |
| 139 | +1097 |
- ),+ |
|
| 140 | +1098 | ! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ summary_plot_patients <- summary_plot_patients %>% |
| 141 | -+ | ||
| 1099 | +! |
- )+ tidyr::gather("col", "isna", -"id", -tidyselect::all_of(parent_keys)) %>%
|
|
| 142 | -+ | ||
| 1100 | +! |
- }+ dplyr::mutate(col = create_cols_labels(col)) |
|
| 143 | +1101 |
-
+ }) |
|
| 144 | +1102 |
- ui_g_response <- function(id, ...) {
+ ) %>% |
|
| 145 | +1103 | ! |
- ns <- NS(id)+ teal.code::eval_code( |
| 146 | +1104 | ! |
- args <- list(...)+ substitute( |
| 147 | +1105 | ! |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$response, args$x, args$row_facet, args$col_facet)+ expr = {
|
| 148 | -+ | ||
| 1106 | +! |
-
+ g <- ggplot(summary_plot_patients, aes( |
|
| 149 | +1107 | ! |
- teal.widgets::standard_layout(+ x = factor(id, levels = order_subjects), |
| 150 | +1108 | ! |
- output = teal.widgets::white_small_well(+ y = factor(col, levels = ordered_columns[["column"]]), |
| 151 | +1109 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("myplot"))
+ fill = isna |
| 152 | +1110 |
- ),+ )) + |
|
| 153 | +1111 | ! |
- encoding = div(+ geom_raster() + |
| 154 | -+ | ||
| 1112 | +! |
- ### Reporter+ annotate( |
|
| 155 | +1113 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ "text", |
| 156 | -+ | ||
| 1114 | +! |
- ###+ x = length(order_subjects), |
|
| 157 | +1115 | ! |
- tags$label("Encodings", class = "text-primary"),
+ y = seq_len(nrow(ordered_columns)), |
| 158 | +1116 | ! |
- teal.transform::datanames_input(args[c("response", "x", "row_facet", "col_facet")]),
+ hjust = 1, |
| 159 | +1117 | ! |
- teal.transform::data_extract_ui(+ label = sprintf("%d [%.02f%%]", ordered_columns[["na_count"]], ordered_columns[["na_percent"]])
+ |
+
| 1118 | ++ |
+ ) + |
|
| 160 | +1119 | ! |
- id = ns("response"),
+ scale_fill_manual( |
| 161 | +1120 | ! |
- label = "Response variable",+ name = "", |
| 162 | +1121 | ! |
- data_extract_spec = args$response,+ values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
|
| 163 | +1122 | ! |
- is_single_dataset = is_single_dataset_value+ labels = c("Present", "Missing (at least one)")
|
| 164 | +1123 |
- ),- |
- |
| 165 | -! | -
- teal.transform::data_extract_ui(+ ) + |
|
| 166 | +1124 | ! |
- id = ns("x"),
+ labs + |
| 167 | +1125 | ! |
- label = "X variable",+ ggthemes + |
| 168 | +1126 | ! |
- data_extract_spec = args$x,+ themes |
| 169 | +1127 | ! |
- is_single_dataset = is_single_dataset_value+ print(g) |
| 170 | +1128 |
- ),+ }, |
|
| 171 | +1129 | ! |
- if (!is.null(args$row_facet)) {
+ env = list( |
| 172 | +1130 | ! |
- teal.transform::data_extract_ui(+ labs = parsed_ggplot2_args$labs, |
| 173 | +1131 | ! |
- id = ns("row_facet"),
+ themes = parsed_ggplot2_args$theme, |
| 174 | +1132 | ! |
- label = "Row facetting",+ ggthemes = parsed_ggplot2_args$ggtheme |
| 175 | -! | +||
| 1133 | +
- data_extract_spec = args$row_facet,+ ) |
||
| 176 | -! | +||
| 1134 | +
- is_single_dataset = is_single_dataset_value+ ) |
||
| 177 | +1135 |
) |
|
| 178 | +1136 |
- },+ }) |
|
| 179 | -! | +||
| 1137 | +
- if (!is.null(args$col_facet)) {
+
|
||
| 180 | +1138 | ! |
- teal.transform::data_extract_ui(+ by_subject_plot_r <- reactive(by_subject_plot_q()[["g"]]) |
| 181 | -! | +||
| 1139 | +
- id = ns("col_facet"),
+
|
||
| 182 | +1140 | ! |
- label = "Column facetting",+ output$levels_table <- DT::renderDataTable( |
| 183 | +1141 | ! |
- data_extract_spec = args$col_facet,+ expr = {
|
| 184 | +1142 | ! |
- is_single_dataset = is_single_dataset_value+ if (length(input$variables_select) == 0) {
|
| 185 | +1143 |
- )+ # so that zeroRecords message gets printed |
|
| 186 | +1144 |
- },+ # using tibble as it supports weird column names, such as " " |
|
| 187 | +1145 | ! |
- shinyWidgets::radioGroupButtons(+ tibble::tibble(` ` = logical(0)) |
| 188 | -! | +||
| 1146 | +
- inputId = ns("freq"),
+ } else {
|
||
| 189 | +1147 | ! |
- label = NULL,+ summary_table_r() |
| 190 | -! | +||
| 1148 | +
- choices = c("frequency", "density"),
+ } |
||
| 191 | -! | +||
| 1149 | +
- selected = ifelse(args$freq, "frequency", "density"),+ }, |
||
| 192 | +1150 | ! |
- justified = TRUE+ options = list(language = list(zeroRecords = "No variable selected"), pageLength = input$levels_table_rows) |
| 193 | +1151 |
- ),+ ) |
|
| 194 | -! | +||
| 1152 | +
- teal.widgets::panel_group(+ |
||
| 195 | +1153 | ! |
- teal.widgets::panel_item(+ pws1 <- teal.widgets::plot_with_settings_srv( |
| 196 | +1154 | ! |
- title = "Plot settings",+ id = "summary_plot", |
| 197 | +1155 | ! |
- checkboxInput(ns("count_labels"), "Add count labels", value = args$count_labels),
+ plot_r = summary_plot_r, |
| 198 | +1156 | ! |
- checkboxInput(ns("coord_flip"), "Swap axes", value = args$coord_flip),
+ height = plot_height, |
| 199 | +1157 | ! |
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
+ width = plot_width |
| 200 | -! | +||
| 1158 | +
- selectInput(+ ) |
||
| 201 | -! | +||
| 1159 | +
- inputId = ns("ggtheme"),
+
|
||
| 202 | +1160 | ! |
- label = "Theme (by ggplot):",+ pws2 <- teal.widgets::plot_with_settings_srv( |
| 203 | +1161 | ! |
- choices = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
+ id = "combination_plot", |
| 204 | +1162 | ! |
- selected = args$ggtheme,+ plot_r = combination_plot_r, |
| 205 | +1163 | ! |
- multiple = FALSE- |
-
| 206 | -- |
- )+ height = plot_height, |
|
| 207 | -+ | ||
| 1164 | +! |
- )+ width = plot_width |
|
| 208 | +1165 |
- )+ ) |
|
| 209 | +1166 |
- ),+ |
|
| 210 | +1167 | ! |
- forms = tagList(+ pws3 <- teal.widgets::plot_with_settings_srv( |
| 211 | +1168 | ! |
- teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"),
+ id = "by_subject_plot", |
| 212 | +1169 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
- |
-
| 213 | -- |
- ),+ plot_r = by_subject_plot_r, |
|
| 214 | +1170 | ! |
- pre_output = args$pre_output,+ height = plot_height, |
| 215 | +1171 | ! |
- post_output = args$post_output+ width = plot_width |
| 216 | +1172 |
- )+ ) |
|
| 217 | +1173 |
- }+ |
|
| 218 | -+ | ||
| 1174 | +! |
-
+ final_q <- reactive({
|
|
| 219 | -+ | ||
| 1175 | +! |
- srv_g_response <- function(id,+ req(input$summary_type) |
|
| 220 | -+ | ||
| 1176 | +! |
- data,+ sum_type <- input$summary_type |
|
| 221 | -+ | ||
| 1177 | +! |
- reporter,+ if (sum_type == "Summary") {
|
|
| 222 | -+ | ||
| 1178 | +! |
- filter_panel_api,+ summary_plot_q() |
|
| 223 | -+ | ||
| 1179 | +! |
- response,+ } else if (sum_type == "Combinations") {
|
|
| 224 | -+ | ||
| 1180 | +! |
- x,+ combination_plot_q() |
|
| 225 | -+ | ||
| 1181 | +! |
- row_facet,+ } else if (sum_type == "By Variable Levels") {
|
|
| 226 | -+ | ||
| 1182 | +! |
- col_facet,+ summary_table_q()+ |
+ |
| 1183 | +! | +
+ } else if (sum_type == "Grouped by Subject") {
+ |
+ |
| 1184 | +! | +
+ by_subject_plot_q() |
|
| 227 | +1185 |
- plot_height,+ } |
|
| 228 | +1186 |
- plot_width,+ }) |
|
| 229 | +1187 |
- ggplot2_args) {
+
|
|
| 230 | +1188 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ teal.widgets::verbatim_popup_srv( |
| 231 | +1189 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ id = "warning", |
| 232 | +1190 | ! |
- checkmate::assert_class(data, "tdata")+ verbatim_content = reactive(teal.code::get_warnings(final_q())), |
| 233 | +1191 | ! |
- moduleServer(id, function(input, output, session) {
+ title = "Warning", |
| 234 | +1192 | ! |
- data_extract <- list(response = response, x = x, row_facet = row_facet, col_facet = col_facet)+ disabled = reactive(is.null(teal.code::get_warnings(final_q()))) |
| 235 | +1193 | - - | -|
| 236 | -! | -
- rule_diff <- function(other) {
+ ) |
|
| 237 | -! | +||
| 1194 | +
- function(value) {
+
|
||
| 238 | +1195 | ! |
- othervalue <- selector_list()[[other]]()[["select"]]+ teal.widgets::verbatim_popup_srv( |
| 239 | +1196 | ! |
- if (!is.null(othervalue)) {
+ id = "rcode", |
| 240 | +1197 | ! |
- if (identical(value, othervalue)) {
+ verbatim_content = reactive(teal.code::get_code(final_q())), |
| 241 | +1198 | ! |
- "Row and column facetting variables must be different."- |
-
| 242 | -- |
- }- |
- |
| 243 | -- |
- }+ title = "Show R Code for Missing Data" |
|
| 244 | +1199 |
- }+ ) |
|
| 245 | +1200 |
- }+ |
|
| 246 | +1201 |
-
+ ### REPORTER |
|
| 247 | +1202 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ if (with_reporter) {
|
| 248 | +1203 | ! |
- data_extract = data_extract,+ card_fun <- function(comment, label) {
|
| 249 | +1204 | ! |
- datasets = data,+ card <- teal::TealReportCard$new() |
| 250 | +1205 | ! |
- select_validation_rule = list(+ sum_type <- input$summary_type |
| 251 | +1206 | ! |
- response = shinyvalidate::sv_required("Please define a column for the response variable"),
+ title <- if (sum_type == "By Variable Levels") paste0(sum_type, " Table") else paste0(sum_type, " Plot") |
| 252 | +1207 | ! |
- x = shinyvalidate::sv_required("Please define a column for X variable"),
+ title_dataname <- paste(title, dataname, sep = " - ") |
| 253 | +1208 | ! |
- row_facet = shinyvalidate::compose_rules(+ label <- if (label == "") {
|
| 254 | +1209 | ! |
- shinyvalidate::sv_optional(),+ paste("Missing Data", sum_type, dataname, sep = " - ")
|
| 255 | -! | +||
| 1210 | +
- ~ if (length(.) > 1) "There must be 1 or no row facetting variable.",+ } else {
|
||
| 256 | +1211 | ! |
- rule_diff("col_facet")
+ label |
| 257 | +1212 |
- ),+ } |
|
| 258 | +1213 | ! |
- col_facet = shinyvalidate::compose_rules(+ card$set_name(label) |
| 259 | +1214 | ! |
- shinyvalidate::sv_optional(),+ card$append_text(title_dataname, "header2") |
| 260 | +1215 | ! |
- ~ if (length(.) > 1) "There must be 1 or no column facetting variable.",+ if (with_filter) card$append_fs(filter_panel_api$get_filter_state()) |
| 261 | +1216 | ! |
- rule_diff("row_facet")
+ if (sum_type == "Summary") {
|
| 262 | -+ | ||
| 1217 | +! |
- )+ card$append_text("Plot", "header3")
|
|
| 263 | -+ | ||
| 1218 | +! |
- )+ card$append_plot(summary_plot_r(), dim = pws1$dim()) |
|
| 264 | -+ | ||
| 1219 | +! |
- )+ } else if (sum_type == "Combinations") {
|
|
| 265 | -+ | ||
| 1220 | +! |
-
+ card$append_text("Plot", "header3")
|
|
| 266 | +1221 | ! |
- iv_r <- reactive({
+ card$append_plot(combination_plot_r(), dim = pws2$dim()) |
| 267 | +1222 | ! |
- iv <- shinyvalidate::InputValidator$new()+ } else if (sum_type == "By Variable Levels") {
|
| 268 | +1223 | ! |
- iv$add_rule("ggtheme", shinyvalidate::sv_required("Please select a theme"))
+ card$append_text("Table", "header3")
|
| 269 | +1224 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list)+ card$append_table(summary_table_r[["summary_data"]]) |
| 270 | -+ | ||
| 1225 | +! |
- })+ } else if (sum_type == "Grouped by Subject") {
|
|
| 271 | -+ | ||
| 1226 | +! |
-
+ card$append_text("Plot", "header3")
|
|
| 272 | +1227 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ card$append_plot(by_subject_plot_r(), dim = pws3$dim()) |
| 273 | -! | +||
| 1228 | +
- selector_list = selector_list,+ } |
||
| 274 | +1229 | ! |
- datasets = data,+ if (!comment == "") {
|
| 275 | +1230 | ! |
- join_keys = get_join_keys(data)+ card$append_text("Comment", "header3")
|
| 276 | -+ | ||
| 1231 | +! |
- )+ card$append_text(comment) |
|
| 277 | +1232 |
-
+ } |
|
| 278 | +1233 | ! |
- anl_merged_q <- reactive({
+ card$append_src(paste(teal.code::get_code(final_q()), collapse = "\n")) |
| 279 | +1234 | ! |
- req(anl_merged_input())+ card |
| 280 | -! | +||
| 1235 | +
- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>%+ } |
||
| 281 | +1236 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 282 | +1237 |
- })+ } |
|
| 283 | +1238 |
-
+ ### |
|
| 284 | -! | +||
| 1239 | +
- merged <- list(+ }) |
||
| 285 | -! | +||
| 1240 | +
- anl_input_r = anl_merged_input,+ } |
||
| 286 | -! | +
| 1 | +
- anl_q_r = anl_merged_q+ #' Univariate and bivariate visualizations |
||
| 287 | +2 |
- )+ #' @md |
|
| 288 | +3 |
-
+ #' |
|
| 289 | -! | +||
| 4 | +
- output_q <- reactive({
+ #' @inheritParams teal::module |
||
| 290 | -! | +||
| 5 | +
- teal::validate_inputs(iv_r())+ #' @inheritParams shared_params |
||
| 291 | +6 |
-
+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 292 | -! | +||
| 7 | +
- qenv <- merged$anl_q_r()+ #' Variable names selected to plot along the x-axis by default. Variable can be numeric, factor or character. |
||
| 293 | -! | +||
| 8 | +
- ANL <- qenv[["ANL"]] # nolint+ #' No empty selections are allowed! |
||
| 294 | -! | +||
| 9 | +
- resp_var <- as.vector(merged$anl_input_r()$columns_source$response)+ #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 295 | -! | +||
| 10 | +
- x <- as.vector(merged$anl_input_r()$columns_source$x)+ #' Variable names selected to plot along the y-axis by default. Variable can be numeric, factor or character. |
||
| 296 | +11 |
-
+ #' @param use_density optional, (`logical`) value for whether density (`TRUE`) is plotted or |
|
| 297 | -! | +||
| 12 | +
- validate(need(is.factor(ANL[[resp_var]]), "Please select a factor variable as the response."))+ #' frequency (`FALSE`). Defaults to frequency (`FALSE`). |
||
| 298 | -! | +||
| 13 | +
- validate(need(is.factor(ANL[[x]]), "Please select a factor variable as the X-Variable."))+ #' @param row_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 299 | -! | +||
| 14 | +
- teal::validate_has_data(ANL, 10)+ #' Variables for row facetting. |
||
| 300 | -! | +||
| 15 | +
- teal::validate_has_data(ANL[, c(resp_var, x)], 10, complete = TRUE, allow_inf = FALSE)+ #' @param col_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 301 | +16 |
-
+ #' Variables for col facetting. |
|
| 302 | -! | +||
| 17 | +
- row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
+ #' @param facet optional, (`logical`) to specify whether the facet encodings `ui` elements are toggled |
||
| 303 | -! | +||
| 18 | +
- character(0)+ #' on and shown to the user by default. Defaults to `TRUE` if either `row_facet` or `column_facet` |
||
| 304 | +19 |
- } else {
+ #' are supplied. |
|
| 305 | -! | +||
| 20 | +
- as.vector(merged$anl_input_r()$columns_source$row_facet)+ #' @param color_settings (`logical`) Whether coloring, filling and size should be applied |
||
| 306 | +21 |
- }+ #' and `UI` tool offered to the user. |
|
| 307 | -! | +||
| 22 | +
- col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
+ #' @param color optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 308 | -! | +||
| 23 | +
- character(0)+ #' Variables selected for the outline color inside the coloring settings. |
||
| 309 | +24 |
- } else {
+ #' It will be applied when `color_settings` is set to `TRUE`. |
|
| 310 | -! | +||
| 25 | +
- as.vector(merged$anl_input_r()$columns_source$col_facet)+ #' @param fill optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 311 | +26 |
- }+ #' Variables selected for the fill color inside the coloring settings. |
|
| 312 | +27 |
-
+ #' It will be applied when `color_settings` is set to `TRUE`. |
|
| 313 | -! | +||
| 28 | +
- freq <- input$freq == "frequency"+ #' @param size optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 314 | -! | +||
| 29 | +
- swap_axes <- input$coord_flip+ #' Variables selected for the size of `geom_point` plots inside the coloring settings. |
||
| 315 | -! | +||
| 30 | +
- counts <- input$count_labels+ #' It will be applied when `color_settings` is set to `TRUE`. |
||
| 316 | -! | +||
| 31 | +
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ #' @param free_x_scales optional, (`logical`) Whether X scaling shall be changeable. |
||
| 317 | -! | +||
| 32 | +
- ggtheme <- input$ggtheme+ #' Does not allow scaling to be changed by default (`FALSE`). |
||
| 318 | +33 |
-
+ #' @param free_y_scales optional, (`logical`) Whether Y scaling shall be changeable. |
|
| 319 | -! | +||
| 34 | +
- arg_position <- if (freq) "stack" else "fill" # nolint+ #' Does not allow scaling to be changed by default (`FALSE`). |
||
| 320 | +35 |
-
+ #' @param swap_axes optional, (`logical`) Whether to swap X and Y axes. Defaults to `FALSE`. |
|
| 321 | -! | +||
| 36 | +
- rowf <- if (length(row_facet_name) == 0) NULL else as.name(row_facet_name) # nolint+ #' |
||
| 322 | -! | +||
| 37 | +
- colf <- if (length(col_facet_name) == 0) NULL else as.name(col_facet_name) # nolint+ #' @details |
||
| 323 | -! | +||
| 38 | +
- resp_cl <- as.name(resp_var) # nolint+ #' This is a general module to visualize 1 & 2 dimensional data. |
||
| 324 | -! | +||
| 39 | +
- x_cl <- as.name(x) # nolint+ #' |
||
| 325 | +40 |
-
+ #' @note |
|
| 326 | -! | +||
| 41 | +
- if (swap_axes) {
+ #' For more examples, please see the vignette "Using bivariate plot" via |
||
| 327 | -! | +||
| 42 | +
- qenv <- teal.code::eval_code(+ #' `vignette("using-bivariate-plot", package = "teal.modules.general")`.
|
||
| 328 | -! | +||
| 43 | +
- qenv,+ #' |
||
| 329 | -! | +||
| 44 | +
- substitute(+ #' @export |
||
| 330 | -! | +||
| 45 | +
- expr = ANL[[x]] <- with(ANL, forcats::fct_rev(x_cl)), # nolint+ #' |
||
| 331 | -! | +||
| 46 | +
- env = list(x = x, x_cl = x_cl)+ #' @examples |
||
| 332 | +47 |
- )+ #' # Bivariate plot of selected variable (AGE) against selected (SEX) |
|
| 333 | +48 |
- )+ #' ADSL <- teal.modules.general::rADSL |
|
| 334 | +49 |
- }+ #' |
|
| 335 | +50 |
-
+ #' app <- teal::init( |
|
| 336 | -! | +||
| 51 | +
- qenv <- teal.code::eval_code(+ #' data = teal.data::cdisc_data( |
||
| 337 | -! | +||
| 52 | +
- qenv,+ #' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
|
||
| 338 | -! | +||
| 53 | +
- substitute(+ #' check = TRUE |
||
| 339 | -! | +||
| 54 | +
- expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]), # nolint+ #' ), |
||
| 340 | -! | +||
| 55 | +
- env = list(resp_var = resp_var)+ #' modules = teal::modules( |
||
| 341 | +56 |
- )+ #' teal.modules.general::tm_g_bivariate( |
|
| 342 | +57 |
- ) %>%+ #' x = teal.transform::data_extract_spec( |
|
| 343 | +58 |
- # nolint start+ #' dataname = "ADSL", |
|
| 344 | +59 |
- # rowf and colf will be a NULL if not set by a user+ #' select = teal.transform::select_spec( |
|
| 345 | -! | +||
| 60 | +
- teal.code::eval_code(+ #' label = "Select variable:", |
||
| 346 | -! | +||
| 61 | +
- substitute(+ #' choices = teal.transform::variable_choices(ADSL), |
||
| 347 | -! | +||
| 62 | +
- expr = ANL2 <- ANL %>%+ #' selected = "AGE", |
||
| 348 | -! | +||
| 63 | +
- dplyr::group_by_at(dplyr::vars(x_cl, resp_cl, rowf, colf)) %>%+ #' fixed = FALSE |
||
| 349 | -! | +||
| 64 | +
- dplyr::summarise(ns = dplyr::n()) %>%+ #' ) |
||
| 350 | -! | +||
| 65 | +
- dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%+ #' ), |
||
| 351 | -! | +||
| 66 | +
- dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)),+ #' y = teal.transform::data_extract_spec( |
||
| 352 | -! | +||
| 67 | +
- env = list(x_cl = x_cl, resp_cl = resp_cl, rowf = rowf, colf = colf)+ #' dataname = "ADSL", |
||
| 353 | +68 |
- )+ #' select = teal.transform::select_spec( |
|
| 354 | +69 |
- ) %>%+ #' label = "Select variable:", |
|
| 355 | -! | +||
| 70 | +
- teal.code::eval_code(+ #' choices = teal.transform::variable_choices(ADSL), |
||
| 356 | -! | +||
| 71 | +
- substitute(+ #' selected = "SEX", |
||
| 357 | -! | +||
| 72 | +
- expr = ANL3 <- ANL %>%+ #' multiple = FALSE, |
||
| 358 | -! | +||
| 73 | +
- dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%+ #' fixed = FALSE |
||
| 359 | -! | +||
| 74 | +
- dplyr::summarise(ns = dplyr::n()),+ #' ) |
||
| 360 | -! | +||
| 75 | +
- env = list(x_cl = x_cl, rowf = rowf, colf = colf)+ #' ), |
||
| 361 | +76 |
- )+ #' row_facet = teal.transform::data_extract_spec( |
|
| 362 | +77 |
- )+ #' dataname = "ADSL", |
|
| 363 | +78 |
- # nolint end+ #' select = teal.transform::select_spec( |
|
| 364 | +79 |
-
+ #' label = "Select variable:", |
|
| 365 | -! | +||
| 80 | +
- plot_call <- substitute(+ #' choices = teal.transform::variable_choices(ADSL), |
||
| 366 | -! | +||
| 81 | +
- expr =+ #' selected = "ARM", |
||
| 367 | -! | +||
| 82 | +
- ggplot(ANL2, aes(x = x_cl, y = ns)) ++ #' fixed = FALSE |
||
| 368 | -! | +||
| 83 | +
- geom_bar(aes(fill = resp_cl), stat = "identity", position = arg_position),+ #' ) |
||
| 369 | -! | +||
| 84 | +
- env = list(+ #' ), |
||
| 370 | -! | +||
| 85 | +
- x_cl = x_cl,+ #' col_facet = teal.transform::data_extract_spec( |
||
| 371 | -! | +||
| 86 | +
- resp_cl = resp_cl,+ #' dataname = "ADSL", |
||
| 372 | -! | +||
| 87 | +
- arg_position = arg_position+ #' select = teal.transform::select_spec( |
||
| 373 | +88 |
- )+ #' label = "Select variable:", |
|
| 374 | +89 |
- )+ #' choices = teal.transform::variable_choices(ADSL), |
|
| 375 | +90 |
-
+ #' selected = "COUNTRY", |
|
| 376 | -! | +||
| 91 | +
- if (!freq) plot_call <- substitute(plot_call + expand_limits(y = c(0, 1.1)), env = list(plot_call = plot_call))+ #' fixed = FALSE |
||
| 377 | +92 |
-
+ #' ) |
|
| 378 | -! | +||
| 93 | +
- if (counts) {
+ #' ), |
||
| 379 | -! | +||
| 94 | +
- plot_call <- substitute(+ #' ggplot2_args = teal.widgets::ggplot2_args( |
||
| 380 | -! | +||
| 95 | +
- expr = plot_call ++ #' labs = list(subtitle = "Plot generated by Bivariate Module") |
||
| 381 | -! | +||
| 96 | +
- geom_text(+ #' ) |
||
| 382 | -! | +||
| 97 | +
- data = ANL2,+ #' ) |
||
| 383 | -! | +||
| 98 | +
- aes(label = ns, x = x_cl, y = ns, group = resp_cl),+ #' ) |
||
| 384 | -! | +||
| 99 | +
- col = "white",+ #' ) |
||
| 385 | -! | +||
| 100 | +
- vjust = "middle",+ #' if (interactive()) {
|
||
| 386 | -! | +||
| 101 | +
- hjust = "middle",+ #' shinyApp(app$ui, app$server) |
||
| 387 | -! | +||
| 102 | +
- position = position_anl2_value+ #' } |
||
| 388 | +103 |
- ) ++ tm_g_bivariate <- function(label = "Bivariate Plots", |
|
| 389 | -! | +||
| 104 | +
- geom_text(+ x, |
||
| 390 | -! | +||
| 105 | +
- data = ANL3, aes(label = ns, x = x_cl, y = anl3_y),+ y, |
||
| 391 | -! | +||
| 106 | +
- hjust = hjust_value,+ row_facet = NULL, |
||
| 392 | -! | +||
| 107 | +
- vjust = vjust_value,+ col_facet = NULL, |
||
| 393 | -! | +||
| 108 | +
- position = position_anl3_value+ facet = !is.null(row_facet) || !is.null(col_facet), |
||
| 394 | +109 |
- ),+ color = NULL, |
|
| 395 | -! | +||
| 110 | +
- env = list(+ fill = NULL, |
||
| 396 | -! | +||
| 111 | +
- plot_call = plot_call,+ size = NULL, |
||
| 397 | -! | +||
| 112 | +
- x_cl = x_cl,+ use_density = FALSE, |
||
| 398 | -! | +||
| 113 | +
- resp_cl = resp_cl,+ color_settings = FALSE, |
||
| 399 | -! | +||
| 114 | +
- hjust_value = if (swap_axes) "left" else "middle",+ free_x_scales = FALSE, |
||
| 400 | -! | +||
| 115 | +
- vjust_value = if (swap_axes) "middle" else -1,+ free_y_scales = FALSE, |
||
| 401 | -! | +||
| 116 | +
- position_anl2_value = if (!freq) quote(position_fill(0.5)) else quote(position_stack(0.5)),+ plot_height = c(600, 200, 2000), |
||
| 402 | -! | +||
| 117 | +
- anl3_y = if (!freq) 1.1 else as.name("ns"),
+ plot_width = NULL, |
||
| 403 | -! | +||
| 118 | +
- position_anl3_value = if (!freq) "fill" else "stack"+ rotate_xaxis_labels = FALSE, |
||
| 404 | +119 |
- )+ swap_axes = FALSE, |
|
| 405 | +120 |
- )+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
|
|
| 406 | +121 |
- }+ ggplot2_args = teal.widgets::ggplot2_args(), |
|
| 407 | +122 |
-
+ pre_output = NULL,+ |
+ |
| 123 | ++ |
+ post_output = NULL) {
|
|
| 408 | +124 | ! |
- if (swap_axes) {
+ logger::log_info("Initializing tm_g_bivariate")
|
| 409 | +125 | ! |
- plot_call <- substitute(plot_call + coord_flip(), env = list(plot_call = plot_call))+ if (inherits(x, "data_extract_spec")) x <- list(x) |
| 410 | -+ | ||
| 126 | +! |
- }+ if (inherits(y, "data_extract_spec")) y <- list(y) |
|
| 411 | -+ | ||
| 127 | +! |
-
+ if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet) |
|
| 412 | +128 | ! |
- facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name)+ if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) |
| 413 | -+ | ||
| 129 | +! |
-
+ if (inherits(color, "data_extract_spec")) color <- list(color) |
|
| 414 | +130 | ! |
- if (!is.null(facet_cl)) {
+ if (inherits(fill, "data_extract_spec")) fill <- list(fill) |
| 415 | +131 | ! |
- plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))+ if (inherits(size, "data_extract_spec")) size <- list(size) |
| 416 | +132 |
- }+ |
|
| 417 | -+ | ||
| 133 | +! |
-
+ checkmate::assert_list(x, types = "data_extract_spec") |
|
| 418 | +134 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ if (!all(vapply(x, function(x) !x$select$multiple, logical(1)))) {
|
| 419 | +135 | ! |
- labs = list(+ stop("'x' should not allow multiple selection")
+ |
+
| 136 | ++ |
+ } |
|
| 420 | +137 | ! |
- x = varname_w_label(x, ANL),+ checkmate::assert_list(y, types = "data_extract_spec") |
| 421 | +138 | ! |
- y = varname_w_label(resp_var, ANL, prefix = "Proportion of "),+ if (!all(vapply(y, function(x) !x$select$multiple, logical(1)))) {
|
| 422 | +139 | ! |
- fill = varname_w_label(resp_var, ANL)+ stop("'y' should not allow multiple selection")
|
| 423 | +140 |
- ),+ } |
|
| 424 | +141 | ! |
- theme = list(legend.position = "bottom")+ checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) |
| 425 | -+ | ||
| 142 | +! |
- )+ if (!all(vapply(row_facet, function(x) !x$select$multiple, logical(1)))) {
+ |
+ |
| 143 | +! | +
+ stop("'row_facet' should not allow multiple selection")
|
|
| 426 | +144 |
-
+ } |
|
| 427 | +145 | ! |
- if (rotate_xaxis_labels) {
+ checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) |
| 428 | +146 | ! |
- dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1)) # nolint+ if (!all(vapply(col_facet, function(x) !x$select$multiple, logical(1)))) {
|
| 429 | -+ | ||
| 147 | +! |
- }+ stop("'col_facet' should not allow multiple selection")
|
|
| 430 | +148 |
-
+ } |
|
| 431 | +149 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ checkmate::assert_list(color, types = "data_extract_spec", null.ok = TRUE) |
| 432 | +150 | ! |
- user_plot = ggplot2_args,+ if (!all(vapply(color, function(x) !x$select$multiple, logical(1)))) {
|
| 433 | +151 | ! |
- module_plot = dev_ggplot2_args+ stop("'color' should not allow multiple selection")
|
| 434 | +152 |
- )+ }+ |
+ |
| 153 | +! | +
+ checkmate::assert_list(fill, types = "data_extract_spec", null.ok = TRUE)+ |
+ |
| 154 | +! | +
+ if (!all(vapply(fill, function(x) !x$select$multiple, logical(1)))) {
+ |
+ |
| 155 | +! | +
+ stop("'fill' should not allow multiple selection")
|
|
| 435 | +156 |
-
+ } |
|
| 436 | +157 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ checkmate::assert_list(size, types = "data_extract_spec", null.ok = TRUE) |
| 437 | +158 | ! |
- all_ggplot2_args,+ if (!all(vapply(size, function(x) !x$select$multiple, logical(1)))) {
|
| 438 | +159 | ! |
- ggtheme = ggtheme+ stop("'size' should not allow multiple selection")
|
| 439 | +160 |
- )+ } |
|
| 440 | +161 | ||
| 441 | +162 | ! |
- plot_call <- substitute(expr = {
+ ggtheme <- match.arg(ggtheme) |
| 442 | +163 | ! |
- p <- plot_call + labs + ggthemes + themes+ checkmate::assert_string(label) |
| 443 | +164 | ! |
- print(p)+ checkmate::assert_flag(use_density) |
| 444 | +165 | ! |
- }, env = list(+ checkmate::assert_flag(color_settings) |
| 445 | +166 | ! |
- plot_call = plot_call,+ checkmate::assert_flag(free_x_scales) |
| 446 | +167 | ! |
- labs = parsed_ggplot2_args$labs,+ checkmate::assert_flag(free_y_scales) |
| 447 | +168 | ! |
- themes = parsed_ggplot2_args$theme,+ checkmate::assert_flag(rotate_xaxis_labels) |
| 448 | +169 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme+ checkmate::assert_flag(swap_axes) |
| 449 | -+ | ||
| 170 | +! |
- ))+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
|
| 450 | -+ | ||
| 171 | +! |
-
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
|
| 451 | +172 | ! |
- teal.code::eval_code(qenv, plot_call)+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 452 | -+ | ||
| 173 | +! |
- })+ checkmate::assert_numeric( |
|
| 453 | -+ | ||
| 174 | +! |
-
+ plot_width[1], |
|
| 454 | +175 | ! |
- plot_r <- reactive(output_q()[["p"]])+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 455 | +176 |
-
+ ) |
|
| 456 | -+ | ||
| 177 | +! |
- # Insert the plot into a plot_with_settings module from teal.widgets+ checkmate::assert_class(ggplot2_args, "ggplot2_args") |
|
| 457 | -! | +||
| 178 | +
- pws <- teal.widgets::plot_with_settings_srv(+ |
||
| 458 | +179 | ! |
- id = "myplot",+ if (color_settings) {
|
| 459 | +180 | ! |
- plot_r = plot_r,+ if (is.null(color)) {
|
| 460 | +181 | ! |
- height = plot_height,+ color <- x |
| 461 | +182 | ! |
- width = plot_width+ color[[1]]$select <- teal.transform::select_spec(choices = color[[1]]$select$choices, selected = NULL) |
| 462 | +183 |
- )+ } |
|
| 463 | -+ | ||
| 184 | +! |
-
+ if (is.null(fill)) {
|
|
| 464 | +185 | ! |
- teal.widgets::verbatim_popup_srv(+ fill <- x |
| 465 | +186 | ! |
- id = "warning",+ fill[[1]]$select <- teal.transform::select_spec(choices = fill[[1]]$select$choices, selected = NULL)+ |
+
| 187 | ++ |
+ } |
|
| 466 | +188 | ! |
- verbatim_content = reactive(teal.code::get_warnings(output_q())),+ if (is.null(size)) {
|
| 467 | +189 | ! |
- title = "Warning",+ size <- x |
| 468 | +190 | ! |
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ size[[1]]$select <- teal.transform::select_spec(choices = size[[1]]$select$choices, selected = NULL) |
| 469 | +191 |
- )+ } |
|
| 470 | +192 | - - | -|
| 471 | -! | -
- teal.widgets::verbatim_popup_srv(- |
- |
| 472 | -! | -
- id = "rcode",+ } else {
|
|
| 473 | +193 | ! |
- verbatim_content = reactive(teal.code::get_code(output_q())),+ if (!is.null(c(color, fill, size))) {
|
| 474 | +194 | ! |
- title = "Show R Code for Response"+ stop("'color_settings' argument needs to be set to TRUE if 'color', 'fill', and/or 'size' is/are supplied.")
|
| 475 | +195 |
- )+ } |
|
| 476 | +196 |
-
+ } |
|
| 477 | +197 |
- ### REPORTER+ |
|
| 478 | +198 | ! |
- if (with_reporter) {
+ args <- as.list(environment()) |
| 479 | -! | +||
| 199 | +
- card_fun <- function(comment) {
+
|
||
| 480 | +200 | ! |
- card <- teal::TealReportCard$new()+ data_extract_list <- list( |
| 481 | +201 | ! |
- card$set_name("Response Plot")
+ x = x, |
| 482 | +202 | ! |
- card$append_text("Response Plot", "header2")
+ y = y, |
| 483 | +203 | ! |
- if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ row_facet = row_facet, |
| 484 | +204 | ! |
- card$append_text("Plot", "header3")
+ col_facet = col_facet, |
| 485 | +205 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ color_settings = color_settings, |
| 486 | +206 | ! |
- if (!comment == "") {
+ color = color, |
| 487 | +207 | ! |
- card$append_text("Comment", "header3")
+ fill = fill, |
| 488 | +208 | ! |
- card$append_text(comment)+ size = size |
| 489 | +209 |
- }+ ) |
|
| 490 | -! | +||
| 210 | +
- card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n"))+ |
||
| 491 | +211 | ! |
- card+ module( |
| 492 | -+ | ||
| 212 | +! |
- }+ label = label, |
|
| 493 | +213 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ server = srv_g_bivariate, |
| 494 | -+ | ||
| 214 | +! |
- }+ ui = ui_g_bivariate, |
|
| 495 | -+ | ||
| 215 | +! |
- ###+ ui_args = args, |
|
| 496 | -+ | ||
| 216 | +! |
- })+ server_args = c( |
|
| 497 | -+ | ||
| 217 | +! |
- }+ data_extract_list, |
| 1 | -+ | ||
| 218 | +! |
- #' Distribution Module+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args) |
|
| 2 | +219 |
- #' @md+ ), |
|
| 3 | -+ | ||
| 220 | +! |
- #'+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
|
| 4 | +221 |
- #' @details+ ) |
|
| 5 | +222 |
- #' Module to analyze and explore univariate variable distribution+ } |
|
| 6 | +223 |
- #'+ |
|
| 7 | +224 |
- #' @inheritParams teal::module+ ui_g_bivariate <- function(id, ...) {
|
|
| 8 | -+ | ||
| 225 | +! |
- #' @inheritParams teal.widgets::standard_layout+ args <- list(...) |
|
| 9 | -+ | ||
| 226 | +! |
- #' @inheritParams shared_params+ is_single_dataset_value <- teal.transform::is_single_dataset( |
|
| 10 | -+ | ||
| 227 | +! |
- #'+ args$x, args$y, args$row_facet, args$col_facet, args$color, args$fill, args$size |
|
| 11 | +228 |
- #' @param dist_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ ) |
|
| 12 | +229 |
- #' Variable to consider for the distribution analysis.+ |
|
| 13 | -+ | ||
| 230 | +! |
- #' @param strata_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ ns <- NS(id) |
|
| 14 | -+ | ||
| 231 | +! |
- #' Categorical variable to split the selected distribution variable on.+ teal.widgets::standard_layout( |
|
| 15 | -+ | ||
| 232 | +! |
- #' @param group_var optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ output = teal.widgets::white_small_well( |
|
| 16 | -+ | ||
| 233 | +! |
- #' Which data columns to use for faceting rows.+ tags$div(teal.widgets::plot_with_settings_ui(id = ns("myplot")))
|
|
| 17 | +234 |
- #' @param freq optional, (`logical`) Whether to display frequency (`TRUE`) or density (`FALSE`).+ ), |
|
| 18 | -+ | ||
| 235 | +! |
- #' Defaults to density (`FALSE`).+ encoding = div( |
|
| 19 | +236 |
- #' @param bins optional, (`integer(1)` or `integer(3)`) If scalar then the histogram bins will have a fixed size.+ ### Reporter |
|
| 20 | -+ | ||
| 237 | +! |
- #' If a slider should be presented to adjust the number of histogram bins dynamically then it can be a+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 21 | +238 |
- #' vector of length three with `c(value, min, max)`.+ ### |
|
| 22 | -+ | ||
| 239 | +! |
- #' Defaults to `c(30L, 1L, 100L)`.+ tags$label("Encodings", class = "text-primary"),
|
|
| 23 | -+ | ||
| 240 | +! |
- #'+ teal.transform::datanames_input(args[c("x", "y", "row_facet", "col_facet", "color", "fill", "size")]),
|
|
| 24 | -+ | ||
| 241 | +! |
- #' @templateVar ggnames "Histogram", "QQplot"+ teal.transform::data_extract_ui( |
|
| 25 | -+ | ||
| 242 | +! |
- #' @template ggplot2_args_multi+ id = ns("x"),
|
|
| 26 | -+ | ||
| 243 | +! |
- #'+ label = "X variable", |
|
| 27 | -+ | ||
| 244 | +! |
- #'+ data_extract_spec = args$x, |
|
| 28 | -+ | ||
| 245 | +! |
- #' @export+ is_single_dataset = is_single_dataset_value |
|
| 29 | +246 |
- #'+ ), |
|
| 30 | -+ | ||
| 247 | +! |
- #' @examples+ teal.transform::data_extract_ui( |
|
| 31 | -+ | ||
| 248 | +! |
- #' # Example with non-clinical data+ id = ns("y"),
|
|
| 32 | -+ | ||
| 249 | +! |
- #' app <- teal::init(+ label = "Y variable", |
|
| 33 | -+ | ||
| 250 | +! |
- #' data = teal_data(dataset("iris", iris)),
+ data_extract_spec = args$y, |
|
| 34 | -+ | ||
| 251 | +! |
- #' modules = list(+ is_single_dataset = is_single_dataset_value |
|
| 35 | +252 |
- #' teal.modules.general::tm_g_distribution(+ ), |
|
| 36 | -+ | ||
| 253 | +! |
- #' dist_var = teal.transform::data_extract_spec(+ conditionalPanel( |
|
| 37 | -+ | ||
| 254 | +! |
- #' dataname = "iris",+ condition = |
|
| 38 | -+ | ||
| 255 | +! |
- #' select = teal.transform::select_spec(variable_choices("iris"), "Petal.Length")
+ "$(\"button[data-id*='-x-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' || |
|
| 39 | -+ | ||
| 256 | +! |
- #' ),+ $(\"button[data-id*='-y-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ", |
|
| 40 | -+ | ||
| 257 | +! |
- #' ggplot2_args = teal.widgets::ggplot2_args(+ shinyWidgets::radioGroupButtons( |
|
| 41 | -+ | ||
| 258 | +! |
- #' labs = list(subtitle = "Plot generated by Distribution Module")+ inputId = ns("use_density"),
|
|
| 42 | -+ | ||
| 259 | +! |
- #' )+ label = NULL, |
|
| 43 | -+ | ||
| 260 | +! |
- #' )+ choices = c("frequency", "density"),
|
|
| 44 | -+ | ||
| 261 | +! |
- #' )+ selected = ifelse(args$use_density, "density", "frequency"), |
|
| 45 | -+ | ||
| 262 | +! |
- #' )+ justified = TRUE |
|
| 46 | +263 |
- #' if (interactive()) {
+ ) |
|
| 47 | +264 |
- #' shinyApp(app$ui, app$server)+ ), |
|
| 48 | -+ | ||
| 265 | +! |
- #' }+ if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
|
|
| 49 | -+ | ||
| 266 | +! |
- #'+ div( |
|
| 50 | -+ | ||
| 267 | +! |
- #' # Example with clinical data+ class = "data-extract-box", |
|
| 51 | -+ | ||
| 268 | +! |
- #' ADSL <- teal.modules.general::rADSL+ tags$label("Facetting"),
|
|
| 52 | -+ | ||
| 269 | +! |
- #'+ shinyWidgets::switchInput(inputId = ns("facetting"), value = args$facet, size = "mini"),
|
|
| 53 | -+ | ||
| 270 | +! |
- #' vars1 <- choices_selected(variable_choices(ADSL, c("ARM", "COUNTRY", "SEX")), selected = NULL)
+ conditionalPanel( |
|
| 54 | -+ | ||
| 271 | +! |
- #'+ condition = paste0("input['", ns("facetting"), "']"),
|
|
| 55 | -+ | ||
| 272 | +! |
- #' app <- teal::init(+ div( |
|
| 56 | -+ | ||
| 273 | +! |
- #' data = teal.data::cdisc_data(+ if (!is.null(args$row_facet)) {
|
|
| 57 | -+ | ||
| 274 | +! |
- #' teal.data::cdisc_dataset("ADSL", ADSL),
+ teal.transform::data_extract_ui( |
|
| 58 | -+ | ||
| 275 | +! |
- #' code = "ADSL <- teal.modules.general::rADSL",+ id = ns("row_facet"),
|
|
| 59 | -+ | ||
| 276 | +! |
- #' check = FALSE+ label = "Row facetting variable", |
|
| 60 | -+ | ||
| 277 | +! |
- #' ),+ data_extract_spec = args$row_facet, |
|
| 61 | -+ | ||
| 278 | +! |
- #' modules = teal::modules(+ is_single_dataset = is_single_dataset_value |
|
| 62 | +279 |
- #' teal.modules.general::tm_g_distribution(+ ) |
|
| 63 | +280 |
- #' dist_var = teal.transform::data_extract_spec(+ }, |
|
| 64 | -+ | ||
| 281 | +! |
- #' dataname = "ADSL",+ if (!is.null(args$col_facet)) {
|
|
| 65 | -+ | ||
| 282 | +! |
- #' select = teal.transform::select_spec(+ teal.transform::data_extract_ui( |
|
| 66 | -+ | ||
| 283 | +! |
- #' choices = teal.transform::variable_choices(ADSL, c("AGE", "BMRKR1")),
+ id = ns("col_facet"),
|
|
| 67 | -+ | ||
| 284 | +! |
- #' selected = "BMRKR1",+ label = "Column facetting variable", |
|
| 68 | -+ | ||
| 285 | +! |
- #' multiple = FALSE,+ data_extract_spec = args$col_facet, |
|
| 69 | -+ | ||
| 286 | +! |
- #' fixed = FALSE+ is_single_dataset = is_single_dataset_value |
|
| 70 | +287 |
- #' )+ ) |
|
| 71 | +288 |
- #' ),+ }, |
|
| 72 | -+ | ||
| 289 | +! |
- #' strata_var = teal.transform::data_extract_spec(+ checkboxInput(ns("free_x_scales"), "free x scales", value = args$free_x_scales),
|
|
| 73 | -+ | ||
| 290 | +! |
- #' dataname = "ADSL",+ checkboxInput(ns("free_y_scales"), "free y scales", value = args$free_y_scales)
|
|
| 74 | +291 |
- #' filter = teal.transform::filter_spec(+ ) |
|
| 75 | +292 |
- #' vars = vars1,+ ) |
|
| 76 | +293 |
- #' multiple = TRUE+ ) |
|
| 77 | +294 |
- #' )+ }, |
|
| 78 | -+ | ||
| 295 | +! |
- #' ),+ if (args$color_settings) {
|
|
| 79 | +296 |
- #' group_var = teal.transform::data_extract_spec(+ # Put a grey border around the coloring settings |
|
| 80 | -+ | ||
| 297 | +! |
- #' dataname = "ADSL",+ div( |
|
| 81 | -+ | ||
| 298 | +! |
- #' filter = teal.transform::filter_spec(+ class = "data-extract-box", |
|
| 82 | -+ | ||
| 299 | +! |
- #' vars = vars1,+ tags$label("Color settings"),
|
|
| 83 | -+ | ||
| 300 | +! |
- #' multiple = TRUE+ shinyWidgets::switchInput(inputId = ns("coloring"), value = TRUE, size = "mini"),
|
|
| 84 | -+ | ||
| 301 | +! |
- #' )+ conditionalPanel( |
|
| 85 | -+ | ||
| 302 | +! |
- #' ),+ condition = paste0("input['", ns("coloring"), "']"),
|
|
| 86 | -+ | ||
| 303 | +! |
- #' ggplot2_args = teal.widgets::ggplot2_args(+ div( |
|
| 87 | -+ | ||
| 304 | +! |
- #' labs = list(subtitle = "Plot generated by Distribution Module")+ teal.transform::data_extract_ui( |
|
| 88 | -+ | ||
| 305 | +! |
- #' )+ id = ns("color"),
|
|
| 89 | -+ | ||
| 306 | +! |
- #' )+ label = "Outline color by variable", |
|
| 90 | -+ | ||
| 307 | +! |
- #' )+ data_extract_spec = args$color, |
|
| 91 | -+ | ||
| 308 | +! |
- #' )+ is_single_dataset = is_single_dataset_value |
|
| 92 | +309 |
- #' if (interactive()) {
+ ), |
|
| 93 | -+ | ||
| 310 | +! |
- #' shinyApp(app$ui, app$server)+ teal.transform::data_extract_ui( |
|
| 94 | -+ | ||
| 311 | +! |
- #' }+ id = ns("fill"),
|
|
| 95 | -+ | ||
| 312 | +! |
- tm_g_distribution <- function(label = "Distribution Module",+ label = "Fill color by variable", |
|
| 96 | -+ | ||
| 313 | +! |
- dist_var,+ data_extract_spec = args$fill, |
|
| 97 | -+ | ||
| 314 | +! |
- strata_var = NULL,+ is_single_dataset = is_single_dataset_value |
|
| 98 | +315 |
- group_var = NULL,+ ), |
|
| 99 | -+ | ||
| 316 | +! |
- freq = FALSE,+ div( |
|
| 100 | -+ | ||
| 317 | +! |
- ggtheme = c(+ id = ns("size_settings"),
|
|
| 101 | -+ | ||
| 318 | +! |
- "gray", "bw", "linedraw", "light", "dark",+ teal.transform::data_extract_ui( |
|
| 102 | -+ | ||
| 319 | +! |
- "minimal", "classic", "void", "test"+ id = ns("size"),
|
|
| 103 | -+ | ||
| 320 | +! |
- ),+ label = "Size of points by variable (only if x and y are numeric)",+ |
+ |
| 321 | +! | +
+ data_extract_spec = args$size,+ |
+ |
| 322 | +! | +
+ is_single_dataset = is_single_dataset_value |
|
| 104 | +323 |
- ggplot2_args = teal.widgets::ggplot2_args(),+ ) |
|
| 105 | +324 |
- bins = c(30L, 1L, 100L),+ ) |
|
| 106 | +325 |
- plot_height = c(600, 200, 2000),+ ) |
|
| 107 | +326 |
- plot_width = NULL,+ ) |
|
| 108 | +327 |
- pre_output = NULL,+ ) |
|
| 109 | +328 |
- post_output = NULL) {
+ }, |
|
| 110 | +329 | ! |
- logger::log_info("Initializing tm_g_distribution")
+ teal.widgets::panel_group( |
| 111 | -+ | ||
| 330 | +! |
-
+ teal.widgets::panel_item( |
|
| 112 | +331 | ! |
- extra_packages <- c("ggpmisc", "ggpp", "goftest", "MASS", "broom")
+ title = "Plot settings", |
| 113 | +332 | ! |
- missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages)+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
|
| 114 | +333 | ! |
- if (length(missing_packages) > 0L) {
+ checkboxInput(ns("swap_axes"), "Swap axes", value = args$swap_axes),
|
| 115 | +334 | ! |
- stop(sprintf(+ selectInput( |
| 116 | +335 | ! |
- "Cannot load package(s): %s.\nInstall or restart your session.",+ inputId = ns("ggtheme"),
|
| 117 | +336 | ! |
- toString(missing_packages)+ label = "Theme (by ggplot):", |
| 118 | -+ | ||
| 337 | +! |
- ))+ choices = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
|
|
| 119 | -+ | ||
| 338 | +! |
- }+ selected = args$ggtheme,+ |
+ |
| 339 | +! | +
+ multiple = FALSE |
|
| 120 | +340 |
-
+ ), |
|
| 121 | +341 | ! |
- if (inherits(dist_var, "data_extract_spec")) dist_var <- list(dist_var)+ sliderInput( |
| 122 | +342 | ! |
- if (inherits(strata_var, "data_extract_spec")) strata_var <- list(strata_var)+ ns("alpha"), "Opacity Scatterplot:",
|
| 123 | +343 | ! |
- if (inherits(group_var, "data_extract_spec")) group_var <- list(group_var)+ min = 0, max = 1, |
| 124 | +344 | ! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ step = .05, value = .5, ticks = FALSE |
| 125 | +345 |
-
+ ), |
|
| 126 | +346 | ! |
- ggtheme <- match.arg(ggtheme)+ sliderInput( |
| 127 | +347 | ! |
- if (length(bins) == 1) {
+ ns("fixed_size"), "Scatterplot point size:",
|
| 128 | +348 | ! |
- checkmate::assert_numeric(bins, any.missing = FALSE, lower = 1)+ min = 1, max = 8,+ |
+
| 349 | +! | +
+ step = 1, value = 2, ticks = FALSE |
|
| 129 | +350 |
- } else {
+ ), |
|
| 130 | +351 | ! |
- checkmate::assert_numeric(bins, len = 3, any.missing = FALSE, lower = 1)+ checkboxInput(ns("add_lines"), "Add lines"),
|
| 131 | -! | +||
| 352 | +
- checkmate::assert_numeric(bins[1], lower = bins[2], upper = bins[3], .var.name = "bins")+ ) |
||
| 132 | +353 |
- }+ ) |
|
| 133 | -! | +||
| 354 | +
- checkmate::assert_string(label)+ ), |
||
| 134 | +355 | ! |
- checkmate::assert_list(dist_var, "data_extract_spec")+ forms = tagList( |
| 135 | +356 | ! |
- checkmate::assert_false(dist_var[[1]]$select$multiple)+ teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"),
|
| 136 | +357 | ! |
- checkmate::assert_list(strata_var, types = "data_extract_spec", null.ok = TRUE)+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
| 137 | -! | +||
| 358 | +
- checkmate::assert_list(group_var, types = "data_extract_spec", null.ok = TRUE)+ ), |
||
| 138 | +359 | ! |
- checkmate::assert_flag(freq)+ pre_output = args$pre_output, |
| 139 | +360 | ! |
- plot_choices <- c("Histogram", "QQplot")
+ post_output = args$post_output |
| 140 | -! | +||
| 361 | +
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ ) |
||
| 141 | -! | +||
| 362 | +
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ } |
||
| 142 | +363 | ||
| 143 | -! | +||
| 364 | +
- args <- as.list(environment())+ |
||
| 144 | +365 |
-
+ srv_g_bivariate <- function(id, |
|
| 145 | -! | +||
| 366 | +
- data_extract_list <- list(+ data, |
||
| 146 | -! | +||
| 367 | +
- dist_var = dist_var,+ reporter, |
||
| 147 | -! | +||
| 368 | +
- strata_var = strata_var,+ filter_panel_api, |
||
| 148 | -! | +||
| 369 | +
- group_var = group_var+ x, |
||
| 149 | +370 |
- )+ y, |
|
| 150 | +371 |
-
+ row_facet, |
|
| 151 | -! | +||
| 372 | +
- module(+ col_facet, |
||
| 152 | -! | +||
| 373 | +
- label = label,+ color_settings = FALSE, |
||
| 153 | -! | +||
| 374 | +
- server = srv_distribution,+ color, |
||
| 154 | -! | +||
| 375 | +
- server_args = c(+ fill, |
||
| 155 | -! | +||
| 376 | +
- data_extract_list,+ size, |
||
| 156 | -! | +||
| 377 | +
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)+ plot_height, |
||
| 157 | +378 |
- ),+ plot_width, |
|
| 158 | -! | +||
| 379 | +
- ui = ui_distribution,+ ggplot2_args) {
|
||
| 159 | +380 | ! |
- ui_args = args,+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 160 | +381 | ! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)- |
-
| 161 | -- |
- )+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 162 | -+ | ||
| 382 | +! |
- }+ checkmate::assert_class(data, "tdata") |
|
| 163 | -+ | ||
| 383 | +! |
-
+ moduleServer(id, function(input, output, session) {
|
|
| 164 | -+ | ||
| 384 | +! |
- ui_distribution <- function(id, ...) {
+ data_extract <- list( |
|
| 165 | +385 | ! |
- args <- list(...)+ x = x, y = y, row_facet = row_facet, col_facet = col_facet, |
| 166 | +386 | ! |
- ns <- NS(id)+ color = color, fill = fill, size = size |
| 167 | -! | +||
| 387 | +
- is_single_dataset_value <- teal.transform::is_single_dataset(args$dist_var, args$strata_var, args$group_var)+ ) |
||
| 168 | +388 | ||
| 169 | +389 | ! |
- teal.widgets::standard_layout(+ rule_var <- function(other) {
|
| 170 | +390 | ! |
- output = teal.widgets::white_small_well(+ function(value) {
|
| 171 | +391 | ! |
- tabsetPanel(+ othervalue <- selector_list()[[other]]()$select |
| 172 | +392 | ! |
- id = ns("tabs"),
+ if (length(value) == 0L && length(othervalue) == 0L) {
|
| 173 | +393 | ! |
- tabPanel("Histogram", teal.widgets::plot_with_settings_ui(id = ns("hist_plot"))),
+ "Please select at least one of x-variable or y-variable" |
| 174 | -! | +||
| 394 | +
- tabPanel("QQplot", teal.widgets::plot_with_settings_ui(id = ns("qq_plot")))
+ } |
||
| 175 | +395 |
- ),+ }+ |
+ |
| 396 | ++ |
+ } |
|
| 176 | +397 | ! |
- h3("Statistics Table"),
+ rule_diff <- function(other) {
|
| 177 | +398 | ! |
- DT::dataTableOutput(ns("summary_table")),
+ function(value) {
|
| 178 | +399 | ! |
- h3("Tests"),
+ othervalue <- selector_list()[[other]]()[["select"]] |
| 179 | +400 | ! |
- DT::dataTableOutput(ns("t_stats"))
+ if (!is.null(othervalue)) {
|
| 180 | -+ | ||
| 401 | +! |
- ),+ if (identical(value, othervalue)) {
|
|
| 181 | +402 | ! |
- encoding = div(+ "Row and column facetting variables must be different." |
| 182 | +403 |
- ### Reporter+ } |
|
| 183 | -! | +||
| 404 | +
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ } |
||
| 184 | +405 |
- ###+ } |
|
| 185 | -! | +||
| 406 | +
- tags$label("Encodings", class = "text-primary"),
+ } |
||
| 186 | -! | +||
| 407 | +
- teal.transform::datanames_input(args[c("dist_var", "strata_var")]),
+
|
||
| 187 | +408 | ! |
- teal.transform::data_extract_ui(+ selector_list <- teal.transform::data_extract_multiple_srv( |
| 188 | +409 | ! |
- id = ns("dist_i"),
+ data_extract = data_extract, |
| 189 | +410 | ! |
- label = "Variable",+ datasets = data, |
| 190 | +411 | ! |
- data_extract_spec = args$dist_var,+ select_validation_rule = list( |
| 191 | +412 | ! |
- is_single_dataset = is_single_dataset_value+ x = rule_var("y"),
|
| 192 | -+ | ||
| 413 | +! |
- ),+ y = rule_var("x"),
|
|
| 193 | +414 | ! |
- if (!is.null(args$group_var)) {
+ row_facet = shinyvalidate::compose_rules( |
| 194 | +415 | ! |
- tagList(+ shinyvalidate::sv_optional(), |
| 195 | +416 | ! |
- teal.transform::data_extract_ui(+ rule_diff("col_facet")
|
| 196 | -! | +||
| 417 | +
- id = ns("group_i"),
+ ), |
||
| 197 | +418 | ! |
- label = "Group by",+ col_facet = shinyvalidate::compose_rules( |
| 198 | +419 | ! |
- data_extract_spec = args$group_var,+ shinyvalidate::sv_optional(), |
| 199 | +420 | ! |
- is_single_dataset = is_single_dataset_value+ rule_diff("row_facet")
|
| 200 | +421 |
- ),+ ) |
|
| 201 | -! | +||
| 422 | +
- uiOutput(ns("scales_types_ui"))
+ ) |
||
| 202 | +423 |
- )+ ) |
|
| 203 | +424 |
- },+ |
|
| 204 | +425 | ! |
- if (!is.null(args$strata_var)) {
+ iv_r <- reactive({
|
| 205 | +426 | ! |
- teal.transform::data_extract_ui(+ iv_facet <- shinyvalidate::InputValidator$new() |
| 206 | +427 | ! |
- id = ns("strata_i"),
+ iv_child <- teal.transform::compose_and_enable_validators(iv_facet, selector_list, |
| 207 | +428 | ! |
- label = "Stratify by",+ validator_names = c("row_facet", "col_facet")
|
| 208 | -! | +||
| 429 | +
- data_extract_spec = args$strata_var,+ ) |
||
| 209 | +430 | ! |
- is_single_dataset = is_single_dataset_value+ iv_child$condition(~ isTRUE(input$facetting)) |
| 210 | +431 |
- )+ |
|
| 211 | -+ | ||
| 432 | +! |
- },+ iv <- shinyvalidate::InputValidator$new() |
|
| 212 | +433 | ! |
- teal.widgets::panel_group(+ iv$add_validator(iv_child) |
| 213 | +434 | ! |
- conditionalPanel(+ teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = c("x", "y"))
|
| 214 | -! | +||
| 435 | +
- condition = paste0("input['", ns("tabs"), "'] == 'Histogram'"),
+ }) |
||
| 215 | -! | +||
| 436 | +
- teal.widgets::panel_item(+ |
||
| 216 | +437 | ! |
- "Histogram",+ anl_merged_input <- teal.transform::merge_expression_srv( |
| 217 | +438 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("bins"), "Bins", args$bins, ticks = FALSE, step = 1),
+ selector_list = selector_list, |
| 218 | +439 | ! |
- shinyWidgets::prettyRadioButtons(+ datasets = data, |
| 219 | +440 | ! |
- ns("main_type"),
+ join_keys = get_join_keys(data) |
| 220 | -! | +||
| 441 | +
- label = "Plot Type:",+ )+ |
+ ||
| 442 | ++ | + | |
| 221 | +443 | ! |
- choices = c("Density", "Frequency"),
+ anl_merged_q <- reactive({
|
| 222 | +444 | ! |
- selected = if (!args$freq) "Density" else "Frequency",+ req(anl_merged_input()) |
| 223 | +445 | ! |
- bigger = FALSE,+ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% |
| 224 | +446 | ! |
- inline = TRUE+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
| 225 | +447 |
- ),+ })+ |
+ |
| 448 | ++ | + | |
| 226 | +449 | ! |
- checkboxInput(ns("add_dens"), label = "Overlay Density", value = TRUE),
+ merged <- list( |
| 227 | +450 | ! |
- collapsed = FALSE+ anl_input_r = anl_merged_input, |
| 228 | -+ | ||
| 451 | +! |
- )+ anl_q_r = anl_merged_q |
|
| 229 | +452 |
- ),+ ) |
|
| 230 | -! | +||
| 453 | +
- conditionalPanel(+ |
||
| 231 | +454 | ! |
- condition = paste0("input['", ns("tabs"), "'] == 'QQplot'"),
+ output_q <- reactive({
|
| 232 | +455 | ! |
- teal.widgets::panel_item(+ teal::validate_inputs(iv_r()) |
| 233 | -! | +||
| 456 | +
- "QQ Plot",+ |
||
| 234 | +457 | ! |
- checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE),
+ ANL <- merged$anl_q_r()[["ANL"]] # nolint |
| 235 | +458 | ! |
- collapsed = FALSE+ teal::validate_has_data(ANL, 3) |
| 236 | +459 |
- )+ |
|
| 237 | -+ | ||
| 460 | +! |
- ),+ x_col_vec <- as.vector(merged$anl_input_r()$columns_source$x) |
|
| 238 | +461 | ! |
- conditionalPanel(+ x_name <- `if`(is.null(x_col_vec), character(0), x_col_vec) |
| 239 | +462 | ! |
- condition = paste0("input['", ns("main_type"), "'] == 'Density'"),
+ y_col_vec <- as.vector(merged$anl_input_r()$columns_source$y) |
| 240 | +463 | ! |
- teal.widgets::panel_item(+ y_name <- `if`(is.null(y_col_vec), character(0), y_col_vec) |
| 241 | -! | +||
| 464 | +
- "Theoretical Distribution",+ |
||
| 242 | +465 | ! |
- teal.widgets::optionalSelectInput(+ row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet) |
| 243 | +466 | ! |
- ns("t_dist"),
+ col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet) |
| 244 | +467 | ! |
- div(+ color_name <- if ("color" %in% names(merged$anl_input_r()$columns_source)) {
|
| 245 | +468 | ! |
- class = "teal-tooltip",+ as.vector(merged$anl_input_r()$columns_source$color)+ |
+
| 469 | ++ |
+ } else {
|
|
| 246 | +470 | ! |
- tagList(+ character(0)+ |
+
| 471 | ++ |
+ } |
|
| 247 | +472 | ! |
- "Distribution:",+ fill_name <- if ("fill" %in% names(merged$anl_input_r()$columns_source)) {
|
| 248 | +473 | ! |
- icon("circle-info"),
+ as.vector(merged$anl_input_r()$columns_source$fill)+ |
+
| 474 | ++ |
+ } else {
|
|
| 249 | +475 | ! |
- span(+ character(0)+ |
+
| 476 | ++ |
+ } |
|
| 250 | +477 | ! |
- class = "tooltiptext",+ size_name <- if ("size" %in% names(merged$anl_input_r()$columns_source)) {
|
| 251 | +478 | ! |
- "Default parameters are optimized with MASS::fitdistr function."+ as.vector(merged$anl_input_r()$columns_source$size) |
| 252 | +479 |
- )+ } else {
+ |
+ |
| 480 | +! | +
+ character(0) |
|
| 253 | +481 |
- )+ } |
|
| 254 | +482 |
- ),+ |
|
| 255 | +483 | ! |
- choices = c("normal", "lognormal", "gamma", "unif"),
+ use_density <- input$use_density == "density" |
| 256 | +484 | ! |
- selected = NULL,+ free_x_scales <- input$free_x_scales |
| 257 | +485 | ! |
- multiple = FALSE+ free_y_scales <- input$free_y_scales |
| 258 | -+ | ||
| 486 | +! |
- ),+ ggtheme <- input$ggtheme |
|
| 259 | +487 | ! |
- numericInput(ns("dist_param1"), label = "param1", value = NULL),
+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
| 260 | +488 | ! |
- numericInput(ns("dist_param2"), label = "param2", value = NULL),
+ swap_axes <- input$swap_axes+ |
+
| 489 | ++ | + | |
| 261 | +490 | ! |
- span(actionButton(ns("params_reset"), "Reset params")),
+ is_scatterplot <- all(vapply(ANL[c(x_name, y_name)], is.numeric, logical(1))) && |
| 262 | +491 | ! |
- collapsed = FALSE+ length(x_name) > 0 && length(y_name) > 0 |
| 263 | +492 |
- )+ |
|
| 264 | -+ | ||
| 493 | +! |
- )+ if (is_scatterplot) {
|
|
| 265 | -+ | ||
| 494 | +! |
- ),+ shinyjs::show("alpha")
|
|
| 266 | +495 | ! |
- teal.widgets::panel_item(+ alpha <- input$alpha # nolint |
| 267 | +496 | ! |
- "Tests",+ shinyjs::show("add_lines")
+ |
+
| 497 | ++ | + | |
| 268 | +498 | ! |
- teal.widgets::optionalSelectInput(+ if (color_settings && input$coloring) {
|
| 269 | +499 | ! |
- ns("dist_tests"),
+ shinyjs::hide("fixed_size")
|
| 270 | +500 | ! |
- "Tests:",+ shinyjs::show("size_settings")
|
| 271 | +501 | ! |
- choices = c(+ size <- NULL+ |
+
| 502 | ++ |
+ } else {
|
|
| 272 | +503 | ! |
- "Shapiro-Wilk",+ shinyjs::show("fixed_size")
|
| 273 | +504 | ! |
- if (!is.null(args$strata_var)) "t-test (two-samples, not paired)",+ size <- input$fixed_size+ |
+
| 505 | ++ |
+ }+ |
+ |
| 506 | ++ |
+ } else {
|
|
| 274 | +507 | ! |
- if (!is.null(args$strata_var)) "one-way ANOVA",+ shinyjs::hide("add_lines")
|
| 275 | +508 | ! |
- if (!is.null(args$strata_var)) "Fligner-Killeen",+ updateCheckboxInput(session, "add_lines", value = FALSE) |
| 276 | +509 | ! |
- if (!is.null(args$strata_var)) "F-test",+ shinyjs::hide("alpha")
|
| 277 | +510 | ! |
- "Kolmogorov-Smirnov (one-sample)",+ shinyjs::hide("fixed_size")
|
| 278 | +511 | ! |
- "Anderson-Darling (one-sample)",+ shinyjs::hide("size_settings")
|
| 279 | +512 | ! |
- "Cramer-von Mises (one-sample)",+ alpha <- 1 |
| 280 | +513 | ! |
- if (!is.null(args$strata_var)) "Kolmogorov-Smirnov (two-samples)"+ size <- NULL |
| 281 | +514 |
- ),+ } |
|
| 282 | -! | +||
| 515 | +
- selected = NULL+ |
||
| 283 | +516 |
- )+ + |
+ |
| 517 | +! | +
+ teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE) |
|
| 284 | +518 |
- ),+ |
|
| 285 | +519 | ! |
- teal.widgets::panel_item(+ cl <- bivariate_plot_call( |
| 286 | +520 | ! |
- "Statistics Table",+ data_name = "ANL", |
| 287 | +521 | ! |
- sliderInput(ns("roundn"), "Round to n digits", min = 0, max = 10, value = 2)
+ x = x_name, |
| 288 | -+ | ||
| 522 | +! |
- ),+ y = y_name, |
|
| 289 | +523 | ! |
- teal.widgets::panel_item(+ x_class = ifelse(!identical(x_name, character(0)), class(ANL[[x_name]]), "NULL"), |
| 290 | +524 | ! |
- title = "Plot settings",+ y_class = ifelse(!identical(y_name, character(0)), class(ANL[[y_name]]), "NULL"), |
| 291 | +525 | ! |
- selectInput(+ x_label = varname_w_label(x_name, ANL), |
| 292 | +526 | ! |
- inputId = ns("ggtheme"),
+ y_label = varname_w_label(y_name, ANL), |
| 293 | +527 | ! |
- label = "Theme (by ggplot):",+ freq = !use_density, |
| 294 | +528 | ! |
- choices = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
+ theme = ggtheme, |
| 295 | +529 | ! |
- selected = args$ggtheme,+ rotate_xaxis_labels = rotate_xaxis_labels, |
| 296 | +530 | ! |
- multiple = FALSE+ swap_axes = swap_axes, |
| 297 | -+ | ||
| 531 | +! |
- )+ alpha = alpha,+ |
+ |
| 532 | +! | +
+ size = size,+ |
+ |
| 533 | +! | +
+ ggplot2_args = ggplot2_args |
|
| 298 | +534 |
) |
|
| 299 | +535 |
- ),+ |
|
| 300 | +536 | ! |
- forms = tagList(+ facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name)))+ |
+
| 537 | ++ | + | |
| 301 | +538 | ! |
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+ if (facetting) {
|
| 302 | +539 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name, free_x_scales, free_y_scales) |
| 303 | +540 |
- ),+ |
|
| 304 | +541 | ! |
- pre_output = args$pre_output,+ if (!is.null(facet_cl)) {
|
| 305 | +542 | ! |
- post_output = args$post_output+ cl <- call("+", cl, facet_cl)
|
| 306 | +543 |
- )+ } |
|
| 307 | +544 |
- }+ } |
|
| 308 | +545 | ||
| 309 | -- |
- srv_distribution <- function(id,- |
- |
| 310 | -- |
- data,- |
- |
| 311 | -- |
- reporter,- |
- |
| 312 | -- |
- filter_panel_api,- |
- |
| 313 | -- |
- dist_var,- |
- |
| 314 | -+ | ||
| 546 | +! |
- strata_var,+ if (input$add_lines) {
|
|
| 315 | -+ | ||
| 547 | +! |
- group_var,+ cl <- call("+", cl, quote(geom_line(size = 1)))
|
|
| 316 | +548 |
- plot_height,+ } |
|
| 317 | +549 |
- plot_width,+ |
|
| 318 | -+ | ||
| 550 | +! |
- ggplot2_args) {
+ coloring_cl <- NULL |
|
| 319 | +551 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ if (color_settings) {
|
| 320 | +552 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ if (input$coloring) {
|
| 321 | +553 | ! |
- checkmate::assert_class(data, "tdata")+ coloring_cl <- coloring_ggplot_call( |
| 322 | +554 | ! |
- moduleServer(id, function(input, output, session) {
+ colour = color_name, |
| 323 | +555 | ! |
- rule_req <- function(value) {
+ fill = fill_name, |
| 324 | +556 | ! |
- if (isTRUE(input$dist_tests %in% c(+ size = size_name, |
| 325 | +557 | ! |
- "Fligner-Killeen",+ is_point = any(grepl("geom_point", cl %>% deparse()))
|
| 326 | -! | +||
| 558 | +
- "t-test (two-samples, not paired)",+ ) |
||
| 327 | +559 | ! |
- "F-test",+ legend_lbls <- substitute( |
| 328 | +560 | ! |
- "Kolmogorov-Smirnov (two-samples)",+ expr = labs(color = color_name, fill = fill_name, size = size_name), |
| 329 | +561 | ! |
- "one-way ANOVA"+ env = list( |
| 330 | -+ | ||
| 562 | +! |
- ))) {
+ color_name = varname_w_label(color_name, ANL), |
|
| 331 | +563 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ fill_name = varname_w_label(fill_name, ANL), |
| 332 | +564 | ! |
- "Please select stratify variable."+ size_name = varname_w_label(size_name, ANL) |
| 333 | +565 |
- }+ ) |
|
| 334 | +566 |
- }+ ) |
|
| 335 | +567 |
- }- |
- |
| 336 | -! | -
- rule_dupl <- function(...) {
- |
- |
| 337 | -! | -
- if (identical(input$dist_tests, "Fligner-Killeen")) {
- |
- |
| 338 | -! | -
- strata <- selector_list()$strata_i()$select- |
- |
| 339 | -! | -
- group <- selector_list()$group_i()$select+ } |
|
| 340 | +568 | ! |
- if (isTRUE(strata == group)) {
+ if (!is.null(coloring_cl)) {
|
| 341 | +569 | ! |
- "Please select different variables for strata and group."+ cl <- call("+", call("+", cl, coloring_cl), legend_lbls)
|
| 342 | +570 |
} |
|
| 343 | +571 |
} |
|
| 344 | +572 |
- }+ |
|
| 345 | +573 |
-
+ # Add labels to facets |
|
| 346 | +574 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ nulled_row_facet_name <- varname_w_label(row_facet_name, ANL) |
| 347 | +575 | ! |
- data_extract = list(+ nulled_col_facet_name <- varname_w_label(col_facet_name, ANL) |
| 348 | +576 | ! |
- dist_i = dist_var,+ without_facet <- (is.null(nulled_row_facet_name) && is.null(nulled_col_facet_name)) || !facetting+ |
+
| 577 | ++ | + | |
| 349 | +578 | ! |
- strata_i = strata_var,+ print_call <- if (without_facet) {
|
| 350 | +579 | ! |
- group_i = group_var+ quote(print(p)) |
| 351 | +580 |
- ),- |
- |
| 352 | -! | -
- data,+ } else {
|
|
| 353 | +581 | ! |
- select_validation_rule = list(+ substitute( |
| 354 | +582 | ! |
- dist_i = shinyvalidate::sv_required("Please select a variable")
+ expr = {
|
| 355 | +583 |
- ),+ # Add facetting labels |
|
| 356 | -! | +||
| 584 | +
- filter_validation_rule = list(+ # optional: grid.newpage() #nolintr |
||
| 357 | +585 | ! |
- strata_i = shinyvalidate::compose_rules(+ p <- add_facet_labels(p, xfacet_label = nulled_col_facet_name, yfacet_label = nulled_row_facet_name) |
| 358 | +586 | ! |
- rule_req,+ grid::grid.newpage() |
| 359 | +587 | ! |
- rule_dupl+ grid::grid.draw(p) |
| 360 | +588 |
- ),+ }, |
|
| 361 | +589 | ! |
- group_i = rule_dupl+ env = list(nulled_col_facet_name = nulled_col_facet_name, nulled_row_facet_name = nulled_row_facet_name) |
| 362 | +590 |
- )+ ) |
|
| 363 | +591 |
- )+ } |
|
| 364 | +592 | ||
| 365 | +593 | ! |
- iv_r <- reactive({
+ teal.code::eval_code(merged$anl_q_r(), substitute(expr = p <- cl, env = list(cl = cl))) %>% |
| 366 | +594 | ! |
- iv <- shinyvalidate::InputValidator$new()+ teal.code::eval_code(print_call)+ |
+
| 595 | ++ |
+ })+ |
+ |
| 596 | ++ | + | |
| 367 | +597 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = "dist_i")+ plot_r <- shiny::reactive({
+ |
+
| 598 | +! | +
+ output_q()[["p"]] |
|
| 368 | +599 |
}) |
|
| 369 | +600 | ||
| 370 | +601 | ! |
- iv_r_dist <- reactive({
+ pws <- teal.widgets::plot_with_settings_srv( |
| 371 | +602 | ! |
- iv <- shinyvalidate::InputValidator$new()+ id = "myplot", |
| 372 | +603 | ! |
- teal.transform::compose_and_enable_validators(+ plot_r = plot_r, |
| 373 | +604 | ! |
- iv, selector_list,+ height = plot_height, |
| 374 | +605 | ! |
- validator_names = c("strata_i", "group_i")
+ width = plot_width |
| 375 | +606 |
- )+ ) |
|
| 376 | +607 |
- })+ |
|
| 377 | +608 | ! |
- rule_dist_1 <- function(value) {
+ teal.widgets::verbatim_popup_srv( |
| 378 | +609 | ! |
- if (!is.null(input$t_dist)) {
+ id = "warning", |
| 379 | +610 | ! |
- switch(input$t_dist,+ verbatim_content = reactive(teal.code::get_warnings(output_q())), |
| 380 | +611 | ! |
- "normal" = if (!shinyvalidate::input_provided(value)) "mean is required",+ title = "Warning", |
| 381 | +612 | ! |
- "lognormal" = if (!shinyvalidate::input_provided(value)) "meanlog is required",+ disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ |
+
| 613 | ++ |
+ )+ |
+ |
| 614 | ++ | + | |
| 382 | +615 | ! |
- "gamma" = {
+ teal.widgets::verbatim_popup_srv( |
| 383 | +616 | ! |
- if (!shinyvalidate::input_provided(value)) "shape is required" else if (value <= 0) "shape must be positive"+ id = "rcode", |
| 384 | -+ | ||
| 617 | +! |
- },+ verbatim_content = reactive(teal.code::get_code(output_q())), |
|
| 385 | +618 | ! |
- "unif" = NULL+ title = "Bivariate Plot" |
| 386 | +619 |
- )+ ) |
|
| 387 | +620 |
- }+ |
|
| 388 | +621 |
- }- |
- |
| 389 | -! | -
- rule_dist_2 <- function(value) {
+ ### REPORTER |
|
| 390 | +622 | ! |
- if (!is.null(input$t_dist)) {
+ if (with_reporter) {
|
| 391 | +623 | ! |
- switch(input$t_dist,+ card_fun <- function(comment, label) {
|
| 392 | +624 | ! |
- "normal" = {
+ card <- teal::report_card_template( |
| 393 | +625 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ title = "Bivariate Plot", |
| 394 | +626 | ! |
- "sd is required"+ label = label, |
| 395 | +627 | ! |
- } else if (value < 0) {
+ with_filter = with_filter, |
| 396 | +628 | ! |
- "sd must be non-negative"- |
-
| 397 | -- |
- }+ filter_panel_api = filter_panel_api |
|
| 398 | +629 |
- },+ ) |
|
| 399 | +630 | ! |
- "lognormal" = {
+ card$append_text("Plot", "header3")
|
| 400 | +631 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ card$append_plot(plot_r(), dim = pws$dim()) |
| 401 | +632 | ! |
- "sdlog is required"+ if (!comment == "") {
|
| 402 | +633 | ! |
- } else if (value < 0) {
+ card$append_text("Comment", "header3")
|
| 403 | +634 | ! |
- "sdlog must be non-negative"- |
-
| 404 | -- |
- }+ card$append_text(comment) |
|
| 405 | +635 |
- },- |
- |
| 406 | -! | -
- "gamma" = {
+ } |
|
| 407 | +636 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n")) |
| 408 | +637 | ! |
- "rate is required"+ card |
| 409 | -! | +||
| 638 | +
- } else if (value <= 0) {
+ } |
||
| 410 | +639 | ! |
- "rate must be positive"+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 411 | +640 |
- }+ } |
|
| 412 | +641 |
- },- |
- |
| 413 | -! | -
- "unif" = NULL+ ### |
|
| 414 | +642 |
- )+ }) |
|
| 415 | +643 |
- }+ } |
|
| 416 | +644 |
- }- |
- |
| 417 | -! | -
- rule_dist <- function(value) {
- |
- |
| 418 | -! | -
- if (isTRUE(input$tabs == "QQplot" ||- |
- |
| 419 | -! | -
- input$dist_tests %in% c(- |
- |
| 420 | -! | -
- "Kolmogorov-Smirnov (one-sample)",- |
- |
| 421 | -! | -
- "Anderson-Darling (one-sample)",- |
- |
| 422 | -! | -
- "Cramer-von Mises (one-sample)"+ |
|
| 423 | +645 |
- ))) {
- |
- |
| 424 | -! | -
- if (!shinyvalidate::input_provided(value)) {
+
|
|
| 425 | -! | +||
| 646 | +
- "Please select the theoretical distribution."+ #' Get Substituted ggplot call |
||
| 426 | +647 |
- }+ #' |
|
| 427 | +648 |
- }+ #' @noRd |
|
| 428 | +649 |
- }+ #' |
|
| 429 | -! | +||
| 650 | +
- iv_dist <- shinyvalidate::InputValidator$new()+ #' @examples |
||
| 430 | -! | +||
| 651 | +
- iv_dist$add_rule("t_dist", rule_dist)
+ #' |
||
| 431 | -! | +||
| 652 | +
- iv_dist$add_rule("dist_param1", rule_dist_1)
+ #' bivariate_plot_call("ANL", "BAGE", "RACE", "numeric", "factor")
|
||
| 432 | -! | +||
| 653 | +
- iv_dist$add_rule("dist_param2", rule_dist_2)
+ #' bivariate_plot_call("ANL", "BAGE", character(0), "numeric", "NULL")
|
||
| 433 | -! | +||
| 654 | +
- iv_dist$enable()+ bivariate_plot_call <- function(data_name, |
||
| 434 | +655 |
-
+ x = character(0), |
|
| 435 | -! | +||
| 656 | +
- anl_merged_input <- teal.transform::merge_expression_srv(+ y = character(0), |
||
| 436 | -! | +||
| 657 | +
- selector_list = selector_list,+ x_class = "NULL", |
||
| 437 | -! | +||
| 658 | +
- datasets = data,+ y_class = "NULL", |
||
| 438 | -! | +||
| 659 | +
- join_keys = get_join_keys(data)+ x_label = NULL, |
||
| 439 | +660 |
- )+ y_label = NULL, |
|
| 440 | +661 |
-
+ freq = TRUE, |
|
| 441 | -! | +||
| 662 | +
- anl_merged_q <- reactive({
+ theme = "gray", |
||
| 442 | -! | +||
| 663 | +
- req(anl_merged_input())+ rotate_xaxis_labels = FALSE, |
||
| 443 | -! | +||
| 664 | +
- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>%+ swap_axes = FALSE, |
||
| 444 | -! | +||
| 665 | +
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ alpha = double(0), |
||
| 445 | +666 |
- })+ size = 2, |
|
| 446 | +667 |
-
+ ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 447 | +668 | ! |
- merged <- list(+ supported_types <- c("NULL", "numeric", "integer", "factor", "character", "logical")
|
| 448 | +669 | ! |
- anl_input_r = anl_merged_input,+ validate(need(x_class %in% supported_types, paste0("Data type '", x_class, "' is not supported.")))
|
| 449 | +670 | ! |
- anl_q_r = anl_merged_q+ validate(need(y_class %in% supported_types, paste0("Data type '", y_class, "' is not supported.")))
|
| 450 | +671 |
- )+ |
|
| 451 | +672 | ||
| 452 | -! | -
- output$scales_types_ui <- renderUI({
- |
- |
| 453 | -! | -
- if ("group_i" %in% names(selector_list()) && length(selector_list()$group_i()$filters[[1]]$selected) > 0) {
- |
- |
| 454 | +673 | ! |
- shinyWidgets::prettyRadioButtons(+ if (identical(x, character(0))) {
|
| 455 | +674 | ! |
- session$ns("scales_type"),
+ x <- x_label <- "-" |
| 456 | -! | +||
| 675 | +
- label = "Scales:",+ } else {
|
||
| 457 | +676 | ! |
- choices = c("Fixed", "Free"),
+ x <- if (is.call(x)) x else as.name(x) |
| 458 | -! | +||
| 677 | +
- selected = "Fixed",+ } |
||
| 459 | +678 | ! |
- bigger = FALSE,+ if (identical(y, character(0))) {
|
| 460 | +679 | ! |
- inline = TRUE+ y <- y_label <- "-" |
| 461 | +680 |
- )+ } else {
|
|
| 462 | -+ | ||
| 681 | +! |
- }+ y <- if (is.call(y)) y else as.name(y) |
|
| 463 | +682 |
- })+ } |
|
| 464 | +683 | ||
| 465 | +684 | ! |
- observeEvent(+ cl <- bivariate_ggplot_call( |
| 466 | +685 | ! |
- eventExpr = list(+ x_class = x_class, |
| 467 | +686 | ! |
- input$t_dist,+ y_class = y_class, |
| 468 | +687 | ! |
- input$params_reset,+ freq = freq, |
| 469 | +688 | ! |
- selector_list()$dist_i()$select- |
-
| 470 | -- |
- ),+ theme = theme, |
|
| 471 | +689 | ! |
- handlerExpr = {
+ rotate_xaxis_labels = rotate_xaxis_labels, |
| 472 | +690 | ! |
- if (length(input$t_dist) != 0) {
+ swap_axes = swap_axes, |
| 473 | +691 | ! |
- dist_var2 <- as.vector(merged$anl_input_r()$columns_source$dist_i)- |
-
| 474 | -- |
-
+ alpha = alpha, |
|
| 475 | +692 | ! |
- get_dist_params <- function(x, dist) {
+ size = size, |
| 476 | +693 | ! |
- if (dist == "unif") {
+ ggplot2_args = ggplot2_args, |
| 477 | +694 | ! |
- res <- as.list(range(x))+ x = x, |
| 478 | +695 | ! |
- names(res) <- c("min", "max")
+ y = y, |
| 479 | +696 | ! |
- return(res)- |
-
| 480 | -- |
- }+ xlab = x_label, |
|
| 481 | +697 | ! |
- tryCatch(+ ylab = y_label, |
| 482 | +698 | ! |
- as.list(MASS::fitdistr(x, densfun = dist)$estimate),+ data_name = data_name |
| 483 | -! | +||
| 699 | +
- error = function(e) list(param1 = NA, param2 = NA)+ ) |
||
| 484 | +700 |
- )+ } |
|
| 485 | +701 |
- }+ |
|
| 486 | +702 |
-
+ substitute_q <- function(x, env) {
|
|
| 487 | +703 | ! |
- ANL <- merged$anl_q_r()[[as.character(dist_var[[1]]$dataname)]] # nolint+ stopifnot(is.language(x)) |
| 488 | +704 | ! |
- params <- get_dist_params(as.numeric(stats::na.omit(ANL[[dist_var2]])), input$t_dist)+ call <- substitute(substitute(x, env), list(x = x)) |
| 489 | +705 | ! |
- params_vec <- round(unname(unlist(params)), 2)+ eval(call) |
| 490 | -! | +||
| 706 | +
- params_names <- names(params)+ } |
||
| 491 | +707 | ||
| 492 | -! | +||
| 708 | +
- updateNumericInput(session, "dist_param1", label = params_names[1], value = params_vec[1])+ |
||
| 493 | -! | +||
| 709 | +
- updateNumericInput(session, "dist_param2", label = params_names[2], value = params_vec[2])+ #' Create ggplot part of plot call |
||
| 494 | +710 |
- } else {
+ #' |
|
| 495 | -! | +||
| 711 | +
- updateNumericInput(session, "dist_param1", label = "param1", value = NA)+ #' Due to the type of the x and y variable the plot type is chosen |
||
| 496 | -! | +||
| 712 | +
- updateNumericInput(session, "dist_param2", label = "param2", value = NA)+ #' |
||
| 497 | +713 |
- }+ #' @noRd |
|
| 498 | +714 |
- },+ #' |
|
| 499 | -! | +||
| 715 | +
- ignoreInit = TRUE+ #' @examples |
||
| 500 | +716 |
- )+ #' bivariate_ggplot_call("numeric", "NULL")
|
|
| 501 | +717 |
-
+ #' bivariate_ggplot_call("numeric", "NULL", freq = FALSE)
|
|
| 502 | -! | +||
| 718 | +
- merge_vars <- reactive({
+ #' |
||
| 503 | -! | +||
| 719 | +
- teal::validate_inputs(iv_r())+ #' bivariate_ggplot_call("NULL", "numeric")
|
||
| 504 | +720 |
-
+ #' bivariate_ggplot_call("NULL", "numeric", freq = FALSE)
|
|
| 505 | -! | +||
| 721 | +
- dist_var <- as.vector(merged$anl_input_r()$columns_source$dist_i)+ #' |
||
| 506 | -! | +||
| 722 | +
- s_var <- as.vector(merged$anl_input_r()$columns_source$strata_i)+ #' bivariate_ggplot_call("NULL", "factor")
|
||
| 507 | -! | +||
| 723 | +
- g_var <- as.vector(merged$anl_input_r()$columns_source$group_i)+ #' bivariate_ggplot_call("NULL", "factor", freq = FALSE)
|
||
| 508 | +724 |
-
+ #' |
|
| 509 | -! | +||
| 725 | +
- dist_var_name <- if (length(dist_var)) as.name(dist_var) else NULL+ #' bivariate_ggplot_call("factor", "NULL")
|
||
| 510 | -! | +||
| 726 | +
- s_var_name <- if (length(s_var)) as.name(s_var) else NULL+ #' bivariate_ggplot_call("factor", "NULL", freq = FALSE)
|
||
| 511 | -! | +||
| 727 | +
- g_var_name <- if (length(g_var)) as.name(g_var) else NULL+ #' |
||
| 512 | +728 |
-
+ #' bivariate_ggplot_call("numeric", "numeric")
|
|
| 513 | -! | +||
| 729 | +
- list(+ #' bivariate_ggplot_call("numeric", "factor")
|
||
| 514 | -! | +||
| 730 | +
- dist_var = dist_var,+ #' bivariate_ggplot_call("factor", "numeric")
|
||
| 515 | -! | +||
| 731 | +
- s_var = s_var,+ #' bivariate_ggplot_call("factor", "factor")
|
||
| 516 | -! | +||
| 732 | +
- g_var = g_var,+ bivariate_ggplot_call <- function(x_class = c("NULL", "numeric", "integer", "factor", "character", "logical"),
|
||
| 517 | -! | +||
| 733 | +
- dist_var_name = dist_var_name,+ y_class = c("NULL", "numeric", "integer", "factor", "character", "logical"),
|
||
| 518 | -! | +||
| 734 | +
- s_var_name = s_var_name,+ freq = TRUE, |
||
| 519 | -! | +||
| 735 | +
- g_var_name = g_var_name+ theme = "gray", |
||
| 520 | +736 |
- )+ rotate_xaxis_labels = FALSE, |
|
| 521 | +737 |
- })+ swap_axes = FALSE, |
|
| 522 | +738 |
-
+ size = double(0), |
|
| 523 | +739 |
- # common qenv+ alpha = double(0), |
|
| 524 | -! | +||
| 740 | +
- common_q <- reactive({
+ x = NULL, |
||
| 525 | +741 |
- # Create a private stack for this function only.+ y = NULL, |
|
| 526 | +742 |
-
+ xlab = "-", |
|
| 527 | -! | +||
| 743 | +
- ANL <- merged$anl_q_r()[["ANL"]] # nolint+ ylab = "-", |
||
| 528 | -! | +||
| 744 | +
- dist_var <- merge_vars()$dist_var+ data_name = "ANL", |
||
| 529 | -! | +||
| 745 | +
- s_var <- merge_vars()$s_var+ ggplot2_args = teal.widgets::ggplot2_args()) {
|
||
| 530 | -! | +||
| 746 | +42x |
- g_var <- merge_vars()$g_var+ x_class <- match.arg(x_class) |
|
| 531 | -+ | ||
| 747 | +42x |
-
+ y_class <- match.arg(y_class) |
|
| 532 | -! | +||
| 748 | +
- dist_var_name <- merge_vars()$dist_var_name+ |
||
| 533 | -! | +||
| 749 | +42x |
- s_var_name <- merge_vars()$s_var_name+ if (x_class %in% c("character", "logical")) {
|
|
| 534 | -! | +||
| 750 | +12x |
- g_var_name <- merge_vars()$g_var_name+ x_class <- "factor" |
|
| 535 | +751 | - - | -|
| 536 | -! | -
- roundn <- input$roundn+ } |
|
| 537 | -! | +||
| 752 | +42x |
- dist_param1 <- input$dist_param1+ if (x_class %in% c("integer")) {
|
|
| 538 | +753 | ! |
- dist_param2 <- input$dist_param2+ x_class <- "numeric" |
| 539 | +754 |
- # isolated as dist_param1/dist_param2 already triggered the reactivity+ } |
|
| 540 | -! | +||
| 755 | +42x |
- t_dist <- isolate(input$t_dist)+ if (y_class %in% c("character", "logical")) {
|
|
| 541 | -+ | ||
| 756 | +8x |
-
+ y_class <- "factor" |
|
| 542 | -! | +||
| 757 | +
- qenv <- merged$anl_q_r()+ } |
||
| 543 | -+ | ||
| 758 | +42x |
-
+ if (y_class %in% c("integer")) {
|
|
| 544 | +759 | ! |
- if (length(g_var) > 0) {
+ y_class <- "numeric" |
| 545 | -! | +||
| 760 | +
- validate(+ } |
||
| 546 | -! | +||
| 761 | +
- need(+ |
||
| 547 | -! | +||
| 762 | +42x |
- inherits(ANL[[g_var]], c("integer", "factor", "character")),
+ if (all(c(x_class, y_class) == "NULL")) {
|
|
| 548 | +763 | ! |
- "Group by variable must be `factor`, `character`, or `integer`"+ stop("either x or y is required")
|
| 549 | +764 |
- )+ } |
|
| 550 | +765 |
- )+ |
|
| 551 | -! | +||
| 766 | +42x |
- qenv <- teal.code::eval_code(+ reduce_plot_call <- function(...) {
|
|
| 552 | -! | +||
| 767 | +104x |
- qenv,+ args <- Filter(Negate(is.null), list(...)) |
|
| 553 | -! | +||
| 768 | +104x |
- substitute(+ Reduce(function(x, y) call("+", x, y), args)
|
|
| 554 | -! | +||
| 769 | +
- expr = ANL[[g_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[g_var]]), "NA"), # nolint+ } |
||
| 555 | -! | +||
| 770 | +
- env = list(g_var = g_var)+ |
||
| 556 | -+ | ||
| 771 | +42x |
- )+ plot_call <- substitute(ggplot(data_name), env = list(data_name = as.name(data_name))) |
|
| 557 | +772 |
- )+ |
|
| 558 | +773 |
- }+ # Single data plots+ |
+ |
| 774 | +42x | +
+ if (x_class == "numeric" && y_class == "NULL") {
+ |
+ |
| 775 | +6x | +
+ plot_call <- reduce_plot_call(plot_call, substitute(aes(x = xval), env = list(xval = x))) |
|
| 559 | +776 | ||
| 560 | -! | +||
| 777 | +6x |
- if (length(s_var) > 0) {
+ if (freq) {
|
|
| 561 | -! | +||
| 778 | +4x |
- validate(+ plot_call <- reduce_plot_call( |
|
| 562 | -! | +||
| 779 | +4x |
- need(+ plot_call, |
|
| 563 | -! | +||
| 780 | +4x |
- inherits(ANL[[s_var]], c("integer", "factor", "character")),
+ quote(geom_histogram(bins = 30)), |
|
| 564 | -! | +||
| 781 | +4x |
- "Stratify by variable must be `factor`, `character`, or `integer`"+ quote(ylab("Frequency"))
|
|
| 565 | +782 |
- )+ ) |
|
| 566 | +783 |
- )+ } else {
|
|
| 567 | -! | +||
| 784 | +2x |
- qenv <- teal.code::eval_code(+ plot_call <- reduce_plot_call( |
|
| 568 | -! | +||
| 785 | +2x |
- qenv,+ plot_call, |
|
| 569 | -! | +||
| 786 | +2x |
- substitute(+ quote(geom_histogram(bins = 30, aes(y = after_stat(density)))), |
|
| 570 | -! | +||
| 787 | +2x |
- expr = ANL[[s_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[s_var]]), "NA"), # nolint+ quote(geom_density(aes(y = after_stat(density)))), |
|
| 571 | -! | +||
| 788 | +2x |
- env = list(s_var = s_var)+ quote(ylab("Density"))
|
|
| 572 | +789 |
- )+ ) |
|
| 573 | +790 |
- )+ } |
|
| 574 | -+ | ||
| 791 | +36x |
- }+ } else if (x_class == "NULL" && y_class == "numeric") {
+ |
+ |
| 792 | +6x | +
+ plot_call <- reduce_plot_call(plot_call, substitute(aes(x = yval), env = list(yval = y))) |
|
| 575 | +793 | ||
| 576 | -! | +||
| 794 | +6x |
- validate(need(is.numeric(ANL[[dist_var]]), "Please select a numeric variable."))+ if (freq) {
|
|
| 577 | -! | +||
| 795 | +4x |
- teal::validate_has_data(ANL, 1, complete = TRUE)+ plot_call <- reduce_plot_call( |
|
| 578 | -- | - - | -|
| 579 | -! | -
- if (length(t_dist) != 0) {
- |
- |
| 580 | -! | -
- map_distr_nams <- list(- |
- |
| 581 | -! | -
- normal = c("mean", "sd"),
- |
- |
| 582 | -! | +||
| 796 | +4x |
- lognormal = c("meanlog", "sdlog"),
+ plot_call, |
|
| 583 | -! | +||
| 797 | +4x |
- gamma = c("shape", "rate"),
+ quote(geom_histogram(bins = 30)), |
|
| 584 | -! | +||
| 798 | +4x |
- unif = c("min", "max")
+ quote(ylab("Frequency"))
|
|
| 585 | +799 |
- )- |
- |
| 586 | -! | -
- params_names_raw <- map_distr_nams[[t_dist]]+ ) |
|
| 587 | +800 | - - | -|
| 588 | -! | -
- qenv <- teal.code::eval_code(- |
- |
| 589 | -! | -
- qenv,- |
- |
| 590 | -! | -
- substitute(- |
- |
| 591 | -! | -
- expr = {
- |
- |
| 592 | -! | -
- params <- as.list(c(dist_param1, dist_param2))- |
- |
| 593 | -! | -
- names(params) <- params_names_raw+ } else {
|
|
| 594 | -+ | ||
| 801 | +2x |
- },+ plot_call <- reduce_plot_call( |
|
| 595 | -! | +||
| 802 | +2x |
- env = list(+ plot_call, |
|
| 596 | -! | +||
| 803 | +2x |
- dist_param1 = dist_param1,+ quote(geom_histogram(bins = 30, aes(y = after_stat(density)))), |
|
| 597 | -! | +||
| 804 | +2x |
- dist_param2 = dist_param2,+ quote(geom_density(aes(y = after_stat(density)))), |
|
| 598 | -! | +||
| 805 | +2x |
- params_names_raw = params_names_raw+ quote(ylab("Density"))
|
|
| 599 | +806 |
- )+ ) |
|
| 600 | +807 |
- )+ } |
|
| 601 | -+ | ||
| 808 | +30x |
- )+ } else if (x_class == "factor" && y_class == "NULL") {
|
|
| 602 | -+ | ||
| 809 | +4x |
- }+ plot_call <- reduce_plot_call(plot_call, substitute(aes(x = xval), env = list(xval = x))) |
|
| 603 | +810 | ||
| 604 | -! | -
- if (length(s_var) == 0 && length(g_var) == 0) {
- |
- |
| 605 | -! | -
- qenv <- teal.code::eval_code(- |
- |
| 606 | -! | -
- qenv,- |
- |
| 607 | -! | -
- substitute(- |
- |
| 608 | -! | -
- expr = {
- |
- |
| 609 | -! | -
- summary_table <- ANL %>%- |
- |
| 610 | -! | -
- dplyr::summarise(- |
- |
| 611 | -! | -
- min = round(min(dist_var_name, na.rm = TRUE), roundn),- |
- |
| 612 | -! | +||
| 811 | +4x |
- median = round(stats::median(dist_var_name, na.rm = TRUE), roundn),+ if (freq) {
|
|
| 613 | -! | +||
| 812 | +2x |
- mean = round(mean(dist_var_name, na.rm = TRUE), roundn),+ plot_call <- reduce_plot_call( |
|
| 614 | -! | +||
| 813 | +2x |
- max = round(max(dist_var_name, na.rm = TRUE), roundn),+ plot_call, |
|
| 615 | -! | +||
| 814 | +2x |
- sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn),+ quote(geom_bar()), |
|
| 616 | -! | +||
| 815 | +2x |
- count = dplyr::n()+ quote(ylab("Frequency"))
|
|
| 617 | +816 |
- )+ ) |
|
| 618 | +817 |
- },- |
- |
| 619 | -! | -
- env = list(+ } else {
|
|
| 620 | -! | +||
| 818 | +2x |
- dist_var_name = as.name(dist_var),+ plot_call <- reduce_plot_call( |
|
| 621 | -! | +||
| 819 | +2x |
- roundn = roundn+ plot_call, |
|
| 622 | -+ | ||
| 820 | +2x |
- )+ quote(geom_bar(aes(y = after_stat(prop), group = 1))), |
|
| 623 | -+ | ||
| 821 | +2x |
- )+ quote(ylab("Fraction"))
|
|
| 624 | +822 |
- )+ ) |
|
| 625 | +823 |
- } else {
- |
- |
| 626 | -! | -
- qenv <- teal.code::eval_code(- |
- |
| 627 | -! | -
- qenv,- |
- |
| 628 | -! | -
- substitute(- |
- |
| 629 | -! | -
- expr = {
- |
- |
| 630 | -! | -
- strata_vars <- strata_vars_raw- |
- |
| 631 | -! | -
- summary_table <- ANL %>%+ } |
|
| 632 | -! | +||
| 824 | +26x |
- dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>%+ } else if (x_class == "NULL" && y_class == "factor") {
|
|
| 633 | -! | +||
| 825 | +4x |
- dplyr::summarise(+ plot_call <- reduce_plot_call(plot_call, substitute(aes(x = yval), env = list(yval = y))) |
|
| 634 | -! | +||
| 826 | +
- min = round(min(dist_var_name, na.rm = TRUE), roundn),+ |
||
| 635 | -! | +||
| 827 | +4x |
- median = round(stats::median(dist_var_name, na.rm = TRUE), roundn),+ if (freq) {
|
|
| 636 | -! | +||
| 828 | +2x |
- mean = round(mean(dist_var_name, na.rm = TRUE), roundn),+ plot_call <- reduce_plot_call( |
|
| 637 | -! | +||
| 829 | +2x |
- max = round(max(dist_var_name, na.rm = TRUE), roundn),+ plot_call, |
|
| 638 | -! | +||
| 830 | +2x |
- sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn),+ quote(geom_bar()), |
|
| 639 | -! | +||
| 831 | +2x |
- count = dplyr::n()+ quote(ylab("Frequency"))
|
|
| 640 | +832 |
- )- |
- |
| 641 | -! | -
- summary_table # used to display table when running show-r-code code+ ) |
|
| 642 | +833 |
- },- |
- |
| 643 | -! | -
- env = list(- |
- |
| 644 | -! | -
- dist_var_name = dist_var_name,+ } else {
|
|
| 645 | -! | +||
| 834 | +2x |
- strata_vars_raw = c(g_var, s_var),+ plot_call <- reduce_plot_call( |
|
| 646 | -! | +||
| 835 | +2x |
- roundn = roundn+ plot_call, |
|
| 647 | -+ | ||
| 836 | +2x |
- )+ quote(geom_bar(aes(y = after_stat(prop), group = 1))), |
|
| 648 | -+ | ||
| 837 | +2x |
- )+ quote(ylab("Fraction"))
|
|
| 649 | +838 |
- )+ ) |
|
| 650 | +839 |
- }+ } |
|
| 651 | +840 |
- })+ # Numeric Plots |
|
| 652 | -+ | ||
| 841 | +22x |
-
+ } else if (x_class == "numeric" && y_class == "numeric") {
|
|
| 653 | -+ | ||
| 842 | +2x |
- # distplot qenv ----+ plot_call <- reduce_plot_call( |
|
| 654 | -! | +||
| 843 | +2x |
- dist_q <- eventReactive(+ plot_call, |
|
| 655 | -! | +||
| 844 | +2x |
- eventExpr = {
+ substitute(aes(x = xval, y = yval), env = list(xval = x, yval = y)), |
|
| 656 | -! | +||
| 845 | +
- common_q()+ # pch = 21 for consistent coloring behaviour b/w all geoms (outline and fill properties) |
||
| 657 | -! | +||
| 846 | +2x |
- input$scales_type+ `if`( |
|
| 658 | -! | +||
| 847 | +2x |
- input$main_type+ !is.null(size), |
|
| 659 | -! | +||
| 848 | +2x |
- input$bins+ substitute( |
|
| 660 | -! | +||
| 849 | +2x |
- input$add_dens+ geom_point(alpha = alphaval, size = sizeval, pch = 21), |
|
| 661 | -! | +||
| 850 | +2x |
- is.null(input$ggtheme)+ env = list(alphaval = alpha, sizeval = size) |
|
| 662 | +851 |
- },+ ),+ |
+ |
| 852 | +2x | +
+ substitute( |
|
| 663 | -! | +||
| 853 | +2x |
- valueExpr = {
+ geom_point(alpha = alphaval, pch = 21), |
|
| 664 | -! | +||
| 854 | +2x |
- dist_var <- merge_vars()$dist_var+ env = list(alphaval = alpha) |
|
| 665 | -! | +||
| 855 | +
- s_var <- merge_vars()$s_var+ ) |
||
| 666 | -! | +||
| 856 | +
- g_var <- merge_vars()$g_var+ ) |
||
| 667 | -! | +||
| 857 | +
- dist_var_name <- merge_vars()$dist_var_name+ ) |
||
| 668 | -! | +||
| 858 | +20x |
- s_var_name <- merge_vars()$s_var_name+ } else if ((x_class == "numeric" && y_class == "factor") || (x_class == "factor" && y_class == "numeric")) {
|
|
| 669 | -! | +||
| 859 | +6x |
- g_var_name <- merge_vars()$g_var_name+ plot_call <- reduce_plot_call( |
|
| 670 | -! | +||
| 860 | +6x |
- t_dist <- input$t_dist+ plot_call, |
|
| 671 | -! | +||
| 861 | +6x |
- dist_param1 <- input$dist_param1+ substitute(aes(x = xval, y = yval), env = list(xval = x, yval = y)), |
|
| 672 | -! | +||
| 862 | +6x |
- dist_param2 <- input$dist_param2+ quote(geom_boxplot()) |
|
| 673 | +863 |
-
+ ) |
|
| 674 | -! | +||
| 864 | +
- scales_type <- input$scales_type+ # Factor and character plots |
||
| 675 | -+ | ||
| 865 | +14x |
-
+ } else if (x_class == "factor" && y_class == "factor") {
|
|
| 676 | -! | +||
| 866 | +14x |
- ndensity <- 512+ plot_call <- reduce_plot_call( |
|
| 677 | -! | +||
| 867 | +14x |
- main_type_var <- input$main_type+ plot_call, |
|
| 678 | -! | +||
| 868 | +14x |
- bins_var <- input$bins+ substitute( |
|
| 679 | -! | +||
| 869 | +14x |
- add_dens_var <- input$add_dens+ ggmosaic::geom_mosaic(aes(x = ggmosaic::product(xval), fill = yval), na.rm = TRUE), |
|
| 680 | -! | +||
| 870 | +14x |
- ggtheme <- input$ggtheme+ env = list(xval = x, yval = y) |
|
| 681 | +871 |
-
+ ) |
|
| 682 | -! | +||
| 872 | +
- teal::validate_inputs(iv_dist)+ ) |
||
| 683 | +873 |
-
+ } else {
|
|
| 684 | +874 | ! |
- qenv <- common_q()+ stop("x y type combination not allowed")
|
| 685 | +875 | - - | -|
| 686 | -! | -
- m_type <- if (main_type_var == "Density") "density" else "count"+ } |
|
| 687 | +876 | ||
| 688 | -! | +||
| 877 | +42x |
- plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
+ labs_base <- if (x_class == "NULL") {
|
|
| 689 | -! | +||
| 878 | +10x |
- substitute(+ list(x = substitute(ylab, list(ylab = ylab))) |
|
| 690 | -! | +||
| 879 | +42x |
- expr = ggplot(ANL, aes(dist_var_name)) ++ } else if (y_class == "NULL") {
|
|
| 691 | -! | +||
| 880 | +10x |
- geom_histogram(+ list(x = substitute(xlab, list(xlab = xlab))) |
|
| 692 | -! | +||
| 881 | +
- position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3+ } else {
|
||
| 693 | -+ | ||
| 882 | +22x |
- ),+ list( |
|
| 694 | -! | +||
| 883 | +22x |
- env = list(+ x = substitute(xlab, list(xlab = xlab)), |
|
| 695 | -! | +||
| 884 | +22x |
- m_type = as.name(m_type), bins_var = bins_var, dist_var_name = as.name(dist_var)+ y = substitute(ylab, list(ylab = ylab)) |
|
| 696 | +885 |
- )+ ) |
|
| 697 | +886 |
- )+ } |
|
| 698 | -! | +||
| 887 | +
- } else if (length(s_var) != 0 && length(g_var) == 0) {
+
|
||
| 699 | -! | +||
| 888 | +42x |
- substitute(+ dev_ggplot2_args <- teal.widgets::ggplot2_args(labs = labs_base) |
|
| 700 | -! | +||
| 889 | +
- expr = ggplot(ANL, aes(dist_var_name, col = s_var_name)) ++ |
||
| 701 | -! | +||
| 890 | +42x |
- geom_histogram(+ if (rotate_xaxis_labels) {
|
|
| 702 | +891 | ! |
- position = "identity", aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3+ dev_ggplot2_args$theme <- list(axis.text.x = quote(element_text(angle = 45, hjust = 1))) |
| 703 | +892 |
- ),- |
- |
| 704 | -! | -
- env = list(+ } |
|
| 705 | -! | +||
| 893 | +
- m_type = as.name(m_type),+ |
||
| 706 | -! | +||
| 894 | +42x |
- bins_var = bins_var,+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 707 | -! | +||
| 895 | +42x |
- dist_var_name = dist_var_name,+ user_plot = ggplot2_args, |
|
| 708 | -! | +||
| 896 | +42x |
- s_var = as.name(s_var),+ module_plot = dev_ggplot2_args |
|
| 709 | -! | +||
| 897 | +
- s_var_name = s_var_name+ ) |
||
| 710 | +898 |
- )+ |
|
| 711 | -+ | ||
| 899 | +42x |
- )+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = theme) |
|
| 712 | -! | +||
| 900 | +
- } else if (length(s_var) == 0 && length(g_var) != 0) {
+
|
||
| 713 | -! | +||
| 901 | +42x |
- req(scales_type)+ plot_call <- reduce_plot_call( |
|
| 714 | -! | +||
| 902 | +42x |
- substitute(+ plot_call, |
|
| 715 | -! | +||
| 903 | +42x |
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name)) ++ parsed_ggplot2_args$labs, |
|
| 716 | -! | +||
| 904 | +42x |
- geom_histogram(+ parsed_ggplot2_args$ggtheme, |
|
| 717 | -! | +||
| 905 | +42x |
- position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3+ parsed_ggplot2_args$theme |
|
| 718 | +906 |
- ) ++ ) |
|
| 719 | -! | +||
| 907 | +
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ |
||
| 720 | -! | +||
| 908 | +42x |
- env = list(+ if (swap_axes) {
|
|
| 721 | +909 | ! |
- m_type = as.name(m_type),+ plot_call <- reduce_plot_call(plot_call, quote(coord_flip())) |
| 722 | -! | +||
| 910 | +
- bins_var = bins_var,+ } |
||
| 723 | -! | +||
| 911 | +
- dist_var_name = dist_var_name,+ |
||
| 724 | -! | +||
| 912 | +42x |
- g_var = g_var,+ return(plot_call) |
|
| 725 | -! | +||
| 913 | +
- g_var_name = g_var_name,+ } |
||
| 726 | -! | +||
| 914 | +
- scales_raw = tolower(scales_type)+ |
||
| 727 | +915 |
- )+ |
|
| 728 | +916 |
- )+ #' Create facet call |
|
| 729 | +917 |
- } else {
+ #' |
|
| 730 | -! | +||
| 918 | +
- req(scales_type)+ #' @noRd |
||
| 731 | -! | +||
| 919 | +
- substitute(+ #' |
||
| 732 | -! | +||
| 920 | +
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name, col = s_var_name)) ++ #' @examples |
||
| 733 | -! | +||
| 921 | +
- geom_histogram(- |
- ||
| 734 | -! | +||
| 922 | +
- position = "identity",+ #' facet_ggplot_call(LETTERS[1:3]) |
||
| 735 | -! | +||
| 923 | +
- aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3+ #' facet_ggplot_call(NULL, LETTERS[23:26]) |
||
| 736 | +924 |
- ) ++ #' facet_ggplot_call(LETTERS[1:3], LETTERS[23:26]) |
|
| 737 | -! | +||
| 925 | +
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ facet_ggplot_call <- function(row_facet = character(0), |
||
| 738 | -! | +||
| 926 | +
- env = list(+ col_facet = character(0), |
||
| 739 | -! | +||
| 927 | +
- m_type = as.name(m_type),+ free_x_scales = FALSE, |
||
| 740 | -! | +||
| 928 | +
- bins_var = bins_var,+ free_y_scales = FALSE) {
|
||
| 741 | +929 | ! |
- dist_var_name = dist_var_name,+ scales <- if (free_x_scales && free_y_scales) {
|
| 742 | +930 | ! |
- g_var = g_var,+ "free" |
| 743 | +931 | ! |
- s_var = as.name(s_var),+ } else if (free_x_scales) {
|
| 744 | +932 | ! |
- g_var_name = g_var_name,+ "free_x" |
| 745 | +933 | ! |
- s_var_name = s_var_name,+ } else if (free_y_scales) {
|
| 746 | +934 | ! |
- scales_raw = tolower(scales_type)+ "free_y" |
| 747 | +935 |
- )+ } else {
|
|
| 748 | -+ | ||
| 936 | +! |
- )+ "fixed" |
|
| 749 | +937 |
- }+ } |
|
| 750 | +938 | ||
| 751 | -! | -
- if (add_dens_var) {
- |
- |
| 752 | -! | -
- plot_call <- substitute(- |
- |
| 753 | +939 | ! |
- expr = plot_call ++ if (identical(row_facet, character(0)) && identical(col_facet, character(0))) {
|
| 754 | +940 | ! |
- stat_density(+ NULL |
| 755 | +941 | ! |
- aes(y = after_stat(const * m_type2)),+ } else if (!identical(row_facet, character(0)) && !identical(col_facet, character(0))) {
|
| 756 | +942 | ! |
- geom = "line",+ call( |
| 757 | +943 | ! |
- position = "identity",+ "facet_grid", |
| 758 | +944 | ! |
- alpha = 0.5,+ rows = call_fun_dots("vars", row_facet),
|
| 759 | +945 | ! |
- size = 2,+ cols = call_fun_dots("vars", col_facet),
|
| 760 | +946 | ! |
- n = ndensity+ scales = scales |
| 761 | +947 |
- ),+ ) |
|
| 762 | +948 | ! |
- env = list(+ } else if (identical(row_facet, character(0)) && !identical(col_facet, character(0))) {
|
| 763 | +949 | ! |
- plot_call = plot_call,+ call("facet_grid", cols = call_fun_dots("vars", col_facet), scales = scales)
|
| 764 | +950 | ! |
- const = if (main_type_var == "Density") {
+ } else if (!identical(row_facet, character(0)) && identical(col_facet, character(0))) {
|
| 765 | +951 | ! |
- 1+ call("facet_grid", rows = call_fun_dots("vars", row_facet), scales = scales)
|
| 766 | +952 |
- } else {
- |
- |
| 767 | -! | -
- diff(range(qenv[["ANL"]][[dist_var]], na.rm = TRUE)) / bins_var+ } |
|
| 768 | +953 |
- },- |
- |
| 769 | -! | -
- m_type2 = if (main_type_var == "Density") as.name("density") else as.name("count"),
- |
- |
| 770 | -! | -
- ndensity = ndensity+ } |
|
| 771 | +954 |
- )+ |
|
| 772 | +955 |
- )+ coloring_ggplot_call <- function(colour, |
|
| 773 | +956 |
- }+ fill, |
|
| 774 | +957 | - - | -|
| 775 | -! | -
- if (length(t_dist) != 0 && main_type_var == "Density" && length(g_var) == 0 && length(s_var) == 0) {
- |
- |
| 776 | -! | -
- qenv <- teal.code::eval_code(- |
- |
| 777 | -! | -
- qenv,- |
- |
| 778 | -! | -
- substitute(+ size, |
|
| 779 | -! | +||
| 958 | +
- df_params <- as.data.frame(append(params, list(name = t_dist))),+ is_point = FALSE) {
|
||
| 780 | -! | +||
| 959 | +15x |
- env = list(t_dist = t_dist)+ if (!identical(colour, character(0)) && !identical(fill, character(0)) && |
|
| 781 | -+ | ||
| 960 | +15x |
- )+ is_point && !identical(size, character(0))) {
|
|
| 782 | -+ | ||
| 961 | +1x |
- )+ substitute( |
|
| 783 | -! | +||
| 962 | +1x |
- datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params))))+ expr = aes(colour = colour_name, fill = fill_name, size = size_name), |
|
| 784 | -! | +||
| 963 | +1x |
- label <- quote(tb)+ env = list(colour_name = as.name(colour), fill_name = as.name(fill), size_name = as.name(size)) |
|
| 785 | +964 | - - | -|
| 786 | -! | -
- plot_call <- substitute(+ ) |
|
| 787 | -! | +||
| 965 | +14x |
- expr = plot_call + ggpp::geom_table_npc(+ } else if (identical(colour, character(0)) && !identical(fill, character(0)) && |
|
| 788 | -! | +||
| 966 | +14x |
- data = data,+ is_point && identical(size, character(0))) {
|
|
| 789 | -! | +||
| 967 | +1x |
- aes(npcx = x, npcy = y, label = label),+ substitute(expr = aes(fill = fill_name), env = list(fill_name = as.name(fill))) |
|
| 790 | -! | +||
| 968 | +13x |
- hjust = 0, vjust = 1, size = 4+ } else if (!identical(colour, character(0)) && !identical(fill, character(0)) && |
|
| 791 | -+ | ||
| 969 | +13x |
- ),+ (!is_point || identical(size, character(0)))) {
|
|
| 792 | -! | +||
| 970 | +3x |
- env = list(plot_call = plot_call, data = datas, label = label)+ substitute( |
|
| 793 | -+ | ||
| 971 | +3x |
- )+ expr = aes(colour = colour_name, fill = fill_name), |
|
| 794 | -+ | ||
| 972 | +3x |
- }+ env = list(colour_name = as.name(colour), fill_name = as.name(fill)) |
|
| 795 | +973 |
-
+ ) |
|
| 796 | -! | +||
| 974 | +10x |
- if (length(s_var) == 0 && length(g_var) == 0 && main_type_var == "Density" &&+ } else if (!identical(colour, character(0)) && identical(fill, character(0)) && |
|
| 797 | -! | +||
| 975 | +10x |
- length(t_dist) != 0 && main_type_var == "Density") {
+ (!is_point || identical(size, character(0)))) {
|
|
| 798 | -! | +||
| 976 | +1x |
- map_dist <- stats::setNames(+ substitute(expr = aes(colour = colour_name), env = list(colour_name = as.name(colour))) |
|
| 799 | -! | +||
| 977 | +9x |
- c("dnorm", "dlnorm", "dgamma", "dunif"),
+ } else if (identical(colour, character(0)) && !identical(fill, character(0)) && |
|
| 800 | -! | +||
| 978 | +9x |
- c("normal", "lognormal", "gamma", "unif")
+ (!is_point || identical(size, character(0)))) {
|
|
| 801 | -+ | ||
| 979 | +2x |
- )+ substitute(expr = aes(fill = fill_name), env = list(fill_name = as.name(fill))) |
|
| 802 | -! | +||
| 980 | +7x |
- plot_call <- substitute(+ } else if (identical(colour, character(0)) && identical(fill, character(0)) && |
|
| 803 | -! | +||
| 981 | +7x |
- expr = plot_call + stat_function(+ is_point && !identical(size, character(0))) {
|
|
| 804 | -! | +||
| 982 | +1x |
- data = data.frame(x = range(ANL[[dist_var]]), color = mapped_dist),+ substitute(expr = aes(size = size_name), env = list(size_name = as.name(size))) |
|
| 805 | -! | +||
| 983 | +6x |
- aes(x, color = color),+ } else if (!identical(colour, character(0)) && identical(fill, character(0)) && |
|
| 806 | -! | +||
| 984 | +6x |
- fun = mapped_dist_name,+ is_point && !identical(size, character(0))) {
|
|
| 807 | -! | +||
| 985 | +1x |
- n = ndensity,+ substitute( |
|
| 808 | -! | +||
| 986 | +1x |
- size = 2,+ expr = aes(colour = colour_name, size = size_name), |
|
| 809 | -! | +||
| 987 | +1x |
- args = params+ env = list(colour_name = as.name(colour), size_name = as.name(size)) |
|
| 810 | +988 |
- ) +- |
- |
| 811 | -! | -
- scale_color_manual(values = stats::setNames("blue", mapped_dist), aesthetics = "color"),
- |
- |
| 812 | -! | -
- env = list(+ ) |
|
| 813 | -! | +||
| 989 | +5x |
- plot_call = plot_call,+ } else if (identical(colour, character(0)) && !identical(fill, character(0)) && |
|
| 814 | -! | +||
| 990 | +5x |
- dist_var = dist_var,+ is_point && !identical(size, character(0))) {
|
|
| 815 | -! | +||
| 991 | +1x |
- ndensity = ndensity,+ substitute( |
|
| 816 | -! | +||
| 992 | +1x |
- mapped_dist = unname(map_dist[t_dist]),+ expr = aes(colour = colour_name, fill = fill_name, size = size_name), |
|
| 817 | -! | +||
| 993 | +1x |
- mapped_dist_name = as.name(unname(map_dist[t_dist]))+ env = list(colour_name = as.name(fill), fill_name = as.name(fill), size_name = as.name(size)) |
|
| 818 | +994 |
- )+ ) |
|
| 819 | +995 |
- )+ } else {
|
|
| 820 | -+ | ||
| 996 | +4x |
- }+ NULL |
|
| 821 | +997 | - - | -|
| 822 | -! | -
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ } |
|
| 823 | -! | +||
| 998 | +
- user_plot = ggplot2_args[["Histogram"]],+ } |
||
| 824 | -! | +
| 1 | +
- user_default = ggplot2_args$default+ #' Distribution Module |
||
| 825 | +2 |
- )+ #' @md |
|
| 826 | +3 |
-
+ #' |
|
| 827 | -! | +||
| 4 | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ #' @details |
||
| 828 | -! | +||
| 5 | +
- all_ggplot2_args,+ #' Module to analyze and explore univariate variable distribution |
||
| 829 | -! | +||
| 6 | +
- ggtheme = ggtheme+ #' |
||
| 830 | +7 |
- )+ #' @inheritParams teal::module |
|
| 831 | +8 |
-
+ #' @inheritParams teal.widgets::standard_layout |
|
| 832 | -! | +||
| 9 | +
- teal.code::eval_code(+ #' @inheritParams shared_params |
||
| 833 | -! | +||
| 10 | +
- qenv,+ #' |
||
| 834 | -! | +||
| 11 | +
- substitute(+ #' @param dist_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 835 | -! | +||
| 12 | +
- expr = {
+ #' Variable to consider for the distribution analysis. |
||
| 836 | -! | +||
| 13 | +
- g <- plot_call+ #' @param strata_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 837 | -! | +||
| 14 | +
- print(g)+ #' Categorical variable to split the selected distribution variable on. |
||
| 838 | +15 |
- },+ #' @param group_var optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 839 | -! | +||
| 16 | +
- env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
+ #' Which data columns to use for faceting rows. |
||
| 840 | +17 |
- )+ #' @param freq optional, (`logical`) Whether to display frequency (`TRUE`) or density (`FALSE`). |
|
| 841 | +18 |
- )+ #' Defaults to density (`FALSE`). |
|
| 842 | +19 |
- }+ #' @param bins optional, (`integer(1)` or `integer(3)`) If scalar then the histogram bins will have a fixed size. |
|
| 843 | +20 |
- )+ #' If a slider should be presented to adjust the number of histogram bins dynamically then it can be a |
|
| 844 | +21 |
-
+ #' vector of length three with `c(value, min, max)`. |
|
| 845 | +22 |
- # qqplot qenv ----+ #' Defaults to `c(30L, 1L, 100L)`. |
|
| 846 | -! | +||
| 23 | +
- qq_q <- eventReactive(+ #' |
||
| 847 | -! | +||
| 24 | +
- eventExpr = {
+ #' @templateVar ggnames "Histogram", "QQplot" |
||
| 848 | -! | +||
| 25 | +
- common_q()+ #' @template ggplot2_args_multi |
||
| 849 | -! | +||
| 26 | +
- input$scales_type+ #' |
||
| 850 | -! | +||
| 27 | +
- input$qq_line+ #' |
||
| 851 | -! | +||
| 28 | +
- is.null(input$ggtheme)+ #' @export |
||
| 852 | +29 |
- },+ #' |
|
| 853 | -! | +||
| 30 | +
- valueExpr = {
+ #' @examples |
||
| 854 | -! | +||
| 31 | +
- dist_var <- merge_vars()$dist_var+ #' # Example with non-clinical data |
||
| 855 | -! | +||
| 32 | +
- s_var <- merge_vars()$s_var+ #' app <- teal::init( |
||
| 856 | -! | +||
| 33 | +
- g_var <- merge_vars()$g_var+ #' data = teal_data(dataset("iris", iris)),
|
||
| 857 | -! | +||
| 34 | +
- dist_var_name <- merge_vars()$dist_var_name+ #' modules = list( |
||
| 858 | -! | +||
| 35 | +
- s_var_name <- merge_vars()$s_var_name+ #' teal.modules.general::tm_g_distribution( |
||
| 859 | -! | +||
| 36 | +
- g_var_name <- merge_vars()$g_var_name+ #' dist_var = teal.transform::data_extract_spec( |
||
| 860 | -! | +||
| 37 | +
- t_dist <- input$t_dist+ #' dataname = "iris", |
||
| 861 | -! | +||
| 38 | +
- dist_param1 <- input$dist_param1+ #' select = teal.transform::select_spec(variable_choices("iris"), "Petal.Length")
|
||
| 862 | -! | +||
| 39 | +
- dist_param2 <- input$dist_param2+ #' ), |
||
| 863 | +40 |
-
+ #' ggplot2_args = teal.widgets::ggplot2_args( |
|
| 864 | -! | +||
| 41 | +
- scales_type <- input$scales_type+ #' labs = list(subtitle = "Plot generated by Distribution Module") |
||
| 865 | -! | +||
| 42 | +
- ggtheme <- input$ggtheme+ #' ) |
||
| 866 | +43 |
-
+ #' ) |
|
| 867 | -! | +||
| 44 | +
- teal::validate_inputs(iv_r_dist(), iv_dist)+ #' ) |
||
| 868 | +45 |
-
+ #' ) |
|
| 869 | -! | +||
| 46 | +
- qenv <- common_q()+ #' if (interactive()) {
|
||
| 870 | +47 |
-
+ #' shinyApp(app$ui, app$server) |
|
| 871 | -! | +||
| 48 | +
- plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
+ #' } |
||
| 872 | -! | +||
| 49 | +
- substitute(+ #' |
||
| 873 | -! | +||
| 50 | +
- expr = ggplot(ANL, aes_string(sample = dist_var)),+ #' # Example with clinical data |
||
| 874 | -! | +||
| 51 | +
- env = list(dist_var = dist_var)+ #' ADSL <- teal.modules.general::rADSL |
||
| 875 | +52 |
- )+ #' |
|
| 876 | -! | +||
| 53 | +
- } else if (length(s_var) != 0 && length(g_var) == 0) {
+ #' vars1 <- choices_selected(variable_choices(ADSL, c("ARM", "COUNTRY", "SEX")), selected = NULL)
|
||
| 877 | -! | +||
| 54 | +
- substitute(+ #' |
||
| 878 | -! | +||
| 55 | +
- expr = ggplot(ANL, aes_string(sample = dist_var, color = s_var)),+ #' app <- teal::init( |
||
| 879 | -! | +||
| 56 | +
- env = list(dist_var = dist_var, s_var = s_var)+ #' data = teal.data::cdisc_data( |
||
| 880 | +57 |
- )+ #' teal.data::cdisc_dataset("ADSL", ADSL),
|
|
| 881 | -! | +||
| 58 | +
- } else if (length(s_var) == 0 && length(g_var) != 0) {
+ #' code = "ADSL <- teal.modules.general::rADSL", |
||
| 882 | -! | +||
| 59 | +
- substitute(+ #' check = FALSE |
||
| 883 | -! | +||
| 60 | +
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var)) ++ #' ), |
||
| 884 | -! | +||
| 61 | +
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ #' modules = teal::modules( |
||
| 885 | -! | +||
| 62 | +
- env = list(+ #' teal.modules.general::tm_g_distribution( |
||
| 886 | -! | +||
| 63 | +
- dist_var = dist_var,+ #' dist_var = teal.transform::data_extract_spec( |
||
| 887 | -! | +||
| 64 | +
- g_var = g_var,+ #' dataname = "ADSL", |
||
| 888 | -! | +||
| 65 | +
- g_var_name = g_var_name,+ #' select = teal.transform::select_spec( |
||
| 889 | -! | +||
| 66 | +
- scales_raw = tolower(scales_type)+ #' choices = teal.transform::variable_choices(ADSL, c("AGE", "BMRKR1")),
|
||
| 890 | +67 |
- )+ #' selected = "BMRKR1", |
|
| 891 | +68 |
- )+ #' multiple = FALSE, |
|
| 892 | +69 |
- } else {
+ #' fixed = FALSE |
|
| 893 | -! | +||
| 70 | +
- substitute(+ #' ) |
||
| 894 | -! | +||
| 71 | +
- expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var, color = s_var)) ++ #' ), |
||
| 895 | -! | +||
| 72 | +
- facet_wrap(~g_var_name, ncol = 1, scales = scales_raw),+ #' strata_var = teal.transform::data_extract_spec( |
||
| 896 | -! | +||
| 73 | +
- env = list(+ #' dataname = "ADSL", |
||
| 897 | -! | +||
| 74 | +
- dist_var = dist_var,+ #' filter = teal.transform::filter_spec( |
||
| 898 | -! | +||
| 75 | +
- g_var = g_var,+ #' vars = vars1, |
||
| 899 | -! | +||
| 76 | +
- s_var = s_var,+ #' multiple = TRUE |
||
| 900 | -! | +||
| 77 | +
- g_var_name = g_var_name,+ #' ) |
||
| 901 | -! | +||
| 78 | +
- scales_raw = tolower(scales_type)+ #' ), |
||
| 902 | +79 |
- )+ #' group_var = teal.transform::data_extract_spec( |
|
| 903 | +80 |
- )+ #' dataname = "ADSL", |
|
| 904 | +81 |
- }+ #' filter = teal.transform::filter_spec( |
|
| 905 | +82 |
-
+ #' vars = vars1, |
|
| 906 | -! | +||
| 83 | +
- map_dist <- stats::setNames(+ #' multiple = TRUE |
||
| 907 | -! | +||
| 84 | +
- c("qnorm", "qlnorm", "qgamma", "qunif"),
+ #' ) |
||
| 908 | -! | +||
| 85 | +
- c("normal", "lognormal", "gamma", "unif")
+ #' ), |
||
| 909 | +86 |
- )+ #' ggplot2_args = teal.widgets::ggplot2_args( |
|
| 910 | +87 |
-
+ #' labs = list(subtitle = "Plot generated by Distribution Module") |
|
| 911 | -! | +||
| 88 | +
- plot_call <- substitute(+ #' ) |
||
| 912 | -! | +||
| 89 | +
- expr = plot_call ++ #' ) |
||
| 913 | -! | +||
| 90 | +
- stat_qq(distribution = mapped_dist, dparams = params),+ #' ) |
||
| 914 | -! | +||
| 91 | +
- env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist])))+ #' ) |
||
| 915 | +92 |
- )+ #' if (interactive()) {
|
|
| 916 | +93 |
-
+ #' shinyApp(app$ui, app$server) |
|
| 917 | -! | +||
| 94 | +
- if (length(t_dist) != 0 && length(g_var) == 0 && length(s_var) == 0) {
+ #' } |
||
| 918 | -! | +||
| 95 | +
- qenv <- teal.code::eval_code(+ tm_g_distribution <- function(label = "Distribution Module", |
||
| 919 | -! | +||
| 96 | +
- qenv,+ dist_var, |
||
| 920 | -! | +||
| 97 | +
- substitute(+ strata_var = NULL, |
||
| 921 | -! | +||
| 98 | +
- df_params <- as.data.frame(append(params, list(name = t_dist))),+ group_var = NULL, |
||
| 922 | -! | +||
| 99 | +
- env = list(t_dist = t_dist)+ freq = FALSE, |
||
| 923 | +100 |
- )+ ggtheme = c( |
|
| 924 | +101 |
- )+ "gray", "bw", "linedraw", "light", "dark", |
|
| 925 | -! | +||
| 102 | +
- datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params))))+ "minimal", "classic", "void", "test" |
||
| 926 | -! | +||
| 103 | +
- label <- quote(tb)+ ), |
||
| 927 | +104 |
-
+ ggplot2_args = teal.widgets::ggplot2_args(), |
|
| 928 | -! | +||
| 105 | +
- plot_call <- substitute(+ bins = c(30L, 1L, 100L), |
||
| 929 | -! | +||
| 106 | +
- expr = plot_call ++ plot_height = c(600, 200, 2000), |
||
| 930 | -! | +||
| 107 | +
- ggpp::geom_table_npc(+ plot_width = NULL, |
||
| 931 | -! | +||
| 108 | +
- data = data,+ pre_output = NULL, |
||
| 932 | -! | +||
| 109 | +
- aes(npcx = x, npcy = y, label = label),+ post_output = NULL) {
|
||
| 933 | +110 | ! |
- hjust = 0,+ logger::log_info("Initializing tm_g_distribution")
|
| 934 | -! | +||
| 111 | +
- vjust = 1,+ |
||
| 935 | +112 | ! |
- size = 4- |
-
| 936 | -- |
- ),+ extra_packages <- c("ggpmisc", "ggpp", "goftest", "MASS", "broom")
|
|
| 937 | +113 | ! |
- env = list(+ missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages) |
| 938 | +114 | ! |
- plot_call = plot_call,+ if (length(missing_packages) > 0L) {
|
| 939 | +115 | ! |
- data = datas,+ stop(sprintf( |
| 940 | +116 | ! |
- label = label+ "Cannot load package(s): %s.\nInstall or restart your session.", |
| 941 | -+ | ||
| 117 | +! |
- )+ toString(missing_packages) |
|
| 942 | +118 |
- )+ )) |
|
| 943 | +119 |
- }+ } |
|
| 944 | +120 | ||
| 945 | -! | -
- if (isTRUE(input$qq_line)) {
- |
- |
| 946 | +121 | ! |
- plot_call <- substitute(+ if (inherits(dist_var, "data_extract_spec")) dist_var <- list(dist_var) |
| 947 | +122 | ! |
- expr = plot_call ++ if (inherits(strata_var, "data_extract_spec")) strata_var <- list(strata_var) |
| 948 | +123 | ! |
- stat_qq_line(distribution = mapped_dist, dparams = params),+ if (inherits(group_var, "data_extract_spec")) group_var <- list(group_var) |
| 949 | +124 | ! |
- env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist])))- |
-
| 950 | -- |
- )- |
- |
| 951 | -- |
- }+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
|
| 952 | +125 | ||
| 953 | +126 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ ggtheme <- match.arg(ggtheme) |
| 954 | +127 | ! |
- user_plot = ggplot2_args[["QQplot"]],+ if (length(bins) == 1) {
|
| 955 | +128 | ! |
- user_default = ggplot2_args$default,+ checkmate::assert_numeric(bins, any.missing = FALSE, lower = 1)+ |
+
| 129 | ++ |
+ } else {
|
|
| 956 | +130 | ! |
- module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample"))+ checkmate::assert_numeric(bins, len = 3, any.missing = FALSE, lower = 1) |
| 957 | -+ | ||
| 131 | +! |
- )+ checkmate::assert_numeric(bins[1], lower = bins[2], upper = bins[3], .var.name = "bins") |
|
| 958 | +132 |
-
+ } |
|
| 959 | +133 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ checkmate::assert_string(label) |
| 960 | +134 | ! |
- all_ggplot2_args,+ checkmate::assert_list(dist_var, "data_extract_spec") |
| 961 | +135 | ! |
- ggtheme = ggtheme- |
-
| 962 | -- |
- )- |
- |
| 963 | -- |
-
+ checkmate::assert_false(dist_var[[1]]$select$multiple) |
|
| 964 | +136 | ! |
- teal.code::eval_code(+ checkmate::assert_list(strata_var, types = "data_extract_spec", null.ok = TRUE) |
| 965 | +137 | ! |
- qenv,+ checkmate::assert_list(group_var, types = "data_extract_spec", null.ok = TRUE) |
| 966 | +138 | ! |
- substitute(+ checkmate::assert_flag(freq) |
| 967 | +139 | ! |
- expr = {
+ plot_choices <- c("Histogram", "QQplot")
|
| 968 | +140 | ! |
- g <- plot_call+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
| 969 | +141 | ! |
- print(g)+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
| 970 | +142 |
- },+ |
|
| 971 | +143 | ! |
- env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
+ args <- as.list(environment()) |
| 972 | +144 |
- )+ |
|
| 973 | -+ | ||
| 145 | +! |
- )+ data_extract_list <- list( |
|
| 974 | -+ | ||
| 146 | +! |
- }+ dist_var = dist_var, |
|
| 975 | -+ | ||
| 147 | +! | +
+ strata_var = strata_var,+ |
+ |
| 148 | +! |
- )+ group_var = group_var |
|
| 976 | +149 |
-
+ ) |
|
| 977 | +150 |
- # test qenv ----- |
- |
| 978 | -! | -
- test_q <- eventReactive(+ |
|
| 979 | +151 | ! |
- ignoreNULL = FALSE,+ module( |
| 980 | +152 | ! |
- eventExpr = {
+ label = label, |
| 981 | +153 | ! |
- common_q()+ server = srv_distribution, |
| 982 | +154 | ! |
- input$dist_param1+ server_args = c( |
| 983 | +155 | ! |
- input$dist_param2+ data_extract_list, |
| 984 | +156 | ! |
- input$dist_tests+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args) |
| 985 | +157 |
- },+ ), |
|
| 986 | +158 | ! |
- valueExpr = {
+ ui = ui_distribution, |
| 987 | -+ | ||
| 159 | +! |
- # Create a private stack for this function only.+ ui_args = args, |
|
| 988 | +160 | ! |
- ANL <- common_q()[["ANL"]] # nolint+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 989 | +161 | - - | -|
| 990 | -! | -
- dist_var <- merge_vars()$dist_var+ ) |
|
| 991 | -! | +||
| 162 | +
- s_var <- merge_vars()$s_var+ } |
||
| 992 | -! | +||
| 163 | +
- g_var <- merge_vars()$g_var+ |
||
| 993 | +164 |
-
+ ui_distribution <- function(id, ...) {
|
|
| 994 | +165 | ! |
- dist_var_name <- merge_vars()$dist_var_name+ args <- list(...) |
| 995 | +166 | ! |
- s_var_name <- merge_vars()$s_var_name+ ns <- NS(id) |
| 996 | +167 | ! |
- g_var_name <- merge_vars()$g_var_name+ is_single_dataset_value <- teal.transform::is_single_dataset(args$dist_var, args$strata_var, args$group_var) |
| 997 | +168 | ||
| 998 | +169 | ! |
- dist_param1 <- input$dist_param1+ teal.widgets::standard_layout( |
| 999 | +170 | ! |
- dist_param2 <- input$dist_param2+ output = teal.widgets::white_small_well( |
| 1000 | +171 | ! |
- dist_tests <- input$dist_tests+ tabsetPanel( |
| 1001 | +172 | ! |
- t_dist <- input$t_dist- |
-
| 1002 | -- |
-
+ id = ns("tabs"),
|
|
| 1003 | +173 | ! |
- validate(need(dist_tests, "Please select a test"))- |
-
| 1004 | -- |
-
+ tabPanel("Histogram", teal.widgets::plot_with_settings_ui(id = ns("hist_plot"))),
|
|
| 1005 | +174 | ! |
- teal::validate_inputs(iv_dist)+ tabPanel("QQplot", teal.widgets::plot_with_settings_ui(id = ns("qq_plot")))
|
| 1006 | +175 |
-
+ ), |
|
| 1007 | +176 | ! |
- if (length(s_var) > 0 || length(g_var) > 0) {
+ h3("Statistics Table"),
|
| 1008 | +177 | ! |
- counts <- ANL %>%+ DT::dataTableOutput(ns("summary_table")),
|
| 1009 | +178 | ! |
- dplyr::group_by_at(dplyr::vars(dplyr::any_of(c(s_var, g_var)))) %>%+ h3("Tests"),
|
| 1010 | +179 | ! |
- dplyr::summarise(n = dplyr::n())+ DT::dataTableOutput(ns("t_stats"))
|
| 1011 | +180 |
-
+ ), |
|
| 1012 | +181 | ! |
- validate(need(all(counts$n > 5), "Please select strata*group with at least 5 observation each."))+ encoding = div( |
| 1013 | +182 |
- }+ ### Reporter |
|
| 1014 | -+ | ||
| 183 | +! |
-
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 1015 | +184 | - - | -|
| 1016 | -! | -
- if (dist_tests %in% c(+ ### |
|
| 1017 | +185 | ! |
- "t-test (two-samples, not paired)",+ tags$label("Encodings", class = "text-primary"),
|
| 1018 | +186 | ! |
- "F-test",+ teal.transform::datanames_input(args[c("dist_var", "strata_var")]),
|
| 1019 | +187 | ! |
- "Kolmogorov-Smirnov (two-samples)"- |
-
| 1020 | -- |
- )) {
+ teal.transform::data_extract_ui( |
|
| 1021 | +188 | ! |
- if (length(g_var) == 0 && length(s_var) > 0) {
+ id = ns("dist_i"),
|
| 1022 | +189 | ! |
- validate(need(+ label = "Variable", |
| 1023 | +190 | ! |
- length(unique(ANL[[s_var]])) == 2,+ data_extract_spec = args$dist_var, |
| 1024 | +191 | ! |
- "Please select stratify variable with 2 levels."+ is_single_dataset = is_single_dataset_value |
| 1025 | +192 |
- ))+ ), |
|
| 1026 | -+ | ||
| 193 | +! |
- }+ if (!is.null(args$group_var)) {
|
|
| 1027 | +194 | ! |
- if (length(g_var) > 0 && length(s_var) > 0) {
+ tagList( |
| 1028 | +195 | ! |
- validate(need(+ teal.transform::data_extract_ui( |
| 1029 | +196 | ! |
- all(stats::na.omit(as.vector(+ id = ns("group_i"),
|
| 1030 | +197 | ! |
- tapply(ANL[[s_var]], list(ANL[[g_var]]), function(x) length(unique(x))) == 2+ label = "Group by", |
| 1031 | -+ | ||
| 198 | +! |
- ))),+ data_extract_spec = args$group_var, |
|
| 1032 | +199 | ! |
- "Please select stratify variable with 2 levels, per each group."+ is_single_dataset = is_single_dataset_value |
| 1033 | +200 |
- ))+ ), |
|
| 1034 | -+ | ||
| 201 | +! |
- }+ uiOutput(ns("scales_types_ui"))
|
|
| 1035 | +202 |
- }+ ) |
|
| 1036 | +203 |
-
+ }, |
|
| 1037 | +204 | ! |
- map_dist <- stats::setNames(+ if (!is.null(args$strata_var)) {
|
| 1038 | +205 | ! |
- c("pnorm", "plnorm", "pgamma", "punif"),
+ teal.transform::data_extract_ui( |
| 1039 | +206 | ! |
- c("normal", "lognormal", "gamma", "unif")
- |
-
| 1040 | -- |
- )+ id = ns("strata_i"),
|
|
| 1041 | +207 | ! |
- sks_args <- list(+ label = "Stratify by", |
| 1042 | +208 | ! |
- test = quote(stats::ks.test),+ data_extract_spec = args$strata_var, |
| 1043 | +209 | ! |
- args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),+ is_single_dataset = is_single_dataset_value |
| 1044 | -! | +||
| 210 | +
- groups = c(g_var, s_var)+ ) |
||
| 1045 | +211 |
- )+ }, |
|
| 1046 | +212 | ! |
- ssw_args <- list(+ teal.widgets::panel_group( |
| 1047 | +213 | ! |
- test = quote(stats::shapiro.test),+ conditionalPanel( |
| 1048 | +214 | ! |
- args = bquote(list(.[[.(dist_var)]])),+ condition = paste0("input['", ns("tabs"), "'] == 'Histogram'"),
|
| 1049 | +215 | ! |
- groups = c(g_var, s_var)- |
-
| 1050 | -- |
- )+ teal.widgets::panel_item( |
|
| 1051 | +216 | ! |
- mfil_args <- list(+ "Histogram", |
| 1052 | +217 | ! |
- test = quote(stats::fligner.test),+ teal.widgets::optionalSliderInputValMinMax(ns("bins"), "Bins", args$bins, ticks = FALSE, step = 1),
|
| 1053 | +218 | ! |
- args = bquote(list(.[[.(dist_var)]], .[[.(s_var)]])),+ shinyWidgets::prettyRadioButtons( |
| 1054 | +219 | ! |
- groups = c(g_var)+ ns("main_type"),
|
| 1055 | -+ | ||
| 220 | +! |
- )+ label = "Plot Type:", |
|
| 1056 | +221 | ! |
- sad_args <- list(+ choices = c("Density", "Frequency"),
|
| 1057 | +222 | ! |
- test = quote(goftest::ad.test),+ selected = if (!args$freq) "Density" else "Frequency", |
| 1058 | +223 | ! |
- args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),+ bigger = FALSE, |
| 1059 | +224 | ! |
- groups = c(g_var, s_var)+ inline = TRUE |
| 1060 | +225 |
- )+ ), |
|
| 1061 | +226 | ! |
- scvm_args <- list(+ checkboxInput(ns("add_dens"), label = "Overlay Density", value = TRUE),
|
| 1062 | +227 | ! |
- test = quote(goftest::cvm.test),+ collapsed = FALSE |
| 1063 | -! | +||
| 228 | +
- args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)),+ )+ |
+ ||
| 229 | ++ |
+ ), |
|
| 1064 | +230 | ! |
- groups = c(g_var, s_var)+ conditionalPanel( |
| 1065 | -+ | ||
| 231 | +! |
- )+ condition = paste0("input['", ns("tabs"), "'] == 'QQplot'"),
|
|
| 1066 | +232 | ! |
- manov_args <- list(+ teal.widgets::panel_item( |
| 1067 | +233 | ! |
- test = quote(stats::aov),+ "QQ Plot", |
| 1068 | +234 | ! |
- args = bquote(list(stats::formula(.(dist_var_name) ~ .(s_var_name)), .)),+ checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE),
|
| 1069 | +235 | ! |
- groups = c(g_var)+ collapsed = FALSE |
| 1070 | +236 |
- )+ )+ |
+ |
| 237 | ++ |
+ ), |
|
| 1071 | +238 | ! |
- mt_args <- list(+ conditionalPanel( |
| 1072 | +239 | ! |
- test = quote(stats::t.test),+ condition = paste0("input['", ns("main_type"), "'] == 'Density'"),
|
| 1073 | +240 | ! |
- args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),+ teal.widgets::panel_item( |
| 1074 | +241 | ! |
- groups = c(g_var)+ "Theoretical Distribution", |
| 1075 | -+ | ||
| 242 | +! |
- )+ teal.widgets::optionalSelectInput( |
|
| 1076 | +243 | ! |
- mv_args <- list(+ ns("t_dist"),
|
| 1077 | +244 | ! |
- test = quote(stats::var.test),+ div( |
| 1078 | +245 | ! |
- args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),+ class = "teal-tooltip", |
| 1079 | +246 | ! |
- groups = c(g_var)+ tagList( |
| 1080 | -+ | ||
| 247 | +! |
- )+ "Distribution:", |
|
| 1081 | +248 | ! |
- mks_args <- list(+ icon("circle-info"),
|
| 1082 | +249 | ! |
- test = quote(stats::ks.test),+ span( |
| 1083 | +250 | ! |
- args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))),+ class = "tooltiptext", |
| 1084 | +251 | ! |
- groups = c(g_var)+ "Default parameters are optimized with MASS::fitdistr function." |
| 1085 | +252 |
- )+ ) |
|
| 1086 | +253 |
-
+ ) |
|
| 1087 | -! | +||
| 254 | +
- tests_base <- switch(dist_tests,+ ), |
||
| 1088 | +255 | ! |
- "Kolmogorov-Smirnov (one-sample)" = sks_args,+ choices = c("normal", "lognormal", "gamma", "unif"),
|
| 1089 | +256 | ! |
- "Shapiro-Wilk" = ssw_args,+ selected = NULL, |
| 1090 | +257 | ! |
- "Fligner-Killeen" = mfil_args,+ multiple = FALSE |
| 1091 | -! | +||
| 258 | +
- "one-way ANOVA" = manov_args,+ ), |
||
| 1092 | +259 | ! |
- "t-test (two-samples, not paired)" = mt_args,+ numericInput(ns("dist_param1"), label = "param1", value = NULL),
|
| 1093 | +260 | ! |
- "F-test" = mv_args,+ numericInput(ns("dist_param2"), label = "param2", value = NULL),
|
| 1094 | +261 | ! |
- "Kolmogorov-Smirnov (two-samples)" = mks_args,+ span(actionButton(ns("params_reset"), "Reset params")),
|
| 1095 | +262 | ! |
- "Anderson-Darling (one-sample)" = sad_args,+ collapsed = FALSE |
| 1096 | -! | +||
| 263 | +
- "Cramer-von Mises (one-sample)" = scvm_args+ ) |
||
| 1097 | +264 |
) |
|
| 1098 | +265 |
-
+ ), |
|
| 1099 | +266 | ! |
- env <- list(+ teal.widgets::panel_item( |
| 1100 | +267 | ! |
- t_test = t_dist,+ "Tests", |
| 1101 | +268 | ! |
- dist_var = dist_var,+ teal.widgets::optionalSelectInput( |
| 1102 | +269 | ! |
- g_var = g_var,+ ns("dist_tests"),
|
| 1103 | +270 | ! |
- s_var = s_var,+ "Tests:", |
| 1104 | +271 | ! |
- args = tests_base$args,+ choices = c( |
| 1105 | +272 | ! |
- groups = tests_base$groups,+ "Shapiro-Wilk", |
| 1106 | +273 | ! |
- test = tests_base$test,+ if (!is.null(args$strata_var)) "t-test (two-samples, not paired)", |
| 1107 | +274 | ! |
- dist_var_name = dist_var_name,+ if (!is.null(args$strata_var)) "one-way ANOVA", |
| 1108 | +275 | ! |
- g_var_name = g_var_name,+ if (!is.null(args$strata_var)) "Fligner-Killeen", |
| 1109 | +276 | ! |
- s_var_name = s_var_name+ if (!is.null(args$strata_var)) "F-test", |
| 1110 | -+ | ||
| 277 | +! |
- )+ "Kolmogorov-Smirnov (one-sample)",+ |
+ |
| 278 | +! | +
+ "Anderson-Darling (one-sample)",+ |
+ |
| 279 | +! | +
+ "Cramer-von Mises (one-sample)",+ |
+ |
| 280 | +! | +
+ if (!is.null(args$strata_var)) "Kolmogorov-Smirnov (two-samples)" |
|
| 1111 | +281 |
-
+ ), |
|
| 1112 | +282 | ! |
- qenv <- common_q()+ selected = NULL |
| 1113 | +283 |
-
+ )+ |
+ |
| 284 | ++ |
+ ), |
|
| 1114 | +285 | ! |
- if (length(s_var) == 0 && length(g_var) == 0) {
+ teal.widgets::panel_item( |
| 1115 | +286 | ! |
- qenv <- teal.code::eval_code(+ "Statistics Table", |
| 1116 | +287 | ! |
- qenv,+ sliderInput(ns("roundn"), "Round to n digits", min = 0, max = 10, value = 2)
+ |
+
| 288 | ++ |
+ ), |
|
| 1117 | +289 | ! |
- substitute(+ teal.widgets::panel_item( |
| 1118 | +290 | ! |
- expr = {
+ title = "Plot settings", |
| 1119 | +291 | ! |
- test_stats <- ANL %>%+ selectInput( |
| 1120 | +292 | ! |
- dplyr::select(dist_var) %>%+ inputId = ns("ggtheme"),
|
| 1121 | +293 | ! |
- with(., broom::glance(do.call(test, args))) %>%+ label = "Theme (by ggplot):", |
| 1122 | +294 | ! |
- dplyr::mutate_if(is.numeric, round, 3)+ choices = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
|
| 1123 | -+ | ||
| 295 | +! |
- },+ selected = args$ggtheme, |
|
| 1124 | +296 | ! |
- env = env+ multiple = FALSE |
| 1125 | +297 |
- )+ ) |
|
| 1126 | +298 |
- )+ ) |
|
| 1127 | +299 |
- } else {
+ ), |
|
| 1128 | +300 | ! |
- qenv <- teal.code::eval_code(+ forms = tagList( |
| 1129 | +301 | ! |
- qenv,+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
|
| 1130 | +302 | ! |
- substitute(+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
| 1131 | -! | +||
| 303 | +
- expr = {
+ ), |
||
| 1132 | +304 | ! |
- test_stats <- ANL %>%+ pre_output = args$pre_output, |
| 1133 | +305 | ! |
- dplyr::select(dist_var, s_var, g_var) %>%+ post_output = args$post_output |
| 1134 | -! | +||
| 306 | +
- dplyr::group_by_at(dplyr::vars(dplyr::any_of(groups))) %>%+ ) |
||
| 1135 | -! | +||
| 307 | +
- dplyr::do(tests = broom::glance(do.call(test, args))) %>%+ } |
||
| 1136 | -! | +||
| 308 | +
- tidyr::unnest(tests) %>%+ |
||
| 1137 | -! | +||
| 309 | +
- dplyr::mutate_if(is.numeric, round, 3)+ srv_distribution <- function(id, |
||
| 1138 | +310 |
- },+ data, |
|
| 1139 | -! | +||
| 311 | +
- env = env+ reporter, |
||
| 1140 | +312 |
- )+ filter_panel_api, |
|
| 1141 | +313 |
- )+ dist_var, |
|
| 1142 | +314 |
- }+ strata_var, |
|
| 1143 | -! | +||
| 315 | +
- qenv %>%+ group_var, |
||
| 1144 | +316 |
- # used to display table when running show-r-code code+ plot_height, |
|
| 1145 | -! | +||
| 317 | +
- teal.code::eval_code(quote(test_stats))+ plot_width, |
||
| 1146 | +318 |
- }+ ggplot2_args) {
|
|
| 1147 | -+ | ||
| 319 | +! |
- )+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 1148 | -+ | ||
| 320 | +! |
-
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 1149 | -+ | ||
| 321 | +! |
- # outputs ----+ checkmate::assert_class(data, "tdata") |
|
| 1150 | -+ | ||
| 322 | +! |
- ## building main qenv+ moduleServer(id, function(input, output, session) {
|
|
| 1151 | +323 | ! |
- output_q <- reactive({
+ rule_req <- function(value) {
|
| 1152 | +324 | ! |
- tab <- input$tabs+ if (isTRUE(input$dist_tests %in% c( |
| 1153 | +325 | ! |
- req(tab) # tab is NULL upon app launch, hence will crash without this statement+ "Fligner-Killeen", |
| 1154 | -+ | ||
| 326 | +! |
-
+ "t-test (two-samples, not paired)", |
|
| 1155 | +327 | ! |
- qenv_final <- common_q()+ "F-test", |
| 1156 | -+ | ||
| 328 | +! |
- # wrapped in if since could lead into validate error - we do want to continue+ "Kolmogorov-Smirnov (two-samples)", |
|
| 1157 | +329 | ! |
- test_r_qenv_out <- try(test_q(), silent = TRUE)+ "one-way ANOVA"+ |
+
| 330 | ++ |
+ ))) {
|
|
| 1158 | +331 | ! |
- if (!inherits(test_r_qenv_out, c("try-error", "error"))) {
+ if (!shinyvalidate::input_provided(value)) {
|
| 1159 | +332 | ! |
- qenv_final <- teal.code::join(qenv_final, test_q())+ "Please select stratify variable." |
| 1160 | +333 | ++ |
+ }+ |
+
| 334 |
} |
||
| 1161 | +335 |
-
+ } |
|
| 1162 | +336 | ! |
- qenv_final <- if (tab == "Histogram") {
+ rule_dupl <- function(...) {
|
| 1163 | +337 | ! |
- req(dist_q())+ if (identical(input$dist_tests, "Fligner-Killeen")) {
|
| 1164 | +338 | ! |
- teal.code::join(qenv_final, dist_q())+ strata <- selector_list()$strata_i()$select |
| 1165 | +339 | ! |
- } else if (tab == "QQplot") {
+ group <- selector_list()$group_i()$select |
| 1166 | +340 | ! |
- req(qq_q())+ if (isTRUE(strata == group)) {
|
| 1167 | +341 | ! |
- teal.code::join(qenv_final, qq_q())+ "Please select different variables for strata and group." |
| 1168 | +342 |
- }+ } |
|
| 1169 | -! | +||
| 343 | +
- qenv_final+ } |
||
| 1170 | +344 |
- })+ } |
|
| 1171 | +345 | - + + | +|
| 346 | +! | +
+ selector_list <- teal.transform::data_extract_multiple_srv(+ |
+ |
| 347 | +! | +
+ data_extract = list(+ |
+ |
| 348 | +! | +
+ dist_i = dist_var,+ |
+ |
| 349 | +! | +
+ strata_i = strata_var, |
|
| 1172 | +350 | ! |
- dist_r <- reactive(dist_q()[["g"]])+ group_i = group_var |
| 1173 | +351 |
-
+ ), |
|
| 1174 | +352 | ! |
- qq_r <- reactive(qq_q()[["g"]])+ data, |
| 1175 | -+ | ||
| 353 | +! |
-
+ select_validation_rule = list( |
|
| 1176 | +354 | ! |
- output$summary_table <- DT::renderDataTable(+ dist_i = shinyvalidate::sv_required("Please select a variable")
+ |
+
| 355 | ++ |
+ ), |
|
| 1177 | +356 | ! |
- expr = if (iv_r()$is_valid()) common_q()[["summary_table"]] else NULL,+ filter_validation_rule = list( |
| 1178 | +357 | ! |
- options = list(+ strata_i = shinyvalidate::compose_rules( |
| 1179 | +358 | ! |
- autoWidth = TRUE,+ rule_req, |
| 1180 | +359 | ! |
- columnDefs = list(list(width = "200px", targets = "_all"))+ rule_dupl |
| 1181 | +360 |
- ),+ ), |
|
| 1182 | +361 | ! |
- rownames = FALSE+ group_i = rule_dupl |
| 1183 | +362 |
- )+ ) |
|
| 1184 | +363 |
-
+ ) |
|
| 1185 | -! | +||
| 364 | +
- tests_r <- reactive({
+
|
||
| 1186 | +365 | ! |
- req(iv_r()$is_valid())+ iv_r <- reactive({
|
| 1187 | +366 | ! |
- teal::validate_inputs(iv_r_dist())+ iv <- shinyvalidate::InputValidator$new() |
| 1188 | +367 | ! |
- test_q()[["test_stats"]]+ teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = "dist_i") |
| 1189 | +368 |
}) |
|
| 1190 | +369 | ||
| 1191 | -! | -
- pws1 <- teal.widgets::plot_with_settings_srv(- |
- |
| 1192 | +370 | ! |
- id = "hist_plot",+ iv_r_dist <- reactive({
|
| 1193 | +371 | ! |
- plot_r = dist_r,+ iv <- shinyvalidate::InputValidator$new() |
| 1194 | +372 | ! |
- height = plot_height,+ teal.transform::compose_and_enable_validators( |
| 1195 | +373 | ! |
- width = plot_width,+ iv, selector_list, |
| 1196 | +374 | ! |
- brushing = FALSE+ validator_names = c("strata_i", "group_i")
|
| 1197 | +375 |
- )+ ) |
|
| 1198 | +376 |
-
+ }) |
|
| 1199 | +377 | ! |
- pws2 <- teal.widgets::plot_with_settings_srv(+ rule_dist_1 <- function(value) {
|
| 1200 | +378 | ! |
- id = "qq_plot",+ if (!is.null(input$t_dist)) {
|
| 1201 | +379 | ! |
- plot_r = qq_r,+ switch(input$t_dist, |
| 1202 | +380 | ! |
- height = plot_height,+ "normal" = if (!shinyvalidate::input_provided(value)) "mean is required", |
| 1203 | +381 | ! |
- width = plot_width,+ "lognormal" = if (!shinyvalidate::input_provided(value)) "meanlog is required", |
| 1204 | +382 | ! |
- brushing = FALSE+ "gamma" = {
|
| 1205 | -+ | ||
| 383 | +! |
- )+ if (!shinyvalidate::input_provided(value)) "shape is required" else if (value <= 0) "shape must be positive" |
|
| 1206 | +384 |
-
+ }, |
|
| 1207 | +385 | ! |
- output$t_stats <- DT::renderDataTable(+ "unif" = NULL |
| 1208 | -! | +||
| 386 | +
- expr = tests_r(),+ ) |
||
| 1209 | -! | +||
| 387 | +
- options = list(scrollX = TRUE),+ }+ |
+ ||
| 388 | ++ |
+ } |
|
| 1210 | +389 | ! |
- rownames = FALSE+ rule_dist_2 <- function(value) {
|
| 1211 | -+ | ||
| 390 | +! |
- )+ if (!is.null(input$t_dist)) {
|
|
| 1212 | -+ | ||
| 391 | +! |
-
+ switch(input$t_dist, |
|
| 1213 | +392 | ! |
- teal.widgets::verbatim_popup_srv(+ "normal" = {
|
| 1214 | +393 | ! |
- id = "warning",+ if (!shinyvalidate::input_provided(value)) {
|
| 1215 | +394 | ! |
- verbatim_content = reactive(teal.code::get_warnings(output_q())),+ "sd is required" |
| 1216 | +395 | ! |
- title = "Warning",+ } else if (value < 0) {
|
| 1217 | +396 | ! |
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ "sd must be non-negative" |
| 1218 | +397 |
- )+ } |
|
| 1219 | +398 |
-
+ }, |
|
| 1220 | +399 | ! |
- teal.widgets::verbatim_popup_srv(+ "lognormal" = {
|
| 1221 | +400 | ! |
- id = "rcode",+ if (!shinyvalidate::input_provided(value)) {
|
| 1222 | +401 | ! |
- verbatim_content = reactive(teal.code::get_code(output_q())),+ "sdlog is required" |
| 1223 | +402 | ! |
- title = "R Code for distribution"+ } else if (value < 0) {
|
| 1224 | -+ | ||
| 403 | +! |
- )+ "sdlog must be non-negative" |
|
| 1225 | +404 |
-
+ } |
|
| 1226 | +405 |
- ### REPORTER- |
- |
| 1227 | -! | -
- if (with_reporter) {
- |
- |
| 1228 | -! | -
- card_fun <- function(comment) {
- |
- |
| 1229 | -! | -
- card <- teal::TealReportCard$new()+ }, |
|
| 1230 | +406 | ! |
- card$set_name("Distribution Plot")
+ "gamma" = {
|
| 1231 | +407 | ! |
- card$append_text("Distribution Plot", "header2")
+ if (!shinyvalidate::input_provided(value)) {
|
| 1232 | +408 | ! |
- if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ "rate is required" |
| 1233 | +409 | ! |
- card$append_text("Plot", "header3")
+ } else if (value <= 0) {
|
| 1234 | +410 | ! |
- if (input$tabs == "Histogram") {
+ "rate must be positive" |
| 1235 | -! | +||
| 411 | +
- card$append_plot(dist_r(), dim = pws1$dim())+ } |
||
| 1236 | -! | +||
| 412 | +
- } else if (input$tabs == "QQplot") {
+ }, |
||
| 1237 | +413 | ! |
- card$append_plot(qq_r(), dim = pws2$dim())+ "unif" = NULL |
| 1238 | +414 |
- }+ ) |
|
| 1239 | -! | +||
| 415 | +
- card$append_text("Statistics table", "header3")
+ } |
||
| 1240 | +416 |
-
+ } |
|
| 1241 | +417 | ! |
- card$append_table(common_q()[["summary_table"]])+ rule_dist <- function(value) {
|
| 1242 | +418 | ! |
- tests_error <- tryCatch(expr = tests_r(), error = function(e) "error")+ if (isTRUE(input$tabs == "QQplot" || |
| 1243 | +419 | ! |
- if (inherits(tests_error, "data.frame")) {
+ input$dist_tests %in% c( |
| 1244 | +420 | ! |
- card$append_text("Tests table", "header3")
+ "Kolmogorov-Smirnov (one-sample)", |
| 1245 | +421 | ! |
- card$append_table(tests_r())+ "Anderson-Darling (one-sample)", |
| 1246 | -+ | ||
| 422 | +! |
- }+ "Cramer-von Mises (one-sample)" |
|
| 1247 | +423 | - - | -|
| 1248 | -! | -
- if (!comment == "") {
+ ))) {
|
|
| 1249 | +424 | ! |
- card$append_text("Comment", "header3")
+ if (!shinyvalidate::input_provided(value)) {
|
| 1250 | +425 | ! |
- card$append_text(comment)+ "Please select the theoretical distribution." |
| 1251 | +426 |
} |
|
| 1252 | -! | -
- card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n"))- |
- |
| 1253 | -! | +||
| 427 | +
- card+ } |
||
| 1254 | +428 |
- }+ } |
|
| 1255 | +429 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ iv_dist <- shinyvalidate::InputValidator$new() |
| 1256 | -+ | ||
| 430 | +! |
- }+ iv_dist$add_rule("t_dist", rule_dist)
|
|
| 1257 | -+ | ||
| 431 | +! |
- ###+ iv_dist$add_rule("dist_param1", rule_dist_1)
|
|
| 1258 | -+ | ||
| 432 | +! |
- })+ iv_dist$add_rule("dist_param2", rule_dist_2)
|
|
| 1259 | -+ | ||
| 433 | +! |
- }+ iv_dist$enable() |
| 1 | +434 |
- #' Create a simple scatterplot+ |
|
| 2 | -+ | ||
| 435 | +! |
- #'+ anl_merged_input <- teal.transform::merge_expression_srv( |
|
| 3 | -+ | ||
| 436 | +! |
- #' Create a plot with the \code{\link{ggplot2}[geom_point]} function
+ selector_list = selector_list, |
|
| 4 | -+ | ||
| 437 | +! |
- #' @md+ datasets = data, |
|
| 5 | -+ | ||
| 438 | +! |
- #'+ join_keys = get_join_keys(data) |
|
| 6 | +439 |
- #' @inheritParams teal::module+ ) |
|
| 7 | +440 |
- #' @inheritParams shared_params+ |
|
| 8 | -+ | ||
| 441 | +! |
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) Variable+ anl_merged_q <- reactive({
|
|
| 9 | -+ | ||
| 442 | +! |
- #' names selected to plot along the x-axis by default.+ req(anl_merged_input()) |
|
| 10 | -+ | ||
| 443 | +! |
- #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) Variable+ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% |
|
| 11 | -+ | ||
| 444 | +! |
- #' names selected to plot along the y-axis by default.+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
|
| 12 | +445 |
- #' @param color_by optional (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ }) |
|
| 13 | +446 |
- #' Defines the color encoding. If `NULL` then no color encoding option will be displayed.+ |
|
| 14 | -+ | ||
| 447 | +! |
- #' @param size_by optional (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ merged <- list( |
|
| 15 | -+ | ||
| 448 | +! |
- #' Defines the point size encoding. If `NULL` then no size encoding option will be displayed.+ anl_input_r = anl_merged_input, |
|
| 16 | -+ | ||
| 449 | +! |
- #' @param row_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ anl_q_r = anl_merged_q |
|
| 17 | +450 |
- #' Which data columns to use for faceting rows.+ ) |
|
| 18 | +451 |
- #' @param col_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
|
| 19 | -+ | ||
| 452 | +! |
- #' Which data to use for faceting columns.+ output$scales_types_ui <- renderUI({
|
|
| 20 | -+ | ||
| 453 | +! |
- #' @param alpha optional, (`numeric`) If scalar then the plot points will have a fixed opacity. If a+ if ("group_i" %in% names(selector_list()) && length(selector_list()$group_i()$filters[[1]]$selected) > 0) {
|
|
| 21 | -+ | ||
| 454 | +! |
- #' slider should be presented to adjust the plot point opacity dynamically then it can be a vector of+ shinyWidgets::prettyRadioButtons( |
|
| 22 | -+ | ||
| 455 | +! |
- #' length three with `c(value, min, max)`.+ session$ns("scales_type"),
|
|
| 23 | -+ | ||
| 456 | +! |
- #' @param size optional, (`numeric`) If scalar then the plot point sizes will have a fixed size+ label = "Scales:", |
|
| 24 | -+ | ||
| 457 | +! |
- #' If a slider should be presented to adjust the plot point sizes dynamically then it can be a+ choices = c("Fixed", "Free"),
|
|
| 25 | -+ | ||
| 458 | +! |
- #' vector of length three with `c(value, min, max)`.+ selected = "Fixed", |
|
| 26 | -+ | ||
| 459 | +! |
- #' @param shape optional, (`character`) A character vector with the English names of the+ bigger = FALSE, |
|
| 27 | -+ | ||
| 460 | +! |
- #' shape, e.g. `c("triangle", "square", "circle")`. It defaults to `shape_names`. This is a complete list from
+ inline = TRUE |
|
| 28 | +461 |
- #' `vignette("ggplot2-specs", package="ggplot2")`.
+ ) |
|
| 29 | +462 |
- #' @param max_deg optional, (`integer`) The maximum degree for the polynomial trend line. Must not be less than 1.+ } |
|
| 30 | +463 |
- #' @param table_dec optional, (`integer`) Number of decimal places used to round numeric values in the table.+ }) |
|
| 31 | +464 |
- #'+ |
|
| 32 | -+ | ||
| 465 | +! |
- #'+ observeEvent( |
|
| 33 | -+ | ||
| 466 | +! |
- #' @note For more examples, please see the vignette "Using scatterplot" via+ eventExpr = list( |
|
| 34 | -+ | ||
| 467 | +! |
- #' `vignette("using-scatterplot", package = "teal.modules.general")`.
+ input$t_dist, |
|
| 35 | -+ | ||
| 468 | +! |
- #'+ input$params_reset, |
|
| 36 | -+ | ||
| 469 | +! |
- #' @export+ selector_list()$dist_i()$select |
|
| 37 | +470 |
- #' @examples+ ), |
|
| 38 | -+ | ||
| 471 | +! |
- #' # Scatterplot of variables from ADSL dataset+ handlerExpr = {
|
|
| 39 | -+ | ||
| 472 | +! |
- #' library(nestcolor)+ if (length(input$t_dist) != 0) {
|
|
| 40 | -+ | ||
| 473 | +! |
- #'+ dist_var2 <- as.vector(merged$anl_input_r()$columns_source$dist_i) |
|
| 41 | +474 |
- #' ADSL <- teal.modules.general::rADSL+ |
|
| 42 | -+ | ||
| 475 | +! |
- #'+ get_dist_params <- function(x, dist) {
|
|
| 43 | -+ | ||
| 476 | +! |
- #' app <- teal::init(+ if (dist == "unif") {
|
|
| 44 | -+ | ||
| 477 | +! |
- #' data = teal.data::cdisc_data(+ res <- as.list(range(x)) |
|
| 45 | -+ | ||
| 478 | +! |
- #' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
+ names(res) <- c("min", "max")
|
|
| 46 | -+ | ||
| 479 | +! |
- #' check = TRUE+ return(res) |
|
| 47 | +480 |
- #' ),+ } |
|
| 48 | -+ | ||
| 481 | +! |
- #' modules = teal::modules(+ tryCatch( |
|
| 49 | -+ | ||
| 482 | +! |
- #' teal.modules.general::tm_g_scatterplot(+ as.list(MASS::fitdistr(x, densfun = dist)$estimate), |
|
| 50 | -+ | ||
| 483 | +! |
- #' label = "Scatterplot Choices",+ error = function(e) list(param1 = NA, param2 = NA) |
|
| 51 | +484 |
- #' x = teal.transform::data_extract_spec(+ ) |
|
| 52 | +485 |
- #' dataname = "ADSL",+ } |
|
| 53 | +486 |
- #' select = teal.transform::select_spec(+ |
|
| 54 | -+ | ||
| 487 | +! |
- #' label = "Select variable:",+ ANL <- merged$anl_q_r()[[as.character(dist_var[[1]]$dataname)]] # nolint |
|
| 55 | -+ | ||
| 488 | +! |
- #' choices = teal.transform::variable_choices(+ params <- get_dist_params(as.numeric(stats::na.omit(ANL[[dist_var2]])), input$t_dist) |
|
| 56 | -+ | ||
| 489 | +! |
- #' ADSL,+ params_vec <- round(unname(unlist(params)), 2) |
|
| 57 | -+ | ||
| 490 | +! |
- #' c("AGE", "BMRKR1", "BMRKR2")
+ params_names <- names(params) |
|
| 58 | +491 |
- #' ),+ |
|
| 59 | -+ | ||
| 492 | +! |
- #' selected = "AGE",+ updateNumericInput(session, "dist_param1", label = params_names[1], value = params_vec[1]) |
|
| 60 | -+ | ||
| 493 | +! |
- #' multiple = FALSE,+ updateNumericInput(session, "dist_param2", label = params_names[2], value = params_vec[2]) |
|
| 61 | +494 |
- #' fixed = FALSE+ } else {
|
|
| 62 | -+ | ||
| 495 | +! |
- #' )+ updateNumericInput(session, "dist_param1", label = "param1", value = NA) |
|
| 63 | -+ | ||
| 496 | +! |
- #' ),+ updateNumericInput(session, "dist_param2", label = "param2", value = NA) |
|
| 64 | +497 |
- #' y = teal.transform::data_extract_spec(+ } |
|
| 65 | +498 |
- #' dataname = "ADSL",+ }, |
|
| 66 | -+ | ||
| 499 | +! |
- #' select = teal.transform::select_spec(+ ignoreInit = TRUE |
|
| 67 | +500 |
- #' label = "Select variable:",+ ) |
|
| 68 | +501 |
- #' choices = teal.transform::variable_choices(+ |
|
| 69 | -+ | ||
| 502 | +! |
- #' ADSL,+ merge_vars <- reactive({
|
|
| 70 | -+ | ||
| 503 | +! |
- #' c("AGE", "BMRKR1", "BMRKR2")
+ teal::validate_inputs(iv_r()) |
|
| 71 | +504 |
- #' ),+ |
|
| 72 | -+ | ||
| 505 | +! |
- #' selected = "BMRKR1",+ dist_var <- as.vector(merged$anl_input_r()$columns_source$dist_i) |
|
| 73 | -+ | ||
| 506 | +! |
- #' multiple = FALSE,+ s_var <- as.vector(merged$anl_input_r()$columns_source$strata_i) |
|
| 74 | -+ | ||
| 507 | +! |
- #' fixed = FALSE+ g_var <- as.vector(merged$anl_input_r()$columns_source$group_i) |
|
| 75 | +508 |
- #' )+ |
|
| 76 | -+ | ||
| 509 | +! |
- #' ),+ dist_var_name <- if (length(dist_var)) as.name(dist_var) else NULL |
|
| 77 | -+ | ||
| 510 | +! |
- #' color_by = teal.transform::data_extract_spec(+ s_var_name <- if (length(s_var)) as.name(s_var) else NULL |
|
| 78 | -+ | ||
| 511 | +! |
- #' dataname = "ADSL",+ g_var_name <- if (length(g_var)) as.name(g_var) else NULL |
|
| 79 | +512 |
- #' select = teal.transform::select_spec(+ |
|
| 80 | -+ | ||
| 513 | +! |
- #' label = "Select variable:",+ list( |
|
| 81 | -+ | ||
| 514 | +! |
- #' choices = teal.transform::variable_choices(+ dist_var = dist_var, |
|
| 82 | -+ | ||
| 515 | +! |
- #' ADSL,+ s_var = s_var, |
|
| 83 | -+ | ||
| 516 | +! |
- #' c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1")
+ g_var = g_var, |
|
| 84 | -+ | ||
| 517 | +! |
- #' ),+ dist_var_name = dist_var_name, |
|
| 85 | -+ | ||
| 518 | +! |
- #' selected = NULL,+ s_var_name = s_var_name, |
|
| 86 | -+ | ||
| 519 | +! |
- #' multiple = FALSE,+ g_var_name = g_var_name |
|
| 87 | +520 |
- #' fixed = FALSE+ ) |
|
| 88 | +521 |
- #' )+ }) |
|
| 89 | +522 |
- #' ),+ |
|
| 90 | +523 |
- #' size_by = teal.transform::data_extract_spec(+ # common qenv |
|
| 91 | -+ | ||
| 524 | +! |
- #' dataname = "ADSL",+ common_q <- reactive({
|
|
| 92 | +525 |
- #' select = teal.transform::select_spec(+ # Create a private stack for this function only. |
|
| 93 | +526 |
- #' label = "Select variable:",+ |
|
| 94 | -+ | ||
| 527 | +! |
- #' choices = teal.transform::variable_choices(+ ANL <- merged$anl_q_r()[["ANL"]] # nolint |
|
| 95 | -+ | ||
| 528 | +! |
- #' ADSL,+ dist_var <- merge_vars()$dist_var |
|
| 96 | -+ | ||
| 529 | +! |
- #' c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1")
+ s_var <- merge_vars()$s_var |
|
| 97 | -+ | ||
| 530 | +! |
- #' ),+ g_var <- merge_vars()$g_var |
|
| 98 | +531 |
- #' selected = "AGE",+ |
|
| 99 | -+ | ||
| 532 | +! |
- #' multiple = FALSE,+ dist_var_name <- merge_vars()$dist_var_name |
|
| 100 | -+ | ||
| 533 | +! |
- #' fixed = FALSE+ s_var_name <- merge_vars()$s_var_name |
|
| 101 | -+ | ||
| 534 | +! |
- #' )+ g_var_name <- merge_vars()$g_var_name |
|
| 102 | +535 |
- #' ),+ |
|
| 103 | -+ | ||
| 536 | +! |
- #' row_facet = teal.transform::data_extract_spec(+ roundn <- input$roundn |
|
| 104 | -+ | ||
| 537 | +! |
- #' dataname = "ADSL",+ dist_param1 <- input$dist_param1 |
|
| 105 | -+ | ||
| 538 | +! |
- #' select = teal.transform::select_spec(+ dist_param2 <- input$dist_param2 |
|
| 106 | +539 |
- #' label = "Select variable:",+ # isolated as dist_param1/dist_param2 already triggered the reactivity |
|
| 107 | -+ | ||
| 540 | +! |
- #' choices = teal.transform::variable_choices(+ t_dist <- isolate(input$t_dist) |
|
| 108 | +541 |
- #' ADSL,+ |
|
| 109 | -+ | ||
| 542 | +! |
- #' c("BMRKR2", "RACE", "REGION1")
+ qenv <- merged$anl_q_r() |
|
| 110 | +543 |
- #' ),+ |
|
| 111 | -+ | ||
| 544 | +! |
- #' selected = NULL,+ if (length(g_var) > 0) {
|
|
| 112 | -+ | ||
| 545 | +! |
- #' multiple = FALSE,+ validate( |
|
| 113 | -+ | ||
| 546 | +! |
- #' fixed = FALSE+ need( |
|
| 114 | -+ | ||
| 547 | +! |
- #' )+ inherits(ANL[[g_var]], c("integer", "factor", "character")),
|
|
| 115 | -+ | ||
| 548 | +! |
- #' ),+ "Group by variable must be `factor`, `character`, or `integer`" |
|
| 116 | +549 |
- #' col_facet = teal.transform::data_extract_spec(+ ) |
|
| 117 | +550 |
- #' dataname = "ADSL",+ ) |
|
| 118 | -+ | ||
| 551 | +! |
- #' select = teal.transform::select_spec(+ qenv <- teal.code::eval_code( |
|
| 119 | -+ | ||
| 552 | +! |
- #' label = "Select variable:",+ qenv, |
|
| 120 | -+ | ||
| 553 | +! |
- #' choices = teal.transform::variable_choices(+ substitute( |
|
| 121 | -+ | ||
| 554 | +! |
- #' ADSL,+ expr = ANL[[g_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[g_var]]), "NA"), # nolint |
|
| 122 | -+ | ||
| 555 | +! |
- #' c("BMRKR2", "RACE", "REGION1")
+ env = list(g_var = g_var) |
|
| 123 | +556 |
- #' ),+ ) |
|
| 124 | +557 |
- #' selected = NULL,+ ) |
|
| 125 | +558 |
- #' multiple = FALSE,+ } |
|
| 126 | +559 |
- #' fixed = FALSE+ |
|
| 127 | -+ | ||
| 560 | +! |
- #' )+ if (length(s_var) > 0) {
|
|
| 128 | -+ | ||
| 561 | +! |
- #' ),+ validate( |
|
| 129 | -+ | ||
| 562 | +! |
- #' ggplot2_args = teal.widgets::ggplot2_args(+ need( |
|
| 130 | -+ | ||
| 563 | +! |
- #' labs = list(subtitle = "Plot generated by Scatterplot Module")+ inherits(ANL[[s_var]], c("integer", "factor", "character")),
|
|
| 131 | -+ | ||
| 564 | +! |
- #' )+ "Stratify by variable must be `factor`, `character`, or `integer`" |
|
| 132 | +565 |
- #' )+ ) |
|
| 133 | +566 |
- #' )+ ) |
|
| 134 | -+ | ||
| 567 | +! |
- #' )+ qenv <- teal.code::eval_code( |
|
| 135 | -+ | ||
| 568 | +! |
- #' if (interactive()) {
+ qenv, |
|
| 136 | -+ | ||
| 569 | +! |
- #' shinyApp(app$ui, app$server)+ substitute( |
|
| 137 | -+ | ||
| 570 | +! |
- #' }+ expr = ANL[[s_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[s_var]]), "NA"), # nolint |
|
| 138 | -+ | ||
| 571 | +! |
- tm_g_scatterplot <- function(label = "Scatterplot",+ env = list(s_var = s_var) |
|
| 139 | +572 |
- x,+ ) |
|
| 140 | +573 |
- y,+ ) |
|
| 141 | +574 |
- color_by = NULL,+ } |
|
| 142 | +575 |
- size_by = NULL,+ |
|
| 143 | -+ | ||
| 576 | +! |
- row_facet = NULL,+ validate(need(is.numeric(ANL[[dist_var]]), "Please select a numeric variable.")) |
|
| 144 | -+ | ||
| 577 | +! |
- col_facet = NULL,+ teal::validate_has_data(ANL, 1, complete = TRUE) |
|
| 145 | +578 |
- plot_height = c(600, 200, 2000),+ |
|
| 146 | -+ | ||
| 579 | +! |
- plot_width = NULL,+ if (length(t_dist) != 0) {
|
|
| 147 | -+ | ||
| 580 | +! |
- alpha = c(1, 0, 1),+ map_distr_nams <- list( |
|
| 148 | -+ | ||
| 581 | +! |
- shape = shape_names,+ normal = c("mean", "sd"),
|
|
| 149 | -+ | ||
| 582 | +! |
- size = c(5, 1, 15),+ lognormal = c("meanlog", "sdlog"),
|
|
| 150 | -+ | ||
| 583 | +! |
- max_deg = 5L,+ gamma = c("shape", "rate"),
|
|
| 151 | -+ | ||
| 584 | +! |
- rotate_xaxis_labels = FALSE,+ unif = c("min", "max")
|
|
| 152 | +585 |
- ggtheme = c(+ ) |
|
| 153 | -+ | ||
| 586 | +! |
- "gray", "bw", "linedraw", "light", "dark",+ params_names_raw <- map_distr_nams[[t_dist]] |
|
| 154 | +587 |
- "minimal", "classic", "void", "test"+ |
|
| 155 | -+ | ||
| 588 | +! |
- ),+ qenv <- teal.code::eval_code( |
|
| 156 | -+ | ||
| 589 | +! |
- pre_output = NULL,+ qenv, |
|
| 157 | -+ | ||
| 590 | +! |
- post_output = NULL,+ substitute( |
|
| 158 | -+ | ||
| 591 | +! |
- table_dec = 4,+ expr = {
|
|
| 159 | -+ | ||
| 592 | +! |
- ggplot2_args = teal.widgets::ggplot2_args()) {
+ params <- as.list(c(dist_param1, dist_param2)) |
|
| 160 | +593 | ! |
- logger::log_info("Initializing tm_g_scatterplot")
+ names(params) <- params_names_raw |
| 161 | +594 |
-
+ }, |
|
| 162 | +595 | ! |
- extra_packages <- c("ggpmisc", "ggExtra", "colourpicker")
+ env = list( |
| 163 | +596 | ! |
- missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages)+ dist_param1 = dist_param1, |
| 164 | +597 | ! |
- if (length(missing_packages) > 0L) {
+ dist_param2 = dist_param2, |
| 165 | +598 | ! |
- stop(sprintf(+ params_names_raw = params_names_raw |
| 166 | -! | +||
| 599 | +
- "Cannot load package(s): %s.\nInstall or restart your session.",+ ) |
||
| 167 | -! | +||
| 600 | +
- toString(missing_packages)+ ) |
||
| 168 | +601 |
- ))+ ) |
|
| 169 | +602 |
- }+ } |
|
| 170 | +603 | ||
| 171 | +604 | ! |
- if (inherits(x, "data_extract_spec")) x <- list(x)+ if (length(s_var) == 0 && length(g_var) == 0) {
|
| 172 | +605 | ! |
- if (inherits(y, "data_extract_spec")) y <- list(y)+ qenv <- teal.code::eval_code( |
| 173 | +606 | ! |
- if (inherits(color_by, "data_extract_spec")) color_by <- list(color_by)+ qenv, |
| 174 | +607 | ! |
- if (inherits(size_by, "data_extract_spec")) size_by <- list(size_by)+ substitute( |
| 175 | +608 | ! |
- if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)+ expr = {
|
| 176 | +609 | ! |
- if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)+ summary_table <- ANL %>% |
| 177 | +610 | ! |
- if (is.double(max_deg)) max_deg <- as.integer(max_deg)- |
-
| 178 | -- |
-
+ dplyr::summarise( |
|
| 179 | +611 | ! |
- ggtheme <- match.arg(ggtheme)+ min = round(min(dist_var_name, na.rm = TRUE), roundn), |
| 180 | +612 | ! |
- checkmate::assert_string(label)+ median = round(stats::median(dist_var_name, na.rm = TRUE), roundn), |
| 181 | +613 | ! |
- checkmate::assert_list(x, types = "data_extract_spec")+ mean = round(mean(dist_var_name, na.rm = TRUE), roundn), |
| 182 | +614 | ! |
- checkmate::assert_list(y, types = "data_extract_spec")+ max = round(max(dist_var_name, na.rm = TRUE), roundn), |
| 183 | +615 | ! |
- checkmate::assert_list(color_by, types = "data_extract_spec", null.ok = TRUE)+ sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn), |
| 184 | +616 | ! |
- checkmate::assert_list(size_by, types = "data_extract_spec", null.ok = TRUE)+ count = dplyr::n() |
| 185 | -! | +||
| 617 | +
- checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)+ ) |
||
| 186 | -! | +||
| 618 | +
- checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)+ }, |
||
| 187 | +619 | ! |
- checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)+ env = list( |
| 188 | +620 | ! |
- if (!all(vapply(row_facet, function(x) !x$select$multiple, logical(1)))) {
+ dist_var_name = as.name(dist_var), |
| 189 | +621 | ! |
- stop("'row_facet' should not allow multiple selection")
+ roundn = roundn |
| 190 | +622 |
- }+ ) |
|
| 191 | -! | +||
| 623 | +
- if (!all(vapply(col_facet, function(x) !x$select$multiple, logical(1)))) {
+ ) |
||
| 192 | -! | +||
| 624 | +
- stop("'col_facet' should not allow multiple selection")
+ ) |
||
| 193 | +625 |
- }+ } else {
|
|
| 194 | +626 | ! |
- checkmate::assert_character(shape)+ qenv <- teal.code::eval_code( |
| 195 | -+ | ||
| 627 | +! |
-
+ qenv, |
|
| 196 | +628 | ! |
- checkmate::assert_int(max_deg, lower = 1L)+ substitute( |
| 197 | +629 | ! |
- checkmate::assert_scalar(table_dec)+ expr = {
|
| 198 | +630 | ! |
- checkmate::assert_flag(rotate_xaxis_labels)+ strata_vars <- strata_vars_raw |
| 199 | +631 | ! |
- if (length(alpha) == 1) {
+ summary_table <- ANL %>% |
| 200 | +632 | ! |
- checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE)+ dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>% |
| 201 | -+ | ||
| 633 | +! |
- } else {
+ dplyr::summarise( |
|
| 202 | +634 | ! |
- checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE)+ min = round(min(dist_var_name, na.rm = TRUE), roundn), |
| 203 | +635 | ! |
- checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")+ median = round(stats::median(dist_var_name, na.rm = TRUE), roundn), |
| 204 | -+ | ||
| 636 | +! |
- }+ mean = round(mean(dist_var_name, na.rm = TRUE), roundn), |
|
| 205 | -+ | ||
| 637 | +! |
-
+ max = round(max(dist_var_name, na.rm = TRUE), roundn), |
|
| 206 | +638 | ! |
- if (length(size) == 1) {
+ sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn), |
| 207 | +639 | ! |
- checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE)+ count = dplyr::n() |
| 208 | +640 |
- } else {
- |
- |
| 209 | -! | -
- checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE)+ ) |
|
| 210 | +641 | ! |
- checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")- |
-
| 211 | -- |
- }+ summary_table # used to display table when running show-r-code code |
|
| 212 | +642 |
-
+ }, |
|
| 213 | +643 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ env = list( |
| 214 | +644 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ dist_var_name = dist_var_name, |
| 215 | +645 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ strata_vars_raw = c(g_var, s_var), |
| 216 | +646 | ! |
- checkmate::assert_numeric(+ roundn = roundn |
| 217 | -! | +||
| 647 | +
- plot_width[1],+ ) |
||
| 218 | -! | +||
| 648 | +
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ ) |
||
| 219 | +649 |
- )+ ) |
|
| 220 | +650 |
-
+ } |
|
| 221 | -! | +||
| 651 | +
- checkmate::assert_class(ggplot2_args, "ggplot2_args")+ }) |
||
| 222 | +652 | ||
| 223 | -! | -
- args <- as.list(environment())- |
- |
| 224 | +653 |
-
+ # distplot qenv ---- |
|
| 225 | +654 | ! |
- data_extract_list <- list(+ dist_q <- eventReactive( |
| 226 | +655 | ! |
- x = x,+ eventExpr = {
|
| 227 | +656 | ! |
- y = y,+ common_q() |
| 228 | +657 | ! |
- color_by = color_by,+ input$scales_type |
| 229 | +658 | ! |
- size_by = size_by,+ input$main_type |
| 230 | +659 | ! |
- row_facet = row_facet,+ input$bins |
| 231 | +660 | ! |
- col_facet = col_facet+ input$add_dens |
| 232 | -+ | ||
| 661 | +! |
- )+ is.null(input$ggtheme) |
|
| 233 | +662 |
-
+ }, |
|
| 234 | +663 | ! |
- module(+ valueExpr = {
|
| 235 | +664 | ! |
- label = label,+ dist_var <- merge_vars()$dist_var |
| 236 | +665 | ! |
- server = srv_g_scatterplot,+ s_var <- merge_vars()$s_var |
| 237 | +666 | ! |
- ui = ui_g_scatterplot,+ g_var <- merge_vars()$g_var |
| 238 | +667 | ! |
- ui_args = args,+ dist_var_name <- merge_vars()$dist_var_name |
| 239 | +668 | ! |
- server_args = c(+ s_var_name <- merge_vars()$s_var_name |
| 240 | +669 | ! |
- data_extract_list,+ g_var_name <- merge_vars()$g_var_name |
| 241 | +670 | ! |
- list(plot_height = plot_height, plot_width = plot_width, table_dec = table_dec, ggplot2_args = ggplot2_args)+ t_dist <- input$t_dist |
| 242 | -+ | ||
| 671 | +! |
- ),+ dist_param1 <- input$dist_param1 |
|
| 243 | +672 | ! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ dist_param2 <- input$dist_param2 |
| 244 | +673 |
- )+ |
|
| 245 | -+ | ||
| 674 | +! |
- }+ scales_type <- input$scales_type |
|
| 246 | +675 | ||
| 247 | -+ | ||
| 676 | +! |
- ui_g_scatterplot <- function(id, ...) {
+ ndensity <- 512 |
|
| 248 | +677 | ! |
- args <- list(...)+ main_type_var <- input$main_type |
| 249 | +678 | ! |
- ns <- NS(id)+ bins_var <- input$bins |
| 250 | +679 | ! |
- is_single_dataset_value <- teal.transform::is_single_dataset(+ add_dens_var <- input$add_dens |
| 251 | +680 | ! |
- args$x, args$y, args$color_by, args$size_by, args$row_facet, args$col_facet+ ggtheme <- input$ggtheme |
| 252 | +681 |
- )+ + |
+ |
| 682 | +! | +
+ teal::validate_inputs(iv_dist) |
|
| 253 | +683 | ||
| 254 | +684 | ! |
- shiny::tagList(+ qenv <- common_q() |
| 255 | -! | +||
| 685 | +
- include_css_files("custom"),
+
|
||
| 256 | +686 | ! |
- teal.widgets::standard_layout(+ m_type <- if (main_type_var == "Density") "density" else "count"+ |
+
| 687 | ++ | + | |
| 257 | +688 | ! |
- output = teal.widgets::white_small_well(+ plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
|
| 258 | +689 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")),
+ substitute( |
| 259 | +690 | ! |
- tags$h1(tags$strong("Selected points:"), class = "text-center font-150p"),
+ expr = ggplot(ANL, aes(dist_var_name)) + |
| 260 | +691 | ! |
- teal.widgets::get_dt_rows(ns("data_table"), ns("data_table_rows")),
+ geom_histogram( |
| 261 | +692 | ! |
- DT::dataTableOutput(ns("data_table"), width = "100%")
+ position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3 |
| 262 | +693 |
- ),+ ), |
|
| 263 | +694 | ! |
- encoding = div(- |
-
| 264 | -- |
- ### Reporter+ env = list( |
|
| 265 | +695 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ m_type = as.name(m_type), bins_var = bins_var, dist_var_name = as.name(dist_var) |
| 266 | +696 |
- ###- |
- |
| 267 | -! | -
- tags$label("Encodings", class = "text-primary"),
+ ) |
|
| 268 | -! | +||
| 697 | +
- teal.transform::datanames_input(args[c("x", "y", "color_by", "size_by", "row_facet", "col_facet")]),
+ ) |
||
| 269 | +698 | ! |
- teal.transform::data_extract_ui(+ } else if (length(s_var) != 0 && length(g_var) == 0) {
|
| 270 | +699 | ! |
- id = ns("x"),
+ substitute( |
| 271 | +700 | ! |
- label = "X variable",+ expr = ggplot(ANL, aes(dist_var_name, col = s_var_name)) + |
| 272 | +701 | ! |
- data_extract_spec = args$x,+ geom_histogram( |
| 273 | +702 | ! |
- is_single_dataset = is_single_dataset_value+ position = "identity", aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3 |
| 274 | +703 |
- ),- |
- |
| 275 | -! | -
- checkboxInput(ns("log_x"), "Use log transformation", value = FALSE),
+ ), |
|
| 276 | +704 | ! |
- conditionalPanel(+ env = list( |
| 277 | +705 | ! |
- condition = paste0("input['", ns("log_x"), "'] == true"),
+ m_type = as.name(m_type), |
| 278 | +706 | ! |
- radioButtons(+ bins_var = bins_var, |
| 279 | +707 | ! |
- ns("log_x_base"),
+ dist_var_name = dist_var_name, |
| 280 | +708 | ! |
- label = NULL,+ s_var = as.name(s_var), |
| 281 | +709 | ! |
- inline = TRUE,+ s_var_name = s_var_name |
| 282 | -! | +||
| 710 | +
- choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
+ ) |
||
| 283 | +711 |
) |
|
| 284 | -+ | ||
| 712 | +! |
- ),+ } else if (length(s_var) == 0 && length(g_var) != 0) {
|
|
| 285 | +713 | ! |
- teal.transform::data_extract_ui(+ req(scales_type) |
| 286 | +714 | ! |
- id = ns("y"),
+ substitute( |
| 287 | +715 | ! |
- label = "Y variable",+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name)) + |
| 288 | +716 | ! |
- data_extract_spec = args$y,+ geom_histogram( |
| 289 | +717 | ! |
- is_single_dataset = is_single_dataset_value+ position = "identity", aes(y = after_stat(m_type)), bins = bins_var, alpha = 0.3 |
| 290 | +718 |
- ),+ ) + |
|
| 291 | +719 | ! |
- checkboxInput(ns("log_y"), "Use log transformation", value = FALSE),
+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), |
| 292 | +720 | ! |
- conditionalPanel(+ env = list( |
| 293 | +721 | ! |
- condition = paste0("input['", ns("log_y"), "'] == true"),
+ m_type = as.name(m_type), |
| 294 | +722 | ! |
- radioButtons(+ bins_var = bins_var, |
| 295 | +723 | ! |
- ns("log_y_base"),
+ dist_var_name = dist_var_name, |
| 296 | +724 | ! |
- label = NULL,+ g_var = g_var, |
| 297 | +725 | ! |
- inline = TRUE,+ g_var_name = g_var_name, |
| 298 | +726 | ! |
- choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
+ scales_raw = tolower(scales_type) |
| 299 | +727 |
- )+ ) |
|
| 300 | +728 |
- ),+ ) |
|
| 301 | -! | +||
| 729 | +
- if (!is.null(args$color_by)) {
+ } else {
|
||
| 302 | +730 | ! |
- teal.transform::data_extract_ui(+ req(scales_type) |
| 303 | +731 | ! |
- id = ns("color_by"),
+ substitute( |
| 304 | +732 | ! |
- label = "Color by variable",+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes(dist_var_name, col = s_var_name)) + |
| 305 | +733 | ! |
- data_extract_spec = args$color_by,+ geom_histogram( |
| 306 | +734 | ! |
- is_single_dataset = is_single_dataset_value+ position = "identity", |
| 307 | -+ | ||
| 735 | +! |
- )+ aes(y = after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3 |
|
| 308 | +736 |
- },+ ) + |
|
| 309 | +737 | ! |
- if (!is.null(args$size_by)) {
+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), |
| 310 | +738 | ! |
- teal.transform::data_extract_ui(+ env = list( |
| 311 | +739 | ! |
- id = ns("size_by"),
+ m_type = as.name(m_type), |
| 312 | +740 | ! |
- label = "Size by variable",+ bins_var = bins_var, |
| 313 | +741 | ! |
- data_extract_spec = args$size_by,+ dist_var_name = dist_var_name, |
| 314 | +742 | ! |
- is_single_dataset = is_single_dataset_value- |
-
| 315 | -- |
- )- |
- |
| 316 | -- |
- },+ g_var = g_var, |
|
| 317 | +743 | ! |
- if (!is.null(args$row_facet)) {
+ s_var = as.name(s_var), |
| 318 | +744 | ! |
- teal.transform::data_extract_ui(+ g_var_name = g_var_name, |
| 319 | +745 | ! |
- id = ns("row_facet"),
+ s_var_name = s_var_name, |
| 320 | +746 | ! |
- label = "Row facetting",+ scales_raw = tolower(scales_type) |
| 321 | -! | +||
| 747 | +
- data_extract_spec = args$row_facet,+ ) |
||
| 322 | -! | +||
| 748 | +
- is_single_dataset = is_single_dataset_value+ ) |
||
| 323 | +749 |
- )+ } |
|
| 324 | +750 |
- },+ |
|
| 325 | +751 | ! |
- if (!is.null(args$col_facet)) {
+ if (add_dens_var) {
|
| 326 | +752 | ! |
- teal.transform::data_extract_ui(+ plot_call <- substitute( |
| 327 | +753 | ! |
- id = ns("col_facet"),
+ expr = plot_call + |
| 328 | +754 | ! |
- label = "Column facetting",+ stat_density( |
| 329 | +755 | ! |
- data_extract_spec = args$col_facet,+ aes(y = after_stat(const * m_type2)), |
| 330 | +756 | ! |
- is_single_dataset = is_single_dataset_value+ geom = "line", |
| 331 | -+ | ||
| 757 | +! |
- )+ position = "identity", |
|
| 332 | -+ | ||
| 758 | +! |
- },+ alpha = 0.5, |
|
| 333 | +759 | ! |
- teal.widgets::panel_group(+ size = 2, |
| 334 | +760 | ! |
- teal.widgets::panel_item(+ n = ndensity |
| 335 | -! | +||
| 761 | +
- title = "Plot settings",+ ), |
||
| 336 | +762 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
+ env = list( |
| 337 | +763 | ! |
- teal.widgets::optionalSelectInput(+ plot_call = plot_call, |
| 338 | +764 | ! |
- inputId = ns("shape"),
+ const = if (main_type_var == "Density") {
|
| 339 | +765 | ! |
- label = "Points shape:",+ 1+ |
+
| 766 | ++ |
+ } else {
|
|
| 340 | +767 | ! |
- choices = args$shape,+ diff(range(qenv[["ANL"]][[dist_var]], na.rm = TRUE)) / bins_var+ |
+
| 768 | ++ |
+ }, |
|
| 341 | +769 | ! |
- selected = args$shape[1],+ m_type2 = if (main_type_var == "Density") as.name("density") else as.name("count"),
|
| 342 | +770 | ! |
- multiple = FALSE+ ndensity = ndensity |
| 343 | +771 |
- ),+ ) |
|
| 344 | -! | +||
| 772 | +
- colourpicker::colourInput(ns("color"), "Points color:", "black"),
+ ) |
||
| 345 | -! | +||
| 773 | +
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE, step = .1),
+ } |
||
| 346 | -! | +||
| 774 | +
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
+
|
||
| 347 | +775 | ! |
- checkboxInput(ns("add_density"), "Add marginal density", value = FALSE),
+ if (length(t_dist) != 0 && main_type_var == "Density" && length(g_var) == 0 && length(s_var) == 0) {
|
| 348 | +776 | ! |
- checkboxInput(ns("rug_plot"), "Include rug plot", value = FALSE),
+ qenv <- teal.code::eval_code( |
| 349 | +777 | ! |
- checkboxInput(ns("show_count"), "Show N (number of observations)", value = FALSE),
+ qenv, |
| 350 | +778 | ! |
- shinyjs::hidden(helpText(id = ns("line_msg"), "Trendline needs numeric X and Y variables")),
+ substitute( |
| 351 | +779 | ! |
- teal.widgets::optionalSelectInput(ns("smoothing_degree"), "Smoothing degree", seq_len(args$max_deg)),
+ df_params <- as.data.frame(append(params, list(name = t_dist))), |
| 352 | +780 | ! |
- shinyjs::hidden(teal.widgets::optionalSelectInput(ns("color_sub"), label = "", multiple = TRUE)),
+ env = list(t_dist = t_dist) |
| 353 | -! | +||
| 781 | +
- teal.widgets::optionalSliderInputValMinMax(ns("ci"), "Confidence", c(.95, .8, .99), ticks = FALSE),
+ ) |
||
| 354 | -! | +||
| 782 | +
- shinyjs::hidden(checkboxInput(ns("show_form"), "Show formula", value = TRUE)),
+ ) |
||
| 355 | +783 | ! |
- shinyjs::hidden(checkboxInput(ns("show_r2"), "Show adj-R Squared", value = TRUE)),
+ datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params)))) |
| 356 | +784 | ! |
- uiOutput(ns("num_na_removed")),
+ label <- quote(tb)+ |
+
| 785 | ++ | + | |
| 357 | +786 | ! |
- div(+ plot_call <- substitute( |
| 358 | +787 | ! |
- id = ns("label_pos"),
+ expr = plot_call + ggpp::geom_table_npc( |
| 359 | +788 | ! |
- div(strong("Stats position")),
+ data = data, |
| 360 | +789 | ! |
- div(class = "inline-block w-10", helpText("Left")),
+ aes(npcx = x, npcy = y, label = label), |
| 361 | +790 | ! |
- div(+ hjust = 0, vjust = 1, size = 4+ |
+
| 791 | ++ |
+ ), |
|
| 362 | +792 | ! |
- class = "inline-block w-70",+ env = list(plot_call = plot_call, data = datas, label = label)+ |
+
| 793 | ++ |
+ )+ |
+ |
| 794 | ++ |
+ }+ |
+ |
| 795 | ++ | + | |
| 363 | +796 | ! |
- teal.widgets::optionalSliderInput(+ if (length(s_var) == 0 && length(g_var) == 0 && main_type_var == "Density" && |
| 364 | +797 | ! |
- ns("pos"),
+ length(t_dist) != 0 && main_type_var == "Density") {
|
| 365 | +798 | ! |
- label = NULL,+ map_dist <- stats::setNames( |
| 366 | +799 | ! |
- min = 0, max = 1, value = .99, ticks = FALSE, step = .01+ c("dnorm", "dlnorm", "dgamma", "dunif"),
|
| 367 | -+ | ||
| 800 | +! |
- )+ c("normal", "lognormal", "gamma", "unif")
|
|
| 368 | +801 |
- ),+ ) |
|
| 369 | +802 | ! |
- div(class = "inline-block w-10", helpText("Right"))
+ plot_call <- substitute( |
| 370 | -+ | ||
| 803 | +! |
- ),+ expr = plot_call + stat_function( |
|
| 371 | +804 | ! |
- teal.widgets::optionalSliderInput(+ data = data.frame(x = range(ANL[[dist_var]]), color = mapped_dist), |
| 372 | +805 | ! |
- ns("label_size"), "Stats font size",
+ aes(x, color = color), |
| 373 | +806 | ! |
- min = 3, max = 10, value = 5, ticks = FALSE, step = .1+ fun = mapped_dist_name, |
| 374 | -+ | ||
| 807 | +! |
- ),+ n = ndensity, |
|
| 375 | +808 | ! |
- if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
+ size = 2, |
| 376 | +809 | ! |
- checkboxInput(ns("free_scales"), "Free scales", value = FALSE)
+ args = params |
| 377 | +810 |
- },+ ) + |
|
| 378 | +811 | ! |
- selectInput(+ scale_color_manual(values = stats::setNames("blue", mapped_dist), aesthetics = "color"),
|
| 379 | +812 | ! |
- inputId = ns("ggtheme"),
+ env = list( |
| 380 | +813 | ! |
- label = "Theme (by ggplot):",+ plot_call = plot_call, |
| 381 | +814 | ! |
- choices = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
+ dist_var = dist_var, |
| 382 | +815 | ! |
- selected = args$ggtheme,+ ndensity = ndensity, |
| 383 | +816 | ! |
- multiple = FALSE+ mapped_dist = unname(map_dist[t_dist]),+ |
+
| 817 | +! | +
+ mapped_dist_name = as.name(unname(map_dist[t_dist])) |
|
| 384 | +818 |
) |
|
| 385 | +819 |
) |
|
| 386 | +820 |
- )+ } |
|
| 387 | +821 |
- ),+ |
|
| 388 | +822 | ! |
- forms = tagList(+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 389 | +823 | ! |
- teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"),
+ user_plot = ggplot2_args[["Histogram"]], |
| 390 | +824 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ user_default = ggplot2_args$default |
| 391 | +825 |
- ),+ ) |
|
| 392 | -! | +||
| 826 | +
- pre_output = args$pre_output,+ |
||
| 393 | +827 | ! |
- post_output = args$post_output+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 394 | -+ | ||
| 828 | +! |
- )+ all_ggplot2_args, |
|
| 395 | -+ | ||
| 829 | +! |
- )+ ggtheme = ggtheme |
|
| 396 | +830 |
- }+ ) |
|
| 397 | +831 | ||
| 398 | -+ | ||
| 832 | +! |
- srv_g_scatterplot <- function(id,+ teal.code::eval_code( |
|
| 399 | -+ | ||
| 833 | +! |
- data,+ qenv, |
|
| 400 | -+ | ||
| 834 | +! |
- reporter,+ substitute( |
|
| 401 | -+ | ||
| 835 | +! |
- filter_panel_api,+ expr = {
|
|
| 402 | -+ | ||
| 836 | +! |
- x,+ g <- plot_call |
|
| 403 | -+ | ||
| 837 | +! |
- y,+ print(g) |
|
| 404 | +838 |
- color_by,+ }, |
|
| 405 | -+ | ||
| 839 | +! |
- size_by,+ env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
|
|
| 406 | +840 |
- row_facet,+ ) |
|
| 407 | +841 |
- col_facet,+ ) |
|
| 408 | +842 |
- plot_height,+ } |
|
| 409 | +843 |
- plot_width,+ ) |
|
| 410 | +844 |
- table_dec,+ |
|
| 411 | +845 |
- ggplot2_args) {
+ # qqplot qenv ---- |
|
| 412 | +846 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ qq_q <- eventReactive( |
| 413 | +847 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ eventExpr = {
|
| 414 | +848 | ! |
- checkmate::assert_class(data, "tdata")+ common_q() |
| 415 | +849 | ! |
- moduleServer(id, function(input, output, session) {
+ input$scales_type |
| 416 | +850 | ! |
- data_extract <- list(+ input$qq_line |
| 417 | +851 | ! |
- x = x,+ is.null(input$ggtheme) |
| 418 | -! | +||
| 852 | +
- y = y,+ }, |
||
| 419 | +853 | ! |
- color_by = color_by,+ valueExpr = {
|
| 420 | +854 | ! |
- size_by = size_by,+ dist_var <- merge_vars()$dist_var |
| 421 | +855 | ! |
- row_facet = row_facet,+ s_var <- merge_vars()$s_var |
| 422 | +856 | ! |
- col_facet = col_facet- |
-
| 423 | -- |
- )- |
- |
| 424 | -- |
-
+ g_var <- merge_vars()$g_var |
|
| 425 | +857 | ! |
- rule_diff <- function(other) {
+ dist_var_name <- merge_vars()$dist_var_name |
| 426 | +858 | ! |
- function(value) {
+ s_var_name <- merge_vars()$s_var_name |
| 427 | +859 | ! |
- othervalue <- selector_list()[[other]]()[["select"]]+ g_var_name <- merge_vars()$g_var_name |
| 428 | +860 | ! |
- if (!is.null(othervalue)) {
+ t_dist <- input$t_dist |
| 429 | +861 | ! |
- if (identical(value, othervalue)) {
+ dist_param1 <- input$dist_param1 |
| 430 | +862 | ! |
- "Row and column facetting variables must be different."+ dist_param2 <- input$dist_param2 |
| 431 | +863 |
- }+ |
|
| 432 | -+ | ||
| 864 | +! |
- }+ scales_type <- input$scales_type |
|
| 433 | -+ | ||
| 865 | +! |
- }+ ggtheme <- input$ggtheme |
|
| 434 | +866 |
- }+ + |
+ |
| 867 | +! | +
+ teal::validate_inputs(iv_r_dist(), iv_dist) |
|
| 435 | +868 | ||
| 436 | +869 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ qenv <- common_q() |
| 437 | -! | +||
| 870 | +
- data_extract = data_extract,+ |
||
| 438 | +871 | ! |
- datasets = data,+ plot_call <- if (length(s_var) == 0 && length(g_var) == 0) {
|
| 439 | +872 | ! |
- select_validation_rule = list(+ substitute( |
| 440 | +873 | ! |
- x = ~ if (length(.) != 1) "Please select exactly one x var.",+ expr = ggplot(ANL, aes_string(sample = dist_var)), |
| 441 | +874 | ! |
- y = ~ if (length(.) != 1) "Please select exactly one y var.",+ env = list(dist_var = dist_var) |
| 442 | -! | +||
| 875 | +
- color_by = ~ if (length(.) > 1) "There cannot be more than 1 color variable.",+ ) |
||
| 443 | +876 | ! |
- size_by = ~ if (length(.) > 1) "There cannot be more than 1 size variable.",+ } else if (length(s_var) != 0 && length(g_var) == 0) {
|
| 444 | +877 | ! |
- row_facet = shinyvalidate::compose_rules(+ substitute( |
| 445 | +878 | ! |
- shinyvalidate::sv_optional(),+ expr = ggplot(ANL, aes_string(sample = dist_var, color = s_var)), |
| 446 | +879 | ! |
- rule_diff("col_facet")
+ env = list(dist_var = dist_var, s_var = s_var) |
| 447 | +880 |
- ),+ ) |
|
| 448 | +881 | ! |
- col_facet = shinyvalidate::compose_rules(+ } else if (length(s_var) == 0 && length(g_var) != 0) {
|
| 449 | +882 | ! |
- shinyvalidate::sv_optional(),+ substitute( |
| 450 | +883 | ! |
- rule_diff("row_facet")
- |
-
| 451 | -- |
- )- |
- |
| 452 | -- |
- )+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var)) + |
|
| 453 | -+ | ||
| 884 | +! |
- )+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), |
|
| 454 | -+ | ||
| 885 | +! |
-
+ env = list( |
|
| 455 | +886 | ! |
- iv_r <- reactive({
+ dist_var = dist_var, |
| 456 | +887 | ! |
- iv_facet <- shinyvalidate::InputValidator$new()+ g_var = g_var, |
| 457 | +888 | ! |
- iv <- shinyvalidate::InputValidator$new()+ g_var_name = g_var_name, |
| 458 | +889 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list)+ scales_raw = tolower(scales_type) |
| 459 | +890 |
- })+ ) |
|
| 460 | -! | +||
| 891 | +
- iv_facet <- shinyvalidate::InputValidator$new()+ ) |
||
| 461 | -! | +||
| 892 | +
- iv_facet$add_rule("add_density", ~ if (isTRUE(.) &&
+ } else {
|
||
| 462 | +893 | ! |
- (length(selector_list()$row_facet()$select) > 0L ||+ substitute( |
| 463 | +894 | ! |
- length(selector_list()$col_facet()$select) > 0L)) {
+ expr = ggplot(ANL[ANL[[g_var]] != "NA", ], aes_string(sample = dist_var, color = s_var)) + |
| 464 | +895 | ! |
- "Cannot add marginal density when Row or Column facetting has been selected"- |
-
| 465 | -- |
- })+ facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), |
|
| 466 | +896 | ! |
- iv_facet$enable()- |
-
| 467 | -- |
-
+ env = list( |
|
| 468 | +897 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ dist_var = dist_var, |
| 469 | +898 | ! |
- selector_list = selector_list,+ g_var = g_var, |
| 470 | +899 | ! |
- datasets = data,+ s_var = s_var, |
| 471 | +900 | ! |
- join_keys = get_join_keys(data),+ g_var_name = g_var_name, |
| 472 | +901 | ! |
- merge_function = "dplyr::inner_join"+ scales_raw = tolower(scales_type) |
| 473 | +902 |
- )+ ) |
|
| 474 | +903 |
-
+ ) |
|
| 475 | -! | +||
| 904 | +
- anl_merged_q <- reactive({
+ } |
||
| 476 | -! | +||
| 905 | +
- req(anl_merged_input())+ |
||
| 477 | +906 | ! |
- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>%+ map_dist <- stats::setNames( |
| 478 | +907 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr)) %>%+ c("qnorm", "qlnorm", "qgamma", "qunif"),
|
| 479 | +908 | ! |
- teal.code::eval_code(quote(ANL)) # used to display table when running show-r-code code+ c("normal", "lognormal", "gamma", "unif")
|
| 480 | +909 |
- })+ ) |
|
| 481 | +910 | ||
| 482 | +911 | ! |
- merged <- list(+ plot_call <- substitute( |
| 483 | +912 | ! |
- anl_input_r = anl_merged_input,+ expr = plot_call + |
| 484 | +913 | ! |
- anl_q_r = anl_merged_q+ stat_qq(distribution = mapped_dist, dparams = params),+ |
+
| 914 | +! | +
+ env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist]))) |
|
| 485 | +915 |
- )+ ) |
|
| 486 | +916 | ||
| 487 | +917 | ! |
- trend_line_is_applicable <- reactive({
+ if (length(t_dist) != 0 && length(g_var) == 0 && length(s_var) == 0) {
|
| 488 | +918 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint+ qenv <- teal.code::eval_code( |
| 489 | +919 | ! |
- x_var <- as.vector(merged$anl_input_r()$columns_source$x)+ qenv, |
| 490 | +920 | ! |
- y_var <- as.vector(merged$anl_input_r()$columns_source$y)+ substitute( |
| 491 | +921 | ! |
- length(x_var) > 0 && length(y_var) > 0 && is.numeric(ANL[[x_var]]) && is.numeric(ANL[[y_var]])+ df_params <- as.data.frame(append(params, list(name = t_dist))), |
| 492 | -+ | ||
| 922 | +! |
- })+ env = list(t_dist = t_dist) |
|
| 493 | +923 |
-
+ ) |
|
| 494 | -! | +||
| 924 | +
- add_trend_line <- reactive({
+ ) |
||
| 495 | +925 | ! |
- smoothing_degree <- as.integer(input$smoothing_degree)+ datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params)))) |
| 496 | +926 | ! |
- trend_line_is_applicable() && length(smoothing_degree) > 0+ label <- quote(tb) |
| 497 | +927 |
- })+ |
|
| 498 | -+ | ||
| 928 | +! |
-
+ plot_call <- substitute( |
|
| 499 | +929 | ! |
- if (!is.null(color_by)) {
+ expr = plot_call + |
| 500 | +930 | ! |
- observeEvent(+ ggpp::geom_table_npc( |
| 501 | +931 | ! |
- eventExpr = merged$anl_input_r()$columns_source$color_by,+ data = data, |
| 502 | +932 | ! |
- handlerExpr = {
+ aes(npcx = x, npcy = y, label = label), |
| 503 | +933 | ! |
- color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by)+ hjust = 0, |
| 504 | +934 | ! |
- if (length(color_by_var) > 0) {
+ vjust = 1, |
| 505 | +935 | ! |
- shinyjs::hide("color")
+ size = 4 |
| 506 | +936 |
- } else {
+ ), |
|
| 507 | +937 | ! |
- shinyjs::show("color")
+ env = list( |
| 508 | -+ | ||
| 938 | +! |
- }+ plot_call = plot_call,+ |
+ |
| 939 | +! | +
+ data = datas,+ |
+ |
| 940 | +! | +
+ label = label |
|
| 509 | +941 |
- }+ ) |
|
| 510 | +942 |
- )+ ) |
|
| 511 | +943 |
- }+ } |
|
| 512 | +944 | ||
| 513 | +945 | ! |
- output$num_na_removed <- renderUI({
+ if (isTRUE(input$qq_line)) {
|
| 514 | +946 | ! |
- if (add_trend_line()) {
+ plot_call <- substitute( |
| 515 | +947 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint+ expr = plot_call + |
| 516 | +948 | ! |
- x_var <- as.vector(merged$anl_input_r()$columns_source$x)+ stat_qq_line(distribution = mapped_dist, dparams = params), |
| 517 | +949 | ! |
- y_var <- as.vector(merged$anl_input_r()$columns_source$y)+ env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist])))+ |
+
| 950 | ++ |
+ )+ |
+ |
| 951 | ++ |
+ }+ |
+ |
| 952 | ++ | + | |
| 518 | +953 | ! |
- if ((num_total_na <- nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)]))) > 0) {
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 519 | +954 | ! |
- shiny::tags$div(paste(num_total_na, "row(s) with missing values were removed"), shiny::tags$hr())+ user_plot = ggplot2_args[["QQplot"]],+ |
+
| 955 | +! | +
+ user_default = ggplot2_args$default,+ |
+ |
| 956 | +! | +
+ module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample")) |
|
| 520 | +957 |
- }+ ) |
|
| 521 | +958 |
- }+ + |
+ |
| 959 | +! | +
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ |
+ |
| 960 | +! | +
+ all_ggplot2_args,+ |
+ |
| 961 | +! | +
+ ggtheme = ggtheme |
|
| 522 | +962 |
- })+ ) |
|
| 523 | +963 | ||
| 524 | +964 | ! |
- observeEvent(+ teal.code::eval_code( |
| 525 | +965 | ! |
- eventExpr = merged$anl_input_r()$columns_source[c("col_facet", "row_facet")],
+ qenv, |
| 526 | +966 | ! |
- handlerExpr = {
+ substitute( |
| 527 | +967 | ! |
- if (length(merged$anl_input_r()$columns_source$col_facet) == 0 &&+ expr = {
|
| 528 | +968 | ! |
- length(merged$anl_input_r()$columns_source$row_facet) == 0) {
+ g <- plot_call |
| 529 | +969 | ! |
- shinyjs::hide("free_scales")
+ print(g) |
| 530 | +970 |
- } else {
+ }, |
|
| 531 | +971 | ! |
- shinyjs::show("free_scales")
+ env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args)))
|
| 532 | +972 |
- }+ ) |
|
| 533 | +973 | ++ |
+ )+ |
+
| 974 |
} |
||
| 534 | +975 |
) |
|
| 535 | +976 | ||
| 536 | -! | +||
| 977 | +
- output_q <- reactive({
+ # test qenv ---- |
||
| 537 | +978 | ! |
- teal::validate_inputs(iv_r(), iv_facet)- |
-
| 538 | -- |
-
+ test_q <- eventReactive( |
|
| 539 | +979 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint+ ignoreNULL = FALSE, |
| 540 | -+ | ||
| 980 | +! |
-
+ eventExpr = {
|
|
| 541 | +981 | ! |
- x_var <- as.vector(merged$anl_input_r()$columns_source$x)+ common_q() |
| 542 | +982 | ! |
- y_var <- as.vector(merged$anl_input_r()$columns_source$y)+ input$dist_param1 |
| 543 | +983 | ! |
- color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by)+ input$dist_param2 |
| 544 | +984 | ! |
- size_by_var <- as.vector(merged$anl_input_r()$columns_source$size_by)+ input$dist_tests |
| 545 | -! | +||
| 985 | +
- row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
+ }, |
||
| 546 | +986 | ! |
- character(0)+ valueExpr = {
|
| 547 | +987 |
- } else {
+ # Create a private stack for this function only. |
|
| 548 | +988 | ! |
- as.vector(merged$anl_input_r()$columns_source$row_facet)+ ANL <- common_q()[["ANL"]] # nolint |
| 549 | +989 |
- }+ |
|
| 550 | +990 | ! |
- col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
+ dist_var <- merge_vars()$dist_var |
| 551 | +991 | ! |
- character(0)+ s_var <- merge_vars()$s_var+ |
+
| 992 | +! | +
+ g_var <- merge_vars()$g_var |
|
| 552 | +993 |
- } else {
+
|
|
| 553 | +994 | ! |
- as.vector(merged$anl_input_r()$columns_source$col_facet)+ dist_var_name <- merge_vars()$dist_var_name |
| 554 | -+ | ||
| 995 | +! |
- }+ s_var_name <- merge_vars()$s_var_name |
|
| 555 | +996 | ! |
- alpha <- input$alpha # nolint+ g_var_name <- merge_vars()$g_var_name |
| 556 | -! | +||
| 997 | +
- size <- input$size # nolint+ |
||
| 557 | +998 | ! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels # nolint+ dist_param1 <- input$dist_param1 |
| 558 | +999 | ! |
- add_density <- input$add_density+ dist_param2 <- input$dist_param2 |
| 559 | +1000 | ! |
- ggtheme <- input$ggtheme+ dist_tests <- input$dist_tests |
| 560 | +1001 | ! |
- rug_plot <- input$rug_plot+ t_dist <- input$t_dist+ |
+
| 1002 | ++ | + | |
| 561 | +1003 | ! |
- color <- input$color # nolint+ validate(need(dist_tests, "Please select a test"))+ |
+
| 1004 | ++ | + | |
| 562 | +1005 | ! |
- shape <- `if`(is.null(input$shape) || identical(input$shape, ""), "circle", input$shape) # nolint+ teal::validate_inputs(iv_dist) |
| 563 | -! | +||
| 1006 | +
- smoothing_degree <- as.integer(input$smoothing_degree)+ |
||
| 564 | +1007 | ! |
- ci <- input$ci # nolint+ if (length(s_var) > 0 || length(g_var) > 0) {
|
| 565 | -+ | ||
| 1008 | +! |
-
+ counts <- ANL %>% |
|
| 566 | +1009 | ! |
- log_x <- input$log_x+ dplyr::group_by_at(dplyr::vars(dplyr::any_of(c(s_var, g_var)))) %>% |
| 567 | +1010 | ! |
- log_y <- input$log_y+ dplyr::summarise(n = dplyr::n()) |
| 568 | +1011 | ||
| 569 | +1012 | ! |
- validate(need(+ validate(need(all(counts$n > 5), "Please select strata*group with at least 5 observation each.")) |
| 570 | -! | +||
| 1013 | +
- length(row_facet_name) == 0 || inherits(ANL[[row_facet_name]], c("character", "factor", "Date", "integer")),
+ } |
||
| 571 | -! | +||
| 1014 | +
- "`Row facetting` variable must be of class `character`, `factor`, `Date`, or `integer`"+ |
||
| 572 | +1015 |
- ))+ |
|
| 573 | +1016 | ! |
- validate(need(+ if (dist_tests %in% c( |
| 574 | +1017 | ! |
- length(col_facet_name) == 0 || inherits(ANL[[col_facet_name]], c("character", "factor", "Date", "integer")),
+ "t-test (two-samples, not paired)", |
| 575 | +1018 | ! |
- "`Column facetting` variable must be of class `character`, `factor`, `Date`, or `integer`"+ "F-test", |
| 576 | -+ | ||
| 1019 | +! |
- ))+ "Kolmogorov-Smirnov (two-samples)" |
|
| 577 | +1020 |
-
+ )) {
|
|
| 578 | +1021 | ! |
- if (add_density && length(color_by_var) > 0) {
+ if (length(g_var) == 0 && length(s_var) > 0) {
|
| 579 | +1022 | ! |
- validate(need(+ validate(need( |
| 580 | +1023 | ! |
- !is.numeric(ANL[[color_by_var]]),+ length(unique(ANL[[s_var]])) == 2, |
| 581 | +1024 | ! |
- "Marginal plots cannot be produced when the points are colored by numeric variables.+ "Please select stratify variable with 2 levels." |
| 582 | -! | +||
| 1025 | +
- \n Uncheck the 'Add marginal density' checkbox to display the plot."+ )) |
||
| 583 | +1026 |
- ))+ } |
|
| 584 | +1027 | ! |
- validate(need(+ if (length(g_var) > 0 && length(s_var) > 0) {
|
| 585 | +1028 | ! |
- !(inherits(ANL[[color_by_var]], "Date") ||+ validate(need( |
| 586 | +1029 | ! |
- inherits(ANL[[color_by_var]], "POSIXct") ||+ all(stats::na.omit(as.vector( |
| 587 | +1030 | ! |
- inherits(ANL[[color_by_var]], "POSIXlt")),+ tapply(ANL[[s_var]], list(ANL[[g_var]]), function(x) length(unique(x))) == 2 |
| 588 | -! | +||
| 1031 | +
- "Marginal plots cannot be produced when the points are colored by Date or POSIX variables.+ ))), |
||
| 589 | +1032 | ! |
- \n Uncheck the 'Add marginal density' checkbox to display the plot."+ "Please select stratify variable with 2 levels, per each group." |
| 590 | +1033 |
- ))+ )) |
|
| 591 | +1034 |
- }+ } |
|
| 592 | +1035 | - - | -|
| 593 | -! | -
- teal::validate_has_data(ANL[, c(x_var, y_var)], 10, complete = TRUE, allow_inf = FALSE)+ } |
|
| 594 | +1036 | ||
| 595 | +1037 | ! |
- if (log_x) {
+ map_dist <- stats::setNames( |
| 596 | +1038 | ! |
- validate(+ c("pnorm", "plnorm", "pgamma", "punif"),
|
| 597 | +1039 | ! |
- need(+ c("normal", "lognormal", "gamma", "unif")
|
| 598 | -! | +||
| 1040 | +
- is.numeric(ANL[[x_var]]) && all(+ ) |
||
| 599 | +1041 | ! |
- ANL[[x_var]] > 0 | is.na(ANL[[x_var]])+ sks_args <- list( |
| 600 | -+ | ||
| 1042 | +! |
- ),+ test = quote(stats::ks.test), |
|
| 601 | +1043 | ! |
- "X variable can only be log transformed if variable is numeric and all values are positive."+ args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), |
| 602 | -+ | ||
| 1044 | +! |
- )+ groups = c(g_var, s_var) |
|
| 603 | +1045 |
) |
|
| 604 | -- |
- }- |
- |
| 605 | -! | -
- if (log_y) {
- |
- |
| 606 | +1046 | ! |
- validate(+ ssw_args <- list( |
| 607 | +1047 | ! |
- need(+ test = quote(stats::shapiro.test), |
| 608 | +1048 | ! |
- is.numeric(ANL[[y_var]]) && all(+ args = bquote(list(.[[.(dist_var)]])), |
| 609 | +1049 | ! |
- ANL[[y_var]] > 0 | is.na(ANL[[y_var]])+ groups = c(g_var, s_var) |
| 610 | +1050 |
- ),+ ) |
|
| 611 | +1051 | ! |
- "Y variable can only be log transformed if variable is numeric and all values are positive."+ mfil_args <- list( |
| 612 | -+ | ||
| 1052 | +! |
- )+ test = quote(stats::fligner.test), |
|
| 613 | -+ | ||
| 1053 | +! |
- )+ args = bquote(list(.[[.(dist_var)]], .[[.(s_var)]])), |
|
| 614 | -+ | ||
| 1054 | +! |
- }+ groups = c(g_var) |
|
| 615 | +1055 | - - | -|
| 616 | -! | -
- facet_cl <- facet_ggplot_call(+ ) |
|
| 617 | +1056 | ! |
- row_facet_name,+ sad_args <- list( |
| 618 | +1057 | ! |
- col_facet_name,+ test = quote(goftest::ad.test), |
| 619 | +1058 | ! |
- free_x_scales = isTRUE(input$free_scales),+ args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), |
| 620 | +1059 | ! |
- free_y_scales = isTRUE(input$free_scales)- |
-
| 621 | -- |
- )+ groups = c(g_var, s_var) |
|
| 622 | +1060 | - - | -|
| 623 | -! | -
- point_sizes <- if (length(size_by_var) > 0) {
+ ) |
|
| 624 | +1061 | ! |
- validate(need(is.numeric(ANL[[size_by_var]]), "Variable to size by must be numeric"))+ scvm_args <- list( |
| 625 | +1062 | ! |
- substitute(+ test = quote(goftest::cvm.test), |
| 626 | +1063 | ! |
- expr = size * ANL[[size_by_var]] / max(ANL[[size_by_var]], na.rm = TRUE),+ args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), |
| 627 | +1064 | ! |
- env = list(size = size, size_by_var = size_by_var)+ groups = c(g_var, s_var) |
| 628 | +1065 |
) |
|
| 629 | -- |
- } else {
- |
- |
| 630 | +1066 | ! |
- size+ manov_args <- list( |
| 631 | -+ | ||
| 1067 | +! |
- }+ test = quote(stats::aov), |
|
| 632 | -+ | ||
| 1068 | +! |
-
+ args = bquote(list(stats::formula(.(dist_var_name) ~ .(s_var_name)), .)), |
|
| 633 | +1069 | ! |
- plot_q <- merged$anl_q_r()+ groups = c(g_var) |
| 634 | +1070 |
-
+ ) |
|
| 635 | +1071 | ! |
- if (log_x) {
+ mt_args <- list( |
| 636 | +1072 | ! |
- log_x_fn <- input$log_x_base+ test = quote(stats::t.test), |
| 637 | +1073 | ! |
- plot_q <- teal.code::eval_code(+ args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), |
| 638 | +1074 | ! |
- object = plot_q,+ groups = c(g_var) |
| 639 | -! | +||
| 1075 | +
- code = substitute(+ ) |
||
| 640 | +1076 | ! |
- expr = ANL[, log_x_var] <- log_x_fn(ANL[, x_var]), # nolint+ mv_args <- list( |
| 641 | +1077 | ! |
- env = list(+ test = quote(stats::var.test), |
| 642 | +1078 | ! |
- x_var = x_var,+ args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), |
| 643 | +1079 | ! |
- log_x_fn = as.name(log_x_fn),+ groups = c(g_var)+ |
+
| 1080 | ++ |
+ ) |
|
| 644 | +1081 | ! |
- log_x_var = paste0(log_x_fn, "_", x_var)+ mks_args <- list( |
| 645 | -+ | ||
| 1082 | +! |
- )+ test = quote(stats::ks.test), |
|
| 646 | -+ | ||
| 1083 | +! |
- )+ args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), |
|
| 647 | -+ | ||
| 1084 | +! |
- )+ groups = c(g_var) |
|
| 648 | +1085 |
- }+ ) |
|
| 649 | +1086 | ||
| 650 | +1087 | ! |
- if (log_y) {
+ tests_base <- switch(dist_tests, |
| 651 | +1088 | ! |
- log_y_fn <- input$log_y_base+ "Kolmogorov-Smirnov (one-sample)" = sks_args, |
| 652 | +1089 | ! |
- plot_q <- teal.code::eval_code(+ "Shapiro-Wilk" = ssw_args, |
| 653 | +1090 | ! |
- object = plot_q,+ "Fligner-Killeen" = mfil_args, |
| 654 | +1091 | ! |
- code = substitute(+ "one-way ANOVA" = manov_args, |
| 655 | +1092 | ! |
- expr = ANL[, log_y_var] <- log_y_fn(ANL[, y_var]), # nolint+ "t-test (two-samples, not paired)" = mt_args, |
| 656 | +1093 | ! |
- env = list(+ "F-test" = mv_args, |
| 657 | +1094 | ! |
- y_var = y_var,+ "Kolmogorov-Smirnov (two-samples)" = mks_args, |
| 658 | +1095 | ! |
- log_y_fn = as.name(log_y_fn),+ "Anderson-Darling (one-sample)" = sad_args, |
| 659 | +1096 | ! |
- log_y_var = paste0(log_y_fn, "_", y_var)- |
-
| 660 | -- |
- )- |
- |
| 661 | -- |
- )- |
- |
| 662 | -- |
- )+ "Cramer-von Mises (one-sample)" = scvm_args |
|
| 663 | +1097 |
- }+ ) |
|
| 664 | +1098 | ||
| 665 | +1099 | ! |
- pre_pro_anl <- if (input$show_count) {
+ env <- list( |
| 666 | +1100 | ! |
- paste0(+ t_test = t_dist, |
| 667 | +1101 | ! |
- "ANL %>% dplyr::group_by(",
+ dist_var = dist_var, |
| 668 | +1102 | ! |
- paste(+ g_var = g_var, |
| 669 | +1103 | ! |
- c(+ s_var = s_var, |
| 670 | +1104 | ! |
- if (length(color_by_var) > 0 && inherits(ANL[[color_by_var]], c("factor", "character"))) color_by_var,
+ args = tests_base$args, |
| 671 | +1105 | ! |
- row_facet_name,+ groups = tests_base$groups, |
| 672 | +1106 | ! |
- col_facet_name- |
-
| 673 | -- |
- ),+ test = tests_base$test, |
|
| 674 | +1107 | ! |
- collapse = ", "- |
-
| 675 | -- |
- ),+ dist_var_name = dist_var_name, |
|
| 676 | +1108 | ! |
- ") %>% dplyr::mutate(n = dplyr::n()) %>% dplyr::ungroup()"- |
-
| 677 | -- |
- )- |
- |
| 678 | -- |
- } else {
+ g_var_name = g_var_name, |
|
| 679 | +1109 | ! |
- "ANL"+ s_var_name = s_var_name |
| 680 | +1110 |
- }+ ) |
|
| 681 | +1111 | ||
| 682 | +1112 | ! |
- plot_call <- substitute(expr = pre_pro_anl %>% ggplot(), env = list(pre_pro_anl = str2lang(pre_pro_anl)))+ qenv <- common_q() |
| 683 | +1113 | ||
| 684 | -! | -
- plot_call <- if (length(color_by_var) == 0) {
- |
- |
| 685 | -! | -
- substitute(- |
- |
| 686 | +1114 | ! |
- expr = plot_call ++ if (length(s_var) == 0 && length(g_var) == 0) {
|
| 687 | +1115 | ! |
- ggplot2::aes(x = x_name, y = y_name) ++ qenv <- teal.code::eval_code( |
| 688 | +1116 | ! |
- ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value, color = color_value),+ qenv, |
| 689 | +1117 | ! |
- env = list(+ substitute( |
| 690 | +1118 | ! |
- plot_call = plot_call,+ expr = {
|
| 691 | +1119 | ! |
- x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var),+ test_stats <- ANL %>% |
| 692 | +1120 | ! |
- y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var),+ dplyr::select(dist_var) %>% |
| 693 | +1121 | ! |
- alpha_value = alpha,+ with(., broom::glance(do.call(test, args))) %>% |
| 694 | +1122 | ! |
- point_sizes = point_sizes,+ dplyr::mutate_if(is.numeric, round, 3) |
| 695 | -! | +||
| 1123 | +
- shape_value = shape,+ }, |
||
| 696 | +1124 | ! |
- color_value = color+ env = env |
| 697 | +1125 |
- )+ ) |
|
| 698 | +1126 |
- )+ ) |
|
| 699 | +1127 |
- } else {
+ } else {
|
|
| 700 | +1128 | ! |
- substitute(+ qenv <- teal.code::eval_code( |
| 701 | +1129 | ! |
- expr = plot_call ++ qenv, |
| 702 | +1130 | ! |
- ggplot2::aes(x = x_name, y = y_name, color = color_by_var_name) ++ substitute( |
| 703 | +1131 | ! |
- ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value),+ expr = {
|
| 704 | +1132 | ! |
- env = list(+ test_stats <- ANL %>% |
| 705 | +1133 | ! |
- plot_call = plot_call,+ dplyr::select(dist_var, s_var, g_var) %>% |
| 706 | +1134 | ! |
- x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var),+ dplyr::group_by_at(dplyr::vars(dplyr::any_of(groups))) %>% |
| 707 | +1135 | ! |
- y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var),+ dplyr::do(tests = broom::glance(do.call(test, args))) %>% |
| 708 | +1136 | ! |
- color_by_var_name = as.name(color_by_var),+ tidyr::unnest(tests) %>% |
| 709 | +1137 | ! |
- alpha_value = alpha,+ dplyr::mutate_if(is.numeric, round, 3) |
| 710 | -! | +||
| 1138 | +
- point_sizes = point_sizes,+ }, |
||
| 711 | +1139 | ! |
- shape_value = shape+ env = env |
| 712 | +1140 |
- )+ ) |
|
| 713 | +1141 |
- )+ ) |
|
| 714 | +1142 |
- }+ }+ |
+ |
| 1143 | +! | +
+ qenv %>% |
|
| 715 | +1144 |
-
+ # used to display table when running show-r-code code |
|
| 716 | +1145 | ! |
- if (rug_plot) plot_call <- substitute(expr = plot_call + geom_rug(), env = list(plot_call = plot_call))+ teal.code::eval_code(quote(test_stats)) |
| 717 | +1146 | ++ |
+ }+ |
+
| 1147 | ++ |
+ )+ |
+ |
| 1148 | |||
| 718 | -! | +||
| 1149 | +
- plot_label_generator <- function(rhs_formula = quote(y ~ 1),+ # outputs ---- |
||
| 719 | -! | +||
| 1150 | +
- show_form = input$show_form,+ ## building main qenv |
||
| 720 | +1151 | ! |
- show_r2 = input$show_r2,+ output_q <- reactive({
|
| 721 | +1152 | ! |
- show_count = input$show_count,+ tab <- input$tabs |
| 722 | +1153 | ! |
- pos = input$pos,+ req(tab) # tab is NULL upon app launch, hence will crash without this statement |
| 723 | -! | +||
| 1154 | +
- label_size = input$label_size) {
+
|
||
| 724 | +1155 | ! |
- stopifnot(sum(show_form, show_r2, show_count) >= 1)+ qenv_final <- common_q() |
| 725 | -! | +||
| 1156 | +
- aes_label <- paste0(+ # wrapped in if since could lead into validate error - we do want to continue |
||
| 726 | +1157 | ! |
- "aes(",
+ test_r_qenv_out <- try(test_q(), silent = TRUE) |
| 727 | +1158 | ! |
- if (show_count) "n = n, ",+ if (!inherits(test_r_qenv_out, c("try-error", "error"))) {
|
| 728 | +1159 | ! |
- "label = ",+ qenv_final <- teal.code::join(qenv_final, test_q())+ |
+
| 1160 | ++ |
+ }+ |
+ |
| 1161 | ++ | + | |
| 729 | +1162 | ! |
- if (sum(show_form, show_r2, show_count) > 1) "paste(",
+ qenv_final <- if (tab == "Histogram") {
|
| 730 | +1163 | ! |
- paste(+ req(dist_q()) |
| 731 | +1164 | ! |
- c(+ teal.code::join(qenv_final, dist_q()) |
| 732 | +1165 | ! |
- if (show_form) "stat(eq.label)",+ } else if (tab == "QQplot") {
|
| 733 | +1166 | ! |
- if (show_r2) "stat(adj.rr.label)",+ req(qq_q()) |
| 734 | +1167 | ! |
- if (show_count) "paste('N ~`=`~', n)"
+ teal.code::join(qenv_final, qq_q()) |
| 735 | +1168 |
- ),+ } |
|
| 736 | +1169 | ! |
- collapse = ", "+ qenv_final |
| 737 | +1170 |
- ),+ })+ |
+ |
| 1171 | ++ | + | |
| 738 | +1172 | ! |
- if (sum(show_form, show_r2, show_count) > 1) ", sep = '*\", \"*'))" else ")"+ dist_r <- reactive(dist_q()[["g"]]) |
| 739 | +1173 |
- )+ |
|
| 740 | +1174 | ! |
- label_geom <- substitute(+ qq_r <- reactive(qq_q()[["g"]]) |
| 741 | -! | +||
| 1175 | +
- expr = ggpmisc::stat_poly_eq(+ |
||
| 742 | +1176 | ! |
- mapping = aes_label,+ output$summary_table <- DT::renderDataTable( |
| 743 | +1177 | ! |
- formula = rhs_formula,+ expr = if (iv_r()$is_valid()) common_q()[["summary_table"]] else NULL, |
| 744 | +1178 | ! |
- parse = TRUE,+ options = list( |
| 745 | +1179 | ! |
- label.x = pos,+ autoWidth = TRUE, |
| 746 | +1180 | ! |
- size = label_size+ columnDefs = list(list(width = "200px", targets = "_all")) |
| 747 | +1181 |
- ),+ ), |
|
| 748 | +1182 | ! |
- env = list(+ rownames = FALSE+ |
+
| 1183 | ++ |
+ )+ |
+ |
| 1184 | ++ | + | |
| 749 | +1185 | ! |
- rhs_formula = rhs_formula,+ tests_r <- reactive({
|
| 750 | +1186 | ! |
- pos = pos,+ req(iv_r()$is_valid()) |
| 751 | +1187 | ! |
- aes_label = str2lang(aes_label),+ teal::validate_inputs(iv_r_dist()) |
| 752 | +1188 | ! |
- label_size = label_size+ test_q()[["test_stats"]] |
| 753 | +1189 |
- )+ }) |
|
| 754 | +1190 |
- )+ |
|
| 755 | +1191 | ! |
- substitute(+ pws1 <- teal.widgets::plot_with_settings_srv( |
| 756 | +1192 | ! |
- expr = plot_call + label_geom,+ id = "hist_plot", |
| 757 | +1193 | ! |
- env = list(+ plot_r = dist_r, |
| 758 | +1194 | ! |
- plot_call = plot_call,+ height = plot_height, |
| 759 | +1195 | ! |
- label_geom = label_geom- |
-
| 760 | -- |
- )- |
- |
| 761 | -- |
- )+ width = plot_width, |
|
| 762 | -+ | ||
| 1196 | +! |
- }+ brushing = FALSE |
|
| 763 | +1197 | - - | -|
| 764 | -! | -
- if (trend_line_is_applicable()) {
+ ) |
|
| 765 | -! | +||
| 1198 | +
- shinyjs::hide("line_msg")
+
|
||
| 766 | +1199 | ! |
- shinyjs::show("smoothing_degree")
+ pws2 <- teal.widgets::plot_with_settings_srv( |
| 767 | +1200 | ! |
- if (!add_trend_line()) {
+ id = "qq_plot", |
| 768 | +1201 | ! |
- shinyjs::hide("ci")
+ plot_r = qq_r, |
| 769 | +1202 | ! |
- shinyjs::hide("color_sub")
+ height = plot_height, |
| 770 | +1203 | ! |
- shinyjs::hide("show_form")
+ width = plot_width, |
| 771 | +1204 | ! |
- shinyjs::hide("show_r2")
+ brushing = FALSE |
| 772 | -! | +||
| 1205 | +
- if (input$show_count) {
+ ) |
||
| 773 | -! | +||
| 1206 | +
- plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE)+ |
||
| 774 | +1207 | ! |
- shinyjs::show("label_pos")
+ output$t_stats <- DT::renderDataTable( |
| 775 | +1208 | ! |
- shinyjs::show("label_size")
- |
-
| 776 | -- |
- } else {
+ expr = tests_r(), |
|
| 777 | +1209 | ! |
- shinyjs::hide("label_pos")
+ options = list(scrollX = TRUE), |
| 778 | +1210 | ! |
- shinyjs::hide("label_size")
+ rownames = FALSE |
| 779 | +1211 |
- }+ ) |
|
| 780 | +1212 |
- } else {
+
|
|
| 781 | +1213 | ! |
- shinyjs::show("ci")
+ teal.widgets::verbatim_popup_srv( |
| 782 | +1214 | ! |
- shinyjs::show("show_form")
+ id = "warning", |
| 783 | +1215 | ! |
- shinyjs::show("show_r2")
+ verbatim_content = reactive(teal.code::get_warnings(output_q())), |
| 784 | +1216 | ! |
- if (nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)])) > 0) {
+ title = "Warning", |
| 785 | +1217 | ! |
- plot_q <- teal.code::eval_code(+ disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ |
+
| 1218 | ++ |
+ )+ |
+ |
| 1219 | ++ | + | |
| 786 | +1220 | ! |
- plot_q,+ teal.widgets::verbatim_popup_srv( |
| 787 | +1221 | ! |
- substitute(+ id = "rcode", |
| 788 | +1222 | ! |
- expr = ANL <- dplyr::filter(ANL, !is.na(x_var) & !is.na(y_var)), # nolint+ verbatim_content = reactive(teal.code::get_code(output_q())), |
| 789 | +1223 | ! |
- env = list(x_var = as.name(x_var), y_var = as.name(y_var))+ title = "R Code for distribution" |
| 790 | +1224 |
- )+ ) |
|
| 791 | +1225 |
- )+ |
|
| 792 | +1226 |
- }+ ### REPORTER |
|
| 793 | +1227 | ! |
- rhs_formula <- substitute(+ if (with_reporter) {
|
| 794 | +1228 | ! |
- expr = y ~ poly(x, smoothing_degree, raw = TRUE),+ card_fun <- function(comment, label) {
|
| 795 | +1229 | ! |
- env = list(smoothing_degree = smoothing_degree)- |
-
| 796 | -- |
- )+ card <- teal::report_card_template( |
|
| 797 | +1230 | ! |
- if (input$show_form || input$show_r2 || input$show_count) {
+ title = "Distribution Plot", |
| 798 | +1231 | ! |
- plot_call <- plot_label_generator(rhs_formula = rhs_formula)+ label = label, |
| 799 | +1232 | ! |
- shinyjs::show("label_pos")
+ with_filter = with_filter, |
| 800 | +1233 | ! |
- shinyjs::show("label_size")
+ filter_panel_api = filter_panel_api |
| 801 | +1234 |
- } else {
+ ) |
|
| 802 | +1235 | ! |
- shinyjs::hide("label_pos")
+ card$append_text("Plot", "header3")
|
| 803 | +1236 | ! |
- shinyjs::hide("label_size")
- |
-
| 804 | -- |
- }+ if (input$tabs == "Histogram") {
|
|
| 805 | +1237 | ! |
- plot_call <- substitute(+ card$append_plot(dist_r(), dim = pws1$dim()) |
| 806 | +1238 | ! |
- expr = plot_call + ggplot2::geom_smooth(formula = rhs_formula, se = TRUE, level = ci, method = "lm"),+ } else if (input$tabs == "QQplot") {
|
| 807 | +1239 | ! |
- env = list(plot_call = plot_call, rhs_formula = rhs_formula, ci = ci)+ card$append_plot(qq_r(), dim = pws2$dim()) |
| 808 | +1240 |
- )+ } |
|
| 809 | -+ | ||
| 1241 | +! |
- }+ card$append_text("Statistics table", "header3")
|
|
| 810 | +1242 |
- } else {
+
|
|
| 811 | +1243 | ! |
- shinyjs::hide("smoothing_degree")
+ card$append_table(common_q()[["summary_table"]]) |
| 812 | +1244 | ! |
- shinyjs::hide("ci")
+ tests_error <- tryCatch(expr = tests_r(), error = function(e) "error") |
| 813 | +1245 | ! |
- shinyjs::hide("color_sub")
+ if (inherits(tests_error, "data.frame")) {
|
| 814 | +1246 | ! |
- shinyjs::hide("show_form")
+ card$append_text("Tests table", "header3")
|
| 815 | +1247 | ! |
- shinyjs::hide("show_r2")
+ card$append_table(tests_r()) |
| 816 | -! | +||
| 1248 | +
- if (input$show_count) {
+ }+ |
+ ||
| 1249 | ++ | + | |
| 817 | +1250 | ! |
- plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE)+ if (!comment == "") {
|
| 818 | +1251 | ! |
- shinyjs::show("label_pos")
+ card$append_text("Comment", "header3")
|
| 819 | +1252 | ! |
- shinyjs::show("label_size")
+ card$append_text(comment) |
| 820 | +1253 |
- } else {
+ } |
|
| 821 | +1254 | ! |
- shinyjs::hide("label_pos")
+ card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n")) |
| 822 | +1255 | ! |
- shinyjs::hide("label_size")
+ card |
| 823 | +1256 |
- }+ } |
|
| 824 | +1257 | ! |
- shinyjs::show("line_msg")
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 825 | +1258 |
- }+ } |
|
| 826 | +1259 |
-
+ ### |
|
| 827 | -! | +||
| 1260 | +
- if (!is.null(facet_cl)) {
+ }) |
||
| 828 | -! | +||
| 1261 | +
- plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))+ } |
| 829 | +1 |
- }+ #' Variable Browser Teal Module |
|
| 830 | +2 |
-
+ #' |
|
| 831 | -! | +||
| 3 | +
- y_label <- varname_w_label(+ #' The variable browser provides a table with variable names and labels and a |
||
| 832 | -! | +||
| 4 | +
- y_var,+ #' plot that visualizes the content of a particular variable. |
||
| 833 | -! | +||
| 5 | +
- ANL,+ #' |
||
| 834 | -! | +||
| 6 | +
- prefix = if (log_y) paste(log_y_fn, "(") else NULL,
+ #' @details Numeric columns with fewer than 30 distinct values can be treated as either factors |
||
| 835 | -! | +||
| 7 | +
- suffix = if (log_y) ")" else NULL+ #' or numbers with a checkbox allowing users to switch how they are treated (if < 6 unique values |
||
| 836 | +8 |
- )+ #' then the default is categorical, otherwise it is numeric). |
|
| 837 | -! | +||
| 9 | +
- x_label <- varname_w_label(+ #' |
||
| 838 | -! | +||
| 10 | +
- x_var,+ #' @inheritParams teal::module |
||
| 839 | -! | +||
| 11 | +
- ANL,+ #' @inheritParams shared_params |
||
| 840 | -! | +||
| 12 | +
- prefix = if (log_x) paste(log_x_fn, "(") else NULL,
+ #' @param parent_dataname (`character(1)`) If this `dataname` exists in `datasets_selected` |
||
| 841 | -! | +||
| 13 | +
- suffix = if (log_x) ")" else NULL+ #' then an extra checkbox will be shown to allow users to not show variables in other datasets |
||
| 842 | +14 |
- )+ #' which exist in this `dataname`. |
|
| 843 | +15 |
-
+ #' This is typically used to remove `ADSL` columns in `CDISC` data. In non `CDISC` data this |
|
| 844 | -! | +||
| 16 | +
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ #' can be ignored. Defaults to `"ADSL"`. |
||
| 845 | -! | +||
| 17 | +
- labs = list(y = y_label, x = x_label),+ #' @param datasets_selected (`character`) A vector of datasets which should be |
||
| 846 | -! | +||
| 18 | +
- theme = list(legend.position = "bottom")+ #' shown and in what order. Names in the vector have to correspond with datasets names. |
||
| 847 | +19 |
- )+ #' If vector of length zero (default) then all datasets are shown. |
|
| 848 | +20 |
-
+ #' |
|
| 849 | -! | +||
| 21 | +
- if (rotate_xaxis_labels) {
+ #' @aliases |
||
| 850 | -! | +||
| 22 | ++ |
+ #' tm_variable_browser_ui,+ |
+ |
| 23 | ++ |
+ #' tm_variable_browser_srv,+ |
+ |
| 24 | ++ |
+ #' tm_variable_browser,+ |
+ |
| 25 | ++ |
+ #' variable_browser_ui,+ |
+ |
| 26 | ++ |
+ #' variable_browser_srv,+ |
+ |
| 27 | ++ |
+ #' variable_browser+ |
+ |
| 28 | ++ |
+ #'+ |
+ |
| 29 | ++ |
+ #'+ |
+ |
| 30 | +
- dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1)) # nolint+ #' @export |
||
| 851 | +31 |
- }+ #' |
|
| 852 | +32 |
-
+ #' @examples |
|
| 853 | -! | +||
| 33 | +
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ #' |
||
| 854 | -! | +||
| 34 | +
- user_plot = ggplot2_args,+ #' ADSL <- teal.modules.general::rADSL |
||
| 855 | -! | +||
| 35 | +
- module_plot = dev_ggplot2_args+ #' ADTTE <- teal.modules.general::rADTTE |
||
| 856 | +36 |
- )+ #' |
|
| 857 | +37 |
-
+ #' app <- teal::init( |
|
| 858 | -! | +||
| 38 | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = ggtheme)+ #' data = teal.data::cdisc_data( |
||
| 859 | +39 |
-
+ #' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
|
|
| 860 | +40 |
-
+ #' teal.data::cdisc_dataset("ADTTE", ADTTE, code = "ADTTE <- teal.modules.general::rADTTE"),
|
|
| 861 | -! | +||
| 41 | +
- if (add_density) {
+ #' check = TRUE |
||
| 862 | -! | +||
| 42 | +
- plot_call <- substitute(+ #' ), |
||
| 863 | -! | +||
| 43 | +
- expr = ggExtra::ggMarginal(+ #' modules( |
||
| 864 | -! | +||
| 44 | +
- plot_call + labs + ggthemes + themes,+ #' teal.modules.general::tm_variable_browser( |
||
| 865 | -! | +||
| 45 | +
- type = "density",+ #' label = "Variable browser", |
||
| 866 | -! | +||
| 46 | +
- groupColour = group_colour+ #' ggplot2_args = teal.widgets::ggplot2_args( |
||
| 867 | +47 |
- ),+ #' labs = list(subtitle = "Plot generated by Variable Browser Module") |
|
| 868 | -! | +||
| 48 | +
- env = list(+ #' ), |
||
| 869 | -! | +||
| 49 | +
- plot_call = plot_call,+ #' ) |
||
| 870 | -! | +||
| 50 | +
- group_colour = if (length(color_by_var) > 0) TRUE else FALSE,+ #' ) |
||
| 871 | -! | +||
| 51 | +
- labs = parsed_ggplot2_args$labs,+ #' ) |
||
| 872 | -! | +||
| 52 | +
- ggthemes = parsed_ggplot2_args$ggtheme,+ #' if (interactive()) {
|
||
| 873 | -! | +||
| 53 | +
- themes = parsed_ggplot2_args$theme+ #' shinyApp(app$ui, app$server) |
||
| 874 | +54 |
- )+ #' } |
|
| 875 | +55 |
- )+ tm_variable_browser <- function(label = "Variable Browser", |
|
| 876 | +56 |
- } else {
+ datasets_selected = character(0), |
|
| 877 | -! | +||
| 57 | +
- plot_call <- substitute(+ parent_dataname = "ADSL", |
||
| 878 | -! | +||
| 58 | +
- expr = plot_call ++ pre_output = NULL, |
||
| 879 | -! | +||
| 59 | +
- labs ++ post_output = NULL, |
||
| 880 | -! | +||
| 60 | +
- ggthemes ++ ggplot2_args = teal.widgets::ggplot2_args()) {
|
||
| 881 | +61 | ! |
- themes,+ logger::log_info("Initializing tm_variable_browser")
|
| 882 | +62 | ! |
- env = list(+ if (!requireNamespace("sparkline", quietly = TRUE)) {
|
| 883 | +63 | ! |
- plot_call = plot_call,+ stop("Cannot load sparkline - please install the package or restart your session.")
|
| 884 | -! | +||
| 64 | +
- labs = parsed_ggplot2_args$labs,+ } |
||
| 885 | +65 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme,+ if (!requireNamespace("htmlwidgets", quietly = TRUE)) {
|
| 886 | +66 | ! |
- themes = parsed_ggplot2_args$theme+ stop("Cannot load htmlwidgets - please install the package or restart your session.")
|
| 887 | +67 |
- )+ } |
|
| 888 | -+ | ||
| 68 | +! |
- )+ if (!requireNamespace("jsonlite", quietly = TRUE)) {
|
|
| 889 | -+ | ||
| 69 | +! |
- }+ stop("Cannot load jsonlite - please install the package or restart your session.")
|
|
| 890 | +70 |
-
+ } |
|
| 891 | +71 | ! |
- plot_call <- substitute(expr = p <- plot_call, env = list(plot_call = plot_call))+ checkmate::assert_string(label) |
| 892 | -+ | ||
| 72 | +! |
-
+ checkmate::assert_character(datasets_selected) |
|
| 893 | +73 | ! |
- teal.code::eval_code(plot_q, plot_call) %>%+ checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1) |
| 894 | +74 | ! |
- teal.code::eval_code(quote(print(p)))+ checkmate::assert_class(ggplot2_args, "ggplot2_args") |
| 895 | -+ | ||
| 75 | +! |
- })+ datasets_selected <- unique(datasets_selected) |
|
| 896 | +76 | ||
| 897 | +77 | ! |
- plot_r <- reactive(output_q()[["p"]])- |
-
| 898 | -- |
-
+ module( |
|
| 899 | -+ | ||
| 78 | +! |
- # Insert the plot into a plot_with_settings module from teal.widgets+ label, |
|
| 900 | +79 | ! |
- pws <- teal.widgets::plot_with_settings_srv(+ server = srv_variable_browser, |
| 901 | +80 | ! |
- id = "scatter_plot",+ ui = ui_variable_browser, |
| 902 | +81 | ! |
- plot_r = plot_r,+ datanames = "all", |
| 903 | +82 | ! |
- height = plot_height,+ server_args = list( |
| 904 | +83 | ! |
- width = plot_width,+ datasets_selected = datasets_selected, |
| 905 | +84 | ! |
- brushing = TRUE+ parent_dataname = parent_dataname, |
| 906 | -+ | ||
| 85 | +! |
- )+ ggplot2_args = ggplot2_args |
|
| 907 | +86 |
-
+ ), |
|
| 908 | +87 | ! |
- output$data_table <- DT::renderDataTable({
+ ui_args = list( |
| 909 | +88 | ! |
- plot_brush <- pws$brush()+ datasets_selected = datasets_selected, |
| 910 | -+ | ||
| 89 | +! |
-
+ parent_dataname = parent_dataname, |
|
| 911 | +90 | ! |
- if (!is.null(plot_brush)) {
+ pre_output = pre_output, |
| 912 | +91 | ! |
- validate(need(!input$add_density, "Brushing feature is currently not supported when plot has marginal density"))+ post_output = post_output |
| 913 | +92 |
- }+ ) |
|
| 914 | +93 |
-
+ ) |
|
| 915 | -! | +||
| 94 | +
- merged_data <- isolate(teal.code::dev_suppress(output_q()[["ANL"]]))+ } |
||
| 916 | +95 | ||
| 917 | -! | +||
| 96 | +
- brushed_df <- teal.widgets::clean_brushedPoints(merged_data, plot_brush)+ # ui function |
||
| 918 | -! | +||
| 97 | +
- numeric_cols <- names(brushed_df)[+ ui_variable_browser <- function(id, |
||
| 919 | -! | +||
| 98 | +
- vapply(brushed_df, function(x) is.numeric(x) && !is.integer(x), FUN.VALUE = logical(1))+ data, |
||
| 920 | +99 |
- ]+ datasets_selected, |
|
| 921 | +100 |
-
+ parent_dataname, |
|
| 922 | -! | +||
| 101 | +
- if (length(numeric_cols) > 0) {
+ pre_output = NULL, |
||
| 923 | -! | +||
| 102 | +
- DT::formatRound(+ post_output = NULL) {
|
||
| 924 | +103 | ! |
- DT::datatable(brushed_df,+ ns <- NS(id) |
| 925 | -! | +||
| 104 | +
- rownames = FALSE,+ |
||
| 926 | +105 | ! |
- options = list(scrollX = TRUE, pageLength = input$data_table_rows)+ datanames <- names(data) |
| 927 | +106 |
- ),+ |
|
| 928 | +107 | ! |
- numeric_cols,+ if (!identical(datasets_selected, character(0))) {
|
| 929 | +108 | ! |
- table_dec+ stopifnot(all(datasets_selected %in% datanames)) |
| 930 | -+ | ||
| 109 | +! |
- )+ datanames <- datasets_selected |
|
| 931 | +110 |
- } else {
- |
- |
| 932 | -! | -
- DT::datatable(brushed_df, rownames = FALSE, options = list(scrollX = TRUE, pageLength = input$data_table_rows))+ } |
|
| 933 | +111 |
- }+ |
|
| 934 | -+ | ||
| 112 | +! |
- })+ shiny::tagList( |
|
| 935 | -+ | ||
| 113 | +! |
-
+ include_css_files("custom"),
|
|
| 936 | +114 | ! |
- teal.widgets::verbatim_popup_srv(+ shinyjs::useShinyjs(), |
| 937 | +115 | ! |
- id = "warning",+ teal.widgets::standard_layout( |
| 938 | +116 | ! |
- verbatim_content = reactive(teal.code::get_warnings(output_q())),+ output = fluidRow( |
| 939 | +117 | ! |
- title = "Warning",+ htmlwidgets::getDependency("sparkline"), # needed for sparklines to work
|
| 940 | +118 | ! |
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ column( |
| 941 | -+ | ||
| 119 | +! |
- )+ 6, |
|
| 942 | +120 |
-
+ # variable browser |
|
| 943 | +121 | ! |
- teal.widgets::verbatim_popup_srv(+ teal.widgets::white_small_well( |
| 944 | +122 | ! |
- id = "rcode",+ do.call( |
| 945 | +123 | ! |
- verbatim_content = reactive(teal.code::get_code(output_q())),+ tabsetPanel, |
| 946 | +124 | ! |
- title = "R Code for scatterplot"- |
-
| 947 | -- |
- )- |
- |
| 948 | -- |
-
+ c( |
|
| 949 | -+ | ||
| 125 | +! |
- ### REPORTER+ id = ns("tabset_panel"),
|
|
| 950 | +126 | ! |
- if (with_reporter) {
+ do.call( |
| 951 | +127 | ! |
- card_fun <- function(comment) {
+ tagList, |
| 952 | +128 | ! |
- card <- teal::TealReportCard$new()+ lapply(datanames, function(dataname) {
|
| 953 | +129 | ! |
- card$set_name("Scatter Plot")
+ tabPanel( |
| 954 | +130 | ! |
- card$append_text("Scatter Plot", "header2")
+ dataname, |
| 955 | +131 | ! |
- if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ div( |
| 956 | +132 | ! |
- card$append_text("Plot", "header3")
+ class = "mt-4", |
| 957 | +133 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ textOutput(ns(paste0("dataset_summary_", dataname)))
|
| 958 | -! | +||
| 134 | +
- if (!comment == "") {
+ ), |
||
| 959 | +135 | ! |
- card$append_text("Comment", "header3")
+ div( |
| 960 | +136 | ! |
- card$append_text(comment)+ class = "mt-4", |
| 961 | -+ | ||
| 137 | +! |
- }+ teal.widgets::get_dt_rows( |
|
| 962 | +138 | ! |
- card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n"))+ ns(paste0( |
| 963 | +139 | ! |
- card+ "variable_browser_", dataname |
| 964 | +140 |
- }+ )), |
|
| 965 | +141 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ ns( |
| 966 | -+ | ||
| 142 | +! |
- }+ paste0("variable_browser_", dataname, "_rows")
|
|
| 967 | +143 |
- ###+ ) |
|
| 968 | +144 |
- })+ ), |
|
| 969 | -+ | ||
| 145 | +! |
- }+ DT::dataTableOutput(ns(paste0( |
| 1 | -+ | ||
| 146 | +! |
- #' Create a simple cross-table+ "variable_browser_", dataname |
|
| 2 | -+ | ||
| 147 | +! |
- #' @md+ )), width = "100%") |
|
| 3 | +148 |
- #'+ ) |
|
| 4 | +149 |
- #' @inheritParams teal::module+ ) |
|
| 5 | +150 |
- #' @inheritParams shared_params+ }) |
|
| 6 | +151 |
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ ) |
|
| 7 | +152 |
- #' Object with all available choices with pre-selected option for variable X - row values. In case+ ) |
|
| 8 | +153 |
- #' of `data_extract_spec` use `select_spec(..., ordered = TRUE)` if table elements should be+ ), |
|
| 9 | -+ | ||
| 154 | +! |
- #' rendered according to selection order.+ shinyjs::hidden({
|
|
| 10 | -+ | ||
| 155 | +! |
- #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ checkboxInput(ns("show_parent_vars"), "Show parent dataset variables", value = FALSE)
|
|
| 11 | +156 |
- #' Object with all available choices with pre-selected option for variable Y - column values+ }) |
|
| 12 | +157 |
- #' \code{data_extract_spec} must not allow multiple selection in this case.
+ ) |
|
| 13 | +158 |
- #'+ ), |
|
| 14 | -+ | ||
| 159 | +! |
- #' @param show_percentage optional, (`logical`) Whether to show percentages+ column( |
|
| 15 | -+ | ||
| 160 | +! |
- #' (relevant only when `x` is a `factor`). Defaults to `TRUE`.+ 6, |
|
| 16 | -+ | ||
| 161 | +! |
- #' @param show_total optional, (`logical`) Whether to show total column. Defaults to `TRUE`.+ teal.widgets::white_small_well( |
|
| 17 | +162 |
- #'+ ### Reporter |
|
| 18 | -+ | ||
| 163 | +! |
- #' @note For more examples, please see the vignette "Using cross table" via+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 19 | +164 |
- #' `vignette("using-cross-table", package = "teal.modules.general")`.
+ ### |
|
| 20 | -+ | ||
| 165 | +! |
- #'+ div( |
|
| 21 | -+ | ||
| 166 | +! |
- #' @export+ class = "block", |
|
| 22 | -+ | ||
| 167 | +! |
- #'+ uiOutput(ns("ui_histogram_display"))
|
|
| 23 | +168 |
- #' @examples+ ), |
|
| 24 | -+ | ||
| 169 | +! |
- #' # Percentage cross table of variables from ADSL dataset+ div( |
|
| 25 | -+ | ||
| 170 | +! |
- #'+ class = "block", |
|
| 26 | -+ | ||
| 171 | +! |
- #' ADSL <- teal.modules.general::rADSL+ uiOutput(ns("ui_numeric_display"))
|
|
| 27 | +172 |
- #'+ ), |
|
| 28 | -+ | ||
| 173 | +! |
- #' app <- teal::init(+ teal.widgets::plot_with_settings_ui(ns("variable_plot")),
|
|
| 29 | -+ | ||
| 174 | +! |
- #' data = teal.data::cdisc_data(+ br(), |
|
| 30 | +175 |
- #' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
+ # input user-defined text size |
|
| 31 | -+ | ||
| 176 | +! |
- #' check = TRUE+ teal.widgets::panel_item( |
|
| 32 | -+ | ||
| 177 | +! |
- #' ),+ title = "Plot settings", |
|
| 33 | -+ | ||
| 178 | +! |
- #' modules = teal::modules(+ collapsed = TRUE, |
|
| 34 | -+ | ||
| 179 | +! |
- #' teal.modules.general::tm_t_crosstable(+ selectInput( |
|
| 35 | -+ | ||
| 180 | +! |
- #' label = "Cross Table",+ inputId = ns("ggplot_theme"), label = "ggplot2 theme",
|
|
| 36 | -+ | ||
| 181 | +! |
- #' x = teal.transform::data_extract_spec(+ choices = c( |
|
| 37 | -+ | ||
| 182 | +! |
- #' dataname = "ADSL",+ "gray", "bw", "linedraw", "light", |
|
| 38 | -+ | ||
| 183 | +! |
- #' select = teal.transform::select_spec(+ "dark", "minimal", "classic", "void", "test" |
|
| 39 | +184 |
- #' label = "Select variable:",+ ), |
|
| 40 | -+ | ||
| 185 | +! |
- #' choices = variable_choices(ADSL, subset = function(data) {
+ selected = "grey" |
|
| 41 | +186 |
- #' idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt"))
+ ), |
|
| 42 | -+ | ||
| 187 | +! |
- #' return(names(data)[idx])+ fluidRow( |
|
| 43 | -+ | ||
| 188 | +! |
- #' }),+ column(6, sliderInput( |
|
| 44 | -+ | ||
| 189 | +! |
- #' selected = "COUNTRY",+ inputId = ns("font_size"), label = "font size",
|
|
| 45 | -+ | ||
| 190 | +! |
- #' multiple = TRUE,+ min = 5L, max = 30L, value = 15L, step = 1L, ticks = FALSE |
|
| 46 | +191 |
- #' ordered = TRUE,+ )), |
|
| 47 | -+ | ||
| 192 | +! |
- #' fixed = FALSE+ column(6, sliderInput( |
|
| 48 | -+ | ||
| 193 | +! |
- #' )+ inputId = ns("label_rotation"), label = "rotate x labels",
|
|
| 49 | -+ | ||
| 194 | +! |
- #' ),+ min = 0L, max = 90L, value = 45L, step = 1, ticks = FALSE |
|
| 50 | +195 |
- #' y = teal.transform::data_extract_spec(+ )) |
|
| 51 | +196 |
- #' dataname = "ADSL",+ ) |
|
| 52 | +197 |
- #' select = teal.transform::select_spec(+ ), |
|
| 53 | -+ | ||
| 198 | +! |
- #' label = "Select variable:",+ br(), |
|
| 54 | -+ | ||
| 199 | +! | +
+ teal.widgets::get_dt_rows(ns("variable_summary_table"), ns("variable_summary_table_rows")),
+ |
+ |
| 200 | +! |
- #' choices = variable_choices(ADSL, subset = function(data) {
+ DT::dataTableOutput(ns("variable_summary_table"))
|
|
| 55 | +201 |
- #' idx <- vapply(data, is.factor, logical(1))+ ) |
|
| 56 | +202 |
- #' return(names(data)[idx])+ ) |
|
| 57 | +203 |
- #' }),+ ), |
|
| 58 | -+ | ||
| 204 | +! |
- #' selected = "SEX",+ pre_output = pre_output, |
|
| 59 | -+ | ||
| 205 | +! |
- #' multiple = FALSE,+ post_output = post_output |
|
| 60 | +206 |
- #' fixed = FALSE+ ) |
|
| 61 | +207 |
- #' )+ ) |
|
| 62 | +208 |
- #' ),+ } |
|
| 63 | +209 |
- #' basic_table_args = teal.widgets::basic_table_args(+ |
|
| 64 | +210 |
- #' subtitles = "Table generated by Crosstable Module"+ srv_variable_browser <- function(id, |
|
| 65 | +211 |
- #' )+ data, |
|
| 66 | +212 |
- #' )+ reporter, |
|
| 67 | +213 |
- #' )+ filter_panel_api, |
|
| 68 | +214 |
- #' )+ datasets_selected, parent_dataname, ggplot2_args) {
|
|
| 69 | -+ | ||
| 215 | +! |
- #' if (interactive()) {
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 70 | -+ | ||
| 216 | +! |
- #' shinyApp(app$ui, app$server)+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 71 | -+ | ||
| 217 | +! |
- #' }+ checkmate::assert_class(data, "tdata") |
|
| 72 | -+ | ||
| 218 | +! |
- #'+ moduleServer(id, function(input, output, session) {
|
|
| 73 | +219 |
- tm_t_crosstable <- function(label = "Cross Table",+ # if there are < this number of unique records then a numeric |
|
| 74 | +220 |
- x,+ # variable can be treated as a factor and all factors with < this groups |
|
| 75 | +221 |
- y,+ # have their values plotted |
|
| 76 | -+ | ||
| 222 | +! |
- show_percentage = TRUE,+ .unique_records_for_factor <- 30 |
|
| 77 | +223 |
- show_total = TRUE,+ # if there are < this number of unique records then a numeric |
|
| 78 | +224 |
- pre_output = NULL,+ # variable is by default treated as a factor |
|
| 79 | -+ | ||
| 225 | +! |
- post_output = NULL,+ .unique_records_default_as_factor <- 6 # nolint |
|
| 80 | +226 |
- basic_table_args = teal.widgets::basic_table_args()) {
+
|
|
| 81 | +227 | ! |
- logger::log_info("Initializing tm_t_crosstable")
+ datanames <- names(data) |
| 82 | -! | +||
| 228 | +
- if (!requireNamespace("rtables", quietly = TRUE)) {
+
|
||
| 83 | +229 | ! |
- stop("Cannot load rtables - please install the package or restart your session.")
+ checkmate::assert_character(datasets_selected) |
| 84 | -+ | ||
| 230 | +! |
- }+ checkmate::assert_subset(datasets_selected, datanames) |
|
| 85 | +231 | ! |
- if (inherits(x, "data_extract_spec")) x <- list(x)+ if (length(datasets_selected) != 0L) {
|
| 86 | +232 | ! |
- if (inherits(y, "data_extract_spec")) y <- list(y)+ datanames <- datasets_selected |
| 87 | +233 |
-
+ } |
|
| 88 | -! | +||
| 234 | +
- checkmate::assert_string(label)+ |
||
| 89 | -! | +||
| 235 | +
- checkmate::assert_list(x, types = "data_extract_spec")+ # conditionally display checkbox |
||
| 90 | +236 | ! |
- checkmate::assert_list(y, types = "data_extract_spec")+ shinyjs::toggle( |
| 91 | +237 | ! |
- if (any(vapply(y, function(x) x$select$multiple, logical(1)))) {
+ id = "show_parent_vars", |
| 92 | +238 | ! |
- stop("'y' should not allow multiple selection")
+ condition = length(parent_dataname) > 0 && parent_dataname %in% datanames |
| 93 | +239 |
- }+ ) |
|
| 94 | -! | +||
| 240 | +
- checkmate::assert_flag(show_percentage)+ |
||
| 95 | +241 | ! |
- checkmate::assert_flag(show_total)+ columns_names <- new.env() # nolint |
| 96 | -! | +||
| 242 | +
- checkmate::assert_class(basic_table_args, classes = "basic_table_args")+ |
||
| 97 | +243 |
-
+ # plot_var$data holds the name of the currently selected dataset |
|
| 98 | -! | +||
| 244 | +
- ui_args <- as.list(environment())+ # plot_var$variable[[<dataset_name>]] holds the name of the currently selected |
||
| 99 | +245 |
-
+ # variable for dataset <dataset_name> |
|
| 100 | +246 | ! |
- server_args <- list(+ plot_var <- reactiveValues(data = NULL, variable = list()) |
| 101 | -! | +||
| 247 | +
- label = label,+ |
||
| 102 | +248 | ! |
- x = x,+ establish_updating_selection(datanames, input, plot_var, columns_names) |
| 103 | -! | +||
| 249 | +
- y = y,+ + |
+ ||
| 250 | ++ |
+ # validations |
|
| 104 | +251 | ! |
- basic_table_args = basic_table_args+ validation_checks <- validate_input(input, plot_var, data) |
| 105 | +252 |
- )+ |
|
| 106 | +253 |
-
+ # data_for_analysis is a list with two elements: a column from a dataset and the column label |
|
| 107 | +254 | ! |
- module(+ plotted_data <- reactive({
|
| 108 | +255 | ! |
- label = label,+ validation_checks() |
| 109 | -! | +||
| 256 | +
- server = srv_t_crosstable,+ |
||
| 110 | +257 | ! |
- ui = ui_t_crosstable,+ get_plotted_data(input, plot_var, data)+ |
+
| 258 | ++ |
+ })+ |
+ |
| 259 | ++ | + | |
| 111 | +260 | ! |
- ui_args = ui_args,+ treat_numeric_as_factor <- reactive({
|
| 112 | +261 | ! |
- server_args = server_args,+ if (is_num_var_short(.unique_records_for_factor, input, plotted_data)) {
|
| 113 | +262 | ! |
- datanames = teal.transform::get_extract_datanames(list(x = x, y = y))+ input$numeric_as_factor |
| 114 | +263 |
- )+ } else {
+ |
+ |
| 264 | +! | +
+ FALSE |
|
| 115 | +265 |
- }+ } |
|
| 116 | +266 |
-
+ }) |
|
| 117 | +267 |
- ui_t_crosstable <- function(id, x, y, show_percentage, show_total, pre_output, post_output, ...) {
+
|
|
| 118 | +268 | ! |
- ns <- NS(id)+ render_tabset_panel_content( |
| 119 | +269 | ! |
- is_single_dataset <- teal.transform::is_single_dataset(x, y)+ input = input, |
| 120 | -+ | ||
| 270 | +! |
-
+ output = output, |
|
| 121 | +271 | ! |
- join_default_options <- c(+ data = data, |
| 122 | +272 | ! |
- "Full Join" = "dplyr::full_join",+ datanames = datanames, |
| 123 | +273 | ! |
- "Inner Join" = "dplyr::inner_join",+ parent_dataname = parent_dataname, |
| 124 | +274 | ! |
- "Left Join" = "dplyr::left_join",+ columns_names = columns_names, |
| 125 | +275 | ! |
- "Right Join" = "dplyr::right_join"+ plot_var = plot_var |
| 126 | +276 |
- )+ ) |
|
| 127 | +277 |
-
+ # add used-defined text size to ggplot arguments passed from caller frame |
|
| 128 | +278 | ! |
- teal.widgets::standard_layout(+ all_ggplot2_args <- reactive({
|
| 129 | +279 | ! |
- output = teal.widgets::white_small_well(+ user_text <- teal.widgets::ggplot2_args( |
| 130 | +280 | ! |
- textOutput(ns("title")),
+ theme = list( |
| 131 | +281 | ! |
- teal.widgets::table_with_settings_ui(ns("table"))
+ "text" = ggplot2::element_text(size = input[["font_size"]]),+ |
+
| 282 | +! | +
+ "axis.text.x" = ggplot2::element_text(angle = input[["label_rotation"]], hjust = 1) |
|
| 132 | +283 |
- ),+ )+ |
+ |
| 284 | ++ |
+ ) |
|
| 133 | +285 | ! |
- encoding = div(+ user_theme <- utils::getFromNamespace(sprintf("theme_%s", input[["ggplot_theme"]]), ns = "ggplot2")
+ |
+
| 286 | +! | +
+ user_theme <- user_theme() |
|
| 134 | +287 |
- ### Reporter+ # temporary fix to circumvent assertion issue with resolve_ggplot2_args+ |
+ |
| 288 | ++ |
+ # drop problematic elements |
|
| 135 | +289 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ user_theme <- user_theme[grep("strip.text.y.left", names(user_theme), fixed = TRUE, invert = TRUE)]
|
| 136 | +290 |
- ###+ |
|
| 137 | +291 | ! |
- tags$label("Encodings", class = "text-primary"),
+ teal.widgets::resolve_ggplot2_args( |
| 138 | +292 | ! |
- teal.transform::datanames_input(list(x, y)),+ user_plot = user_text, |
| 139 | +293 | ! |
- teal.transform::data_extract_ui(ns("x"), label = "Row values", x, is_single_dataset = is_single_dataset),
+ user_default = teal.widgets::ggplot2_args(theme = user_theme), |
| 140 | +294 | ! |
- teal.transform::data_extract_ui(ns("y"), label = "Column values", y, is_single_dataset = is_single_dataset),
+ module_plot = ggplot2_args |
| 141 | -! | +||
| 295 | +
- teal.widgets::optionalSelectInput(+ ) |
||
| 142 | -! | +||
| 296 | +
- ns("join_fun"),
+ })+ |
+ ||
| 297 | ++ | + | |
| 143 | +298 | ! |
- label = "Row to Column type of join",+ output$ui_numeric_display <- renderUI({
|
| 144 | +299 | ! |
- choices = join_default_options,+ dataname <- input$tabset_panel |
| 145 | +300 | ! |
- selected = join_default_options[1],+ varname <- plot_var$variable[[input$tabset_panel]] |
| 146 | +301 | ! |
- multiple = FALSE+ req(data, varname) |
| 147 | +302 |
- ),+ |
|
| 148 | +303 | ! |
- tags$hr(),+ df <- data[[dataname]]() |
| 149 | -! | +||
| 304 | +
- teal.widgets::panel_group(+ |
||
| 150 | +305 | ! |
- teal.widgets::panel_item(+ numeric_ui <- tagList( |
| 151 | +306 | ! |
- title = "Table settings",+ fluidRow( |
| 152 | +307 | ! |
- checkboxInput(ns("show_percentage"), "Show column percentage", value = show_percentage),
+ div( |
| 153 | +308 | ! |
- checkboxInput(ns("show_total"), "Show total column", value = show_total)
- |
-
| 154 | -- |
- )- |
- |
| 155 | -- |
- )- |
- |
| 156 | -- |
- ),+ class = "col-md-4", |
|
| 157 | +309 | ! |
- forms = tagList(+ br(), |
| 158 | +310 | ! |
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+ shinyWidgets::switchInput( |
| 159 | +311 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ inputId = session$ns("display_density"),
|
| 160 | -+ | ||
| 312 | +! |
- ),+ label = "Show density", |
|
| 161 | +313 | ! |
- pre_output = pre_output,+ value = `if`(is.null(isolate(input$display_density)), TRUE, isolate(input$display_density)), |
| 162 | +314 | ! |
- post_output = post_output+ width = "50%", |
| 163 | -+ | ||
| 315 | +! |
- )+ labelWidth = "100px", |
|
| 164 | -+ | ||
| 316 | +! |
- }+ handleWidth = "50px" |
|
| 165 | +317 |
-
+ ) |
|
| 166 | +318 |
- srv_t_crosstable <- function(id, data, reporter, filter_panel_api, label, x, y, basic_table_args) {
+ ), |
|
| 167 | +319 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ div( |
| 168 | +320 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ class = "col-md-4", |
| 169 | +321 | ! |
- checkmate::assert_class(data, "tdata")+ br(), |
| 170 | +322 | ! |
- moduleServer(id, function(input, output, session) {
+ shinyWidgets::switchInput( |
| 171 | +323 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ inputId = session$ns("remove_outliers"),
|
| 172 | +324 | ! |
- data_extract = list(x = x, y = y),+ label = "Remove outliers", |
| 173 | +325 | ! |
- datasets = data,+ value = `if`(is.null(isolate(input$remove_outliers)), FALSE, isolate(input$remove_outliers)), |
| 174 | +326 | ! |
- select_validation_rule = list(+ width = "50%", |
| 175 | +327 | ! |
- x = shinyvalidate::sv_required("Please define column for row variable."),
+ labelWidth = "100px", |
| 176 | +328 | ! |
- y = shinyvalidate::sv_required("Please define column for column variable.")
+ handleWidth = "50px" |
| 177 | +329 |
- )+ ) |
|
| 178 | +330 |
- )+ ), |
|
| 179 | -+ | ||
| 331 | +! |
-
+ div( |
|
| 180 | +332 | ! |
- iv_r <- reactive({
+ class = "col-md-4", |
| 181 | +333 | ! |
- iv <- shinyvalidate::InputValidator$new()+ uiOutput(session$ns("outlier_definition_slider_ui"))
+ |
+
| 334 | ++ |
+ )+ |
+ |
| 335 | ++ |
+ ), |
|
| 182 | +336 | ! |
- iv$add_rule("join_fun", function(value) {
+ div( |
| 183 | +337 | ! |
- if (!identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
+ class = "ml-4", |
| 184 | +338 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ uiOutput(session$ns("ui_density_help")),
|
| 185 | +339 | ! |
- "Please select a joining function."+ uiOutput(session$ns("ui_outlier_help"))
|
| 186 | +340 |
- }+ ) |
|
| 187 | +341 |
- }+ ) |
|
| 188 | +342 |
- })+ |
|
| 189 | +343 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list)- |
-
| 190 | -- |
- })- |
- |
| 191 | -- |
-
+ if (is.numeric(df[[varname]])) {
|
|
| 192 | +344 | ! |
- observeEvent(+ unique_entries <- length(unique(df[[varname]])) |
| 193 | +345 | ! |
- eventExpr = {
+ if (unique_entries < .unique_records_for_factor && unique_entries > 0) {
|
| 194 | +346 | ! |
- req(!is.null(selector_list()$x()) && !is.null(selector_list()$y()))+ list( |
| 195 | +347 | ! |
- list(selector_list()$x(), selector_list()$y())+ checkboxInput( |
| 196 | -+ | ||
| 348 | +! |
- },+ session$ns("numeric_as_factor"),
|
|
| 197 | +349 | ! |
- handlerExpr = {
+ "Treat variable as factor", |
| 198 | +350 | ! |
- if (identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
+ value = `if`( |
| 199 | +351 | ! |
- shinyjs::hide("join_fun")
+ is.null(isolate(input$numeric_as_factor)), |
| 200 | -+ | ||
| 352 | +! |
- } else {
+ unique_entries < .unique_records_default_as_factor, |
|
| 201 | +353 | ! |
- shinyjs::show("join_fun")
+ isolate(input$numeric_as_factor) |
| 202 | +354 |
- }+ ) |
|
| 203 | +355 |
- }+ ), |
|
| 204 | -+ | ||
| 356 | +! |
- )+ conditionalPanel("!input.numeric_as_factor", ns = session$ns, numeric_ui)
|
|
| 205 | +357 |
-
+ ) |
|
| 206 | +358 | ! |
- merge_function <- reactive({
+ } else if (unique_entries > 0) {
|
| 207 | +359 | ! |
- if (is.null(input$join_fun)) {
+ numeric_ui |
| 208 | -! | +||
| 360 | +
- "dplyr::full_join"+ } |
||
| 209 | +361 |
} else {
|
|
| 210 | +362 | ! |
- input$join_fun+ NULL |
| 211 | +363 |
} |
|
| 212 | +364 |
}) |
|
| 213 | +365 | ||
| 214 | +366 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ output$ui_histogram_display <- renderUI({
|
| 215 | +367 | ! |
- datasets = data,+ dataname <- input$tabset_panel |
| 216 | +368 | ! |
- join_keys = get_join_keys(data),+ varname <- plot_var$variable[[input$tabset_panel]] |
| 217 | +369 | ! |
- selector_list = selector_list,+ req(data, varname)+ |
+
| 370 | ++ | + | |
| 218 | +371 | ! |
- merge_function = merge_function+ df <- data[[dataname]]() |
| 219 | +372 |
- )+ |
|
| 220 | -+ | ||
| 373 | +! |
-
+ numeric_ui <- tagList(fluidRow( |
|
| 221 | +374 | ! |
- anl_merged_q <- reactive({
+ div( |
| 222 | +375 | ! |
- req(anl_merged_input())+ class = "col-md-4", |
| 223 | +376 | ! |
- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>%+ shinyWidgets::switchInput( |
| 224 | +377 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ inputId = session$ns("remove_NA_hist"),
|
| 225 | -+ | ||
| 378 | +! |
- })+ label = "Remove NA values", |
|
| 226 | -+ | ||
| 379 | +! |
-
+ value = FALSE, |
|
| 227 | +380 | ! |
- merged <- list(+ width = "50%", |
| 228 | +381 | ! |
- anl_input_r = anl_merged_input,+ labelWidth = "100px", |
| 229 | +382 | ! |
- anl_q_r = anl_merged_q+ handleWidth = "50px" |
| 230 | +383 |
- )+ ) |
|
| 231 | +384 |
-
+ ) |
|
| 232 | -! | +||
| 385 | +
- output_q <- reactive({
+ ))+ |
+ ||
| 386 | ++ | + | |
| 233 | +387 | ! |
- teal::validate_inputs(iv_r())+ var <- df[[varname]] |
| 234 | +388 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint+ if (anyNA(var) && (is.factor(var) || is.character(var) || is.logical(var))) {
|
| 235 | -+ | ||
| 389 | +! |
-
+ groups <- unique(as.character(var)) |
|
| 236 | -+ | ||
| 390 | +! |
- # As this is a summary+ len_groups <- length(groups) |
|
| 237 | +391 | ! |
- x_name <- as.vector(merged$anl_input_r()$columns_source$x)+ if (len_groups >= .unique_records_for_factor) {
|
| 238 | +392 | ! |
- y_name <- as.vector(merged$anl_input_r()$columns_source$y)+ NULL |
| 239 | +393 | - - | -|
| 240 | -! | -
- teal::validate_has_data(ANL, 3)+ } else {
|
|
| 241 | +394 | ! |
- teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE)+ numeric_ui |
| 242 | +395 |
-
+ } |
|
| 243 | -! | +||
| 396 | +
- is_allowed_class <- function(x) is.numeric(x) || is.factor(x) || is.character(x) || is.logical(x)+ } else {
|
||
| 244 | +397 | ! |
- validate(need(+ NULL |
| 245 | -! | +||
| 398 | +
- all(vapply(ANL[x_name], is_allowed_class, logical(1))),+ } |
||
| 246 | -! | +||
| 399 | +
- "Selected row variable has an unsupported data type."+ }) |
||
| 247 | +400 |
- ))+ |
|
| 248 | +401 | ! |
- validate(need(+ output$outlier_definition_slider_ui <- renderUI({
|
| 249 | +402 | ! |
- is_allowed_class(ANL[[y_name]]),+ req(input$remove_outliers) |
| 250 | +403 | ! |
- "Selected column variable has an unsupported data type."+ sliderInput( |
| 251 | -+ | ||
| 404 | +! |
- ))+ inputId = session$ns("outlier_definition_slider"),
|
|
| 252 | -+ | ||
| 405 | +! |
-
+ div( |
|
| 253 | +406 | ! |
- show_percentage <- input$show_percentage # nolint+ class = "teal-tooltip", |
| 254 | +407 | ! |
- show_total <- input$show_total # nolint+ tagList( |
| 255 | -+ | ||
| 408 | +! |
-
+ "Outlier definition:", |
|
| 256 | +409 | ! |
- plot_title <- paste(+ icon("circle-info"),
|
| 257 | +410 | ! |
- "Cross-Table of",+ span( |
| 258 | +411 | ! |
- paste0(varname_w_label(x_name, ANL), collapse = ", "),+ class = "tooltiptext", |
| 259 | +412 | ! |
- "(rows)", "vs.",+ paste( |
| 260 | +413 | ! |
- varname_w_label(y_name, ANL),+ "Use the slider to choose the cut-off value to define outliers; the larger the value the", |
| 261 | +414 | ! |
- "(columns)"+ "further below Q1/above Q3 points have to be in order to be classed as outliers" |
| 262 | +415 |
- )+ ) |
|
| 263 | +416 |
-
+ ) |
|
| 264 | -! | +||
| 417 | +
- labels_vec <- vapply(+ )+ |
+ ||
| 418 | ++ |
+ ), |
|
| 265 | +419 | ! |
- x_name,+ min = 1, |
| 266 | +420 | ! |
- varname_w_label,+ max = 5, |
| 267 | +421 | ! |
- character(1),+ value = 3, |
| 268 | +422 | ! |
- ANL+ step = 0.5 |
| 269 | +423 |
) |
|
| 270 | +424 | ++ |
+ })+ |
+
| 425 | |||
| 271 | +426 | ! |
- teal.code::eval_code(+ output$ui_density_help <- renderUI({
|
| 272 | +427 | ! |
- merged$anl_q_r(),+ req(is.logical(input$display_density)) |
| 273 | +428 | ! |
- substitute(+ if (input$display_density) {
|
| 274 | +429 | ! |
- expr = {
+ tags$small(helpText(paste( |
| 275 | +430 | ! |
- title <- plot_title+ "Kernel density estimation with gaussian kernel",+ |
+
| 431 | +! | +
+ "and bandwidth function bw.nrd0 (R default)" |
|
| 276 | +432 |
- },+ )))+ |
+ |
| 433 | ++ |
+ } else {
|
|
| 277 | +434 | ! |
- env = list(plot_title = plot_title)+ NULL |
| 278 | +435 |
- )+ } |
|
| 279 | +436 |
- ) %>%+ }) |
|
| 280 | -! | +||
| 437 | +
- teal.code::eval_code(+ |
||
| 281 | +438 | ! |
- substitute(+ output$ui_outlier_help <- renderUI({
|
| 282 | +439 | ! |
- expr = {
+ req(is.logical(input$remove_outliers), input$outlier_definition_slider) |
| 283 | +440 | ! |
- lyt <- basic_tables %>%+ if (input$remove_outliers) {
|
| 284 | +441 | ! |
- split_call %>% # styler: off+ tags$small( |
| 285 | +442 | ! |
- rtables::add_colcounts() %>%+ helpText( |
| 286 | +443 | ! |
- tern::analyze_vars(+ withMathJax(paste0( |
| 287 | +444 | ! |
- vars = x_name,+ "Outlier data points (\\( X \\lt Q1 - ", input$outlier_definition_slider, "\\times IQR \\) or |
| 288 | +445 | ! |
- var_labels = labels_vec,+ \\(Q3 + ", input$outlier_definition_slider, "\\times IQR \\lt X\\)) |
| 289 | +446 | ! |
- na.rm = FALSE,+ have not been displayed on the graph and will not be used for any kernel density estimations, ", |
| 290 | +447 | ! |
- denom = "N_col",+ "although their values remain in the statisics table below." |
| 291 | -! | +||
| 448 | +
- .stats = c("mean_sd", "median", "range", count_value)
+ )) |
||
| 292 | +449 |
- )+ ) |
|
| 293 | +450 |
- },+ ) |
|
| 294 | -! | +||
| 451 | +
- env = list(+ } else {
|
||
| 295 | +452 | ! |
- basic_tables = teal.widgets::parse_basic_table_args(+ NULL |
| 296 | -! | +||
| 453 | +
- basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args)+ } |
||
| 297 | +454 |
- ),+ }) |
|
| 298 | -! | +||
| 455 | +
- split_call = if (show_total) {
+
|
||
| 299 | -! | +||
| 456 | +
- substitute(+ |
||
| 300 | +457 | ! |
- expr = rtables::split_cols_by(+ variable_plot_r <- reactive({
|
| 301 | +458 | ! |
- y_name,+ display_density <- `if`(is.null(input$display_density), FALSE, input$display_density) |
| 302 | +459 | ! |
- split_fun = rtables::add_overall_level(label = "Total", first = FALSE)+ remove_outliers <- `if`(is.null(input$remove_outliers), FALSE, input$remove_outliers) |
| 303 | +460 |
- ),+ |
|
| 304 | +461 | ! |
- env = list(y_name = y_name)- |
-
| 305 | -- |
- )- |
- |
| 306 | -- |
- } else {
+ if (remove_outliers) {
|
|
| 307 | +462 | ! |
- substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name))- |
-
| 308 | -- |
- },+ req(input$outlier_definition_slider) |
|
| 309 | +463 | ! |
- x_name = x_name,+ outlier_definition <- as.numeric(input$outlier_definition_slider) |
| 310 | -! | +||
| 464 | +
- labels_vec = labels_vec,+ } else {
|
||
| 311 | +465 | ! |
- count_value = ifelse(show_percentage, "count_fraction", "count")+ outlier_definition <- 0 |
| 312 | +466 |
- )+ } |
|
| 313 | +467 |
- )+ |
|
| 314 | -+ | ||
| 468 | +! |
- ) %>%+ plot_var_summary( |
|
| 315 | +469 | ! |
- teal.code::eval_code(+ var = plotted_data()$data, |
| 316 | +470 | ! |
- substitute(+ var_lab = plotted_data()$var_description, |
| 317 | +471 | ! |
- expr = {
+ wrap_character = 15, |
| 318 | +472 | ! |
- ANL <- tern::df_explicit_na(ANL) # nolint+ numeric_as_factor = treat_numeric_as_factor(), |
| 319 | +473 | ! |
- tbl <- rtables::build_table(lyt = lyt, df = ANL[order(ANL[[y_name]]), ])+ remove_NA_hist = input$remove_NA_hist, |
| 320 | +474 | ! |
- tbl+ display_density = display_density, |
| 321 | -+ | ||
| 475 | +! |
- },+ outlier_definition = outlier_definition, |
|
| 322 | +476 | ! |
- env = list(y_name = y_name)+ records_for_factor = .unique_records_for_factor, |
| 323 | -+ | ||
| 477 | +! |
- )+ ggplot2_args = all_ggplot2_args() |
|
| 324 | +478 |
- )+ ) |
|
| 325 | +479 |
}) |
|
| 326 | +480 | ||
| 327 | +481 | ! |
- output$title <- renderText(output_q()[["title"]])- |
-
| 328 | -- |
-
+ pws <- teal.widgets::plot_with_settings_srv( |
|
| 329 | +482 | ! |
- table_r <- reactive({
+ id = "variable_plot", |
| 330 | +483 | ! |
- shiny::req(iv_r()$is_valid())+ plot_r = variable_plot_r, |
| 331 | +484 | ! |
- output_q()[["tbl"]]+ height = c(500, 200, 2000) |
| 332 | +485 |
- })+ ) |
|
| 333 | +486 | ||
| 334 | +487 | ! |
- teal.widgets::table_with_settings_srv(+ output$variable_summary_table <- DT::renderDataTable({
|
| 335 | +488 | ! |
- id = "table",+ var_summary_table( |
| 336 | +489 | ! |
- table_r = table_r- |
-
| 337 | -- |
- )- |
- |
| 338 | -- |
-
+ plotted_data()$data, |
|
| 339 | +490 | ! |
- teal.widgets::verbatim_popup_srv(+ treat_numeric_as_factor(), |
| 340 | +491 | ! |
- id = "warning",+ input$variable_summary_table_rows, |
| 341 | +492 | ! |
- verbatim_content = reactive(teal.code::get_warnings(output_q())),+ if (!is.null(input$remove_outliers) && input$remove_outliers) {
|
| 342 | +493 | ! |
- title = "Warning",+ req(input$outlier_definition_slider) |
| 343 | +494 | ! |
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))- |
-
| 344 | -- |
- )+ as.numeric(input$outlier_definition_slider) |
|
| 345 | +495 | - - | -|
| 346 | -! | -
- teal.widgets::verbatim_popup_srv(+ } else {
|
|
| 347 | +496 | ! |
- id = "rcode",- |
-
| 348 | -! | +||
| 497 | +
- verbatim_content = reactive(teal.code::get_code(output_q())),+ } |
||
| 349 | -! | +||
| 498 | +
- title = "Show R Code for Cross-Table"+ ) |
||
| 350 | +499 |
- )+ }) |
|
| 351 | +500 | ||
| 352 | +501 |
### REPORTER |
|
| 353 | +502 | ! |
if (with_reporter) {
|
| 354 | +503 | ! |
- card_fun <- function(comment) {
+ card_fun <- function(comment, label) {
|
| 355 | +504 | ! |
- card <- teal::TealReportCard$new()+ card <- teal::report_card_template( |
| 356 | +505 | ! |
- card$set_name("Cross Table")
+ title = "Variable Browser Plot", |
| 357 | +506 | ! |
- card$append_text("Cross Table", "header2")
+ label = label, |
| 358 | +507 | ! |
- if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ with_filter = with_filter, |
| 359 | +508 | ! |
- card$append_text("Table", "header3")
+ filter_panel_api = filter_panel_api+ |
+
| 509 | ++ |
+ ) |
|
| 360 | +510 | ! |
- card$append_table(table_r())+ card$append_text("Plot", "header3")
|
| 361 | +511 | +! | +
+ card$append_plot(variable_plot_r(), dim = pws$dim())+ |
+
| 512 | ! |
if (!comment == "") {
|
|
| 362 | +513 | ! |
card$append_text("Comment", "header3")
|
| 363 | +514 | ! |
card$append_text(comment) |
| 364 | +515 |
} |
|
| 365 | -! | -
- card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n"))- |
- |
| 366 | +516 | ! |
card |
| 367 | +517 |
} |
|
| 368 | +518 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 369 | +519 |
} |
|
| 370 | +520 |
### |
|
| 371 | +521 |
}) |
|
| 372 | +522 |
} |
| 1 | +523 |
- #' Principal component analysis module+ |
|
| 2 | +524 |
- #' @md+ #' Summarizes missings occurrence |
|
| 3 | +525 |
#' |
|
| 4 | +526 |
- #' @inheritParams teal::module+ #' Summarizes missings occurrence in vector |
|
| 5 | +527 |
- #' @inheritParams shared_params+ #' @param x vector of any type and length |
|
| 6 | +528 |
- #' @param dat (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ #' @return text describing \code{NA} occurrence.
|
|
| 7 | +529 |
- #' Columns used to compute PCA.+ #' @keywords internal |
|
| 8 | +530 |
- #' @param alpha optional, (`numeric`) If scalar then the plot points will have a fixed opacity. If a+ var_missings_info <- function(x) {
|
|
| 9 | -+ | ||
| 531 | +! |
- #' slider should be presented to adjust the plot point opacity dynamically then it can be a vector of+ return(sprintf("%s [%s%%]", sum(is.na(x)), round(mean(is.na(x) * 100), 2)))
|
|
| 10 | +532 |
- #' length three with `c(value, min, max)`.+ } |
|
| 11 | +533 |
- #' @param size optional, (`numeric`) If scalar then the plot point sizes will have a fixed size.+ |
|
| 12 | +534 |
- #' If a slider should be presented to adjust the plot point sizes dynamically then it can be a+ #' S3 generic for \code{sparkline} widget HTML
|
|
| 13 | +535 |
- #' vector of length three with `c(value, min, max)`.+ #' |
|
| 14 | +536 |
- #' @param font_size optional, (`numeric`) font size control for title, x-axis label, y-axis label and legend.+ #' Generates the \code{sparkline} HTML code corresponding to the input array.
|
|
| 15 | +537 |
- #' If scalar then the font size will have a fixed size. If a slider should be presented to adjust the plot+ #' For numeric variables creates a box plot, for character and factors - bar plot. |
|
| 16 | +538 |
- #' point sizes dynamically then it can be a vector of length three with `c(value, min, max)`.+ #' Produces an empty string for variables of other types. |
|
| 17 | +539 |
#' |
|
| 18 | +540 |
- #' @templateVar ggnames "Elbow plot", "Circle plot", "Biplot", "Eigenvector plot"+ #' @param arr vector of any type and length |
|
| 19 | +541 |
- #' @template ggplot2_args_multi+ #' @param width \code{numeric} the width of the \code{sparkline} widget (pixels)
|
|
| 20 | +542 |
- #'+ #' @param ... \code{list} additional options passed to bar plots of \code{jquery.sparkline}; see
|
|
| 21 | +543 |
- #' @export+ #' \href{https://omnipotent.net/jquery.sparkline/#common}{\code{jquery.sparkline docs}}
|
|
| 22 | +544 |
#' |
|
| 23 | +545 |
- #' @examples+ #' @return character variable containing the HTML code of the \code{sparkline} HTML widget
|
|
| 24 | +546 |
- #'+ #' @keywords internal |
|
| 25 | +547 |
- #' # ADSL example+ #' |
|
| 26 | +548 |
- #'+ create_sparklines <- function(arr, width = 150, ...) {
|
|
| 27 | -+ | ||
| 549 | +! |
- #' library(nestcolor)+ if (all(is.null(arr))) {
|
|
| 28 | -+ | ||
| 550 | +! |
- #' ADSL <- teal.modules.general::rADSL+ return("")
|
|
| 29 | +551 |
- #'+ } |
|
| 30 | -+ | ||
| 552 | +! |
- #' app <- teal::init(+ UseMethod("create_sparklines")
|
|
| 31 | +553 |
- #' data = teal.data::cdisc_data(+ } |
|
| 32 | +554 |
- #' teal.data::cdisc_dataset(+ |
|
| 33 | +555 |
- #' "ADSL", ADSL,+ #' Default method for \code{\link{create_sparklines}}
|
|
| 34 | +556 |
- #' code = "ADSL <- teal.modules.general::rADSL"+ #' |
|
| 35 | +557 |
- #' ),+ #' |
|
| 36 | +558 |
- #' check = TRUE+ #' @export |
|
| 37 | +559 |
- #' ),+ #' @keywords internal |
|
| 38 | +560 |
- #' modules = teal::modules(+ #' @rdname create_sparklines |
|
| 39 | +561 |
- #' teal.modules.general::tm_a_pca(+ create_sparklines.default <- function(arr, width = 150, ...) { # nolint
|
|
| 40 | -+ | ||
| 562 | +! |
- #' "PCA",+ return(as.character(tags$code("unsupported variable type", class = "text-blue")))
|
|
| 41 | +563 |
- #' dat = teal.transform::data_extract_spec(+ } |
|
| 42 | +564 |
- #' dataname = "ADSL",+ |
|
| 43 | +565 |
- #' select = teal.transform::select_spec(+ #' Generates the HTML code for the \code{sparkline} widget
|
|
| 44 | +566 |
- #' choices = teal.transform::variable_choices(data = ADSL, c("BMRKR1", "AGE", "EOSDY")),
+ #' |
|
| 45 | +567 |
- #' selected = c("BMRKR1", "AGE"),
+ #' @param bar_spacing \code{numeric} the spacing between the bars (in pixels)
|
|
| 46 | +568 |
- #' multiple = TRUE+ #' @param bar_width \code{numeric} the width of the bars (in pixels)
|
|
| 47 | +569 |
- #' ),+ #' |
|
| 48 | +570 |
- #' filter = NULL+ #' @return \code{character} with HTML code for the \code{sparkline} widget
|
|
| 49 | +571 |
- #' ),+ #' |
|
| 50 | +572 |
- #' ggplot2_args = teal.widgets::ggplot2_args(+ #' @export |
|
| 51 | +573 |
- #' labs = list(subtitle = "Plot generated by PCA Module")+ #' @keywords internal |
|
| 52 | +574 |
- #' )+ #' @rdname create_sparklines |
|
| 53 | +575 |
- #' )+ create_sparklines.Date <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) { # nolint
+ |
+ |
| 576 | +! | +
+ arr_num <- as.numeric(arr)+ |
+ |
| 577 | +! | +
+ arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")+ |
+ |
| 578 | +! | +
+ binwidth <- get_bin_width(arr_num, 1)+ |
+ |
| 579 | +! | +
+ bins <- floor(diff(range(arr_num)) / binwidth) + 1+ |
+ |
| 580 | +! | +
+ if (all(is.na(bins))) {
+ |
+ |
| 581 | +! | +
+ return(as.character(tags$code("only NA", class = "text-blue")))
+ |
+ |
| 582 | +! | +
+ } else if (bins == 1) {
+ |
+ |
| 583 | +! | +
+ return(as.character(tags$code("one date", class = "text-blue")))
|
|
| 54 | +584 |
- #' )+ }+ |
+ |
| 585 | +! | +
+ counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))+ |
+ |
| 586 | +! | +
+ max_value <- max(counts) |
|
| 55 | +587 |
- #' )+ + |
+ |
| 588 | +! | +
+ start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))+ |
+ |
| 589 | +! | +
+ labels_start <- as.character(as.Date(arr_num[start_bins], origin = as.Date("1970-01-01")))
+ |
+ |
| 590 | +! | +
+ labels <- paste("Start:", labels_start)
|
|
| 56 | +591 |
- #' if (interactive()) {
+
+ |
+ |
| 592 | +! | +
+ sparkline::spk_chr(+ |
+ |
| 593 | +! | +
+ unname(counts),+ |
+ |
| 594 | +! | +
+ type = "bar",+ |
+ |
| 595 | +! | +
+ chartRangeMin = 0,+ |
+ |
| 596 | +! | +
+ chartRangeMax = max_value,+ |
+ |
| 597 | +! | +
+ width = width,+ |
+ |
| 598 | +! | +
+ barWidth = bar_width,+ |
+ |
| 599 | +! | +
+ barSpacing = bar_spacing,+ |
+ |
| 600 | +! | +
+ tooltipFormatter = custom_sparkline_formatter(labels, counts) |
|
| 57 | +601 |
- #' shinyApp(app$ui, app$server)+ ) |
|
| 58 | +602 |
- #' }+ } |
|
| 59 | +603 |
- #'+ |
|
| 60 | +604 |
- tm_a_pca <- function(label = "Principal Component Analysis",+ #' Generates the HTML code for the \code{sparkline} widget
|
|
| 61 | +605 |
- dat,+ #' |
|
| 62 | +606 |
- plot_height = c(600, 200, 2000),+ #' |
|
| 63 | +607 |
- plot_width = NULL,+ #' @param bar_spacing \code{numeric} the spacing between the bars (in pixels)
|
|
| 64 | +608 |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
+ #' @param bar_width \code{numeric} the width of the bars (in pixels)
|
|
| 65 | +609 |
- ggplot2_args = teal.widgets::ggplot2_args(),+ #' |
|
| 66 | +610 |
- rotate_xaxis_labels = FALSE,+ #' @return \code{character} with HTML code for the \code{sparkline} widget
|
|
| 67 | +611 |
- font_size = c(12, 8, 20),+ #' |
|
| 68 | +612 |
- alpha = c(1, 0, 1),+ #' @export |
|
| 69 | +613 |
- size = c(2, 1, 8),+ #' @keywords internal |
|
| 70 | +614 |
- pre_output = NULL,+ #' @rdname create_sparklines |
|
| 71 | +615 |
- post_output = NULL) {
+ create_sparklines.POSIXct <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) { # nolint
|
|
| 72 | +616 | ! |
- logger::log_info("Initializing tm_a_pca")
+ arr_num <- as.numeric(arr) |
| 73 | +617 | ! |
- if (inherits(dat, "data_extract_spec")) dat <- list(dat)+ arr_num <- sort(arr_num, decreasing = FALSE, method = "radix") |
| 74 | +618 | ! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ binwidth <- get_bin_width(arr_num, 1) |
| 75 | -+ | ||
| 619 | +! |
-
+ bins <- floor(diff(range(arr_num)) / binwidth) + 1 |
|
| 76 | +620 | ! |
- checkmate::assert_string(label)+ if (all(is.na(bins))) {
|
| 77 | +621 | ! |
- checkmate::assert_list(dat, types = "data_extract_spec")+ return(as.character(tags$code("only NA", class = "text-blue")))
|
| 78 | +622 | ! |
- ggtheme <- match.arg(ggtheme)+ } else if (bins == 1) {
|
| 79 | +623 | ! |
- checkmate::assert_flag(rotate_xaxis_labels)+ return(as.character(tags$code("one date-time", class = "text-blue")))
|
| 80 | +624 |
-
+ } |
|
| 81 | +625 | ! |
- if (length(alpha) == 1) {
+ counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins)))) |
| 82 | +626 | ! |
- checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1)+ max_value <- max(counts) |
| 83 | +627 |
- } else {
+
|
|
| 84 | +628 | ! |
- checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1)+ start_bins <- as.integer(seq(1, length(arr_num), length.out = bins)) |
| 85 | +629 | ! |
- checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")+ labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
|
| 86 | -+ | ||
| 630 | +! |
- }+ labels <- paste("Start:", labels_start)
|
|
| 87 | +631 | ||
| 88 | +632 | ! |
- if (length(size) == 1) {
+ sparkline::spk_chr( |
| 89 | +633 | ! |
- checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8)+ unname(counts), |
| 90 | -+ | ||
| 634 | +! |
- } else {
+ type = "bar", |
|
| 91 | +635 | ! |
- checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8)+ chartRangeMin = 0, |
| 92 | +636 | ! |
- checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")+ chartRangeMax = max_value,+ |
+
| 637 | +! | +
+ width = width,+ |
+ |
| 638 | +! | +
+ barWidth = bar_width,+ |
+ |
| 639 | +! | +
+ barSpacing = bar_spacing,+ |
+ |
| 640 | +! | +
+ tooltipFormatter = custom_sparkline_formatter(labels, counts) |
|
| 93 | +641 |
- }+ ) |
|
| 94 | +642 | ++ |
+ }+ |
+
| 643 | |||
| 95 | -! | +||
| 644 | +
- if (length(font_size) == 1) {
+ #' Generates the HTML code for the \code{sparkline} widget
|
||
| 96 | -! | +||
| 645 | +
- checkmate::assert_numeric(font_size, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20)+ #' |
||
| 97 | +646 |
- } else {
+ #' |
|
| 98 | -! | +||
| 647 | +
- checkmate::assert_numeric(font_size, len = 3, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20)+ #' @param bar_spacing \code{numeric} the spacing between the bars (in pixels)
|
||
| 99 | -! | +||
| 648 | +
- checkmate::assert_numeric(font_size[1], lower = font_size[2], upper = font_size[3], .var.name = "font_size")+ #' @param bar_width \code{numeric} the width of the bars (in pixels)
|
||
| 100 | +649 |
- }+ #' |
|
| 101 | +650 |
-
+ #' @return \code{character} with HTML code for the \code{sparkline} widget
|
|
| 102 | -! | +||
| 651 | +
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ #'+ |
+ ||
| 652 | ++ |
+ #' @export+ |
+ |
| 653 | ++ |
+ #' @keywords internal+ |
+ |
| 654 | ++ |
+ #' @rdname create_sparklines+ |
+ |
| 655 | ++ |
+ create_sparklines.POSIXlt <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) { # nolint
|
|
| 103 | +656 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ arr_num <- as.numeric(arr) |
| 104 | +657 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ arr_num <- sort(arr_num, decreasing = FALSE, method = "radix") |
| 105 | +658 | ! |
- checkmate::assert_numeric(+ binwidth <- get_bin_width(arr_num, 1) |
| 106 | +659 | ! |
- plot_width[1],+ bins <- floor(diff(range(arr_num)) / binwidth) + 1 |
| 107 | +660 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ if (all(is.na(bins))) {
|
| 108 | -+ | ||
| 661 | +! |
- )+ return(as.character(tags$code("only NA", class = "text-blue")))
|
|
| 109 | -+ | ||
| 662 | +! |
-
+ } else if (bins == 1) {
|
|
| 110 | +663 | ! |
- plot_choices <- c("Elbow plot", "Circle plot", "Biplot", "Eigenvector plot")
+ return(as.character(tags$code("one date-time", class = "text-blue")))
+ |
+
| 664 | ++ |
+ } |
|
| 111 | +665 | ! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins)))) |
| 112 | +666 | ! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ max_value <- max(counts) |
| 113 | +667 | ||
| 114 | +668 | ! |
- args <- as.list(environment())+ start_bins <- as.integer(seq(1, length(arr_num), length.out = bins)) |
| 115 | -+ | ||
| 669 | +! |
-
+ labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
|
|
| 116 | +670 | ! |
- data_extract_list <- list(dat = dat)+ labels <- paste("Start:", labels_start)
|
| 117 | +671 | ||
| 118 | +672 | ! |
- module(+ sparkline::spk_chr( |
| 119 | +673 | ! |
- label = label,+ unname(counts), |
| 120 | +674 | ! |
- server = srv_a_pca,+ type = "bar", |
| 121 | +675 | ! |
- ui = ui_a_pca,+ chartRangeMin = 0, |
| 122 | +676 | ! |
- ui_args = args,+ chartRangeMax = max_value, |
| 123 | +677 | ! |
- server_args = c(+ width = width, |
| 124 | +678 | ! |
- data_extract_list,+ barWidth = bar_width, |
| 125 | +679 | ! |
- list(+ barSpacing = bar_spacing, |
| 126 | +680 | ! |
- plot_height = plot_height,+ tooltipFormatter = custom_sparkline_formatter(labels, counts) |
| 127 | -! | +||
| 681 | +
- plot_width = plot_width,+ ) |
||
| 128 | -! | +||
| 682 | +
- ggplot2_args = ggplot2_args+ } |
||
| 129 | +683 |
- )+ |
|
| 130 | +684 |
- ),+ |
|
| 131 | -! | +||
| 685 | +
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ #' Generates the HTML code for the \code{sparkline} widget
|
||
| 132 | +686 |
- )+ #' |
|
| 133 | +687 |
- }+ #' Coerces a character vector to factor and delegates to the \code{create_sparklines.factor}
|
|
| 134 | +688 |
-
+ #' |
|
| 135 | +689 |
-
+ #' |
|
| 136 | +690 |
- ui_a_pca <- function(id, ...) {
+ #' @return \code{character} with HTML code for the \code{sparkline} widget
|
|
| 137 | -! | +||
| 691 | +
- ns <- NS(id)+ #' |
||
| 138 | -! | +||
| 692 | +
- args <- list(...)+ #' @export |
||
| 139 | -! | +||
| 693 | +
- is_single_dataset_value <- teal.transform::is_single_dataset(args$dat)+ #' @keywords internal |
||
| 140 | +694 |
-
+ #' @rdname create_sparklines |
|
| 141 | -! | +||
| 695 | +
- color_selector <- args$dat+ create_sparklines.character <- function(arr, ...) { # nolint
|
||
| 142 | +696 | ! |
- for (i in seq_along(color_selector)) {
+ return(create_sparklines(as.factor(arr))) |
| 143 | -! | +||
| 697 | +
- color_selector[[i]]$select$multiple <- FALSE+ } |
||
| 144 | -! | +||
| 698 | +
- color_selector[[i]]$select$always_selected <- NULL+ |
||
| 145 | -! | +||
| 699 | +
- color_selector[[i]]$select$selected <- NULL+ |
||
| 146 | +700 |
- }+ #' Generates the HTML code for the \code{sparkline} widget
|
|
| 147 | +701 |
-
+ #' |
|
| 148 | -! | +||
| 702 | +
- shiny::tagList(+ #' Coerces logical vector to factor and delegates to the \code{create_sparklines.factor}
|
||
| 149 | -! | +||
| 703 | +
- include_css_files("custom"),
+ #' |
||
| 150 | -! | +||
| 704 | ++ |
+ #'+ |
+ |
| 705 | +
- teal.widgets::standard_layout(+ #' @return \code{character} with HTML code for the \code{sparkline} widget
|
||
| 151 | -! | +||
| 706 | +
- output = teal.widgets::white_small_well(+ #' |
||
| 152 | -! | +||
| 707 | +
- uiOutput(ns("all_plots"))
+ #' @export |
||
| 153 | +708 |
- ),+ #' @keywords internal |
|
| 154 | -! | +||
| 709 | +
- encoding = div(+ #' @rdname create_sparklines |
||
| 155 | +710 |
- ### Reporter+ create_sparklines.logical <- function(arr, ...) { # nolint
|
|
| 156 | +711 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ return(create_sparklines(as.factor(arr))) |
| 157 | +712 |
- ###+ } |
|
| 158 | -! | +||
| 713 | +
- tags$label("Encodings", class = "text-primary"),
+
|
||
| 159 | -! | +||
| 714 | +
- teal.transform::datanames_input(args["dat"]),+ |
||
| 160 | -! | +||
| 715 | +
- teal.transform::data_extract_ui(+ #' Generates the \code{sparkline} HTML code
|
||
| 161 | -! | +||
| 716 | +
- id = ns("dat"),
+ #' |
||
| 162 | -! | +||
| 717 | +
- label = "Data selection",+ #' @param bar_spacing \code{numeric} spacing between the bars (in pixels)
|
||
| 163 | -! | +||
| 718 | +
- data_extract_spec = args$dat,+ #' @param bar_width \code{numeric} width of the bars (in pixels)
|
||
| 164 | -! | +||
| 719 | +
- is_single_dataset = is_single_dataset_value+ #' |
||
| 165 | +720 |
- ),+ #' @return \code{character} with HTML code for the \code{sparkline} widget
|
|
| 166 | -! | +||
| 721 | +
- teal.widgets::panel_group(+ #' |
||
| 167 | -! | +||
| 722 | +
- teal.widgets::panel_item(+ #' @export |
||
| 168 | -! | +||
| 723 | +
- title = "Display",+ #' @keywords internal |
||
| 169 | -! | +||
| 724 | +
- collapsed = FALSE,+ #' @rdname create_sparklines |
||
| 170 | -! | +||
| 725 | +
- checkboxGroupInput(+ create_sparklines.factor <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) { # nolint
|
||
| 171 | +726 | ! |
- ns("tables_display"),
+ decreasing_order <- TRUE |
| 172 | -! | +||
| 727 | +
- "Tables display",+ |
||
| 173 | +728 | ! |
- choices = c("PC importance" = "importance", "Eigenvectors" = "eigenvector"),
+ counts <- table(arr) |
| 174 | +729 | ! |
- selected = c("importance", "eigenvector")
+ if (length(counts) >= 100) {
|
| 175 | -+ | ||
| 730 | +! |
- ),+ return(as.character(tags$code("> 99 levels", class = "text-blue")))
|
|
| 176 | +731 | ! |
- radioButtons(+ } else if (length(counts) == 0) {
|
| 177 | +732 | ! |
- ns("plot_type"),
+ return(as.character(tags$code("no levels", class = "text-blue")))
|
| 178 | +733 | ! |
- label = "Plot type",+ } else if (length(counts) == 1) {
|
| 179 | +734 | ! |
- choices = args$plot_choices,+ return(as.character(tags$code("one level", class = "text-blue")))
|
| 180 | -! | +||
| 735 | +
- selected = args$plot_choices[1]+ } |
||
| 181 | +736 |
- )+ |
|
| 182 | +737 |
- ),+ # Summarize the occurences of different levels |
|
| 183 | -! | +||
| 738 | +
- teal.widgets::panel_item(+ # and get the maximum and minimum number of occurences |
||
| 184 | -! | +||
| 739 | +
- title = "Pre-processing",+ # This is needed for the sparkline to correctly display the bar plots |
||
| 185 | -! | +||
| 740 | +
- radioButtons(+ # Otherwise they are cropped |
||
| 186 | +741 | ! |
- ns("standardization"), "Standardization",
+ counts <- sort(counts, decreasing = decreasing_order, method = "radix") |
| 187 | +742 | ! |
- choices = c("None" = "none", "Center" = "center", "Center & Scale" = "center_scale"),
+ max_value <- if (decreasing_order) counts[1] else counts[length[counts]] |
| 188 | +743 | ! |
- selected = "center_scale"+ max_value <- unname(max_value) |
| 189 | +744 |
- ),- |
- |
| 190 | -! | -
- radioButtons(+ |
|
| 191 | +745 | ! |
- ns("na_action"), "NA action",
+ sparkline::spk_chr( |
| 192 | +746 | ! |
- choices = c("None" = "none", "Drop" = "drop"),
+ unname(counts), |
| 193 | +747 | ! |
- selected = "none"- |
-
| 194 | -- |
- )- |
- |
| 195 | -- |
- ),+ type = "bar", |
|
| 196 | +748 | ! |
- teal.widgets::panel_item(+ chartRangeMin = 0, |
| 197 | +749 | ! |
- title = "Selected plot specific settings",+ chartRangeMax = max_value, |
| 198 | +750 | ! |
- collapsed = FALSE,+ width = width, |
| 199 | +751 | ! |
- uiOutput(ns("plot_settings")),
+ barWidth = bar_width, |
| 200 | +752 | ! |
- conditionalPanel(+ barSpacing = bar_spacing, |
| 201 | +753 | ! |
- condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")),
+ tooltipFormatter = custom_sparkline_formatter(names(counts), as.vector(counts)) |
| 202 | -! | +||
| 754 | +
- list(+ ) |
||
| 203 | -! | +||
| 755 | +
- teal.transform::data_extract_ui(+ } |
||
| 204 | -! | +||
| 756 | +
- id = ns("response"),
+
|
||
| 205 | -! | +||
| 757 | +
- label = "Color by",+ #' Generates the \code{sparkline} HTML code
|
||
| 206 | -! | +||
| 758 | +
- data_extract_spec = color_selector,+ #' |
||
| 207 | -! | +||
| 759 | +
- is_single_dataset = is_single_dataset_value+ #' |
||
| 208 | +760 |
- ),+ #' @return \code{character} with HTML code for the \code{sparkline} widget
|
|
| 209 | -! | +||
| 761 | +
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
+ #' |
||
| 210 | -! | +||
| 762 | +
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE)
+ #' @export |
||
| 211 | +763 |
- )+ #' @keywords internal |
|
| 212 | +764 |
- )+ #' @rdname create_sparklines |
|
| 213 | +765 |
- ),+ create_sparklines.numeric <- function(arr, width = 150, ...) { # nolint
|
|
| 214 | +766 | ! |
- teal.widgets::panel_item(+ if (any(is.infinite(arr))) {
|
| 215 | +767 | ! |
- title = "Plot settings",+ return(as.character(tags$code("infinite values", class = "text-blue")))
|
| 216 | -! | +||
| 768 | +
- collapsed = TRUE,+ } |
||
| 217 | +769 | ! |
- conditionalPanel(+ if (length(arr) > 100000) {
|
| 218 | +770 | ! |
- condition = sprintf(+ return(as.character(tags$code("Too many rows (>100000)", class = "text-blue")))
+ |
+
| 771 | ++ |
+ }+ |
+ |
| 772 | ++ | + | |
| 219 | +773 | ! |
- "input['%s'] == 'Elbow Plot' || input['%s'] == 'Eigenvector plot'",+ arr <- arr[!is.na(arr)] |
| 220 | +774 | ! |
- ns("plot_type"),
+ res <- sparkline::spk_chr(unname(arr), type = "box", width = width, ...) |
| 221 | +775 | ! |
- ns("plot_type")
+ return(res) |
| 222 | +776 |
- ),+ } |
|
| 223 | -! | +||
| 777 | +
- list(checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels))
+
|
||
| 224 | +778 |
- ),+ #' Summarizes variable |
|
| 225 | -! | +||
| 779 | +
- selectInput(+ #' |
||
| 226 | -! | +||
| 780 | +
- inputId = ns("ggtheme"),
+ #' Creates html summary with statistics relevant to data type. For numeric values it returns central |
||
| 227 | -! | +||
| 781 | +
- label = "Theme (by ggplot):",+ #' tendency measures, for factor returns level counts, for Date date range, for other just |
||
| 228 | -! | +||
| 782 | +
- choices = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
+ #' number of levels. |
||
| 229 | -! | +||
| 783 | +
- selected = args$ggtheme,+ #' @param x vector of any type |
||
| 230 | -! | +||
| 784 | +
- multiple = FALSE+ #' @param numeric_as_factor \code{logical} should the numeric variable be treated as a factor
|
||
| 231 | +785 |
- ),+ #' @param dt_rows \code{numeric} current/latest `DT` page length
|
|
| 232 | -! | +||
| 786 | +
- teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", args$font_size, ticks = FALSE)
+ #' @param outlier_definition If 0 no outliers are removed, otherwise |
||
| 233 | +787 |
- )+ #' outliers (those more than outlier_definition*IQR below/above Q1/Q3 be removed) |
|
| 234 | +788 |
- )+ #' @return text with simple statistics. |
|
| 235 | +789 |
- ),+ #' @keywords internal |
|
| 236 | -! | +||
| 790 | +
- forms = tagList(+ var_summary_table <- function(x, numeric_as_factor, dt_rows, outlier_definition) {
|
||
| 237 | +791 | ! |
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+ if (is.null(dt_rows)) {
|
| 238 | +792 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ dt_rows <- 10 |
| 239 | +793 |
- ),+ } |
|
| 240 | +794 | ! |
- pre_output = args$pre_output,+ if (is.numeric(x) && !numeric_as_factor) {
|
| 241 | +795 | ! |
- post_output = args$post_output+ req(!any(is.infinite(x))) |
| 242 | +796 |
- )+ |
|
| 243 | -+ | ||
| 797 | +! |
- )+ x <- remove_outliers_from(x, outlier_definition) |
|
| 244 | +798 |
- }+ |
|
| 245 | -+ | ||
| 799 | +! |
-
+ qvals <- round(stats::quantile(x, na.rm = TRUE, probs = c(0.25, 0.5, 0.75), type = 2), 2) |
|
| 246 | +800 |
- srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, plot_width, ggplot2_args) {
+ # classical central tendency measures |
|
| 247 | -! | +||
| 801 | +
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ |
||
| 248 | +802 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ summary <- |
| 249 | +803 | ! |
- checkmate::assert_class(data, "tdata")+ data.frame( |
| 250 | +804 | ! |
- moduleServer(id, function(input, output, session) {
+ Statistic = c("min", "Q1", "median", "mean", "Q3", "max", "sd", "n"),
|
| 251 | +805 | ! |
- response <- dat- |
-
| 252 | -- |
-
+ Value = c( |
|
| 253 | +806 | ! |
- for (i in seq_along(response)) {
+ round(min(x, na.rm = TRUE), 2), |
| 254 | +807 | ! |
- response[[i]]$select$multiple <- FALSE+ qvals[1], |
| 255 | +808 | ! |
- response[[i]]$select$always_selected <- NULL+ qvals[2], |
| 256 | +809 | ! |
- response[[i]]$select$selected <- NULL+ round(mean(x, na.rm = TRUE), 2), |
| 257 | +810 | ! |
- response[[i]]$select$choices <- var_labels(data[[response[[i]]$dataname]]())+ qvals[3], |
| 258 | +811 | ! |
- response[[i]]$select$choices <- setdiff(+ round(max(x, na.rm = TRUE), 2), |
| 259 | +812 | ! |
- response[[i]]$select$choices,+ round(stats::sd(x, na.rm = TRUE), 2), |
| 260 | +813 | ! |
- unlist(get_join_keys(data)$get(response[[i]]$dataname))+ length(x[!is.na(x)]) |
| 261 | +814 |
- )+ ) |
|
| 262 | +815 |
- }+ ) |
|
| 263 | +816 | ||
| 264 | +817 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows)) |
| 265 | +818 | ! |
- data_extract = list(dat = dat, response = response),+ } else if (is.factor(x) || is.character(x) || (is.numeric(x) && numeric_as_factor) || is.logical(x)) {
|
| 266 | -! | +||
| 819 | +
- datasets = data,+ # make sure factor is ordered numeric |
||
| 267 | +820 | ! |
- select_validation_rule = list(+ if (is.numeric(x)) {
|
| 268 | +821 | ! |
- dat = ~ if (length(.) < 2L) "Please select more than 1 variable to perform PCA.",+ x <- factor(x, levels = sort(unique(x)))+ |
+
| 822 | ++ |
+ }+ |
+ |
| 823 | ++ | + | |
| 269 | +824 | ! |
- response = shinyvalidate::compose_rules(+ level_counts <- table(x) |
| 270 | +825 | ! |
- shinyvalidate::sv_optional(),+ max_levels_signif <- nchar(level_counts)+ |
+
| 826 | ++ | + | |
| 271 | +827 | ! |
- ~ if (isTRUE(is.element(., selector_list()$dat()$select))) {
+ if (!all(is.na(x))) {
|
| 272 | +828 | ! |
- "Response must not have been used for PCA."+ levels <- names(level_counts) |
| 273 | -+ | ||
| 829 | +! |
- }+ counts <- sprintf( |
|
| 274 | -+ | ||
| 830 | +! |
- )+ "%s [%.2f%%]", |
|
| 275 | -+ | ||
| 831 | +! |
- )+ format(level_counts, width = max_levels_signif), prop.table(level_counts) * 100 |
|
| 276 | +832 |
- )+ ) |
|
| 277 | +833 | - - | -|
| 278 | -! | -
- iv_r <- reactive({
+ } else {
|
|
| 279 | +834 | ! |
- iv <- shinyvalidate::InputValidator$new()+ levels <- character(0) |
| 280 | +835 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list)+ counts <- numeric(0) |
| 281 | +836 |
- })+ } |
|
| 282 | +837 | ||
| 283 | -! | -
- iv_extra <- shinyvalidate::InputValidator$new()- |
- |
| 284 | +838 | ! |
- iv_extra$add_rule("x_axis", function(value) {
+ summary <- data.frame( |
| 285 | +839 | ! |
- if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
+ Level = levels, |
| 286 | +840 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ Count = counts, |
| 287 | +841 | ! |
- "Need X axis"+ stringsAsFactors = FALSE |
| 288 | +842 |
- }+ ) |
|
| 289 | +843 |
- }+ |
|
| 290 | +844 |
- })+ # sort the dataset in decreasing order of counts (needed as character variables default to alphabetical) |
|
| 291 | +845 | ! |
- iv_extra$add_rule("y_axis", function(value) {
+ summary <- summary[order(summary$Count, decreasing = TRUE), ] |
| 292 | -! | +||
| 846 | +
- if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
+
|
||
| 293 | +847 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ dom_opts <- if (nrow(summary) <= 10) {
|
| 294 | +848 | ! |
- "Need Y axis"+ "<t>" |
| 295 | +849 |
- }+ } else {
|
|
| 296 | -+ | ||
| 850 | +! |
- }+ "<lf<t>ip>" |
|
| 297 | +851 |
- })+ } |
|
| 298 | +852 | ! |
- rule_dupl <- function(...) {
+ DT::datatable(summary, rownames = FALSE, options = list(dom = dom_opts, pageLength = dt_rows)) |
| 299 | +853 | ! |
- if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
+ } else if (inherits(x, "Date") || inherits(x, "POSIXct") || inherits(x, "POSIXlt")) {
|
| 300 | +854 | ! |
- if (isTRUE(input$x_axis == input$y_axis)) {
+ summary <- |
| 301 | +855 | ! |
- "Please choose different X and Y axes."+ data.frame( |
| 302 | -+ | ||
| 856 | +! |
- }+ Statistic = c("min", "median", "max"),
|
|
| 303 | -+ | ||
| 857 | +! |
- }+ Value = c( |
|
| 304 | -+ | ||
| 858 | +! |
- }+ min(x, na.rm = TRUE), |
|
| 305 | +859 | ! |
- iv_extra$add_rule("x_axis", rule_dupl)
+ stats::median(x, na.rm = TRUE), |
| 306 | +860 | ! |
- iv_extra$add_rule("y_axis", rule_dupl)
+ max(x, na.rm = TRUE) |
| 307 | -! | +||
| 861 | +
- iv_extra$add_rule("variables", function(value) {
+ ) |
||
| 308 | -! | +||
| 862 | +
- if (identical(input$plot_type, "Circle plot")) {
+ ) |
||
| 309 | +863 | ! |
- if (!shinyvalidate::input_provided(value)) {
+ DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows))+ |
+
| 864 | ++ |
+ } else {
|
|
| 310 | +865 | ! |
- "Need Original Coordinates"+ NULL |
| 311 | +866 |
- }+ } |
|
| 312 | +867 |
- }+ } |
|
| 313 | +868 |
- })+ |
|
| 314 | -! | +||
| 869 | +
- iv_extra$add_rule("pc", function(value) {
+
|
||
| 315 | -! | +||
| 870 | +
- if (identical(input$plot_type, "Eigenvector plot")) {
+ #' Plot variable |
||
| 316 | -! | +||
| 871 | +
- if (!shinyvalidate::input_provided(value)) {
+ #' |
||
| 317 | -! | +||
| 872 | +
- "Need PC"+ #' Creates summary plot with statistics relevant to data type. |
||
| 318 | +873 |
- }+ #' @inheritParams shared_params |
|
| 319 | +874 |
- }+ #' @param var vector of any type to be plotted. For numeric variables it produces histogram with |
|
| 320 | +875 |
- })+ #' density line, for factors it creates frequency plot |
|
| 321 | -! | +||
| 876 | +
- iv_extra$enable()+ #' @param var_lab text describing selected variable to be displayed on the plot |
||
| 322 | +877 |
-
+ #' @param wrap_character (`numeric`) number of characters at which to wrap text values of `var` |
|
| 323 | -! | +||
| 878 | +
- anl_merged_input <- teal.transform::merge_expression_srv(+ #' @param numeric_as_factor (`logical`) should the numeric variable be treated as a factor |
||
| 324 | -! | +||
| 879 | +
- selector_list = selector_list,+ #' @param display_density (`logical`) should density estimation be displayed for numeric values |
||
| 325 | -! | +||
| 880 | +
- datasets = data,+ #' @param remove_NA_hist (`logical`) should (`NA`) values be removed for histogram of factor like variables |
||
| 326 | -! | +||
| 881 | +
- join_keys = get_join_keys(data)+ #' @param outlier_definition if 0 no outliers are removed, otherwise+ |
+ ||
| 882 | ++ |
+ #' outliers (those more than outlier_definition*IQR below/above Q1/Q3 be removed)+ |
+ |
| 883 | ++ |
+ #' @param records_for_factor (`numeric`) if the number of factor levels is >= than this value then |
|
| 327 | +884 |
- )+ #' a graph of the factors isn't shown, only a list of values |
|
| 328 | +885 |
-
+ #' |
|
| 329 | -! | +||
| 886 | +
- anl_merged_q <- reactive({
+ #' @return plot |
||
| 330 | -! | +||
| 887 | +
- req(anl_merged_input())+ #' @keywords internal |
||
| 331 | -! | +||
| 888 | +
- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>%+ plot_var_summary <- function(var, |
||
| 332 | -! | +||
| 889 | +
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ var_lab, |
||
| 333 | +890 |
- })+ wrap_character = NULL, |
|
| 334 | +891 |
-
+ numeric_as_factor, |
|
| 335 | -! | +||
| 892 | +
- merged <- list(+ display_density = is.numeric(var), |
||
| 336 | -! | +||
| 893 | +
- anl_input_r = anl_merged_input,+ remove_NA_hist = FALSE, # nolint |
||
| 337 | -! | +||
| 894 | +
- anl_q_r = anl_merged_q+ outlier_definition, |
||
| 338 | +895 |
- )+ records_for_factor, |
|
| 339 | +896 |
-
+ ggplot2_args) {
|
|
| 340 | +897 | ! |
- validation <- reactive({
+ checkmate::assert_character(var_lab) |
| 341 | +898 | ! |
- req(merged$anl_q_r())- |
-
| 342 | -- |
- # inputs+ checkmate::assert_numeric(wrap_character, null.ok = TRUE) |
|
| 343 | +899 | ! |
- keep_cols <- as.character(merged$anl_input_r()$columns_source$dat)+ checkmate::assert_flag(numeric_as_factor) |
| 344 | +900 | ! |
- na_action <- input$na_action+ checkmate::assert_flag(display_density) |
| 345 | +901 | ! |
- standardization <- input$standardization+ checkmate::assert_logical(remove_NA_hist, null.ok = TRUE) |
| 346 | +902 | ! |
- center <- standardization %in% c("center", "center_scale") # nolint
+ checkmate::assert_number(outlier_definition, lower = 0, finite = TRUE) |
| 347 | +903 | ! |
- scale <- standardization == "center_scale"+ checkmate::assert_integerish(records_for_factor, lower = 0, len = 1, any.missing = FALSE) |
| 348 | +904 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint+ checkmate::assert_class(ggplot2_args, "ggplot2_args") |
| 349 | +905 | ||
| 350 | +906 | ! |
- teal::validate_has_data(ANL, 10)+ grid::grid.newpage() |
| 351 | -! | +||
| 907 | +
- validate(need(+ |
||
| 352 | +908 | ! |
- na_action != "none" | !anyNA(ANL[keep_cols]),+ plot_main <- if (is.factor(var) || is.character(var) || is.logical(var)) {
|
| 353 | +909 | ! |
- paste(+ groups <- unique(as.character(var)) |
| 354 | +910 | ! |
- "There are NAs in the dataset. Please deal with them in preprocessing",+ len_groups <- length(groups) |
| 355 | +911 | ! |
- "or select \"Drop\" in the NA actions inside the encodings panel (left)."- |
-
| 356 | -- |
- )+ if (len_groups >= records_for_factor) {
|
|
| 357 | -+ | ||
| 912 | +! |
- ))+ grid::textGrob( |
|
| 358 | +913 | ! |
- if (scale) {
+ sprintf( |
| 359 | +914 | ! |
- not_single <- vapply(ANL[keep_cols], function(column) length(unique(column)) != 1, FUN.VALUE = logical(1))+ "%s unique values\n%s:\n %s\n ...\n %s", |
| 360 | -+ | ||
| 915 | +! |
-
+ len_groups, |
|
| 361 | +916 | ! |
- msg <- paste0(+ var_lab, |
| 362 | +917 | ! |
- "You have selected `Center & Scale` under `Standardization` in the `Pre-processing` panel, ",+ paste(utils::head(groups), collapse = ",\n "), |
| 363 | +918 | ! |
- "but one or more of your columns has/have a variance value of zero, indicating all values are identical"+ paste(utils::tail(groups), collapse = ",\n ") |
| 364 | +919 |
- )+ ), |
|
| 365 | +920 | ! |
- validate(need(all(not_single), msg))+ x = grid::unit(1, "line"), |
| 366 | -+ | ||
| 921 | +! |
- }+ y = grid::unit(1, "npc") - grid::unit(1, "line"), |
|
| 367 | -+ | ||
| 922 | +! |
- })+ just = c("left", "top")
|
|
| 368 | +923 |
-
+ ) |
|
| 369 | +924 |
- # computation ----+ } else {
|
|
| 370 | +925 | ! |
- computation <- reactive({
+ if (!is.null(wrap_character)) {
|
| 371 | +926 | ! |
- validation()+ var <- stringr::str_wrap(var, width = wrap_character) |
| 372 | +927 |
-
+ } |
|
| 373 | -+ | ||
| 928 | +! |
- # inputs+ var <- if (isTRUE(remove_NA_hist)) as.vector(stats::na.omit(var)) else var |
|
| 374 | +929 | ! |
- keep_cols <- as.character(merged$anl_input_r()$columns_source$dat)+ ggplot(data.frame(var), aes(x = forcats::fct_infreq(as.factor(var)))) + |
| 375 | +930 | ! |
- na_action <- input$na_action+ geom_bar(stat = "count", aes(fill = ifelse(is.na(var), "withcolor", "")), show.legend = FALSE) + |
| 376 | +931 | ! |
- standardization <- input$standardization+ scale_fill_manual(values = c("gray50", "tan"))
|
| 377 | -! | +||
| 932 | +
- center <- standardization %in% c("center", "center_scale") # nolint
+ } |
||
| 378 | +933 | ! |
- scale <- standardization == "center_scale"+ } else if (is.numeric(var)) {
|
| 379 | +934 | ! |
- ANL <- merged$anl_q_r()[["ANL"]] # nolint+ validate(need(any(!is.na(var)), "No data left to visualize.")) |
| 380 | +935 | ||
| 381 | -! | +||
| 936 | +
- qenv <- teal.code::eval_code(+ # Filter out NA |
||
| 382 | +937 | ! |
- merged$anl_q_r(),+ var <- var[which(!is.na(var))]+ |
+
| 938 | ++ | + | |
| 383 | +939 | ! |
- substitute(+ validate(need(!any(is.infinite(var)), "Cannot display graph when data includes infinite values"))+ |
+
| 940 | ++ | + | |
| 384 | +941 | ! |
- expr = keep_columns <- keep_cols,+ if (numeric_as_factor) {
|
| 385 | +942 | ! |
- env = list(keep_cols = keep_cols)+ var <- factor(var, levels = sort(unique(var))) |
| 386 | -+ | ||
| 943 | +! |
- )+ p <- qplot(var) |
|
| 387 | +944 |
- )+ } else {
|
|
| 388 | +945 |
-
+ # remove outliers |
|
| 389 | +946 | ! |
- if (na_action == "drop") {
+ if (outlier_definition != 0) {
|
| 390 | +947 | ! |
- qenv <- teal.code::eval_code(+ number_records <- length(var) |
| 391 | +948 | ! |
- qenv,+ var <- remove_outliers_from(var, outlier_definition) |
| 392 | +949 | ! |
- quote(ANL <- tidyr::drop_na(ANL, keep_columns)) # nolint+ number_outliers <- number_records - length(var) |
| 393 | -+ | ||
| 950 | +! |
- )+ outlier_text <- paste0( |
|
| 394 | -+ | ||
| 951 | +! |
- }+ number_outliers, " outliers (",
|
|
| 395 | -+ | ||
| 952 | +! |
-
+ round(number_outliers / number_records * 100, 2), |
|
| 396 | +953 | ! |
- qenv <- teal.code::eval_code(+ "% of non-missing records) not shown" |
| 397 | -! | +||
| 954 | +
- qenv,+ ) |
||
| 398 | +955 | ! |
- substitute(+ validate(need( |
| 399 | +956 | ! |
- expr = pca <- summary(stats::prcomp(ANL[keep_columns], center = center, scale. = scale, retx = TRUE)),+ length(var) > 1, |
| 400 | +957 | ! |
- env = list(center = center, scale = scale)+ "At least two data points must remain after removing outliers for this graph to be displayed" |
| 401 | +958 |
- )+ )) |
|
| 402 | +959 |
- )+ } |
|
| 403 | +960 |
-
+ ## histogram |
|
| 404 | +961 | ! |
- qenv <- teal.code::eval_code(+ binwidth <- get_bin_width(var) |
| 405 | +962 | ! |
- qenv,+ p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) + |
| 406 | +963 | ! |
- quote({
+ geom_histogram(binwidth = binwidth) + |
| 407 | +964 | ! |
- tbl_importance <- dplyr::as_tibble(pca$importance, rownames = "Metric")+ scale_y_continuous( |
| 408 | +965 | ! |
- tbl_importance- |
-
| 409 | -- |
- })- |
- |
| 410 | -- |
- )- |
- |
| 411 | -- |
-
+ sec.axis = sec_axis( |
|
| 412 | +966 | ! |
- teal.code::eval_code(+ trans = ~ . / nrow(data.frame(var = var)), |
| 413 | +967 | ! |
- qenv,+ labels = scales::percent, |
| 414 | +968 | ! |
- quote({
+ name = "proportion (in %)" |
| 415 | -! | +||
| 969 | +
- tbl_eigenvector <- dplyr::as_tibble(pca$rotation, rownames = "Variable")+ ) |
||
| 416 | -! | +||
| 970 | +
- tbl_eigenvector+ ) |
||
| 417 | +971 |
- })+ |
|
| 418 | -+ | ||
| 972 | +! |
- )+ if (display_density) {
|
|
| 419 | -+ | ||
| 973 | +! |
- })+ p <- p + geom_density(aes(y = after_stat(count * binwidth))) |
|
| 420 | +974 |
-
+ } |
|
| 421 | +975 |
- # plot args ----+ |
|
| 422 | +976 | ! |
- output$plot_settings <- renderUI({
+ if (outlier_definition != 0) {
|
| 423 | -+ | ||
| 977 | +! |
- # reactivity triggers+ p <- p + annotate( |
|
| 424 | +978 | ! |
- req(iv_r()$is_valid())+ geom = "text", |
| 425 | +979 | ! |
- req(computation())+ label = outlier_text, |
| 426 | +980 | ! |
- qenv <- computation()+ x = Inf, y = Inf, |
| 427 | -+ | ||
| 981 | +! |
-
+ hjust = 1.02, vjust = 1.2, |
|
| 428 | +982 | ! |
- ns <- session$ns+ color = "black", |
| 429 | +983 |
-
+ # explicitly modify geom text size according |
|
| 430 | +984 | ! |
- pca <- qenv[["pca"]]+ size = ggplot2_args[["theme"]][["text"]][["size"]] / 3.5 |
| 431 | -! | +||
| 985 | +
- chcs_pcs <- colnames(pca$rotation)+ )+ |
+ ||
| 986 | ++ |
+ } |
|
| 432 | +987 | ! |
- chcs_vars <- qenv[["keep_columns"]]+ p |
| 433 | +988 |
-
+ } |
|
| 434 | +989 | ! |
- tagList(+ } else if (inherits(var, "Date") || inherits(var, "POSIXct") || inherits(var, "POSIXlt")) {
|
| 435 | +990 | ! |
- conditionalPanel(+ var_num <- as.numeric(var) |
| 436 | +991 | ! |
- condition = sprintf(+ binwidth <- get_bin_width(var_num, 1) |
| 437 | +992 | ! |
- "input['%s'] == 'Biplot' || input['%s'] == 'Circle plot'",+ p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) + |
| 438 | +993 | ! |
- ns("plot_type"), ns("plot_type")
+ geom_histogram(binwidth = binwidth) |
| 439 | +994 |
- ),- |
- |
| 440 | -! | -
- list(+ } else {
|
|
| 441 | +995 | ! |
- teal.widgets::optionalSelectInput(ns("x_axis"), "X axis", choices = chcs_pcs, selected = chcs_pcs[1]),
+ grid::textGrob( |
| 442 | +996 | ! |
- teal.widgets::optionalSelectInput(ns("y_axis"), "Y axis", choices = chcs_pcs, selected = chcs_pcs[2]),
+ paste(strwrap( |
| 443 | +997 | ! |
- teal.widgets::optionalSelectInput(+ utils::capture.output(utils::str(var)), |
| 444 | +998 | ! |
- ns("variables"), "Original coordinates",
+ width = .9 * grid::convertWidth(grid::unit(1, "npc"), "char", TRUE) |
| 445 | +999 | ! |
- choices = chcs_vars, selected = chcs_vars,+ ), collapse = "\n"), |
| 446 | +1000 | ! |
- multiple = TRUE+ x = grid::unit(1, "line"), y = grid::unit(1, "npc") - grid::unit(1, "line"), just = c("left", "top")
|
| 447 | +1001 |
- )+ ) |
|
| 448 | +1002 |
- )+ } |
|
| 449 | +1003 |
- ),+ |
|
| 450 | +1004 | ! |
- conditionalPanel(+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 451 | +1005 | ! |
- condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")),
+ labs = list(x = var_lab) |
| 452 | -! | +||
| 1006 | +
- helpText("No plot specific settings available.")
+ ) |
||
| 453 | +1007 |
- ),+ ### |
|
| 454 | +1008 | ! |
- conditionalPanel(+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 455 | +1009 | ! |
- condition = paste0("input['", ns("plot_type"), "'] == 'Eigenvector plot'"),
+ ggplot2_args, |
| 456 | +1010 | ! |
- teal.widgets::optionalSelectInput(ns("pc"), "PC", choices = chcs_pcs, selected = chcs_pcs[1])
+ module_plot = dev_ggplot2_args |
| 457 | +1011 |
- )+ ) |
|
| 458 | +1012 |
- )+ |
|
| 459 | -+ | ||
| 1013 | +! |
- })+ if (is.ggplot(plot_main)) {
|
|
| 460 | -+ | ||
| 1014 | +! |
-
+ if (is.numeric(var) && !numeric_as_factor) {
|
|
| 461 | +1015 |
- # plot elbow ----+ # numeric not as factor |
|
| 462 | +1016 | ! |
- plot_elbow <- function(base_q) {
+ plot_main <- plot_main + |
| 463 | +1017 | ! |
- ggtheme <- input$ggtheme+ theme_light() + |
| 464 | +1018 | ! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels # nolint+ list( |
| 465 | +1019 | ! |
- font_size <- input$font_size # nolint+ labs = do.call("labs", all_ggplot2_args$labs),
|
| 466 | -+ | ||
| 1020 | +! |
-
+ theme = do.call("theme", all_ggplot2_args$theme)
|
|
| 467 | -! | +||
| 1021 | +
- angle_value <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)+ ) |
||
| 468 | -! | +||
| 1022 | +
- hjust_value <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)+ } else {
|
||
| 469 | +1023 |
-
+ # factor low number of levels OR numeric as factor OR Date |
|
| 470 | +1024 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ plot_main <- plot_main + |
| 471 | +1025 | ! |
- labs = list(x = "Principal component", y = "Proportion of variance explained", color = "", fill = "Legend"),+ theme_light() + |
| 472 | +1026 | ! |
- theme = list(+ list( |
| 473 | +1027 | ! |
- legend.position = "right",+ labs = do.call("labs", all_ggplot2_args$labs),
|
| 474 | +1028 | ! |
- legend.spacing.y = quote(grid::unit(-5, "pt")),+ theme = do.call("theme", all_ggplot2_args$theme)
|
| 475 | -! | +||
| 1029 | +
- legend.title = quote(element_text(vjust = 25)),+ )+ |
+ ||
| 1030 | ++ |
+ } |
|
| 476 | +1031 | ! |
- axis.text.x = substitute(+ plot_main <- ggplotGrob(plot_main)+ |
+
| 1032 | ++ |
+ }+ |
+ |
| 1033 | ++ | + | |
| 477 | +1034 | ! |
- element_text(angle = angle_value, hjust = hjust_value),+ grid::grid.draw(plot_main) |
| 478 | +1035 | ! |
- list(angle_value = angle_value, hjust_value = hjust_value)+ plot_main |
| 479 | +1036 |
- ),+ } |
|
| 480 | -! | +||
| 1037 | +
- text = substitute(element_text(size = font_size), list(font_size = font_size))+ |
||
| 481 | +1038 |
- )+ #' Returns a short variable description. |
|
| 482 | +1039 |
- )+ #' |
|
| 483 | +1040 |
-
+ #' @description |
|
| 484 | -! | +||
| 1041 | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ #' The format of the variable description is: |
||
| 485 | -! | +||
| 1042 | +
- teal.widgets::resolve_ggplot2_args(+ #' `"<Long variable label> [<dataset name>.<variable name>]"` |
||
| 486 | -! | +||
| 1043 | +
- user_plot = ggplot2_args[["Elbow plot"]],+ #' |
||
| 487 | -! | +||
| 1044 | +
- user_default = ggplot2_args$default,+ #' Example: `"Study Identifier [ADSL.STUDYID]"` |
||
| 488 | -! | +||
| 1045 | +
- module_plot = dev_ggplot2_args+ #' |
||
| 489 | +1046 |
- ),+ #' @param data (`tdata`) the object containing the dataset |
|
| 490 | -! | +||
| 1047 | +
- ggtheme = ggtheme+ #' @param dataset_name (`character`) the name of the dataset containing the variable |
||
| 491 | +1048 |
- )+ #' @param var_name (`character`) the name of the variable |
|
| 492 | +1049 |
-
+ #' @keywords internal |
|
| 493 | -! | +||
| 1050 | +
- teal.code::eval_code(+ get_var_description <- function(data, dataset_name, var_name) {
|
||
| 494 | +1051 | ! |
- base_q,+ varlabel <- var_labels(data[[dataset_name]]())[[var_name]] |
| 495 | +1052 | ! |
- substitute(+ sprintf( |
| 496 | +1053 | ! |
- expr = {
+ "%s [%s.%s]", |
| 497 | +1054 | ! |
- elb_dat <- pca$importance[c("Proportion of Variance", "Cumulative Proportion"), ] %>%
+ if (is.na(varlabel)) var_name else varlabel, |
| 498 | +1055 | ! |
- dplyr::as_tibble(rownames = "metric") %>%+ dataset_name, |
| 499 | +1056 | ! |
- tidyr::gather("component", "value", -metric) %>%
+ var_name |
| 500 | -! | +||
| 1057 | +
- dplyr::mutate(+ )+ |
+ ||
| 1058 | ++ |
+ }+ |
+ |
| 1059 | ++ | + + | +|
| 1060 | ++ |
+ is_num_var_short <- function(.unique_records_for_factor, input, data_for_analysis) {
|
|
| 501 | +1061 | ! |
- component = factor(component, levels = unique(stringr::str_sort(component, numeric = TRUE)))+ length(unique(data_for_analysis()$data)) < .unique_records_for_factor && !is.null(input$numeric_as_factor) |
| 502 | +1062 |
- )+ } |
|
| 503 | +1063 | ||
| 504 | -! | +||
| 1064 | +
- cols <- c(getOption("ggplot2.discrete.colour"), c("lightblue", "darkred", "black"))[1:3]
+ #' Validates the variable browser inputs |
||
| 505 | -! | +||
| 1065 | +
- g <- ggplot(mapping = aes_string(x = "component", y = "value")) ++ #' |
||
| 506 | -! | +||
| 1066 | +
- geom_bar(+ #' @param input (`session$input`) the shiny session input |
||
| 507 | -! | +||
| 1067 | +
- aes(fill = "Single variance"),+ #' @param plot_var (`list`) list of a data frame and an array of variable names |
||
| 508 | -! | +||
| 1068 | +
- data = dplyr::filter(elb_dat, metric == "Proportion of Variance"),+ #' @param data (`tdata`) the datasets passed to the module |
||
| 509 | -! | +||
| 1069 | +
- color = "black",+ #' |
||
| 510 | -! | +||
| 1070 | +
- stat = "identity"+ #' @returns `logical` TRUE if validations pass; a Shiny validation error otherwise |
||
| 511 | +1071 |
- ) ++ #' @keywords internal+ |
+ |
| 1072 | ++ |
+ validate_input <- function(input, plot_var, data) {
|
|
| 512 | +1073 | ! |
- geom_point(+ reactive({
|
| 513 | +1074 | ! |
- aes(color = "Cumulative variance"),+ dataset_name <- input$tabset_panel |
| 514 | +1075 | ! |
- data = dplyr::filter(elb_dat, metric == "Cumulative Proportion")+ varname <- plot_var$variable[[input$tabset_panel]] |
| 515 | +1076 |
- ) +- |
- |
| 516 | -! | -
- geom_line(+ |
|
| 517 | +1077 | ! |
- aes(group = 1, color = "Cumulative variance"),+ validate(need(dataset_name, "No data selected")) |
| 518 | +1078 | ! |
- data = dplyr::filter(elb_dat, metric == "Cumulative Proportion")+ validate(need(varname, "No variable selected")) |
| 519 | +1079 |
- ) ++ |
|
| 520 | +1080 | ! |
- labs ++ df <- data[[dataset_name]]() |
| 521 | +1081 | ! |
- scale_color_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[3])) +
+ teal::validate_has_data(df, 1) |
| 522 | +1082 | ! |
- scale_fill_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[1])) +
+ teal::validate_has_variable(varname = varname, data = df, "Variable not available") |
| 523 | -! | +||
| 1083 | +
- ggthemes ++ |
||
| 524 | +1084 | ! |
- themes+ TRUE |
| 525 | +1085 |
-
+ }) |
|
| 526 | -! | +||
| 1086 | +
- print(g)+ } |
||
| 527 | +1087 |
- },+ |
|
| 528 | -! | +||
| 1088 | +
- env = list(+ get_plotted_data <- function(input, plot_var, data) {
|
||
| 529 | +1089 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme,+ dataset_name <- input$tabset_panel |
| 530 | +1090 | ! |
- labs = parsed_ggplot2_args$labs,+ varname <- plot_var$variable[[input$tabset_panel]] |
| 531 | +1091 | ! |
- themes = parsed_ggplot2_args$theme+ df <- data[[dataset_name]]() |
| 532 | +1092 |
- )+ |
|
| 533 | -+ | ||
| 1093 | +! |
- )+ var_description <- var_labels(df)[[varname]] |
|
| 534 | -+ | ||
| 1094 | +! |
- )+ list(data = df[[varname]], var_description = var_description) |
|
| 535 | +1095 |
- }+ } |
|
| 536 | +1096 | ||
| 537 | +1097 |
- # plot circle ----+ #' Renders the left-hand side `tabset` panel of the module |
|
| 538 | -! | +||
| 1098 | +
- plot_circle <- function(base_q) {
+ #' |
||
| 539 | -! | +||
| 1099 | +
- x_axis <- input$x_axis # nolint+ #' @param datanames (`character`) the name of the dataset |
||
| 540 | -! | +||
| 1100 | +
- y_axis <- input$y_axis # nolint+ #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from |
||
| 541 | -! | +||
| 1101 | +
- variables <- input$variables # nolint+ #' @param data (`tdata`) the object containing all datasets |
||
| 542 | -! | +||
| 1102 | +
- ggtheme <- input$ggtheme+ #' @param input (`session$input`) the shiny session input |
||
| 543 | +1103 |
-
+ #' @param output (`session$output`) the shiny session output |
|
| 544 | -! | +||
| 1104 | +
- rotate_xaxis_labels <- input$rotate_xaxis_labels # nolint+ #' @param columns_names (`environment`) the environment containing bindings for each dataset |
||
| 545 | -! | +||
| 1105 | +
- font_size <- input$font_size # nolint+ #' @param plot_var (`list`) the list containing the currently selected dataset (tab) and its column names |
||
| 546 | +1106 |
-
+ #' @keywords internal |
|
| 547 | -! | +||
| 1107 | +
- angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)+ render_tabset_panel_content <- function(datanames, parent_dataname, output, data, input, columns_names, plot_var) {
|
||
| 548 | +1108 | ! |
- hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)- |
-
| 549 | -- |
-
+ lapply(datanames, render_single_tab, |
|
| 550 | +1109 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ input = input, |
| 551 | +1110 | ! |
- theme = list(+ output = output, |
| 552 | +1111 | ! |
- text = substitute(element_text(size = font_size), list(font_size = font_size)),+ data = data, |
| 553 | +1112 | ! |
- axis.text.x = substitute(+ parent_dataname = parent_dataname, |
| 554 | +1113 | ! |
- element_text(angle = angle_val, hjust = hjust_val),+ columns_names = columns_names, |
| 555 | +1114 | ! |
- list(angle_val = angle, hjust_val = hjust)+ plot_var = plot_var |
| 556 | +1115 |
- )+ ) |
|
| 557 | +1116 |
- )+ } |
|
| 558 | +1117 |
- )+ |
|
| 559 | +1118 | - - | -|
| 560 | -! | -
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ #' Renders a single tab in the left-hand side tabset panel |
|
| 561 | -! | +||
| 1119 | +
- user_plot = ggplot2_args[["Circle plot"]],+ #' |
||
| 562 | -! | +||
| 1120 | +
- user_default = ggplot2_args$default,+ #' @description |
||
| 563 | -! | +||
| 1121 | +
- module_plot = dev_ggplot2_args+ #' Renders a single tab in the left-hand side tabset panel. The rendered tab contains |
||
| 564 | +1122 |
- )+ #' information about one dataset out of many presented in the module. |
|
| 565 | +1123 |
-
+ #' |
|
| 566 | -! | +||
| 1124 | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ #' @param dataset_name (`character`) the name of the dataset contained in the rendered tab |
||
| 567 | -! | +||
| 1125 | +
- all_ggplot2_args,+ #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from |
||
| 568 | -! | +||
| 1126 | +
- ggtheme = ggtheme+ #' @inheritParams render_tabset_panel_content |
||
| 569 | +1127 |
- )+ #' @keywords internal |
|
| 570 | +1128 |
-
+ render_single_tab <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
|
|
| 571 | +1129 | ! |
- teal.code::eval_code(+ render_tab_header(dataset_name, output, data) |
| 572 | -! | +||
| 1130 | +
- base_q,+ |
||
| 573 | +1131 | ! |
- substitute(+ render_tab_table( |
| 574 | +1132 | ! |
- expr = {
+ dataset_name = dataset_name, |
| 575 | +1133 | ! |
- pca_rot <- pca$rotation[, c(x_axis, y_axis)] %>%+ parent_dataname = parent_dataname, |
| 576 | +1134 | ! |
- dplyr::as_tibble(rownames = "label") %>%+ output = output, |
| 577 | +1135 | ! |
- dplyr::filter(label %in% variables)- |
-
| 578 | -- |
-
+ data = data, |
|
| 579 | +1136 | ! |
- circle_data <- data.frame(+ input = input, |
| 580 | +1137 | ! |
- x = cos(seq(0, 2 * pi, length.out = 100)),+ columns_names = columns_names, |
| 581 | +1138 | ! |
- y = sin(seq(0, 2 * pi, length.out = 100))+ plot_var = plot_var |
| 582 | +1139 |
- )+ ) |
|
| 583 | +1140 |
-
+ } |
|
| 584 | -! | +||
| 1141 | +
- g <- ggplot(pca_rot) ++ |
||
| 585 | -! | +||
| 1142 | +
- geom_point(aes_string(x = x_axis, y = y_axis)) ++ #' Renders the text headlining a single tab in the left-hand side tabset panel |
||
| 586 | -! | +||
| 1143 | +
- geom_label(+ #' |
||
| 587 | -! | +||
| 1144 | +
- aes_string(x = x_axis, y = y_axis, label = "label"),+ #' @param dataset_name (`character`) the name of the dataset of the tab |
||
| 588 | -! | +||
| 1145 | +
- nudge_x = 0.1, nudge_y = 0.05,+ #' @inheritParams render_tabset_panel_content |
||
| 589 | -! | +||
| 1146 | +
- fontface = "bold"+ #' @keywords internal |
||
| 590 | +1147 |
- ) ++ render_tab_header <- function(dataset_name, output, data) {
|
|
| 591 | +1148 | ! |
- geom_path(aes(x, y, group = 1), data = circle_data) ++ dataset_ui_id <- paste0("dataset_summary_", dataset_name)
|
| 592 | +1149 | ! |
- geom_point(aes(x = x, y = y), data = data.frame(x = 0, y = 0), shape = "x", size = 5) ++ output[[dataset_ui_id]] <- renderText({
|
| 593 | +1150 | ! |
- labs ++ df <- data[[dataset_name]]() |
| 594 | +1151 | ! |
- ggthemes ++ join_keys <- get_join_keys(data) |
| 595 | +1152 | ! |
- themes+ if (!is.null(join_keys)) {
|
| 596 | +1153 | ! |
- print(g)+ key <- get_join_keys(data)$get(dataset_name)[[dataset_name]] |
| 597 | +1154 |
- },+ } else {
|
|
| 598 | +1155 | ! |
- env = list(+ key <- NULL |
| 599 | -! | +||
| 1156 | +
- x_axis = x_axis,+ } |
||
| 600 | +1157 | ! |
- y_axis = y_axis,+ sprintf( |
| 601 | +1158 | ! |
- variables = variables,+ "Dataset with %s unique key rows and %s variables", |
| 602 | +1159 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme,+ nrow(unique(`if`(length(key) > 0, df[, key, drop = FALSE], df))), |
| 603 | +1160 | ! |
- labs = `if`(is.null(parsed_ggplot2_args$labs), quote(labs()), parsed_ggplot2_args$labs),+ ncol(df)+ |
+
| 1161 | ++ |
+ )+ |
+ |
| 1162 | ++ |
+ })+ |
+ |
| 1163 | ++ |
+ }+ |
+ |
| 1164 | ++ | + + | +|
| 1165 | ++ |
+ #' Renders the table for a single dataset in the left-hand side tabset panel |
|
| 604 | -! | +||
| 1166 | +
- themes = parsed_ggplot2_args$theme+ #' |
||
| 605 | +1167 |
- )+ #' @description |
|
| 606 | +1168 |
- )+ #' The table contains column names, column labels, |
|
| 607 | +1169 |
- )+ #' small summary about NA values and `sparkline` (if appropriate). |
|
| 608 | +1170 |
- }+ #' |
|
| 609 | +1171 |
-
+ #' @param dataset_name (`character`) the name of the dataset |
|
| 610 | +1172 |
- # plot biplot ----+ #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from |
|
| 611 | -! | +||
| 1173 | +
- plot_biplot <- function(base_q) {
+ #' @inheritParams render_tabset_panel_content |
||
| 612 | -! | +||
| 1174 | +
- qenv <- base_q+ #' @keywords internal |
||
| 613 | +1175 |
-
+ render_tab_table <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
|
|
| 614 | +1176 | ! |
- ANL <- qenv[["ANL"]] # nolint+ table_ui_id <- paste0("variable_browser_", dataset_name)
|
| 615 | +1177 | ||
| 616 | +1178 | ! |
- resp_col <- as.character(merged$anl_input_r()$columns_source$response)+ output[[table_ui_id]] <- DT::renderDataTable({
|
| 617 | +1179 | ! |
- dat_cols <- as.character(merged$anl_input_r()$columns_source$dat)+ df <- data[[dataset_name]]() |
| 618 | -! | +||
| 1180 | +
- x_axis <- input$x_axis # nolint+ |
||
| 619 | +1181 | ! |
- y_axis <- input$y_axis # nolint+ get_vars_df <- function(input, dataset_name, parent_name, data) {
|
| 620 | +1182 | ! |
- variables <- input$variables # nolint+ data_cols <- colnames(data[[dataset_name]]()) |
| 621 | +1183 | ! |
- pca <- qenv[["pca"]]- |
-
| 622 | -- |
-
+ if (isTRUE(input$show_parent_vars)) {
|
|
| 623 | +1184 | ! |
- ggtheme <- input$ggtheme- |
-
| 624 | -- |
-
+ data_cols |
|
| 625 | +1185 | ! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels # nolint+ } else if (dataset_name != parent_name && parent_name %in% names(data)) {
|
| 626 | +1186 | ! |
- alpha <- input$alpha # nolint+ setdiff(data_cols, colnames(data[[parent_name]]())) |
| 627 | -! | +||
| 1187 | +
- size <- input$size # nolint+ } else {
|
||
| 628 | +1188 | ! |
- font_size <- input$font_size # nolint+ data_cols |
| 629 | +1189 |
-
+ } |
|
| 630 | -! | +||
| 1190 | +
- qenv <- teal.code::eval_code(+ } |
||
| 631 | -! | +||
| 1191 | +
- qenv,+ |
||
| 632 | +1192 | ! |
- substitute(+ if (length(parent_dataname) > 0) {
|
| 633 | +1193 | ! |
- expr = pca_rot <- dplyr::as_tibble(pca$x[, c(x_axis, y_axis)]),+ df_vars <- get_vars_df(input, dataset_name, parent_dataname, data) |
| 634 | +1194 | ! |
- env = list(x_axis = x_axis, y_axis = y_axis)+ df <- df[df_vars] |
| 635 | +1195 |
- )+ } |
|
| 636 | +1196 |
- )+ |
|
| 637 | -+ | ||
| 1197 | +! |
-
+ if (is.null(df) || ncol(df) == 0) {
|
|
| 638 | -+ | ||
| 1198 | +! |
- # rot_vars = data frame that displays arrows in the plot, need to be scaled to data+ columns_names[[dataset_name]] <- character(0) |
|
| 639 | +1199 | ! |
- if (!is.null(input$variables)) {
+ df_output <- data.frame( |
| 640 | +1200 | ! |
- qenv <- teal.code::eval_code(+ Type = character(0), |
| 641 | +1201 | ! |
- qenv,+ Variable = character(0), |
| 642 | +1202 | ! |
- substitute(+ Label = character(0), |
| 643 | +1203 | ! |
- expr = {
+ Missings = character(0), |
| 644 | +1204 | ! |
- r <- sqrt(qchisq(0.69, df = 2)) * prod(colMeans(pca_rot ^ 2)) ^ (1 / 4) # styler: off+ Sparklines = character(0), |
| 645 | +1205 | ! |
- v_scale <- rowSums(pca$rotation ^ 2) # styler: off+ stringsAsFactors = FALSE |
| 646 | +1206 |
-
+ ) |
|
| 647 | -! | +||
| 1207 | +
- rot_vars <- pca$rotation[, c(x_axis, y_axis)] %>%+ } else {
|
||
| 648 | -! | +||
| 1208 | +
- dplyr::as_tibble(rownames = "label") %>%+ # extract data variable labels |
||
| 649 | +1209 | ! |
- dplyr::mutate_at(vars(c(x_axis, y_axis)), function(x) r * x / sqrt(max(v_scale)))+ labels <- teal.data::col_labels(df) |
| 650 | +1210 |
- },+ |
|
| 651 | +1211 | ! |
- env = list(x_axis = x_axis, y_axis = y_axis)+ columns_names[[dataset_name]] <- names(labels) |
| 652 | +1212 |
- )+ |
|
| 653 | +1213 |
- ) %>%- |
- |
| 654 | -! | -
- teal.code::eval_code(- |
- |
| 655 | -! | -
- if (is.logical(pca$center) && !pca$center) {
+ # calculate number of missing values |
|
| 656 | +1214 | ! |
- substitute(+ missings <- vapply( |
| 657 | +1215 | ! |
- expr = {
+ df, |
| 658 | +1216 | ! |
- rot_vars <- rot_vars %>%+ var_missings_info, |
| 659 | +1217 | ! |
- tibble::column_to_rownames("label") %>%
+ FUN.VALUE = character(1), |
| 660 | +1218 | ! |
- sweep(1, apply(ANL[keep_columns], 2, mean, na.rm = TRUE)) %>%+ USE.NAMES = FALSE |
| 661 | -! | +||
| 1219 | +
- tibble::rownames_to_column("label") %>%
+ ) |
||
| 662 | -! | +||
| 1220 | +
- dplyr::mutate(+ |
||
| 663 | -! | +||
| 1221 | +
- xstart = mean(pca$x[, x_axis], na.rm = TRUE),+ # get icons proper for the data types |
||
| 664 | +1222 | ! |
- ystart = mean(pca$x[, y_axis], na.rm = TRUE)+ icons <- stats::setNames(teal.slice:::variable_types(df), colnames(df)) |
| 665 | +1223 |
- )+ |
|
| 666 | -+ | ||
| 1224 | +! |
- },+ join_keys <- get_join_keys(data) |
|
| 667 | +1225 | ! |
- env = list(x_axis = x_axis, y_axis = y_axis)+ if (!is.null(join_keys)) {
|
| 668 | -+ | ||
| 1226 | +! |
- )+ icons[intersect(join_keys$get(dataset_name)[[dataset_name]], colnames(df))] <- "primary_key" |
|
| 669 | +1227 |
- } else {
+ } |
|
| 670 | +1228 | ! |
- quote(rot_vars <- rot_vars %>% dplyr::mutate(xstart = 0, ystart = 0))+ icons <- variable_type_icons(icons) |
| 671 | +1229 |
- }+ |
|
| 672 | +1230 |
- ) %>%+ # generate sparklines |
|
| 673 | +1231 | ! |
- teal.code::eval_code(+ sparklines_html <- vapply( |
| 674 | +1232 | ! |
- substitute(+ df, |
| 675 | +1233 | ! |
- expr = rot_vars <- rot_vars %>% dplyr::filter(label %in% variables),+ create_sparklines, |
| 676 | +1234 | ! |
- env = list(variables = variables)- |
-
| 677 | -- |
- )+ FUN.VALUE = character(1), |
|
| 678 | -+ | ||
| 1235 | +! |
- )+ USE.NAMES = FALSE |
|
| 679 | +1236 |
- }+ ) |
|
| 680 | +1237 | ||
| 681 | +1238 | ! |
- pca_plot_biplot_expr <- list(quote(ggplot()))- |
-
| 682 | -- |
-
+ df_output <- data.frame( |
|
| 683 | +1239 | ! |
- if (length(resp_col) == 0) {
+ Type = icons, |
| 684 | +1240 | ! |
- pca_plot_biplot_expr <- c(+ Variable = names(labels), |
| 685 | +1241 | ! |
- pca_plot_biplot_expr,+ Label = labels, |
| 686 | +1242 | ! |
- substitute(+ Missings = missings, |
| 687 | +1243 | ! |
- geom_point(aes_string(x = x_axis, y = y_axis), data = pca_rot, alpha = alpha, size = size),+ Sparklines = sparklines_html, |
| 688 | +1244 | ! |
- list(x_axis = input$x_axis, y_axis = input$y_axis, alpha = input$alpha, size = input$size)+ stringsAsFactors = FALSE |
| 689 | +1245 |
- )+ ) |
|
| 690 | +1246 |
- )- |
- |
| 691 | -! | -
- dev_labs <- list()+ } |
|
| 692 | +1247 |
- } else {
- |
- |
| 693 | -! | -
- rp_keys <- setdiff(+ |
|
| 694 | -! | +||
| 1248 | +
- colnames(ANL),+ # Select row 1 as default / fallback |
||
| 695 | +1249 | ! |
- as.character(unlist(merged$anl_input_r()$columns_source))+ selected_ix <- 1 |
| 696 | -! | +||
| 1250 | +
- ) # nolint+ # Define starting page index (base-0 index of the first item on page |
||
| 697 | +1251 |
-
+ # note: in many cases it's not the item itself |
|
| 698 | +1252 | ! |
- response <- ANL[[resp_col]]+ selected_page_ix <- 0 |
| 699 | +1253 | ||
| 700 | -! | -
- aes_biplot <- substitute(- |
- |
| 701 | -! | +||
| 1254 | +
- aes_string(x = x_axis, y = y_axis, color = "response"),+ # Retrieve current selected variable if any |
||
| 702 | +1255 | ! |
- env = list(x_axis = x_axis, y_axis = y_axis)- |
-
| 703 | -- |
- )+ isolated_variable <- shiny::isolate(plot_var$variable[[dataset_name]]) |
|
| 704 | +1256 | ||
| 705 | +1257 | ! |
- qenv <- teal.code::eval_code(+ if (!is.null(isolated_variable)) {
|
| 706 | +1258 | ! |
- qenv,+ index <- which(columns_names[[dataset_name]] == isolated_variable)[1] |
| 707 | +1259 | ! |
- substitute(response <- ANL[[resp_col]], env = list(resp_col = resp_col))+ if (!is.null(index) && !is.na(index) && length(index) > 0) selected_ix <- index |
| 708 | +1260 |
- )+ } |
|
| 709 | +1261 | ||
| 710 | -! | +||
| 1262 | +
- dev_labs <- list(color = varname_w_label(resp_col, ANL))+ # Retrieve the index of the first item of the current page |
||
| 711 | +1263 |
-
+ # it works with varying number of entries on the page (10, 25, ...) |
|
| 712 | +1264 | ! |
- scales_biplot <-+ table_id_sel <- paste0("variable_browser_", dataset_name, "_state")
|
| 713 | +1265 | ! |
- if (is.character(response) || is.factor(response) || (is.numeric(response) && length(unique(response)) <= 6)) { # nolint
+ dt_state <- shiny::isolate(input[[table_id_sel]]) |
| 714 | +1266 | ! |
- qenv <- teal.code::eval_code(+ if (selected_ix != 1 && !is.null(dt_state)) {
|
| 715 | +1267 | ! |
- qenv,+ selected_page_ix <- floor(selected_ix / dt_state$length) * dt_state$length |
| 716 | -! | +||
| 1268 | +
- quote(pca_rot$response <- as.factor(response))+ } |
||
| 717 | +1269 |
- )+ |
|
| 718 | +1270 | ! |
- quote(scale_color_brewer(palette = "Dark2"))+ DT::datatable( |
| 719 | +1271 | ! |
- } else if (inherits(response, "Date")) {
+ df_output, |
| 720 | +1272 | ! |
- qenv <- teal.code::eval_code(+ escape = FALSE, |
| 721 | +1273 | ! |
- qenv,+ rownames = FALSE, |
| 722 | +1274 | ! |
- quote(pca_rot$response <- numeric(response))+ selection = list(mode = "single", target = "row", selected = selected_ix), |
| 723 | -+ | ||
| 1275 | +! |
- )+ options = list( |
|
| 724 | -+ | ||
| 1276 | +! |
-
+ fnDrawCallback = htmlwidgets::JS("function() { HTMLWidgets.staticRender(); }"),
|
|
| 725 | +1277 | ! |
- quote(+ pageLength = input[[paste0(table_ui_id, "_rows")]], |
| 726 | +1278 | ! |
- scale_color_gradient(+ displayStart = selected_page_ix |
| 727 | -! | +||
| 1279 | +
- low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],
+ ) |
||
| 728 | -! | +||
| 1280 | +
- high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1],
+ ) |
||
| 729 | -! | +||
| 1281 | +
- labels = function(x) as.Date(x, origin = "1970-01-01")+ }) |
||
| 730 | +1282 |
- )+ } |
|
| 731 | +1283 |
- )+ |
|
| 732 | +1284 |
- } else {
+ #' Creates observers updating the currently selected column |
|
| 733 | -! | +||
| 1285 | +
- qenv <- teal.code::eval_code(+ #' |
||
| 734 | -! | +||
| 1286 | +
- qenv,+ #' @description |
||
| 735 | -! | +||
| 1287 | +
- quote(pca_rot$response <- response)+ #' The created observers update the column currently selected in the left-hand side |
||
| 736 | +1288 |
- )+ #' tabset panel. |
|
| 737 | -! | +||
| 1289 | +
- quote(scale_color_gradient(+ #' |
||
| 738 | -! | +||
| 1290 | +
- low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],
+ #' @note |
||
| 739 | -! | +||
| 1291 | +
- high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
+ #' Creates an observer for each dataset (each tab in the tabset panel). |
||
| 740 | +1292 |
- ))+ #' |
|
| 741 | +1293 |
- }+ #' @inheritParams render_tabset_panel_content |
|
| 742 | +1294 |
-
+ #' @keywords internal |
|
| 743 | -! | +||
| 1295 | +
- pca_plot_biplot_expr <- c(+ establish_updating_selection <- function(datanames, input, plot_var, columns_names) {
|
||
| 744 | +1296 | ! |
- pca_plot_biplot_expr,+ lapply(datanames, function(dataset_name) {
|
| 745 | +1297 | ! |
- substitute(+ table_ui_id <- paste0("variable_browser_", dataset_name)
|
| 746 | +1298 | ! |
- geom_point(aes_biplot, data = pca_rot, alpha = alpha, size = size),+ table_id_sel <- paste0(table_ui_id, "_rows_selected") |
| 747 | +1299 | ! |
- env = list(aes_biplot = aes_biplot, alpha = alpha, size = size)+ observeEvent(input[[table_id_sel]], {
|
| 748 | -+ | ||
| 1300 | +! |
- ),+ plot_var$data <- dataset_name |
|
| 749 | +1301 | ! |
- scales_biplot+ plot_var$variable[[dataset_name]] <- columns_names[[dataset_name]][input[[table_id_sel]]] |
| 750 | +1302 |
- )+ }) |
|
| 751 | +1303 |
- }+ }) |
|
| 752 | +1304 | ++ |
+ }+ |
+
| 1305 | |||
| 753 | -! | +||
| 1306 | +
- if (!is.null(input$variables)) {
+ get_bin_width <- function(x_vec, scaling_factor = 2) {
|
||
| 754 | +1307 | ! |
- pca_plot_biplot_expr <- c(+ x_vec <- x_vec[!is.na(x_vec)] |
| 755 | +1308 | ! |
- pca_plot_biplot_expr,+ qntls <- stats::quantile(x_vec, probs = c(0.1, 0.25, 0.75, 0.9), type = 2) |
| 756 | +1309 | ! |
- substitute(+ iqr <- qntls[3] - qntls[2] |
| 757 | +1310 | ! |
- geom_segment(+ binwidth <- max(scaling_factor * iqr / length(x_vec) ^ (1 / 3), sqrt(qntls[4] - qntls[1])) # styler: off |
| 758 | +1311 | ! |
- aes_string(x = "xstart", y = "ystart", xend = x_axis, yend = y_axis),+ binwidth <- ifelse(binwidth == 0, 1, binwidth) |
| 759 | -! | +||
| 1312 | +
- data = rot_vars,+ # to ensure at least two bins when variable span is very small |
||
| 760 | +1313 | ! |
- lineend = "round", linejoin = "round",+ x_span <- diff(range(x_vec)) |
| 761 | +1314 | ! |
- arrow = grid::arrow(length = grid::unit(0.5, "cm"))+ if (isTRUE(x_span / binwidth >= 2)) binwidth else x_span / 2 |
| 762 | +1315 |
- ),+ } |
|
| 763 | -! | +||
| 1316 | +
- env = list(x_axis = x_axis, y_axis = y_axis)+ |
||
| 764 | +1317 |
- ),+ custom_sparkline_formatter <- function(labels, counts) {
|
|
| 765 | +1318 | ! |
- substitute(+ htmlwidgets::JS( |
| 766 | +1319 | ! |
- geom_label(+ sprintf( |
| 767 | +1320 | ! |
- aes_string(+ "function(sparkline, options, field) {
|
| 768 | +1321 | ! |
- x = x_axis,+ return 'ID: ' + %s[field[0].offset] + '<br>' + 'Count: ' + %s[field[0].offset];+ |
+
| 1322 | ++ |
+ }", |
|
| 769 | +1323 | ! |
- y = y_axis,+ jsonlite::toJSON(labels), |
| 770 | +1324 | ! |
- label = "label"+ jsonlite::toJSON(counts) |
| 771 | +1325 |
- ),+ ) |
|
| 772 | -! | +||
| 1326 | +
- data = rot_vars,+ ) |
||
| 773 | -! | +||
| 1327 | +
- nudge_y = 0.1,+ } |
||
| 774 | -! | +||
| 1328 | +
- fontface = "bold"+ |
||
| 775 | +1329 |
- ),+ #' Removes the outlier observation from an array |
|
| 776 | -! | +||
| 1330 | +
- env = list(x_axis = x_axis, y_axis = y_axis)+ #' |
||
| 777 | +1331 |
- ),+ #' @param var (`numeric`) a numeric vector |
|
| 778 | -! | +||
| 1332 | +
- quote(geom_point(aes(x = xstart, y = ystart), data = rot_vars, shape = "x", size = 5))+ #' @param outlier_definition (`numeric`) if `0` then no outliers are removed, otherwise |
||
| 779 | +1333 |
- )+ #' outliers (those more than `outlier_definition*IQR below/above Q1/Q3`) are removed |
|
| 780 | +1334 |
- }+ #' @returns (`numeric`) vector without the outlier values |
|
| 781 | +1335 |
-
+ #' @keywords internal |
|
| 782 | -! | +||
| 1336 | +
- angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)+ remove_outliers_from <- function(var, outlier_definition) {
|
||
| 783 | -! | +||
| 1337 | +3x |
- hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)+ if (outlier_definition == 0) {
+ |
+ |
| 1338 | +1x | +
+ return(var) |
|
| 784 | +1339 |
-
+ } |
|
| 785 | -! | +||
| 1340 | +2x |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ q1_q3 <- stats::quantile(var, probs = c(0.25, 0.75), type = 2, na.rm = TRUE) |
|
| 786 | -! | +||
| 1341 | +2x |
- labs = dev_labs,+ iqr <- q1_q3[2] - q1_q3[1] |
|
| 787 | -! | +||
| 1342 | +2x |
- theme = list(+ var[var >= q1_q3[1] - outlier_definition * iqr & var <= q1_q3[2] + outlier_definition * iqr] |
|
| 788 | -! | +||
| 1343 | +
- text = substitute(element_text(size = font_size), list(font_size = font_size)),+ } |
||
| 789 | -! | +
| 1 | +
- axis.text.x = substitute(+ #' File Viewer Teal Module |
||
| 790 | -! | +||
| 2 | +
- element_text(angle = angle_val, hjust = hjust_val),+ #' |
||
| 791 | -! | +||
| 3 | +
- list(angle_val = angle, hjust_val = hjust)+ #' The file viewer module provides a tool to view static files. |
||
| 792 | +4 |
- )+ #' Supported formats include text formats, \code{PDF}, \code{PNG}, \code{APNG},
|
|
| 793 | +5 |
- )+ #' \code{JPEG}, \code{SVG}, \code{WEBP}, \code{GIF} and \code{BMP}.
|
|
| 794 | +6 |
- )+ #' |
|
| 795 | +7 |
-
+ #' @inheritParams teal::module |
|
| 796 | -! | +||
| 8 | +
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ #' @inheritParams shared_params |
||
| 797 | -! | +||
| 9 | +
- user_plot = ggplot2_args[["Biplot"]],+ #' @param input_path optional, (`list`) of the input paths to either: specific files of accepted formats, |
||
| 798 | -! | +||
| 10 | +
- user_default = ggplot2_args$default,+ #' a directory or a URL. The paths can be specified as absolute paths or relative to the running |
||
| 799 | -! | +||
| 11 | +
- module_plot = dev_ggplot2_args+ #' directory of the application. Will default to current working directory if not supplied. |
||
| 800 | +12 |
- )+ #' |
|
| 801 | +13 |
-
+ #' @export |
|
| 802 | -! | +||
| 14 | +
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ #' |
||
| 803 | -! | +||
| 15 | +
- all_ggplot2_args,+ #' @examples |
||
| 804 | -! | +||
| 16 | +
- ggtheme = ggtheme+ #' data <- data.frame(1) |
||
| 805 | +17 |
- )+ #' app <- teal::init( |
|
| 806 | +18 |
-
+ #' data = teal_data( |
|
| 807 | -! | +||
| 19 | +
- pca_plot_biplot_expr <- c(+ #' dataset("data", data)
|
||
| 808 | -! | +||
| 20 | +
- pca_plot_biplot_expr,+ #' ), |
||
| 809 | -! | +||
| 21 | +
- parsed_ggplot2_args+ #' modules = teal::modules( |
||
| 810 | +22 |
- )+ #' teal.modules.general::tm_file_viewer( |
|
| 811 | +23 |
-
+ #' input_path = list( |
|
| 812 | -! | +||
| 24 | +
- teal.code::eval_code(+ #' folder = system.file("sample_files", package = "teal.modules.general"),
|
||
| 813 | -! | +||
| 25 | +
- qenv,+ #' png = system.file("sample_files/sample_file.png", package = "teal.modules.general"),
|
||
| 814 | -! | +||
| 26 | +
- substitute(+ #' txt = system.file("sample_files/sample_file.txt", package = "teal.modules.general"),
|
||
| 815 | -! | +||
| 27 | +
- expr = {
+ #' url = |
||
| 816 | -! | +||
| 28 | +
- g <- plot_call+ #' "https://www.fda.gov/files/drugs/published/Portable-Document-Format-Specifications.pdf" |
||
| 817 | -! | +||
| 29 | +
- print(g)+ #' ) |
||
| 818 | +30 |
- },+ #' ) |
|
| 819 | -! | +||
| 31 | +
- env = list(+ #' ) |
||
| 820 | -! | +||
| 32 | +
- plot_call = Reduce(function(x, y) call("+", x, y), pca_plot_biplot_expr)
+ #' ) |
||
| 821 | +33 |
- )+ #' if (interactive()) {
|
|
| 822 | +34 |
- )+ #' shinyApp(app$ui, app$server) |
|
| 823 | +35 |
- )+ #' } |
|
| 824 | +36 |
- }+ #' |
|
| 825 | +37 |
-
+ tm_file_viewer <- function(label = "File Viewer Module", |
|
| 826 | +38 |
- # plot pc_var ----+ input_path = list("Current Working Directory" = ".")) {
|
|
| 827 | +39 | ! |
- plot_pc_var <- function(base_q) {
+ logger::log_info("Initializing tm_file_viewer")
|
| 828 | +40 | ! |
- pc <- input$pc # nolint+ if (length(label) == 0 || identical(label, "")) {
|
| 829 | +41 | ! |
- ggtheme <- input$ggtheme+ label <- " " |
| 830 | +42 |
-
+ } |
|
| 831 | +43 | ! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels # nolint+ if (length(input_path) == 0 || identical(input_path, "")) {
|
| 832 | +44 | ! |
- font_size <- input$font_size # nolint+ input_path <- list() |
| 833 | +45 | - - | -|
| 834 | -! | -
- angle <- ifelse(rotate_xaxis_labels, 45, 0)- |
- |
| 835 | -! | -
- hjust <- ifelse(rotate_xaxis_labels, 1, 0.5)+ } |
|
| 836 | +46 | ||
| 837 | -! | -
- dev_ggplot2_args <- teal.widgets::ggplot2_args(- |
- |
| 838 | -! | -
- theme = list(- |
- |
| 839 | +47 | ! |
- text = substitute(element_text(size = font_size), list(font_size = font_size)),+ checkmate::assert_string(label) |
| 840 | +48 | ! |
- axis.text.x = substitute(+ checkmate::assert( |
| 841 | +49 | ! |
- element_text(angle = angle_val, hjust = hjust_val),+ checkmate::check_list(input_path, types = "character", min.len = 0), |
| 842 | +50 | ! |
- list(angle_val = angle, hjust_val = hjust)+ checkmate::check_character(input_path, min.len = 1) |
| 843 | +51 |
- )+ ) |
|
| 844 | +52 |
- )+ |
|
| 845 | -+ | ||
| 53 | +! |
- )+ if (length(input_path) > 0) {
|
|
| 846 | -+ | ||
| 54 | +! |
-
+ valid_url <- function(url_input, timeout = 2) {
|
|
| 847 | +55 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ con <- try(url(url_input), silent = TRUE) |
| 848 | +56 | ! |
- user_plot = ggplot2_args[["Eigenvector plot"]],+ check <- suppressWarnings(try(open.connection(con, open = "rt", timeout = timeout), silent = TRUE)[1]) |
| 849 | +57 | ! |
- user_default = ggplot2_args$default,+ try(close.connection(con), silent = TRUE) |
| 850 | +58 | ! |
- module_plot = dev_ggplot2_args+ ifelse(is.null(check), TRUE, FALSE) |
| 851 | +59 |
- )+ }+ |
+ |
| 60 | +! | +
+ idx <- vapply(input_path, function(x) file.exists(x) || valid_url(x), logical(1)) |
|
| 852 | +61 | ||
| 853 | +62 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ if (!all(idx)) {
|
| 854 | +63 | ! |
- all_ggplot2_args,+ warning( |
| 855 | +64 | ! |
- ggtheme = ggtheme+ paste0( |
| 856 | -+ | ||
| 65 | +! |
- )+ "Non-existent file or url path. Please provide valid paths for:\n",+ |
+ |
| 66 | +! | +
+ paste0(input_path[!idx], collapse = "\n") |
|
| 857 | +67 |
-
+ ) |
|
| 858 | -! | +||
| 68 | +
- ggplot_exprs <- c(+ ) |
||
| 859 | -! | +||
| 69 | +
- list(+ } |
||
| 860 | +70 | ! |
- quote(ggplot(pca_rot)),+ input_path <- input_path[idx] |
| 861 | -! | +||
| 71 | +
- substitute(+ } else {
|
||
| 862 | +72 | ! |
- geom_bar(+ warning( |
| 863 | +73 | ! |
- aes_string(x = "Variable", y = pc),+ "No file or url paths were provided." |
| 864 | -! | +||
| 74 | +
- stat = "identity",+ ) |
||
| 865 | -! | +||
| 75 | +
- color = "black",+ } |
||
| 866 | -! | +||
| 76 | +
- fill = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
+
|
||
| 867 | +77 |
- ),+ |
|
| 868 | +78 | ! |
- env = list(pc = pc)+ args <- as.list(environment()) |
| 869 | +79 |
- ),+ |
|
| 870 | +80 | ! |
- substitute(+ module( |
| 871 | +81 | ! |
- geom_text(+ label = label, |
| 872 | +82 | ! |
- aes(+ server = srv_viewer, |
| 873 | +83 | ! |
- x = Variable,+ server_args = list(input_path = input_path), |
| 874 | +84 | ! |
- y = pc_name,+ ui = ui_viewer, |
| 875 | +85 | ! |
- label = round(pc_name, 3),+ ui_args = args, |
| 876 | +86 | ! |
- vjust = ifelse(pc_name > 0, -0.5, 1.3)+ datanames = NULL |
| 877 | +87 |
- )+ ) |
|
| 878 | +88 |
- ),- |
- |
| 879 | -! | -
- env = list(pc_name = as.name(pc))+ } |
|
| 880 | +89 |
- )+ |
|
| 881 | +90 |
- ),+ ui_viewer <- function(id, ...) {
|
|
| 882 | +91 | ! |
- parsed_ggplot2_args$labs,+ args <- list(...) |
| 883 | +92 | ! |
- parsed_ggplot2_args$ggtheme,+ ns <- NS(id)+ |
+
| 93 | ++ | + | |
| 884 | +94 | ! |
- parsed_ggplot2_args$theme+ shiny::tagList( |
| 885 | -+ | ||
| 95 | +! |
- )+ include_css_files("custom"),
|
|
| 886 | -+ | ||
| 96 | +! |
-
+ teal.widgets::standard_layout( |
|
| 887 | +97 | ! |
- teal.code::eval_code(+ output = div( |
| 888 | +98 | ! |
- base_q,+ uiOutput(ns("output"))
|
| 889 | -! | +||
| 99 | +
- substitute(+ ), |
||
| 890 | +100 | ! |
- expr = {
+ encoding = div( |
| 891 | +101 | ! |
- pca_rot <- pca$rotation[, pc, drop = FALSE] %>%+ class = "file_viewer_encoding", |
| 892 | +102 | ! |
- dplyr::as_tibble(rownames = "Variable")+ tags$label("Encodings", class = "text-primary"),
|
| 893 | -+ | ||
| 103 | +! |
-
+ shinyTree::shinyTree( |
|
| 894 | +104 | ! |
- g <- plot_call+ ns("tree"),
|
| 895 | -+ | ||
| 105 | +! |
-
+ dragAndDrop = FALSE, |
|
| 896 | +106 | ! |
- print(g)+ sort = FALSE, |
| 897 | -+ | ||
| 107 | +! |
- },+ wholerow = TRUE, |
|
| 898 | +108 | ! |
- env = list(+ theme = "proton", |
| 899 | +109 | ! |
- pc = pc,+ multiple = FALSE |
| 900 | -! | +||
| 110 | +
- plot_call = Reduce(function(x, y) call("+", x, y), ggplot_exprs)
+ ) |
||
| 901 | +111 |
- )+ ) |
|
| 902 | +112 |
- )+ ) |
|
| 903 | +113 |
- )+ ) |
|
| 904 | +114 |
- }+ } |
|
| 905 | +115 | ||
| 906 | +116 |
- # plot final ----+ srv_viewer <- function(id, input_path) {
|
|
| 907 | +117 | ! |
- output_q <- reactive({
+ moduleServer(id, function(input, output, session) {
|
| 908 | +118 | ! |
- req(computation())+ temp_dir <- tempfile() |
| 909 | +119 | ! |
- teal::validate_inputs(iv_r())+ if (!dir.exists(temp_dir)) {
|
| 910 | +120 | ! |
- teal::validate_inputs(iv_extra, header = "Plot settings are required")+ dir.create(temp_dir, recursive = TRUE) |
| 911 | +121 |
-
+ } |
|
| 912 | +122 | ! |
- switch(input$plot_type,+ addResourcePath(basename(temp_dir), temp_dir)+ |
+
| 123 | ++ | + | |
| 913 | +124 | ! |
- "Elbow plot" = plot_elbow(computation()),+ test_path_text <- function(selected_path, type) {
|
| 914 | +125 | ! |
- "Circle plot" = plot_circle(computation()),+ out <- tryCatch( |
| 915 | +126 | ! |
- "Biplot" = plot_biplot(computation()),+ expr = {
|
| 916 | +127 | ! |
- "Eigenvector plot" = plot_pc_var(computation()),+ if (type != "url") {
|
| 917 | +128 | ! |
- stop("Unknown plot")
+ selected_path <- normalizePath(selected_path, winslash = "/") |
| 918 | +129 |
- )+ } |
|
| 919 | -+ | ||
| 130 | +! |
- })+ readLines(con = selected_path) |
|
| 920 | +131 |
-
+ }, |
|
| 921 | +132 | ! |
- plot_r <- reactive({
+ error = function(cond) FALSE, |
| 922 | +133 | ! |
- output_q()[["g"]]+ warning = function(cond) {
+ |
+
| 134 | +! | +
+ `if`(grepl("^incomplete final line found on", cond[[1]]), suppressWarnings(eval(cond[[2]])), FALSE)
|
|
| 923 | +135 |
- })+ } |
|
| 924 | +136 |
-
+ ) |
|
| 925 | -! | +||
| 137 | +
- pws <- teal.widgets::plot_with_settings_srv(+ } |
||
| 926 | -! | +||
| 138 | +
- id = "pca_plot",+ |
||
| 927 | +139 | ! |
- plot_r = plot_r,+ handle_connection_type <- function(selected_path) {
|
| 928 | +140 | ! |
- height = plot_height,+ file_extension <- tools::file_ext(selected_path) |
| 929 | +141 | ! |
- width = plot_width,+ file_class <- suppressWarnings(file(selected_path)) |
| 930 | +142 | ! |
- graph_align = "center"+ close(file_class) |
| 931 | +143 |
- )+ + |
+ |
| 144 | +! | +
+ output_text <- test_path_text(selected_path, type = class(file_class)[1]) |
|
| 932 | +145 | ||
| 933 | -+ | ||
| 146 | +! |
- # tables ----+ if (class(file_class)[1] == "url") {
|
|
| 934 | +147 | ! |
- output$tbl_importance <- renderTable(+ list(selected_path = selected_path, output_text = output_text)+ |
+
| 148 | ++ |
+ } else {
|
|
| 935 | +149 | ! |
- expr = {
+ file.copy(normalizePath(selected_path, winslash = "/"), temp_dir) |
| 936 | +150 | ! |
- req("importance" %in% input$tables_display, computation())
+ selected_path <- file.path(basename(temp_dir), basename(selected_path)) |
| 937 | +151 | ! |
- computation()[["tbl_importance"]]+ list(selected_path = selected_path, output_text = output_text) |
| 938 | +152 |
- },+ }+ |
+ |
| 153 | ++ |
+ }+ |
+ |
| 154 | ++ | + | |
| 939 | +155 | ! |
- bordered = TRUE,+ display_file <- function(selected_path) {
|
| 940 | +156 | ! |
- align = "c",+ con_type <- handle_connection_type(selected_path) |
| 941 | +157 | ! |
- digits = 3+ file_extension <- tools::file_ext(selected_path) |
| 942 | -+ | ||
| 158 | +! |
- )+ if (file_extension %in% c("png", "apng", "jpg", "jpeg", "svg", "gif", "webp", "bmp")) {
|
|
| 943 | -+ | ||
| 159 | +! |
-
+ tags$img(src = con_type$selected_path, alt = "file does not exist") |
|
| 944 | +160 | ! |
- output$tbl_importance_ui <- renderUI({
+ } else if (file_extension == "pdf") {
|
| 945 | +161 | ! |
- req("importance" %in% input$tables_display)
+ tags$embed( |
| 946 | +162 | ! |
- div(+ class = "embed_pdf", |
| 947 | +163 | ! |
- align = "center",+ src = con_type$selected_path+ |
+
| 164 | ++ |
+ ) |
|
| 948 | +165 | ! |
- tags$h4("Principal components importance"),
+ } else if (!isFALSE(con_type$output_text[1])) {
|
| 949 | +166 | ! |
- tableOutput(session$ns("tbl_importance")),
+ tags$pre(paste0(con_type$output_text, collapse = "\n"))+ |
+
| 167 | ++ |
+ } else {
|
|
| 950 | +168 | ! |
- hr()+ tags$p("Please select a supported format.")
|
| 951 | +169 |
- )+ } |
|
| 952 | +170 |
- })+ } |
|
| 953 | +171 | ||
| 954 | +172 | ! |
- output$tbl_eigenvector <- renderTable(+ tree_list <- function(file_or_dir) {
|
| 955 | +173 | ! |
- expr = {
+ nested_list <- lapply(file_or_dir, function(path) {
|
| 956 | +174 | ! |
- req("eigenvector" %in% input$tables_display, req(computation()))
+ file_class <- suppressWarnings(file(path)) |
| 957 | +175 | ! |
- computation()[["tbl_eigenvector"]]+ close(file_class) |
| 958 | -+ | ||
| 176 | +! |
- },+ if (class(file_class)[[1]] != "url") {
|
|
| 959 | +177 | ! |
- bordered = TRUE,+ isdir <- file.info(path)$isdir |
| 960 | +178 | ! |
- align = "c",+ if (!isdir) {
|
| 961 | +179 | ! |
- digits = 3+ structure(path, ancestry = path, sticon = "file") |
| 962 | +180 |
- )+ } else {
|
|
| 963 | -+ | ||
| 181 | +! |
-
+ files <- list.files(path, full.names = TRUE, include.dirs = TRUE) |
|
| 964 | +182 | ! |
- output$tbl_eigenvector_ui <- renderUI({
+ out <- lapply(files, function(x) tree_list(x)) |
| 965 | +183 | ! |
- req("eigenvector" %in% input$tables_display)
+ out <- unlist(out, recursive = FALSE) |
| 966 | +184 | ! |
- div(+ if (length(files) > 0) names(out) <- basename(files) |
| 967 | +185 | ! |
- align = "center",+ out |
| 968 | -! | +||
| 186 | +
- tags$h4("Eigenvectors"),
+ } |
||
| 969 | -! | +||
| 187 | +
- tableOutput(session$ns("tbl_eigenvector")),
+ } else {
|
||
| 970 | +188 | ! |
- hr()+ structure(path, ancestry = path, sticon = "file") |
| 971 | +189 |
- )+ } |
|
| 972 | +190 |
- })+ }) |
|
| 973 | +191 | ||
| 974 | +192 | ! |
- output$all_plots <- renderUI({
+ missing_labels <- if (is.null(names(nested_list))) seq_along(nested_list) else which(names(nested_list) == "") |
| 975 | +193 | ! |
- teal::validate_inputs(iv_r())+ names(nested_list)[missing_labels] <- file_or_dir[missing_labels] |
| 976 | +194 | ! |
- teal::validate_inputs(iv_extra, header = "Plot settings are required")+ nested_list |
| 977 | +195 |
-
+ } |
|
| 978 | -! | +||
| 196 | +
- validation()+ |
||
| 979 | +197 | ! |
- tags$div(+ output$tree <- shinyTree::renderTree({
|
| 980 | +198 | ! |
- class = "overflow-scroll",+ if (length(input_path) > 0) {
|
| 981 | +199 | ! |
- uiOutput(session$ns("tbl_importance_ui")),
+ tree_list(input_path) |
| 982 | -! | +||
| 200 | +
- uiOutput(session$ns("tbl_eigenvector_ui")),
+ } else {
|
||
| 983 | +201 | ! |
- teal.widgets::plot_with_settings_ui(id = session$ns("pca_plot"))
+ list("Empty Path" = NULL)
|
| 984 | +202 |
- )+ } |
|
| 985 | +203 |
}) |
|
| 986 | +204 | ||
| 987 | +205 | ! |
- teal.widgets::verbatim_popup_srv(+ output$output <- renderUI({
|
| 988 | +206 | ! |
- id = "warning",+ validate( |
| 989 | +207 | ! |
- verbatim_content = reactive(teal.code::get_warnings(output_q())),+ need( |
| 990 | +208 | ! |
- title = "Warning",+ length(shinyTree::get_selected(input$tree)) > 0, |
| 991 | +209 | ! |
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ "Please select a file." |
| 992 | +210 |
- )+ ) |
|
| 993 | +211 |
-
+ ) |
|
| 994 | -! | +||
| 212 | +
- teal.widgets::verbatim_popup_srv(+ |
||
| 995 | +213 | ! |
- id = "rcode",+ obj <- shinyTree::get_selected(input$tree, format = "names")[[1]] |
| 996 | +214 | ! |
- verbatim_content = reactive(teal.code::get_code(output_q())),+ repo <- attr(obj, "ancestry") |
| 997 | +215 | ! |
- title = "R Code for PCA"+ repo_collapsed <- if (length(repo) > 1) paste0(repo, collapse = "/") else repo |
| 998 | -+ | ||
| 216 | +! |
- )+ is_not_named <- file.exists(file.path(c(repo_collapsed, obj[1])))[1] |
|
| 999 | +217 | ||
| 1000 | -+ | ||
| 218 | +! |
- ### REPORTER+ if (is_not_named) {
|
|
| 1001 | +219 | ! |
- if (with_reporter) {
+ selected_path <- do.call("file.path", as.list(c(repo, obj[1])))
|
| 1002 | -! | +||
| 220 | +
- card_fun <- function(comment) {
+ } else {
|
||
| 1003 | +221 | ! |
- card <- teal::TealReportCard$new()+ if (length(repo) == 0) {
|
| 1004 | +222 | ! |
- card$set_name("PCA Plot")
+ selected_path <- do.call("file.path", as.list(attr(input$tree[[obj[1]]], "ancestry")))
|
| 1005 | -! | +||
| 223 | +
- card$append_text("PCA Plot", "header2")
+ } else {
|
||
| 1006 | +224 | ! |
- card$append_text("Principal Component Analysis Plot", "header3")
+ selected_path <- do.call("file.path", as.list(attr(input$tree[[repo]][[obj[1]]], "ancestry")))
|
| 1007 | -! | +||
| 225 | +
- if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ } |
||
| 1008 | -! | +||
| 226 | +
- card$append_text("Principal Components Table", "header3")
+ } |
||
| 1009 | -! | +||
| 227 | +
- card$append_table(computation()[["tbl_importance"]])+ |
||
| 1010 | +228 | ! |
- card$append_text("Eigenvectors Table", "header3")
+ validate( |
| 1011 | +229 | ! |
- card$append_table(computation()[["tbl_eigenvector"]])+ need( |
| 1012 | +230 | ! |
- card$append_text("Plot", "header3")
+ !isTRUE(file.info(selected_path)$isdir) && length(selected_path) > 0, |
| 1013 | +231 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ "Please select a single file." |
| 1014 | -! | +||
| 232 | +
- if (!comment == "") {
+ ) |
||
| 1015 | -! | +||
| 233 | +
- card$append_text("Comment", "header3")
+ ) |
||
| 1016 | +234 | ! |
- card$append_text(comment)+ display_file(selected_path) |
| 1017 | +235 |
- }+ }) |
|
| 1018 | -! | +||
| 236 | +
- card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n"))+ |
||
| 1019 | +237 | ! |
- card- |
-
| 1020 | -- |
- }+ onStop(function() {
|
|
| 1021 | +238 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ removeResourcePath(basename(temp_dir)) |
| 1022 | -+ | ||
| 239 | +! |
- }+ unlink(temp_dir) |
|
| 1023 | +240 |
- ###+ }) |
|
| 1024 | +241 |
}) |
|
| 1025 | +242 |
}@@ -50517,140 +50294,140 @@ teal.modules.general coverage - 2.27% |
| 1 |
- #' Variable Browser Teal Module+ #' Principal component analysis module |
||
| 2 |
- #'+ #' @md |
||
| 3 |
- #' The variable browser provides a table with variable names and labels and a+ #' |
||
| 4 |
- #' plot that visualizes the content of a particular variable.+ #' @inheritParams teal::module |
||
| 5 |
- #'+ #' @inheritParams shared_params |
||
| 6 |
- #' @details Numeric columns with fewer than 30 distinct values can be treated as either factors+ #' @param dat (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 7 |
- #' or numbers with a checkbox allowing users to switch how they are treated (if < 6 unique values+ #' Columns used to compute PCA. |
||
| 8 |
- #' then the default is categorical, otherwise it is numeric).+ #' @param alpha optional, (`numeric`) If scalar then the plot points will have a fixed opacity. If a |
||
| 9 |
- #'+ #' slider should be presented to adjust the plot point opacity dynamically then it can be a vector of |
||
| 10 |
- #' @inheritParams teal::module+ #' length three with `c(value, min, max)`. |
||
| 11 |
- #' @inheritParams shared_params+ #' @param size optional, (`numeric`) If scalar then the plot point sizes will have a fixed size. |
||
| 12 |
- #' @param parent_dataname (`character(1)`) If this `dataname` exists in `datasets_selected`+ #' If a slider should be presented to adjust the plot point sizes dynamically then it can be a |
||
| 13 |
- #' then an extra checkbox will be shown to allow users to not show variables in other datasets+ #' vector of length three with `c(value, min, max)`. |
||
| 14 |
- #' which exist in this `dataname`.+ #' @param font_size optional, (`numeric`) font size control for title, x-axis label, y-axis label and legend. |
||
| 15 |
- #' This is typically used to remove `ADSL` columns in `CDISC` data. In non `CDISC` data this+ #' If scalar then the font size will have a fixed size. If a slider should be presented to adjust the plot |
||
| 16 |
- #' can be ignored. Defaults to `"ADSL"`.+ #' point sizes dynamically then it can be a vector of length three with `c(value, min, max)`. |
||
| 17 |
- #' @param datasets_selected (`character`) A vector of datasets which should be+ #' |
||
| 18 |
- #' shown and in what order. Names in the vector have to correspond with datasets names.+ #' @templateVar ggnames "Elbow plot", "Circle plot", "Biplot", "Eigenvector plot" |
||
| 19 |
- #' If vector of length zero (default) then all datasets are shown.+ #' @template ggplot2_args_multi |
||
| 21 |
- #' @aliases+ #' @export |
||
| 22 |
- #' tm_variable_browser_ui,+ #' |
||
| 23 |
- #' tm_variable_browser_srv,+ #' @examples |
||
| 24 |
- #' tm_variable_browser,+ #' |
||
| 25 |
- #' variable_browser_ui,+ #' # ADSL example |
||
| 26 |
- #' variable_browser_srv,+ #' |
||
| 27 |
- #' variable_browser+ #' library(nestcolor) |
||
| 28 |
- #'+ #' ADSL <- teal.modules.general::rADSL |
||
| 30 |
- #' @export+ #' app <- teal::init( |
||
| 31 |
- #'+ #' data = teal.data::cdisc_data( |
||
| 32 |
- #' @examples+ #' teal.data::cdisc_dataset( |
||
| 33 |
- #'+ #' "ADSL", ADSL, |
||
| 34 |
- #' ADSL <- teal.modules.general::rADSL+ #' code = "ADSL <- teal.modules.general::rADSL" |
||
| 35 |
- #' ADTTE <- teal.modules.general::rADTTE+ #' ), |
||
| 36 |
- #'+ #' check = TRUE |
||
| 37 |
- #' app <- teal::init(+ #' ), |
||
| 38 |
- #' data = teal.data::cdisc_data(+ #' modules = teal::modules( |
||
| 39 |
- #' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
+ #' teal.modules.general::tm_a_pca( |
||
| 40 |
- #' teal.data::cdisc_dataset("ADTTE", ADTTE, code = "ADTTE <- teal.modules.general::rADTTE"),
+ #' "PCA", |
||
| 41 |
- #' check = TRUE+ #' dat = teal.transform::data_extract_spec( |
||
| 42 |
- #' ),+ #' dataname = "ADSL", |
||
| 43 |
- #' modules(+ #' select = teal.transform::select_spec( |
||
| 44 |
- #' teal.modules.general::tm_variable_browser(+ #' choices = teal.transform::variable_choices(data = ADSL, c("BMRKR1", "AGE", "EOSDY")),
|
||
| 45 |
- #' label = "Variable browser",+ #' selected = c("BMRKR1", "AGE"),
|
||
| 46 |
- #' ggplot2_args = teal.widgets::ggplot2_args(+ #' multiple = TRUE |
||
| 47 |
- #' labs = list(subtitle = "Plot generated by Variable Browser Module")+ #' ), |
||
| 48 |
- #' ),+ #' filter = NULL |
||
| 49 |
- #' )+ #' ), |
||
| 50 |
- #' )+ #' ggplot2_args = teal.widgets::ggplot2_args( |
||
| 51 |
- #' )+ #' labs = list(subtitle = "Plot generated by PCA Module") |
||
| 52 |
- #' if (interactive()) {
+ #' ) |
||
| 53 |
- #' shinyApp(app$ui, app$server)+ #' ) |
||
| 54 |
- #' }+ #' ) |
||
| 55 |
- tm_variable_browser <- function(label = "Variable Browser",+ #' ) |
||
| 56 |
- datasets_selected = character(0),+ #' if (interactive()) {
|
||
| 57 |
- parent_dataname = "ADSL",+ #' shinyApp(app$ui, app$server) |
||
| 58 |
- pre_output = NULL,+ #' } |
||
| 59 |
- post_output = NULL,+ #' |
||
| 60 |
- ggplot2_args = teal.widgets::ggplot2_args()) {
+ tm_a_pca <- function(label = "Principal Component Analysis", |
||
| 61 | -! | +
- logger::log_info("Initializing tm_variable_browser")
+ dat, |
|
| 62 | -! | +
- if (!requireNamespace("sparkline", quietly = TRUE)) {
+ plot_height = c(600, 200, 2000), |
|
| 63 | -! | +
- stop("Cannot load sparkline - please install the package or restart your session.")
+ plot_width = NULL, |
|
| 64 |
- }+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
|
||
| 65 | -! | +
- if (!requireNamespace("htmlwidgets", quietly = TRUE)) {
+ ggplot2_args = teal.widgets::ggplot2_args(), |
|
| 66 | -! | +
- stop("Cannot load htmlwidgets - please install the package or restart your session.")
+ rotate_xaxis_labels = FALSE, |
|
| 67 |
- }+ font_size = c(12, 8, 20), |
||
| 68 | -! | +
- if (!requireNamespace("jsonlite", quietly = TRUE)) {
+ alpha = c(1, 0, 1), |
|
| 69 | -! | +
- stop("Cannot load jsonlite - please install the package or restart your session.")
+ size = c(2, 1, 8), |
|
| 70 |
- }+ pre_output = NULL, |
||
| 71 | -! | +
- checkmate::assert_string(label)+ post_output = NULL) {
|
|
| 72 | ! |
- checkmate::assert_character(datasets_selected)+ logger::log_info("Initializing tm_a_pca")
|
|
| 73 | ! |
- checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1)+ if (inherits(dat, "data_extract_spec")) dat <- list(dat) |
|
| 74 | ! |
- checkmate::assert_class(ggplot2_args, "ggplot2_args")+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
|
| 75 | -! | +
- datasets_selected <- unique(datasets_selected)+ |
|
| 76 | -+ | ! |
-
+ checkmate::assert_string(label) |
| 77 | ! |
- module(+ checkmate::assert_list(dat, types = "data_extract_spec") |
|
| 78 | ! |
- label,+ ggtheme <- match.arg(ggtheme) |
|
| 79 | ! |
- server = srv_variable_browser,+ checkmate::assert_flag(rotate_xaxis_labels) |
|
| 80 | -! | +
- ui = ui_variable_browser,+ |
|
| 81 | ! |
- datanames = "all",+ if (length(alpha) == 1) {
|
|
| 82 | ! |
- server_args = list(+ checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1) |
|
| 83 | -! | +
- datasets_selected = datasets_selected,+ } else {
|
|
| 84 | ! |
- parent_dataname = parent_dataname,+ checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1) |
|
| 85 | ! |
- ggplot2_args = ggplot2_args+ checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha") |
|
| 86 |
- ),+ } |
||
| 87 | -! | +
- ui_args = list(+ |
|
| 88 | ! |
- datasets_selected = datasets_selected,+ if (length(size) == 1) {
|
|
| 89 | ! |
- parent_dataname = parent_dataname,+ checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8) |
|
| 90 | -! | +
- pre_output = pre_output,+ } else {
|
|
| 91 | ! |
- post_output = post_output+ checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8) |
|
| 92 | -+ | ! |
- )+ checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size") |
| 93 |
- )+ } |
||
| 94 |
- }+ |
||
| 95 | -+ | ! |
-
+ if (length(font_size) == 1) {
|
| 96 | -+ | ! |
- # ui function+ checkmate::assert_numeric(font_size, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20) |
| 97 |
- ui_variable_browser <- function(id,+ } else {
|
||
| 98 | -+ | ! |
- data,+ checkmate::assert_numeric(font_size, len = 3, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20) |
| 99 | -+ | ! |
- datasets_selected,+ checkmate::assert_numeric(font_size[1], lower = font_size[2], upper = font_size[3], .var.name = "font_size") |
| 100 |
- parent_dataname,+ } |
||
| 101 |
- pre_output = NULL,+ |
||
| 102 | -+ | ! |
- post_output = NULL) {
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 103 | ! |
- ns <- NS(id)+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
|
| 104 | -+ | ! |
-
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 105 | ! |
- datanames <- names(data)+ checkmate::assert_numeric( |
|
| 106 | -+ | ! |
-
+ plot_width[1], |
| 107 | ! |
- if (!identical(datasets_selected, character(0))) {
+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
|
| 108 | -! | +
- stopifnot(all(datasets_selected %in% datanames))+ ) |
|
| 109 | -! | +
- datanames <- datasets_selected+ |
|
| 110 | -+ | ! |
- }+ plot_choices <- c("Elbow plot", "Circle plot", "Biplot", "Eigenvector plot")
|
| 111 | -+ | ! |
-
+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
| 112 | ! |
- shiny::tagList(+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
|
| 113 | -! | +
- include_css_files("custom"),
+
|
|
| 114 | ! |
- shinyjs::useShinyjs(),+ args <- as.list(environment()) |
|
| 115 | -! | +
- teal.widgets::standard_layout(+ |
|
| 116 | ! |
- output = fluidRow(+ data_extract_list <- list(dat = dat) |
|
| 117 | -! | +
- htmlwidgets::getDependency("sparkline"), # needed for sparklines to work
+
|
|
| 118 | ! |
- column(+ module( |
|
| 119 | ! |
- 6,+ label = label, |
|
| 120 | -+ | ! |
- # variable browser+ server = srv_a_pca, |
| 121 | ! |
- teal.widgets::white_small_well(+ ui = ui_a_pca, |
|
| 122 | ! |
- do.call(+ ui_args = args, |
|
| 123 | ! |
- tabsetPanel,+ server_args = c( |
|
| 124 | ! |
- c(+ data_extract_list, |
|
| 125 | ! |
- id = ns("tabset_panel"),
+ list( |
|
| 126 | ! |
- do.call(+ plot_height = plot_height, |
|
| 127 | ! |
- tagList,+ plot_width = plot_width, |
|
| 128 | ! |
- lapply(datanames, function(dataname) {
+ ggplot2_args = ggplot2_args |
|
| 129 | -! | +
- tabPanel(+ ) |
|
| 130 | -! | +
- dataname,+ ), |
|
| 131 | ! |
- div(+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
|
| 132 | -! | +
- class = "mt-4",+ ) |
|
| 133 | -! | +
- textOutput(ns(paste0("dataset_summary_", dataname)))
+ } |
|
| 134 |
- ),+ |
||
| 135 | -! | +
- div(+ |
|
| 136 | -! | +
- class = "mt-4",+ ui_a_pca <- function(id, ...) {
|
|
| 137 | ! |
- teal.widgets::get_dt_rows(+ ns <- NS(id) |
|
| 138 | ! |
- ns(paste0(+ args <- list(...) |
|
| 139 | ! |
- "variable_browser_", dataname+ is_single_dataset_value <- teal.transform::is_single_dataset(args$dat) |
|
| 140 |
- )),+ |
||
| 141 | ! |
- ns(+ color_selector <- args$dat |
|
| 142 | ! |
- paste0("variable_browser_", dataname, "_rows")
+ for (i in seq_along(color_selector)) {
|
|
| 143 | -+ | ! |
- )+ color_selector[[i]]$select$multiple <- FALSE |
| 144 | -+ | ! |
- ),+ color_selector[[i]]$select$always_selected <- NULL |
| 145 | ! |
- DT::dataTableOutput(ns(paste0(+ color_selector[[i]]$select$selected <- NULL |
|
| 146 | -! | +
- "variable_browser_", dataname+ } |
|
| 147 | -! | +
- )), width = "100%")+ |
|
| 148 | -+ | ! |
- )+ shiny::tagList( |
| 149 | -+ | ! |
- )+ include_css_files("custom"),
|
| 150 | -+ | ! |
- })+ teal.widgets::standard_layout( |
| 151 | -+ | ! |
- )+ output = teal.widgets::white_small_well( |
| 152 | -+ | ! |
- )+ uiOutput(ns("all_plots"))
|
| 153 |
- ),+ ), |
||
| 154 | ! |
- shinyjs::hidden({
+ encoding = div( |
|
| 155 | -! | +
- checkboxInput(ns("show_parent_vars"), "Show parent dataset variables", value = FALSE)
+ ### Reporter |
|
| 156 | -+ | ! |
- })+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 157 |
- )+ ### |
||
| 158 | -+ | ! |
- ),+ tags$label("Encodings", class = "text-primary"),
|
| 159 | ! |
- column(+ teal.transform::datanames_input(args["dat"]), |
|
| 160 | ! |
- 6,+ teal.transform::data_extract_ui( |
|
| 161 | ! |
- teal.widgets::white_small_well(+ id = ns("dat"),
|
|
| 162 | -+ | ! |
- ### Reporter+ label = "Data selection", |
| 163 | ! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ data_extract_spec = args$dat, |
|
| 164 | -+ | ! |
- ###+ is_single_dataset = is_single_dataset_value |
| 165 | -! | +
- div(+ ), |
|
| 166 | ! |
- class = "block",+ teal.widgets::panel_group( |
|
| 167 | ! |
- uiOutput(ns("ui_histogram_display"))
+ teal.widgets::panel_item( |
|
| 168 | -+ | ! |
- ),+ title = "Display", |
| 169 | ! |
- div(+ collapsed = FALSE, |
|
| 170 | ! |
- class = "block",+ checkboxGroupInput( |
|
| 171 | ! |
- uiOutput(ns("ui_numeric_display"))
+ ns("tables_display"),
|
|
| 172 | -+ | ! |
- ),+ "Tables display", |
| 173 | ! |
- teal.widgets::plot_with_settings_ui(ns("variable_plot")),
+ choices = c("PC importance" = "importance", "Eigenvectors" = "eigenvector"),
|
|
| 174 | ! |
- br(),+ selected = c("importance", "eigenvector")
|
|
| 175 |
- # input user-defined text size+ ), |
||
| 176 | ! |
- teal.widgets::panel_item(+ radioButtons( |
|
| 177 | ! |
- title = "Plot settings",+ ns("plot_type"),
|
|
| 178 | ! |
- collapsed = TRUE,+ label = "Plot type", |
|
| 179 | ! |
- selectInput(+ choices = args$plot_choices, |
|
| 180 | ! |
- inputId = ns("ggplot_theme"), label = "ggplot2 theme",
+ selected = args$plot_choices[1] |
|
| 181 | -! | +
- choices = c(+ ) |
|
| 182 | -! | +
- "gray", "bw", "linedraw", "light",+ ), |
|
| 183 | ! |
- "dark", "minimal", "classic", "void", "test"+ teal.widgets::panel_item( |
|
| 184 | -+ | ! |
- ),+ title = "Pre-processing", |
| 185 | ! |
- selected = "grey"+ radioButtons( |
|
| 186 | -+ | ! |
- ),+ ns("standardization"), "Standardization",
|
| 187 | ! |
- fluidRow(+ choices = c("None" = "none", "Center" = "center", "Center & Scale" = "center_scale"),
|
|
| 188 | ! |
- column(6, sliderInput(+ selected = "center_scale" |
|
| 189 | -! | +
- inputId = ns("font_size"), label = "font size",
+ ), |
|
| 190 | ! |
- min = 5L, max = 30L, value = 15L, step = 1L, ticks = FALSE+ radioButtons( |
|
| 191 | -+ | ! |
- )),+ ns("na_action"), "NA action",
|
| 192 | ! |
- column(6, sliderInput(+ choices = c("None" = "none", "Drop" = "drop"),
|
|
| 193 | ! |
- inputId = ns("label_rotation"), label = "rotate x labels",
+ selected = "none" |
|
| 194 | -! | +
- min = 0L, max = 90L, value = 45L, step = 1, ticks = FALSE+ ) |
|
| 195 |
- ))+ ), |
||
| 196 | -+ | ! |
- )+ teal.widgets::panel_item( |
| 197 | -+ | ! |
- ),+ title = "Selected plot specific settings", |
| 198 | ! |
- br(),+ collapsed = FALSE, |
|
| 199 | ! |
- teal.widgets::get_dt_rows(ns("variable_summary_table"), ns("variable_summary_table_rows")),
+ uiOutput(ns("plot_settings")),
|
|
| 200 | ! |
- DT::dataTableOutput(ns("variable_summary_table"))
+ conditionalPanel( |
|
| 201 | -+ | ! |
- )+ condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")),
|
| 202 | -+ | ! |
- )+ list( |
| 203 | -+ | ! |
- ),+ teal.transform::data_extract_ui( |
| 204 | ! |
- pre_output = pre_output,+ id = ns("response"),
|
|
| 205 | ! |
- post_output = post_output+ label = "Color by", |
|
| 206 | -+ | ! |
- )+ data_extract_spec = color_selector, |
| 207 | -+ | ! |
- )+ is_single_dataset = is_single_dataset_value |
| 208 |
- }+ ), |
||
| 209 | -+ | ! |
-
+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
|
| 210 | -+ | ! |
- srv_variable_browser <- function(id,+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE)
|
| 211 |
- data,+ ) |
||
| 212 |
- reporter,+ ) |
||
| 213 |
- filter_panel_api,+ ), |
||
| 214 | -+ | ! |
- datasets_selected, parent_dataname, ggplot2_args) {
+ teal.widgets::panel_item( |
| 215 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ title = "Plot settings", |
|
| 216 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ collapsed = TRUE, |
|
| 217 | ! |
- checkmate::assert_class(data, "tdata")+ conditionalPanel( |
|
| 218 | ! |
- moduleServer(id, function(input, output, session) {
+ condition = sprintf( |
|
| 219 | -+ | ! |
- # if there are < this number of unique records then a numeric+ "input['%s'] == 'Elbow Plot' || input['%s'] == 'Eigenvector plot'", |
| 220 | -+ | ! |
- # variable can be treated as a factor and all factors with < this groups+ ns("plot_type"),
|
| 221 | -+ | ! |
- # have their values plotted+ ns("plot_type")
|
| 222 | -! | +
- .unique_records_for_factor <- 30+ ), |
|
| 223 | -+ | ! |
- # if there are < this number of unique records then a numeric+ list(checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels))
|
| 224 |
- # variable is by default treated as a factor+ ), |
||
| 225 | ! |
- .unique_records_default_as_factor <- 6 # nolint+ selectInput( |
|
| 226 | -+ | ! |
-
+ inputId = ns("ggtheme"),
|
| 227 | ! |
- datanames <- names(data)+ label = "Theme (by ggplot):", |
|
| 228 | -+ | ! |
-
+ choices = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
|
| 229 | ! |
- checkmate::assert_character(datasets_selected)+ selected = args$ggtheme, |
|
| 230 | ! |
- checkmate::assert_subset(datasets_selected, datanames)+ multiple = FALSE |
|
| 231 | -! | +
- if (length(datasets_selected) != 0L) {
+ ), |
|
| 232 | ! |
- datanames <- datasets_selected+ teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", args$font_size, ticks = FALSE)
|
|
| 233 |
- }+ ) |
||
| 234 |
-
+ ) |
||
| 235 |
- # conditionally display checkbox+ ), |
||
| 236 | ! |
- shinyjs::toggle(+ forms = tagList( |
|
| 237 | ! |
- id = "show_parent_vars",+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
|
|
| 238 | ! |
- condition = length(parent_dataname) > 0 && parent_dataname %in% datanames+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 239 |
- )+ ), |
||
| 240 | -+ | ! |
-
+ pre_output = args$pre_output, |
| 241 | ! |
- columns_names <- new.env() # nolint+ post_output = args$post_output |
|
| 242 |
-
+ ) |
||
| 243 |
- # plot_var$data holds the name of the currently selected dataset+ ) |
||
| 244 |
- # plot_var$variable[[<dataset_name>]] holds the name of the currently selected+ } |
||
| 245 |
- # variable for dataset <dataset_name>+ |
||
| 246 | -! | +
- plot_var <- reactiveValues(data = NULL, variable = list())+ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, plot_width, ggplot2_args) {
|
|
| 247 | -+ | ! |
-
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 248 | ! |
- establish_updating_selection(datanames, input, plot_var, columns_names)+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 249 | -+ | ! |
-
+ checkmate::assert_class(data, "tdata") |
| 250 | -+ | ! |
- # validations+ moduleServer(id, function(input, output, session) {
|
| 251 | ! |
- validation_checks <- validate_input(input, plot_var, data)+ response <- dat |
|
| 253 | -+ | ! |
- # data_for_analysis is a list with two elements: a column from a dataset and the column label+ for (i in seq_along(response)) {
|
| 254 | ! |
- plotted_data <- reactive({
+ response[[i]]$select$multiple <- FALSE |
|
| 255 | ! |
- validation_checks()+ response[[i]]$select$always_selected <- NULL |
|
| 256 | -+ | ! |
-
+ response[[i]]$select$selected <- NULL |
| 257 | ! |
- get_plotted_data(input, plot_var, data)+ response[[i]]$select$choices <- var_labels(data[[response[[i]]$dataname]]()) |
|
| 258 | -+ | ! |
- })+ response[[i]]$select$choices <- setdiff( |
| 259 | -+ | ! |
-
+ response[[i]]$select$choices, |
| 260 | ! |
- treat_numeric_as_factor <- reactive({
+ unlist(get_join_keys(data)$get(response[[i]]$dataname)) |
|
| 261 | -! | +
- if (is_num_var_short(.unique_records_for_factor, input, plotted_data)) {
+ ) |
|
| 262 | -! | +
- input$numeric_as_factor+ } |
|
| 263 |
- } else {
+
|
||
| 264 | ! |
- FALSE+ selector_list <- teal.transform::data_extract_multiple_srv( |
|
| 265 | -+ | ! |
- }+ data_extract = list(dat = dat, response = response), |
| 266 | -+ | ! |
- })+ datasets = data, |
| 267 | -+ | ! |
-
+ select_validation_rule = list( |
| 268 | ! |
- render_tabset_panel_content(+ dat = ~ if (length(.) < 2L) "Please select more than 1 variable to perform PCA.", |
|
| 269 | ! |
- input = input,+ response = shinyvalidate::compose_rules( |
|
| 270 | ! |
- output = output,+ shinyvalidate::sv_optional(), |
|
| 271 | ! |
- data = data,+ ~ if (isTRUE(is.element(., selector_list()$dat()$select))) {
|
|
| 272 | ! |
- datanames = datanames,+ "Response must not have been used for PCA." |
|
| 273 | -! | +
- parent_dataname = parent_dataname,+ } |
|
| 274 | -! | +
- columns_names = columns_names,+ ) |
|
| 275 | -! | +
- plot_var = plot_var+ ) |
|
| 277 |
- # add used-defined text size to ggplot arguments passed from caller frame+ |
||
| 278 | ! |
- all_ggplot2_args <- reactive({
+ iv_r <- reactive({
|
|
| 279 | ! |
- user_text <- teal.widgets::ggplot2_args(+ iv <- shinyvalidate::InputValidator$new() |
|
| 280 | ! |
- theme = list(+ teal.transform::compose_and_enable_validators(iv, selector_list) |
|
| 281 | -! | +
- "text" = ggplot2::element_text(size = input[["font_size"]]),+ }) |
|
| 282 | -! | +
- "axis.text.x" = ggplot2::element_text(angle = input[["label_rotation"]], hjust = 1)+ |
|
| 283 | -+ | ! |
- )+ iv_extra <- shinyvalidate::InputValidator$new() |
| 284 | -+ | ! |
- )+ iv_extra$add_rule("x_axis", function(value) {
|
| 285 | ! |
- user_theme <- utils::getFromNamespace(sprintf("theme_%s", input[["ggplot_theme"]]), ns = "ggplot2")
+ if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
|
|
| 286 | ! |
- user_theme <- user_theme()+ if (!shinyvalidate::input_provided(value)) {
|
|
| 287 | -+ | ! |
- # temporary fix to circumvent assertion issue with resolve_ggplot2_args+ "Need X axis" |
| 288 |
- # drop problematic elements+ } |
||
| 289 | -! | +
- user_theme <- user_theme[grep("strip.text.y.left", names(user_theme), fixed = TRUE, invert = TRUE)]
+ } |
|
| 290 |
-
+ }) |
||
| 291 | ! |
- teal.widgets::resolve_ggplot2_args(+ iv_extra$add_rule("y_axis", function(value) {
|
|
| 292 | ! |
- user_plot = user_text,+ if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
|
|
| 293 | ! |
- user_default = teal.widgets::ggplot2_args(theme = user_theme),+ if (!shinyvalidate::input_provided(value)) {
|
|
| 294 | ! |
- module_plot = ggplot2_args+ "Need Y axis" |
|
| 295 |
- )+ } |
||
| 296 |
- })+ } |
||
| 297 |
-
+ }) |
||
| 298 | ! |
- output$ui_numeric_display <- renderUI({
+ rule_dupl <- function(...) {
|
|
| 299 | ! |
- dataname <- input$tabset_panel+ if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
|
|
| 300 | ! |
- varname <- plot_var$variable[[input$tabset_panel]]+ if (isTRUE(input$x_axis == input$y_axis)) {
|
|
| 301 | ! |
- req(data, varname)+ "Please choose different X and Y axes." |
|
| 302 |
-
+ } |
||
| 303 | -! | +
- df <- data[[dataname]]()+ } |
|
| 304 |
-
+ } |
||
| 305 | ! |
- numeric_ui <- tagList(+ iv_extra$add_rule("x_axis", rule_dupl)
|
|
| 306 | ! |
- fluidRow(+ iv_extra$add_rule("y_axis", rule_dupl)
|
|
| 307 | ! |
- div(+ iv_extra$add_rule("variables", function(value) {
|
|
| 308 | ! |
- class = "col-md-4",+ if (identical(input$plot_type, "Circle plot")) {
|
|
| 309 | ! |
- br(),+ if (!shinyvalidate::input_provided(value)) {
|
|
| 310 | ! |
- shinyWidgets::switchInput(+ "Need Original Coordinates" |
|
| 311 | -! | +
- inputId = session$ns("display_density"),
+ } |
|
| 312 | -! | +
- label = "Show density",+ } |
|
| 313 | -! | +
- value = `if`(is.null(isolate(input$display_density)), TRUE, isolate(input$display_density)),+ }) |
|
| 314 | ! |
- width = "50%",+ iv_extra$add_rule("pc", function(value) {
|
|
| 315 | ! |
- labelWidth = "100px",+ if (identical(input$plot_type, "Eigenvector plot")) {
|
|
| 316 | ! |
- handleWidth = "50px"+ if (!shinyvalidate::input_provided(value)) {
|
|
| 317 | -+ | ! |
- )+ "Need PC" |
| 318 |
- ),+ } |
||
| 319 | -! | +
- div(+ } |
|
| 320 | -! | +
- class = "col-md-4",+ }) |
|
| 321 | ! |
- br(),+ iv_extra$enable() |
|
| 322 | -! | +
- shinyWidgets::switchInput(+ |
|
| 323 | ! |
- inputId = session$ns("remove_outliers"),
+ anl_merged_input <- teal.transform::merge_expression_srv( |
|
| 324 | ! |
- label = "Remove outliers",+ selector_list = selector_list, |
|
| 325 | ! |
- value = `if`(is.null(isolate(input$remove_outliers)), FALSE, isolate(input$remove_outliers)),+ datasets = data, |
|
| 326 | ! |
- width = "50%",+ join_keys = get_join_keys(data) |
|
| 327 | -! | +
- labelWidth = "100px",+ ) |
|
| 328 | -! | +
- handleWidth = "50px"+ |
|
| 329 | -+ | ! |
- )+ anl_merged_q <- reactive({
|
| 330 | -+ | ! |
- ),+ req(anl_merged_input()) |
| 331 | ! |
- div(+ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% |
|
| 332 | ! |
- class = "col-md-4",+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
|
| 333 | -! | +
- uiOutput(session$ns("outlier_definition_slider_ui"))
+ }) |
|
| 334 |
- )+ |
||
| 335 | -+ | ! |
- ),+ merged <- list( |
| 336 | ! |
- div(+ anl_input_r = anl_merged_input, |
|
| 337 | ! |
- class = "ml-4",+ anl_q_r = anl_merged_q |
|
| 338 | -! | +
- uiOutput(session$ns("ui_density_help")),
+ ) |
|
| 339 | -! | +
- uiOutput(session$ns("ui_outlier_help"))
+
|
|
| 340 | -+ | ! |
- )+ validation <- reactive({
|
| 341 | -+ | ! |
- )+ req(merged$anl_q_r()) |
| 342 |
-
+ # inputs |
||
| 343 | ! |
- if (is.numeric(df[[varname]])) {
+ keep_cols <- as.character(merged$anl_input_r()$columns_source$dat) |
|
| 344 | ! |
- unique_entries <- length(unique(df[[varname]]))+ na_action <- input$na_action |
|
| 345 | ! |
- if (unique_entries < .unique_records_for_factor && unique_entries > 0) {
+ standardization <- input$standardization |
|
| 346 | ! |
- list(+ center <- standardization %in% c("center", "center_scale") # nolint
|
|
| 347 | ! |
- checkboxInput(+ scale <- standardization == "center_scale" |
|
| 348 | ! |
- session$ns("numeric_as_factor"),
+ ANL <- merged$anl_q_r()[["ANL"]] # nolint |
|
| 349 | -! | +
- "Treat variable as factor",+ |
|
| 350 | ! |
- value = `if`(+ teal::validate_has_data(ANL, 10) |
|
| 351 | ! |
- is.null(isolate(input$numeric_as_factor)),+ validate(need( |
|
| 352 | ! |
- unique_entries < .unique_records_default_as_factor,+ na_action != "none" | !anyNA(ANL[keep_cols]), |
|
| 353 | ! |
- isolate(input$numeric_as_factor)+ paste( |
|
| 354 | -+ | ! |
- )+ "There are NAs in the dataset. Please deal with them in preprocessing", |
| 355 | -+ | ! |
- ),+ "or select \"Drop\" in the NA actions inside the encodings panel (left)." |
| 356 | -! | +
- conditionalPanel("!input.numeric_as_factor", ns = session$ns, numeric_ui)
+ ) |
|
| 357 |
- )+ )) |
||
| 358 | ! |
- } else if (unique_entries > 0) {
+ if (scale) {
|
|
| 359 | ! |
- numeric_ui+ not_single <- vapply(ANL[keep_cols], function(column) length(unique(column)) != 1, FUN.VALUE = logical(1)) |
|
| 360 |
- }+ |
||
| 361 | -+ | ! |
- } else {
+ msg <- paste0( |
| 362 | ! |
- NULL+ "You have selected `Center & Scale` under `Standardization` in the `Pre-processing` panel, ", |
|
| 363 | -+ | ! |
- }+ "but one or more of your columns has/have a variance value of zero, indicating all values are identical" |
| 364 |
- })+ ) |
||
| 365 | -+ | ! |
-
+ validate(need(all(not_single), msg)) |
| 366 | -! | +
- output$ui_histogram_display <- renderUI({
+ } |
|
| 367 | -! | +
- dataname <- input$tabset_panel+ }) |
|
| 368 | -! | +
- varname <- plot_var$variable[[input$tabset_panel]]+ |
|
| 369 | -! | +
- req(data, varname)+ # computation ---- |
|
| 370 | -+ | ! |
-
+ computation <- reactive({
|
| 371 | ! |
- df <- data[[dataname]]()+ validation() |
|
| 373 | -! | +
- numeric_ui <- tagList(fluidRow(+ # inputs |
|
| 374 | ! |
- div(+ keep_cols <- as.character(merged$anl_input_r()$columns_source$dat) |
|
| 375 | ! |
- class = "col-md-4",+ na_action <- input$na_action |
|
| 376 | ! |
- shinyWidgets::switchInput(+ standardization <- input$standardization |
|
| 377 | ! |
- inputId = session$ns("remove_NA_hist"),
+ center <- standardization %in% c("center", "center_scale") # nolint
|
|
| 378 | ! |
- label = "Remove NA values",+ scale <- standardization == "center_scale" |
|
| 379 | ! |
- value = FALSE,+ ANL <- merged$anl_q_r()[["ANL"]] # nolint |
|
| 380 | -! | +
- width = "50%",+ |
|
| 381 | ! |
- labelWidth = "100px",+ qenv <- teal.code::eval_code( |
|
| 382 | ! |
- handleWidth = "50px"+ merged$anl_q_r(), |
|
| 383 | -+ | ! |
- )+ substitute( |
| 384 | -+ | ! |
- )+ expr = keep_columns <- keep_cols, |
| 385 | -+ | ! |
- ))+ env = list(keep_cols = keep_cols) |
| 386 |
-
+ ) |
||
| 387 | -! | +
- var <- df[[varname]]+ ) |
|
| 388 | -! | +
- if (anyNA(var) && (is.factor(var) || is.character(var) || is.logical(var))) {
+
|
|
| 389 | ! |
- groups <- unique(as.character(var))+ if (na_action == "drop") {
|
|
| 390 | ! |
- len_groups <- length(groups)+ qenv <- teal.code::eval_code( |
|
| 391 | ! |
- if (len_groups >= .unique_records_for_factor) {
+ qenv, |
|
| 392 | ! |
- NULL+ quote(ANL <- tidyr::drop_na(ANL, keep_columns)) # nolint |
|
| 393 |
- } else {
+ ) |
||
| 394 | -! | +
- numeric_ui+ } |
|
| 395 |
- }+ |
||
| 396 | -+ | ! |
- } else {
+ qenv <- teal.code::eval_code( |
| 397 | ! |
- NULL+ qenv, |
|
| 398 | -+ | ! |
- }+ substitute( |
| 399 | -+ | ! |
- })+ expr = pca <- summary(stats::prcomp(ANL[keep_columns], center = center, scale. = scale, retx = TRUE)), |
| 400 | -+ | ! |
-
+ env = list(center = center, scale = scale) |
| 401 | -! | +
- output$outlier_definition_slider_ui <- renderUI({
+ ) |
|
| 402 | -! | +
- req(input$remove_outliers)+ ) |
|
| 403 | -! | +
- sliderInput(+ |
|
| 404 | ! |
- inputId = session$ns("outlier_definition_slider"),
+ qenv <- teal.code::eval_code( |
|
| 405 | ! |
- div(+ qenv, |
|
| 406 | ! |
- class = "teal-tooltip",+ quote({
|
|
| 407 | ! |
- tagList(+ tbl_importance <- dplyr::as_tibble(pca$importance, rownames = "Metric") |
|
| 408 | ! |
- "Outlier definition:",+ tbl_importance |
|
| 409 | -! | +
- icon("circle-info"),
+ }) |
|
| 410 | -! | +
- span(+ ) |
|
| 411 | -! | +
- class = "tooltiptext",+ |
|
| 412 | ! |
- paste(+ teal.code::eval_code( |
|
| 413 | ! |
- "Use the slider to choose the cut-off value to define outliers; the larger the value the",+ qenv, |
|
| 414 | ! |
- "further below Q1/above Q3 points have to be in order to be classed as outliers"+ quote({
|
|
| 415 | -+ | ! |
- )+ tbl_eigenvector <- dplyr::as_tibble(pca$rotation, rownames = "Variable") |
| 416 | -+ | ! |
- )+ tbl_eigenvector |
| 417 |
- )+ }) |
||
| 418 |
- ),+ ) |
||
| 419 | -! | +
- min = 1,+ }) |
|
| 420 | -! | +
- max = 5,+ |
|
| 421 | -! | +
- value = 3,+ # plot args ---- |
|
| 422 | ! |
- step = 0.5+ output$plot_settings <- renderUI({
|
|
| 423 |
- )+ # reactivity triggers |
||
| 424 | -+ | ! |
- })+ req(iv_r()$is_valid()) |
| 425 | -+ | ! |
-
+ req(computation()) |
| 426 | ! |
- output$ui_density_help <- renderUI({
+ qenv <- computation() |
|
| 427 | -! | +
- req(is.logical(input$display_density))+ |
|
| 428 | ! |
- if (input$display_density) {
+ ns <- session$ns |
|
| 429 | -! | +
- tags$small(helpText(paste(+ |
|
| 430 | ! |
- "Kernel density estimation with gaussian kernel",+ pca <- qenv[["pca"]] |
|
| 431 | ! |
- "and bandwidth function bw.nrd0 (R default)"+ chcs_pcs <- colnames(pca$rotation) |
|
| 432 | -+ | ! |
- )))+ chcs_vars <- qenv[["keep_columns"]] |
| 433 |
- } else {
+
|
||
| 434 | ! |
- NULL+ tagList( |
|
| 435 | -+ | ! |
- }+ conditionalPanel( |
| 436 | -+ | ! |
- })+ condition = sprintf( |
| 437 | -+ | ! |
-
+ "input['%s'] == 'Biplot' || input['%s'] == 'Circle plot'", |
| 438 | ! |
- output$ui_outlier_help <- renderUI({
+ ns("plot_type"), ns("plot_type")
|
|
| 439 | -! | +
- req(is.logical(input$remove_outliers), input$outlier_definition_slider)+ ), |
|
| 440 | ! |
- if (input$remove_outliers) {
+ list( |
|
| 441 | ! |
- tags$small(+ teal.widgets::optionalSelectInput(ns("x_axis"), "X axis", choices = chcs_pcs, selected = chcs_pcs[1]),
|
|
| 442 | ! |
- helpText(+ teal.widgets::optionalSelectInput(ns("y_axis"), "Y axis", choices = chcs_pcs, selected = chcs_pcs[2]),
|
|
| 443 | ! |
- withMathJax(paste0(+ teal.widgets::optionalSelectInput( |
|
| 444 | ! |
- "Outlier data points (\\( X \\lt Q1 - ", input$outlier_definition_slider, "\\times IQR \\) or+ ns("variables"), "Original coordinates",
|
|
| 445 | ! |
- \\(Q3 + ", input$outlier_definition_slider, "\\times IQR \\lt X\\))+ choices = chcs_vars, selected = chcs_vars, |
|
| 446 | ! |
- have not been displayed on the graph and will not be used for any kernel density estimations, ",+ multiple = TRUE |
|
| 447 | -! | +
- "although their values remain in the statisics table below."+ ) |
|
| 448 |
- ))+ ) |
||
| 449 |
- )+ ), |
||
| 450 | -+ | ! |
- )+ conditionalPanel( |
| 451 | -+ | ! |
- } else {
+ condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")),
|
| 452 | ! |
- NULL+ helpText("No plot specific settings available.")
|
|
| 453 |
- }+ ), |
||
| 454 | -+ | ! |
- })+ conditionalPanel( |
| 455 | -+ | ! |
-
+ condition = paste0("input['", ns("plot_type"), "'] == 'Eigenvector plot'"),
|
| 456 | -+ | ! |
-
+ teal.widgets::optionalSelectInput(ns("pc"), "PC", choices = chcs_pcs, selected = chcs_pcs[1])
|
| 457 | -! | +
- variable_plot_r <- reactive({
+ ) |
|
| 458 | -! | +
- display_density <- `if`(is.null(input$display_density), FALSE, input$display_density)+ ) |
|
| 459 | -! | +
- remove_outliers <- `if`(is.null(input$remove_outliers), FALSE, input$remove_outliers)+ }) |
|
| 461 | -! | +
- if (remove_outliers) {
+ # plot elbow ---- |
|
| 462 | ! |
- req(input$outlier_definition_slider)+ plot_elbow <- function(base_q) {
|
|
| 463 | ! |
- outlier_definition <- as.numeric(input$outlier_definition_slider)+ ggtheme <- input$ggtheme |
|
| 464 | -+ | ! |
- } else {
+ rotate_xaxis_labels <- input$rotate_xaxis_labels # nolint |
| 465 | ! |
- outlier_definition <- 0+ font_size <- input$font_size # nolint |
|
| 466 |
- }+ |
||
| 467 | -+ | ! |
-
+ angle_value <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0) |
| 468 | ! |
- plot_var_summary(+ hjust_value <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5) |
|
| 469 | -! | +
- var = plotted_data()$data,+ |
|
| 470 | ! |
- var_lab = plotted_data()$var_description,+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
|
| 471 | ! |
- wrap_character = 15,+ labs = list(x = "Principal component", y = "Proportion of variance explained", color = "", fill = "Legend"), |
|
| 472 | ! |
- numeric_as_factor = treat_numeric_as_factor(),+ theme = list( |
|
| 473 | ! |
- remove_NA_hist = input$remove_NA_hist,+ legend.position = "right", |
|
| 474 | ! |
- display_density = display_density,+ legend.spacing.y = quote(grid::unit(-5, "pt")), |
|
| 475 | ! |
- outlier_definition = outlier_definition,+ legend.title = quote(element_text(vjust = 25)), |
|
| 476 | ! |
- records_for_factor = .unique_records_for_factor,+ axis.text.x = substitute( |
|
| 477 | ! |
- ggplot2_args = all_ggplot2_args()+ element_text(angle = angle_value, hjust = hjust_value), |
|
| 478 | -+ | ! |
- )+ list(angle_value = angle_value, hjust_value = hjust_value) |
| 479 |
- })+ ), |
||
| 480 | -+ | ! |
-
+ text = substitute(element_text(size = font_size), list(font_size = font_size)) |
| 481 | -! | +
- pws <- teal.widgets::plot_with_settings_srv(+ ) |
|
| 482 | -! | +
- id = "variable_plot",+ ) |
|
| 483 | -! | +
- plot_r = variable_plot_r,+ |
|
| 484 | ! |
- height = c(500, 200, 2000)+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 485 | -+ | ! |
- )+ teal.widgets::resolve_ggplot2_args( |
| 486 | -+ | ! |
-
+ user_plot = ggplot2_args[["Elbow plot"]], |
| 487 | ! |
- output$variable_summary_table <- DT::renderDataTable({
+ user_default = ggplot2_args$default, |
|
| 488 | ! |
- var_summary_table(+ module_plot = dev_ggplot2_args |
|
| 489 | -! | +
- plotted_data()$data,+ ), |
|
| 490 | ! |
- treat_numeric_as_factor(),+ ggtheme = ggtheme |
|
| 491 | -! | +
- input$variable_summary_table_rows,+ ) |
|
| 492 | -! | +
- if (!is.null(input$remove_outliers) && input$remove_outliers) {
+
|
|
| 493 | ! |
- req(input$outlier_definition_slider)+ teal.code::eval_code( |
|
| 494 | ! |
- as.numeric(input$outlier_definition_slider)+ base_q, |
|
| 495 | -+ | ! |
- } else {
+ substitute( |
| 496 | ! |
- 0+ expr = {
|
|
| 497 | -+ | ! |
- }+ elb_dat <- pca$importance[c("Proportion of Variance", "Cumulative Proportion"), ] %>%
|
| 498 | -+ | ! |
- )+ dplyr::as_tibble(rownames = "metric") %>% |
| 499 | -+ | ! |
- })+ tidyr::gather("component", "value", -metric) %>%
|
| 500 | -+ | ! |
-
+ dplyr::mutate( |
| 501 | -+ | ! |
- ### REPORTER+ component = factor(component, levels = unique(stringr::str_sort(component, numeric = TRUE))) |
| 502 | -! | +
- if (with_reporter) {
+ ) |
|
| 503 | -! | +
- card_fun <- function(comment) {
+
|
|
| 504 | ! |
- card <- teal::TealReportCard$new()+ cols <- c(getOption("ggplot2.discrete.colour"), c("lightblue", "darkred", "black"))[1:3]
|
|
| 505 | ! |
- card$set_name("Variable Browser Plot")
+ g <- ggplot(mapping = aes_string(x = "component", y = "value")) + |
|
| 506 | ! |
- card$append_text("Variable Browser Plot", "header2")
+ geom_bar( |
|
| 507 | ! |
- if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ aes(fill = "Single variance"), |
|
| 508 | ! |
- card$append_text("Plot", "header3")
+ data = dplyr::filter(elb_dat, metric == "Proportion of Variance"), |
|
| 509 | ! |
- card$append_plot(variable_plot_r(), dim = pws$dim())+ color = "black", |
|
| 510 | ! |
- if (!comment == "") {
+ stat = "identity" |
|
| 511 | -! | +
- card$append_text("Comment", "header3")
+ ) + |
|
| 512 | ! |
- card$append_text(comment)+ geom_point( |
|
| 513 | -+ | ! |
- }+ aes(color = "Cumulative variance"), |
| 514 | ! |
- card+ data = dplyr::filter(elb_dat, metric == "Cumulative Proportion") |
|
| 515 |
- }+ ) + |
||
| 516 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ geom_line( |
|
| 517 | -+ | ! |
- }+ aes(group = 1, color = "Cumulative variance"), |
| 518 | -+ | ! |
- ###+ data = dplyr::filter(elb_dat, metric == "Cumulative Proportion") |
| 519 |
- })+ ) + |
||
| 520 | -+ | ! |
- }+ labs + |
| 521 | -+ | ! |
-
+ scale_color_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[3])) +
|
| 522 | -+ | ! |
- #' Summarizes missings occurrence+ scale_fill_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[1])) +
|
| 523 | -+ | ! |
- #'+ ggthemes + |
| 524 | -+ | ! |
- #' Summarizes missings occurrence in vector+ themes |
| 525 |
- #' @param x vector of any type and length+ |
||
| 526 | -+ | ! |
- #' @return text describing \code{NA} occurrence.
+ print(g) |
| 527 |
- #' @keywords internal+ }, |
||
| 528 | -+ | ! |
- var_missings_info <- function(x) {
+ env = list( |
| 529 | ! |
- return(sprintf("%s [%s%%]", sum(is.na(x)), round(mean(is.na(x) * 100), 2)))
+ ggthemes = parsed_ggplot2_args$ggtheme, |
|
| 530 | -+ | ! |
- }+ labs = parsed_ggplot2_args$labs, |
| 531 | -+ | ! |
-
+ themes = parsed_ggplot2_args$theme |
| 532 |
- #' S3 generic for \code{sparkline} widget HTML
+ ) |
||
| 533 |
- #'+ ) |
||
| 534 |
- #' Generates the \code{sparkline} HTML code corresponding to the input array.
+ ) |
||
| 535 |
- #' For numeric variables creates a box plot, for character and factors - bar plot.+ } |
||
| 536 |
- #' Produces an empty string for variables of other types.+ |
||
| 537 |
- #'+ # plot circle ---- |
||
| 538 | -+ | ! |
- #' @param arr vector of any type and length+ plot_circle <- function(base_q) {
|
| 539 | -+ | ! |
- #' @param width \code{numeric} the width of the \code{sparkline} widget (pixels)
+ x_axis <- input$x_axis # nolint |
| 540 | -+ | ! |
- #' @param ... \code{list} additional options passed to bar plots of \code{jquery.sparkline}; see
+ y_axis <- input$y_axis # nolint |
| 541 | -+ | ! |
- #' \href{https://omnipotent.net/jquery.sparkline/#common}{\code{jquery.sparkline docs}}
+ variables <- input$variables # nolint |
| 542 | -+ | ! |
- #'+ ggtheme <- input$ggtheme |
| 543 |
- #' @return character variable containing the HTML code of the \code{sparkline} HTML widget
+
|
||
| 544 | -+ | ! |
- #' @keywords internal+ rotate_xaxis_labels <- input$rotate_xaxis_labels # nolint |
| 545 | -+ | ! |
- #'+ font_size <- input$font_size # nolint |
| 546 |
- create_sparklines <- function(arr, width = 150, ...) {
+
|
||
| 547 | ! |
- if (all(is.null(arr))) {
+ angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0) |
|
| 548 | ! |
- return("")
+ hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5) |
|
| 549 |
- }+ |
||
| 550 | ! |
- UseMethod("create_sparklines")
+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
|
| 551 | -+ | ! |
- }+ theme = list( |
| 552 | -+ | ! |
-
+ text = substitute(element_text(size = font_size), list(font_size = font_size)), |
| 553 | -+ | ! |
- #' Default method for \code{\link{create_sparklines}}
+ axis.text.x = substitute( |
| 554 | -+ | ! |
- #'+ element_text(angle = angle_val, hjust = hjust_val), |
| 555 | -+ | ! |
- #'+ list(angle_val = angle, hjust_val = hjust) |
| 556 |
- #' @export+ ) |
||
| 557 |
- #' @keywords internal+ ) |
||
| 558 |
- #' @rdname create_sparklines+ ) |
||
| 559 |
- create_sparklines.default <- function(arr, width = 150, ...) { # nolint
+
|
||
| 560 | ! |
- return(as.character(tags$code("unsupported variable type", class = "text-blue")))
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 561 | -+ | ! |
- }+ user_plot = ggplot2_args[["Circle plot"]], |
| 562 | -+ | ! |
-
+ user_default = ggplot2_args$default, |
| 563 | -+ | ! |
- #' Generates the HTML code for the \code{sparkline} widget
+ module_plot = dev_ggplot2_args |
| 564 |
- #'+ ) |
||
| 565 |
- #' @param bar_spacing \code{numeric} the spacing between the bars (in pixels)
+
|
||
| 566 | -+ | ! |
- #' @param bar_width \code{numeric} the width of the bars (in pixels)
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 567 | -+ | ! |
- #'+ all_ggplot2_args, |
| 568 | -+ | ! |
- #' @return \code{character} with HTML code for the \code{sparkline} widget
+ ggtheme = ggtheme |
| 569 |
- #'+ ) |
||
| 570 |
- #' @export+ |
||
| 571 | -+ | ! |
- #' @keywords internal+ teal.code::eval_code( |
| 572 | -+ | ! |
- #' @rdname create_sparklines+ base_q, |
| 573 | -+ | ! |
- create_sparklines.Date <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) { # nolint
+ substitute( |
| 574 | ! |
- arr_num <- as.numeric(arr)+ expr = {
|
|
| 575 | ! |
- arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")+ pca_rot <- pca$rotation[, c(x_axis, y_axis)] %>% |
|
| 576 | ! |
- binwidth <- get_bin_width(arr_num, 1)+ dplyr::as_tibble(rownames = "label") %>% |
|
| 577 | ! |
- bins <- floor(diff(range(arr_num)) / binwidth) + 1+ dplyr::filter(label %in% variables) |
|
| 578 | -! | +
- if (all(is.na(bins))) {
+
|
|
| 579 | ! |
- return(as.character(tags$code("only NA", class = "text-blue")))
+ circle_data <- data.frame( |
|
| 580 | ! |
- } else if (bins == 1) {
+ x = cos(seq(0, 2 * pi, length.out = 100)), |
|
| 581 | ! |
- return(as.character(tags$code("one date", class = "text-blue")))
+ y = sin(seq(0, 2 * pi, length.out = 100)) |
|
| 582 |
- }+ ) |
||
| 583 | -! | +
- counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))+ |
|
| 584 | ! |
- max_value <- max(counts)+ g <- ggplot(pca_rot) + |
|
| 585 | -+ | ! |
-
+ geom_point(aes_string(x = x_axis, y = y_axis)) + |
| 586 | ! |
- start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))+ geom_label( |
|
| 587 | ! |
- labels_start <- as.character(as.Date(arr_num[start_bins], origin = as.Date("1970-01-01")))
+ aes_string(x = x_axis, y = y_axis, label = "label"), |
|
| 588 | ! |
- labels <- paste("Start:", labels_start)
+ nudge_x = 0.1, nudge_y = 0.05, |
|
| 589 | -+ | ! |
-
+ fontface = "bold" |
| 590 | -! | +
- sparkline::spk_chr(+ ) + |
|
| 591 | ! |
- unname(counts),+ geom_path(aes(x, y, group = 1), data = circle_data) + |
|
| 592 | ! |
- type = "bar",+ geom_point(aes(x = x, y = y), data = data.frame(x = 0, y = 0), shape = "x", size = 5) + |
|
| 593 | ! |
- chartRangeMin = 0,+ labs + |
|
| 594 | ! |
- chartRangeMax = max_value,+ ggthemes + |
|
| 595 | ! |
- width = width,+ themes |
|
| 596 | ! |
- barWidth = bar_width,+ print(g) |
|
| 597 | -! | +
- barSpacing = bar_spacing,+ }, |
|
| 598 | ! |
- tooltipFormatter = custom_sparkline_formatter(labels, counts)+ env = list( |
|
| 599 | -+ | ! |
- )+ x_axis = x_axis, |
| 600 | -+ | ! |
- }+ y_axis = y_axis, |
| 601 | -+ | ! |
-
+ variables = variables, |
| 602 | -+ | ! |
- #' Generates the HTML code for the \code{sparkline} widget
+ ggthemes = parsed_ggplot2_args$ggtheme, |
| 603 | -+ | ! |
- #'+ labs = `if`(is.null(parsed_ggplot2_args$labs), quote(labs()), parsed_ggplot2_args$labs), |
| 604 | -+ | ! |
- #'+ themes = parsed_ggplot2_args$theme |
| 605 |
- #' @param bar_spacing \code{numeric} the spacing between the bars (in pixels)
+ ) |
||
| 606 |
- #' @param bar_width \code{numeric} the width of the bars (in pixels)
+ ) |
||
| 607 |
- #'+ ) |
||
| 608 |
- #' @return \code{character} with HTML code for the \code{sparkline} widget
+ } |
||
| 609 |
- #'+ |
||
| 610 |
- #' @export+ # plot biplot ---- |
||
| 611 | -+ | ! |
- #' @keywords internal+ plot_biplot <- function(base_q) {
|
| 612 | -+ | ! |
- #' @rdname create_sparklines+ qenv <- base_q |
| 613 |
- create_sparklines.POSIXct <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) { # nolint
+
|
||
| 614 | ! |
- arr_num <- as.numeric(arr)+ ANL <- qenv[["ANL"]] # nolint |
|
| 615 | -! | +
- arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")+ |
|
| 616 | ! |
- binwidth <- get_bin_width(arr_num, 1)+ resp_col <- as.character(merged$anl_input_r()$columns_source$response) |
|
| 617 | ! |
- bins <- floor(diff(range(arr_num)) / binwidth) + 1+ dat_cols <- as.character(merged$anl_input_r()$columns_source$dat) |
|
| 618 | ! |
- if (all(is.na(bins))) {
+ x_axis <- input$x_axis # nolint |
|
| 619 | ! |
- return(as.character(tags$code("only NA", class = "text-blue")))
+ y_axis <- input$y_axis # nolint |
|
| 620 | ! |
- } else if (bins == 1) {
+ variables <- input$variables # nolint |
|
| 621 | ! |
- return(as.character(tags$code("one date-time", class = "text-blue")))
+ pca <- qenv[["pca"]] |
|
| 622 |
- }+ |
||
| 623 | ! |
- counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))+ ggtheme <- input$ggtheme |
|
| 624 | -! | +
- max_value <- max(counts)+ |
|
| 625 | -+ | ! |
-
+ rotate_xaxis_labels <- input$rotate_xaxis_labels # nolint |
| 626 | ! |
- start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))+ alpha <- input$alpha # nolint |
|
| 627 | ! |
- labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
+ size <- input$size # nolint |
|
| 628 | ! |
- labels <- paste("Start:", labels_start)
+ font_size <- input$font_size # nolint |
|
| 630 | ! |
- sparkline::spk_chr(+ qenv <- teal.code::eval_code( |
|
| 631 | ! |
- unname(counts),+ qenv, |
|
| 632 | ! |
- type = "bar",+ substitute( |
|
| 633 | ! |
- chartRangeMin = 0,+ expr = pca_rot <- dplyr::as_tibble(pca$x[, c(x_axis, y_axis)]), |
|
| 634 | ! |
- chartRangeMax = max_value,+ env = list(x_axis = x_axis, y_axis = y_axis) |
|
| 635 | -! | +
- width = width,+ ) |
|
| 636 | -! | +
- barWidth = bar_width,+ ) |
|
| 637 | -! | +
- barSpacing = bar_spacing,+ |
|
| 638 | -! | +
- tooltipFormatter = custom_sparkline_formatter(labels, counts)+ # rot_vars = data frame that displays arrows in the plot, need to be scaled to data |
|
| 639 | -+ | ! |
- )+ if (!is.null(input$variables)) {
|
| 640 | -+ | ! |
- }+ qenv <- teal.code::eval_code( |
| 641 | -+ | ! |
-
+ qenv, |
| 642 | -+ | ! |
- #' Generates the HTML code for the \code{sparkline} widget
+ substitute( |
| 643 | -+ | ! |
- #'+ expr = {
|
| 644 | -+ | ! |
- #'+ r <- sqrt(qchisq(0.69, df = 2)) * prod(colMeans(pca_rot ^ 2)) ^ (1 / 4) # styler: off |
| 645 | -+ | ! |
- #' @param bar_spacing \code{numeric} the spacing between the bars (in pixels)
+ v_scale <- rowSums(pca$rotation ^ 2) # styler: off |
| 646 |
- #' @param bar_width \code{numeric} the width of the bars (in pixels)
+
|
||
| 647 | -+ | ! |
- #'+ rot_vars <- pca$rotation[, c(x_axis, y_axis)] %>% |
| 648 | -+ | ! |
- #' @return \code{character} with HTML code for the \code{sparkline} widget
+ dplyr::as_tibble(rownames = "label") %>% |
| 649 | -+ | ! |
- #'+ dplyr::mutate_at(vars(c(x_axis, y_axis)), function(x) r * x / sqrt(max(v_scale))) |
| 650 |
- #' @export+ }, |
||
| 651 | -+ | ! |
- #' @keywords internal+ env = list(x_axis = x_axis, y_axis = y_axis) |
| 652 |
- #' @rdname create_sparklines+ ) |
||
| 653 |
- create_sparklines.POSIXlt <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) { # nolint
+ ) %>% |
||
| 654 | ! |
- arr_num <- as.numeric(arr)+ teal.code::eval_code( |
|
| 655 | ! |
- arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")+ if (is.logical(pca$center) && !pca$center) {
|
|
| 656 | ! |
- binwidth <- get_bin_width(arr_num, 1)+ substitute( |
|
| 657 | ! |
- bins <- floor(diff(range(arr_num)) / binwidth) + 1+ expr = {
|
|
| 658 | ! |
- if (all(is.na(bins))) {
+ rot_vars <- rot_vars %>% |
|
| 659 | ! |
- return(as.character(tags$code("only NA", class = "text-blue")))
+ tibble::column_to_rownames("label") %>%
|
|
| 660 | ! |
- } else if (bins == 1) {
+ sweep(1, apply(ANL[keep_columns], 2, mean, na.rm = TRUE)) %>% |
|
| 661 | ! |
- return(as.character(tags$code("one date-time", class = "text-blue")))
+ tibble::rownames_to_column("label") %>%
|
|
| 662 | -+ | ! |
- }+ dplyr::mutate( |
| 663 | ! |
- counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))+ xstart = mean(pca$x[, x_axis], na.rm = TRUE), |
|
| 664 | ! |
- max_value <- max(counts)+ ystart = mean(pca$x[, y_axis], na.rm = TRUE) |
|
| 665 |
-
+ ) |
||
| 666 | -! | +
- start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))+ }, |
|
| 667 | ! |
- labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
+ env = list(x_axis = x_axis, y_axis = y_axis) |
|
| 668 | -! | +
- labels <- paste("Start:", labels_start)
+ ) |
|
| 669 |
-
+ } else {
|
||
| 670 | ! |
- sparkline::spk_chr(+ quote(rot_vars <- rot_vars %>% dplyr::mutate(xstart = 0, ystart = 0)) |
|
| 671 | -! | +
- unname(counts),+ } |
|
| 672 | -! | +
- type = "bar",+ ) %>% |
|
| 673 | ! |
- chartRangeMin = 0,+ teal.code::eval_code( |
|
| 674 | ! |
- chartRangeMax = max_value,+ substitute( |
|
| 675 | ! |
- width = width,+ expr = rot_vars <- rot_vars %>% dplyr::filter(label %in% variables), |
|
| 676 | ! |
- barWidth = bar_width,+ env = list(variables = variables) |
|
| 677 | -! | +
- barSpacing = bar_spacing,+ ) |
|
| 678 | -! | +
- tooltipFormatter = custom_sparkline_formatter(labels, counts)+ ) |
|
| 679 |
- )+ } |
||
| 680 |
- }+ |
||
| 681 | -+ | ! |
-
+ pca_plot_biplot_expr <- list(quote(ggplot())) |
| 683 | -+ | ! |
- #' Generates the HTML code for the \code{sparkline} widget
+ if (length(resp_col) == 0) {
|
| 684 | -+ | ! |
- #'+ pca_plot_biplot_expr <- c( |
| 685 | -+ | ! |
- #' Coerces a character vector to factor and delegates to the \code{create_sparklines.factor}
+ pca_plot_biplot_expr, |
| 686 | -+ | ! |
- #'+ substitute( |
| 687 | -+ | ! |
- #'+ geom_point(aes_string(x = x_axis, y = y_axis), data = pca_rot, alpha = alpha, size = size), |
| 688 | -+ | ! |
- #' @return \code{character} with HTML code for the \code{sparkline} widget
+ list(x_axis = input$x_axis, y_axis = input$y_axis, alpha = input$alpha, size = input$size) |
| 689 |
- #'+ ) |
||
| 690 |
- #' @export+ ) |
||
| 691 | -+ | ! |
- #' @keywords internal+ dev_labs <- list() |
| 692 |
- #' @rdname create_sparklines+ } else {
|
||
| 693 | -+ | ! |
- create_sparklines.character <- function(arr, ...) { # nolint
+ rp_keys <- setdiff( |
| 694 | ! |
- return(create_sparklines(as.factor(arr)))+ colnames(ANL), |
|
| 695 | -+ | ! |
- }+ as.character(unlist(merged$anl_input_r()$columns_source)) |
| 696 | -+ | ! |
-
+ ) # nolint |
| 698 | -+ | ! |
- #' Generates the HTML code for the \code{sparkline} widget
+ response <- ANL[[resp_col]] |
| 699 |
- #'+ |
||
| 700 | -+ | ! |
- #' Coerces logical vector to factor and delegates to the \code{create_sparklines.factor}
+ aes_biplot <- substitute( |
| 701 | -+ | ! |
- #'+ aes_string(x = x_axis, y = y_axis, color = "response"), |
| 702 | -+ | ! |
- #'+ env = list(x_axis = x_axis, y_axis = y_axis) |
| 703 |
- #' @return \code{character} with HTML code for the \code{sparkline} widget
+ ) |
||
| 704 |
- #'+ |
||
| 705 | -+ | ! |
- #' @export+ qenv <- teal.code::eval_code( |
| 706 | -+ | ! |
- #' @keywords internal+ qenv, |
| 707 | -+ | ! |
- #' @rdname create_sparklines+ substitute(response <- ANL[[resp_col]], env = list(resp_col = resp_col)) |
| 708 |
- create_sparklines.logical <- function(arr, ...) { # nolint
+ ) |
||
| 709 | -! | +
- return(create_sparklines(as.factor(arr)))+ |
|
| 710 | -+ | ! |
- }+ dev_labs <- list(color = varname_w_label(resp_col, ANL)) |
| 712 | -+ | ! |
-
+ scales_biplot <- |
| 713 | -+ | ! |
- #' Generates the \code{sparkline} HTML code
+ if (is.character(response) || is.factor(response) || (is.numeric(response) && length(unique(response)) <= 6)) { # nolint
|
| 714 | -+ | ! |
- #'+ qenv <- teal.code::eval_code( |
| 715 | -+ | ! |
- #' @param bar_spacing \code{numeric} spacing between the bars (in pixels)
+ qenv, |
| 716 | -+ | ! |
- #' @param bar_width \code{numeric} width of the bars (in pixels)
+ quote(pca_rot$response <- as.factor(response)) |
| 717 |
- #'+ ) |
||
| 718 | -+ | ! |
- #' @return \code{character} with HTML code for the \code{sparkline} widget
+ quote(scale_color_brewer(palette = "Dark2")) |
| 719 | -+ | ! |
- #'+ } else if (inherits(response, "Date")) {
|
| 720 | -+ | ! |
- #' @export+ qenv <- teal.code::eval_code( |
| 721 | -+ | ! |
- #' @keywords internal+ qenv, |
| 722 | -+ | ! |
- #' @rdname create_sparklines+ quote(pca_rot$response <- numeric(response)) |
| 723 |
- create_sparklines.factor <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) { # nolint
+ ) |
||
| 724 | -! | +
- decreasing_order <- TRUE+ |
|
| 725 | -+ | ! |
-
+ quote( |
| 726 | ! |
- counts <- table(arr)+ scale_color_gradient( |
|
| 727 | ! |
- if (length(counts) >= 100) {
+ low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],
|
|
| 728 | ! |
- return(as.character(tags$code("> 99 levels", class = "text-blue")))
+ high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1],
|
|
| 729 | ! |
- } else if (length(counts) == 0) {
+ labels = function(x) as.Date(x, origin = "1970-01-01") |
|
| 730 | -! | +
- return(as.character(tags$code("no levels", class = "text-blue")))
+ ) |
|
| 731 | -! | +
- } else if (length(counts) == 1) {
+ ) |
|
| 732 | -! | +
- return(as.character(tags$code("one level", class = "text-blue")))
+ } else {
|
|
| 733 | -+ | ! |
- }+ qenv <- teal.code::eval_code( |
| 734 | -+ | ! |
-
+ qenv, |
| 735 | -+ | ! |
- # Summarize the occurences of different levels+ quote(pca_rot$response <- response) |
| 736 |
- # and get the maximum and minimum number of occurences+ ) |
||
| 737 | -+ | ! |
- # This is needed for the sparkline to correctly display the bar plots+ quote(scale_color_gradient( |
| 738 | -+ | ! |
- # Otherwise they are cropped+ low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],
|
| 739 | ! |
- counts <- sort(counts, decreasing = decreasing_order, method = "radix")+ high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
|
|
| 740 | -! | +
- max_value <- if (decreasing_order) counts[1] else counts[length[counts]]+ )) |
|
| 741 | -! | +
- max_value <- unname(max_value)+ } |
|
| 743 | ! |
- sparkline::spk_chr(+ pca_plot_biplot_expr <- c( |
|
| 744 | ! |
- unname(counts),+ pca_plot_biplot_expr, |
|
| 745 | ! |
- type = "bar",+ substitute( |
|
| 746 | ! |
- chartRangeMin = 0,+ geom_point(aes_biplot, data = pca_rot, alpha = alpha, size = size), |
|
| 747 | ! |
- chartRangeMax = max_value,+ env = list(aes_biplot = aes_biplot, alpha = alpha, size = size) |
|
| 748 | -! | +
- width = width,+ ), |
|
| 749 | ! |
- barWidth = bar_width,+ scales_biplot |
|
| 750 | -! | +
- barSpacing = bar_spacing,+ ) |
|
| 751 | -! | +
- tooltipFormatter = custom_sparkline_formatter(names(counts), as.vector(counts))+ } |
|
| 752 |
- )+ |
||
| 753 | -+ | ! |
- }+ if (!is.null(input$variables)) {
|
| 754 | -+ | ! |
-
+ pca_plot_biplot_expr <- c( |
| 755 | -+ | ! |
- #' Generates the \code{sparkline} HTML code
+ pca_plot_biplot_expr, |
| 756 | -+ | ! |
- #'+ substitute( |
| 757 | -+ | ! |
- #'+ geom_segment( |
| 758 | -+ | ! |
- #' @return \code{character} with HTML code for the \code{sparkline} widget
+ aes_string(x = "xstart", y = "ystart", xend = x_axis, yend = y_axis), |
| 759 | -+ | ! |
- #'+ data = rot_vars, |
| 760 | -+ | ! |
- #' @export+ lineend = "round", linejoin = "round", |
| 761 | -+ | ! |
- #' @keywords internal+ arrow = grid::arrow(length = grid::unit(0.5, "cm")) |
| 762 |
- #' @rdname create_sparklines+ ), |
||
| 763 | -+ | ! |
- create_sparklines.numeric <- function(arr, width = 150, ...) { # nolint
+ env = list(x_axis = x_axis, y_axis = y_axis) |
| 764 | -! | +
- if (any(is.infinite(arr))) {
+ ), |
|
| 765 | ! |
- return(as.character(tags$code("infinite values", class = "text-blue")))
+ substitute( |
|
| 766 | -+ | ! |
- }+ geom_label( |
| 767 | ! |
- if (length(arr) > 100000) {
+ aes_string( |
|
| 768 | ! |
- return(as.character(tags$code("Too many rows (>100000)", class = "text-blue")))
+ x = x_axis, |
|
| 769 | -+ | ! |
- }+ y = y_axis, |
| 770 | -+ | ! |
-
+ label = "label" |
| 771 | -! | +
- arr <- arr[!is.na(arr)]+ ), |
|
| 772 | ! |
- res <- sparkline::spk_chr(unname(arr), type = "box", width = width, ...)+ data = rot_vars, |
|
| 773 | ! |
- return(res)+ nudge_y = 0.1, |
|
| 774 | -+ | ! |
- }+ fontface = "bold" |
| 775 |
-
+ ), |
||
| 776 | -+ | ! |
- #' Summarizes variable+ env = list(x_axis = x_axis, y_axis = y_axis) |
| 777 |
- #'+ ), |
||
| 778 | -+ | ! |
- #' Creates html summary with statistics relevant to data type. For numeric values it returns central+ quote(geom_point(aes(x = xstart, y = ystart), data = rot_vars, shape = "x", size = 5)) |
| 779 |
- #' tendency measures, for factor returns level counts, for Date date range, for other just+ ) |
||
| 780 |
- #' number of levels.+ } |
||
| 781 |
- #' @param x vector of any type+ |
||
| 782 | -+ | ! |
- #' @param numeric_as_factor \code{logical} should the numeric variable be treated as a factor
+ angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0) |
| 783 | -+ | ! |
- #' @param dt_rows \code{numeric} current/latest `DT` page length
+ hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5) |
| 784 |
- #' @param outlier_definition If 0 no outliers are removed, otherwise+ |
||
| 785 | -+ | ! |
- #' outliers (those more than outlier_definition*IQR below/above Q1/Q3 be removed)+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 786 | -+ | ! |
- #' @return text with simple statistics.+ labs = dev_labs, |
| 787 | -+ | ! |
- #' @keywords internal+ theme = list( |
| 788 | -+ | ! |
- var_summary_table <- function(x, numeric_as_factor, dt_rows, outlier_definition) {
+ text = substitute(element_text(size = font_size), list(font_size = font_size)), |
| 789 | ! |
- if (is.null(dt_rows)) {
+ axis.text.x = substitute( |
|
| 790 | ! |
- dt_rows <- 10+ element_text(angle = angle_val, hjust = hjust_val), |
|
| 791 | -+ | ! |
- }+ list(angle_val = angle, hjust_val = hjust) |
| 792 | -! | +
- if (is.numeric(x) && !numeric_as_factor) {
+ ) |
|
| 793 | -! | +
- req(!any(is.infinite(x)))+ ) |
|
| 794 |
-
+ ) |
||
| 795 | -! | +
- x <- remove_outliers_from(x, outlier_definition)+ |
|
| 796 | -+ | ! |
-
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 797 | ! |
- qvals <- round(stats::quantile(x, na.rm = TRUE, probs = c(0.25, 0.5, 0.75), type = 2), 2)+ user_plot = ggplot2_args[["Biplot"]], |
|
| 798 | -+ | ! |
- # classical central tendency measures+ user_default = ggplot2_args$default, |
| 799 | -+ | ! |
-
+ module_plot = dev_ggplot2_args |
| 800 | -! | +
- summary <-+ ) |
|
| 801 | -! | +
- data.frame(+ |
|
| 802 | ! |
- Statistic = c("min", "Q1", "median", "mean", "Q3", "max", "sd", "n"),
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 803 | ! |
- Value = c(+ all_ggplot2_args, |
|
| 804 | ! |
- round(min(x, na.rm = TRUE), 2),+ ggtheme = ggtheme |
|
| 805 | -! | +
- qvals[1],+ ) |
|
| 806 | -! | +
- qvals[2],+ |
|
| 807 | ! |
- round(mean(x, na.rm = TRUE), 2),+ pca_plot_biplot_expr <- c( |
|
| 808 | ! |
- qvals[3],+ pca_plot_biplot_expr, |
|
| 809 | ! |
- round(max(x, na.rm = TRUE), 2),+ parsed_ggplot2_args |
|
| 810 | -! | +
- round(stats::sd(x, na.rm = TRUE), 2),+ ) |
|
| 811 | -! | +
- length(x[!is.na(x)])+ |
|
| 812 | -+ | ! |
- )+ teal.code::eval_code( |
| 813 | -+ | ! |
- )+ qenv, |
| 814 | -+ | ! |
-
+ substitute( |
| 815 | ! |
- DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows))+ expr = {
|
|
| 816 | ! |
- } else if (is.factor(x) || is.character(x) || (is.numeric(x) && numeric_as_factor) || is.logical(x)) {
+ g <- plot_call |
|
| 817 | -+ | ! |
- # make sure factor is ordered numeric+ print(g) |
| 818 | -! | +
- if (is.numeric(x)) {
+ }, |
|
| 819 | ! |
- x <- factor(x, levels = sort(unique(x)))+ env = list( |
|
| 820 | -+ | ! |
- }+ plot_call = Reduce(function(x, y) call("+", x, y), pca_plot_biplot_expr)
|
| 821 |
-
+ ) |
||
| 822 | -! | +
- level_counts <- table(x)+ ) |
|
| 823 | -! | +
- max_levels_signif <- nchar(level_counts)+ ) |
|
| 824 |
-
+ } |
||
| 825 | -! | +
- if (!all(is.na(x))) {
+
|
|
| 826 | -! | +
- levels <- names(level_counts)+ # plot pc_var ---- |
|
| 827 | ! |
- counts <- sprintf(+ plot_pc_var <- function(base_q) {
|
|
| 828 | ! |
- "%s [%.2f%%]",+ pc <- input$pc # nolint |
|
| 829 | ! |
- format(level_counts, width = max_levels_signif), prop.table(level_counts) * 100+ ggtheme <- input$ggtheme |
|
| 830 |
- )+ |
||
| 831 | -+ | ! |
- } else {
+ rotate_xaxis_labels <- input$rotate_xaxis_labels # nolint |
| 832 | ! |
- levels <- character(0)+ font_size <- input$font_size # nolint |
|
| 833 | -! | +
- counts <- numeric(0)+ |
|
| 834 | -+ | ! |
- }+ angle <- ifelse(rotate_xaxis_labels, 45, 0) |
| 835 | -+ | ! |
-
+ hjust <- ifelse(rotate_xaxis_labels, 1, 0.5) |
| 836 | -! | +
- summary <- data.frame(+ |
|
| 837 | ! |
- Level = levels,+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
|
| 838 | ! |
- Count = counts,+ theme = list( |
|
| 839 | ! |
- stringsAsFactors = FALSE+ text = substitute(element_text(size = font_size), list(font_size = font_size)), |
|
| 840 | -+ | ! |
- )+ axis.text.x = substitute( |
| 841 | -+ | ! |
-
+ element_text(angle = angle_val, hjust = hjust_val), |
| 842 | -+ | ! |
- # sort the dataset in decreasing order of counts (needed as character variables default to alphabetical)+ list(angle_val = angle, hjust_val = hjust) |
| 843 | -! | +
- summary <- summary[order(summary$Count, decreasing = TRUE), ]+ ) |
|
| 844 |
-
+ ) |
||
| 845 | -! | +
- dom_opts <- if (nrow(summary) <= 10) {
+ ) |
|
| 846 | -! | +
- "<t>"+ |
|
| 847 | -+ | ! |
- } else {
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 848 | ! |
- "<lf<t>ip>"+ user_plot = ggplot2_args[["Eigenvector plot"]], |
|
| 849 | -+ | ! |
- }+ user_default = ggplot2_args$default, |
| 850 | ! |
- DT::datatable(summary, rownames = FALSE, options = list(dom = dom_opts, pageLength = dt_rows))+ module_plot = dev_ggplot2_args |
|
| 851 | -! | +
- } else if (inherits(x, "Date") || inherits(x, "POSIXct") || inherits(x, "POSIXlt")) {
+ ) |
|
| 852 | -! | +
- summary <-+ |
|
| 853 | ! |
- data.frame(+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 854 | ! |
- Statistic = c("min", "median", "max"),
+ all_ggplot2_args, |
|
| 855 | ! |
- Value = c(+ ggtheme = ggtheme |
|
| 856 | -! | +
- min(x, na.rm = TRUE),+ ) |
|
| 857 | -! | +
- stats::median(x, na.rm = TRUE),+ |
|
| 858 | ! |
- max(x, na.rm = TRUE)+ ggplot_exprs <- c( |
|
| 859 | -+ | ! |
- )+ list( |
| 860 | -+ | ! |
- )+ quote(ggplot(pca_rot)), |
| 861 | ! |
- DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows))+ substitute( |
|
| 862 | -+ | ! |
- } else {
+ geom_bar( |
| 863 | ! |
- NULL+ aes_string(x = "Variable", y = pc), |
|
| 864 | -+ | ! |
- }+ stat = "identity", |
| 865 | -+ | ! |
- }+ color = "black", |
| 866 | -+ | ! |
-
+ fill = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
|
| 867 |
-
+ ), |
||
| 868 | -+ | ! |
- #' Plot variable+ env = list(pc = pc) |
| 869 |
- #'+ ), |
||
| 870 | -+ | ! |
- #' Creates summary plot with statistics relevant to data type.+ substitute( |
| 871 | -+ | ! |
- #' @inheritParams shared_params+ geom_text( |
| 872 | -+ | ! |
- #' @param var vector of any type to be plotted. For numeric variables it produces histogram with+ aes( |
| 873 | -+ | ! |
- #' density line, for factors it creates frequency plot+ x = Variable, |
| 874 | -+ | ! |
- #' @param var_lab text describing selected variable to be displayed on the plot+ y = pc_name, |
| 875 | -+ | ! |
- #' @param wrap_character (`numeric`) number of characters at which to wrap text values of `var`+ label = round(pc_name, 3), |
| 876 | -+ | ! |
- #' @param numeric_as_factor (`logical`) should the numeric variable be treated as a factor+ vjust = ifelse(pc_name > 0, -0.5, 1.3) |
| 877 |
- #' @param display_density (`logical`) should density estimation be displayed for numeric values+ ) |
||
| 878 |
- #' @param remove_NA_hist (`logical`) should (`NA`) values be removed for histogram of factor like variables+ ), |
||
| 879 | -+ | ! |
- #' @param outlier_definition if 0 no outliers are removed, otherwise+ env = list(pc_name = as.name(pc)) |
| 880 |
- #' outliers (those more than outlier_definition*IQR below/above Q1/Q3 be removed)+ ) |
||
| 881 |
- #' @param records_for_factor (`numeric`) if the number of factor levels is >= than this value then+ ), |
||
| 882 | -+ | ! |
- #' a graph of the factors isn't shown, only a list of values+ parsed_ggplot2_args$labs, |
| 883 | -+ | ! |
- #'+ parsed_ggplot2_args$ggtheme, |
| 884 | -+ | ! |
- #' @return plot+ parsed_ggplot2_args$theme |
| 885 |
- #' @keywords internal+ ) |
||
| 886 |
- plot_var_summary <- function(var,+ |
||
| 887 | -+ | ! |
- var_lab,+ teal.code::eval_code( |
| 888 | -+ | ! |
- wrap_character = NULL,+ base_q, |
| 889 | -+ | ! |
- numeric_as_factor,+ substitute( |
| 890 | -+ | ! |
- display_density = is.numeric(var),+ expr = {
|
| 891 | -+ | ! |
- remove_NA_hist = FALSE, # nolint+ pca_rot <- pca$rotation[, pc, drop = FALSE] %>% |
| 892 | -+ | ! |
- outlier_definition,+ dplyr::as_tibble(rownames = "Variable") |
| 893 |
- records_for_factor,+ |
||
| 894 | -+ | ! |
- ggplot2_args) {
+ g <- plot_call |
| 895 | -! | +
- checkmate::assert_character(var_lab)+ |
|
| 896 | ! |
- checkmate::assert_numeric(wrap_character, null.ok = TRUE)+ print(g) |
|
| 897 | -! | +
- checkmate::assert_flag(numeric_as_factor)+ }, |
|
| 898 | ! |
- checkmate::assert_flag(display_density)+ env = list( |
|
| 899 | ! |
- checkmate::assert_logical(remove_NA_hist, null.ok = TRUE)+ pc = pc, |
|
| 900 | ! |
- checkmate::assert_number(outlier_definition, lower = 0, finite = TRUE)+ plot_call = Reduce(function(x, y) call("+", x, y), ggplot_exprs)
|
|
| 901 | -! | +
- checkmate::assert_integerish(records_for_factor, lower = 0, len = 1, any.missing = FALSE)+ ) |
|
| 902 | -! | +
- checkmate::assert_class(ggplot2_args, "ggplot2_args")+ ) |
|
| 903 |
-
+ ) |
||
| 904 | -! | +
- grid::grid.newpage()+ } |
|
| 906 | -! | +
- plot_main <- if (is.factor(var) || is.character(var) || is.logical(var)) {
+ # plot final ---- |
|
| 907 | ! |
- groups <- unique(as.character(var))+ output_q <- reactive({
|
|
| 908 | ! |
- len_groups <- length(groups)+ req(computation()) |
|
| 909 | ! |
- if (len_groups >= records_for_factor) {
+ teal::validate_inputs(iv_r()) |
|
| 910 | ! |
- grid::textGrob(+ teal::validate_inputs(iv_extra, header = "Plot settings are required") |
|
| 911 | -! | +
- sprintf(+ |
|
| 912 | ! |
- "%s unique values\n%s:\n %s\n ...\n %s",+ switch(input$plot_type, |
|
| 913 | ! |
- len_groups,+ "Elbow plot" = plot_elbow(computation()), |
|
| 914 | ! |
- var_lab,+ "Circle plot" = plot_circle(computation()), |
|
| 915 | ! |
- paste(utils::head(groups), collapse = ",\n "),+ "Biplot" = plot_biplot(computation()), |
|
| 916 | ! |
- paste(utils::tail(groups), collapse = ",\n ")+ "Eigenvector plot" = plot_pc_var(computation()), |
|
| 917 | -+ | ! |
- ),+ stop("Unknown plot")
|
| 918 | -! | +
- x = grid::unit(1, "line"),+ ) |
|
| 919 | -! | +
- y = grid::unit(1, "npc") - grid::unit(1, "line"),+ }) |
|
| 920 | -! | +
- just = c("left", "top")
+
|
|
| 921 | -+ | ! |
- )+ plot_r <- reactive({
|
| 922 | -+ | ! |
- } else {
+ output_q()[["g"]] |
| 923 | -! | +
- if (!is.null(wrap_character)) {
+ }) |
|
| 924 | -! | +
- var <- stringr::str_wrap(var, width = wrap_character)+ |
|
| 925 | -+ | ! |
- }+ pws <- teal.widgets::plot_with_settings_srv( |
| 926 | ! |
- var <- if (isTRUE(remove_NA_hist)) as.vector(stats::na.omit(var)) else var+ id = "pca_plot", |
|
| 927 | ! |
- ggplot(data.frame(var), aes(x = forcats::fct_infreq(as.factor(var)))) ++ plot_r = plot_r, |
|
| 928 | ! |
- geom_bar(stat = "count", aes(fill = ifelse(is.na(var), "withcolor", "")), show.legend = FALSE) ++ height = plot_height, |
|
| 929 | ! |
- scale_fill_manual(values = c("gray50", "tan"))
+ width = plot_width, |
|
| 930 | -+ | ! |
- }+ graph_align = "center" |
| 931 | -! | +
- } else if (is.numeric(var)) {
+ ) |
|
| 932 | -! | +
- validate(need(any(!is.na(var)), "No data left to visualize."))+ |
|
| 933 |
-
+ # tables ---- |
||
| 934 | -+ | ! |
- # Filter out NA+ output$tbl_importance <- renderTable( |
| 935 | ! |
- var <- var[which(!is.na(var))]+ expr = {
|
|
| 936 | -+ | ! |
-
+ req("importance" %in% input$tables_display, computation())
|
| 937 | ! |
- validate(need(!any(is.infinite(var)), "Cannot display graph when data includes infinite values"))+ computation()[["tbl_importance"]] |
|
| 938 |
-
+ }, |
||
| 939 | ! |
- if (numeric_as_factor) {
+ bordered = TRUE, |
|
| 940 | ! |
- var <- factor(var, levels = sort(unique(var)))+ align = "c", |
|
| 941 | ! |
- p <- qplot(var)+ digits = 3 |
|
| 942 |
- } else {
+ ) |
||
| 943 |
- # remove outliers+ |
||
| 944 | ! |
- if (outlier_definition != 0) {
+ output$tbl_importance_ui <- renderUI({
|
|
| 945 | ! |
- number_records <- length(var)+ req("importance" %in% input$tables_display)
|
|
| 946 | ! |
- var <- remove_outliers_from(var, outlier_definition)+ div( |
|
| 947 | ! |
- number_outliers <- number_records - length(var)+ align = "center", |
|
| 948 | ! |
- outlier_text <- paste0(+ tags$h4("Principal components importance"),
|
|
| 949 | ! |
- number_outliers, " outliers (",
+ tableOutput(session$ns("tbl_importance")),
|
|
| 950 | ! |
- round(number_outliers / number_records * 100, 2),+ hr() |
|
| 951 | -! | +
- "% of non-missing records) not shown"+ ) |
|
| 952 |
- )+ }) |
||
| 953 | -! | +
- validate(need(+ |
|
| 954 | ! |
- length(var) > 1,+ output$tbl_eigenvector <- renderTable( |
|
| 955 | ! |
- "At least two data points must remain after removing outliers for this graph to be displayed"+ expr = {
|
|
| 956 | -+ | ! |
- ))+ req("eigenvector" %in% input$tables_display, req(computation()))
|
| 957 | -+ | ! |
- }+ computation()[["tbl_eigenvector"]] |
| 958 |
- ## histogram+ }, |
||
| 959 | ! |
- binwidth <- get_bin_width(var)+ bordered = TRUE, |
|
| 960 | ! |
- p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) ++ align = "c", |
|
| 961 | ! |
- geom_histogram(binwidth = binwidth) ++ digits = 3 |
|
| 962 | -! | +
- scale_y_continuous(+ ) |
|
| 963 | -! | +
- sec.axis = sec_axis(+ |
|
| 964 | ! |
- trans = ~ . / nrow(data.frame(var = var)),+ output$tbl_eigenvector_ui <- renderUI({
|
|
| 965 | ! |
- labels = scales::percent,+ req("eigenvector" %in% input$tables_display)
|
|
| 966 | ! |
- name = "proportion (in %)"+ div( |
|
| 967 | -+ | ! |
- )+ align = "center", |
| 968 | -+ | ! |
- )+ tags$h4("Eigenvectors"),
|
| 969 | -+ | ! |
-
+ tableOutput(session$ns("tbl_eigenvector")),
|
| 970 | ! |
- if (display_density) {
+ hr() |
|
| 971 | -! | +
- p <- p + geom_density(aes(y = after_stat(count * binwidth)))+ ) |
|
| 972 |
- }+ }) |
||
| 974 | ! |
- if (outlier_definition != 0) {
+ output$all_plots <- renderUI({
|
|
| 975 | ! |
- p <- p + annotate(+ teal::validate_inputs(iv_r()) |
|
| 976 | ! |
- geom = "text",+ teal::validate_inputs(iv_extra, header = "Plot settings are required") |
|
| 977 | -! | +
- label = outlier_text,+ |
|
| 978 | ! |
- x = Inf, y = Inf,+ validation() |
|
| 979 | ! |
- hjust = 1.02, vjust = 1.2,+ tags$div( |
|
| 980 | ! |
- color = "black",+ class = "overflow-scroll", |
|
| 981 | -+ | ! |
- # explicitly modify geom text size according+ uiOutput(session$ns("tbl_importance_ui")),
|
| 982 | ! |
- size = ggplot2_args[["theme"]][["text"]][["size"]] / 3.5+ uiOutput(session$ns("tbl_eigenvector_ui")),
|
|
| 983 | -+ | ! |
- )+ teal.widgets::plot_with_settings_ui(id = session$ns("pca_plot"))
|
| 984 |
- }+ ) |
||
| 985 | -! | +
- p+ }) |
|
| 986 |
- }+ |
||
| 987 | ! |
- } else if (inherits(var, "Date") || inherits(var, "POSIXct") || inherits(var, "POSIXlt")) {
+ teal.widgets::verbatim_popup_srv( |
|
| 988 | ! |
- var_num <- as.numeric(var)+ id = "warning", |
|
| 989 | ! |
- binwidth <- get_bin_width(var_num, 1)+ verbatim_content = reactive(teal.code::get_warnings(output_q())), |
|
| 990 | ! |
- p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) ++ title = "Warning", |
|
| 991 | ! |
- geom_histogram(binwidth = binwidth)+ disabled = reactive(is.null(teal.code::get_warnings(output_q()))) |
|
| 992 |
- } else {
+ ) |
||
| 993 | -! | +
- grid::textGrob(+ |
|
| 994 | ! |
- paste(strwrap(+ teal.widgets::verbatim_popup_srv( |
|
| 995 | ! |
- utils::capture.output(utils::str(var)),+ id = "rcode", |
|
| 996 | ! |
- width = .9 * grid::convertWidth(grid::unit(1, "npc"), "char", TRUE)+ verbatim_content = reactive(teal.code::get_code(output_q())), |
|
| 997 | ! |
- ), collapse = "\n"),+ title = "R Code for PCA" |
|
| 998 | -! | +
- x = grid::unit(1, "line"), y = grid::unit(1, "npc") - grid::unit(1, "line"), just = c("left", "top")
+ ) |
|
| 999 |
- )+ |
||
| 1000 |
- }+ ### REPORTER |
||
| 1001 | -+ | ! |
-
+ if (with_reporter) {
|
| 1002 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ card_fun <- function(comment, label) {
|
|
| 1003 | ! |
- labs = list(x = var_lab)+ card <- teal::report_card_template( |
|
| 1004 | -+ | ! |
- )+ title = "Principal Component Analysis Plot", |
| 1005 | -+ | ! |
- ###+ label = label, |
| 1006 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ with_filter = with_filter, |
|
| 1007 | ! |
- ggplot2_args,+ filter_panel_api = filter_panel_api |
|
| 1008 | -! | +
- module_plot = dev_ggplot2_args+ ) |
|
| 1009 | -+ | ! |
- )+ card$append_text("Principal Components Table", "header3")
|
| 1010 | -+ | ! |
-
+ card$append_table(computation()[["tbl_importance"]]) |
| 1011 | ! |
- if (is.ggplot(plot_main)) {
+ card$append_text("Eigenvectors Table", "header3")
|
|
| 1012 | ! |
- if (is.numeric(var) && !numeric_as_factor) {
+ card$append_table(computation()[["tbl_eigenvector"]]) |
|
| 1013 | -+ | ! |
- # numeric not as factor+ card$append_text("Plot", "header3")
|
| 1014 | ! |
- plot_main <- plot_main ++ card$append_plot(plot_r(), dim = pws$dim()) |
|
| 1015 | ! |
- theme_light() ++ if (!comment == "") {
|
|
| 1016 | ! |
- list(+ card$append_text("Comment", "header3")
|
|
| 1017 | ! |
- labs = do.call("labs", all_ggplot2_args$labs),
+ card$append_text(comment) |
|
| 1018 | -! | +
- theme = do.call("theme", all_ggplot2_args$theme)
+ } |
|
| 1019 | -+ | ! |
- )+ card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n")) |
| 1020 | -+ | ! |
- } else {
+ card |
| 1021 |
- # factor low number of levels OR numeric as factor OR Date+ } |
||
| 1022 | ! |
- plot_main <- plot_main ++ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 1023 | -! | +
- theme_light() ++ } |
|
| 1024 | -! | +
- list(+ ### |
|
| 1025 | -! | +
- labs = do.call("labs", all_ggplot2_args$labs),
+ }) |
|
| 1026 | -! | +
- theme = do.call("theme", all_ggplot2_args$theme)
+ }+ |
+
| 1 | ++ |
+ #' Response Plots |
|
| 1027 | +2 |
- )+ #' @md |
|
| 1028 | +3 |
- }+ #' |
|
| 1029 | -! | +||
| 4 | +
- plot_main <- ggplotGrob(plot_main)+ #' @inheritParams teal::module |
||
| 1030 | +5 |
- }+ #' @inheritParams shared_params |
|
| 1031 | +6 |
-
+ #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 1032 | -! | +||
| 7 | ++ |
+ #' Which variable to use as the response. You can define one fixed column by using the+ |
+ |
| 8 | ++ |
+ #' setting `fixed = TRUE` inside the `select_spec`.+ |
+ |
| 9 | ++ |
+ #' `data_extract_spec` must not allow multiple selection in this case.+ |
+ |
| 10 | ++ |
+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
+ |
| 11 | +
- grid::grid.draw(plot_main)+ #' Which variable to use on the X-axis of the response plot. Allow the user to select multiple |
||
| 1033 | -! | +||
| 12 | +
- plot_main+ #' columns from the `data` allowed in teal. |
||
| 1034 | +13 |
- }+ #' `data_extract_spec` must not allow multiple selection in this case. |
|
| 1035 | +14 |
-
+ #' @param row_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 1036 | +15 |
- #' Returns a short variable description.+ #' Which data columns to use for faceting rows. |
|
| 1037 | +16 |
- #'+ #' @param col_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 1038 | +17 |
- #' @description+ #' Which data to use for faceting columns. |
|
| 1039 | +18 |
- #' The format of the variable description is:+ #' @param coord_flip optional, (`logical`) Whether to flip coordinates between `x` and `response`. |
|
| 1040 | +19 |
- #' `"<Long variable label> [<dataset name>.<variable name>]"`+ #' @param count_labels optional, (`logical`) Whether to show count labels. |
|
| 1041 | +20 |
- #'+ #' Defaults to `TRUE`. |
|
| 1042 | +21 |
- #' Example: `"Study Identifier [ADSL.STUDYID]"`+ #' @param freq optional, (`logical`) Whether to display frequency (`TRUE`) or density (`FALSE`). |
|
| 1043 | +22 |
- #'+ #' Defaults to density (`FALSE`). |
|
| 1044 | +23 |
- #' @param data (`tdata`) the object containing the dataset+ #' |
|
| 1045 | +24 |
- #' @param dataset_name (`character`) the name of the dataset containing the variable+ #' @note For more examples, please see the vignette "Using response plot" via |
|
| 1046 | +25 |
- #' @param var_name (`character`) the name of the variable+ #' \code{vignette("using-response-plot", package = "teal.modules.general")}.
|
|
| 1047 | +26 |
- #' @keywords internal+ #' @export |
|
| 1048 | +27 |
- get_var_description <- function(data, dataset_name, var_name) {
+ #' @examples |
|
| 1049 | -! | +||
| 28 | +
- varlabel <- var_labels(data[[dataset_name]]())[[var_name]]+ #' # Response plot with selected response (BMRKR1) and selected x variable (RACE) |
||
| 1050 | -! | +||
| 29 | +
- sprintf(+ #' library(nestcolor) |
||
| 1051 | -! | +||
| 30 | +
- "%s [%s.%s]",+ #' |
||
| 1052 | -! | +||
| 31 | +
- if (is.na(varlabel)) var_name else varlabel,+ #' ADSL <- teal.modules.general::rADSL |
||
| 1053 | -! | +||
| 32 | +
- dataset_name,+ #' |
||
| 1054 | -! | +||
| 33 | +
- var_name+ #' app <- teal::init( |
||
| 1055 | +34 |
- )+ #' data = teal.data::cdisc_data( |
|
| 1056 | +35 |
- }+ #' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
|
|
| 1057 | +36 |
-
+ #' check = TRUE |
|
| 1058 | +37 |
- is_num_var_short <- function(.unique_records_for_factor, input, data_for_analysis) {
+ #' ), |
|
| 1059 | -! | +||
| 38 | +
- length(unique(data_for_analysis()$data)) < .unique_records_for_factor && !is.null(input$numeric_as_factor)+ #' modules = teal::modules( |
||
| 1060 | +39 |
- }+ #' teal.modules.general::tm_g_response( |
|
| 1061 | +40 |
-
+ #' label = "Response Plots", |
|
| 1062 | +41 |
- #' Validates the variable browser inputs+ #' response = teal.transform::data_extract_spec( |
|
| 1063 | +42 |
- #'+ #' dataname = "ADSL", |
|
| 1064 | +43 |
- #' @param input (`session$input`) the shiny session input+ #' select = teal.transform::select_spec( |
|
| 1065 | +44 |
- #' @param plot_var (`list`) list of a data frame and an array of variable names+ #' label = "Select variable:", |
|
| 1066 | +45 |
- #' @param data (`tdata`) the datasets passed to the module+ #' choices = teal.transform::variable_choices(ADSL, c("BMRKR2", "COUNTRY")),
|
|
| 1067 | +46 |
- #'+ #' selected = "BMRKR2", |
|
| 1068 | +47 |
- #' @returns `logical` TRUE if validations pass; a Shiny validation error otherwise+ #' multiple = FALSE, |
|
| 1069 | +48 |
- #' @keywords internal+ #' fixed = FALSE |
|
| 1070 | +49 |
- validate_input <- function(input, plot_var, data) {
+ #' ) |
|
| 1071 | -! | +||
| 50 | +
- reactive({
+ #' ), |
||
| 1072 | -! | +||
| 51 | +
- dataset_name <- input$tabset_panel+ #' x = teal.transform::data_extract_spec( |
||
| 1073 | -! | +||
| 52 | +
- varname <- plot_var$variable[[input$tabset_panel]]+ #' dataname = "ADSL", |
||
| 1074 | +53 |
-
+ #' select = teal.transform::select_spec( |
|
| 1075 | -! | +||
| 54 | +
- validate(need(dataset_name, "No data selected"))+ #' label = "Select variable:", |
||
| 1076 | -! | +||
| 55 | +
- validate(need(varname, "No variable selected"))+ #' choices = teal.transform::variable_choices(ADSL, c("SEX", "RACE")),
|
||
| 1077 | +56 |
-
+ #' selected = "RACE", |
|
| 1078 | -! | +||
| 57 | +
- df <- data[[dataset_name]]()+ #' multiple = FALSE, |
||
| 1079 | -! | +||
| 58 | +
- teal::validate_has_data(df, 1)+ #' fixed = FALSE |
||
| 1080 | -! | +||
| 59 | +
- teal::validate_has_variable(varname = varname, data = df, "Variable not available")+ #' ) |
||
| 1081 | +60 |
-
+ #' ), |
|
| 1082 | -! | +||
| 61 | +
- TRUE+ #' ggplot2_args = teal.widgets::ggplot2_args( |
||
| 1083 | +62 |
- })+ #' labs = list(subtitle = "Plot generated by Response Module") |
|
| 1084 | +63 |
- }+ #' ) |
|
| 1085 | +64 |
-
+ #' ) |
|
| 1086 | +65 |
- get_plotted_data <- function(input, plot_var, data) {
+ #' ) |
|
| 1087 | -! | +||
| 66 | +
- dataset_name <- input$tabset_panel+ #' ) |
||
| 1088 | -! | +||
| 67 | +
- varname <- plot_var$variable[[input$tabset_panel]]+ #' if (interactive()) {
|
||
| 1089 | -! | +||
| 68 | +
- df <- data[[dataset_name]]()+ #' shinyApp(app$ui, app$server) |
||
| 1090 | +69 |
-
+ #' } |
|
| 1091 | -! | +||
| 70 | +
- var_description <- var_labels(df)[[varname]]+ tm_g_response <- function(label = "Response Plot", |
||
| 1092 | -! | +||
| 71 | +
- list(data = df[[varname]], var_description = var_description)+ response, |
||
| 1093 | +72 |
- }+ x, |
|
| 1094 | +73 |
-
+ row_facet = NULL, |
|
| 1095 | +74 |
- #' Renders the left-hand side `tabset` panel of the module+ col_facet = NULL, |
|
| 1096 | +75 |
- #'+ coord_flip = FALSE, |
|
| 1097 | +76 |
- #' @param datanames (`character`) the name of the dataset+ count_labels = TRUE, |
|
| 1098 | +77 |
- #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from+ rotate_xaxis_labels = FALSE, |
|
| 1099 | +78 |
- #' @param data (`tdata`) the object containing all datasets+ freq = FALSE, |
|
| 1100 | +79 |
- #' @param input (`session$input`) the shiny session input+ plot_height = c(600, 400, 5000), |
|
| 1101 | +80 |
- #' @param output (`session$output`) the shiny session output+ plot_width = NULL, |
|
| 1102 | +81 |
- #' @param columns_names (`environment`) the environment containing bindings for each dataset+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
|
|
| 1103 | +82 |
- #' @param plot_var (`list`) the list containing the currently selected dataset (tab) and its column names+ ggplot2_args = teal.widgets::ggplot2_args(), |
|
| 1104 | +83 |
- #' @keywords internal+ pre_output = NULL, |
|
| 1105 | +84 |
- render_tabset_panel_content <- function(datanames, parent_dataname, output, data, input, columns_names, plot_var) {
+ post_output = NULL) {
|
|
| 1106 | +85 | ! |
- lapply(datanames, render_single_tab,+ logger::log_info("Initializing tm_g_response")
|
| 1107 | +86 | ! |
- input = input,+ if (inherits(response, "data_extract_spec")) response <- list(response) |
| 1108 | +87 | ! |
- output = output,+ if (inherits(x, "data_extract_spec")) x <- list(x) |
| 1109 | +88 | ! |
- data = data,+ if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet) |
| 1110 | +89 | ! |
- parent_dataname = parent_dataname,+ if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) |
| 1111 | +90 | ! |
- columns_names = columns_names,+ checkmate::assert_string(label) |
| 1112 | +91 | ! |
- plot_var = plot_var- |
-
| 1113 | -- |
- )- |
- |
| 1114 | -- |
- }+ ggtheme <- match.arg(ggtheme) |
|
| 1115 | -+ | ||
| 92 | +! |
-
+ checkmate::assert_list(response, types = "data_extract_spec") |
|
| 1116 | -+ | ||
| 93 | +! |
- #' Renders a single tab in the left-hand side tabset panel+ if (!all(vapply(response, function(x) !("" %in% x$select$choices), logical(1)))) {
|
|
| 1117 | -+ | ||
| 94 | +! |
- #'+ stop("'response' should not allow empty values")
|
|
| 1118 | +95 |
- #' @description+ } |
|
| 1119 | -+ | ||
| 96 | +! |
- #' Renders a single tab in the left-hand side tabset panel. The rendered tab contains+ if (!all(vapply(response, function(x) !x$select$multiple, logical(1)))) {
|
|
| 1120 | -+ | ||
| 97 | +! |
- #' information about one dataset out of many presented in the module.+ stop("'response' should not allow multiple selection")
|
|
| 1121 | +98 |
- #'+ } |
|
| 1122 | -+ | ||
| 99 | +! |
- #' @param dataset_name (`character`) the name of the dataset contained in the rendered tab+ checkmate::assert_list(x, types = "data_extract_spec") |
|
| 1123 | -+ | ||
| 100 | +! |
- #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from+ if (!all(vapply(x, function(x) !("" %in% x$select$choices), logical(1)))) {
|
|
| 1124 | -+ | ||
| 101 | +! |
- #' @inheritParams render_tabset_panel_content+ stop("'x' should not allow empty values")
|
|
| 1125 | +102 |
- #' @keywords internal+ } |
|
| 1126 | -+ | ||
| 103 | +! |
- render_single_tab <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
+ if (!all(vapply(x, function(x) !x$select$multiple, logical(1)))) {
|
|
| 1127 | +104 | ! |
- render_tab_header(dataset_name, output, data)+ stop("'x' should not allow multiple selection")
|
| 1128 | +105 |
-
+ } |
|
| 1129 | +106 | ! |
- render_tab_table(+ checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) |
| 1130 | +107 | ! |
- dataset_name = dataset_name,+ checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) |
| 1131 | +108 | ! |
- parent_dataname = parent_dataname,+ checkmate::assert_flag(coord_flip) |
| 1132 | +109 | ! |
- output = output,+ checkmate::assert_flag(count_labels) |
| 1133 | +110 | ! |
- data = data,+ checkmate::assert_flag(rotate_xaxis_labels) |
| 1134 | +111 | ! |
- input = input,+ checkmate::assert_flag(freq) |
| 1135 | +112 | ! |
- columns_names = columns_names,+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 1136 | +113 | ! |
- plot_var = plot_var+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 1137 | -+ | ||
| 114 | +! |
- )+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
|
| 1138 | -+ | ||
| 115 | +! |
- }+ checkmate::assert_numeric( |
|
| 1139 | -+ | ||
| 116 | +! |
-
+ plot_width[1], |
|
| 1140 | -+ | ||
| 117 | +! |
- #' Renders the text headlining a single tab in the left-hand side tabset panel+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
|
| 1141 | +118 |
- #'+ ) |
|
| 1142 | +119 |
- #' @param dataset_name (`character`) the name of the dataset of the tab+ |
|
| 1143 | -+ | ||
| 120 | +! |
- #' @inheritParams render_tabset_panel_content+ checkmate::assert_class(ggplot2_args, "ggplot2_args") |
|
| 1144 | +121 |
- #' @keywords internal+ |
|
| 1145 | -+ | ||
| 122 | +! |
- render_tab_header <- function(dataset_name, output, data) {
+ args <- as.list(environment()) |
|
| 1146 | -! | +||
| 123 | +
- dataset_ui_id <- paste0("dataset_summary_", dataset_name)
+
|
||
| 1147 | +124 | ! |
- output[[dataset_ui_id]] <- renderText({
+ data_extract_list <- list( |
| 1148 | +125 | ! |
- df <- data[[dataset_name]]()+ response = response, |
| 1149 | +126 | ! |
- join_keys <- get_join_keys(data)+ x = x, |
| 1150 | +127 | ! |
- if (!is.null(join_keys)) {
+ row_facet = row_facet, |
| 1151 | +128 | ! |
- key <- get_join_keys(data)$get(dataset_name)[[dataset_name]]+ col_facet = col_facet |
| 1152 | +129 |
- } else {
- |
- |
| 1153 | -! | -
- key <- NULL+ ) |
|
| 1154 | +130 |
- }+ |
|
| 1155 | +131 | ! |
- sprintf(+ module( |
| 1156 | +132 | ! |
- "Dataset with %s unique key rows and %s variables",+ label = label, |
| 1157 | +133 | ! |
- nrow(unique(`if`(length(key) > 0, df[, key, drop = FALSE], df))),+ server = srv_g_response, |
| 1158 | +134 | ! |
- ncol(df)- |
-
| 1159 | -- |
- )- |
- |
| 1160 | -- |
- })- |
- |
| 1161 | -- |
- }- |
- |
| 1162 | -- | - - | -|
| 1163 | -- |
- #' Renders the table for a single dataset in the left-hand side tabset panel+ ui = ui_g_response, |
|
| 1164 | -+ | ||
| 135 | +! |
- #'+ ui_args = args, |
|
| 1165 | -+ | ||
| 136 | +! |
- #' @description+ server_args = c( |
|
| 1166 | -+ | ||
| 137 | +! |
- #' The table contains column names, column labels,+ data_extract_list, |
|
| 1167 | -+ | ||
| 138 | +! |
- #' small summary about NA values and `sparkline` (if appropriate).+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args) |
|
| 1168 | +139 |
- #'+ ), |
|
| 1169 | -+ | ||
| 140 | +! |
- #' @param dataset_name (`character`) the name of the dataset+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
|
| 1170 | +141 |
- #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from+ ) |
|
| 1171 | +142 |
- #' @inheritParams render_tabset_panel_content+ } |
|
| 1172 | +143 |
- #' @keywords internal+ |
|
| 1173 | +144 |
- render_tab_table <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
+ ui_g_response <- function(id, ...) {
|
|
| 1174 | +145 | ! |
- table_ui_id <- paste0("variable_browser_", dataset_name)
- |
-
| 1175 | -- |
-
+ ns <- NS(id) |
|
| 1176 | +146 | ! |
- output[[table_ui_id]] <- DT::renderDataTable({
+ args <- list(...) |
| 1177 | +147 | ! |
- df <- data[[dataset_name]]()+ is_single_dataset_value <- teal.transform::is_single_dataset(args$response, args$x, args$row_facet, args$col_facet) |
| 1178 | +148 | ||
| 1179 | -! | -
- get_vars_df <- function(input, dataset_name, parent_name, data) {
- |
- |
| 1180 | -! | -
- data_cols <- colnames(data[[dataset_name]]())- |
- |
| 1181 | -! | -
- if (isTRUE(input$show_parent_vars)) {
- |
- |
| 1182 | +149 | ! |
- data_cols+ teal.widgets::standard_layout( |
| 1183 | +150 | ! |
- } else if (dataset_name != parent_name && parent_name %in% names(data)) {
+ output = teal.widgets::white_small_well( |
| 1184 | +151 | ! |
- setdiff(data_cols, colnames(data[[parent_name]]()))+ teal.widgets::plot_with_settings_ui(id = ns("myplot"))
|
| 1185 | +152 |
- } else {
+ ), |
|
| 1186 | +153 | ! |
- data_cols+ encoding = div( |
| 1187 | +154 |
- }+ ### Reporter |
|
| 1188 | -+ | ||
| 155 | +! |
- }+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 1189 | +156 |
-
+ ### |
|
| 1190 | +157 | ! |
- if (length(parent_dataname) > 0) {
+ tags$label("Encodings", class = "text-primary"),
|
| 1191 | +158 | ! |
- df_vars <- get_vars_df(input, dataset_name, parent_dataname, data)+ teal.transform::datanames_input(args[c("response", "x", "row_facet", "col_facet")]),
|
| 1192 | +159 | ! |
- df <- df[df_vars]- |
-
| 1193 | -- |
- }+ teal.transform::data_extract_ui( |
|
| 1194 | -+ | ||
| 160 | +! |
-
+ id = ns("response"),
|
|
| 1195 | +161 | ! |
- if (is.null(df) || ncol(df) == 0) {
+ label = "Response variable", |
| 1196 | +162 | ! |
- columns_names[[dataset_name]] <- character(0)+ data_extract_spec = args$response, |
| 1197 | +163 | ! |
- df_output <- data.frame(+ is_single_dataset = is_single_dataset_value |
| 1198 | -! | +||
| 164 | +
- Type = character(0),+ ), |
||
| 1199 | +165 | ! |
- Variable = character(0),+ teal.transform::data_extract_ui( |
| 1200 | +166 | ! |
- Label = character(0),+ id = ns("x"),
|
| 1201 | +167 | ! |
- Missings = character(0),+ label = "X variable", |
| 1202 | +168 | ! |
- Sparklines = character(0),+ data_extract_spec = args$x, |
| 1203 | +169 | ! |
- stringsAsFactors = FALSE+ is_single_dataset = is_single_dataset_value |
| 1204 | +170 |
- )+ ), |
|
| 1205 | -+ | ||
| 171 | +! |
- } else {
+ if (!is.null(args$row_facet)) {
|
|
| 1206 | -+ | ||
| 172 | +! |
- # extract data variable labels+ teal.transform::data_extract_ui( |
|
| 1207 | +173 | ! |
- labels <- teal.data::col_labels(df)+ id = ns("row_facet"),
|
| 1208 | -+ | ||
| 174 | +! |
-
+ label = "Row facetting", |
|
| 1209 | +175 | ! |
- columns_names[[dataset_name]] <- names(labels)+ data_extract_spec = args$row_facet,+ |
+
| 176 | +! | +
+ is_single_dataset = is_single_dataset_value |
|
| 1210 | +177 |
-
+ ) |
|
| 1211 | +178 |
- # calculate number of missing values+ }, |
|
| 1212 | +179 | ! |
- missings <- vapply(+ if (!is.null(args$col_facet)) {
|
| 1213 | +180 | ! |
- df,+ teal.transform::data_extract_ui( |
| 1214 | +181 | ! |
- var_missings_info,+ id = ns("col_facet"),
|
| 1215 | +182 | ! |
- FUN.VALUE = character(1),+ label = "Column facetting", |
| 1216 | +183 | ! |
- USE.NAMES = FALSE+ data_extract_spec = args$col_facet, |
| 1217 | -+ | ||
| 184 | +! |
- )+ is_single_dataset = is_single_dataset_value |
|
| 1218 | +185 |
-
+ ) |
|
| 1219 | +186 |
- # get icons proper for the data types+ }, |
|
| 1220 | +187 | ! |
- icons <- stats::setNames(teal.slice:::variable_types(df), colnames(df))- |
-
| 1221 | -- |
-
+ shinyWidgets::radioGroupButtons( |
|
| 1222 | +188 | ! |
- join_keys <- get_join_keys(data)+ inputId = ns("freq"),
|
| 1223 | +189 | ! |
- if (!is.null(join_keys)) {
+ label = NULL, |
| 1224 | +190 | ! |
- icons[intersect(join_keys$get(dataset_name)[[dataset_name]], colnames(df))] <- "primary_key"- |
-
| 1225 | -- |
- }+ choices = c("frequency", "density"),
|
|
| 1226 | +191 | ! |
- icons <- variable_type_icons(icons)+ selected = ifelse(args$freq, "frequency", "density"), |
| 1227 | -+ | ||
| 192 | +! |
-
+ justified = TRUE |
|
| 1228 | +193 |
- # generate sparklines+ ), |
|
| 1229 | +194 | ! |
- sparklines_html <- vapply(+ teal.widgets::panel_group( |
| 1230 | +195 | ! |
- df,+ teal.widgets::panel_item( |
| 1231 | +196 | ! |
- create_sparklines,+ title = "Plot settings", |
| 1232 | +197 | ! |
- FUN.VALUE = character(1),+ checkboxInput(ns("count_labels"), "Add count labels", value = args$count_labels),
|
| 1233 | +198 | ! |
- USE.NAMES = FALSE- |
-
| 1234 | -- |
- )- |
- |
| 1235 | -- |
-
+ checkboxInput(ns("coord_flip"), "Swap axes", value = args$coord_flip),
|
|
| 1236 | +199 | ! |
- df_output <- data.frame(+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
|
| 1237 | +200 | ! |
- Type = icons,+ selectInput( |
| 1238 | +201 | ! |
- Variable = names(labels),+ inputId = ns("ggtheme"),
|
| 1239 | +202 | ! |
- Label = labels,+ label = "Theme (by ggplot):", |
| 1240 | +203 | ! |
- Missings = missings,+ choices = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
|
| 1241 | +204 | ! |
- Sparklines = sparklines_html,+ selected = args$ggtheme, |
| 1242 | +205 | ! |
- stringsAsFactors = FALSE+ multiple = FALSE |
| 1243 | +206 |
- )+ ) |
|
| 1244 | +207 |
- }+ ) |
|
| 1245 | +208 |
-
+ ) |
|
| 1246 | +209 |
- # Select row 1 as default / fallback+ ), |
|
| 1247 | +210 | ! |
- selected_ix <- 1- |
-
| 1248 | -- |
- # Define starting page index (base-0 index of the first item on page+ forms = tagList( |
|
| 1249 | -+ | ||
| 211 | +! |
- # note: in many cases it's not the item itself+ teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"),
|
|
| 1250 | +212 | ! |
- selected_page_ix <- 0+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
| 1251 | +213 |
-
+ ), |
|
| 1252 | -+ | ||
| 214 | +! |
- # Retrieve current selected variable if any+ pre_output = args$pre_output, |
|
| 1253 | +215 | ! |
- isolated_variable <- shiny::isolate(plot_var$variable[[dataset_name]])+ post_output = args$post_output |
| 1254 | +216 |
-
+ ) |
|
| 1255 | -! | +||
| 217 | +
- if (!is.null(isolated_variable)) {
+ } |
||
| 1256 | -! | +||
| 218 | +
- index <- which(columns_names[[dataset_name]] == isolated_variable)[1]+ |
||
| 1257 | -! | +||
| 219 | +
- if (!is.null(index) && !is.na(index) && length(index) > 0) selected_ix <- index+ srv_g_response <- function(id, |
||
| 1258 | +220 |
- }+ data, |
|
| 1259 | +221 |
-
+ reporter, |
|
| 1260 | +222 |
- # Retrieve the index of the first item of the current page+ filter_panel_api, |
|
| 1261 | +223 |
- # it works with varying number of entries on the page (10, 25, ...)+ response, |
|
| 1262 | -! | +||
| 224 | +
- table_id_sel <- paste0("variable_browser_", dataset_name, "_state")
+ x, |
||
| 1263 | -! | +||
| 225 | +
- dt_state <- shiny::isolate(input[[table_id_sel]])+ row_facet, |
||
| 1264 | -! | +||
| 226 | +
- if (selected_ix != 1 && !is.null(dt_state)) {
+ col_facet, |
||
| 1265 | -! | +||
| 227 | +
- selected_page_ix <- floor(selected_ix / dt_state$length) * dt_state$length+ plot_height, |
||
| 1266 | +228 |
- }+ plot_width, |
|
| 1267 | +229 |
-
+ ggplot2_args) {
|
|
| 1268 | +230 | ! |
- DT::datatable(+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 1269 | +231 | ! |
- df_output,+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 1270 | +232 | ! |
- escape = FALSE,+ checkmate::assert_class(data, "tdata") |
| 1271 | +233 | ! |
- rownames = FALSE,+ moduleServer(id, function(input, output, session) {
|
| 1272 | +234 | ! |
- selection = list(mode = "single", target = "row", selected = selected_ix),+ data_extract <- list(response = response, x = x, row_facet = row_facet, col_facet = col_facet) |
| 1273 | -! | +||
| 235 | +
- options = list(+ |
||
| 1274 | +236 | ! |
- fnDrawCallback = htmlwidgets::JS("function() { HTMLWidgets.staticRender(); }"),
+ rule_diff <- function(other) {
|
| 1275 | +237 | ! |
- pageLength = input[[paste0(table_ui_id, "_rows")]],+ function(value) {
|
| 1276 | +238 | ! |
- displayStart = selected_page_ix+ othervalue <- selector_list()[[other]]()[["select"]] |
| 1277 | -+ | ||
| 239 | +! |
- )+ if (!is.null(othervalue)) {
|
|
| 1278 | -+ | ||
| 240 | +! |
- )+ if (identical(value, othervalue)) {
|
|
| 1279 | -+ | ||
| 241 | +! |
- })+ "Row and column facetting variables must be different." |
|
| 1280 | +242 |
- }+ } |
|
| 1281 | +243 |
-
+ } |
|
| 1282 | +244 |
- #' Creates observers updating the currently selected column+ } |
|
| 1283 | +245 |
- #'+ } |
|
| 1284 | +246 |
- #' @description+ |
|
| 1285 | -+ | ||
| 247 | +! |
- #' The created observers update the column currently selected in the left-hand side+ selector_list <- teal.transform::data_extract_multiple_srv( |
|
| 1286 | -+ | ||
| 248 | +! |
- #' tabset panel.+ data_extract = data_extract, |
|
| 1287 | -+ | ||
| 249 | +! |
- #'+ datasets = data, |
|
| 1288 | -+ | ||
| 250 | +! |
- #' @note+ select_validation_rule = list( |
|
| 1289 | -+ | ||
| 251 | +! |
- #' Creates an observer for each dataset (each tab in the tabset panel).+ response = shinyvalidate::sv_required("Please define a column for the response variable"),
|
|
| 1290 | -+ | ||
| 252 | +! |
- #'+ x = shinyvalidate::sv_required("Please define a column for X variable"),
|
|
| 1291 | -+ | ||
| 253 | +! |
- #' @inheritParams render_tabset_panel_content+ row_facet = shinyvalidate::compose_rules( |
|
| 1292 | -+ | ||
| 254 | +! |
- #' @keywords internal+ shinyvalidate::sv_optional(), |
|
| 1293 | -+ | ||
| 255 | +! |
- establish_updating_selection <- function(datanames, input, plot_var, columns_names) {
+ ~ if (length(.) > 1) "There must be 1 or no row facetting variable.", |
|
| 1294 | +256 | ! |
- lapply(datanames, function(dataset_name) {
+ rule_diff("col_facet")
|
| 1295 | -! | +||
| 257 | +
- table_ui_id <- paste0("variable_browser_", dataset_name)
+ ), |
||
| 1296 | +258 | ! |
- table_id_sel <- paste0(table_ui_id, "_rows_selected")+ col_facet = shinyvalidate::compose_rules( |
| 1297 | +259 | ! |
- observeEvent(input[[table_id_sel]], {
+ shinyvalidate::sv_optional(), |
| 1298 | +260 | ! |
- plot_var$data <- dataset_name+ ~ if (length(.) > 1) "There must be 1 or no column facetting variable.", |
| 1299 | +261 | ! |
- plot_var$variable[[dataset_name]] <- columns_names[[dataset_name]][input[[table_id_sel]]]+ rule_diff("row_facet")
|
| 1300 | +262 |
- })+ ) |
|
| 1301 | +263 |
- })+ ) |
|
| 1302 | +264 |
- }+ ) |
|
| 1303 | +265 | ||
| 1304 | -- |
- get_bin_width <- function(x_vec, scaling_factor = 2) {
- |
- |
| 1305 | +266 | ! |
- x_vec <- x_vec[!is.na(x_vec)]+ iv_r <- reactive({
|
| 1306 | +267 | ! |
- qntls <- stats::quantile(x_vec, probs = c(0.1, 0.25, 0.75, 0.9), type = 2)+ iv <- shinyvalidate::InputValidator$new() |
| 1307 | +268 | ! |
- iqr <- qntls[3] - qntls[2]+ iv$add_rule("ggtheme", shinyvalidate::sv_required("Please select a theme"))
|
| 1308 | +269 | ! |
- binwidth <- max(scaling_factor * iqr / length(x_vec) ^ (1 / 3), sqrt(qntls[4] - qntls[1])) # styler: off+ teal.transform::compose_and_enable_validators(iv, selector_list) |
| 1309 | -! | +||
| 270 | +
- binwidth <- ifelse(binwidth == 0, 1, binwidth)+ }) |
||
| 1310 | +271 |
- # to ensure at least two bins when variable span is very small+ |
|
| 1311 | +272 | ! |
- x_span <- diff(range(x_vec))+ anl_merged_input <- teal.transform::merge_expression_srv( |
| 1312 | +273 | ! |
- if (isTRUE(x_span / binwidth >= 2)) binwidth else x_span / 2+ selector_list = selector_list, |
| 1313 | -+ | ||
| 274 | +! |
- }+ datasets = data,+ |
+ |
| 275 | +! | +
+ join_keys = get_join_keys(data) |
|
| 1314 | +276 |
-
+ ) |
|
| 1315 | +277 |
- custom_sparkline_formatter <- function(labels, counts) {
+
|
|
| 1316 | +278 | ! |
- htmlwidgets::JS(+ anl_merged_q <- reactive({
|
| 1317 | +279 | ! |
- sprintf(+ req(anl_merged_input()) |
| 1318 | +280 | ! |
- "function(sparkline, options, field) {
+ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% |
| 1319 | +281 | ! |
- return 'ID: ' + %s[field[0].offset] + '<br>' + 'Count: ' + %s[field[0].offset];+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
| 1320 | +282 | ++ |
+ })+ |
+
| 283 |
- }",+ + |
+ ||
| 284 | +! | +
+ merged <- list( |
|
| 1321 | +285 | ! |
- jsonlite::toJSON(labels),+ anl_input_r = anl_merged_input, |
| 1322 | +286 | ! |
- jsonlite::toJSON(counts)+ anl_q_r = anl_merged_q |
| 1323 | +287 |
) |
|
| 1324 | +288 |
- )+ |
|
| 1325 | -+ | ||
| 289 | +! |
- }+ output_q <- reactive({
|
|
| 1326 | -+ | ||
| 290 | +! |
-
+ teal::validate_inputs(iv_r()) |
|
| 1327 | +291 |
- #' Removes the outlier observation from an array+ |
|
| 1328 | -+ | ||
| 292 | +! |
- #'+ qenv <- merged$anl_q_r() |
|
| 1329 | -+ | ||
| 293 | +! |
- #' @param var (`numeric`) a numeric vector+ ANL <- qenv[["ANL"]] # nolint |
|
| 1330 | -+ | ||
| 294 | +! |
- #' @param outlier_definition (`numeric`) if `0` then no outliers are removed, otherwise+ resp_var <- as.vector(merged$anl_input_r()$columns_source$response) |
|
| 1331 | -+ | ||
| 295 | +! |
- #' outliers (those more than `outlier_definition*IQR below/above Q1/Q3`) are removed+ x <- as.vector(merged$anl_input_r()$columns_source$x) |
|
| 1332 | +296 |
- #' @returns (`numeric`) vector without the outlier values+ |
|
| 1333 | -+ | ||
| 297 | +! |
- #' @keywords internal+ validate(need(is.factor(ANL[[resp_var]]), "Please select a factor variable as the response.")) |
|
| 1334 | -+ | ||
| 298 | +! |
- remove_outliers_from <- function(var, outlier_definition) {
+ validate(need(is.factor(ANL[[x]]), "Please select a factor variable as the X-Variable.")) |
|
| 1335 | -3x | +||
| 299 | +! |
- if (outlier_definition == 0) {
+ teal::validate_has_data(ANL, 10) |
|
| 1336 | -1x | +||
| 300 | +! |
- return(var)+ teal::validate_has_data(ANL[, c(resp_var, x)], 10, complete = TRUE, allow_inf = FALSE) |
|
| 1337 | +301 |
- }+ |
|
| 1338 | -2x | +||
| 302 | +! |
- q1_q3 <- stats::quantile(var, probs = c(0.25, 0.75), type = 2, na.rm = TRUE)+ row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
|
|
| 1339 | -2x | +||
| 303 | +! |
- iqr <- q1_q3[2] - q1_q3[1]+ character(0) |
|
| 1340 | -2x | +||
| 304 | +
- var[var >= q1_q3[1] - outlier_definition * iqr & var <= q1_q3[2] + outlier_definition * iqr]+ } else {
|
||
| 1341 | -+ | ||
| 305 | +! |
- }+ as.vector(merged$anl_input_r()$columns_source$row_facet) |
| 1 | +306 |
- #' Front page module+ } |
|
| 2 | -+ | ||
| 307 | +! |
- #'+ col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
|
|
| 3 | -+ | ||
| 308 | +! |
- #' @description This `teal` module creates a simple front page for `teal` applications+ character(0) |
|
| 4 | +309 |
- #'+ } else {
|
|
| 5 | -+ | ||
| 310 | +! |
- #' @inheritParams teal::module+ as.vector(merged$anl_input_r()$columns_source$col_facet) |
|
| 6 | +311 |
- #' @param header_text `character vector` text to be shown at the top of the module, for each+ } |
|
| 7 | +312 |
- #' element, if named the name is shown first in bold as a header followed by the value. The first+ |
|
| 8 | -+ | ||
| 313 | +! |
- #' element's header is displayed larger than the others+ freq <- input$freq == "frequency" |
|
| 9 | -+ | ||
| 314 | +! |
- #' @param tables `named list of dataframes` tables to be shown in the module+ swap_axes <- input$coord_flip |
|
| 10 | -+ | ||
| 315 | +! |
- #' @param additional_tags `shiny.tag.list` or `html` additional shiny tags or `html` to be included after the table,+ counts <- input$count_labels |
|
| 11 | -+ | ||
| 316 | +! |
- #' for example to include an image, `tagList(tags$img(src = "image.png"))` or to include further `html`,+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
|
| 12 | -+ | ||
| 317 | +! |
- #' `HTML("html text here")`
+ ggtheme <- input$ggtheme |
|
| 13 | +318 |
- #' @param footnotes `character vector` text to be shown at the bottom of the module, for each+ |
|
| 14 | -+ | ||
| 319 | +! |
- #' element, if named the name is shown first in bold, followed by the value+ arg_position <- if (freq) "stack" else "fill" # nolint |
|
| 15 | +320 |
- #' @param show_metadata `logical` should the metadata of the datasets be available on the module?+ |
|
| 16 | -+ | ||
| 321 | +! |
- #' @return A `teal` module to be used in `teal` applications+ rowf <- if (length(row_facet_name) == 0) NULL else as.name(row_facet_name) # nolint |
|
| 17 | -+ | ||
| 322 | +! |
- #' @export+ colf <- if (length(col_facet_name) == 0) NULL else as.name(col_facet_name) # nolint |
|
| 18 | -+ | ||
| 323 | +! |
- #' @examples+ resp_cl <- as.name(resp_var) # nolint |
|
| 19 | -+ | ||
| 324 | +! |
- #'+ x_cl <- as.name(x) # nolint |
|
| 20 | +325 |
- #' table_1 <- data.frame(Info = c("A", "B"), Text = c("A", "B"))
+
|
|
| 21 | -+ | ||
| 326 | +! |
- #' table_2 <- data.frame(`Column 1` = c("C", "D"), `Column 2` = c(5.5, 6.6), `Column 3` = c("A", "B"))
+ if (swap_axes) {
|
|
| 22 | -+ | ||
| 327 | +! |
- #' table_3 <- data.frame(Info = c("E", "F"), Text = c("G", "H"))
+ qenv <- teal.code::eval_code( |
|
| 23 | -+ | ||
| 328 | +! |
- #'+ qenv, |
|
| 24 | -+ | ||
| 329 | +! |
- #' table_input <- list(+ substitute( |
|
| 25 | -+ | ||
| 330 | +! |
- #' "Table 1" = table_1,+ expr = ANL[[x]] <- with(ANL, forcats::fct_rev(x_cl)), # nolint |
|
| 26 | -+ | ||
| 331 | +! |
- #' "Table 2" = table_2,+ env = list(x = x, x_cl = x_cl) |
|
| 27 | +332 |
- #' "Table 3" = table_3+ ) |
|
| 28 | +333 |
- #' )+ ) |
|
| 29 | +334 |
- #'+ } |
|
| 30 | +335 |
- #' ADSL <- teal.modules.general::rADSL+ |
|
| 31 | -+ | ||
| 336 | +! |
- #' app <- teal::init(+ qenv <- teal.code::eval_code( |
|
| 32 | -+ | ||
| 337 | +! |
- #' data = teal.data::cdisc_data(+ qenv, |
|
| 33 | -+ | ||
| 338 | +! |
- #' teal.data::cdisc_dataset("ADSL", ADSL,
+ substitute( |
|
| 34 | -+ | ||
| 339 | +! |
- #' code = "ADSL <- teal.modules.general::rADSL",+ expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]), # nolint |
|
| 35 | -+ | ||
| 340 | +! |
- #' metadata = list("Author" = "NEST team", "data_source" = "synthetic data")
+ env = list(resp_var = resp_var) |
|
| 36 | +341 |
- #' ),+ ) |
|
| 37 | +342 |
- #' check = TRUE+ ) %>% |
|
| 38 | +343 |
- #' ),+ # nolint start |
|
| 39 | +344 |
- #' modules = teal::modules(+ # rowf and colf will be a NULL if not set by a user |
|
| 40 | -+ | ||
| 345 | +! |
- #' teal.modules.general::tm_front_page(+ teal.code::eval_code( |
|
| 41 | -+ | ||
| 346 | +! |
- #' header_text = c(+ substitute( |
|
| 42 | -+ | ||
| 347 | +! |
- #' "Important information" = "It can go here.",+ expr = ANL2 <- ANL %>% |
|
| 43 | -+ | ||
| 348 | +! |
- #' "Other information" = "Can go here."+ dplyr::group_by_at(dplyr::vars(x_cl, resp_cl, rowf, colf)) %>% |
|
| 44 | -+ | ||
| 349 | +! |
- #' ),+ dplyr::summarise(ns = dplyr::n()) %>% |
|
| 45 | -+ | ||
| 350 | +! |
- #' tables = table_input,+ dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>% |
|
| 46 | -+ | ||
| 351 | +! |
- #' additional_tags = HTML("Additional HTML or shiny tags go here <br>"),
+ dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)), |
|
| 47 | -+ | ||
| 352 | +! |
- #' footnotes = c("X" = "is the first footnote", "Y is the second footnote"),
+ env = list(x_cl = x_cl, resp_cl = resp_cl, rowf = rowf, colf = colf) |
|
| 48 | +353 |
- #' show_metadata = TRUE+ ) |
|
| 49 | +354 |
- #' )+ ) %>% |
|
| 50 | -+ | ||
| 355 | +! |
- #' ),+ teal.code::eval_code( |
|
| 51 | -+ | ||
| 356 | +! |
- #' header = tags$h1("Sample Application"),
+ substitute( |
|
| 52 | -+ | ||
| 357 | +! |
- #' footer = tags$p("Application footer"),
+ expr = ANL3 <- ANL %>% |
|
| 53 | -+ | ||
| 358 | +! |
- #' )+ dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>% |
|
| 54 | -+ | ||
| 359 | +! |
- #' if (interactive()) {
+ dplyr::summarise(ns = dplyr::n()), |
|
| 55 | -+ | ||
| 360 | +! |
- #' shinyApp(app$ui, app$server)+ env = list(x_cl = x_cl, rowf = rowf, colf = colf) |
|
| 56 | +361 |
- #' }+ ) |
|
| 57 | +362 |
- tm_front_page <- function(label = "Front page",+ ) |
|
| 58 | +363 |
- header_text = character(0),+ # nolint end |
|
| 59 | +364 |
- tables = list(),+ |
|
| 60 | -+ | ||
| 365 | +! |
- additional_tags = tagList(),+ plot_call <- substitute( |
|
| 61 | -+ | ||
| 366 | +! |
- footnotes = character(0),+ expr = |
|
| 62 | -+ | ||
| 367 | +! |
- show_metadata = FALSE) {
+ ggplot(ANL2, aes(x = x_cl, y = ns)) + |
|
| 63 | +368 | ! |
- checkmate::assert_string(label)+ geom_bar(aes(fill = resp_cl), stat = "identity", position = arg_position), |
| 64 | +369 | ! |
- checkmate::assert_character(header_text, min.len = 0, any.missing = FALSE)+ env = list( |
| 65 | +370 | ! |
- checkmate::assert_list(tables, types = "data.frame", names = "named", any.missing = FALSE)+ x_cl = x_cl, |
| 66 | +371 | ! |
- checkmate::assert_multi_class(additional_tags, classes = c("shiny.tag.list", "html"))
+ resp_cl = resp_cl, |
| 67 | +372 | ! |
- checkmate::assert_character(footnotes, min.len = 0, any.missing = FALSE)+ arg_position = arg_position+ |
+
| 373 | ++ |
+ )+ |
+ |
| 374 | ++ |
+ )+ |
+ |
| 375 | ++ | + | |
| 68 | +376 | ! |
- checkmate::assert_flag(show_metadata)+ if (!freq) plot_call <- substitute(plot_call + expand_limits(y = c(0, 1.1)), env = list(plot_call = plot_call)) |
| 69 | +377 | ||
| 70 | +378 | ! |
- logger::log_info("Initializing tm_front_page")
+ if (counts) {
|
| 71 | +379 | ! |
- args <- as.list(environment())+ plot_call <- substitute( |
| 72 | -+ | ||
| 380 | +! |
-
+ expr = plot_call + |
|
| 73 | +381 | ! |
- module(+ geom_text( |
| 74 | +382 | ! |
- label = label,+ data = ANL2, |
| 75 | +383 | ! |
- server = srv_front_page,+ aes(label = ns, x = x_cl, y = ns, group = resp_cl), |
| 76 | +384 | ! |
- ui = ui_front_page,+ col = "white", |
| 77 | +385 | ! |
- ui_args = args,+ vjust = "middle", |
| 78 | +386 | ! |
- server_args = list(tables = tables, show_metadata = show_metadata),+ hjust = "middle", |
| 79 | +387 | ! |
- datanames = if (show_metadata) "all" else NULL+ position = position_anl2_value |
| 80 | +388 |
- )+ ) + |
|
| 81 | -+ | ||
| 389 | +! |
- }+ geom_text( |
|
| 82 | -+ | ||
| 390 | +! |
-
+ data = ANL3, aes(label = ns, x = x_cl, y = anl3_y), |
|
| 83 | -+ | ||
| 391 | +! |
- ui_front_page <- function(id, ...) {
+ hjust = hjust_value, |
|
| 84 | +392 | ! |
- args <- list(...)+ vjust = vjust_value, |
| 85 | +393 | ! |
- ns <- NS(id)+ position = position_anl3_value |
| 86 | +394 |
-
+ ), |
|
| 87 | +395 | ! |
- tagList(+ env = list( |
| 88 | +396 | ! |
- include_css_files("custom"),
+ plot_call = plot_call, |
| 89 | +397 | ! |
- tags$div(+ x_cl = x_cl, |
| 90 | +398 | ! |
- id = "front_page_content",+ resp_cl = resp_cl, |
| 91 | +399 | ! |
- class = "ml-8",+ hjust_value = if (swap_axes) "left" else "middle", |
| 92 | +400 | ! |
- tags$div(+ vjust_value = if (swap_axes) "middle" else -1, |
| 93 | +401 | ! |
- id = "front_page_headers",+ position_anl2_value = if (!freq) quote(position_fill(0.5)) else quote(position_stack(0.5)), |
| 94 | +402 | ! |
- get_header_tags(args$header_text)+ anl3_y = if (!freq) 1.1 else as.name("ns"),
+ |
+
| 403 | +! | +
+ position_anl3_value = if (!freq) "fill" else "stack" |
|
| 95 | +404 |
- ),+ ) |
|
| 96 | -! | +||
| 405 | +
- tags$div(+ ) |
||
| 97 | -! | +||
| 406 | +
- id = "front_page_tables",+ }+ |
+ ||
| 407 | ++ | + | |
| 98 | +408 | ! |
- class = "ml-4",+ if (swap_axes) {
|
| 99 | +409 | ! |
- get_table_tags(args$tables, ns)+ plot_call <- substitute(plot_call + coord_flip(), env = list(plot_call = plot_call)) |
| 100 | +410 |
- ),+ } |
|
| 101 | -! | +||
| 411 | +
- tags$div(+ |
||
| 102 | +412 | ! |
- id = "front_page_custom_html",+ facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name)+ |
+
| 413 | ++ | + | |
| 103 | +414 | ! |
- class = "my-4",+ if (!is.null(facet_cl)) {
|
| 104 | +415 | ! |
- args$additional_tags+ plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl)) |
| 105 | +416 |
- ),+ }+ |
+ |
| 417 | ++ | + | |
| 106 | +418 | ! |
- if (args$show_metadata) {
+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 107 | +419 | ! |
- tags$div(+ labs = list( |
| 108 | +420 | ! |
- id = "front_page_metabutton",+ x = varname_w_label(x, ANL), |
| 109 | +421 | ! |
- class = "m-4",+ y = varname_w_label(resp_var, ANL, prefix = "Proportion of "), |
| 110 | +422 | ! |
- actionButton(ns("metadata_button"), "Show metadata")
+ fill = varname_w_label(resp_var, ANL) |
| 111 | +423 |
- )+ ),+ |
+ |
| 424 | +! | +
+ theme = list(legend.position = "bottom") |
|
| 112 | +425 |
- },+ ) |
|
| 113 | -! | +||
| 426 | +
- tags$footer(+ |
||
| 114 | +427 | ! |
- class = ".small",+ if (rotate_xaxis_labels) {
|
| 115 | +428 | ! |
- get_footer_tags(args$footnotes)+ dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1)) # nolint |
| 116 | +429 |
- )+ } |
|
| 117 | +430 |
- )+ |
|
| 118 | -+ | ||
| 431 | +! |
- )+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ |
+ |
| 432 | +! | +
+ user_plot = ggplot2_args,+ |
+ |
| 433 | +! | +
+ module_plot = dev_ggplot2_args |
|
| 119 | +434 |
- }+ ) |
|
| 120 | +435 | ||
| 121 | -+ | ||
| 436 | +! |
- get_header_tags <- function(header_text) {
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
|
| 122 | +437 | ! |
- if (length(header_text) == 0) {
+ all_ggplot2_args, |
| 123 | +438 | ! |
- return(list())+ ggtheme = ggtheme |
| 124 | +439 |
- }+ ) |
|
| 125 | +440 | ||
| 126 | +441 | ! |
- get_single_header_tags <- function(header_text, p_text, header_tag = tags$h4) {
+ plot_call <- substitute(expr = {
|
| 127 | +442 | ! |
- tagList(+ p <- plot_call + labs + ggthemes + themes |
| 128 | +443 | ! |
- tags$div(+ print(p) |
| 129 | +444 | ! |
- if (!is.null(header_text) && nchar(header_text) > 0) header_tag(header_text),+ }, env = list( |
| 130 | +445 | ! |
- tags$p(p_text)+ plot_call = plot_call,+ |
+
| 446 | +! | +
+ labs = parsed_ggplot2_args$labs,+ |
+ |
| 447 | +! | +
+ themes = parsed_ggplot2_args$theme,+ |
+ |
| 448 | +! | +
+ ggthemes = parsed_ggplot2_args$ggtheme |
|
| 131 | +449 |
- )+ )) |
|
| 132 | +450 |
- )+ + |
+ |
| 451 | +! | +
+ teal.code::eval_code(qenv, plot_call) |
|
| 133 | +452 |
- }+ }) |
|
| 134 | +453 | ||
| 135 | +454 | ! |
- header_tags <- get_single_header_tags(names(header_text[1]), header_text[1], header_tag = tags$h3)+ plot_r <- reactive(output_q()[["p"]]) |
| 136 | -! | +||
| 455 | +
- c(header_tags, mapply(get_single_header_tags, utils::tail(names(header_text), -1), utils::tail(header_text, -1)))+ |
||
| 137 | +456 |
- }+ # Insert the plot into a plot_with_settings module from teal.widgets+ |
+ |
| 457 | +! | +
+ pws <- teal.widgets::plot_with_settings_srv(+ |
+ |
| 458 | +! | +
+ id = "myplot",+ |
+ |
| 459 | +! | +
+ plot_r = plot_r,+ |
+ |
| 460 | +! | +
+ height = plot_height,+ |
+ |
| 461 | +! | +
+ width = plot_width |
|
| 138 | +462 |
-
+ ) |
|
| 139 | +463 |
- get_table_tags <- function(tables, ns) {
+
|
|
| 140 | +464 | ! |
- if (length(tables) == 0) {
+ teal.widgets::verbatim_popup_srv( |
| 141 | +465 | ! |
- return(list())- |
-
| 142 | -- |
- }+ id = "warning", |
|
| 143 | +466 | ! |
- table_tags <- c(lapply(seq_along(tables), function(idx) {
+ verbatim_content = reactive(teal.code::get_warnings(output_q())), |
| 144 | +467 | ! |
- list(+ title = "Warning", |
| 145 | +468 | ! |
- tableOutput(ns(paste0("table_", idx)))
+ disabled = reactive(is.null(teal.code::get_warnings(output_q()))) |
| 146 | +469 |
) |
|
| 147 | +470 |
- }))+ |
|
| 148 | +471 | ! |
- return(table_tags)+ teal.widgets::verbatim_popup_srv( |
| 149 | -+ | ||
| 472 | +! |
- }+ id = "rcode", |
|
| 150 | -+ | ||
| 473 | +! |
-
+ verbatim_content = reactive(teal.code::get_code(output_q())), |
|
| 151 | -+ | ||
| 474 | +! |
- get_footer_tags <- function(footnotes) {
+ title = "Show R Code for Response" |
|
| 152 | -! | +||
| 475 | +
- if (length(footnotes) == 0) {
+ ) |
||
| 153 | -! | +||
| 476 | +
- return(list())+ |
||
| 154 | +477 |
- }+ ### REPORTER |
|
| 155 | +478 | ! |
- bold_texts <- if (is.null(names(footnotes))) rep("", length(footnotes)) else names(footnotes)
+ if (with_reporter) {
|
| 156 | +479 | ! |
- footnote_tags <- mapply(function(bold_text, value) {
+ card_fun <- function(comment, label) {
|
| 157 | +480 | ! |
- list(+ card <- teal::report_card_template( |
| 158 | +481 | ! |
- tags$div(+ title = "Response Plot", |
| 159 | +482 | ! |
- tags$b(bold_text),+ label = label, |
| 160 | +483 | ! |
- value,+ with_filter = with_filter, |
| 161 | +484 | ! |
- tags$br()+ filter_panel_api = filter_panel_api |
| 162 | +485 |
- )+ ) |
|
| 163 | -+ | ||
| 486 | +! |
- )+ card$append_text("Plot", "header3")
|
|
| 164 | +487 | ! |
- }, bold_text = bold_texts, value = footnotes)+ card$append_plot(plot_r(), dim = pws$dim()) |
| 165 | -+ | ||
| 488 | +! |
- }+ if (!comment == "") {
|
|
| 166 | -+ | ||
| 489 | +! |
-
+ card$append_text("Comment", "header3")
+ |
+ |
| 490 | +! | +
+ card$append_text(comment) |
|
| 167 | +491 |
- srv_front_page <- function(id, data, tables, show_metadata) {
+ } |
|
| 168 | +492 | ! |
- checkmate::assert_class(data, "tdata")+ card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n")) |
| 169 | +493 | ! |
- moduleServer(id, function(input, output, session) {
+ card+ |
+
| 494 | ++ |
+ } |
|
| 170 | +495 | ! |
- ns <- session$ns+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 171 | +496 |
-
+ } |
|
| 172 | -! | +||
| 497 | +
- lapply(seq_along(tables), function(idx) {
+ ### |
||
| 173 | -! | +||
| 498 | +
- output[[paste0("table_", idx)]] <- renderTable(
+ }) |
||
| 174 | -! | +||
| 499 | +
- tables[[idx]],+ } |
||
| 175 | -! | +
| 1 | +
- bordered = TRUE,+ #' Stack Plots of variables and show association with reference variable |
||
| 176 | -! | +||
| 2 | +
- caption = names(tables)[idx],+ #' @md |
||
| 177 | -! | +||
| 3 | +
- caption.placement = "top"+ #' |
||
| 178 | +4 |
- )+ #' @inheritParams teal::module |
|
| 179 | +5 |
- })+ #' @inheritParams shared_params |
|
| 180 | +6 |
-
+ #' @param ref (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 181 | -! | +||
| 7 | +
- if (show_metadata) {
+ #' reference variable, must set `multiple = FALSE`. |
||
| 182 | -! | +||
| 8 | +
- observeEvent(+ #' @param vars (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 183 | -! | +||
| 9 | +
- input$metadata_button, showModal(+ #' associated variables. |
||
| 184 | -! | +||
| 10 | +
- modalDialog(+ #' @param show_association optional, (`logical`) Whether show association of `vars` |
||
| 185 | -! | +||
| 11 | +
- title = "Metadata",+ #' with reference variable. Defaults to `TRUE`. |
||
| 186 | -! | +||
| 12 | +
- dataTableOutput(ns("metadata_table")),
+ #' @param distribution_theme optional, (`character`) `ggplot2` theme to be used by default. |
||
| 187 | -! | +||
| 13 | +
- size = "l",+ #' One of `c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test")`.
|
||
| 188 | -! | +||
| 14 | +
- easyClose = TRUE+ #' Each theme can be chosen by the user during the session. Defaults to `"gray"`. |
||
| 189 | +15 |
- )+ #' @param association_theme optional, (`character`) `ggplot2` theme to be used by default. |
|
| 190 | +16 |
- )+ #' One of `c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test")`.
|
|
| 191 | +17 |
- )+ #' Each theme can be chosen by the user during the session. Defaults to `"gray"`. |
|
| 192 | +18 |
-
+ #' |
|
| 193 | -! | +||
| 19 | +
- metadata_data_frame <- reactive({
+ #' @templateVar ggnames "Bivariate1", "Bivariate2" |
||
| 194 | -! | +||
| 20 | +
- convert_metadata_to_dataframe(+ #' @template ggplot2_args_multi |
||
| 195 | -! | +||
| 21 | +
- lapply(names(data), function(dataname) get_metadata(data, dataname)),+ #' |
||
| 196 | -! | +||
| 22 | +
- names(data)+ #' @note For more examples, please see the vignette "Using association plot" via |
||
| 197 | +23 |
- )+ #' \code{vignette("using-association-plot", package = "teal.modules.general")}.
|
|
| 198 | +24 |
- })+ #' @export |
|
| 199 | +25 |
-
+ #' @examples |
|
| 200 | -! | +||
| 26 | +
- output$metadata_table <- renderDataTable({
+ #' # Association plot of selected reference variable (SEX) |
||
| 201 | -! | +||
| 27 | +
- validate(need(nrow(metadata_data_frame()) > 0, "The data has no associated metadata"))+ #' # against other selected variables (BMRKR1) |
||
| 202 | -! | +||
| 28 | +
- metadata_data_frame()+ #' library(nestcolor) |
||
| 203 | +29 |
- })+ #' ADSL <- teal.modules.general::rADSL |
|
| 204 | +30 |
- }+ #' |
|
| 205 | +31 |
- })+ #' app <- teal::init( |
|
| 206 | +32 |
- }+ #' data = teal.data::cdisc_data( |
|
| 207 | +33 |
-
+ #' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
|
|
| 208 | +34 |
- # take a list of metadata, one item per dataset (raw_metadata each element from datasets$get_metadata())+ #' check = TRUE |
|
| 209 | +35 |
- # and the corresponding datanames and output a data.frame with columns {Dataset, Name, Value}.
+ #' ), |
|
| 210 | +36 |
- # which are, the Dataset the metadata came from, the metadata's name and value+ #' modules = teal::modules( |
|
| 211 | +37 |
- convert_metadata_to_dataframe <- function(raw_metadata, datanames) {
+ #' teal.modules.general::tm_g_association( |
|
| 212 | -4x | +||
| 38 | +
- output <- mapply(function(metadata, dataname) {
+ #' ref = teal.transform::data_extract_spec( |
||
| 213 | -6x | +||
| 39 | +
- if (is.null(metadata)) {
+ #' dataname = "ADSL", |
||
| 214 | -2x | +||
| 40 | +
- return(data.frame(Dataset = character(0), Name = character(0), Value = character(0)))+ #' select = teal.transform::select_spec( |
||
| 215 | +41 |
- }+ #' label = "Select variable:", |
|
| 216 | -4x | +||
| 42 | +
- return(data.frame(+ #' choices = teal.transform::variable_choices( |
||
| 217 | -4x | +||
| 43 | +
- Dataset = dataname,+ #' ADSL, |
||
| 218 | -4x | +||
| 44 | +
- Name = names(metadata),+ #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
|
||
| 219 | -4x | +||
| 45 | +
- Value = unname(unlist(lapply(metadata, as.character)))+ #' ), |
||
| 220 | +46 |
- ))+ #' selected = "RACE", |
|
| 221 | -4x | +||
| 47 | +
- }, raw_metadata, datanames, SIMPLIFY = FALSE)+ #' fixed = FALSE |
||
| 222 | -4x | +||
| 48 | +
- do.call(rbind, output)+ #' ) |
||
| 223 | +49 |
- }+ #' ), |
| 1 | +50 |
- #' File Viewer Teal Module+ #' vars = teal.transform::data_extract_spec( |
|
| 2 | +51 |
- #'+ #' dataname = "ADSL", |
|
| 3 | +52 |
- #' The file viewer module provides a tool to view static files.+ #' select = teal.transform::select_spec( |
|
| 4 | +53 |
- #' Supported formats include text formats, \code{PDF}, \code{PNG}, \code{APNG},
+ #' label = "Select variables:", |
|
| 5 | +54 |
- #' \code{JPEG}, \code{SVG}, \code{WEBP}, \code{GIF} and \code{BMP}.
+ #' choices = teal.transform::variable_choices( |
|
| 6 | +55 |
- #'+ #' ADSL, |
|
| 7 | +56 |
- #' @inheritParams teal::module+ #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
|
|
| 8 | +57 |
- #' @inheritParams shared_params+ #' ), |
|
| 9 | +58 |
- #' @param input_path optional, (`list`) of the input paths to either: specific files of accepted formats,+ #' selected = "BMRKR2", |
|
| 10 | +59 |
- #' a directory or a URL. The paths can be specified as absolute paths or relative to the running+ #' multiple = TRUE, |
|
| 11 | +60 |
- #' directory of the application. Will default to current working directory if not supplied.+ #' fixed = FALSE |
|
| 12 | +61 |
- #'+ #' ) |
|
| 13 | +62 |
- #' @export+ #' ), |
|
| 14 | +63 |
- #'+ #' ggplot2_args = teal.widgets::ggplot2_args( |
|
| 15 | +64 |
- #' @examples+ #' labs = list(subtitle = "Plot generated by Association Module") |
|
| 16 | +65 |
- #' data <- data.frame(1)+ #' ) |
|
| 17 | +66 |
- #' app <- teal::init(+ #' ) |
|
| 18 | +67 |
- #' data = teal_data(+ #' ) |
|
| 19 | +68 |
- #' dataset("data", data)
+ #' ) |
|
| 20 | +69 |
- #' ),+ #' if (interactive()) {
|
|
| 21 | +70 |
- #' modules = teal::modules(+ #' shinyApp(app$ui, app$server) |
|
| 22 | +71 |
- #' teal.modules.general::tm_file_viewer(+ #' } |
|
| 23 | +72 |
- #' input_path = list(+ tm_g_association <- function(label = "Association", |
|
| 24 | +73 |
- #' folder = system.file("sample_files", package = "teal.modules.general"),
+ ref, |
|
| 25 | +74 |
- #' png = system.file("sample_files/sample_file.png", package = "teal.modules.general"),
+ vars, |
|
| 26 | +75 |
- #' txt = system.file("sample_files/sample_file.txt", package = "teal.modules.general"),
+ show_association = TRUE, |
|
| 27 | +76 |
- #' url =+ plot_height = c(600, 400, 5000), |
|
| 28 | +77 |
- #' "https://www.fda.gov/files/drugs/published/Portable-Document-Format-Specifications.pdf"+ plot_width = NULL, |
|
| 29 | +78 |
- #' )+ distribution_theme = c( |
|
| 30 | +79 |
- #' )+ "gray", "bw", "linedraw", "light", "dark", |
|
| 31 | +80 |
- #' )+ "minimal", "classic", "void", "test" |
|
| 32 | +81 |
- #' )+ ), |
|
| 33 | +82 |
- #' if (interactive()) {
+ association_theme = c( |
|
| 34 | +83 |
- #' shinyApp(app$ui, app$server)+ "gray", "bw", "linedraw", "light", "dark", |
|
| 35 | +84 |
- #' }+ "minimal", "classic", "void", "test" |
|
| 36 | +85 |
- #'+ ), |
|
| 37 | +86 |
- tm_file_viewer <- function(label = "File Viewer Module",+ pre_output = NULL, |
|
| 38 | +87 |
- input_path = list("Current Working Directory" = ".")) {
+ post_output = NULL, |
|
| 39 | -! | +||
| 88 | +
- logger::log_info("Initializing tm_file_viewer")
+ ggplot2_args = teal.widgets::ggplot2_args()) {
|
||
| 40 | +89 | ! |
- if (length(label) == 0 || identical(label, "")) {
+ logger::log_info("Initializing tm_g_association")
|
| 41 | +90 | ! |
- label <- " "- |
-
| 42 | -- |
- }+ if (inherits(ref, "data_extract_spec")) ref <- list(ref) |
|
| 43 | +91 | ! |
- if (length(input_path) == 0 || identical(input_path, "")) {
+ if (inherits(vars, "data_extract_spec")) vars <- list(vars) |
| 44 | +92 | ! |
- input_path <- list()- |
-
| 45 | -- |
- }+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
|
| 46 | +93 | ||
| 47 | +94 | ! |
checkmate::assert_string(label) |
| 48 | +95 | ! |
- checkmate::assert(+ checkmate::assert_list(ref, types = "data_extract_spec") |
| 49 | +96 | ! |
- checkmate::check_list(input_path, types = "character", min.len = 0),+ if (!all(vapply(ref, function(x) !x$select$multiple, logical(1)))) {
|
| 50 | +97 | ! |
- checkmate::check_character(input_path, min.len = 1)- |
-
| 51 | -- |
- )+ stop("'ref' should not allow multiple selection")
|
|
| 52 | +98 |
-
+ } |
|
| 53 | +99 | ! |
- if (length(input_path) > 0) {
+ checkmate::assert_list(vars, types = "data_extract_spec") |
| 54 | +100 | ! |
- valid_url <- function(url_input, timeout = 2) {
+ checkmate::assert_flag(show_association) |
| 55 | +101 | ! |
- con <- try(url(url_input), silent = TRUE)+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 56 | +102 | ! |
- check <- suppressWarnings(try(open.connection(con, open = "rt", timeout = timeout), silent = TRUE)[1])+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 57 | +103 | ! |
- try(close.connection(con), silent = TRUE)+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 58 | +104 | ! |
- ifelse(is.null(check), TRUE, FALSE)+ checkmate::assert_numeric( |
| 59 | -+ | ||
| 105 | +! |
- }+ plot_width[1], |
|
| 60 | +106 | ! |
- idx <- vapply(input_path, function(x) file.exists(x) || valid_url(x), logical(1))+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 61 | +107 |
-
+ ) |
|
| 62 | +108 | ! |
- if (!all(idx)) {
+ distribution_theme <- match.arg(distribution_theme) |
| 63 | +109 | ! |
- warning(+ association_theme <- match.arg(association_theme) |
| 64 | +110 | ! |
- paste0(+ plot_choices <- c("Bivariate1", "Bivariate2")
|
| 65 | +111 | ! |
- "Non-existent file or url path. Please provide valid paths for:\n",+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
| 66 | +112 | ! |
- paste0(input_path[!idx], collapse = "\n")- |
-
| 67 | -- |
- )- |
- |
| 68 | -- |
- )+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
|
| 69 | +113 |
- }+ |
|
| 70 | +114 | ! |
- input_path <- input_path[idx]+ args <- as.list(environment()) |
| 71 | +115 |
- } else {
+
|
|
| 72 | +116 | ! |
- warning(+ data_extract_list <- list( |
| 73 | +117 | ! |
- "No file or url paths were provided."+ ref = ref, |
| 74 | -+ | ||
| 118 | +! |
- )+ vars = vars |
|
| 75 | +119 |
- }+ ) |
|
| 76 | +120 | ||
| 77 | -+ | ||
| 121 | +! |
-
+ module( |
|
| 78 | +122 | ! |
- args <- as.list(environment())+ label = label, |
| 79 | -+ | ||
| 123 | +! |
-
+ server = srv_tm_g_association, |
|
| 80 | +124 | ! |
- module(+ ui = ui_tm_g_association, |
| 81 | +125 | ! |
- label = label,+ ui_args = args, |
| 82 | +126 | ! |
- server = srv_viewer,+ server_args = c( |
| 83 | +127 | ! |
- server_args = list(input_path = input_path),+ data_extract_list, |
| 84 | +128 | ! |
- ui = ui_viewer,+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args) |
| 85 | -! | +||
| 129 | +
- ui_args = args,+ ), |
||
| 86 | +130 | ! |
- datanames = NULL+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 87 | +131 |
) |
|
| 88 | +132 |
} |
|
| 89 | +133 | ||
| 90 | +134 |
- ui_viewer <- function(id, ...) {
+ ui_tm_g_association <- function(id, ...) {
|
|
| 91 | +135 | +! | +
+ ns <- NS(id)+ |
+
| 136 | ! |
args <- list(...) |
|
| 92 | +137 | ! |
- ns <- NS(id)+ is_single_dataset_value <- teal.transform::is_single_dataset(args$ref, args$vars) |
| 93 | +138 | ||
| 94 | +139 | ! |
- shiny::tagList(+ teal.widgets::standard_layout( |
| 95 | +140 | ! |
- include_css_files("custom"),
+ output = teal.widgets::white_small_well( |
| 96 | +141 | ! |
- teal.widgets::standard_layout(+ textOutput(ns("title")),
|
| 97 | +142 | ! |
- output = div(+ tags$br(), |
| 98 | +143 | ! |
- uiOutput(ns("output"))
+ teal.widgets::plot_with_settings_ui(id = ns("myplot"))
|
| 99 | +144 |
- ),+ ), |
|
| 100 | +145 | ! |
- encoding = div(+ encoding = div( |
| 101 | -! | +||
| 146 | +
- class = "file_viewer_encoding",+ ### Reporter |
||
| 102 | +147 | ! |
- tags$label("Encodings", class = "text-primary"),
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ |
+
| 148 | ++ |
+ ### |
|
| 103 | +149 | ! |
- shinyTree::shinyTree(+ tags$label("Encodings", class = "text-primary"),
|
| 104 | +150 | ! |
- ns("tree"),
+ teal.transform::datanames_input(args[c("ref", "vars")]),
|
| 105 | +151 | ! |
- dragAndDrop = FALSE,+ teal.transform::data_extract_ui( |
| 106 | +152 | ! |
- sort = FALSE,+ id = ns("ref"),
|
| 107 | +153 | ! |
- wholerow = TRUE,+ label = "Reference variable", |
| 108 | +154 | ! |
- theme = "proton",+ data_extract_spec = args$ref, |
| 109 | +155 | ! |
- multiple = FALSE+ is_single_dataset = is_single_dataset_value |
| 110 | +156 |
- )+ ), |
|
| 111 | -+ | ||
| 157 | +! |
- )+ teal.transform::data_extract_ui( |
|
| 112 | -+ | ||
| 158 | +! |
- )+ id = ns("vars"),
|
|
| 113 | -+ | ||
| 159 | +! |
- )+ label = "Associated variables", |
|
| 114 | -+ | ||
| 160 | +! |
- }+ data_extract_spec = args$vars, |
|
| 115 | -+ | ||
| 161 | +! |
-
+ is_single_dataset = is_single_dataset_value |
|
| 116 | +162 |
- srv_viewer <- function(id, input_path) {
+ ), |
|
| 117 | +163 | ! |
- moduleServer(id, function(input, output, session) {
+ checkboxInput( |
| 118 | +164 | ! |
- temp_dir <- tempfile()+ ns("association"),
|
| 119 | +165 | ! |
- if (!dir.exists(temp_dir)) {
+ "Association with reference variable", |
| 120 | +166 | ! |
- dir.create(temp_dir, recursive = TRUE)+ value = args$show_association |
| 121 | +167 |
- }+ ), |
|
| 122 | +168 | ! |
- addResourcePath(basename(temp_dir), temp_dir)+ checkboxInput( |
| 123 | -+ | ||
| 169 | +! |
-
+ ns("show_dist"),
|
|
| 124 | +170 | ! |
- test_path_text <- function(selected_path, type) {
+ "Scaled frequencies", |
| 125 | +171 | ! |
- out <- tryCatch(+ value = FALSE |
| 126 | -! | +||
| 172 | +
- expr = {
+ ), |
||
| 127 | +173 | ! |
- if (type != "url") {
+ checkboxInput( |
| 128 | +174 | ! |
- selected_path <- normalizePath(selected_path, winslash = "/")+ ns("log_transformation"),
|
| 129 | -+ | ||
| 175 | +! |
- }+ "Log transformed", |
|
| 130 | +176 | ! |
- readLines(con = selected_path)+ value = FALSE |
| 131 | +177 |
- },+ ), |
|
| 132 | +178 | ! |
- error = function(cond) FALSE,+ teal.widgets::panel_group( |
| 133 | +179 | ! |
- warning = function(cond) {
+ teal.widgets::panel_item( |
| 134 | +180 | ! |
- `if`(grepl("^incomplete final line found on", cond[[1]]), suppressWarnings(eval(cond[[2]])), FALSE)
+ title = "Plot settings", |
| 135 | -+ | ||
| 181 | +! |
- }+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Scatterplot opacity:", c(0.5, 0, 1), ticks = FALSE),
|
|
| 136 | -+ | ||
| 182 | +! |
- )+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Scatterplot points size:", c(2, 1, 8), ticks = FALSE),
|
|
| 137 | -+ | ||
| 183 | +! |
- }+ checkboxInput(ns("swap_axes"), "Swap axes", value = FALSE),
|
|
| 138 | -+ | ||
| 184 | +! |
-
+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = FALSE),
|
|
| 139 | +185 | ! |
- handle_connection_type <- function(selected_path) {
+ selectInput( |
| 140 | +186 | ! |
- file_extension <- tools::file_ext(selected_path)+ inputId = ns("distribution_theme"),
|
| 141 | +187 | ! |
- file_class <- suppressWarnings(file(selected_path))+ label = "Distribution theme (by ggplot):", |
| 142 | +188 | ! |
- close(file_class)+ choices = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
|
| 143 | -+ | ||
| 189 | +! |
-
+ selected = args$distribution_theme, |
|
| 144 | +190 | ! |
- output_text <- test_path_text(selected_path, type = class(file_class)[1])+ multiple = FALSE |
| 145 | +191 |
-
+ ), |
|
| 146 | +192 | ! |
- if (class(file_class)[1] == "url") {
+ selectInput( |
| 147 | +193 | ! |
- list(selected_path = selected_path, output_text = output_text)+ inputId = ns("association_theme"),
|
| 148 | -+ | ||
| 194 | +! |
- } else {
+ label = "Association theme (by ggplot):", |
|
| 149 | +195 | ! |
- file.copy(normalizePath(selected_path, winslash = "/"), temp_dir)+ choices = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
|
| 150 | +196 | ! |
- selected_path <- file.path(basename(temp_dir), basename(selected_path))+ selected = args$association_theme, |
| 151 | +197 | ! |
- list(selected_path = selected_path, output_text = output_text)+ multiple = FALSE |
| 152 | +198 |
- }+ ) |
|
| 153 | +199 |
- }+ ) |
|
| 154 | +200 |
-
+ ) |
|
| 155 | -! | +||
| 201 | +
- display_file <- function(selected_path) {
+ ), |
||
| 156 | +202 | ! |
- con_type <- handle_connection_type(selected_path)+ forms = tagList( |
| 157 | +203 | ! |
- file_extension <- tools::file_ext(selected_path)+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
|
| 158 | +204 | ! |
- if (file_extension %in% c("png", "apng", "jpg", "jpeg", "svg", "gif", "webp", "bmp")) {
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
| 159 | -! | +||
| 205 | +
- tags$img(src = con_type$selected_path, alt = "file does not exist")+ ), |
||
| 160 | +206 | ! |
- } else if (file_extension == "pdf") {
+ pre_output = args$pre_output, |
| 161 | +207 | ! |
- tags$embed(+ post_output = args$post_output |
| 162 | -! | +||
| 208 | +
- class = "embed_pdf",+ ) |
||
| 163 | -! | +||
| 209 | +
- src = con_type$selected_path+ } |
||
| 164 | +210 |
- )+ |
|
| 165 | -! | +||
| 211 | +
- } else if (!isFALSE(con_type$output_text[1])) {
+ srv_tm_g_association <- function(id, |
||
| 166 | -! | +||
| 212 | +
- tags$pre(paste0(con_type$output_text, collapse = "\n"))+ data, |
||
| 167 | +213 |
- } else {
+ reporter, |
|
| 168 | -! | +||
| 214 | +
- tags$p("Please select a supported format.")
+ filter_panel_api, |
||
| 169 | +215 |
- }+ ref, |
|
| 170 | +216 |
- }+ vars, |
|
| 171 | +217 |
-
+ plot_height, |
|
| 172 | -! | +||
| 218 | +
- tree_list <- function(file_or_dir) {
+ plot_width, |
||
| 173 | -! | +||
| 219 | +
- nested_list <- lapply(file_or_dir, function(path) {
+ ggplot2_args) {
|
||
| 174 | +220 | ! |
- file_class <- suppressWarnings(file(path))+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 175 | +221 | ! |
- close(file_class)+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 176 | +222 | ! |
- if (class(file_class)[[1]] != "url") {
+ checkmate::assert_class(data, "tdata") |
| 177 | +223 | ! |
- isdir <- file.info(path)$isdir+ moduleServer(id, function(input, output, session) {
|
| 178 | +224 | ! |
- if (!isdir) {
+ selector_list <- teal.transform::data_extract_multiple_srv( |
| 179 | +225 | ! |
- structure(path, ancestry = path, sticon = "file")+ data_extract = list(ref = ref, vars = vars), |
| 180 | -+ | ||
| 226 | +! |
- } else {
+ datasets = data, |
|
| 181 | +227 | ! |
- files <- list.files(path, full.names = TRUE, include.dirs = TRUE)+ select_validation_rule = list( |
| 182 | +228 | ! |
- out <- lapply(files, function(x) tree_list(x))+ ref = shinyvalidate::compose_rules( |
| 183 | +229 | ! |
- out <- unlist(out, recursive = FALSE)+ shinyvalidate::sv_required("A reference variable needs to be selected."),
|
| 184 | +230 | ! |
- if (length(files) > 0) names(out) <- basename(files)+ ~ if ((.) %in% selector_list()$vars()$select) {
|
| 185 | +231 | ! |
- out+ "Associated variables and reference variable cannot overlap" |
| 186 | +232 |
} |
|
| 187 | +233 |
- } else {
+ ), |
|
| 188 | +234 | ! |
- structure(path, ancestry = path, sticon = "file")+ vars = shinyvalidate::compose_rules(+ |
+
| 235 | +! | +
+ shinyvalidate::sv_required("An associated variable needs to be selected."),
+ |
+ |
| 236 | +! | +
+ ~ if (length(selector_list()$ref()$select) != 0 && selector_list()$ref()$select %in% (.)) {
+ |
+ |
| 237 | +! | +
+ "Associated variables and reference variable cannot overlap" |
|
| 189 | +238 |
- }+ } |
|
| 190 | +239 |
- })+ ) |
|
| 191 | +240 | ++ |
+ )+ |
+
| 241 | ++ |
+ )+ |
+ |
| 242 | |||
| 192 | +243 | ! |
- missing_labels <- if (is.null(names(nested_list))) seq_along(nested_list) else which(names(nested_list) == "")+ iv_r <- reactive({
|
| 193 | +244 | ! |
- names(nested_list)[missing_labels] <- file_or_dir[missing_labels]+ iv <- shinyvalidate::InputValidator$new() |
| 194 | +245 | ! |
- nested_list+ teal.transform::compose_and_enable_validators(iv, selector_list) |
| 195 | +246 |
- }+ }) |
|
| 196 | +247 | ||
| 197 | +248 | ! |
- output$tree <- shinyTree::renderTree({
+ anl_merged_input <- teal.transform::merge_expression_srv( |
| 198 | +249 | ! |
- if (length(input_path) > 0) {
+ datasets = data, |
| 199 | +250 | ! |
- tree_list(input_path)- |
-
| 200 | -- |
- } else {
+ selector_list = selector_list, |
|
| 201 | +251 | ! |
- list("Empty Path" = NULL)
+ join_keys = get_join_keys(data) |
| 202 | +252 |
- }+ ) |
|
| 203 | +253 |
- })+ |
|
| 204 | -+ | ||
| 254 | +! |
-
+ anl_merged_q <- reactive({
|
|
| 205 | +255 | ! |
- output$output <- renderUI({
+ req(anl_merged_input()) |
| 206 | +256 | ! |
- validate(+ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% |
| 207 | +257 | ! |
- need(+ teal.code::eval_code(as.expression(anl_merged_input()$expr))+ |
+
| 258 | ++ |
+ })+ |
+ |
| 259 | ++ | + | |
| 208 | +260 | ! |
- length(shinyTree::get_selected(input$tree)) > 0,+ merged <- list( |
| 209 | +261 | ! |
- "Please select a file."+ anl_input_r = anl_merged_input, |
| 210 | -+ | ||
| 262 | +! |
- )+ anl_q_r = anl_merged_q |
|
| 211 | +263 |
- )+ ) |
|
| 212 | +264 | ||
| 213 | +265 | ! |
- obj <- shinyTree::get_selected(input$tree, format = "names")[[1]]+ output_q <- reactive({
|
| 214 | +266 | ! |
- repo <- attr(obj, "ancestry")+ teal::validate_inputs(iv_r())+ |
+
| 267 | ++ | + | |
| 215 | +268 | ! |
- repo_collapsed <- if (length(repo) > 1) paste0(repo, collapse = "/") else repo+ ANL <- merged$anl_q_r()[["ANL"]] # nolint |
| 216 | +269 | ! |
- is_not_named <- file.exists(file.path(c(repo_collapsed, obj[1])))[1]+ teal::validate_has_data(ANL, 3) |
| 217 | +270 | ||
| 218 | +271 | ! |
- if (is_not_named) {
+ vars_names <- merged$anl_input_r()$columns_source$vars+ |
+
| 272 | ++ | + | |
| 219 | +273 | ! |
- selected_path <- do.call("file.path", as.list(c(repo, obj[1])))
+ ref_name <- as.vector(merged$anl_input_r()$columns_source$ref) |
| 220 | -+ | ||
| 274 | +! |
- } else {
+ association <- input$association |
|
| 221 | +275 | ! |
- if (length(repo) == 0) {
+ show_dist <- input$show_dist |
| 222 | +276 | ! |
- selected_path <- do.call("file.path", as.list(attr(input$tree[[obj[1]]], "ancestry")))
+ log_transformation <- input$log_transformation |
| 223 | -+ | ||
| 277 | +! |
- } else {
+ rotate_xaxis_labels <- input$rotate_xaxis_labels |
|
| 224 | +278 | ! |
- selected_path <- do.call("file.path", as.list(attr(input$tree[[repo]][[obj[1]]], "ancestry")))
+ swap_axes <- input$swap_axes |
| 225 | -+ | ||
| 279 | +! |
- }+ distribution_theme <- input$distribution_theme |
|
| 226 | -+ | ||
| 280 | +! |
- }+ association_theme <- input$association_theme |
|
| 227 | +281 | ||
| 228 | +282 | ! |
- validate(+ is_scatterplot <- is.numeric(ANL[[ref_name]]) && any(vapply(ANL[vars_names], is.numeric, logical(1))) |
| 229 | +283 | ! |
- need(+ if (is_scatterplot) {
|
| 230 | +284 | ! |
- !isTRUE(file.info(selected_path)$isdir) && length(selected_path) > 0,+ shinyjs::show("alpha")
|
| 231 | +285 | ! |
- "Please select a single file."- |
-
| 232 | -- |
- )- |
- |
| 233 | -- |
- )+ shinyjs::show("size")
|
|
| 234 | +286 | ! |
- display_file(selected_path)+ alpha <- input$alpha # nolint |
| 235 | -+ | ||
| 287 | +! |
- })+ size <- input$size |
|
| 236 | +288 |
-
+ } else {
|
|
| 237 | +289 | ! |
- onStop(function() {
+ shinyjs::hide("alpha")
|
| 238 | +290 | ! |
- removeResourcePath(basename(temp_dir))+ shinyjs::hide("size")
|
| 239 | +291 | ! |
- unlink(temp_dir)+ alpha <- 0.5 |
| 240 | -+ | ||
| 292 | +! |
- })+ size <- 2 |
|
| 241 | +293 |
- })+ } |
|
| 242 | +294 |
- }+ |
| 1 | -+ | ||
| 295 | +! |
- #' Missing data module+ teal::validate_has_data(ANL[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE) |
|
| 2 | +296 |
- #'+ |
|
| 3 | +297 |
- #' Present analysis of missing observations and patients.+ # reference |
|
| 4 | -+ | ||
| 298 | +! |
- #'+ ref_class <- class(ANL[[ref_name]]) |
|
| 5 | -+ | ||
| 299 | +! |
- #' @inheritParams teal::module+ if (is.numeric(ANL[[ref_name]]) && log_transformation) {
|
|
| 6 | +300 |
- #' @inheritParams shared_params+ # works for both integers and doubles |
|
| 7 | -+ | ||
| 301 | +! |
- #' @param parent_dataname (`character(1)`) If this `dataname` exists in then "the by subject"graph is displayed.+ ref_cl_name <- call("log", as.name(ref_name))
|
|
| 8 | -+ | ||
| 302 | +! |
- #' For `CDISC` data. In non `CDISC` data this can be ignored. Defaults to `"ADSL"`.+ ref_cl_lbl <- varname_w_label(ref_name, ANL, prefix = "Log of ") |
|
| 9 | +303 |
- #' @param ggtheme optional, (`character`) `ggplot2` theme to be used by default.+ } else {
|
|
| 10 | +304 |
- #' One of `c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test")`.
+ # silently ignore when non-numeric even if `log` is selected because some |
|
| 11 | +305 |
- #' Each theme can be chosen by the user during the session. Defaults to `"classic"`.+ # variables may be numeric and others not |
|
| 12 | -+ | ||
| 306 | +! |
- #'+ ref_cl_name <- as.name(ref_name) |
|
| 13 | -+ | ||
| 307 | +! |
- #' @templateVar ggnames "Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject"+ ref_cl_lbl <- varname_w_label(ref_name, ANL) |
|
| 14 | +308 |
- #' @template ggplot2_args_multi+ } |
|
| 15 | +309 |
- #'+ |
|
| 16 | -+ | ||
| 310 | +! |
- #' @export+ user_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 17 | -+ | ||
| 311 | +! |
- #'+ user_plot = ggplot2_args[["Bivariate1"]], |
|
| 18 | -+ | ||
| 312 | +! |
- #' @examples+ user_default = ggplot2_args$default |
|
| 19 | +313 |
- #' library(nestcolor)+ ) |
|
| 20 | +314 |
- #'+ |
|
| 21 | -+ | ||
| 315 | +! |
- #' ADSL <- teal.modules.general::rADSL+ ref_call <- bivariate_plot_call( |
|
| 22 | -+ | ||
| 316 | +! |
- #' ADRS <- teal.modules.general::rADRS+ data_name = "ANL", |
|
| 23 | -+ | ||
| 317 | +! |
- #'+ x = ref_cl_name, |
|
| 24 | -+ | ||
| 318 | +! |
- #' app <- teal::init(+ x_class = ref_class, |
|
| 25 | -+ | ||
| 319 | +! |
- #' data = teal.data::cdisc_data(+ x_label = ref_cl_lbl, |
|
| 26 | -+ | ||
| 320 | +! |
- #' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
+ freq = !show_dist, |
|
| 27 | -+ | ||
| 321 | +! |
- #' teal.data::cdisc_dataset("ADRS", ADRS, code = "ADRS <- teal.modules.general::rADRS"),
+ theme = distribution_theme, |
|
| 28 | -+ | ||
| 322 | +! |
- #' check = TRUE+ rotate_xaxis_labels = rotate_xaxis_labels, |
|
| 29 | -+ | ||
| 323 | +! |
- #' ),+ swap_axes = FALSE, |
|
| 30 | -+ | ||
| 324 | +! |
- #' modules = teal::modules(+ size = size, |
|
| 31 | -+ | ||
| 325 | +! |
- #' teal.modules.general::tm_missing_data(+ alpha = alpha, |
|
| 32 | -+ | ||
| 326 | +! |
- #' ggplot2_args = list(+ ggplot2_args = user_ggplot2_args |
|
| 33 | +327 |
- #' "Combinations Hist" = teal.widgets::ggplot2_args(+ ) |
|
| 34 | +328 |
- #' labs = list(subtitle = "Plot produced by Missing Data Module", caption = NULL)+ |
|
| 35 | +329 |
- #' ),+ # association |
|
| 36 | -+ | ||
| 330 | +! |
- #' "Combinations Main" = teal.widgets::ggplot2_args(labs = list(title = NULL))+ ref_class_cov <- ifelse(association, ref_class, "NULL") |
|
| 37 | +331 |
- #' )+ |
|
| 38 | -+ | ||
| 332 | +! |
- #' )+ print_call <- quote(print(p)) |
|
| 39 | +333 |
- #' )+ |
|
| 40 | -+ | ||
| 334 | +! |
- #' )+ var_calls <- lapply(vars_names, function(var_i) {
|
|
| 41 | -+ | ||
| 335 | +! |
- #' if (interactive()) {
+ var_class <- class(ANL[[var_i]]) |
|
| 42 | -+ | ||
| 336 | +! |
- #' shinyApp(app$ui, app$server)+ if (is.numeric(ANL[[var_i]]) && log_transformation) {
|
|
| 43 | +337 |
- #' }+ # works for both integers and doubles |
|
| 44 | -+ | ||
| 338 | +! |
- tm_missing_data <- function(label = "Missing data",+ var_cl_name <- call("log", as.name(var_i))
|
|
| 45 | -+ | ||
| 339 | +! |
- plot_height = c(600, 400, 5000),+ var_cl_lbl <- varname_w_label(var_i, ANL, prefix = "Log of ") |
|
| 46 | +340 |
- plot_width = NULL,+ } else {
|
|
| 47 | +341 |
- parent_dataname = "ADSL",+ # silently ignore when non-numeric even if `log` is selected because some |
|
| 48 | +342 |
- ggtheme = c(+ # variables may be numeric and others not |
|
| 49 | -+ | ||
| 343 | +! |
- "classic", "gray", "bw", "linedraw",+ var_cl_name <- as.name(var_i) |
|
| 50 | -+ | ||
| 344 | +! |
- "light", "dark", "minimal", "void", "test"+ var_cl_lbl <- varname_w_label(var_i, ANL) |
|
| 51 | +345 |
- ),+ } |
|
| 52 | +346 |
- ggplot2_args = list(+ |
|
| 53 | -+ | ||
| 347 | +! |
- "Combinations Hist" = teal.widgets::ggplot2_args(labs = list(caption = NULL)),+ user_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
|
| 54 | -+ | ||
| 348 | +! |
- "Combinations Main" = teal.widgets::ggplot2_args(labs = list(title = NULL))+ user_plot = ggplot2_args[["Bivariate2"]], |
|
| 55 | -+ | ||
| 349 | +! |
- ),+ user_default = ggplot2_args$default |
|
| 56 | +350 |
- pre_output = NULL,+ ) |
|
| 57 | +351 |
- post_output = NULL) {
+
|
|
| 58 | +352 | ! |
- if (!requireNamespace("gridExtra", quietly = TRUE)) {
+ bivariate_plot_call( |
| 59 | +353 | ! |
- stop("Cannot load gridExtra - please install the package or restart your session.")
+ data_name = "ANL", |
| 60 | -+ | ||
| 354 | +! |
- }+ x = ref_cl_name, |
|
| 61 | +355 | ! |
- if (!requireNamespace("rlang", quietly = TRUE)) {
+ y = var_cl_name, |
| 62 | +356 | ! |
- stop("Cannot load rlang - please install the package or restart your session.")
+ x_class = ref_class_cov, |
| 63 | -+ | ||
| 357 | +! |
- }+ y_class = var_class, |
|
| 64 | +358 | ! |
- logger::log_info("Initializing tm_missing_data")
+ x_label = ref_cl_lbl, |
| 65 | +359 | ! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ y_label = var_cl_lbl, |
| 66 | -+ | ||
| 360 | +! |
-
+ theme = association_theme, |
|
| 67 | +361 | ! |
- checkmate::assert_string(label)+ freq = !show_dist, |
| 68 | +362 | ! |
- checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1)+ rotate_xaxis_labels = rotate_xaxis_labels, |
| 69 | +363 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ swap_axes = swap_axes, |
| 70 | +364 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ alpha = alpha, |
| 71 | +365 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ size = size, |
| 72 | +366 | ! |
- checkmate::assert_numeric(+ ggplot2_args = user_ggplot2_args |
| 73 | -! | +||
| 367 | +
- plot_width[1],+ ) |
||
| 74 | -! | +||
| 368 | +
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ }) |
||
| 75 | +369 |
- )+ + |
+ |
| 370 | ++ |
+ # helper function to format variable name |
|
| 76 | +371 | ! |
- ggtheme <- match.arg(ggtheme)+ format_varnames <- function(x) {
|
| 77 | +372 | ! |
- plot_choices <- c("Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject")
+ if (is.numeric(ANL[[x]]) && log_transformation) {
|
| 78 | +373 | ! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ varname_w_label(x, ANL, prefix = "Log of ")+ |
+
| 374 | ++ |
+ } else {
|
|
| 79 | +375 | ! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ varname_w_label(x, ANL) |
| 80 | +376 |
-
+ }+ |
+ |
| 377 | ++ |
+ } |
|
| 81 | +378 | ! |
- module(+ new_title <- |
| 82 | +379 | ! |
- label,+ if (association) {
|
| 83 | +380 | ! |
- server = srv_page_missing_data,+ switch(as.character(length(vars_names)), |
| 84 | +381 | ! |
- server_args = list(+ "0" = sprintf("Value distribution for %s", ref_cl_lbl),
|
| 85 | +382 | ! |
- parent_dataname = parent_dataname, plot_height = plot_height,+ "1" = sprintf( |
| 86 | +383 | ! |
- plot_width = plot_width, ggplot2_args = ggplot2_args+ "Association between %s and %s", |
| 87 | -+ | ||
| 384 | +! |
- ),+ ref_cl_lbl, |
|
| 88 | +385 | ! |
- ui = ui_page_missing_data,+ format_varnames(vars_names)+ |
+
| 386 | ++ |
+ ), |
|
| 89 | +387 | ! |
- datanames = "all",+ sprintf( |
| 90 | +388 | ! |
- ui_args = list(+ "Associations between %s and: %s", |
| 91 | +389 | ! |
- parent_dataname = parent_dataname, pre_output = pre_output,+ ref_cl_lbl, |
| 92 | +390 | ! |
- post_output = post_output, ggtheme = ggtheme+ paste(lapply(vars_names, format_varnames), collapse = ", ") |
| 93 | +391 |
- )+ ) |
|
| 94 | +392 |
- )+ ) |
|
| 95 | +393 |
- }+ } else {
|
|
| 96 | -+ | ||
| 394 | +! |
-
+ switch(as.character(length(vars_names)), |
|
| 97 | -+ | ||
| 395 | +! |
- ui_page_missing_data <- function(id, data, parent_dataname, pre_output = NULL, post_output = NULL, ggtheme) {
+ "0" = sprintf("Value distribution for %s", ref_cl_lbl),
|
|
| 98 | +396 | ! |
- ns <- NS(id)+ sprintf( |
| 99 | +397 | ! |
- datanames <- names(data)+ "Value distributions for %s and %s", |
| 100 | -+ | ||
| 398 | +! |
-
+ ref_cl_lbl, |
|
| 101 | +399 | ! |
- if_subject_plot <- length(parent_dataname) > 0 && parent_dataname %in% datanames+ paste(lapply(vars_names, format_varnames), collapse = ", ") |
| 102 | +400 | ++ |
+ )+ |
+
| 401 | ++ |
+ )+ |
+ |
| 402 | ++ |
+ }+ |
+ |
| 403 | |||
| 103 | +404 | ! |
- shiny::tagList(+ teal.code::eval_code( |
| 104 | +405 | ! |
- include_css_files("custom"),
+ merged$anl_q_r(), |
| 105 | +406 | ! |
- teal.widgets::standard_layout(+ substitute( |
| 106 | +407 | ! |
- output = teal.widgets::white_small_well(+ expr = title <- new_title, |
| 107 | +408 | ! |
- div(+ env = list(new_title = new_title) |
| 108 | -! | +||
| 409 | +
- class = "flex",+ ) |
||
| 109 | -! | +||
| 410 | +
- column(+ ) %>% |
||
| 110 | +411 | ! |
- width = 12,+ teal.code::eval_code( |
| 111 | +412 | ! |
- do.call(+ substitute( |
| 112 | +413 | ! |
- tabsetPanel,+ expr = {
|
| 113 | +414 | ! |
- c(+ plots <- plot_calls |
| 114 | +415 | ! |
- id = ns("dataname_tab"),
+ p <- tern::stack_grobs(grobs = lapply(plots, ggplotGrob)) |
| 115 | +416 | ! |
- lapply(+ grid::grid.newpage() |
| 116 | +417 | ! |
- datanames,+ grid::grid.draw(p) |
| 117 | -! | +||
| 418 | +
- function(x) {
+ }, |
||
| 118 | +419 | ! |
- tabPanel(+ env = list( |
| 119 | +420 | ! |
- title = x,+ plot_calls = do.call( |
| 120 | +421 | ! |
- column(+ "call", |
| 121 | +422 | ! |
- width = 12,+ c(list("list", ref_call), var_calls),
|
| 122 | +423 | ! |
- div(+ quote = TRUE |
| 123 | -! | +||
| 424 | +
- class = "mt-4",+ ) |
||
| 124 | -! | +||
| 425 | +
- ui_missing_data(id = ns(x), by_subject_plot = if_subject_plot)+ ) |
||
| 125 | +426 |
- )+ ) |
|
| 126 | +427 |
- )+ ) |
|
| 127 | +428 |
- )+ }) |
|
| 128 | +429 |
- }+ + |
+ |
| 430 | +! | +
+ plot_r <- shiny::reactive({
+ |
+ |
| 431 | +! | +
+ shiny::req(iv_r()$is_valid())+ |
+ |
| 432 | +! | +
+ output_q()[["p"]] |
|
| 129 | +433 |
- )+ }) |
|
| 130 | +434 |
- )+ + |
+ |
| 435 | +! | +
+ pws <- teal.widgets::plot_with_settings_srv(+ |
+ |
| 436 | +! | +
+ id = "myplot",+ |
+ |
| 437 | +! | +
+ plot_r = plot_r,+ |
+ |
| 438 | +! | +
+ height = plot_height,+ |
+ |
| 439 | +! | +
+ width = plot_width |
|
| 131 | +440 |
- )+ ) |
|
| 132 | +441 |
- )+ + |
+ |
| 442 | +! | +
+ output$title <- renderText({
+ |
+ |
| 443 | +! | +
+ teal.code::dev_suppress(output_q()[["title"]]) |
|
| 133 | +444 |
- )+ }) |
|
| 134 | +445 |
- ),- |
- |
| 135 | -! | -
- encoding = div(+ |
|
| 136 | +446 | ! |
- tagList(+ teal.widgets::verbatim_popup_srv( |
| 137 | +447 | ! |
- lapply(+ id = "warning", |
| 138 | +448 | ! |
- datanames,+ verbatim_content = reactive(teal.code::get_warnings(output_q())), |
| 139 | +449 | ! |
- function(x) {
+ title = "Warning", |
| 140 | +450 | ! |
- conditionalPanel(+ disabled = reactive(is.null(teal.code::get_warnings(output_q()))) |
| 141 | -! | +||
| 451 | +
- is_tab_active_js(ns("dataname_tab"), x),
+ ) |
||
| 142 | -! | +||
| 452 | +
- encoding_missing_data(+ |
||
| 143 | +453 | ! |
- id = ns(x),+ teal.widgets::verbatim_popup_srv( |
| 144 | +454 | ! |
- summary_per_patient = if_subject_plot,+ id = "rcode", |
| 145 | +455 | ! |
- ggtheme = ggtheme,+ verbatim_content = reactive(teal.code::get_code(output_q())), |
| 146 | +456 | ! |
- datanames = datanames+ title = "Association Plot" |
| 147 | +457 |
- )+ ) |
|
| 148 | +458 |
- )+ |
|
| 149 | +459 |
- }+ ### REPORTER |
|
| 150 | -+ | ||
| 460 | +! |
- )+ if (with_reporter) {
|
|
| 151 | -+ | ||
| 461 | +! |
- )+ card_fun <- function(comment, label) {
|
|
| 152 | -+ | ||
| 462 | +! |
- ),+ card <- teal::report_card_template( |
|
| 153 | +463 | ! |
- forms <- lapply(datanames, function(x) {
+ title = "Association Plot", |
| 154 | +464 | ! |
- dataname_ns <- NS(ns(x))+ label = label, |
| 155 | -+ | ||
| 465 | +! |
-
+ with_filter = with_filter, |
|
| 156 | +466 | ! |
- conditionalPanel(+ filter_panel_api = filter_panel_api |
| 157 | -! | +||
| 467 | +
- is_tab_active_js(ns("dataname_tab"), x),
+ ) |
||
| 158 | +468 | ! |
- tagList(+ card$append_text("Plot", "header3")
|
| 159 | +469 | ! |
- teal.widgets::verbatim_popup_ui(dataname_ns("warning"), "Show Warnings"),
+ card$append_plot(plot_r(), dim = pws$dim()) |
| 160 | +470 | ! |
- teal.widgets::verbatim_popup_ui(dataname_ns("rcode"), "Show R code")
+ if (!comment == "") {
|
| 161 | -+ | ||
| 471 | +! |
- )+ card$append_text("Comment", "header3")
|
|
| 162 | -+ | ||
| 472 | +! |
- )+ card$append_text(comment) |
|
| 163 | +473 |
- }),+ } |
|
| 164 | +474 | ! |
- pre_output = pre_output,+ card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n")) |
| 165 | +475 | ! |
- post_output = post_output+ card |
| 166 | +476 |
- )+ } |
|
| 167 | -+ | ||
| 477 | +! |
- )+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 168 | +478 |
- }+ } |
|
| 169 | +479 |
-
+ ### |
|
| 170 | +480 |
- srv_page_missing_data <- function(id, data, reporter, filter_panel_api, parent_dataname,+ }) |
|
| 171 | +481 |
- plot_height, plot_width, ggplot2_args) {
- |
- |
| 172 | -! | -
- moduleServer(id, function(input, output, session) {
- |
- |
| 173 | -! | -
- lapply(- |
- |
| 174 | -! | -
- names(data),- |
- |
| 175 | -! | -
- function(x) {
- |
- |
| 176 | -! | -
- srv_missing_data(+ } |
|
| 177 | -! | +
| 1 | +
- id = x,+ #' Create a simple scatterplot |
||
| 178 | -! | +||
| 2 | +
- data = data,+ #' |
||
| 179 | -! | +||
| 3 | +
- reporter = reporter,+ #' Create a plot with the \code{\link{ggplot2}[geom_point]} function
|
||
| 180 | -! | +||
| 4 | +
- filter_panel_api = filter_panel_api,+ #' @md |
||
| 181 | -! | +||
| 5 | +
- dataname = x,+ #' |
||
| 182 | -! | +||
| 6 | +
- parent_dataname = parent_dataname,+ #' @inheritParams teal::module |
||
| 183 | -! | +||
| 7 | +
- plot_height = plot_height,+ #' @inheritParams shared_params |
||
| 184 | -! | +||
| 8 | +
- plot_width = plot_width,+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) Variable |
||
| 185 | -! | +||
| 9 | +
- ggplot2_args = ggplot2_args+ #' names selected to plot along the x-axis by default. |
||
| 186 | +10 |
- )+ #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) Variable |
|
| 187 | +11 |
- }+ #' names selected to plot along the y-axis by default. |
|
| 188 | +12 |
- )+ #' @param color_by optional (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 189 | +13 |
- })+ #' Defines the color encoding. If `NULL` then no color encoding option will be displayed. |
|
| 190 | +14 |
- }+ #' @param size_by optional (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 191 | +15 |
-
+ #' Defines the point size encoding. If `NULL` then no size encoding option will be displayed. |
|
| 192 | +16 |
- ui_missing_data <- function(id, by_subject_plot = FALSE) {
+ #' @param row_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 193 | -! | +||
| 17 | +
- ns <- NS(id)+ #' Which data columns to use for faceting rows. |
||
| 194 | +18 |
-
+ #' @param col_facet optional, (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 195 | -! | +||
| 19 | +
- tab_list <- list(+ #' Which data to use for faceting columns. |
||
| 196 | -! | +||
| 20 | +
- tabPanel(+ #' @param alpha optional, (`numeric`) If scalar then the plot points will have a fixed opacity. If a |
||
| 197 | -! | +||
| 21 | +
- "Summary",+ #' slider should be presented to adjust the plot point opacity dynamically then it can be a vector of |
||
| 198 | -! | +||
| 22 | +
- teal.widgets::plot_with_settings_ui(id = ns("summary_plot")),
+ #' length three with `c(value, min, max)`. |
||
| 199 | -! | +||
| 23 | +
- helpText(+ #' @param size optional, (`numeric`) If scalar then the plot point sizes will have a fixed size |
||
| 200 | -! | +||
| 24 | +
- p(paste(+ #' If a slider should be presented to adjust the plot point sizes dynamically then it can be a |
||
| 201 | -! | +||
| 25 | +
- 'The "Summary" graph shows the number of missing values per variable (both absolute and percentage),',+ #' vector of length three with `c(value, min, max)`. |
||
| 202 | -! | +||
| 26 | +
- "sorted by magnitude."+ #' @param shape optional, (`character`) A character vector with the English names of the |
||
| 203 | +27 |
- )),+ #' shape, e.g. `c("triangle", "square", "circle")`. It defaults to `shape_names`. This is a complete list from
|
|
| 204 | -! | +||
| 28 | +
- p(+ #' `vignette("ggplot2-specs", package="ggplot2")`.
|
||
| 205 | -! | +||
| 29 | +
- 'The "summary per patients" graph is showing how many subjects have at least one missing observation',+ #' @param max_deg optional, (`integer`) The maximum degree for the polynomial trend line. Must not be less than 1. |
||
| 206 | -! | +||
| 30 | +
- "for each variable. It will be most useful for panel datasets."+ #' @param table_dec optional, (`integer`) Number of decimal places used to round numeric values in the table. |
||
| 207 | +31 |
- )+ #' |
|
| 208 | +32 |
- )+ #' |
|
| 209 | +33 |
- ),+ #' @note For more examples, please see the vignette "Using scatterplot" via |
|
| 210 | -! | +||
| 34 | +
- tabPanel(+ #' `vignette("using-scatterplot", package = "teal.modules.general")`.
|
||
| 211 | -! | +||
| 35 | +
- "Combinations",+ #' |
||
| 212 | -! | +||
| 36 | +
- teal.widgets::plot_with_settings_ui(id = ns("combination_plot")),
+ #' @export |
||
| 213 | -! | +||
| 37 | +
- helpText(+ #' @examples |
||
| 214 | -! | +||
| 38 | +
- p(paste(+ #' # Scatterplot of variables from ADSL dataset |
||
| 215 | -! | +||
| 39 | +
- 'The "Combinations" graph is used to explore the relationship between the missing data within',+ #' library(nestcolor) |
||
| 216 | -! | +||
| 40 | +
- "different columns of the dataset.",+ #' |
- ||
| 217 | -! | +||
| 41 | +
- "It shows the different patterns of missingness in the rows of the data.",+ #' ADSL <- teal.modules.general::rADSL |
||
| 218 | -! | +||
| 42 | +
- 'For example, suppose that 70 rows of the data have exactly columns "A" and "B" missing.',+ #' |
||
| 219 | -! | +||
| 43 | +
- "In this case there would be a bar of height 70 in the top graph and",+ #' app <- teal::init( |
||
| 220 | -! | +||
| 44 | +
- 'the column below this in the second graph would have rows "A" and "B" cells shaded red.'+ #' data = teal.data::cdisc_data( |
||
| 221 | +45 |
- )),+ #' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
|
|
| 222 | -! | +||
| 46 | +
- p(paste(+ #' check = TRUE |
||
| 223 | -! | +||
| 47 | +
- "Due to the large number of missing data patterns possible, only those with a large set of observations",+ #' ), |
||
| 224 | -! | +||
| 48 | +
- 'are shown in the graph and the "Combination cut-off" slider can be used to adjust the number shown.'+ #' modules = teal::modules( |
||
| 225 | +49 |
- ))+ #' teal.modules.general::tm_g_scatterplot( |
|
| 226 | +50 |
- )+ #' label = "Scatterplot Choices", |
|
| 227 | +51 |
- ),+ #' x = teal.transform::data_extract_spec( |
|
| 228 | -! | +||
| 52 | +
- tabPanel(+ #' dataname = "ADSL", |
||
| 229 | -! | +||
| 53 | +
- "By Variable Levels",+ #' select = teal.transform::select_spec( |
||
| 230 | -! | +||
| 54 | +
- teal.widgets::get_dt_rows(ns("levels_table"), ns("levels_table_rows")),
+ #' label = "Select variable:", |
||
| 231 | -! | +||
| 55 | +
- DT::dataTableOutput(ns("levels_table"))
+ #' choices = teal.transform::variable_choices( |
||
| 232 | +56 |
- )+ #' ADSL, |
|
| 233 | +57 |
- )+ #' c("AGE", "BMRKR1", "BMRKR2")
|
|
| 234 | -! | +||
| 58 | +
- if (isTRUE(by_subject_plot)) {
+ #' ), |
||
| 235 | -! | +||
| 59 | +
- tab_list <- append(+ #' selected = "AGE", |
||
| 236 | -! | +||
| 60 | +
- tab_list,+ #' multiple = FALSE, |
||
| 237 | -! | +||
| 61 | +
- list(tabPanel(+ #' fixed = FALSE |
||
| 238 | -! | +||
| 62 | +
- "Grouped by Subject",+ #' ) |
||
| 239 | -! | +||
| 63 | +
- teal.widgets::plot_with_settings_ui(id = ns("by_subject_plot")),
+ #' ), |
||
| 240 | -! | +||
| 64 | +
- helpText(+ #' y = teal.transform::data_extract_spec( |
||
| 241 | -! | +||
| 65 | +
- p(paste(+ #' dataname = "ADSL", |
||
| 242 | -! | +||
| 66 | +
- "This graph shows the missingness with respect to subjects rather than individual rows of the",+ #' select = teal.transform::select_spec( |
||
| 243 | -! | +||
| 67 | +
- "dataset. Each row represents one dataset variable and each column a single subject. Only subjects",+ #' label = "Select variable:", |
||
| 244 | -! | +||
| 68 | +
- "with at least one record in this dataset are shown. For a given subject, if they have any missing",+ #' choices = teal.transform::variable_choices( |
||
| 245 | -! | +||
| 69 | +
- "values of a specific variable then the appropriate cell in the graph is marked as missing."+ #' ADSL, |
||
| 246 | +70 |
- ))+ #' c("AGE", "BMRKR1", "BMRKR2")
|
|
| 247 | +71 |
- )+ #' ), |
|
| 248 | +72 |
- ))+ #' selected = "BMRKR1", |
|
| 249 | +73 |
- )+ #' multiple = FALSE, |
|
| 250 | +74 |
- }+ #' fixed = FALSE |
|
| 251 | +75 |
-
+ #' ) |
|
| 252 | -! | +||
| 76 | +
- do.call(+ #' ), |
||
| 253 | -! | +||
| 77 | +
- tabsetPanel,+ #' color_by = teal.transform::data_extract_spec( |
||
| 254 | -! | +||
| 78 | +
- c(+ #' dataname = "ADSL", |
||
| 255 | -! | +||
| 79 | +
- id = ns("summary_type"),
+ #' select = teal.transform::select_spec( |
||
| 256 | -! | +||
| 80 | +
- tab_list+ #' label = "Select variable:", |
||
| 257 | +81 |
- )+ #' choices = teal.transform::variable_choices( |
|
| 258 | +82 |
- )+ #' ADSL, |
|
| 259 | +83 |
- }+ #' c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1")
|
|
| 260 | +84 |
-
+ #' ), |
|
| 261 | +85 |
- encoding_missing_data <- function(id, summary_per_patient = FALSE, ggtheme, datanames) {
+ #' selected = NULL, |
|
| 262 | -! | +||
| 86 | +
- ns <- NS(id)+ #' multiple = FALSE, |
||
| 263 | +87 |
-
+ #' fixed = FALSE |
|
| 264 | -! | +||
| 88 | +
- tagList(+ #' ) |
||
| 265 | +89 |
- ### Reporter+ #' ), |
|
| 266 | -! | +||
| 90 | +
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ #' size_by = teal.transform::data_extract_spec( |
||
| 267 | +91 |
- ###+ #' dataname = "ADSL", |
|
| 268 | -! | +||
| 92 | +
- tags$label("Encodings", class = "text-primary"),
+ #' select = teal.transform::select_spec( |
||
| 269 | -! | +||
| 93 | +
- helpText(+ #' label = "Select variable:", |
||
| 270 | -! | +||
| 94 | +
- paste0("Dataset", `if`(length(datanames) > 1, "s", ""), ":"),
+ #' choices = teal.transform::variable_choices( |
||
| 271 | -! | +||
| 95 | +
- tags$code(paste(datanames, collapse = ", "))+ #' ADSL, |
||
| 272 | +96 |
- ),+ #' c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1")
|
|
| 273 | -! | +||
| 97 | +
- uiOutput(ns("variables")),
+ #' ), |
||
| 274 | -! | +||
| 98 | +
- actionButton(+ #' selected = "AGE", |
||
| 275 | -! | +||
| 99 | +
- ns("filter_na"),
+ #' multiple = FALSE, |
||
| 276 | -! | +||
| 100 | +
- span("Select only vars with missings", class = "whitespace-normal"),
+ #' fixed = FALSE |
||
| 277 | -! | +||
| 101 | +
- width = "100%",+ #' ) |
||
| 278 | -! | +||
| 102 | +
- class = "mb-4"+ #' ), |
||
| 279 | +103 |
- ),+ #' row_facet = teal.transform::data_extract_spec( |
|
| 280 | -! | +||
| 104 | +
- conditionalPanel(+ #' dataname = "ADSL", |
||
| 281 | -! | +||
| 105 | +
- is_tab_active_js(ns("summary_type"), "Summary"),
+ #' select = teal.transform::select_spec( |
||
| 282 | -! | +||
| 106 | +
- checkboxInput(+ #' label = "Select variable:", |
||
| 283 | -! | +||
| 107 | +
- ns("any_na"),
+ #' choices = teal.transform::variable_choices( |
||
| 284 | -! | +||
| 108 | +
- div(+ #' ADSL, |
||
| 285 | -! | +||
| 109 | +
- class = "teal-tooltip",+ #' c("BMRKR2", "RACE", "REGION1")
|
||
| 286 | -! | +||
| 110 | +
- tagList(+ #' ), |
||
| 287 | -! | +||
| 111 | +
- "Add **anyna** variable",+ #' selected = NULL, |
||
| 288 | -! | +||
| 112 | +
- icon("circle-info"),
+ #' multiple = FALSE, |
||
| 289 | -! | +||
| 113 | +
- span(+ #' fixed = FALSE |
||
| 290 | -! | +||
| 114 | +
- class = "tooltiptext",+ #' ) |
||
| 291 | -! | +||
| 115 | +
- "Describes the number of observations with at least one missing value in any variable."+ #' ), |
||
| 292 | +116 |
- )+ #' col_facet = teal.transform::data_extract_spec( |
|
| 293 | +117 |
- )+ #' dataname = "ADSL", |
|
| 294 | +118 |
- ),+ #' select = teal.transform::select_spec( |
|
| 295 | -! | +||
| 119 | +
- value = FALSE+ #' label = "Select variable:", |
||
| 296 | +120 |
- ),+ #' choices = teal.transform::variable_choices( |
|
| 297 | -! | +||
| 121 | +
- if (summary_per_patient) {
+ #' ADSL, |
||
| 298 | -! | +||
| 122 | +
- checkboxInput(+ #' c("BMRKR2", "RACE", "REGION1")
|
||
| 299 | -! | +||
| 123 | +
- ns("if_patients_plot"),
+ #' ), |
||
| 300 | -! | +||
| 124 | +
- div(+ #' selected = NULL, |
||
| 301 | -! | +||
| 125 | +
- class = "teal-tooltip",+ #' multiple = FALSE, |
||
| 302 | -! | +||
| 126 | +
- tagList(+ #' fixed = FALSE |
||
| 303 | -! | +||
| 127 | +
- "Add summary per patients",+ #' ) |
||
| 304 | -! | +||
| 128 | +
- icon("circle-info"),
+ #' ), |
||
| 305 | -! | +||
| 129 | +
- span(+ #' ggplot2_args = teal.widgets::ggplot2_args( |
||
| 306 | -! | +||
| 130 | +
- class = "tooltiptext",+ #' labs = list(subtitle = "Plot generated by Scatterplot Module") |
||
| 307 | -! | +||
| 131 | +
- paste(+ #' ) |
||
| 308 | -! | +||
| 132 | +
- "Displays the number of missing values per observation,",+ #' ) |
||
| 309 | -! | +||
| 133 | +
- "where the x-axis is sorted by observation appearance in the table."+ #' ) |
||
| 310 | +134 |
- )+ #' ) |
|
| 311 | +135 |
- )+ #' if (interactive()) {
|
|
| 312 | +136 |
- )+ #' shinyApp(app$ui, app$server) |
|
| 313 | +137 |
- ),+ #' } |
|
| 314 | -! | +||
| 138 | +
- value = FALSE+ tm_g_scatterplot <- function(label = "Scatterplot", |
||
| 315 | +139 |
- )+ x, |
|
| 316 | +140 |
- }+ y, |
|
| 317 | +141 |
- ),+ color_by = NULL, |
|
| 318 | -! | +||
| 142 | +
- conditionalPanel(+ size_by = NULL, |
||
| 319 | -! | +||
| 143 | +
- is_tab_active_js(ns("summary_type"), "Combinations"),
+ row_facet = NULL, |
||
| 320 | -! | +||
| 144 | +
- uiOutput(ns("cutoff"))
+ col_facet = NULL, |
||
| 321 | +145 |
- ),+ plot_height = c(600, 200, 2000), |
|
| 322 | -! | +||
| 146 | +
- conditionalPanel(+ plot_width = NULL, |
||
| 323 | -! | +||
| 147 | +
- is_tab_active_js(ns("summary_type"), "By Variable Levels"),
+ alpha = c(1, 0, 1), |
||
| 324 | -! | +||
| 148 | +
- tagList(+ shape = shape_names, |
||
| 325 | -! | +||
| 149 | +
- uiOutput(ns("group_by_var_ui")),
+ size = c(5, 1, 15), |
||
| 326 | -! | +||
| 150 | +
- uiOutput(ns("group_by_vals_ui")),
+ max_deg = 5L, |
||
| 327 | -! | +||
| 151 | +
- radioButtons(+ rotate_xaxis_labels = FALSE, |
||
| 328 | -! | +||
| 152 | +
- ns("count_type"),
+ ggtheme = c( |
||
| 329 | -! | +||
| 153 | +
- label = "Display missing as",+ "gray", "bw", "linedraw", "light", "dark", |
||
| 330 | -! | +||
| 154 | +
- choices = c("counts", "proportions"),
+ "minimal", "classic", "void", "test" |
||
| 331 | -! | +||
| 155 | +
- selected = "counts",+ ), |
||
| 332 | -! | +||
| 156 | +
- inline = TRUE+ pre_output = NULL, |
||
| 333 | +157 |
- )+ post_output = NULL, |
|
| 334 | +158 |
- )+ table_dec = 4, |
|
| 335 | +159 |
- ),+ ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 336 | +160 | ! |
- teal.widgets::panel_item(+ logger::log_info("Initializing tm_g_scatterplot")
|
| 337 | -! | +||
| 161 | +
- title = "Plot settings",+ |
||
| 338 | +162 | ! |
- selectInput(+ extra_packages <- c("ggpmisc", "ggExtra", "colourpicker")
|
| 339 | +163 | ! |
- inputId = ns("ggtheme"),
+ missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages) |
| 340 | +164 | ! |
- label = "Theme (by ggplot):",+ if (length(missing_packages) > 0L) {
|
| 341 | +165 | ! |
- choices = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
+ stop(sprintf( |
| 342 | +166 | ! |
- selected = ggtheme,+ "Cannot load package(s): %s.\nInstall or restart your session.", |
| 343 | +167 | ! |
- multiple = FALSE- |
-
| 344 | -- |
- )- |
- |
| 345 | -- |
- )+ toString(missing_packages) |
|
| 346 | +168 |
- )+ )) |
|
| 347 | +169 |
- }+ } |
|
| 348 | +170 | ||
| 349 | -- |
- srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, parent_dataname,- |
- |
| 350 | -- |
- plot_height, plot_width, ggplot2_args) {
- |
- |
| 351 | +171 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ if (inherits(x, "data_extract_spec")) x <- list(x) |
| 352 | +172 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ if (inherits(y, "data_extract_spec")) y <- list(y) |
| 353 | +173 | ! |
- checkmate::assert_class(data, "tdata")+ if (inherits(color_by, "data_extract_spec")) color_by <- list(color_by) |
| 354 | +174 | ! |
- moduleServer(id, function(input, output, session) {
+ if (inherits(size_by, "data_extract_spec")) size_by <- list(size_by) |
| 355 | +175 | ! |
- prev_group_by_var <- reactiveVal("")
+ if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet) |
| 356 | +176 | ! |
- data_r <- data[[dataname]]+ if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) |
| 357 | +177 | ! |
- data_keys <- reactive(get_join_keys(data)$get(dataname)[[dataname]])+ if (is.double(max_deg)) max_deg <- as.integer(max_deg) |
| 358 | +178 | ||
| 359 | +179 | ! |
- iv_r <- reactive({
+ ggtheme <- match.arg(ggtheme) |
| 360 | +180 | ! |
- iv <- shinyvalidate::InputValidator$new()+ checkmate::assert_string(label) |
| 361 | +181 | ! |
- iv$add_rule(+ checkmate::assert_list(x, types = "data_extract_spec") |
| 362 | +182 | ! |
- "variables_select",+ checkmate::assert_list(y, types = "data_extract_spec") |
| 363 | +183 | ! |
- shinyvalidate::sv_required("At least one reference variable needs to be selected.")
- |
-
| 364 | -- |
- )+ checkmate::assert_list(color_by, types = "data_extract_spec", null.ok = TRUE) |
|
| 365 | +184 | ! |
- iv$add_rule(+ checkmate::assert_list(size_by, types = "data_extract_spec", null.ok = TRUE) |
| 366 | +185 | ! |
- "variables_select",+ checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) |
| 367 | +186 | ! |
- ~ if (length(setdiff((.), data_keys())) < 1) "Please also select non-key columns."- |
-
| 368 | -- |
- )+ checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) |
|
| 369 | +187 | ! |
- iv_summary_table <- shinyvalidate::InputValidator$new()+ checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) |
| 370 | +188 | ! |
- iv_summary_table$condition(~ isTRUE(input$summary_type == "By Variable Levels"))+ if (!all(vapply(row_facet, function(x) !x$select$multiple, logical(1)))) {
|
| 371 | +189 | ! |
- iv_summary_table$add_rule("count_type", shinyvalidate::sv_required("Please select type of counts"))
+ stop("'row_facet' should not allow multiple selection")
|
| 372 | -! | +||
| 190 | +
- iv_summary_table$add_rule(+ } |
||
| 373 | +191 | ! |
- "group_by_vals",+ if (!all(vapply(col_facet, function(x) !x$select$multiple, logical(1)))) {
|
| 374 | +192 | ! |
- shinyvalidate::sv_required("Please select both group-by variable and values")
+ stop("'col_facet' should not allow multiple selection")
|
| 375 | +193 |
- )+ } |
|
| 376 | +194 | ! |
- iv_summary_table$add_rule(+ checkmate::assert_character(shape) |
| 377 | -! | +||
| 195 | +
- "group_by_var",+ |
||
| 378 | +196 | ! |
- ~ if (length(.) > 0 && length(input$variables_select) == 1 && (.) == input$variables_select) {
+ checkmate::assert_int(max_deg, lower = 1L) |
| 379 | +197 | ! |
- "If only one reference variable is selected it must not be the grouping variable."+ checkmate::assert_scalar(table_dec) |
| 380 | -+ | ||
| 198 | +! |
- }+ checkmate::assert_flag(rotate_xaxis_labels) |
|
| 381 | -+ | ||
| 199 | +! |
- )+ if (length(alpha) == 1) {
|
|
| 382 | +200 | ! |
- iv_summary_table$add_rule(+ checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE) |
| 383 | -! | +||
| 201 | +
- "variables_select",+ } else {
|
||
| 384 | +202 | ! |
- ~ if (length(input$group_by_var) > 0 && length(.) == 1 && (.) == input$group_by_var) {
+ checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE) |
| 385 | +203 | ! |
- "If only one reference variable is selected it must not be the grouping variable."+ checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha") |
| 386 | +204 |
- }+ } |
|
| 387 | +205 |
- )+ |
|
| 388 | +206 | ! |
- iv$add_validator(iv_summary_table)+ if (length(size) == 1) {
|
| 389 | +207 | ! |
- iv$enable()+ checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE)+ |
+
| 208 | ++ |
+ } else {
|
|
| 390 | +209 | ! |
- iv+ checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE) |
| 391 | -+ | ||
| 210 | +! |
- })+ checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size") |
|
| 392 | +211 |
-
+ } |
|
| 393 | +212 | ||
| 394 | +213 | ! |
- data_parent_keys <- reactive({
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 395 | +214 | ! |
- if (length(parent_dataname) > 0 && parent_dataname %in% names(data)) {
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 396 | +215 | ! |
- keys <- get_join_keys(data)$get(dataname)+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 397 | +216 | ! |
- if (parent_dataname %in% names(keys)) {
+ checkmate::assert_numeric( |
| 398 | +217 | ! |
- keys[[parent_dataname]]- |
-
| 399 | -- |
- } else {
+ plot_width[1], |
|
| 400 | +218 | ! |
- keys[[dataname]]+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 401 | +219 |
- }+ ) |
|
| 402 | +220 |
- } else {
+
|
|
| 403 | +221 | ! |
- NULL+ checkmate::assert_class(ggplot2_args, "ggplot2_args") |
| 404 | +222 |
- }+ |
|
| 405 | -+ | ||
| 223 | +! |
- })+ args <- as.list(environment()) |
|
| 406 | +224 | ||
| 407 | +225 | ! |
- common_code_q <- reactive({
+ data_extract_list <- list( |
| 408 | +226 | ! |
- teal::validate_inputs(iv_r())+ x = x, |
| 409 | -+ | ||
| 227 | +! |
-
+ y = y, |
|
| 410 | +228 | ! |
- group_var <- input$group_by_var+ color_by = color_by, |
| 411 | +229 | ! |
- anl <- data_r()+ size_by = size_by, |
| 412 | +230 | ! |
- qenv <- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data))+ row_facet = row_facet,+ |
+
| 231 | +! | +
+ col_facet = col_facet |
|
| 413 | +232 | ++ |
+ )+ |
+
| 233 | |||
| 414 | +234 | ! |
- qenv <- if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {
+ module( |
| 415 | +235 | ! |
- teal.code::eval_code(+ label = label, |
| 416 | +236 | ! |
- qenv,+ server = srv_g_scatterplot, |
| 417 | +237 | ! |
- substitute(+ ui = ui_g_scatterplot, |
| 418 | +238 | ! |
- expr = ANL <- anl_name[, selected_vars, drop = FALSE], # nolint+ ui_args = args, |
| 419 | +239 | ! |
- env = list(anl_name = as.name(dataname), selected_vars = selected_vars())+ server_args = c(+ |
+
| 240 | +! | +
+ data_extract_list,+ |
+ |
| 241 | +! | +
+ list(plot_height = plot_height, plot_width = plot_width, table_dec = table_dec, ggplot2_args = ggplot2_args) |
|
| 420 | +242 |
- )+ ),+ |
+ |
| 243 | +! | +
+ datanames = teal.transform::get_extract_datanames(data_extract_list) |
|
| 421 | +244 |
- )+ ) |
|
| 422 | +245 |
- } else {
+ }+ |
+ |
| 246 | ++ | + + | +|
| 247 | ++ |
+ ui_g_scatterplot <- function(id, ...) {
|
|
| 423 | +248 | ! |
- teal.code::eval_code(+ args <- list(...) |
| 424 | +249 | ! |
- qenv,+ ns <- NS(id) |
| 425 | +250 | ! |
- substitute(expr = ANL <- anl_name, env = list(anl_name = as.name(dataname))) # nolint+ is_single_dataset_value <- teal.transform::is_single_dataset( |
| 426 | -+ | ||
| 251 | +! |
- )+ args$x, args$y, args$color_by, args$size_by, args$row_facet, args$col_facet |
|
| 427 | +252 |
- }+ ) |
|
| 428 | +253 | ||
| 429 | +254 | ! |
- if (input$summary_type == "By Variable Levels" && !is.null(group_var) && !(group_var %in% selected_vars())) {
+ shiny::tagList( |
| 430 | +255 | ! |
- qenv <- teal.code::eval_code(+ include_css_files("custom"),
|
| 431 | +256 | ! |
- qenv,+ teal.widgets::standard_layout( |
| 432 | +257 | ! |
- substitute(+ output = teal.widgets::white_small_well( |
| 433 | +258 | ! |
- expr = ANL[[group_var]] <- anl_name[[group_var]], # nolint+ teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")),
|
| 434 | +259 | ! |
- env = list(group_var = group_var, anl_name = as.name(dataname))- |
-
| 435 | -- |
- )+ tags$h1(tags$strong("Selected points:"), class = "text-center font-150p"),
|
|
| 436 | -+ | ||
| 260 | +! |
- )+ teal.widgets::get_dt_rows(ns("data_table"), ns("data_table_rows")),
|
|
| 437 | -+ | ||
| 261 | +! |
- }+ DT::dataTableOutput(ns("data_table"), width = "100%")
|
|
| 438 | +262 |
-
+ ), |
|
| 439 | +263 | ! |
- new_col_name <- "**anyna**" # nolint variable assigned and used+ encoding = div( |
| 440 | +264 |
-
+ ### Reporter |
|
| 441 | +265 | ! |
- qenv <- teal.code::eval_code(+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 442 | -! | +||
| 266 | +
- qenv,+ ### |
||
| 443 | +267 | ! |
- substitute(+ tags$label("Encodings", class = "text-primary"),
|
| 444 | +268 | ! |
- expr =+ teal.transform::datanames_input(args[c("x", "y", "color_by", "size_by", "row_facet", "col_facet")]),
|
| 445 | +269 | ! |
- create_cols_labels <- function(cols, just_label = FALSE) {
+ teal.transform::data_extract_ui( |
| 446 | +270 | ! |
- column_labels <- column_labels_value+ id = ns("x"),
|
| 447 | +271 | ! |
- column_labels[is.na(column_labels) | length(column_labels) == 0] <- ""+ label = "X variable", |
| 448 | +272 | ! |
- if (just_label) {
+ data_extract_spec = args$x, |
| 449 | +273 | ! |
- labels <- column_labels[cols]+ is_single_dataset = is_single_dataset_value |
| 450 | +274 |
- } else {
+ ), |
|
| 451 | +275 | ! |
- labels <- ifelse(cols == new_col_name | cols == "", cols, paste0(column_labels[cols], " [", cols, "]"))- |
-
| 452 | -- |
- }+ checkboxInput(ns("log_x"), "Use log transformation", value = FALSE),
|
|
| 453 | +276 | ! |
- return(labels)- |
-
| 454 | -- |
- },+ conditionalPanel( |
|
| 455 | +277 | ! |
- env = list(+ condition = paste0("input['", ns("log_x"), "'] == true"),
|
| 456 | +278 | ! |
- new_col_name = new_col_name,+ radioButtons( |
| 457 | +279 | ! |
- column_labels_value = c(var_labels(data_r())[selected_vars()],+ ns("log_x_base"),
|
| 458 | +280 | ! |
- new_col_name = new_col_name- |
-
| 459 | -- |
- )- |
- |
| 460 | -- |
- )- |
- |
| 461 | -- |
- )+ label = NULL, |
|
| 462 | -+ | ||
| 281 | +! |
- )+ inline = TRUE, |
|
| 463 | +282 | ! |
- qenv+ choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
|
| 464 | +283 |
- })+ ) |
|
| 465 | +284 |
-
+ ), |
|
| 466 | +285 | ! |
- selected_vars <- reactive({
+ teal.transform::data_extract_ui( |
| 467 | +286 | ! |
- req(input$variables_select)+ id = ns("y"),
|
| 468 | +287 | ! |
- keys <- data_keys()+ label = "Y variable", |
| 469 | +288 | ! |
- vars <- unique(c(keys, input$variables_select))+ data_extract_spec = args$y, |
| 470 | +289 | ! |
- vars- |
-
| 471 | -- |
- })+ is_single_dataset = is_single_dataset_value |
|
| 472 | +290 |
-
+ ), |
|
| 473 | +291 | ! |
- vars_summary <- reactive({
+ checkboxInput(ns("log_y"), "Use log transformation", value = FALSE),
|
| 474 | +292 | ! |
- na_count <- data_r() %>%+ conditionalPanel( |
| 475 | +293 | ! |
- sapply(function(x) mean(is.na(x)), USE.NAMES = TRUE) %>%+ condition = paste0("input['", ns("log_y"), "'] == true"),
|
| 476 | +294 | ! |
- sort(decreasing = TRUE)- |
-
| 477 | -- |
-
+ radioButtons( |
|
| 478 | +295 | ! |
- tibble::tibble(+ ns("log_y_base"),
|
| 479 | +296 | ! |
- key = names(na_count),+ label = NULL, |
| 480 | +297 | ! |
- value = unname(na_count),+ inline = TRUE, |
| 481 | +298 | ! |
- label = cut(na_count, breaks = seq(from = 0, to = 1, by = 0.1), include.lowest = TRUE)- |
-
| 482 | -- |
- )+ choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
|
|
| 483 | +299 |
- })+ ) |
|
| 484 | +300 |
-
+ ), |
|
| 485 | +301 | ! |
- output$variables <- renderUI({
+ if (!is.null(args$color_by)) {
|
| 486 | +302 | ! |
- choices <- split(x = vars_summary()$key, f = vars_summary()$label, drop = TRUE) %>% rev()+ teal.transform::data_extract_ui( |
| 487 | +303 | ! |
- selected <- choices <- unname(unlist(choices))+ id = ns("color_by"),
|
| 488 | -+ | ||
| 304 | +! |
-
+ label = "Color by variable", |
|
| 489 | +305 | ! |
- teal.widgets::optionalSelectInput(+ data_extract_spec = args$color_by, |
| 490 | +306 | ! |
- session$ns("variables_select"),
+ is_single_dataset = is_single_dataset_value+ |
+
| 307 | ++ |
+ )+ |
+ |
| 308 | ++ |
+ }, |
|
| 491 | +309 | ! |
- label = "Select variables",+ if (!is.null(args$size_by)) {
|
| 492 | +310 | ! |
- label_help = HTML(paste0("Dataset: ", tags$code(dataname))),
+ teal.transform::data_extract_ui( |
| 493 | +311 | ! |
- choices = teal.transform::variable_choices(data_r(), choices),+ id = ns("size_by"),
|
| 494 | +312 | ! |
- selected = selected,+ label = "Size by variable", |
| 495 | +313 | ! |
- multiple = TRUE+ data_extract_spec = args$size_by, |
| 496 | -+ | ||
| 314 | +! |
- )+ is_single_dataset = is_single_dataset_value |
|
| 497 | +315 |
- })+ ) |
|
| 498 | +316 | - - | -|
| 499 | -! | -
- observeEvent(input$filter_na, {
+ }, |
|
| 500 | +317 | ! |
- choices <- vars_summary() %>%+ if (!is.null(args$row_facet)) {
|
| 501 | +318 | ! |
- dplyr::select(!!as.name("key")) %>%
+ teal.transform::data_extract_ui( |
| 502 | +319 | ! |
- getElement(name = 1)- |
-
| 503 | -- |
-
+ id = ns("row_facet"),
|
|
| 504 | +320 | ! |
- selected <- vars_summary() %>%+ label = "Row facetting", |
| 505 | +321 | ! |
- dplyr::filter(!!as.name("value") > 0) %>%
+ data_extract_spec = args$row_facet, |
| 506 | +322 | ! |
- dplyr::select(!!as.name("key")) %>%
+ is_single_dataset = is_single_dataset_value |
| 507 | -! | +||
| 323 | +
- getElement(name = 1)+ ) |
||
| 508 | +324 |
-
+ }, |
|
| 509 | +325 | ! |
- teal.widgets::updateOptionalSelectInput(+ if (!is.null(args$col_facet)) {
|
| 510 | +326 | ! |
- session = session,+ teal.transform::data_extract_ui( |
| 511 | +327 | ! |
- inputId = "variables_select",+ id = ns("col_facet"),
|
| 512 | +328 | ! |
- choices = teal.transform::variable_choices(data_r()),+ label = "Column facetting", |
| 513 | +329 | ! |
- selected = selected+ data_extract_spec = args$col_facet, |
| 514 | -+ | ||
| 330 | +! |
- )+ is_single_dataset = is_single_dataset_value |
|
| 515 | +331 |
- })+ ) |
|
| 516 | +332 |
-
+ }, |
|
| 517 | +333 | ! |
- output$group_by_var_ui <- renderUI({
+ teal.widgets::panel_group( |
| 518 | +334 | ! |
- all_choices <- teal.transform::variable_choices(data_r())+ teal.widgets::panel_item( |
| 519 | +335 | ! |
- cat_choices <- all_choices[!sapply(data_r(), function(x) is.numeric(x) || inherits(x, "POSIXct"))]+ title = "Plot settings", |
| 520 | +336 | ! |
- validate(+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
|
| 521 | +337 | ! |
- need(cat_choices, "Dataset does not have any non-numeric or non-datetime variables to use to group data with")+ teal.widgets::optionalSelectInput( |
| 522 | -+ | ||
| 338 | +! |
- )+ inputId = ns("shape"),
|
|
| 523 | +339 | ! |
- teal.widgets::optionalSelectInput(+ label = "Points shape:", |
| 524 | +340 | ! |
- session$ns("group_by_var"),
+ choices = args$shape, |
| 525 | +341 | ! |
- label = "Group by variable",+ selected = args$shape[1], |
| 526 | +342 | ! |
- choices = cat_choices,+ multiple = FALSE+ |
+
| 343 | ++ |
+ ), |
|
| 527 | +344 | ! |
- selected = `if`(+ colourpicker::colourInput(ns("color"), "Points color:", "black"),
|
| 528 | +345 | ! |
- is.null(isolate(input$group_by_var)),+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE, step = .1),
|
| 529 | +346 | ! |
- cat_choices[1],+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
|
| 530 | +347 | ! |
- isolate(input$group_by_var)+ checkboxInput(ns("add_density"), "Add marginal density", value = FALSE),
|
| 531 | -+ | ||
| 348 | +! |
- ),+ checkboxInput(ns("rug_plot"), "Include rug plot", value = FALSE),
|
|
| 532 | +349 | ! |
- multiple = FALSE,+ checkboxInput(ns("show_count"), "Show N (number of observations)", value = FALSE),
|
| 533 | +350 | ! |
- label_help = paste0("Dataset: ", dataname)
+ shinyjs::hidden(helpText(id = ns("line_msg"), "Trendline needs numeric X and Y variables")),
|
| 534 | -+ | ||
| 351 | +! |
- )+ teal.widgets::optionalSelectInput(ns("smoothing_degree"), "Smoothing degree", seq_len(args$max_deg)),
|
|
| 535 | -+ | ||
| 352 | +! |
- })+ shinyjs::hidden(teal.widgets::optionalSelectInput(ns("color_sub"), label = "", multiple = TRUE)),
|
|
| 536 | -+ | ||
| 353 | +! |
-
+ teal.widgets::optionalSliderInputValMinMax(ns("ci"), "Confidence", c(.95, .8, .99), ticks = FALSE),
|
|
| 537 | +354 | ! |
- output$group_by_vals_ui <- renderUI({
+ shinyjs::hidden(checkboxInput(ns("show_form"), "Show formula", value = TRUE)),
|
| 538 | +355 | ! |
- req(input$group_by_var)+ shinyjs::hidden(checkboxInput(ns("show_r2"), "Show adj-R Squared", value = TRUE)),
|
| 539 | -+ | ||
| 356 | +! |
-
+ uiOutput(ns("num_na_removed")),
|
|
| 540 | +357 | ! |
- choices <- teal.transform::value_choices(data_r(), input$group_by_var, input$group_by_var)+ div( |
| 541 | +358 | ! |
- prev_choices <- isolate(input$group_by_vals)+ id = ns("label_pos"),
|
| 542 | -+ | ||
| 359 | +! |
-
+ div(strong("Stats position")),
|
|
| 543 | -+ | ||
| 360 | +! |
- # determine selected value based on filtered data+ div(class = "inline-block w-10", helpText("Left")),
|
|
| 544 | -+ | ||
| 361 | +! |
- # display those previously selected values that are still available+ div( |
|
| 545 | +362 | ! |
- selected <- if (!is.null(prev_choices) && any(prev_choices %in% choices)) {
+ class = "inline-block w-70", |
| 546 | +363 | ! |
- prev_choices[match(choices[choices %in% prev_choices], prev_choices)]+ teal.widgets::optionalSliderInput( |
| 547 | +364 | ! |
- } else if (!is.null(prev_choices) &&+ ns("pos"),
|
| 548 | +365 | ! |
- !any(prev_choices %in% choices) &&+ label = NULL, |
| 549 | +366 | ! |
- isolate(prev_group_by_var()) == input$group_by_var) {
+ min = 0, max = 1, value = .99, ticks = FALSE, step = .01 |
| 550 | +367 |
- # if not any previously selected value is available and the grouping variable is the same,+ ) |
|
| 551 | +368 |
- # then display NULL+ ), |
|
| 552 | +369 | ! |
- NULL- |
-
| 553 | -- |
- } else {
+ div(class = "inline-block w-10", helpText("Right"))
|
|
| 554 | +370 |
- # if new grouping variable (i.e. not any previously selected value is available),+ ), |
|
| 555 | -+ | ||
| 371 | +! |
- # then display all choices+ teal.widgets::optionalSliderInput( |
|
| 556 | +372 | ! |
- choices+ ns("label_size"), "Stats font size",
|
| 557 | -+ | ||
| 373 | +! |
- }+ min = 3, max = 10, value = 5, ticks = FALSE, step = .1 |
|
| 558 | +374 |
-
+ ), |
|
| 559 | +375 | ! |
- prev_group_by_var(input$group_by_var) # set current group_by_var+ if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
|
| 560 | +376 | ! |
- validate(need(length(choices) < 100, "Please select group-by variable with fewer than 100 unique values"))+ checkboxInput(ns("free_scales"), "Free scales", value = FALSE)
|
| 561 | +377 |
-
+ }, |
|
| 562 | +378 | ! |
- teal.widgets::optionalSelectInput(+ selectInput( |
| 563 | +379 | ! |
- session$ns("group_by_vals"),
+ inputId = ns("ggtheme"),
|
| 564 | +380 | ! |
- label = "Filter levels",+ label = "Theme (by ggplot):", |
| 565 | +381 | ! |
- choices = choices,+ choices = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
|
| 566 | +382 | ! |
- selected = selected,+ selected = args$ggtheme, |
| 567 | +383 | ! |
- multiple = TRUE,+ multiple = FALSE |
| 568 | -! | +||
| 384 | +
- label_help = paste0("Dataset: ", dataname)
+ ) |
||
| 569 | +385 |
- )+ ) |
|
| 570 | +386 |
- })+ ) |
|
| 571 | +387 |
-
+ ), |
|
| 572 | +388 | ! |
- summary_plot_q <- reactive({
+ forms = tagList( |
| 573 | +389 | ! |
- req(input$summary_type == "Summary") # needed to trigger show r code update on tab change+ teal.widgets::verbatim_popup_ui(ns("warning"), button_label = "Show Warnings"),
|
| 574 | +390 | ! |
- teal::validate_has_data(data_r(), 1)+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
| 575 | +391 |
-
+ ), |
|
| 576 | +392 | ! |
- qenv <- common_code_q()+ pre_output = args$pre_output, |
| 577 | -+ | ||
| 393 | +! |
-
+ post_output = args$post_output |
|
| 578 | -! | +||
| 394 | +
- if (input$any_na) {
+ ) |
||
| 579 | -! | +||
| 395 | +
- new_col_name <- "**anyna**" # nolint (local variable is assigned and used)+ ) |
||
| 580 | -! | +||
| 396 | +
- qenv <- teal.code::eval_code(+ } |
||
| 581 | -! | +||
| 397 | +
- qenv,+ |
||
| 582 | -! | +||
| 398 | +
- substitute(+ srv_g_scatterplot <- function(id, |
||
| 583 | -! | +||
| 399 | +
- expr = ANL[[new_col_name]] <- ifelse(rowSums(is.na(ANL)) > 0, NA, FALSE), # nolint+ data, |
||
| 584 | -! | +||
| 400 | +
- env = list(new_col_name = new_col_name)+ reporter, |
||
| 585 | +401 |
- )+ filter_panel_api, |
|
| 586 | +402 |
- )+ x, |
|
| 587 | +403 |
- }+ y, |
|
| 588 | +404 |
-
+ color_by, |
|
| 589 | -! | +||
| 405 | +
- qenv <- teal.code::eval_code(+ size_by, |
||
| 590 | -! | +||
| 406 | +
- qenv,+ row_facet, |
||
| 591 | -! | +||
| 407 | +
- substitute(+ col_facet, |
||
| 592 | -! | +||
| 408 | +
- expr = analysis_vars <- setdiff(colnames(ANL), data_keys),+ plot_height, |
||
| 593 | -! | +||
| 409 | +
- env = list(data_keys = data_keys())+ plot_width, |
||
| 594 | +410 |
- )+ table_dec, |
|
| 595 | +411 |
- ) %>%+ ggplot2_args) {
|
|
| 596 | +412 | ! |
- teal.code::eval_code(+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 597 | +413 | ! |
- substitute(+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 598 | +414 | ! |
- expr = summary_plot_obs <- data_frame_call[, analysis_vars] %>%+ checkmate::assert_class(data, "tdata") |
| 599 | +415 | ! |
- dplyr::summarise_all(list(function(x) sum(is.na(x)))) %>%+ moduleServer(id, function(input, output, session) {
|
| 600 | +416 | ! |
- tidyr::pivot_longer(tidyselect::everything(), names_to = "col", values_to = "n_na") %>%+ data_extract <- list( |
| 601 | +417 | ! |
- dplyr::mutate(n_not_na = nrow(ANL) - n_na) %>%+ x = x, |
| 602 | +418 | ! |
- tidyr::pivot_longer(-col, names_to = "isna", values_to = "n") %>%+ y = y, |
| 603 | +419 | ! |
- dplyr::mutate(isna = isna == "n_na", n_pct = n / nrow(ANL) * 100),+ color_by = color_by, |
| 604 | +420 | ! |
- env = list(data_frame_call = if (!inherits(data_r(), "tbl_df")) {
+ size_by = size_by, |
| 605 | +421 | ! |
- quote(tibble::as_tibble(ANL))- |
-
| 606 | -- |
- } else {
+ row_facet = row_facet, |
|
| 607 | +422 | ! |
- quote(ANL)- |
-
| 608 | -- |
- })- |
- |
| 609 | -- |
- )+ col_facet = col_facet |
|
| 610 | +423 |
- ) %>%+ ) |
|
| 611 | +424 |
- # x axis ordering according to number of missing values and alphabet+ |
|
| 612 | +425 | ! |
- teal.code::eval_code(+ rule_diff <- function(other) {
|
| 613 | +426 | ! |
- quote(+ function(value) {
|
| 614 | +427 | ! |
- expr = x_levels <- dplyr::filter(summary_plot_obs, isna) %>%+ othervalue <- selector_list()[[other]]()[["select"]] |
| 615 | +428 | ! |
- dplyr::arrange(n_pct, dplyr::desc(col)) %>%+ if (!is.null(othervalue)) {
|
| 616 | +429 | ! |
- dplyr::pull(col) %>%+ if (identical(value, othervalue)) {
|
| 617 | +430 | ! |
- create_cols_labels()+ "Row and column facetting variables must be different." |
| 618 | +431 |
- )+ } |
|
| 619 | +432 |
- )+ } |
|
| 620 | +433 |
-
+ } |
|
| 621 | +434 |
- # always set "**anyna**" level as the last one+ } |
|
| 622 | -! | +||
| 435 | +
- if (isolate(input$any_na)) {
+
|
||
| 623 | +436 | ! |
- qenv <- teal.code::eval_code(+ selector_list <- teal.transform::data_extract_multiple_srv( |
| 624 | +437 | ! |
- qenv,+ data_extract = data_extract, |
| 625 | +438 | ! |
- quote(x_levels <- c(setdiff(x_levels, "**anyna**"), "**anyna**"))- |
-
| 626 | -- |
- )- |
- |
| 627 | -- |
- }- |
- |
| 628 | -- |
-
+ datasets = data, |
|
| 629 | +439 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ select_validation_rule = list( |
| 630 | +440 | ! |
- labs = list(x = "Variable", y = "Missing observations"),+ x = ~ if (length(.) != 1) "Please select exactly one x var.", |
| 631 | +441 | ! |
- theme = list(legend.position = "bottom", axis.text.x = quote(element_text(angle = 45, hjust = 1)))- |
-
| 632 | -- |
- )- |
- |
| 633 | -- |
-
+ y = ~ if (length(.) != 1) "Please select exactly one y var.", |
|
| 634 | +442 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ color_by = ~ if (length(.) > 1) "There cannot be more than 1 color variable.", |
| 635 | +443 | ! |
- user_plot = ggplot2_args[["Summary Obs"]],+ size_by = ~ if (length(.) > 1) "There cannot be more than 1 size variable.", |
| 636 | +444 | ! |
- user_default = ggplot2_args$default,+ row_facet = shinyvalidate::compose_rules( |
| 637 | +445 | ! |
- module_plot = dev_ggplot2_args+ shinyvalidate::sv_optional(), |
| 638 | -+ | ||
| 446 | +! |
- )+ rule_diff("col_facet")
|
|
| 639 | +447 |
-
+ ), |
|
| 640 | +448 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ col_facet = shinyvalidate::compose_rules( |
| 641 | +449 | ! |
- all_ggplot2_args,+ shinyvalidate::sv_optional(), |
| 642 | +450 | ! |
- ggtheme = input$ggtheme+ rule_diff("row_facet")
|
| 643 | +451 |
- )+ ) |
|
| 644 | +452 |
-
+ ) |
|
| 645 | -! | +||
| 453 | +
- qenv <- teal.code::eval_code(+ ) |
||
| 646 | -! | +||
| 454 | +
- qenv,+ |
||
| 647 | +455 | ! |
- substitute(+ iv_r <- reactive({
|
| 648 | +456 | ! |
- p1 <- summary_plot_obs %>%+ iv_facet <- shinyvalidate::InputValidator$new() |
| 649 | +457 | ! |
- ggplot() ++ iv <- shinyvalidate::InputValidator$new() |
| 650 | +458 | ! |
- aes(+ teal.transform::compose_and_enable_validators(iv, selector_list) |
| 651 | -! | +||
| 459 | +
- x = factor(create_cols_labels(col), levels = x_levels),+ }) |
||
| 652 | +460 | ! |
- y = n_pct,+ iv_facet <- shinyvalidate::InputValidator$new() |
| 653 | +461 | ! |
- fill = isna- |
-
| 654 | -- |
- ) ++ iv_facet$add_rule("add_density", ~ if (isTRUE(.) &&
|
|
| 655 | +462 | ! |
- geom_bar(position = "fill", stat = "identity") ++ (length(selector_list()$row_facet()$select) > 0L || |
| 656 | +463 | ! |
- scale_fill_manual(+ length(selector_list()$col_facet()$select) > 0L)) {
|
| 657 | +464 | ! |
- name = "",+ "Cannot add marginal density when Row or Column facetting has been selected" |
| 658 | -! | +||
| 465 | +
- values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
+ }) |
||
| 659 | +466 | ! |
- labels = c("Present", "Missing")
+ iv_facet$enable() |
| 660 | +467 |
- ) ++ |
|
| 661 | +468 | ! |
- scale_y_continuous(labels = scales::percent_format(), breaks = seq(0, 1, by = 0.1), expand = c(0, 0)) ++ anl_merged_input <- teal.transform::merge_expression_srv( |
| 662 | +469 | ! |
- geom_text(+ selector_list = selector_list, |
| 663 | +470 | ! |
- aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),
+ datasets = data, |
| 664 | +471 | ! |
- hjust = 1,+ join_keys = get_join_keys(data), |
| 665 | +472 | ! |
- color = "black"+ merge_function = "dplyr::inner_join" |
| 666 | +473 |
- ) ++ ) |
|
| 667 | -! | +||
| 474 | +
- labs ++ |
||
| 668 | +475 | ! |
- ggthemes ++ anl_merged_q <- reactive({
|
| 669 | +476 | ! |
- themes ++ req(anl_merged_input()) |
| 670 | +477 | ! |
- coord_flip(),+ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% |
| 671 | +478 | ! |
- env = list(+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) %>% |
| 672 | +479 | ! |
- labs = parsed_ggplot2_args$labs,+ teal.code::eval_code(quote(ANL)) # used to display table when running show-r-code code |
| 673 | -! | +||
| 480 | +
- themes = parsed_ggplot2_args$theme,+ })+ |
+ ||
| 481 | ++ | + | |
| 674 | +482 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme+ merged <- list( |
| 675 | -+ | ||
| 483 | +! |
- )+ anl_input_r = anl_merged_input, |
|
| 676 | -+ | ||
| 484 | +! |
- )+ anl_q_r = anl_merged_q |
|
| 677 | +485 |
- )+ ) |
|
| 678 | +486 | ||
| 679 | -! | -
- if (isTRUE(input$if_patients_plot)) {
- |
- |
| 680 | +487 | ! |
- qenv <- teal.code::eval_code(+ trend_line_is_applicable <- reactive({
|
| 681 | +488 | ! |
- qenv,+ ANL <- merged$anl_q_r()[["ANL"]] # nolint |
| 682 | +489 | ! |
- substitute(+ x_var <- as.vector(merged$anl_input_r()$columns_source$x) |
| 683 | +490 | ! |
- expr = parent_keys <- keys,+ y_var <- as.vector(merged$anl_input_r()$columns_source$y) |
| 684 | +491 | ! |
- env = list(keys = data_parent_keys())+ length(x_var) > 0 && length(y_var) > 0 && is.numeric(ANL[[x_var]]) && is.numeric(ANL[[y_var]]) |
| 685 | +492 |
- )+ }) |
|
| 686 | +493 |
- ) %>%+ |
|
| 687 | +494 | ! |
- teal.code::eval_code(quote(ndistinct_subjects <- dplyr::n_distinct(ANL[, parent_keys]))) %>%+ add_trend_line <- reactive({
|
| 688 | +495 | ! |
- teal.code::eval_code(+ smoothing_degree <- as.integer(input$smoothing_degree) |
| 689 | +496 | ! |
- quote(+ trend_line_is_applicable() && length(smoothing_degree) > 0 |
| 690 | -! | +||
| 497 | +
- summary_plot_patients <- ANL[, c(parent_keys, analysis_vars)] %>%+ }) |
||
| 691 | -! | +||
| 498 | +
- dplyr::group_by_at(parent_keys) %>%+ |
||
| 692 | +499 | ! |
- dplyr::summarise_all(anyNA) %>%+ if (!is.null(color_by)) {
|
| 693 | +500 | ! |
- tidyr::pivot_longer(cols = !tidyselect::all_of(parent_keys), names_to = "col", values_to = "anyna") %>%+ observeEvent( |
| 694 | +501 | ! |
- dplyr::group_by_at(c("col")) %>%
+ eventExpr = merged$anl_input_r()$columns_source$color_by, |
| 695 | +502 | ! |
- dplyr::summarise(count_na = sum(anyna)) %>%+ handlerExpr = {
|
| 696 | +503 | ! |
- dplyr::mutate(count_not_na = ndistinct_subjects - count_na) %>%+ color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by) |
| 697 | +504 | ! |
- tidyr::pivot_longer(-c(col), names_to = "isna", values_to = "n") %>%+ if (length(color_by_var) > 0) {
|
| 698 | +505 | ! |
- dplyr::mutate(isna = isna == "count_na", n_pct = n / ndistinct_subjects * 100) %>%+ shinyjs::hide("color")
+ |
+
| 506 | ++ |
+ } else {
|
|
| 699 | +507 | ! |
- dplyr::arrange_at(c("isna", "n"), .funs = dplyr::desc)
+ shinyjs::show("color")
|
| 700 | +508 |
- )+ } |
|
| 701 | +509 |
- )+ } |
|
| 702 | +510 | ++ |
+ )+ |
+
| 511 | ++ |
+ }+ |
+ |
| 512 | |||
| 703 | +513 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ output$num_na_removed <- renderUI({
|
| 704 | +514 | ! |
- labs = list(x = "", y = "Missing patients"),+ if (add_trend_line()) {
|
| 705 | +515 | ! |
- theme = list(+ ANL <- merged$anl_q_r()[["ANL"]] # nolint |
| 706 | +516 | ! |
- legend.position = "bottom",+ x_var <- as.vector(merged$anl_input_r()$columns_source$x) |
| 707 | +517 | ! |
- axis.text.x = quote(element_text(angle = 45, hjust = 1)),+ y_var <- as.vector(merged$anl_input_r()$columns_source$y) |
| 708 | +518 | ! |
- axis.text.y = quote(element_blank())+ if ((num_total_na <- nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)]))) > 0) {
+ |
+
| 519 | +! | +
+ shiny::tags$div(paste(num_total_na, "row(s) with missing values were removed"), shiny::tags$hr()) |
|
| 709 | +520 |
- )+ } |
|
| 710 | +521 |
- )+ } |
|
| 711 | +522 | ++ |
+ })+ |
+
| 523 | |||
| 712 | +524 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ observeEvent( |
| 713 | +525 | ! |
- user_plot = ggplot2_args[["Summary Patients"]],+ eventExpr = merged$anl_input_r()$columns_source[c("col_facet", "row_facet")],
|
| 714 | +526 | ! |
- user_default = ggplot2_args$default,+ handlerExpr = {
|
| 715 | +527 | ! |
- module_plot = dev_ggplot2_args+ if (length(merged$anl_input_r()$columns_source$col_facet) == 0 && |
| 716 | -+ | ||
| 528 | +! |
- )+ length(merged$anl_input_r()$columns_source$row_facet) == 0) {
+ |
+ |
| 529 | +! | +
+ shinyjs::hide("free_scales")
|
|
| 717 | +530 |
-
+ } else {
|
|
| 718 | +531 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ shinyjs::show("free_scales")
|
| 719 | -! | +||
| 532 | +
- all_ggplot2_args,+ } |
||
| 720 | -! | +||
| 533 | +
- ggtheme = input$ggtheme+ } |
||
| 721 | +534 |
- )+ ) |
|
| 722 | +535 | ||
| 723 | +536 | ! |
- qenv <- teal.code::eval_code(+ output_q <- reactive({
|
| 724 | +537 | ! |
- qenv,+ teal::validate_inputs(iv_r(), iv_facet)+ |
+
| 538 | ++ | + | |
| 725 | +539 | ! |
- substitute(+ ANL <- merged$anl_q_r()[["ANL"]] # nolint+ |
+
| 540 | ++ | + | |
| 726 | +541 | ! |
- p2 <- summary_plot_patients %>%+ x_var <- as.vector(merged$anl_input_r()$columns_source$x) |
| 727 | +542 | ! |
- ggplot() ++ y_var <- as.vector(merged$anl_input_r()$columns_source$y) |
| 728 | +543 | ! |
- aes_(+ color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by) |
| 729 | +544 | ! |
- x = ~ factor(create_cols_labels(col), levels = x_levels),+ size_by_var <- as.vector(merged$anl_input_r()$columns_source$size_by) |
| 730 | +545 | ! |
- y = ~n_pct,+ row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
|
| 731 | +546 | ! |
- fill = ~isna+ character(0) |
| 732 | +547 |
- ) ++ } else {
|
|
| 733 | +548 | ! |
- geom_bar(alpha = 1, stat = "identity", position = "fill") ++ as.vector(merged$anl_input_r()$columns_source$row_facet) |
| 734 | -! | +||
| 549 | +
- scale_y_continuous(labels = scales::percent_format(), breaks = seq(0, 1, by = 0.1), expand = c(0, 0)) ++ } |
||
| 735 | +550 | ! |
- scale_fill_manual(+ col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
|
| 736 | +551 | ! |
- name = "",+ character(0) |
| 737 | -! | +||
| 552 | +
- values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
+ } else {
|
||
| 738 | +553 | ! |
- labels = c("Present", "Missing")
+ as.vector(merged$anl_input_r()$columns_source$col_facet) |
| 739 | +554 |
- ) ++ } |
|
| 740 | +555 | ! |
- geom_text(+ alpha <- input$alpha # nolint |
| 741 | +556 | ! |
- aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),
+ size <- input$size # nolint |
| 742 | +557 | ! |
- hjust = 1,+ rotate_xaxis_labels <- input$rotate_xaxis_labels # nolint |
| 743 | +558 | ! |
- color = "black"- |
-
| 744 | -- |
- ) ++ add_density <- input$add_density |
|
| 745 | +559 | ! |
- labs ++ ggtheme <- input$ggtheme |
| 746 | +560 | ! |
- ggthemes ++ rug_plot <- input$rug_plot |
| 747 | +561 | ! |
- themes ++ color <- input$color # nolint |
| 748 | +562 | ! |
- coord_flip(),+ shape <- `if`(is.null(input$shape) || identical(input$shape, ""), "circle", input$shape) # nolint |
| 749 | +563 | ! |
- env = list(+ smoothing_degree <- as.integer(input$smoothing_degree) |
| 750 | +564 | ! |
- labs = parsed_ggplot2_args$labs,+ ci <- input$ci # nolint |
| 751 | -! | +||
| 565 | +
- themes = parsed_ggplot2_args$theme,+ |
||
| 752 | +566 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme- |
-
| 753 | -- |
- )+ log_x <- input$log_x |
|
| 754 | -+ | ||
| 567 | +! |
- )+ log_y <- input$log_y |
|
| 755 | +568 |
- ) %>%+ |
|
| 756 | +569 | ! |
- teal.code::eval_code(+ validate(need( |
| 757 | +570 | ! |
- quote({
+ length(row_facet_name) == 0 || inherits(ANL[[row_facet_name]], c("character", "factor", "Date", "integer")),
|
| 758 | +571 | ! |
- g1 <- ggplotGrob(p1)+ "`Row facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" |
| 759 | -! | +||
| 572 | +
- g2 <- ggplotGrob(p2)+ )) |
||
| 760 | +573 | ! |
- g <- gridExtra::gtable_cbind(g1, g2, size = "first")+ validate(need( |
| 761 | +574 | ! |
- g$heights <- grid::unit.pmax(g1$heights, g2$heights)+ length(col_facet_name) == 0 || inherits(ANL[[col_facet_name]], c("character", "factor", "Date", "integer")),
|
| 762 | +575 | ! |
- grid::grid.newpage()- |
-
| 763 | -- |
- })+ "`Column facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" |
|
| 764 | +576 |
- )+ )) |
|
| 765 | +577 |
- } else {
+
|
|
| 766 | +578 | ! |
- qenv <- teal.code::eval_code(+ if (add_density && length(color_by_var) > 0) {
|
| 767 | +579 | ! |
- qenv,+ validate(need( |
| 768 | +580 | ! |
- quote({
+ !is.numeric(ANL[[color_by_var]]), |
| 769 | +581 | ! |
- g <- ggplotGrob(p1)+ "Marginal plots cannot be produced when the points are colored by numeric variables. |
| 770 | +582 | ! |
- grid::grid.newpage()+ \n Uncheck the 'Add marginal density' checkbox to display the plot." |
| 771 | +583 |
- })+ )) |
|
| 772 | -+ | ||
| 584 | +! |
- )+ validate(need( |
|
| 773 | -+ | ||
| 585 | +! |
- }+ !(inherits(ANL[[color_by_var]], "Date") || |
|
| 774 | -+ | ||
| 586 | +! |
-
+ inherits(ANL[[color_by_var]], "POSIXct") || |
|
| 775 | +587 | ! |
- teal.code::eval_code(+ inherits(ANL[[color_by_var]], "POSIXlt")), |
| 776 | +588 | ! |
- qenv,+ "Marginal plots cannot be produced when the points are colored by Date or POSIX variables. |
| 777 | +589 | ! |
- quote(grid::grid.draw(g))+ \n Uncheck the 'Add marginal density' checkbox to display the plot." |
| 778 | +590 |
- )+ )) |
|
| 779 | +591 |
- })+ } |
|
| 780 | +592 | ||
| 781 | +593 | ! |
- summary_plot_r <- reactive(summary_plot_q()[["g"]])+ teal::validate_has_data(ANL[, c(x_var, y_var)], 10, complete = TRUE, allow_inf = FALSE) |
| 782 | +594 | ||
| 783 | +595 | +! | +
+ if (log_x) {
+ |
+
| 596 | ! |
- combination_cutoff_q <- reactive({
+ validate( |
|
| 784 | +597 | ! |
- req(common_code_q())+ need( |
| 785 | +598 | ! |
- teal.code::eval_code(+ is.numeric(ANL[[x_var]]) && all( |
| 786 | +599 | ! |
- common_code_q(),+ ANL[[x_var]] > 0 | is.na(ANL[[x_var]]) |
| 787 | -! | +||
| 600 | +
- quote(+ ), |
||
| 788 | +601 | ! |
- combination_cutoff <- ANL %>%+ "X variable can only be log transformed if variable is numeric and all values are positive." |
| 789 | -! | +||
| 602 | +
- dplyr::mutate_all(is.na) %>%+ ) |
||
| 790 | -! | +||
| 603 | +
- dplyr::group_by_all() %>%+ )+ |
+ ||
| 604 | ++ |
+ } |
|
| 791 | +605 | ! |
- dplyr::tally() %>%+ if (log_y) {
|
| 792 | +606 | ! |
- dplyr::ungroup()+ validate( |
| 793 | -+ | ||
| 607 | +! |
- )+ need( |
|
| 794 | -+ | ||
| 608 | +! |
- )+ is.numeric(ANL[[y_var]]) && all( |
|
| 795 | -+ | ||
| 609 | +! |
- })+ ANL[[y_var]] > 0 | is.na(ANL[[y_var]]) |
|
| 796 | +610 |
-
+ ), |
|
| 797 | +611 | ! |
- output$cutoff <- renderUI({
+ "Y variable can only be log transformed if variable is numeric and all values are positive." |
| 798 | -! | +||
| 612 | +
- x <- combination_cutoff_q()[["combination_cutoff"]]$n+ ) |
||
| 799 | +613 |
-
+ ) |
|
| 800 | +614 |
- # select 10-th from the top+ } |
|
| 801 | -! | +||
| 615 | +
- n <- length(x)+ |
||
| 802 | +616 | ! |
- idx <- max(1, n - 10)+ facet_cl <- facet_ggplot_call( |
| 803 | +617 | ! |
- prev_value <- isolate(input$combination_cutoff)+ row_facet_name, |
| 804 | +618 | ! |
- value <- `if`(+ col_facet_name, |
| 805 | +619 | ! |
- is.null(prev_value) || prev_value > max(x) || prev_value < min(x),+ free_x_scales = isTRUE(input$free_scales), |
| 806 | +620 | ! |
- sort(x, partial = idx)[idx], prev_value+ free_y_scales = isTRUE(input$free_scales) |
| 807 | +621 |
) |
|
| 808 | +622 | ||
| 809 | +623 | ! |
- teal.widgets::optionalSliderInputValMinMax(+ point_sizes <- if (length(size_by_var) > 0) {
|
| 810 | +624 | ! |
- session$ns("combination_cutoff"),
+ validate(need(is.numeric(ANL[[size_by_var]]), "Variable to size by must be numeric")) |
| 811 | +625 | ! |
- "Combination cut-off",+ substitute( |
| 812 | +626 | ! |
- c(value, range(x))+ expr = size * ANL[[size_by_var]] / max(ANL[[size_by_var]], na.rm = TRUE), |
| 813 | -+ | ||
| 627 | +! |
- )+ env = list(size = size, size_by_var = size_by_var) |
|
| 814 | +628 |
- })+ ) |
|
| 815 | +629 |
-
+ } else {
|
|
| 816 | +630 | ! |
- combination_plot_q <- reactive({
+ size |
| 817 | -! | +||
| 631 | +
- req(input$summary_type == "Combinations", input$combination_cutoff, combination_cutoff_q())+ }+ |
+ ||
| 632 | ++ | + | |
| 818 | +633 | ! |
- teal::validate_has_data(data_r(), 1)+ plot_q <- merged$anl_q_r() |
| 819 | +634 | ||
| 820 | +635 | ! |
- qenv <- teal.code::eval_code(+ if (log_x) {
|
| 821 | +636 | ! |
- combination_cutoff_q(),+ log_x_fn <- input$log_x_base |
| 822 | +637 | ! |
- substitute(+ plot_q <- teal.code::eval_code( |
| 823 | +638 | ! |
- expr = data_combination_plot_cutoff <- combination_cutoff %>%+ object = plot_q, |
| 824 | +639 | ! |
- dplyr::filter(n >= combination_cutoff_value) %>%+ code = substitute( |
| 825 | +640 | ! |
- dplyr::mutate(id = rank(-n, ties.method = "first")) %>%+ expr = ANL[, log_x_var] <- log_x_fn(ANL[, x_var]), # nolint |
| 826 | +641 | ! |
- tidyr::pivot_longer(-c(n, id), names_to = "key", values_to = "value") %>%+ env = list( |
| 827 | +642 | ! |
- dplyr::arrange(n),+ x_var = x_var, |
| 828 | +643 | ! |
- env = list(combination_cutoff_value = input$combination_cutoff)+ log_x_fn = as.name(log_x_fn), |
| 829 | -+ | ||
| 644 | +! |
- )+ log_x_var = paste0(log_x_fn, "_", x_var) |
|
| 830 | +645 |
- )+ ) |
|
| 831 | +646 |
-
+ ) |
|
| 832 | +647 |
- # find keys in dataset not selected in the UI and remove them from dataset+ ) |
|
| 833 | -! | +||
| 648 | +
- keys_not_selected <- setdiff(data_keys(), input$variables_select)+ } |
||
| 834 | -! | +||
| 649 | +
- if (length(keys_not_selected) > 0) {
+
|
||
| 835 | +650 | ! |
- qenv <- teal.code::eval_code(+ if (log_y) {
|
| 836 | +651 | ! |
- qenv,+ log_y_fn <- input$log_y_base |
| 837 | +652 | ! |
- substitute(+ plot_q <- teal.code::eval_code( |
| 838 | +653 | ! |
- expr = data_combination_plot_cutoff <- data_combination_plot_cutoff %>%+ object = plot_q, |
| 839 | +654 | ! |
- dplyr::filter(!key %in% keys_not_selected),+ code = substitute( |
| 840 | +655 | ! |
- env = list(keys_not_selected = keys_not_selected)- |
-
| 841 | -- |
- )- |
- |
| 842 | -- |
- )- |
- |
| 843 | -- |
- }- |
- |
| 844 | -- |
-
+ expr = ANL[, log_y_var] <- log_y_fn(ANL[, y_var]), # nolint |
|
| 845 | +656 | ! |
- qenv <- teal.code::eval_code(+ env = list( |
| 846 | +657 | ! |
- qenv,+ y_var = y_var, |
| 847 | +658 | ! |
- quote(+ log_y_fn = as.name(log_y_fn), |
| 848 | +659 | ! |
- labels <- data_combination_plot_cutoff %>%+ log_y_var = paste0(log_y_fn, "_", y_var) |
| 849 | -! | +||
| 660 | +
- dplyr::filter(key == key[[1]]) %>%+ ) |
||
| 850 | -! | +||
| 661 | +
- getElement(name = 1)+ ) |
||
| 851 | +662 |
) |
|
| 852 | +663 |
- )+ } |
|
| 853 | +664 | ||
| 854 | +665 | ! |
- dev_ggplot2_args1 <- teal.widgets::ggplot2_args(+ pre_pro_anl <- if (input$show_count) {
|
| 855 | +666 | ! |
- labs = list(x = "", y = ""),+ paste0( |
| 856 | +667 | ! |
- theme = list(+ "ANL %>% dplyr::group_by(",
|
| 857 | +668 | ! |
- legend.position = "bottom",+ paste( |
| 858 | +669 | ! |
- axis.text.x = quote(element_blank())- |
-
| 859 | -- |
- )- |
- |
| 860 | -- |
- )+ c( |
|
| 861 | -+ | ||
| 670 | +! |
-
+ if (length(color_by_var) > 0 && inherits(ANL[[color_by_var]], c("factor", "character"))) color_by_var,
|
|
| 862 | +671 | ! |
- all_ggplot2_args1 <- teal.widgets::resolve_ggplot2_args(+ row_facet_name, |
| 863 | +672 | ! |
- user_plot = ggplot2_args[["Combinations Hist"]],+ col_facet_name |
| 864 | -! | +||
| 673 | +
- user_default = ggplot2_args$default,+ ), |
||
| 865 | +674 | ! |
- module_plot = dev_ggplot2_args1+ collapse = ", " |
| 866 | +675 |
- )+ ), |
|
| 867 | -+ | ||
| 676 | +! |
-
+ ") %>% dplyr::mutate(n = dplyr::n()) %>% dplyr::ungroup()" |
|
| 868 | -! | +||
| 677 | +
- parsed_ggplot2_args1 <- teal.widgets::parse_ggplot2_args(+ ) |
||
| 869 | -! | +||
| 678 | +
- all_ggplot2_args1,+ } else {
|
||
| 870 | +679 | ! |
- ggtheme = "void"+ "ANL" |
| 871 | +680 |
- )+ } |
|
| 872 | +681 | ||
| 873 | +682 | ! |
- dev_ggplot2_args2 <- teal.widgets::ggplot2_args(+ plot_call <- substitute(expr = pre_pro_anl %>% ggplot(), env = list(pre_pro_anl = str2lang(pre_pro_anl))) |
| 874 | -! | +||
| 683 | +
- labs = list(x = "", y = ""),+ |
||
| 875 | +684 | ! |
- theme = list(+ plot_call <- if (length(color_by_var) == 0) {
|
| 876 | +685 | ! |
- legend.position = "bottom",+ substitute( |
| 877 | +686 | ! |
- axis.text.x = quote(element_blank()),+ expr = plot_call + |
| 878 | +687 | ! |
- axis.ticks = quote(element_blank()),+ ggplot2::aes(x = x_name, y = y_name) + |
| 879 | +688 | ! |
- panel.grid.major = quote(element_blank())- |
-
| 880 | -- |
- )- |
- |
| 881 | -- |
- )- |
- |
| 882 | -- |
-
+ ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value, color = color_value), |
|
| 883 | +689 | ! |
- all_ggplot2_args2 <- teal.widgets::resolve_ggplot2_args(+ env = list( |
| 884 | +690 | ! |
- user_plot = ggplot2_args[["Combinations Main"]],+ plot_call = plot_call, |
| 885 | +691 | ! |
- user_default = ggplot2_args$default,+ x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var), |
| 886 | +692 | ! |
- module_plot = dev_ggplot2_args2+ y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var), |
| 887 | -+ | ||
| 693 | +! |
- )+ alpha_value = alpha, |
|
| 888 | -+ | ||
| 694 | +! |
-
+ point_sizes = point_sizes, |
|
| 889 | +695 | ! |
- parsed_ggplot2_args2 <- teal.widgets::parse_ggplot2_args(+ shape_value = shape, |
| 890 | +696 | ! |
- all_ggplot2_args2,+ color_value = color |
| 891 | -! | +||
| 697 | +
- ggtheme = input$ggtheme+ ) |
||
| 892 | +698 |
- )+ ) |
|
| 893 | +699 |
-
+ } else {
|
|
| 894 | +700 | ! |
- teal.code::eval_code(+ substitute( |
| 895 | +701 | ! |
- qenv,+ expr = plot_call + |
| 896 | +702 | ! |
- substitute(+ ggplot2::aes(x = x_name, y = y_name, color = color_by_var_name) + |
| 897 | +703 | ! |
- expr = {
+ ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value), |
| 898 | +704 | ! |
- p1 <- data_combination_plot_cutoff %>%+ env = list( |
| 899 | +705 | ! |
- dplyr::select(id, n) %>%+ plot_call = plot_call, |
| 900 | +706 | ! |
- dplyr::distinct() %>%+ x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var), |
| 901 | +707 | ! |
- ggplot(aes(x = id, y = n)) ++ y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var), |
| 902 | +708 | ! |
- geom_bar(stat = "identity", fill = c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]) +
+ color_by_var_name = as.name(color_by_var), |
| 903 | +709 | ! |
- geom_text(aes(label = n), position = position_dodge(width = 0.9), vjust = -0.25) ++ alpha_value = alpha, |
| 904 | +710 | ! |
- ylim(c(0, max(data_combination_plot_cutoff$n) * 1.5)) ++ point_sizes = point_sizes, |
| 905 | +711 | ! |
- labs1 ++ shape_value = shape |
| 906 | -! | +||
| 712 | +
- ggthemes1 ++ ) |
||
| 907 | -! | +||
| 713 | +
- themes1+ ) |
||
| 908 | +714 |
-
+ } |
|
| 909 | -! | +||
| 715 | +
- graph_number_rows <- length(unique(data_combination_plot_cutoff$id))+ |
||
| 910 | +716 | ! |
- graph_number_cols <- nrow(data_combination_plot_cutoff) / graph_number_rows+ if (rug_plot) plot_call <- substitute(expr = plot_call + geom_rug(), env = list(plot_call = plot_call)) |
| 911 | +717 | ||
| 912 | +718 | ! |
- p2 <- data_combination_plot_cutoff %>% ggplot() ++ plot_label_generator <- function(rhs_formula = quote(y ~ 1), |
| 913 | +719 | ! |
- aes(x = create_cols_labels(key), y = id - 0.5, fill = value) ++ show_form = input$show_form, |
| 914 | +720 | ! |
- geom_tile(alpha = 0.85, height = 0.95) ++ show_r2 = input$show_r2, |
| 915 | +721 | ! |
- scale_fill_manual(+ show_count = input$show_count, |
| 916 | +722 | ! |
- name = "",+ pos = input$pos, |
| 917 | +723 | ! |
- values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
+ label_size = input$label_size) {
|
| 918 | +724 | ! |
- labels = c("Present", "Missing")
+ stopifnot(sum(show_form, show_r2, show_count) >= 1) |
| 919 | -+ | ||
| 725 | +! |
- ) ++ aes_label <- paste0( |
|
| 920 | +726 | ! |
- geom_hline(yintercept = seq_len(1 + graph_number_rows) - 1) ++ "aes(",
|
| 921 | +727 | ! |
- geom_vline(xintercept = seq_len(1 + graph_number_cols) - 0.5, linetype = "dotted") ++ if (show_count) "n = n, ", |
| 922 | +728 | ! |
- coord_flip() ++ "label = ", |
| 923 | +729 | ! |
- labs2 ++ if (sum(show_form, show_r2, show_count) > 1) "paste(",
|
| 924 | +730 | ! |
- ggthemes2 ++ paste( |
| 925 | +731 | ! |
- themes2+ c( |
| 926 | -+ | ||
| 732 | +! |
-
+ if (show_form) "stat(eq.label)", |
|
| 927 | +733 | ! |
- g1 <- ggplotGrob(p1)+ if (show_r2) "stat(adj.rr.label)", |
| 928 | +734 | ! |
- g2 <- ggplotGrob(p2)+ if (show_count) "paste('N ~`=`~', n)"
|
| 929 | +735 | - - | -|
| 930 | -! | -
- g <- gridExtra::gtable_rbind(g1, g2, size = "last")+ ), |
|
| 931 | +736 | ! |
- g$heights[7] <- grid::unit(0.2, "null") # rescale to get the bar chart smaller+ collapse = ", " |
| 932 | -! | +||
| 737 | +
- grid::grid.newpage()+ ), |
||
| 933 | +738 | ! |
- grid::grid.draw(g)+ if (sum(show_form, show_r2, show_count) > 1) ", sep = '*\", \"*'))" else ")" |
| 934 | +739 |
- },+ ) |
|
| 935 | +740 | ! |
- env = list(+ label_geom <- substitute( |
| 936 | +741 | ! |
- labs1 = parsed_ggplot2_args1$labs,+ expr = ggpmisc::stat_poly_eq( |
| 937 | +742 | ! |
- themes1 = parsed_ggplot2_args1$theme,+ mapping = aes_label, |
| 938 | +743 | ! |
- ggthemes1 = parsed_ggplot2_args1$ggtheme,+ formula = rhs_formula, |
| 939 | +744 | ! |
- labs2 = parsed_ggplot2_args2$labs,+ parse = TRUE, |
| 940 | +745 | ! |
- themes2 = parsed_ggplot2_args2$theme,+ label.x = pos, |
| 941 | +746 | ! |
- ggthemes2 = parsed_ggplot2_args2$ggtheme+ size = label_size |
| 942 | +747 |
- )+ ), |
|
| 943 | -+ | ||
| 748 | +! |
- )+ env = list( |
|
| 944 | -+ | ||
| 749 | +! |
- )+ rhs_formula = rhs_formula, |
|
| 945 | -+ | ||
| 750 | +! |
- })+ pos = pos, |
|
| 946 | -+ | ||
| 751 | +! |
-
+ aes_label = str2lang(aes_label), |
|
| 947 | +752 | ! |
- combination_plot_r <- reactive(combination_plot_q()[["g"]])+ label_size = label_size |
| 948 | +753 |
-
+ ) |
|
| 949 | -! | +||
| 754 | +
- summary_table_q <- reactive({
+ ) |
||
| 950 | +755 | ! |
- req(+ substitute( |
| 951 | +756 | ! |
- input$summary_type == "By Variable Levels", # needed to trigger show r code update on tab change+ expr = plot_call + label_geom, |
| 952 | +757 | ! |
- common_code_q()+ env = list( |
| 953 | -+ | ||
| 758 | +! |
- )+ plot_call = plot_call, |
|
| 954 | +759 | ! |
- teal::validate_has_data(data_r(), 1)+ label_geom = label_geom |
| 955 | +760 |
-
+ ) |
|
| 956 | +761 |
- # extract the ANL dataset for use in further validation+ ) |
|
| 957 | -! | +||
| 762 | +
- anl <- common_code_q()[["ANL"]]+ } |
||
| 958 | +763 | ||
| 959 | -! | -
- group_var <- input$group_by_var- |
- |
| 960 | +764 | ! |
- validate(+ if (trend_line_is_applicable()) {
|
| 961 | +765 | ! |
- need(+ shinyjs::hide("line_msg")
|
| 962 | +766 | ! |
- is.null(group_var) ||+ shinyjs::show("smoothing_degree")
|
| 963 | +767 | ! |
- length(unique(anl[[group_var]])) < 100,+ if (!add_trend_line()) {
|
| 964 | +768 | ! |
- "Please select group-by variable with fewer than 100 unique values"- |
-
| 965 | -- |
- )- |
- |
| 966 | -- |
- )- |
- |
| 967 | -- |
-
+ shinyjs::hide("ci")
|
|
| 968 | +769 | ! |
- group_vals <- input$group_by_vals # nolint (local variable is assigned and used)+ shinyjs::hide("color_sub")
|
| 969 | +770 | ! |
- variables_select <- input$variables_select+ shinyjs::hide("show_form")
|
| 970 | +771 | ! |
- vars <- unique(variables_select, group_var)+ shinyjs::hide("show_r2")
|
| 971 | +772 | ! |
- count_type <- input$count_type # nolint (local variable is assigned and used)- |
-
| 972 | -- |
-
+ if (input$show_count) {
|
|
| 973 | +773 | ! |
- if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {
+ plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE) |
| 974 | +774 | ! |
- variables <- selected_vars() # nolint (local variable is assigned and used)- |
-
| 975 | -- |
- } else {
+ shinyjs::show("label_pos")
|
|
| 976 | +775 | ! |
- variables <- colnames(anl)- |
-
| 977 | -- |
- }+ shinyjs::show("label_size")
|
|
| 978 | +776 |
-
+ } else {
|
|
| 979 | +777 | ! |
- summ_fn <- if (input$count_type == "counts") {
+ shinyjs::hide("label_pos")
|
| 980 | +778 | ! |
- function(x) sum(is.na(x))+ shinyjs::hide("label_size")
|
| 981 | +779 |
- } else {
- |
- |
| 982 | -! | -
- function(x) round(sum(is.na(x)) / length(x), 4)+ } |
|
| 983 | +780 |
- }+ } else {
|
|
| 984 | -+ | ||
| 781 | +! |
-
+ shinyjs::show("ci")
|
|
| 985 | +782 | ! |
- qenv <- common_code_q()+ shinyjs::show("show_form")
|
| 986 | -+ | ||
| 783 | +! |
-
+ shinyjs::show("show_r2")
|
|
| 987 | +784 | ! |
- if (!is.null(group_var)) {
+ if (nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)])) > 0) {
|
| 988 | +785 | ! |
- qenv <- teal.code::eval_code(+ plot_q <- teal.code::eval_code( |
| 989 | +786 | ! |
- qenv,+ plot_q, |
| 990 | +787 | ! |
- substitute(+ substitute( |
| 991 | +788 | ! |
- expr = {
+ expr = ANL <- dplyr::filter(ANL, !is.na(x_var) & !is.na(y_var)), # nolint |
| 992 | +789 | ! |
- summary_data <- ANL %>%+ env = list(x_var = as.name(x_var), y_var = as.name(y_var))+ |
+
| 790 | ++ |
+ )+ |
+ |
| 791 | ++ |
+ )+ |
+ |
| 792 | ++ |
+ } |
|
| 993 | +793 | ! |
- dplyr::mutate(group_var_name := forcats::fct_na_value_to_level(as.factor(group_var_name), "NA")) %>%+ rhs_formula <- substitute( |
| 994 | +794 | ! |
- dplyr::group_by_at(group_var) %>%+ expr = y ~ poly(x, smoothing_degree, raw = TRUE), |
| 995 | +795 | ! |
- dplyr::filter(group_var_name %in% group_vals)+ env = list(smoothing_degree = smoothing_degree) |
| 996 | +796 |
-
+ ) |
|
| 997 | +797 | ! |
- count_data <- dplyr::summarise(summary_data, n = dplyr::n())+ if (input$show_form || input$show_r2 || input$show_count) {
|
| 998 | -+ | ||
| 798 | +! |
-
+ plot_call <- plot_label_generator(rhs_formula = rhs_formula) |
|
| 999 | +799 | ! |
- summary_data <- dplyr::summarise_all(summary_data, summ_fn) %>%+ shinyjs::show("label_pos")
|
| 1000 | +800 | ! |
- dplyr::mutate(group_var_name := paste0(group_var, ":", group_var_name, "(N=", count_data$n, ")")) %>%+ shinyjs::show("label_size")
|
| 1001 | -! | +||
| 801 | +
- tidyr::pivot_longer(!tidyselect::all_of(group_var), names_to = "Variable", values_to = "out") %>%+ } else {
|
||
| 1002 | +802 | ! |
- tidyr::pivot_wider(names_from = group_var, values_from = "out") %>%+ shinyjs::hide("label_pos")
|
| 1003 | +803 | ! |
- dplyr::mutate(`Variable label` = create_cols_labels(Variable, just_label = TRUE), .after = Variable)+ shinyjs::hide("label_size")
|
| 1004 | +804 |
- },+ } |
|
| 1005 | +805 | ! |
- env = list(+ plot_call <- substitute( |
| 1006 | +806 | ! |
- group_var = group_var, group_var_name = as.name(group_var), group_vals = group_vals, summ_fn = summ_fn+ expr = plot_call + ggplot2::geom_smooth(formula = rhs_formula, se = TRUE, level = ci, method = "lm"), |
| 1007 | -+ | ||
| 807 | +! |
- )+ env = list(plot_call = plot_call, rhs_formula = rhs_formula, ci = ci) |
|
| 1008 | +808 |
) |
|
| 1009 | +809 |
- )+ } |
|
| 1010 | +810 |
} else {
|
|
| 1011 | +811 | ! |
- qenv <- teal.code::eval_code(+ shinyjs::hide("smoothing_degree")
|
| 1012 | +812 | ! |
- qenv,+ shinyjs::hide("ci")
|
| 1013 | +813 | ! |
- substitute(+ shinyjs::hide("color_sub")
|
| 1014 | +814 | ! |
- expr = summary_data <- ANL %>%+ shinyjs::hide("show_form")
|
| 1015 | +815 | ! |
- dplyr::summarise_all(summ_fn) %>%+ shinyjs::hide("show_r2")
|
| 1016 | +816 | ! |
- tidyr::pivot_longer(tidyselect::everything(),+ if (input$show_count) {
|
| 1017 | +817 | ! |
- names_to = "Variable",+ plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE) |
| 1018 | +818 | ! |
- values_to = paste0("Missing (N=", nrow(ANL), ")")
+ shinyjs::show("label_pos")
+ |
+
| 819 | +! | +
+ shinyjs::show("label_size")
|
|
| 1019 | +820 |
- ) %>%+ } else {
|
|
| 1020 | +821 | ! |
- dplyr::mutate(`Variable label` = create_cols_labels(Variable), .after = Variable),+ shinyjs::hide("label_pos")
|
| 1021 | +822 | ! |
- env = list(summ_fn = summ_fn)+ shinyjs::hide("label_size")
|
| 1022 | +823 |
- )+ } |
|
| 1023 | -+ | ||
| 824 | +! |
- )+ shinyjs::show("line_msg")
|
|
| 1024 | +825 |
} |
|
| 1025 | +826 | ||
| 1026 | +827 | ! |
- teal.code::eval_code(qenv, quote(summary_data))+ if (!is.null(facet_cl)) {
+ |
+
| 828 | +! | +
+ plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl)) |
|
| 1027 | +829 |
- })+ } |
|
| 1028 | +830 | ||
| 1029 | +831 | ! |
- summary_table_r <- reactive(summary_table_q()[["summary_data"]])+ y_label <- varname_w_label( |
| 1030 | -+ | ||
| 832 | +! |
-
+ y_var, |
|
| 1031 | +833 | ! |
- by_subject_plot_q <- reactive({
+ ANL, |
| 1032 | -+ | ||
| 834 | +! |
- # needed to trigger show r code update on tab change+ prefix = if (log_y) paste(log_y_fn, "(") else NULL,
|
|
| 1033 | +835 | ! |
- req(input$summary_type == "Grouped by Subject", common_code_q())+ suffix = if (log_y) ")" else NULL |
| 1034 | +836 |
-
+ ) |
|
| 1035 | +837 | ! |
- teal::validate_has_data(data_r(), 1)+ x_label <- varname_w_label( |
| 1036 | -+ | ||
| 838 | +! |
-
+ x_var, |
|
| 1037 | +839 | ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(+ ANL, |
| 1038 | +840 | ! |
- labs = list(x = "", y = ""),+ prefix = if (log_x) paste(log_x_fn, "(") else NULL,
|
| 1039 | +841 | ! |
- theme = list(legend.position = "bottom", axis.text.x = quote(element_blank()))+ suffix = if (log_x) ")" else NULL |
| 1040 | +842 |
) |
|
| 1041 | +843 | ||
| 1042 | +844 | ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ dev_ggplot2_args <- teal.widgets::ggplot2_args( |
| 1043 | +845 | ! |
- user_plot = ggplot2_args[["By Subject"]],+ labs = list(y = y_label, x = x_label), |
| 1044 | +846 | ! |
- user_default = ggplot2_args$default,+ theme = list(legend.position = "bottom")+ |
+
| 847 | ++ |
+ )+ |
+ |
| 848 | ++ | + | |
| 1045 | +849 | ! |
- module_plot = dev_ggplot2_args+ if (rotate_xaxis_labels) {
+ |
+
| 850 | +! | +
+ dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1)) # nolint |
|
| 1046 | +851 |
- )+ } |
|
| 1047 | +852 | ||
| 1048 | +853 | ! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 1049 | +854 | ! |
- all_ggplot2_args,+ user_plot = ggplot2_args, |
| 1050 | +855 | ! |
- ggtheme = input$ggtheme+ module_plot = dev_ggplot2_args |
| 1051 | +856 |
) |
|
| 1052 | +857 | ||
| 1053 | +858 | ! |
- teal.code::eval_code(+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = ggtheme)+ |
+
| 859 | ++ | + + | +|
| 860 | ++ | + | |
| 1054 | +861 | ! |
- common_code_q(),+ if (add_density) {
|
| 1055 | +862 | ! |
- substitute(+ plot_call <- substitute( |
| 1056 | +863 | ! |
- expr = parent_keys <- keys,+ expr = ggExtra::ggMarginal( |
| 1057 | +864 | ! |
- env = list(keys = data_parent_keys())+ plot_call + labs + ggthemes + themes, |
| 1058 | -+ | ||
| 865 | +! |
- )+ type = "density",+ |
+ |
| 866 | +! | +
+ groupColour = group_colour |
|
| 1059 | +867 |
- ) %>%+ ), |
|
| 1060 | +868 | ! |
- teal.code::eval_code(+ env = list( |
| 1061 | +869 | ! |
- substitute(+ plot_call = plot_call, |
| 1062 | +870 | ! |
- expr = analysis_vars <- setdiff(colnames(ANL), data_keys),+ group_colour = if (length(color_by_var) > 0) TRUE else FALSE, |
| 1063 | +871 | ! |
- env = list(data_keys = data_keys())+ labs = parsed_ggplot2_args$labs,+ |
+
| 872 | +! | +
+ ggthemes = parsed_ggplot2_args$ggtheme,+ |
+ |
| 873 | +! | +
+ themes = parsed_ggplot2_args$theme |
|
| 1064 | +874 |
) |
|
| 1065 | +875 |
- ) %>%+ )+ |
+ |
| 876 | ++ |
+ } else {
|
|
| 1066 | +877 | ! |
- teal.code::eval_code(+ plot_call <- substitute( |
| 1067 | +878 | ! |
- quote({
+ expr = plot_call + |
| 1068 | +879 | ! |
- summary_plot_patients <- ANL[, c(parent_keys, analysis_vars)] %>%+ labs + |
| 1069 | +880 | ! |
- dplyr::group_by_at(parent_keys) %>%+ ggthemes + |
| 1070 | +881 | ! |
- dplyr::mutate(id = dplyr::cur_group_id()) %>%+ themes, |
| 1071 | +882 | ! |
- dplyr::ungroup() %>%+ env = list( |
| 1072 | +883 | ! |
- dplyr::group_by_at(c(parent_keys, "id")) %>%+ plot_call = plot_call, |
| 1073 | +884 | ! |
- dplyr::summarise_all(anyNA) %>%+ labs = parsed_ggplot2_args$labs,+ |
+
| 885 | +! | +
+ ggthemes = parsed_ggplot2_args$ggtheme,+ |
+ |
| 886 | +! | +
+ themes = parsed_ggplot2_args$theme+ |
+ |
| 887 | ++ |
+ )+ |
+ |
| 888 | ++ |
+ )+ |
+ |
| 889 | ++ |
+ }+ |
+ |
| 890 | ++ | + + | +|
| 891 | +! | +
+ plot_call <- substitute(expr = p <- plot_call, env = list(plot_call = plot_call))+ |
+ |
| 892 | ++ | + | |
| 1074 | +893 | ! |
- dplyr::ungroup()+ teal.code::eval_code(plot_q, plot_call) %>% |
| 1075 | -+ | ||
| 894 | +! |
-
+ teal.code::eval_code(quote(print(p))) |
|
| 1076 | +895 |
- # order subjects by decreasing number of missing and then by+ }) |
|
| 1077 | +896 |
- # missingness pattern (defined using sha1)+ |
|
| 1078 | +897 | ! |
- order_subjects <- summary_plot_patients %>%+ plot_r <- reactive(output_q()[["p"]]) |
| 1079 | -! | +||
| 898 | +
- dplyr::select(-"id", -tidyselect::all_of(parent_keys)) %>%+ |
||
| 1080 | -! | +||
| 899 | +
- dplyr::transmute(+ # Insert the plot into a plot_with_settings module from teal.widgets |
||
| 1081 | +900 | ! |
- id = dplyr::row_number(),+ pws <- teal.widgets::plot_with_settings_srv( |
| 1082 | +901 | ! |
- number_NA = apply(., 1, sum),+ id = "scatter_plot", |
| 1083 | +902 | ! |
- sha = apply(., 1, rlang::hash)+ plot_r = plot_r, |
| 1084 | -+ | ||
| 903 | +! |
- ) %>%+ height = plot_height, |
|
| 1085 | +904 | ! |
- dplyr::arrange(dplyr::desc(number_NA), sha) %>%+ width = plot_width, |
| 1086 | +905 | ! |
- getElement(name = "id")+ brushing = TRUE |
| 1087 | +906 |
-
+ ) |
|
| 1088 | +907 |
- # order columns by decreasing percent of missing values+ |
|
| 1089 | +908 | ! |
- ordered_columns <- summary_plot_patients %>%+ output$data_table <- DT::renderDataTable({
|
| 1090 | +909 | ! |
- dplyr::select(-"id", -tidyselect::all_of(parent_keys)) %>%+ plot_brush <- pws$brush() |
| 1091 | -! | +||
| 910 | +
- dplyr::summarise(+ |
||
| 1092 | +911 | ! |
- column = create_cols_labels(colnames(.)),+ if (!is.null(plot_brush)) {
|
| 1093 | +912 | ! |
- na_count = apply(., MARGIN = 2, FUN = sum),+ validate(need(!input$add_density, "Brushing feature is currently not supported when plot has marginal density")) |
| 1094 | -! | +||
| 913 | +
- na_percent = na_count / nrow(.) * 100+ } |
||
| 1095 | +914 |
- ) %>%+ |
|
| 1096 | +915 | ! |
- dplyr::arrange(na_percent, dplyr::desc(column))+ merged_data <- isolate(teal.code::dev_suppress(output_q()[["ANL"]])) |
| 1097 | +916 | ||
| 1098 | +917 | ! |
- summary_plot_patients <- summary_plot_patients %>%+ brushed_df <- teal.widgets::clean_brushedPoints(merged_data, plot_brush) |
| 1099 | +918 | ! |
- tidyr::gather("col", "isna", -"id", -tidyselect::all_of(parent_keys)) %>%
+ numeric_cols <- names(brushed_df)[ |
| 1100 | +919 | ! |
- dplyr::mutate(col = create_cols_labels(col))+ vapply(brushed_df, function(x) is.numeric(x) && !is.integer(x), FUN.VALUE = logical(1)) |
| 1101 | +920 |
- })+ ] |
|
| 1102 | +921 |
- ) %>%+ |
|
| 1103 | +922 | ! |
- teal.code::eval_code(+ if (length(numeric_cols) > 0) {
|
| 1104 | +923 | ! |
- substitute(+ DT::formatRound( |
| 1105 | +924 | ! |
- expr = {
+ DT::datatable(brushed_df, |
| 1106 | +925 | ! |
- g <- ggplot(summary_plot_patients, aes(+ rownames = FALSE, |
| 1107 | +926 | ! |
- x = factor(id, levels = order_subjects),+ options = list(scrollX = TRUE, pageLength = input$data_table_rows)+ |
+
| 927 | ++ |
+ ), |
|
| 1108 | +928 | ! |
- y = factor(col, levels = ordered_columns[["column"]]),+ numeric_cols, |
| 1109 | +929 | ! |
- fill = isna+ table_dec |
| 1110 | +930 |
- )) ++ ) |
|
| 1111 | -! | +||
| 931 | +
- geom_raster() ++ } else {
|
||
| 1112 | +932 | ! |
- annotate(+ DT::datatable(brushed_df, rownames = FALSE, options = list(scrollX = TRUE, pageLength = input$data_table_rows))+ |
+
| 933 | ++ |
+ }+ |
+ |
| 934 | ++ |
+ })+ |
+ |
| 935 | ++ | + | |
| 1113 | +936 | ! |
- "text",+ teal.widgets::verbatim_popup_srv( |
| 1114 | +937 | ! |
- x = length(order_subjects),+ id = "warning", |
| 1115 | +938 | ! |
- y = seq_len(nrow(ordered_columns)),+ verbatim_content = reactive(teal.code::get_warnings(output_q())), |
| 1116 | +939 | ! |
- hjust = 1,+ title = "Warning", |
| 1117 | +940 | ! |
- label = sprintf("%d [%.02f%%]", ordered_columns[["na_count"]], ordered_columns[["na_percent"]])
+ disabled = reactive(is.null(teal.code::get_warnings(output_q()))) |
| 1118 | +941 |
- ) ++ )+ |
+ |
| 942 | ++ | + | |
| 1119 | +943 | ! |
- scale_fill_manual(+ teal.widgets::verbatim_popup_srv( |
| 1120 | +944 | ! |
- name = "",+ id = "rcode", |
| 1121 | +945 | ! |
- values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
+ verbatim_content = reactive(teal.code::get_code(output_q())), |
| 1122 | +946 | ! |
- labels = c("Present", "Missing (at least one)")
+ title = "R Code for scatterplot" |
| 1123 | +947 |
- ) ++ ) |
|
| 1124 | -! | +||
| 948 | +
- labs ++ |
||
| 1125 | -! | +||
| 949 | +
- ggthemes ++ ### REPORTER |
||
| 1126 | +950 | ! |
- themes+ if (with_reporter) {
|
| 1127 | +951 | ! |
- print(g)+ card_fun <- function(comment, label) {
|
| 1128 | -+ | ||
| 952 | +! |
- },+ card <- teal::report_card_template( |
|
| 1129 | +953 | ! |
- env = list(+ title = "Scatter Plot", |
| 1130 | +954 | ! |
- labs = parsed_ggplot2_args$labs,+ label = label, |
| 1131 | +955 | ! |
- themes = parsed_ggplot2_args$theme,+ with_filter = with_filter, |
| 1132 | +956 | ! |
- ggthemes = parsed_ggplot2_args$ggtheme+ filter_panel_api = filter_panel_api |
| 1133 | +957 |
- )+ ) |
|
| 1134 | -+ | ||
| 958 | +! |
- )+ card$append_text("Plot", "header3")
|
|
| 1135 | -+ | ||
| 959 | +! |
- )+ card$append_plot(plot_r(), dim = pws$dim()) |
|
| 1136 | -+ | ||
| 960 | +! |
- })+ if (!comment == "") {
|
|
| 1137 | -+ | ||
| 961 | +! |
-
+ card$append_text("Comment", "header3")
|
|
| 1138 | +962 | ! |
- by_subject_plot_r <- reactive(by_subject_plot_q()[["g"]])+ card$append_text(comment) |
| 1139 | +963 |
-
+ } |
|
| 1140 | +964 | ! |
- output$levels_table <- DT::renderDataTable(+ card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n")) |
| 1141 | +965 | ! |
- expr = {
+ card+ |
+
| 966 | ++ |
+ } |
|
| 1142 | +967 | ! |
- if (length(input$variables_select) == 0) {
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 1143 | +968 |
- # so that zeroRecords message gets printed+ } |
|
| 1144 | +969 |
- # using tibble as it supports weird column names, such as " "+ ### |
|
| 1145 | -! | +||
| 970 | +
- tibble::tibble(` ` = logical(0))+ }) |
||
| 1146 | +971 |
- } else {
+ } |
|
| 1147 | -! | +
| 1 | +
- summary_table_r()+ #' Create a simple cross-table |
||
| 1148 | +2 |
- }+ #' @md |
|
| 1149 | +3 |
- },+ #' |
|
| 1150 | -! | +||
| 4 | +
- options = list(language = list(zeroRecords = "No variable selected"), pageLength = input$levels_table_rows)+ #' @inheritParams teal::module |
||
| 1151 | +5 |
- )+ #' @inheritParams shared_params |
|
| 1152 | +6 |
-
+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
|
| 1153 | -! | +||
| 7 | +
- pws1 <- teal.widgets::plot_with_settings_srv(+ #' Object with all available choices with pre-selected option for variable X - row values. In case |
||
| 1154 | -! | +||
| 8 | +
- id = "summary_plot",+ #' of `data_extract_spec` use `select_spec(..., ordered = TRUE)` if table elements should be |
||
| 1155 | -! | +||
| 9 | +
- plot_r = summary_plot_r,+ #' rendered according to selection order. |
||
| 1156 | -! | +||
| 10 | +
- height = plot_height,+ #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 1157 | -! | +||
| 11 | +
- width = plot_width+ #' Object with all available choices with pre-selected option for variable Y - column values |
||
| 1158 | +12 |
- )+ #' \code{data_extract_spec} must not allow multiple selection in this case.
|
|
| 1159 | +13 |
-
+ #' |
|
| 1160 | -! | +||
| 14 | +
- pws2 <- teal.widgets::plot_with_settings_srv(+ #' @param show_percentage optional, (`logical`) Whether to show percentages |
||
| 1161 | -! | +||
| 15 | +
- id = "combination_plot",+ #' (relevant only when `x` is a `factor`). Defaults to `TRUE`. |
||
| 1162 | -! | +||
| 16 | ++ |
+ #' @param show_total optional, (`logical`) Whether to show total column. Defaults to `TRUE`.+ |
+ |
| 17 | ++ |
+ #'+ |
+ |
| 18 | ++ |
+ #' @note For more examples, please see the vignette "Using cross table" via+ |
+ |
| 19 | +
- plot_r = combination_plot_r,+ #' `vignette("using-cross-table", package = "teal.modules.general")`.
|
||
| 1163 | -! | +||
| 20 | +
- height = plot_height,+ #' |
||
| 1164 | -! | +||
| 21 | +
- width = plot_width+ #' @export |
||
| 1165 | +22 |
- )+ #' |
|
| 1166 | +23 |
-
+ #' @examples |
|
| 1167 | -! | +||
| 24 | +
- pws3 <- teal.widgets::plot_with_settings_srv(+ #' # Percentage cross table of variables from ADSL dataset |
||
| 1168 | -! | +||
| 25 | +
- id = "by_subject_plot",+ #' |
||
| 1169 | -! | +||
| 26 | +
- plot_r = by_subject_plot_r,+ #' ADSL <- teal.modules.general::rADSL |
||
| 1170 | -! | +||
| 27 | +
- height = plot_height,+ #' |
||
| 1171 | -! | +||
| 28 | +
- width = plot_width+ #' app <- teal::init( |
||
| 1172 | +29 |
- )+ #' data = teal.data::cdisc_data( |
|
| 1173 | +30 |
-
+ #' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
|
|
| 1174 | -! | +||
| 31 | +
- final_q <- reactive({
+ #' check = TRUE |
||
| 1175 | -! | +||
| 32 | +
- req(input$summary_type)+ #' ), |
||
| 1176 | -! | +||
| 33 | +
- sum_type <- input$summary_type+ #' modules = teal::modules( |
||
| 1177 | -! | +||
| 34 | +
- if (sum_type == "Summary") {
+ #' teal.modules.general::tm_t_crosstable( |
||
| 1178 | -! | +||
| 35 | +
- summary_plot_q()+ #' label = "Cross Table", |
||
| 1179 | -! | +||
| 36 | +
- } else if (sum_type == "Combinations") {
+ #' x = teal.transform::data_extract_spec( |
||
| 1180 | -! | +||
| 37 | +
- combination_plot_q()+ #' dataname = "ADSL", |
||
| 1181 | -! | +||
| 38 | +
- } else if (sum_type == "By Variable Levels") {
+ #' select = teal.transform::select_spec( |
||
| 1182 | -! | +||
| 39 | +
- summary_table_q()+ #' label = "Select variable:", |
||
| 1183 | -! | +||
| 40 | +
- } else if (sum_type == "Grouped by Subject") {
+ #' choices = variable_choices(ADSL, subset = function(data) {
|
||
| 1184 | -! | +||
| 41 | +
- by_subject_plot_q()+ #' idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt"))
|
||
| 1185 | +42 |
- }+ #' return(names(data)[idx]) |
|
| 1186 | +43 |
- })+ #' }), |
|
| 1187 | +44 |
-
+ #' selected = "COUNTRY", |
|
| 1188 | -! | +||
| 45 | +
- teal.widgets::verbatim_popup_srv(+ #' multiple = TRUE, |
||
| 1189 | -! | +||
| 46 | +
- id = "warning",+ #' ordered = TRUE, |
||
| 1190 | -! | +||
| 47 | +
- verbatim_content = reactive(teal.code::get_warnings(final_q())),+ #' fixed = FALSE |
||
| 1191 | -! | +||
| 48 | +
- title = "Warning",+ #' ) |
||
| 1192 | -! | +||
| 49 | +
- disabled = reactive(is.null(teal.code::get_warnings(final_q())))+ #' ), |
||
| 1193 | +50 |
- )+ #' y = teal.transform::data_extract_spec( |
|
| 1194 | +51 |
-
+ #' dataname = "ADSL", |
|
| 1195 | -! | +||
| 52 | +
- teal.widgets::verbatim_popup_srv(+ #' select = teal.transform::select_spec( |
||
| 1196 | -! | +||
| 53 | +
- id = "rcode",+ #' label = "Select variable:", |
||
| 1197 | -! | +||
| 54 | +
- verbatim_content = reactive(teal.code::get_code(final_q())),+ #' choices = variable_choices(ADSL, subset = function(data) {
|
||
| 1198 | -! | +||
| 55 | +
- title = "Show R Code for Missing Data"+ #' idx <- vapply(data, is.factor, logical(1)) |
||
| 1199 | +56 |
- )+ #' return(names(data)[idx]) |
|
| 1200 | +57 |
-
+ #' }), |
|
| 1201 | +58 |
- ### REPORTER+ #' selected = "SEX", |
|
| 1202 | -! | +||
| 59 | +
- if (with_reporter) {
+ #' multiple = FALSE, |
||
| 1203 | -! | +||
| 60 | +
- card_fun <- function(comment) {
+ #' fixed = FALSE |
||
| 1204 | -! | +||
| 61 | +
- card <- teal::TealReportCard$new()+ #' ) |
||
| 1205 | -! | +||
| 62 | +
- sum_type <- input$summary_type+ #' ), |
||
| 1206 | -! | +||
| 63 | +
- title <- if (sum_type == "By Variable Levels") paste0(sum_type, " Table") else paste0(sum_type, " Plot")+ #' basic_table_args = teal.widgets::basic_table_args( |
||
| 1207 | -! | +||
| 64 | +
- title_dataname <- paste(title, dataname, sep = " - ")+ #' subtitles = "Table generated by Crosstable Module" |
||
| 1208 | -! | +||
| 65 | +
- card$set_name(paste("Missing Data", sum_type, dataname, sep = " - "))
+ #' ) |
||
| 1209 | -! | +||
| 66 | +
- card$append_text(title_dataname, "header2")+ #' ) |
||
| 1210 | -! | +||
| 67 | +
- if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ #' ) |
||
| 1211 | -! | +||
| 68 | +
- if (sum_type == "Summary") {
+ #' ) |
||
| 1212 | -! | +||
| 69 | +
- card$append_text("Plot", "header3")
+ #' if (interactive()) {
|
||
| 1213 | -! | +||
| 70 | +
- card$append_plot(summary_plot_r(), dim = pws1$dim())+ #' shinyApp(app$ui, app$server) |
||
| 1214 | -! | +||
| 71 | +
- } else if (sum_type == "Combinations") {
+ #' } |
||
| 1215 | -! | +||
| 72 | +
- card$append_text("Plot", "header3")
+ #' |
||
| 1216 | -! | +||
| 73 | +
- card$append_plot(combination_plot_r(), dim = pws2$dim())+ tm_t_crosstable <- function(label = "Cross Table", |
||
| 1217 | -! | +||
| 74 | +
- } else if (sum_type == "By Variable Levels") {
+ x, |
||
| 1218 | -! | +||
| 75 | +
- card$append_text("Table", "header3")
+ y, |
||
| 1219 | -! | +||
| 76 | +
- card$append_table(summary_table_r[["summary_data"]])+ show_percentage = TRUE, |
||
| 1220 | -! | +||
| 77 | +
- } else if (sum_type == "Grouped by Subject") {
+ show_total = TRUE, |
||
| 1221 | -! | +||
| 78 | +
- card$append_text("Plot", "header3")
+ pre_output = NULL, |
||
| 1222 | -! | +||
| 79 | +
- card$append_plot(by_subject_plot_r(), dim = pws3$dim())+ post_output = NULL, |
||
| 1223 | +80 |
- }+ basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 1224 | +81 | ! |
- if (!comment == "") {
+ logger::log_info("Initializing tm_t_crosstable")
|
| 1225 | +82 | ! |
- card$append_text("Comment", "header3")
+ if (!requireNamespace("rtables", quietly = TRUE)) {
|
| 1226 | +83 | ! |
- card$append_text(comment)+ stop("Cannot load rtables - please install the package or restart your session.")
|
| 1227 | +84 |
- }+ } |
|
| 1228 | +85 | ! |
- card$append_src(paste(teal.code::get_code(final_q()), collapse = "\n"))+ if (inherits(x, "data_extract_spec")) x <- list(x) |
| 1229 | +86 | ! |
- card+ if (inherits(y, "data_extract_spec")) y <- list(y) |
| 1230 | +87 |
- }+ |
|
| 1231 | +88 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
- |
-
| 1232 | -- |
- }- |
- |
| 1233 | -- |
- ###- |
- |
| 1234 | -- |
- })- |
- |
| 1235 | -- |
- }+ checkmate::assert_string(label) |
| 1 | -+ | ||
| 89 | +! |
- #' Create a scatterplot matrix+ checkmate::assert_list(x, types = "data_extract_spec") |
|
| 2 | -+ | ||
| 90 | +! |
- #'+ checkmate::assert_list(y, types = "data_extract_spec") |
|
| 3 | -+ | ||
| 91 | +! |
- #' The available datasets to choose from for each dataset selector is the same and+ if (any(vapply(y, function(x) x$select$multiple, logical(1)))) {
|
|
| 4 | -+ | ||
| 92 | +! |
- #' determined by the argument `variables`.+ stop("'y' should not allow multiple selection")
|
|
| 5 | +93 |
- #' @md+ } |
|
| 6 | -+ | ||
| 94 | +! |
- #'+ checkmate::assert_flag(show_percentage) |
|
| 7 | -+ | ||
| 95 | +! |
- #' @inheritParams teal::module+ checkmate::assert_flag(show_total) |
|
| 8 | -+ | ||
| 96 | +! |
- #' @inheritParams tm_g_scatterplot+ checkmate::assert_class(basic_table_args, classes = "basic_table_args") |
|
| 9 | +97 |
- #' @inheritParams shared_params+ |
|
| 10 | -+ | ||
| 98 | +! |
- #'+ ui_args <- as.list(environment()) |
|
| 11 | +99 |
- #' @param variables (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ |
|
| 12 | -+ | ||
| 100 | +! |
- #' Plotting variables from an incoming dataset with filtering and selecting. In case of+ server_args <- list( |
|
| 13 | -+ | ||
| 101 | +! |
- #' `data_extract_spec` use `select_spec(..., ordered = TRUE)` if plot elements should be+ label = label, |
|
| 14 | -+ | ||
| 102 | +! |
- #' rendered according to selection order.+ x = x, |
|
| 15 | -+ | ||
| 103 | +! |
- #'+ y = y, |
|
| 16 | -+ | ||
| 104 | +! |
- #' @note For more examples, please see the vignette "Using scatterplot matrix" via+ basic_table_args = basic_table_args |
|
| 17 | +105 |
- #' \code{vignette("using-scatterplot-matrix", package = "teal.modules.general")}.
+ ) |
|
| 18 | +106 |
- #' @export+ |
|
| 19 | -+ | ||
| 107 | +! |
- #'+ module( |
|
| 20 | -+ | ||
| 108 | +! |
- #' @examples+ label = label, |
|
| 21 | -+ | ||
| 109 | +! |
- #' # Scatterplot matrix of variables from ADSL dataset+ server = srv_t_crosstable, |
|
| 22 | -+ | ||
| 110 | +! |
- #'+ ui = ui_t_crosstable, |
|
| 23 | -+ | ||
| 111 | +! |
- #' ADSL <- teal.modules.general::rADSL+ ui_args = ui_args, |
|
| 24 | -+ | ||
| 112 | +! |
- #' ADRS <- teal.modules.general::rADRS+ server_args = server_args, |
|
| 25 | -+ | ||
| 113 | +! |
- #'+ datanames = teal.transform::get_extract_datanames(list(x = x, y = y)) |
|
| 26 | +114 |
- #' app <- teal::init(+ ) |
|
| 27 | +115 |
- #' data = teal.data::cdisc_data(+ } |
|
| 28 | +116 |
- #' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
+
|
|
| 29 | +117 |
- #' teal.data::cdisc_dataset("ADRS", ADRS, code = "ADRS <- teal.modules.general::rADRS"),
+ ui_t_crosstable <- function(id, x, y, show_percentage, show_total, pre_output, post_output, ...) {
|
|
| 30 | -+ | ||
| 118 | +! |
- #' check = TRUE+ ns <- NS(id) |
|
| 31 | -+ | ||
| 119 | +! |
- #' ),+ is_single_dataset <- teal.transform::is_single_dataset(x, y) |
|
| 32 | +120 |
- #' modules = teal::modules(+ |
|
| 33 | -+ | ||
| 121 | +! |
- #' teal.modules.general::tm_g_scatterplotmatrix(+ join_default_options <- c( |
|
| 34 | -+ | ||
| 122 | +! |
- #' label = "Scatterplot matrix",+ "Full Join" = "dplyr::full_join", |
|
| 35 | -+ | ||
| 123 | +! |
- #' variables = list(+ "Inner Join" = "dplyr::inner_join", |
|
| 36 | -+ | ||
| 124 | +! |
- #' teal.transform::data_extract_spec(+ "Left Join" = "dplyr::left_join", |
|
| 37 | -+ | ||
| 125 | +! |
- #' dataname = "ADSL",+ "Right Join" = "dplyr::right_join" |
|
| 38 | +126 |
- #' select = select_spec(+ ) |
|
| 39 | +127 |
- #' label = "Select variables:",+ |
|
| 40 | -+ | ||
| 128 | +! |
- #' choices = variable_choices(ADSL),+ teal.widgets::standard_layout( |
|
| 41 | -+ | ||
| 129 | +! |
- #' selected = c("AGE", "RACE", "SEX"),
+ output = teal.widgets::white_small_well( |
|
| 42 | -+ | ||
| 130 | +! |
- #' multiple = TRUE,+ textOutput(ns("title")),
|
|
| 43 | -+ | ||
| 131 | +! |
- #' ordered = TRUE,+ teal.widgets::table_with_settings_ui(ns("table"))
|
|
| 44 | +132 |
- #' fixed = FALSE+ ), |
|
| 45 | -+ | ||
| 133 | +! |
- #' )+ encoding = div( |
|
| 46 | +134 |
- #' ),+ ### Reporter |
|
| 47 | -+ | ||
| 135 | +! |
- #' teal.transform::data_extract_spec(+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 48 | +136 |
- #' dataname = "ADRS",+ ### |
|
| 49 | -+ | ||
| 137 | +! |
- #' filter = teal.transform::filter_spec(+ tags$label("Encodings", class = "text-primary"),
|
|
| 50 | -+ | ||
| 138 | +! |
- #' label = "Select endpoints:",+ teal.transform::datanames_input(list(x, y)), |
|
| 51 | -+ | ||
| 139 | +! |
- #' vars = c("PARAMCD", "AVISIT"),
+ teal.transform::data_extract_ui(ns("x"), label = "Row values", x, is_single_dataset = is_single_dataset),
|
|
| 52 | -+ | ||
| 140 | +! |
- #' choices = value_choices(ADRS, c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")),
+ teal.transform::data_extract_ui(ns("y"), label = "Column values", y, is_single_dataset = is_single_dataset),
|
|
| 53 | -+ | ||
| 141 | +! |
- #' selected = "INVET - END OF INDUCTION",+ teal.widgets::optionalSelectInput( |
|
| 54 | -+ | ||
| 142 | +! |
- #' multiple = TRUE+ ns("join_fun"),
|
|
| 55 | -+ | ||
| 143 | +! |
- #' ),+ label = "Row to Column type of join", |
|
| 56 | -+ | ||
| 144 | +! |
- #' select = select_spec(+ choices = join_default_options, |
|
| 57 | -+ | ||
| 145 | +! |
- #' label = "Select variables:",+ selected = join_default_options[1], |
|
| 58 | -+ | ||
| 146 | +! |
- #' choices = variable_choices(ADRS),+ multiple = FALSE |
|
| 59 | +147 |
- #' selected = c("AGE", "AVAL", "ADY"),
+ ), |
|
| 60 | -+ | ||
| 148 | +! |
- #' multiple = TRUE,+ tags$hr(), |
|
| 61 | -+ | ||
| 149 | +! |
- #' ordered = TRUE,+ teal.widgets::panel_group( |
|
| 62 | -+ | ||
| 150 | +! |
- #' fixed = FALSE+ teal.widgets::panel_item( |
|
| 63 | -+ | ||
| 151 | +! |
- #' )+ title = "Table settings", |
|
| 64 | -+ | ||
| 152 | +! |
- #' )+ checkboxInput(ns("show_percentage"), "Show column percentage", value = show_percentage),
|
|
| 65 | -+ | ||
| 153 | +! |
- #' )+ checkboxInput(ns("show_total"), "Show total column", value = show_total)
|
|
| 66 | +154 |
- #' )+ ) |
|
| 67 | +155 |
- #' )+ ) |
|
| 68 | +156 |
- #' )+ ), |
|
| 69 | -+ | ||
| 157 | +! |
- #' if (interactive()) {
+ forms = tagList( |
|
| 70 | -+ | ||
| 158 | +! |
- #' shinyApp(app$ui, app$server)+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
|
|
| 71 | -+ | ||
| 159 | +! |
- #' }+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 72 | +160 |
- tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix",+ ), |
|
| 73 | -+ | ||
| 161 | +! |
- variables,+ pre_output = pre_output, |
|
| 74 | -+ | ||
| 162 | +! |
- plot_height = c(600, 200, 2000),+ post_output = post_output |
|
| 75 | +163 |
- plot_width = NULL,+ ) |
|
| 76 | +164 |
- pre_output = NULL,+ } |
|
| 77 | +165 |
- post_output = NULL) {
+
|
|
| 78 | -! | +||
| 166 | +
- logger::log_info("Initializing tm_g_scatterplotmatrix")
+ srv_t_crosstable <- function(id, data, reporter, filter_panel_api, label, x, y, basic_table_args) {
|
||
| 79 | +167 | ! |
- if (!requireNamespace("lattice", quietly = TRUE)) {
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 80 | +168 | ! |
- stop("Cannot load lattice - please install the package or restart your session.")
- |
-
| 81 | -- |
- }+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 82 | +169 | ! |
- if (inherits(variables, "data_extract_spec")) variables <- list(variables)- |
-
| 83 | -- |
-
+ checkmate::assert_class(data, "tdata") |
|
| 84 | +170 | ! |
- checkmate::assert_string(label)+ moduleServer(id, function(input, output, session) {
|
| 85 | +171 | ! |
- checkmate::assert_list(variables, types = "data_extract_spec")+ selector_list <- teal.transform::data_extract_multiple_srv( |
| 86 | +172 | ! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ data_extract = list(x = x, y = y), |
| 87 | +173 | ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ datasets = data, |
| 88 | +174 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ select_validation_rule = list( |
| 89 | +175 | ! |
- checkmate::assert_numeric(+ x = shinyvalidate::sv_required("Please define column for row variable."),
|
| 90 | +176 | ! |
- plot_width[1],+ y = shinyvalidate::sv_required("Please define column for column variable.")
|
| 91 | -! | +||
| 177 | +
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ ) |
||
| 92 | +178 |
- )+ ) |
|
| 93 | +179 | ||
| 94 | +180 | ! |
- args <- as.list(environment())+ iv_r <- reactive({
|
| 95 | +181 | ! |
- module(+ iv <- shinyvalidate::InputValidator$new() |
| 96 | +182 | ! |
- label = label,+ iv$add_rule("join_fun", function(value) {
|
| 97 | +183 | ! |
- server = srv_g_scatterplotmatrix,+ if (!identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
|
| 98 | +184 | ! |
- ui = ui_g_scatterplotmatrix,+ if (!shinyvalidate::input_provided(value)) {
|
| 99 | +185 | ! |
- ui_args = args,+ "Please select a joining function." |
| 100 | -! | +||
| 186 | +
- server_args = list(variables = variables, plot_height = plot_height, plot_width = plot_width),+ } |
||
| 101 | -! | +||
| 187 | +
- datanames = teal.transform::get_extract_datanames(variables)+ } |
||
| 102 | +188 |
- )+ }) |
|
| 103 | -+ | ||
| 189 | +! |
- }+ teal.transform::compose_and_enable_validators(iv, selector_list) |
|
| 104 | +190 |
-
+ }) |
|
| 105 | +191 |
- ui_g_scatterplotmatrix <- function(id, ...) {
+
|
|
| 106 | +192 | ! |
- args <- list(...)+ observeEvent( |
| 107 | +193 | ! |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$variables)+ eventExpr = {
|
| 108 | +194 | ! |
- ns <- NS(id)+ req(!is.null(selector_list()$x()) && !is.null(selector_list()$y())) |
| 109 | +195 | ! |
- teal.widgets::standard_layout(+ list(selector_list()$x(), selector_list()$y()) |
| 110 | -! | +||
| 196 | +
- output = teal.widgets::white_small_well(+ }, |
||
| 111 | +197 | ! |
- textOutput(ns("message")),
+ handlerExpr = {
|
| 112 | +198 | ! |
- br(),+ if (identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
|
| 113 | +199 | ! |
- teal.widgets::plot_with_settings_ui(id = ns("myplot"))
+ shinyjs::hide("join_fun")
|
| 114 | +200 |
- ),+ } else {
|
|
| 115 | +201 | ! |
- encoding = div(+ shinyjs::show("join_fun")
|
| 116 | +202 |
- ### Reporter+ } |
|
| 117 | -! | +||
| 203 | +
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ } |
||
| 118 | +204 |
- ###+ ) |
|
| 119 | -! | +||
| 205 | +
- tags$label("Encodings", class = "text-primary"),
+
|
||
| 120 | +206 | ! |
- teal.transform::datanames_input(args$variables),+ merge_function <- reactive({
|
| 121 | +207 | ! |
- teal.transform::data_extract_ui(+ if (is.null(input$join_fun)) {
|
| 122 | +208 | ! |
- id = ns("variables"),
+ "dplyr::full_join" |
| 123 | -! | +||
| 209 | +
- label = "Variables",+ } else {
|
||
| 124 | +210 | ! |
- data_extract_spec = args$variables,+ input$join_fun |
| 125 | -! | +||
| 211 | +
- is_single_dataset = is_single_dataset_value+ } |
||
| 126 | +212 |
- ),+ })+ |
+ |
| 213 | ++ | + | |
| 127 | +214 | ! |
- hr(),+ anl_merged_input <- teal.transform::merge_expression_srv( |
| 128 | +215 | ! |
- teal.widgets::panel_group(+ datasets = data, |
| 129 | +216 | ! |
- teal.widgets::panel_item(+ join_keys = get_join_keys(data), |
| 130 | +217 | ! |
- title = "Plot settings",+ selector_list = selector_list, |
| 131 | +218 | ! |
- sliderInput(+ merge_function = merge_function+ |
+
| 219 | ++ |
+ )+ |
+ |
| 220 | ++ | + | |
| 132 | +221 | ! |
- ns("alpha"), "Opacity:",
+ anl_merged_q <- reactive({
|
| 133 | +222 | ! |
- min = 0, max = 1,+ req(anl_merged_input()) |
| 134 | +223 | ! |
- step = .05, value = .5, ticks = FALSE+ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>%+ |
+
| 224 | +! | +
+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
|
| 135 | +225 |
- ),+ }) |
|
| 136 | -! | +||
| 226 | +
- sliderInput(+ |
||
| 137 | +227 | ! |
- ns("cex"), "Points size:",
+ merged <- list( |
| 138 | +228 | ! |
- min = 0.2, max = 3,+ anl_input_r = anl_merged_input, |
| 139 | +229 | ! |
- step = .05, value = .65, ticks = FALSE+ anl_q_r = anl_merged_q |
| 140 | +230 |
- ),+ ) |
|
| 141 | -! | +||
| 231 | +
- checkboxInput(ns("cor"), "Add Correlation", value = FALSE),
+
|
||
| 142 | +232 | ! |
- radioButtons(+ output_q <- reactive({
|
| 143 | +233 | ! |
- ns("cor_method"), "Select Correlation Method",
+ teal::validate_inputs(iv_r()) |
| 144 | +234 | ! |
- choiceNames = c("Pearson", "Kendall", "Spearman"),
+ ANL <- merged$anl_q_r()[["ANL"]] # nolint+ |
+
| 235 | ++ | + + | +|
| 236 | ++ |
+ # As this is a summary |
|
| 145 | +237 | ! |
- choiceValues = c("pearson", "kendall", "spearman"),
+ x_name <- as.vector(merged$anl_input_r()$columns_source$x) |
| 146 | +238 | ! |
- inline = TRUE+ y_name <- as.vector(merged$anl_input_r()$columns_source$y) |
| 147 | +239 |
- ),+ |
|
| 148 | +240 | ! |
- checkboxInput(ns("cor_na_omit"), "Omit Missing Values", value = TRUE)
+ teal::validate_has_data(ANL, 3) |
| 149 | -+ | ||
| 241 | +! |
- )+ teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE) |
|
| 150 | +242 |
- )+ |
|
| 151 | -+ | ||
| 243 | +! |
- ),+ is_allowed_class <- function(x) is.numeric(x) || is.factor(x) || is.character(x) || is.logical(x) |
|
| 152 | +244 | ! |
- forms = tagList(+ validate(need( |
| 153 | +245 | ! |
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+ all(vapply(ANL[x_name], is_allowed_class, logical(1))), |
| 154 | +246 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ "Selected row variable has an unsupported data type." |
| 155 | +247 |
- ),+ )) |
|
| 156 | +248 | ! |
- pre_output = args$pre_output,+ validate(need( |
| 157 | +249 | ! |
- post_output = args$post_output+ is_allowed_class(ANL[[y_name]]), |
| 158 | -+ | ||
| 250 | +! |
- )+ "Selected column variable has an unsupported data type." |
|
| 159 | +251 |
- }+ )) |
|
| 160 | +252 | ||
| 161 | -- |
- srv_g_scatterplotmatrix <- function(id, data, reporter, filter_panel_api, variables, plot_height, plot_width) {
- |
- |
| 162 | +253 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ show_percentage <- input$show_percentage # nolint |
| 163 | +254 | ! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ show_total <- input$show_total # nolint |
| 164 | -! | +||
| 255 | +
- checkmate::assert_class(data, "tdata")+ |
||
| 165 | +256 | ! |
- moduleServer(id, function(input, output, session) {
+ plot_title <- paste( |
| 166 | +257 | ! |
- selector_list <- teal.transform::data_extract_multiple_srv(+ "Cross-Table of", |
| 167 | +258 | ! |
- data_extract = list(variables = variables),+ paste0(varname_w_label(x_name, ANL), collapse = ", "), |
| 168 | +259 | ! |
- datasets = data,+ "(rows)", "vs.", |
| 169 | +260 | ! |
- select_validation_rule = list(+ varname_w_label(y_name, ANL), |
| 170 | +261 | ! |
- variables = ~ if (length(.) <= 1) "Please select at least 2 columns."+ "(columns)" |
| 171 | +262 |
) |
|
| 172 | +263 |
- )+ |
|
| 173 | -+ | ||
| 264 | +! |
-
+ labels_vec <- vapply( |
|
| 174 | +265 | +! | +
+ x_name,+ |
+
| 266 | ! |
- iv_r <- reactive({
+ varname_w_label, |
|
| 175 | +267 | ! |
- iv <- shinyvalidate::InputValidator$new()+ character(1), |
| 176 | +268 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list)+ ANL |
| 177 | +269 |
- })+ ) |
|
| 178 | +270 | ||
| 179 | +271 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ teal.code::eval_code( |
| 180 | +272 | ! |
- datasets = data,+ merged$anl_q_r(), |
| 181 | +273 | ! |
- join_keys = get_join_keys(data),+ substitute( |
| 182 | +274 | ! |
- selector_list = selector_list+ expr = {
|
| 183 | -+ | ||
| 275 | +! |
- )+ title <- plot_title |
|
| 184 | +276 |
-
+ }, |
|
| 185 | +277 | ! |
- anl_merged_q <- reactive({
+ env = list(plot_title = plot_title) |
| 186 | -! | +||
| 278 | +
- req(anl_merged_input())+ ) |
||
| 187 | -! | +||
| 279 | +
- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>%+ ) %>% |
||
| 188 | +280 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))- |
-
| 189 | -- |
- })+ teal.code::eval_code( |
|
| 190 | -+ | ||
| 281 | +! |
-
+ substitute( |
|
| 191 | +282 | ! |
- merged <- list(+ expr = {
|
| 192 | +283 | ! |
- anl_input_r = anl_merged_input,+ lyt <- basic_tables %>% |
| 193 | +284 | ! |
- anl_q_r = anl_merged_q+ split_call %>% # styler: off |
| 194 | -+ | ||
| 285 | +! |
- )+ rtables::add_colcounts() %>% |
|
| 195 | -+ | ||
| 286 | +! |
-
+ tern::analyze_vars( |
|
| 196 | -+ | ||
| 287 | +! |
- # plot+ vars = x_name, |
|
| 197 | +288 | ! |
- output_q <- reactive({
+ var_labels = labels_vec, |
| 198 | +289 | ! |
- teal::validate_inputs(iv_r())+ na.rm = FALSE, |
| 199 | -+ | ||
| 290 | +! |
-
+ denom = "N_col", |
|
| 200 | +291 | ! |
- qenv <- merged$anl_q_r()+ .stats = c("mean_sd", "median", "range", count_value)
|
| 201 | -! | +||
| 292 | +
- ANL <- qenv[["ANL"]] # nolint+ ) |
||
| 202 | +293 |
-
+ }, |
|
| 203 | +294 | ! |
- cols_names <- merged$anl_input_r()$columns_source$variables+ env = list( |
| 204 | +295 | ! |
- alpha <- input$alpha # nolint+ basic_tables = teal.widgets::parse_basic_table_args( |
| 205 | +296 | ! |
- cex <- input$cex # nolint+ basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args) |
| 206 | -! | +||
| 297 | +
- add_cor <- input$cor # nolint+ ), |
||
| 207 | +298 | ! |
- cor_method <- input$cor_method # nolint+ split_call = if (show_total) {
|
| 208 | +299 | ! |
- cor_na_omit <- input$cor_na_omit # nolint+ substitute( |
| 209 | -+ | ||
| 300 | +! |
-
+ expr = rtables::split_cols_by( |
|
| 210 | +301 | ! |
- cor_na_action <- if (isTruthy(cor_na_omit)) {
+ y_name, |
| 211 | +302 | ! |
- "na.omit"+ split_fun = rtables::add_overall_level(label = "Total", first = FALSE) |
| 212 | +303 |
- } else {
+ ), |
|
| 213 | +304 | ! |
- "na.fail"+ env = list(y_name = y_name) |
| 214 | +305 |
- }+ ) |
|
| 215 | +306 |
-
+ } else {
|
|
| 216 | +307 | ! |
- teal::validate_has_data(ANL, 10)+ substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name)) |
| 217 | -! | +||
| 308 | +
- teal::validate_has_data(ANL[, cols_names], 10, complete = TRUE, allow_inf = FALSE)+ }, |
||
| 218 | -+ | ||
| 309 | +! |
-
+ x_name = x_name, |
|
| 219 | -+ | ||
| 310 | +! |
- # get labels and proper variable names+ labels_vec = labels_vec, |
|
| 220 | +311 | ! |
- varnames <- varname_w_label(cols_names, ANL, wrap_width = 20) # nolint+ count_value = ifelse(show_percentage, "count_fraction", "count") |
| 221 | +312 |
-
+ ) |
|
| 222 | +313 |
- # check character columns. If any, then those are converted to factors+ ) |
|
| 223 | -! | +||
| 314 | +
- check_char <- vapply(ANL[, cols_names], is.character, logical(1))+ ) %>% |
||
| 224 | +315 | ! |
- if (any(check_char)) {
+ teal.code::eval_code( |
| 225 | +316 | ! |
- qenv <- teal.code::eval_code(+ substitute( |
| 226 | +317 | ! |
- qenv,+ expr = {
|
| 227 | +318 | ! |
- substitute(+ ANL <- tern::df_explicit_na(ANL) # nolint |
| 228 | +319 | ! |
- expr = ANL <- ANL[, cols_names] %>% # nolint+ tbl <- rtables::build_table(lyt = lyt, df = ANL[order(ANL[[y_name]]), ]) |
| 229 | +320 | ! |
- dplyr::mutate_if(is.character, as.factor) %>%+ tbl |
| 230 | -! | +||
| 321 | +
- droplevels(),+ }, |
||
| 231 | +322 | ! |
- env = list(cols_names = cols_names)+ env = list(y_name = y_name) |
| 232 | +323 |
) |
|
| 233 | +324 |
) |
|
| 234 | +325 |
- } else {
+ }) |
|
| 235 | -! | +||
| 326 | +
- qenv <- teal.code::eval_code(+ |
||
| 236 | +327 | ! |
- qenv,+ output$title <- renderText(output_q()[["title"]]) |
| 237 | -! | +||
| 328 | +
- substitute(+ |
||
| 238 | +329 | ! |
- expr = ANL <- ANL[, cols_names] %>% # nolint+ table_r <- reactive({
|
| 239 | +330 | ! |
- droplevels(),+ shiny::req(iv_r()$is_valid()) |
| 240 | +331 | ! |
- env = list(cols_names = cols_names)+ output_q()[["tbl"]] |
| 241 | +332 |
- )+ }) |
|
| 242 | +333 |
- )+ |
|
| 243 | -+ | ||
| 334 | +! |
- }+ teal.widgets::table_with_settings_srv(+ |
+ |
| 335 | +! | +
+ id = "table",+ |
+ |
| 336 | +! | +
+ table_r = table_r |
|
| 244 | +337 |
-
+ ) |
|
| 245 | +338 | ||
| 246 | -+ | ||
| 339 | +! |
- # create plot+ teal.widgets::verbatim_popup_srv( |
|
| 247 | +340 | ! |
- if (add_cor) {
+ id = "warning", |
| 248 | +341 | ! |
- shinyjs::show("cor_method")
+ verbatim_content = reactive(teal.code::get_warnings(output_q())), |
| 249 | +342 | ! |
- shinyjs::show("cor_use")
+ title = "Warning", |
| 250 | +343 | ! |
- shinyjs::show("cor_na_omit")
+ disabled = reactive(is.null(teal.code::get_warnings(output_q()))) |
| 251 | +344 | ++ |
+ )+ |
+
| 345 | |||
| 252 | +346 | ! |
- qenv <- teal.code::eval_code(+ teal.widgets::verbatim_popup_srv( |
| 253 | +347 | ! |
- qenv,+ id = "rcode", |
| 254 | +348 | ! |
- substitute(+ verbatim_content = reactive(teal.code::get_code(output_q())), |
| 255 | +349 | ! |
- expr = {
+ title = "Show R Code for Cross-Table"+ |
+
| 350 | ++ |
+ )+ |
+ |
| 351 | ++ | + + | +|
| 352 | ++ |
+ ### REPORTER |
|
| 256 | +353 | ! |
- g <- lattice::splom(+ if (with_reporter) {
|
| 257 | +354 | ! |
- ANL,+ card_fun <- function(comment, label) {
|
| 258 | +355 | ! |
- varnames = varnames_value,+ card <- teal::report_card_template( |
| 259 | +356 | ! |
- panel = function(x, y, ...) {
+ title = "Cross Table", |
| 260 | +357 | ! |
- lattice::panel.splom(x = x, y = y, ...)+ label = label, |
| 261 | +358 | ! |
- cpl <- lattice::current.panel.limits()+ with_filter = with_filter, |
| 262 | +359 | ! |
- lattice::panel.text(+ filter_panel_api = filter_panel_api+ |
+
| 360 | ++ |
+ ) |
|
| 263 | +361 | ! |
- mean(cpl$xlim),+ card$append_text("Table", "header3")
|
| 264 | +362 | ! |
- mean(cpl$ylim),+ card$append_table(table_r()) |
| 265 | +363 | ! |
- get_scatterplotmatrix_stats(+ if (!comment == "") {
|
| 266 | +364 | ! |
- x,+ card$append_text("Comment", "header3")
|
| 267 | +365 | +! | +
+ card$append_text(comment)+ |
+
| 366 | ++ |
+ }+ |
+ |
| 367 | +! | +
+ card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n"))+ |
+ |
| 368 | ! |
- y,+ card+ |
+ |
| 369 | ++ |
+ } |
|
| 268 | +370 | ! |
- .f = stats::cor.test,+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 269 | -! | +||
| 371 | +
- .f_args = list(method = cor_method, na.action = cor_na_action)+ } |
||
| 270 | +372 |
- ),+ ### |
|
| 271 | -! | +||
| 373 | +
- alpha = 0.6,+ }) |
||
| 272 | -! | +||
| 374 | +
- fontsize = 18,+ } |
||
| 273 | -! | +
| 1 | +
- fontface = "bold"+ #' Create a scatterplot matrix |
||
| 274 | +2 |
- )+ #' |
|
| 275 | +3 |
- },+ #' The available datasets to choose from for each dataset selector is the same and |
|
| 276 | -! | +||
| 4 | +
- pch = 16,+ #' determined by the argument `variables`. |
||
| 277 | -! | +||
| 5 | +
- alpha = alpha_value,+ #' @md |
||
| 278 | -! | +||
| 6 | +
- cex = cex_value+ #' |
||
| 279 | +7 |
- )+ #' @inheritParams teal::module |
|
| 280 | -! | +||
| 8 | +
- print(g)+ #' @inheritParams tm_g_scatterplot |
||
| 281 | +9 |
- },+ #' @inheritParams shared_params |
|
| 282 | -! | +||
| 10 | +
- env = list(+ #' |
||
| 283 | -! | +||
| 11 | +
- varnames_value = varnames,+ #' @param variables (`data_extract_spec` or `list` of multiple `data_extract_spec`) |
||
| 284 | -! | +||
| 12 | +
- cor_method = cor_method,+ #' Plotting variables from an incoming dataset with filtering and selecting. In case of |
||
| 285 | -! | +||
| 13 | +
- cor_na_action = cor_na_action,+ #' `data_extract_spec` use `select_spec(..., ordered = TRUE)` if plot elements should be |
||
| 286 | -! | +||
| 14 | +
- alpha_value = alpha,+ #' rendered according to selection order. |
||
| 287 | -! | +||
| 15 | +
- cex_value = cex+ #' |
||
| 288 | +16 |
- )+ #' @note For more examples, please see the vignette "Using scatterplot matrix" via |
|
| 289 | +17 |
- )+ #' \code{vignette("using-scatterplot-matrix", package = "teal.modules.general")}.
|
|
| 290 | +18 |
- )+ #' @export |
|
| 291 | +19 |
- } else {
+ #' |
|
| 292 | -! | +||
| 20 | +
- shinyjs::hide("cor_method")
+ #' @examples |
||
| 293 | -! | +||
| 21 | +
- shinyjs::hide("cor_use")
+ #' # Scatterplot matrix of variables from ADSL dataset |
||
| 294 | -! | +||
| 22 | +
- shinyjs::hide("cor_na_omit")
+ #' |
||
| 295 | -! | +||
| 23 | +
- qenv <- teal.code::eval_code(+ #' ADSL <- teal.modules.general::rADSL |
||
| 296 | -! | +||
| 24 | +
- qenv,+ #' ADRS <- teal.modules.general::rADRS |
||
| 297 | -! | +||
| 25 | +
- substitute(+ #' |
||
| 298 | -! | +||
| 26 | +
- expr = {
+ #' app <- teal::init( |
||
| 299 | -! | +||
| 27 | +
- g <- lattice::splom(ANL, varnames = varnames_value, pch = 16, alpha = alpha_value, cex = cex_value)+ #' data = teal.data::cdisc_data( |
||
| 300 | -! | +||
| 28 | +
- g+ #' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
|
||
| 301 | +29 |
- },+ #' teal.data::cdisc_dataset("ADRS", ADRS, code = "ADRS <- teal.modules.general::rADRS"),
|
|
| 302 | -! | +||
| 30 | +
- env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex)+ #' check = TRUE |
||
| 303 | +31 |
- )+ #' ), |
|
| 304 | +32 |
- )+ #' modules = teal::modules( |
|
| 305 | +33 |
- }+ #' teal.modules.general::tm_g_scatterplotmatrix( |
|
| 306 | -! | +||
| 34 | +
- qenv+ #' label = "Scatterplot matrix", |
||
| 307 | +35 |
- })+ #' variables = list( |
|
| 308 | +36 |
-
+ #' teal.transform::data_extract_spec( |
|
| 309 | -! | +||
| 37 | +
- plot_r <- reactive(output_q()[["g"]])+ #' dataname = "ADSL", |
||
| 310 | +38 |
-
+ #' select = select_spec( |
|
| 311 | +39 |
- # Insert the plot into a plot_with_settings module+ #' label = "Select variables:", |
|
| 312 | -! | +||
| 40 | +
- pws <- teal.widgets::plot_with_settings_srv(+ #' choices = variable_choices(ADSL), |
||
| 313 | -! | +||
| 41 | +
- id = "myplot",+ #' selected = c("AGE", "RACE", "SEX"),
|
||
| 314 | -! | +||
| 42 | +
- plot_r = plot_r,+ #' multiple = TRUE, |
||
| 315 | -! | +||
| 43 | +
- height = plot_height,+ #' ordered = TRUE, |
||
| 316 | -! | +||
| 44 | +
- width = plot_width+ #' fixed = FALSE |
||
| 317 | +45 |
- )+ #' ) |
|
| 318 | +46 |
-
+ #' ), |
|
| 319 | +47 |
- # show a message if conversion to factors took place+ #' teal.transform::data_extract_spec( |
|
| 320 | -! | +||
| 48 | +
- output$message <- renderText({
+ #' dataname = "ADRS", |
||
| 321 | -! | +||
| 49 | +
- shiny::req(iv_r()$is_valid())+ #' filter = teal.transform::filter_spec( |
||
| 322 | -! | +||
| 50 | +
- req(selector_list()$variables())+ #' label = "Select endpoints:", |
||
| 323 | -! | +||
| 51 | +
- ANL <- merged$anl_q_r()[["ANL"]] # nolint+ #' vars = c("PARAMCD", "AVISIT"),
|
||
| 324 | -! | +||
| 52 | +
- cols_names <- unique(unname(do.call(c, merged$anl_input_r()$columns_source)))+ #' choices = value_choices(ADRS, c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")),
|
||
| 325 | -! | +||
| 53 | +
- check_char <- vapply(ANL[, cols_names], is.character, logical(1))+ #' selected = "INVET - END OF INDUCTION", |
||
| 326 | -! | +||
| 54 | +
- if (any(check_char)) {
+ #' multiple = TRUE |
||
| 327 | -! | +||
| 55 | +
- is_single <- sum(check_char) == 1+ #' ), |
||
| 328 | -! | +||
| 56 | +
- paste(+ #' select = select_spec( |
||
| 329 | -! | +||
| 57 | +
- "Character",+ #' label = "Select variables:", |
||
| 330 | -! | +||
| 58 | +
- ifelse(is_single, "variable", "variables"),+ #' choices = variable_choices(ADRS), |
||
| 331 | -! | +||
| 59 | +
- paste0("(", paste(cols_names[check_char], collapse = ", "), ")"),
+ #' selected = c("AGE", "AVAL", "ADY"),
|
||
| 332 | -! | +||
| 60 | +
- ifelse(is_single, "was", "were"),+ #' multiple = TRUE, |
||
| 333 | -! | +||
| 61 | +
- "converted to",+ #' ordered = TRUE, |
||
| 334 | -! | +||
| 62 | +
- ifelse(is_single, "factor.", "factors.")+ #' fixed = FALSE |
||
| 335 | +63 |
- )+ #' ) |
|
| 336 | +64 |
- } else {
+ #' ) |
|
| 337 | +65 |
- ""+ #' ) |
|
| 338 | +66 |
- }+ #' ) |
|
| 339 | +67 |
- })+ #' ) |
|
| 340 | +68 |
-
+ #' ) |
|
| 341 | -! | +||
| 69 | +
- teal.widgets::verbatim_popup_srv(+ #' if (interactive()) {
|
||
| 342 | -! | +||
| 70 | +
- id = "warning",+ #' shinyApp(app$ui, app$server) |
||
| 343 | -! | +||
| 71 | ++ |
+ #' }+ |
+ |
| 72 | +
- verbatim_content = reactive(teal.code::get_warnings(output_q())),+ tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix", |
||
| 344 | -! | +||
| 73 | +
- title = "Warning",+ variables, |
||
| 345 | -! | +||
| 74 | +
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ plot_height = c(600, 200, 2000), |
||
| 346 | +75 |
- )+ plot_width = NULL, |
|
| 347 | +76 |
-
+ pre_output = NULL, |
|
| 348 | -! | +||
| 77 | +
- teal.widgets::verbatim_popup_srv(+ post_output = NULL) {
|
||
| 349 | +78 | ! |
- id = "rcode",+ logger::log_info("Initializing tm_g_scatterplotmatrix")
|
| 350 | +79 | ! |
- verbatim_content = reactive(teal.code::get_code(output_q())),+ if (!requireNamespace("lattice", quietly = TRUE)) {
|
| 351 | +80 | ! |
- title = "Show R Code for Scatterplotmatrix"+ stop("Cannot load lattice - please install the package or restart your session.")
|
| 352 | +81 |
- )+ } |
|
| 353 | -+ | ||
| 82 | +! |
-
+ if (inherits(variables, "data_extract_spec")) variables <- list(variables) |
|
| 354 | +83 |
- ### REPORTER+ |
|
| 355 | +84 | ! |
- if (with_reporter) {
+ checkmate::assert_string(label) |
| 356 | +85 | ! |
- card_fun <- function(comment) {
+ checkmate::assert_list(variables, types = "data_extract_spec") |
| 357 | +86 | ! |
- card <- teal::TealReportCard$new()+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 358 | +87 | ! |
- card$set_name("Scatter Plot Matrix")
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 359 | +88 | ! |
- card$append_text("Scatter Plot Matrix", "header2")
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 360 | +89 | ! |
- if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ checkmate::assert_numeric( |
| 361 | +90 | ! |
- card$append_text("Plot", "header3")
+ plot_width[1], |
| 362 | +91 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 363 | -! | +||
| 92 | +
- if (!comment == "") {
+ ) |
||
| 364 | -! | +||
| 93 | +
- card$append_text("Comment", "header3")
+
|
||
| 365 | +94 | ! |
- card$append_text(comment)+ args <- as.list(environment()) |
| 366 | -+ | ||
| 95 | +! |
- }+ module( |
|
| 367 | +96 | ! |
- card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n"))+ label = label, |
| 368 | +97 | ! |
- card+ server = srv_g_scatterplotmatrix, |
| 369 | -+ | ||
| 98 | +! |
- }+ ui = ui_g_scatterplotmatrix, |
|
| 370 | +99 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ ui_args = args, |
| 371 | -+ | ||
| 100 | +! |
- }+ server_args = list(variables = variables, plot_height = plot_height, plot_width = plot_width), |
|
| 372 | -+ | ||
| 101 | +! |
- ###+ datanames = teal.transform::get_extract_datanames(variables) |
|
| 373 | +102 |
- })+ ) |
|
| 374 | +103 |
} |
|
| 375 | +104 | ||
| 376 | -- |
- #' Get stats for x-y pairs in scatterplot matrix- |
- |
| 377 | +105 |
- #' @description uses stats::cor.test per default for all numerical input variables and converts results+ ui_g_scatterplotmatrix <- function(id, ...) {
|
|
| 378 | -+ | ||
| 106 | +! |
- #' to character vector. Could be extended if different stats for different variable+ args <- list(...) |
|
| 379 | -+ | ||
| 107 | +! |
- #' types are needed. Meant to be called from \code{lattice::panel.text}.
+ is_single_dataset_value <- teal.transform::is_single_dataset(args$variables) |
|
| 380 | -+ | ||
| 108 | +! |
- #' @param x \code{numeric}
+ ns <- NS(id) |
|
| 381 | -+ | ||
| 109 | +! |
- #' @param y \code{numeric}
+ teal.widgets::standard_layout( |
|
| 382 | -+ | ||
| 110 | +! |
- #' @param .f \code{function}, function that accepts x and y as formula input \code{~ x + y}.
+ output = teal.widgets::white_small_well( |
|
| 383 | -+ | ||
| 111 | +! |
- #' Default \code{stats::cor.test}
+ textOutput(ns("message")),
|
|
| 384 | -+ | ||
| 112 | +! |
- #' @param .f_args \code{list} of arguments to be passed to \code{.f}
+ br(), |
|
| 385 | -+ | ||
| 113 | +! |
- #' @param round_stat \code{integer}
+ teal.widgets::plot_with_settings_ui(id = ns("myplot"))
|
|
| 386 | +114 |
- #' @param round_pval \code{integer}
+ ), |
|
| 387 | -+ | ||
| 115 | +! |
- #' @details presently we need to use a formula input for \code{stats::cor.test} because
+ encoding = div( |
|
| 388 | +116 |
- #' \code{na.fail} only gets evaluated when a formula is passed (see below).
+ ### Reporter |
|
| 389 | -+ | ||
| 117 | +! |
- #' \preformatted{
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 390 | +118 |
- #' x = c(1,3,5,7,NA)+ ### |
|
| 391 | -+ | ||
| 119 | +! |
- #' y = c(3,6,7,8,1)+ tags$label("Encodings", class = "text-primary"),
|
|
| 392 | -+ | ||
| 120 | +! |
- #' stats::cor.test(x, y, na.action = "na.fail")+ teal.transform::datanames_input(args$variables), |
|
| 393 | -+ | ||
| 121 | +! |
- #' stats::cor.test(~ x + y, na.action = "na.fail")+ teal.transform::data_extract_ui( |
|
| 394 | -+ | ||
| 122 | +! |
- #' }+ id = ns("variables"),
|
|
| 395 | -+ | ||
| 123 | +! |
- #' @return \code{character} with stats. For \code{stats::cor.test} correlation coefficient and p-value.
+ label = "Variables", |
|
| 396 | -+ | ||
| 124 | +! |
- #' @export+ data_extract_spec = args$variables, |
|
| 397 | -+ | ||
| 125 | +! |
- #' @examples+ is_single_dataset = is_single_dataset_value |
|
| 398 | +126 |
- #' set.seed(1)+ ), |
|
| 399 | -+ | ||
| 127 | +! |
- #' x <- runif(25, 0, 1)+ hr(), |
|
| 400 | -+ | ||
| 128 | +! |
- #' y <- runif(25, 0, 1)+ teal.widgets::panel_group( |
|
| 401 | -+ | ||
| 129 | +! |
- #' x[c(3, 10, 18)] <- NA+ teal.widgets::panel_item( |
|
| 402 | -+ | ||
| 130 | +! |
- #'+ title = "Plot settings", |
|
| 403 | -+ | ||
| 131 | +! |
- #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson"))+ sliderInput( |
|
| 404 | -+ | ||
| 132 | +! |
- #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(+ ns("alpha"), "Opacity:",
|
|
| 405 | -+ | ||
| 133 | +! |
- #' method = "pearson",+ min = 0, max = 1, |
|
| 406 | -+ | ||
| 134 | +! |
- #' na.action = na.fail+ step = .05, value = .5, ticks = FALSE |
|
| 407 | +135 |
- #' ))+ ), |
|
| 408 | -+ | ||
| 136 | +! |
- get_scatterplotmatrix_stats <- function(x, y,+ sliderInput( |
|
| 409 | -+ | ||
| 137 | +! |
- .f = stats::cor.test,+ ns("cex"), "Points size:",
|
|
| 410 | -+ | ||
| 138 | +! |
- .f_args = list(),+ min = 0.2, max = 3, |
|
| 411 | -+ | ||
| 139 | +! |
- round_stat = 2,+ step = .05, value = .65, ticks = FALSE |
|
| 412 | +140 |
- round_pval = 4) {
+ ), |
|
| 413 | -6x | +||
| 141 | +! |
- if (is.numeric(x) && is.numeric(y)) {
+ checkboxInput(ns("cor"), "Add Correlation", value = FALSE),
|
|
| 414 | -3x | +||
| 142 | +! |
- stat <- tryCatch(do.call(.f, c(list(~ x + y), .f_args)), error = function(e) NA)+ radioButtons( |
|
| 415 | -+ | ||
| 143 | +! |
-
+ ns("cor_method"), "Select Correlation Method",
|
|
| 416 | -3x | +||
| 144 | +! |
- if (anyNA(stat)) {
+ choiceNames = c("Pearson", "Kendall", "Spearman"),
|
|
| 417 | -1x | +||
| 145 | +! |
- return("NA")
+ choiceValues = c("pearson", "kendall", "spearman"),
|
|
| 418 | -2x | +||
| 146 | +! |
- } else if (all(c("estimate", "p.value") %in% names(stat))) {
+ inline = TRUE |
|
| 419 | -2x | +||
| 147 | +
- return(paste(+ ), |
||
| 420 | -2x | +||
| 148 | +! |
- c(+ checkboxInput(ns("cor_na_omit"), "Omit Missing Values", value = TRUE)
|
|
| 421 | -2x | +||
| 149 | +
- paste0(names(stat$estimate), ":", round(stat$estimate, round_stat)),+ ) |
||
| 422 | -2x | +||
| 150 | +
- paste0("P:", round(stat$p.value, round_pval))
+ ) |
||
| 423 | +151 |
- ),+ ), |
|
| 424 | -2x | +||
| 152 | +! |
- collapse = "\n"+ forms = tagList( |
|
| 425 | -+ | ||
| 153 | +! |
- ))+ teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+ |
+ |
| 154 | +! | +
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
|
| 426 | +155 |
- } else {
+ ), |
|
| 427 | +156 | ! |
- stop("function not supported")
+ pre_output = args$pre_output, |
| 428 | -+ | ||
| 157 | +! |
- }+ post_output = args$post_output |
|
| 429 | +158 |
- } else {
+ ) |
|
| 430 | -3x | +||
| 159 | +
- if ("method" %in% names(.f_args)) {
+ } |
||
| 431 | -3x | +||
| 160 | +
- if (.f_args$method == "pearson") {
+
|
||
| 432 | -1x | +||
| 161 | +
- return("cor:-")
+ srv_g_scatterplotmatrix <- function(id, data, reporter, filter_panel_api, variables, plot_height, plot_width) {
|
||
| 433 | -+ | ||
| 162 | +! |
- }+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 434 | -2x | +||
| 163 | +! |
- if (.f_args$method == "kendall") {
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
|
| 435 | -1x | +||
| 164 | +! |
- return("tau:-")
+ checkmate::assert_class(data, "tdata") |
|
| 436 | -+ | ||
| 165 | +! |
- }+ moduleServer(id, function(input, output, session) {
|
|
| 437 | -1x | +||
| 166 | +! |
- if (.f_args$method == "spearman") {
+ selector_list <- teal.transform::data_extract_multiple_srv( |
|
| 438 | -1x | +||
| 167 | +! |
- return("rho:-")
+ data_extract = list(variables = variables), |
|
| 439 | -+ | ||
| 168 | +! |
- }+ datasets = data, |
|
| 440 | -+ | ||
| 169 | +! |
- }+ select_validation_rule = list( |
|
| 441 | +170 | ! |
- return("-")
+ variables = ~ if (length(.) <= 1) "Please select at least 2 columns." |
| 442 | +171 |
- }+ ) |
|
| 443 | +172 |
- }+ ) |
| 1 | +173 |
- #' Shared Parameters+ |
|
| 2 | -+ | ||
| 174 | +! |
- #'+ iv_r <- reactive({
|
|
| 3 | -+ | ||
| 175 | +! |
- #' @description Contains arguments that are shared between multiple functions+ iv <- shinyvalidate::InputValidator$new() |
|
| 4 | -+ | ||
| 176 | +! |
- #' in the package to avoid repetition using `inheritParams`.+ teal.transform::compose_and_enable_validators(iv, selector_list) |
|
| 5 | +177 |
- #'+ }) |
|
| 6 | +178 |
- #' @param plot_height optional, (`numeric`) A vector of length three with `c(value, min and max)`+ |
|
| 7 | -+ | ||
| 179 | +! |
- #' for a slider encoding the plot height.+ anl_merged_input <- teal.transform::merge_expression_srv( |
|
| 8 | -+ | ||
| 180 | +! |
- #' @param plot_width optional, (`numeric`) A vector of length three with `c(value, min and max)`+ datasets = data, |
|
| 9 | -+ | ||
| 181 | +! |
- #' for a slider encoding the plot width.+ join_keys = get_join_keys(data), |
|
| 10 | -+ | ||
| 182 | +! |
- #' @param rotate_xaxis_labels optional, (`logical`) Whether to rotate plot X axis labels. Does not+ selector_list = selector_list |
|
| 11 | +183 |
- #' rotate by default (`FALSE`).+ ) |
|
| 12 | +184 |
- #' @param ggtheme optional, (`character`) `ggplot2` theme to be used by default.+ |
|
| 13 | -+ | ||
| 185 | +! |
- #' One of `c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test")`.
+ anl_merged_q <- reactive({
|
|
| 14 | -+ | ||
| 186 | +! |
- #' Each theme can be chosen by the user during the session. Defaults to `"gray"`.+ req(anl_merged_input()) |
|
| 15 | -+ | ||
| 187 | +! |
- #' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()]+ teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>% |
|
| 16 | -+ | ||
| 188 | +! |
- #' with settings for the module plot.+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) |
|
| 17 | +189 |
- #' The argument is merged with options variable `teal.ggplot2_args` and default module setup.+ }) |
|
| 18 | +190 |
- #'+ |
|
| 19 | -+ | ||
| 191 | +! |
- #' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`
+ merged <- list( |
|
| 20 | -+ | ||
| 192 | +! |
- #' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()]+ anl_input_r = anl_merged_input, |
|
| 21 | -+ | ||
| 193 | +! |
- #' with settings for the module table.+ anl_q_r = anl_merged_q |
|
| 22 | +194 |
- #' The argument is merged with options variable `teal.basic_table_args` and default module setup.+ ) |
|
| 23 | +195 |
- #'+ |
|
| 24 | +196 |
- #' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")`
+ # plot |
|
| 25 | -+ | ||
| 197 | +! |
- #' @param pre_output (`shiny.tag`, optional)\cr+ output_q <- reactive({
|
|
| 26 | -+ | ||
| 198 | +! |
- #' with text placed before the output to put the output into context. For example a title.+ teal::validate_inputs(iv_r()) |
|
| 27 | +199 |
- #' @param post_output (`shiny.tag`, optional) with text placed after the output to put the output+ |
|
| 28 | -+ | ||
| 200 | +! |
- #' into context. For example the [shiny::helpText()] elements are useful.+ qenv <- merged$anl_q_r() |
|
| 29 | -+ | ||
| 201 | +! |
- #'+ ANL <- qenv[["ANL"]] # nolint |
|
| 30 | +202 |
- #' @name shared_params+ |
|
| 31 | -+ | ||
| 203 | +! |
- #' @keywords internal+ cols_names <- merged$anl_input_r()$columns_source$variables |
|
| 32 | -+ | ||
| 204 | +! |
- NULL+ alpha <- input$alpha # nolint |
|
| 33 | -+ | ||
| 205 | +! |
-
+ cex <- input$cex # nolint |
|
| 34 | -+ | ||
| 206 | +! |
- #' Add axis labels that show facetting variable+ add_cor <- input$cor # nolint |
|
| 35 | -+ | ||
| 207 | +! |
- #'+ cor_method <- input$cor_method # nolint |
|
| 36 | -+ | ||
| 208 | +! |
- #' Add axis labels that show facetting variable+ cor_na_omit <- input$cor_na_omit # nolint |
|
| 37 | +209 |
- #'+ |
|
| 38 | -+ | ||
| 210 | +! |
- #' @param p `ggplot2` object to add facet labels to+ cor_na_action <- if (isTruthy(cor_na_omit)) {
|
|
| 39 | -+ | ||
| 211 | +! |
- #' @param xfacet_label label of facet along x axis (nothing created if NULL),+ "na.omit" |
|
| 40 | +212 |
- #' if vector, will be concatenated with " & "+ } else {
|
|
| 41 | -+ | ||
| 213 | +! |
- #' @param yfacet_label label of facet along y axis (nothing created if NULL),+ "na.fail" |
|
| 42 | +214 |
- #' if vector, will be concatenated with " & "+ } |
|
| 43 | +215 |
- #'+ |
|
| 44 | -+ | ||
| 216 | +! |
- #' @return grid grob object (to be drawn with \code{grid.draw})
+ teal::validate_has_data(ANL, 10) |
|
| 45 | -+ | ||
| 217 | +! |
- #'+ teal::validate_has_data(ANL[, cols_names], 10, complete = TRUE, allow_inf = FALSE) |
|
| 46 | +218 |
- #' @export+ |
|
| 47 | +219 |
- #'+ # get labels and proper variable names |
|
| 48 | -+ | ||
| 220 | +! |
- #' @examples+ varnames <- varname_w_label(cols_names, ANL, wrap_width = 20) # nolint |
|
| 49 | +221 |
- #' # we put donttest to avoid strictr error with seq along.with argument+ |
|
| 50 | +222 |
- #' \donttest{
+ # check character columns. If any, then those are converted to factors |
|
| 51 | -+ | ||
| 223 | +! |
- #' library(ggplot2)+ check_char <- vapply(ANL[, cols_names], is.character, logical(1)) |
|
| 52 | -+ | ||
| 224 | +! |
- #' library(grid)+ if (any(check_char)) {
|
|
| 53 | -+ | ||
| 225 | +! |
- #'+ qenv <- teal.code::eval_code( |
|
| 54 | -+ | ||
| 226 | +! | +
+ qenv,+ |
+ |
| 227 | +! |
- #' p <- ggplot(mtcars) ++ substitute( |
|
| 55 | -+ | ||
| 228 | +! |
- #' aes(x = mpg, y = disp) ++ expr = ANL <- ANL[, cols_names] %>% # nolint |
|
| 56 | -+ | ||
| 229 | +! |
- #' geom_point() ++ dplyr::mutate_if(is.character, as.factor) %>% |
|
| 57 | -+ | ||
| 230 | +! |
- #' facet_grid(gear ~ cyl)+ droplevels(), |
|
| 58 | -+ | ||
| 231 | +! |
- #' p+ env = list(cols_names = cols_names) |
|
| 59 | +232 |
- #' xfacet_label <- "cylinders"+ ) |
|
| 60 | +233 |
- #' yfacet_label <- "gear"+ ) |
|
| 61 | +234 |
- #' res <- add_facet_labels(p, xfacet_label, yfacet_label)+ } else {
|
|
| 62 | -+ | ||
| 235 | +! |
- #' grid.newpage()+ qenv <- teal.code::eval_code( |
|
| 63 | -+ | ||
| 236 | +! |
- #' grid.draw(res)+ qenv, |
|
| 64 | -+ | ||
| 237 | +! |
- #'+ substitute( |
|
| 65 | -+ | ||
| 238 | +! |
- #' grid.newpage()+ expr = ANL <- ANL[, cols_names] %>% # nolint |
|
| 66 | -+ | ||
| 239 | +! |
- #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label))+ droplevels(), |
|
| 67 | -+ | ||
| 240 | +! |
- #' grid.newpage()+ env = list(cols_names = cols_names) |
|
| 68 | +241 |
- #' grid.draw(add_facet_labels(p, xfacet_label, yfacet_label = NULL))+ ) |
|
| 69 | +242 |
- #' grid.newpage()+ ) |
|
| 70 | +243 |
- #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label = NULL))+ } |
|
| 71 | +244 |
- #' }+ |
|
| 72 | +245 |
- #'+ |
|
| 73 | +246 |
- add_facet_labels <- function(p, xfacet_label = NULL, yfacet_label = NULL) {
- |
- |
| 74 | -! | -
- checkmate::assert_class(p, classes = "ggplot")+ # create plot |
|
| 75 | +247 | ! |
- checkmate::assert_character(xfacet_label, null.ok = TRUE, min.len = 1)+ if (add_cor) {
|
| 76 | +248 | ! |
- checkmate::assert_character(yfacet_label, null.ok = TRUE, min.len = 1)+ shinyjs::show("cor_method")
|
| 77 | +249 | ! |
- if (is.null(xfacet_label) && is.null(yfacet_label)) {
+ shinyjs::show("cor_use")
|
| 78 | +250 | ! |
- return(ggplotGrob(p))+ shinyjs::show("cor_na_omit")
|
| 79 | +251 |
- }+ |
|
| 80 | +252 | ! |
- grid::grid.grabExpr({
+ qenv <- teal.code::eval_code( |
| 81 | +253 | ! |
- g <- ggplotGrob(p)- |
-
| 82 | -- | - - | -|
| 83 | -- |
- # we are going to replace these, so we make sure they have nothing in them+ qenv, |
|
| 84 | +254 | ! |
- checkmate::assert_class(g$grobs[[grep("xlab-t", g$layout$name, fixed = TRUE)]], "zeroGrob")
+ substitute( |
| 85 | +255 | ! |
- checkmate::assert_class(g$grobs[[grep("ylab-r", g$layout$name, fixed = TRUE)]], "zeroGrob")
- |
-
| 86 | -- |
-
+ expr = {
|
|
| 87 | +256 | ! |
- xaxis_label_grob <- g$grobs[[grep("xlab-b", g$layout$name, fixed = TRUE)]]
+ g <- lattice::splom( |
| 88 | +257 | ! |
- xaxis_label_grob$children[[1]]$label <- paste(xfacet_label, collapse = " & ")+ ANL, |
| 89 | +258 | ! |
- yaxis_label_grob <- g$grobs[[grep("ylab-l", g$layout$name, fixed = TRUE)]]
+ varnames = varnames_value, |
| 90 | +259 | ! |
- yaxis_label_grob$children[[1]]$label <- paste(yfacet_label, collapse = " & ")+ panel = function(x, y, ...) {
|
| 91 | +260 | ! |
- yaxis_label_grob$children[[1]]$rot <- 270+ lattice::panel.splom(x = x, y = y, ...) |
| 92 | -+ | ||
| 261 | +! |
-
+ cpl <- lattice::current.panel.limits() |
|
| 93 | +262 | ! |
- top_height <- if (is.null(xfacet_label)) 0 else grid::unit(2, "line")+ lattice::panel.text( |
| 94 | +263 | ! |
- right_width <- if (is.null(yfacet_label)) 0 else grid::unit(2, "line")+ mean(cpl$xlim), |
| 95 | -+ | ||
| 264 | +! |
-
+ mean(cpl$ylim), |
|
| 96 | +265 | ! |
- grid::grid.newpage()+ get_scatterplotmatrix_stats( |
| 97 | +266 | ! |
- grid::pushViewport(grid::plotViewport(margins = c(0, 0, top_height, right_width), name = "ggplot"))+ x, |
| 98 | +267 | ! |
- grid::grid.draw(g)+ y, |
| 99 | +268 | ! |
- grid::upViewport(1)+ .f = stats::cor.test, |
| 100 | -+ | ||
| 269 | +! |
-
+ .f_args = list(method = cor_method, na.action = cor_na_action) |
|
| 101 | +270 |
- # draw x facet+ ), |
|
| 102 | +271 | ! |
- if (!is.null(xfacet_label)) {
+ alpha = 0.6, |
| 103 | +272 | ! |
- grid::pushViewport(grid::viewport(+ fontsize = 18, |
| 104 | +273 | ! |
- x = 0, y = grid::unit(1, "npc") - top_height, width = grid::unit(1, "npc"),+ fontface = "bold" |
| 105 | -! | +||
| 274 | +
- height = top_height, just = c("left", "bottom"), name = "topxaxis"
+ ) |
||
| 106 | +275 |
- ))+ }, |
|
| 107 | +276 | ! |
- grid::grid.draw(xaxis_label_grob)+ pch = 16, |
| 108 | +277 | ! |
- grid::upViewport(1)+ alpha = alpha_value, |
| 109 | -+ | ||
| 278 | +! |
- }+ cex = cex_value |
|
| 110 | +279 |
-
+ )+ |
+ |
| 280 | +! | +
+ print(g) |
|
| 111 | +281 |
- # draw y facet+ }, |
|
| 112 | +282 | ! |
- if (!is.null(yfacet_label)) {
+ env = list( |
| 113 | +283 | ! |
- grid::pushViewport(grid::viewport(+ varnames_value = varnames, |
| 114 | +284 | ! |
- x = grid::unit(1, "npc") - grid::unit(as.numeric(right_width) / 2, "line"), y = 0, width = right_width,+ cor_method = cor_method, |
| 115 | +285 | ! |
- height = grid::unit(1, "npc"), just = c("left", "bottom"), name = "rightyaxis"
- |
-
| 116 | -- |
- ))+ cor_na_action = cor_na_action, |
|
| 117 | +286 | ! |
- grid::grid.draw(yaxis_label_grob)+ alpha_value = alpha, |
| 118 | +287 | ! |
- grid::upViewport(1)+ cex_value = cex |
| 119 | +288 |
- }+ ) |
|
| 120 | +289 |
- })+ ) |
|
| 121 | +290 |
- }+ ) |
|
| 122 | +291 |
-
+ } else {
|
|
| 123 | -+ | ||
| 292 | +! |
- #' Call a function with a character vector for the \code{...} argument
+ shinyjs::hide("cor_method")
|
|
| 124 | -+ | ||
| 293 | +! |
- #'+ shinyjs::hide("cor_use")
|
|
| 125 | -+ | ||
| 294 | +! |
- #' @param fun (\code{character}) Name of a function where the \code{...} argument
+ shinyjs::hide("cor_na_omit")
|
|
| 126 | -+ | ||
| 295 | +! |
- #' shall be replaced by values from \code{str_args}.
+ qenv <- teal.code::eval_code( |
|
| 127 | -+ | ||
| 296 | +! |
- #' @param str_args (\code{character}) A character vector that the function shall
+ qenv, |
|
| 128 | -+ | ||
| 297 | +! |
- #' be executed with+ substitute( |
|
| 129 | -+ | ||
| 298 | +! |
- #'+ expr = {
|
|
| 130 | -+ | ||
| 299 | +! |
- #' @return: call (i.e. expression) of the function provided by \code{fun}
+ g <- lattice::splom(ANL, varnames = varnames_value, pch = 16, alpha = alpha_value, cex = cex_value) |
|
| 131 | -+ | ||
| 300 | +! |
- #' with arguments provided by \code{str_args}.
+ g |
|
| 132 | +301 |
- #' @keywords internal+ }, |
|
| 133 | -+ | ||
| 302 | +! |
- #'+ env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex) |
|
| 134 | +303 |
- #' @examples+ ) |
|
| 135 | +304 |
- #' \dontrun{
+ ) |
|
| 136 | +305 |
- #' a <- 1+ } |
|
| 137 | -+ | ||
| 306 | +! |
- #' b <- 2+ qenv |
|
| 138 | +307 |
- #' call_fun_dots("sum", c("a", "b"))
+ }) |
|
| 139 | +308 |
- #' eval(call_fun_dots("sum", c("a", "b")))
+
+ |
+ |
| 309 | +! | +
+ plot_r <- reactive(output_q()[["g"]]) |
|
| 140 | +310 |
- #' }+ |
|
| 141 | +311 |
- call_fun_dots <- function(fun, str_args) {
+ # Insert the plot into a plot_with_settings module |
|
| 142 | +312 | ! |
- do.call("call", c(list(fun), lapply(str_args, as.name)), quote = TRUE)
+ pws <- teal.widgets::plot_with_settings_srv( |
| 143 | -+ | ||
| 313 | +! |
- }+ id = "myplot", |
|
| 144 | -+ | ||
| 314 | +! |
-
+ plot_r = plot_r, |
|
| 145 | -+ | ||
| 315 | +! |
- #' Get variable name with label+ height = plot_height, |
|
| 146 | -+ | ||
| 316 | +! |
- #'+ width = plot_width |
|
| 147 | +317 |
- #' @param var_names (\code{character}) Name of variable to extract labels from.
+ ) |
|
| 148 | +318 |
- #' @param dataset (\code{dataset}) Name of analysis dataset.
+
|
|
| 149 | +319 |
- #' @param prefix (\code{character}) String to paste to the beginning of the
+ # show a message if conversion to factors took place |
|
| 150 | -+ | ||
| 320 | +! |
- #' variable name with label.+ output$message <- renderText({
|
|
| 151 | -+ | ||
| 321 | +! |
- #' @param suffix (\code{character}) String to paste to the end of the variable
+ shiny::req(iv_r()$is_valid()) |
|
| 152 | -+ | ||
| 322 | +! |
- #' name with label.+ req(selector_list()$variables()) |
|
| 153 | -+ | ||
| 323 | +! |
- #' @param wrap_width (\code{numeric}) Number of characters to wrap original
+ ANL <- merged$anl_q_r()[["ANL"]] # nolint |
|
| 154 | -+ | ||
| 324 | +! |
- #' label to. Defaults to 80.+ cols_names <- unique(unname(do.call(c, merged$anl_input_r()$columns_source))) |
|
| 155 | -+ | ||
| 325 | +! |
- #'+ check_char <- vapply(ANL[, cols_names], is.character, logical(1)) |
|
| 156 | -+ | ||
| 326 | +! |
- #' @return (\code{character}) String with variable name and label.
+ if (any(check_char)) {
|
|
| 157 | -+ | ||
| 327 | +! |
- #' @keywords internal+ is_single <- sum(check_char) == 1 |
|
| 158 | -+ | ||
| 328 | +! |
- #'+ paste( |
|
| 159 | -+ | ||
| 329 | +! |
- #' @examples+ "Character", |
|
| 160 | -+ | ||
| 330 | +! |
- #' \dontrun{
+ ifelse(is_single, "variable", "variables"), |
|
| 161 | -+ | ||
| 331 | +! |
- #' ADSL <- teal.modules.general::rADSL+ paste0("(", paste(cols_names[check_char], collapse = ", "), ")"),
|
|
| 162 | -+ | ||
| 332 | +! |
- #'+ ifelse(is_single, "was", "were"), |
|
| 163 | -+ | ||
| 333 | +! |
- #' varname_w_label("AGE", ADSL)
+ "converted to", |
|
| 164 | -+ | ||
| 334 | +! |
- #' }+ ifelse(is_single, "factor.", "factors.") |
|
| 165 | +335 |
- varname_w_label <- function(var_names,+ ) |
|
| 166 | +336 |
- dataset,+ } else {
|
|
| 167 | +337 |
- wrap_width = 80,+ "" |
|
| 168 | +338 |
- prefix = NULL,+ } |
|
| 169 | +339 |
- suffix = NULL) {
+ }) |
|
| 170 | -! | +||
| 340 | +
- add_label <- function(var_names) {
+
|
||
| 171 | +341 | ! |
- label <- vapply(+ teal.widgets::verbatim_popup_srv( |
| 172 | +342 | ! |
- dataset[var_names], function(x) {
+ id = "warning", |
| 173 | +343 | ! |
- attr_label <- attr(x, "label")+ verbatim_content = reactive(teal.code::get_warnings(output_q())), |
| 174 | +344 | ! |
- `if`(is.null(attr_label), "", attr_label)- |
-
| 175 | -- |
- },+ title = "Warning", |
|
| 176 | +345 | ! |
- character(1)+ disabled = reactive(is.null(teal.code::get_warnings(output_q()))) |
| 177 | +346 |
) |
|
| 178 | +347 | ||
| 179 | +348 | ! |
- if (length(label) == 1 && !is.na(label) && !identical(label, "")) {
+ teal.widgets::verbatim_popup_srv( |
| 180 | +349 | ! |
- paste0(prefix, label, " [", var_names, "]", suffix)+ id = "rcode", |
| 181 | -+ | ||
| 350 | +! |
- } else {
+ verbatim_content = reactive(teal.code::get_code(output_q())), |
|
| 182 | +351 | ! |
- var_names+ title = "Show R Code for Scatterplotmatrix" |
| 183 | +352 |
- }+ ) |
|
| 184 | +353 |
- }+ |
|
| 185 | +354 |
-
+ ### REPORTER |
|
| 186 | +355 | ! |
- if (length(var_names) < 1) {
+ if (with_reporter) {
|
| 187 | +356 | ! |
- NULL+ card_fun <- function(comment, label) {
|
| 188 | +357 | ! |
- } else if (length(var_names) == 1) {
+ card <- teal::report_card_template( |
| 189 | +358 | ! |
- stringr::str_wrap(add_label(var_names), width = wrap_width)+ title = "Scatter Plot Matrix", |
| 190 | +359 | ! |
- } else if (length(var_names) > 1) {
+ label = label, |
| 191 | +360 | ! |
- stringr::str_wrap(vapply(var_names, add_label, character(1)), width = wrap_width)+ with_filter = with_filter, |
| 192 | -+ | ||
| 361 | +! |
- }+ filter_panel_api = filter_panel_api |
|
| 193 | +362 |
- }+ ) |
|
| 194 | -+ | ||
| 363 | +! |
-
+ card$append_text("Plot", "header3")
|
|
| 195 | -+ | ||
| 364 | +! |
- #' Extract html id for `data_extract_ui`+ card$append_plot(plot_r(), dim = pws$dim()) |
|
| 196 | -+ | ||
| 365 | +! |
- #' @description The `data_extract_ui` is located under extended html id.+ if (!comment == "") {
|
|
| 197 | -+ | ||
| 366 | +! |
- #' We could not use \code{ns("original id")} for reference, as it is extended with specific suffixes.
+ card$append_text("Comment", "header3")
+ |
+ |
| 367 | +! | +
+ card$append_text(comment) |
|
| 198 | +368 |
- #' @param varname character original html id.+ }+ |
+ |
| 369 | +! | +
+ card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n"))+ |
+ |
| 370 | +! | +
+ card |
|
| 199 | +371 |
- #' This will be mostly retrieved with \code{ns("original id")} in `ui` or
+ }+ |
+ |
| 372 | +! | +
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 200 | +373 |
- #' \code{session$ns("original id")} in server function.
+ } |
|
| 201 | +374 |
- #' @param dataname character \code{dataname} from data_extract input.
+ ### |
|
| 202 | +375 |
- #' This might be retrieved like \code{teal.transform::data_extract_spec(...)[[1]]$dataname}.
+ }) |
|
| 203 | +376 |
- #' @param filter logical if the connected \code{extract_data_spec} is used with \code{filter} option.
+ } |
|
| 204 | +377 |
- #' @keywords internal+ |
|
| 205 | +378 |
- extract_input <- function(varname, dataname, filter = FALSE) {
+ #' Get stats for x-y pairs in scatterplot matrix |
|
| 206 | -! | +||
| 379 | +
- if (filter) {
+ #' @description uses stats::cor.test per default for all numerical input variables and converts results |
||
| 207 | -! | +||
| 380 | +
- paste0(varname, "-dataset_", dataname, "_singleextract-filter1-vals")+ #' to character vector. Could be extended if different stats for different variable |
||
| 208 | +381 |
- } else {
+ #' types are needed. Meant to be called from \code{lattice::panel.text}.
|
|
| 209 | -! | +||
| 382 | +
- paste0(varname, "-dataset_", dataname, "_singleextract-select")+ #' @param x \code{numeric}
|
||
| 210 | +383 |
- }+ #' @param y \code{numeric}
|
|
| 211 | +384 |
- }+ #' @param .f \code{function}, function that accepts x and y as formula input \code{~ x + y}.
|
|
| 212 | +385 |
-
+ #' Default \code{stats::cor.test}
|
|
| 213 | +386 |
- # see vignette("ggplot2-specs", package="ggplot2")
+ #' @param .f_args \code{list} of arguments to be passed to \code{.f}
|
|
| 214 | +387 |
- shape_names <- c(+ #' @param round_stat \code{integer}
|
|
| 215 | +388 |
- "circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",
+ #' @param round_pval \code{integer}
|
|
| 216 | +389 |
- "square", paste("square", c("open", "filled", "cross", "plus", "triangle")),
+ #' @details presently we need to use a formula input for \code{stats::cor.test} because
|
|
| 217 | +390 |
- "diamond", paste("diamond", c("open", "filled", "plus")),
+ #' \code{na.fail} only gets evaluated when a formula is passed (see below).
|
|
| 218 | +391 |
- "triangle", paste("triangle", c("open", "filled", "square")),
+ #' \preformatted{
|
|
| 219 | +392 |
- paste("triangle down", c("open", "filled")),
+ #' x = c(1,3,5,7,NA) |
|
| 220 | +393 |
- "plus", "cross", "asterisk"+ #' y = c(3,6,7,8,1) |
|
| 221 | +394 |
- )+ #' stats::cor.test(x, y, na.action = "na.fail") |
|
| 222 | +395 |
-
+ #' stats::cor.test(~ x + y, na.action = "na.fail") |
|
| 223 | +396 |
- #' Get icons to represent variable types in dataset+ #' } |
|
| 224 | +397 |
- #'+ #' @return \code{character} with stats. For \code{stats::cor.test} correlation coefficient and p-value.
|
|
| 225 | +398 |
- #' @param var_type (`character`)\cr+ #' @export |
|
| 226 | +399 |
- #' of R internal types (classes).+ #' @examples |
|
| 227 | +400 |
- #'+ #' set.seed(1) |
|
| 228 | +401 |
- #' @return (`character`)\cr+ #' x <- runif(25, 0, 1) |
|
| 229 | +402 |
- #' vector of HTML icons corresponding to data type in each column.+ #' y <- runif(25, 0, 1) |
|
| 230 | +403 |
- #' @keywords internal+ #' x[c(3, 10, 18)] <- NA |
|
| 231 | +404 |
#' |
|
| 232 | +405 |
- #' @examples+ #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson")) |
|
| 233 | +406 |
- #' teal.modules.general:::variable_type_icons(c(+ #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list( |
|
| 234 | +407 |
- #' "integer", "numeric", "logical", "Date", "POSIXct", "POSIXlt",+ #' method = "pearson", |
|
| 235 | +408 |
- #' "factor", "character", "unknown", ""+ #' na.action = na.fail |
|
| 236 | +409 |
#' )) |
|
| 237 | +410 |
- variable_type_icons <- function(var_type) {
+ get_scatterplotmatrix_stats <- function(x, y, |
|
| 238 | -! | +||
| 411 | +
- checkmate::assert_character(var_type, any.missing = FALSE)+ .f = stats::cor.test, |
||
| 239 | +412 |
-
+ .f_args = list(), |
|
| 240 | -! | +||
| 413 | ++ |
+ round_stat = 2,+ |
+ |
| 414 | +
- class_to_icon <- list(+ round_pval = 4) {
|
||
| 241 | -! | +||
| 415 | +6x |
- numeric = "arrow-up-1-9",+ if (is.numeric(x) && is.numeric(y)) {
|
|
| 242 | -! | +||
| 416 | +3x |
- integer = "arrow-up-1-9",+ stat <- tryCatch(do.call(.f, c(list(~ x + y), .f_args)), error = function(e) NA) |
|
| 243 | -! | +||
| 417 | +
- logical = "pause",+ |
||
| 244 | -! | +||
| 418 | +3x |
- Date = "calendar",+ if (anyNA(stat)) {
|
|
| 245 | -! | +||
| 419 | +1x |
- POSIXct = "calendar",+ return("NA")
|
|
| 246 | -! | +||
| 420 | +2x |
- POSIXlt = "calendar",+ } else if (all(c("estimate", "p.value") %in% names(stat))) {
|
|
| 247 | -! | +||
| 421 | +2x |
- factor = "chart-bar",+ return(paste( |
|
| 248 | -! | +||
| 422 | +2x |
- character = "keyboard",+ c( |
|
| 249 | -! | +||
| 423 | +2x |
- primary_key = "key",+ paste0(names(stat$estimate), ":", round(stat$estimate, round_stat)), |
|
| 250 | -! | +||
| 424 | +2x |
- unknown = "circle-question"+ paste0("P:", round(stat$p.value, round_pval))
|
|
| 251 | +425 |
- )+ ), |
|
| 252 | -! | +||
| 426 | +2x |
- class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome")))+ collapse = "\n" |
|
| 253 | +427 |
-
+ )) |
|
| 254 | -! | +||
| 428 | +
- res <- unname(vapply(+ } else {
|
||
| 255 | +429 | ! |
- var_type,+ stop("function not supported")
|
| 256 | -! | +||
| 430 | +
- FUN.VALUE = character(1),+ } |
||
| 257 | -! | +||
| 431 | +
- FUN = function(class) {
+ } else {
|
||
| 258 | -! | +||
| 432 | +3x |
- if (class == "") {
+ if ("method" %in% names(.f_args)) {
|
|
| 259 | -! | +||
| 433 | +3x |
- class+ if (.f_args$method == "pearson") {
|
|
| 260 | -! | +||
| 434 | +1x |
- } else if (is.null(class_to_icon[[class]])) {
+ return("cor:-")
|
|
| 261 | -! | +||
| 435 | +
- class_to_icon[["unknown"]]+ } |
||
| 262 | -+ | ||
| 436 | +2x |
- } else {
+ if (.f_args$method == "kendall") {
|
|
| 263 | -! | +||
| 437 | +1x |
- class_to_icon[[class]]+ return("tau:-")
|
|
| 264 | +438 |
} |
|
| 265 | -+ | ||
| 439 | +1x |
- }+ if (.f_args$method == "spearman") {
+ |
+ |
| 440 | +1x | +
+ return("rho:-")
|
|
| 266 | +441 |
- ))+ } |
|
| 267 | +442 |
-
+ } |
|
| 268 | +443 | ! |
- return(res)+ return("-")
|
| 269 | +444 |
- }+ } |
|
| 270 | +445 |
-
+ } |
| 271 | +1 |
- #' Include `CSS` files from `/inst/css/` package directory to application header+ #' Shared Parameters |
|
| 272 | +2 |
#' |
|
| 273 | +3 |
- #' `system.file` should not be used to access files in other packages, it does+ #' @description Contains arguments that are shared between multiple functions |
|
| 274 | +4 |
- #' not work with `devtools`. Therefore, we redefine this method in each package+ #' in the package to avoid repetition using `inheritParams`. |
|
| 275 | +5 |
- #' as needed. Thus, we do not export this method+ #' |
|
| 276 | +6 |
- #'+ #' @param plot_height optional, (`numeric`) A vector of length three with `c(value, min and max)` |
|
| 277 | +7 |
- #' @param pattern (`character`) pattern of files to be included+ #' for a slider encoding the plot height. |
|
| 278 | +8 |
- #'+ #' @param plot_width optional, (`numeric`) A vector of length three with `c(value, min and max)` |
|
| 279 | +9 |
- #' @return HTML code that includes `CSS` files+ #' for a slider encoding the plot width. |
|
| 280 | +10 |
- #' @keywords internal+ #' @param rotate_xaxis_labels optional, (`logical`) Whether to rotate plot X axis labels. Does not |
|
| 281 | +11 |
- include_css_files <- function(pattern = "*") {
+ #' rotate by default (`FALSE`). |
|
| 282 | -! | +||
| 12 | +
- css_files <- list.files(+ #' @param ggtheme optional, (`character`) `ggplot2` theme to be used by default. |
||
| 283 | -! | +||
| 13 | +
- system.file("css", package = "teal.modules.general", mustWork = TRUE),
+ #' One of `c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test")`.
|
||
| 284 | -! | +||
| 14 | +
- pattern = pattern, full.names = TRUE+ #' Each theme can be chosen by the user during the session. Defaults to `"gray"`. |
||
| 285 | +15 |
- )+ #' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()] |
|
| 286 | -! | +||
| 16 | +
- if (length(css_files) == 0) {
+ #' with settings for the module plot. |
||
| 287 | -! | +||
| 17 | +
- return(NULL)+ #' The argument is merged with options variable `teal.ggplot2_args` and default module setup. |
||
| 288 | +18 |
- }+ #' |
|
| 289 | -! | +||
| 19 | +
- return(shiny::singleton(shiny::tags$head(lapply(css_files, shiny::includeCSS))))+ #' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`
|
||
| 290 | +20 |
- }+ #' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()] |
|
| 291 | +21 |
-
+ #' with settings for the module table. |
|
| 292 | +22 |
-
+ #' The argument is merged with options variable `teal.basic_table_args` and default module setup. |
|
| 293 | +23 |
- #' Get Label Attributes of Variables in a \code{data.frame}
+ #' |
|
| 294 | +24 |
- #'+ #' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")`
|
|
| 295 | +25 |
- #' Variable labels can be stored as a \code{label} attribute for each variable.
+ #' @param pre_output (`shiny.tag`, optional)\cr |
|
| 296 | +26 |
- #' This functions returns a named character vector with the variable labels+ #' with text placed before the output to put the output into context. For example a title. |
|
| 297 | +27 |
- #' (empty sting if not specified)+ #' @param post_output (`shiny.tag`, optional) with text placed after the output to put the output |
|
| 298 | +28 |
- #'+ #' into context. For example the [shiny::helpText()] elements are useful. |
|
| 299 | +29 |
- #' @param x a \code{data.frame} object
+ #' |
|
| 300 | +30 |
- #' @param fill boolean in case the \code{label} attribute does not exist if
+ #' @name shared_params |
|
| 301 | +31 |
- #' \code{TRUE} the variable names is returned, otherwise \code{NA}
+ #' @keywords internal |
|
| 302 | +32 |
- #'+ NULL |
|
| 303 | +33 |
- #' @return a named character vector with the variable labels, the names+ |
|
| 304 | +34 |
- #' correspond to the variable names+ #' Add axis labels that show facetting variable |
|
| 305 | +35 |
#' |
|
| 306 | +36 |
- #' @note the `formatters` package is the source of the function.+ #' Add axis labels that show facetting variable |
|
| 307 | +37 |
#' |
|
| 308 | +38 |
- #' @keywords internal+ #' @param p `ggplot2` object to add facet labels to |
|
| 309 | +39 |
- var_labels <- function(x, fill = FALSE) {
- |
- |
| 310 | -! | -
- stopifnot(is.data.frame(x))- |
- |
| 311 | -! | -
- if (NCOL(x) == 0) {
- |
- |
| 312 | -! | -
- return(character())+ #' @param xfacet_label label of facet along x axis (nothing created if NULL), |
|
| 313 | +40 |
- }+ #' if vector, will be concatenated with " & " |
|
| 314 | +41 |
-
+ #' @param yfacet_label label of facet along y axis (nothing created if NULL), |
|
| 315 | -! | +||
| 42 | +
- y <- Map(function(col, colname) {
+ #' if vector, will be concatenated with " & " |
||
| 316 | -! | +||
| 43 | +
- label <- attr(col, "label")+ #' |
||
| 317 | +44 |
-
+ #' @return grid grob object (to be drawn with \code{grid.draw})
|
|
| 318 | -! | +||
| 45 | +
- if (is.null(label)) {
+ #' |
||
| 319 | -! | +||
| 46 | +
- if (fill) {
+ #' @export |
||
| 320 | -! | +||
| 47 | +
- colname+ #' |
||
| 321 | +48 |
- } else {
+ #' @examples |
|
| 322 | -! | +||
| 49 | +
- NA_character_+ #' # we put donttest to avoid strictr error with seq along.with argument |
||
| 323 | +50 |
- }+ #' \donttest{
|
|
| 324 | +51 |
- } else {
+ #' library(ggplot2) |
|
| 325 | -! | +||
| 52 | +
- if (!is.character(label) && !(length(label) == 1)) {
+ #' library(grid) |
||
| 326 | -! | +||
| 53 | +
- stop("label for variable ", colname, "is not a character string")
+ #' |
||
| 327 | +54 |
- }+ #' p <- ggplot(mtcars) + |
|
| 328 | -! | +||
| 55 | +
- as.vector(label)+ #' aes(x = mpg, y = disp) + |
||
| 329 | +56 |
- }+ #' geom_point() + |
|
| 330 | -! | +||
| 57 | +
- }, x, colnames(x))+ #' facet_grid(gear ~ cyl) |
||
| 331 | +58 |
-
+ #' p |
|
| 332 | -! | +||
| 59 | +
- labels <- unlist(y, recursive = FALSE, use.names = TRUE)+ #' xfacet_label <- "cylinders" |
||
| 333 | +60 |
-
+ #' yfacet_label <- "gear" |
|
| 334 | -! | +||
| 61 | +
- if (!is.character(labels)) {
+ #' res <- add_facet_labels(p, xfacet_label, yfacet_label) |
||
| 335 | -! | +||
| 62 | +
- stop("label extraction failed")
+ #' grid.newpage() |
||
| 336 | +63 |
- }+ #' grid.draw(res) |
|
| 337 | +64 |
-
+ #' |
|
| 338 | -! | +||
| 65 | +
- labels+ #' grid.newpage() |
||
| 339 | +66 |
- }+ #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label)) |
|
| 340 | +67 |
-
+ #' grid.newpage() |
|
| 341 | +68 |
- #' Get a string with java-script code checking if the specific tab is clicked+ #' grid.draw(add_facet_labels(p, xfacet_label, yfacet_label = NULL)) |
|
| 342 | +69 |
- #' @description will be the input for `shiny::conditionalPanel()`+ #' grid.newpage() |
|
| 343 | +70 |
- #' @param id `character(1)` the id of the tab panel with tabs.+ #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label = NULL)) |
|
| 344 | +71 |
- #' @param name `character(1)` the name of the tab.+ #' } |
|
| 345 | +72 |
- #' @keywords internal+ #' |
|
| 346 | +73 |
- is_tab_active_js <- function(id, name) {
+ add_facet_labels <- function(p, xfacet_label = NULL, yfacet_label = NULL) {
|
|
| 347 | -+ | ||
| 74 | +! |
- # supporting the bs3 and higher version at the same time+ checkmate::assert_class(p, classes = "ggplot") |
|
| 348 | +75 | ! |
- sprintf(+ checkmate::assert_character(xfacet_label, null.ok = TRUE, min.len = 1) |
| 349 | +76 | ! |
- "$(\"#%1$s > li.active\").text().trim() == '%2$s' || $(\"#%1$s > li a.active\").text().trim() == '%2$s'",+ checkmate::assert_character(yfacet_label, null.ok = TRUE, min.len = 1) |
| 350 | +77 | ! |
- id, name+ if (is.null(xfacet_label) && is.null(yfacet_label)) {
|
| 351 | -+ | ||
| 78 | +! |
- )+ return(ggplotGrob(p)) |
|
| 352 | +79 |
- }+ } |
| 1 | -+ | ||
| 80 | +! |
- #' Stack Plots of variables and show association with reference variable+ grid::grid.grabExpr({
|
|
| 2 | -+ | ||
| 81 | +! |
- #' @md+ g <- ggplotGrob(p) |
|
| 3 | +82 |
- #'+ |
|
| 4 | +83 |
- #' @inheritParams teal::module+ # we are going to replace these, so we make sure they have nothing in them |
|
| 5 | -+ | ||
| 84 | +! |
- #' @inheritParams shared_params+ checkmate::assert_class(g$grobs[[grep("xlab-t", g$layout$name, fixed = TRUE)]], "zeroGrob")
|
|
| 6 | -+ | ||
| 85 | +! |
- #' @param ref (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ checkmate::assert_class(g$grobs[[grep("ylab-r", g$layout$name, fixed = TRUE)]], "zeroGrob")
|
|
| 7 | +86 |
- #' reference variable, must set `multiple = FALSE`.+ |
|
| 8 | -+ | ||
| 87 | +! |
- #' @param vars (`data_extract_spec` or `list` of multiple `data_extract_spec`)+ xaxis_label_grob <- g$grobs[[grep("xlab-b", g$layout$name, fixed = TRUE)]]
|
|
| 9 | -+ | ||
| 88 | +! |
- #' associated variables.+ xaxis_label_grob$children[[1]]$label <- paste(xfacet_label, collapse = " & ") |
|
| 10 | -+ | ||
| 89 | +! |
- #' @param show_association optional, (`logical`) Whether show association of `vars`+ yaxis_label_grob <- g$grobs[[grep("ylab-l", g$layout$name, fixed = TRUE)]]
|
|
| 11 | -+ | ||
| 90 | +! |
- #' with reference variable. Defaults to `TRUE`.+ yaxis_label_grob$children[[1]]$label <- paste(yfacet_label, collapse = " & ") |
|
| 12 | -+ | ||
| 91 | +! |
- #' @param distribution_theme optional, (`character`) `ggplot2` theme to be used by default.+ yaxis_label_grob$children[[1]]$rot <- 270 |
|
| 13 | +92 |
- #' One of `c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test")`.
+
|
|
| 14 | -+ | ||
| 93 | +! |
- #' Each theme can be chosen by the user during the session. Defaults to `"gray"`.+ top_height <- if (is.null(xfacet_label)) 0 else grid::unit(2, "line") |
|
| 15 | -+ | ||
| 94 | +! |
- #' @param association_theme optional, (`character`) `ggplot2` theme to be used by default.+ right_width <- if (is.null(yfacet_label)) 0 else grid::unit(2, "line") |
|
| 16 | +95 |
- #' One of `c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test")`.
+
|
|
| 17 | -+ | ||
| 96 | +! |
- #' Each theme can be chosen by the user during the session. Defaults to `"gray"`.+ grid::grid.newpage() |
|
| 18 | -+ | ||
| 97 | +! |
- #'+ grid::pushViewport(grid::plotViewport(margins = c(0, 0, top_height, right_width), name = "ggplot")) |
|
| 19 | -+ | ||
| 98 | +! |
- #' @templateVar ggnames "Bivariate1", "Bivariate2"+ grid::grid.draw(g) |
|
| 20 | -+ | ||
| 99 | +! |
- #' @template ggplot2_args_multi+ grid::upViewport(1) |
|
| 21 | +100 |
- #'+ |
|
| 22 | +101 |
- #' @note For more examples, please see the vignette "Using association plot" via+ # draw x facet |
|
| 23 | -+ | ||
| 102 | +! |
- #' \code{vignette("using-association-plot", package = "teal.modules.general")}.
+ if (!is.null(xfacet_label)) {
|
|
| 24 | -+ | ||
| 103 | +! |
- #' @export+ grid::pushViewport(grid::viewport( |
|
| 25 | -+ | ||
| 104 | +! |
- #' @examples+ x = 0, y = grid::unit(1, "npc") - top_height, width = grid::unit(1, "npc"), |
|
| 26 | -+ | ||
| 105 | +! |
- #' # Association plot of selected reference variable (SEX)+ height = top_height, just = c("left", "bottom"), name = "topxaxis"
|
|
| 27 | +106 |
- #' # against other selected variables (BMRKR1)+ )) |
|
| 28 | -+ | ||
| 107 | +! |
- #' library(nestcolor)+ grid::grid.draw(xaxis_label_grob) |
|
| 29 | -+ | ||
| 108 | +! |
- #' ADSL <- teal.modules.general::rADSL+ grid::upViewport(1) |
|
| 30 | +109 |
- #'+ } |
|
| 31 | +110 |
- #' app <- teal::init(+ |
|
| 32 | +111 |
- #' data = teal.data::cdisc_data(+ # draw y facet |
|
| 33 | -+ | ||
| 112 | +! |
- #' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
+ if (!is.null(yfacet_label)) {
|
|
| 34 | -+ | ||
| 113 | +! |
- #' check = TRUE+ grid::pushViewport(grid::viewport( |
|
| 35 | -+ | ||
| 114 | +! |
- #' ),+ x = grid::unit(1, "npc") - grid::unit(as.numeric(right_width) / 2, "line"), y = 0, width = right_width, |
|
| 36 | -+ | ||
| 115 | +! |
- #' modules = teal::modules(+ height = grid::unit(1, "npc"), just = c("left", "bottom"), name = "rightyaxis"
|
|
| 37 | +116 |
- #' teal.modules.general::tm_g_association(+ ))+ |
+ |
| 117 | +! | +
+ grid::grid.draw(yaxis_label_grob)+ |
+ |
| 118 | +! | +
+ grid::upViewport(1) |
|
| 38 | +119 |
- #' ref = teal.transform::data_extract_spec(+ } |
|
| 39 | +120 |
- #' dataname = "ADSL",+ }) |
|
| 40 | +121 |
- #' select = teal.transform::select_spec(+ } |
|
| 41 | +122 |
- #' label = "Select variable:",+ |
|
| 42 | +123 |
- #' choices = teal.transform::variable_choices(+ #' Call a function with a character vector for the \code{...} argument
|
|
| 43 | +124 |
- #' ADSL,+ #' |
|
| 44 | +125 |
- #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
+ #' @param fun (\code{character}) Name of a function where the \code{...} argument
|
|
| 45 | +126 |
- #' ),+ #' shall be replaced by values from \code{str_args}.
|
|
| 46 | +127 |
- #' selected = "RACE",+ #' @param str_args (\code{character}) A character vector that the function shall
|
|
| 47 | +128 |
- #' fixed = FALSE+ #' be executed with |
|
| 48 | +129 |
- #' )+ #' |
|
| 49 | +130 |
- #' ),+ #' @return: call (i.e. expression) of the function provided by \code{fun}
|
|
| 50 | +131 |
- #' vars = teal.transform::data_extract_spec(+ #' with arguments provided by \code{str_args}.
|
|
| 51 | +132 |
- #' dataname = "ADSL",+ #' @keywords internal |
|
| 52 | +133 |
- #' select = teal.transform::select_spec(+ #' |
|
| 53 | +134 |
- #' label = "Select variables:",+ #' @examples |
|
| 54 | +135 |
- #' choices = teal.transform::variable_choices(+ #' \dontrun{
|
|
| 55 | +136 |
- #' ADSL,+ #' a <- 1 |
|
| 56 | +137 |
- #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
+ #' b <- 2 |
|
| 57 | +138 |
- #' ),+ #' call_fun_dots("sum", c("a", "b"))
|
|
| 58 | +139 |
- #' selected = "BMRKR2",+ #' eval(call_fun_dots("sum", c("a", "b")))
|
|
| 59 | +140 |
- #' multiple = TRUE,+ #' } |
|
| 60 | +141 |
- #' fixed = FALSE+ call_fun_dots <- function(fun, str_args) {
+ |
+ |
| 142 | +! | +
+ do.call("call", c(list(fun), lapply(str_args, as.name)), quote = TRUE)
|
|
| 61 | +143 |
- #' )+ } |
|
| 62 | +144 |
- #' ),+ |
|
| 63 | +145 |
- #' ggplot2_args = teal.widgets::ggplot2_args(+ #' Get variable name with label |
|
| 64 | +146 |
- #' labs = list(subtitle = "Plot generated by Association Module")+ #' |
|
| 65 | +147 |
- #' )+ #' @param var_names (\code{character}) Name of variable to extract labels from.
|
|
| 66 | +148 |
- #' )+ #' @param dataset (\code{dataset}) Name of analysis dataset.
|
|
| 67 | +149 |
- #' )+ #' @param prefix (\code{character}) String to paste to the beginning of the
|
|
| 68 | +150 |
- #' )+ #' variable name with label. |
|
| 69 | +151 |
- #' if (interactive()) {
+ #' @param suffix (\code{character}) String to paste to the end of the variable
|
|
| 70 | +152 |
- #' shinyApp(app$ui, app$server)+ #' name with label. |
|
| 71 | +153 |
- #' }+ #' @param wrap_width (\code{numeric}) Number of characters to wrap original
|
|
| 72 | +154 |
- tm_g_association <- function(label = "Association",+ #' label to. Defaults to 80. |
|
| 73 | +155 |
- ref,+ #' |
|
| 74 | +156 |
- vars,+ #' @return (\code{character}) String with variable name and label.
|
|
| 75 | +157 |
- show_association = TRUE,+ #' @keywords internal |
|
| 76 | +158 |
- plot_height = c(600, 400, 5000),+ #' |
|
| 77 | +159 |
- plot_width = NULL,+ #' @examples |
|
| 78 | +160 |
- distribution_theme = c(+ #' \dontrun{
|
|
| 79 | +161 |
- "gray", "bw", "linedraw", "light", "dark",+ #' ADSL <- teal.modules.general::rADSL |
|
| 80 | +162 |
- "minimal", "classic", "void", "test"+ #' |
|
| 81 | +163 |
- ),+ #' varname_w_label("AGE", ADSL)
|
|
| 82 | +164 |
- association_theme = c(+ #' } |
|
| 83 | +165 |
- "gray", "bw", "linedraw", "light", "dark",+ varname_w_label <- function(var_names, |
|
| 84 | +166 |
- "minimal", "classic", "void", "test"+ dataset, |
|
| 85 | +167 |
- ),+ wrap_width = 80, |
|
| 86 | +168 |
- pre_output = NULL,+ prefix = NULL, |
|
| 87 | +169 |
- post_output = NULL,+ suffix = NULL) {
|
|
| 88 | -+ | ||
| 170 | +! |
- ggplot2_args = teal.widgets::ggplot2_args()) {
+ add_label <- function(var_names) {
|
|
| 89 | +171 | ! |
- logger::log_info("Initializing tm_g_association")
+ label <- vapply( |
| 90 | +172 | ! |
- if (inherits(ref, "data_extract_spec")) ref <- list(ref)+ dataset[var_names], function(x) {
|
| 91 | +173 | ! |
- if (inherits(vars, "data_extract_spec")) vars <- list(vars)+ attr_label <- attr(x, "label") |
| 92 | +174 | ! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)+ `if`(is.null(attr_label), "", attr_label) |
| 93 | +175 |
-
+ }, |
|
| 94 | +176 | ! |
- checkmate::assert_string(label)+ character(1) |
| 95 | -! | +||
| 177 | +
- checkmate::assert_list(ref, types = "data_extract_spec")+ )+ |
+ ||
| 178 | ++ | + | |
| 96 | +179 | ! |
- if (!all(vapply(ref, function(x) !x$select$multiple, logical(1)))) {
+ if (length(label) == 1 && !is.na(label) && !identical(label, "")) {
|
| 97 | +180 | ! |
- stop("'ref' should not allow multiple selection")
+ paste0(prefix, label, " [", var_names, "]", suffix) |
| 98 | +181 |
- }+ } else {
|
|
| 99 | +182 | ! |
- checkmate::assert_list(vars, types = "data_extract_spec")+ var_names |
| 100 | -! | +||
| 183 | +
- checkmate::assert_flag(show_association)+ } |
||
| 101 | -! | +||
| 184 | +
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)+ } |
||
| 102 | -! | +||
| 185 | +
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")+ |
||
| 103 | +186 | ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)+ if (length(var_names) < 1) {
|
| 104 | +187 | ! |
- checkmate::assert_numeric(+ NULL |
| 105 | +188 | ! |
- plot_width[1],+ } else if (length(var_names) == 1) {
|
| 106 | +189 | ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"+ stringr::str_wrap(add_label(var_names), width = wrap_width) |
| 107 | -+ | ||
| 190 | +! |
- )+ } else if (length(var_names) > 1) {
|
|
| 108 | +191 | ! |
- distribution_theme <- match.arg(distribution_theme)+ stringr::str_wrap(vapply(var_names, add_label, character(1)), width = wrap_width) |
| 109 | -! | +||
| 192 | +
- association_theme <- match.arg(association_theme)+ } |
||
| 110 | -! | +||
| 193 | +
- plot_choices <- c("Bivariate1", "Bivariate2")
+ } |
||
| 111 | -! | +||
| 194 | +
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")+ |
||
| 112 | -! | +||
| 195 | +
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ #' Extract html id for `data_extract_ui` |
||
| 113 | +196 |
-
+ #' @description The `data_extract_ui` is located under extended html id. |
|
| 114 | -! | +||
| 197 | +
- args <- as.list(environment())+ #' We could not use \code{ns("original id")} for reference, as it is extended with specific suffixes.
|
||
| 115 | +198 |
-
+ #' @param varname character original html id. |
|
| 116 | -! | +||
| 199 | +
- data_extract_list <- list(+ #' This will be mostly retrieved with \code{ns("original id")} in `ui` or
|
||
| 117 | -! | +||
| 200 | +
- ref = ref,+ #' \code{session$ns("original id")} in server function.
|
||
| 118 | -! | +||
| 201 | +
- vars = vars+ #' @param dataname character \code{dataname} from data_extract input.
|
||
| 119 | +202 |
- )+ #' This might be retrieved like \code{teal.transform::data_extract_spec(...)[[1]]$dataname}.
|
|
| 120 | +203 |
-
+ #' @param filter logical if the connected \code{extract_data_spec} is used with \code{filter} option.
|
|
| 121 | -! | +||
| 204 | +
- module(+ #' @keywords internal |
||
| 122 | -! | +||
| 205 | +
- label = label,+ extract_input <- function(varname, dataname, filter = FALSE) {
|
||
| 123 | +206 | ! |
- server = srv_tm_g_association,+ if (filter) {
|
| 124 | +207 | ! |
- ui = ui_tm_g_association,+ paste0(varname, "-dataset_", dataname, "_singleextract-filter1-vals") |
| 125 | -! | +||
| 208 | +
- ui_args = args,+ } else {
|
||
| 126 | +209 | ! |
- server_args = c(+ paste0(varname, "-dataset_", dataname, "_singleextract-select") |
| 127 | -! | +||
| 210 | +
- data_extract_list,+ } |
||
| 128 | -! | +||
| 211 | +
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)+ } |
||
| 129 | +212 |
- ),+ |
|
| 130 | -! | +||
| 213 | +
- datanames = teal.transform::get_extract_datanames(data_extract_list)+ # see vignette("ggplot2-specs", package="ggplot2")
|
||
| 131 | +214 |
- )+ shape_names <- c( |
|
| 132 | +215 |
- }+ "circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",
|
|
| 133 | +216 |
-
+ "square", paste("square", c("open", "filled", "cross", "plus", "triangle")),
|
|
| 134 | +217 |
- ui_tm_g_association <- function(id, ...) {
+ "diamond", paste("diamond", c("open", "filled", "plus")),
|
|
| 135 | -! | +||
| 218 | +
- ns <- NS(id)+ "triangle", paste("triangle", c("open", "filled", "square")),
|
||
| 136 | -! | +||
| 219 | +
- args <- list(...)+ paste("triangle down", c("open", "filled")),
|
||
| 137 | -! | +||
| 220 | +
- is_single_dataset_value <- teal.transform::is_single_dataset(args$ref, args$vars)+ "plus", "cross", "asterisk" |
||
| 138 | +221 |
-
+ ) |
|
| 139 | -! | +||
| 222 | +
- teal.widgets::standard_layout(+ |
||
| 140 | -! | +||
| 223 | +
- output = teal.widgets::white_small_well(+ #' Get icons to represent variable types in dataset |
||
| 141 | -! | +||
| 224 | +
- textOutput(ns("title")),
+ #' |
||
| 142 | -! | +||
| 225 | +
- tags$br(),+ #' @param var_type (`character`)\cr |
||
| 143 | -! | +||
| 226 | +
- teal.widgets::plot_with_settings_ui(id = ns("myplot"))
+ #' of R internal types (classes). |
||
| 144 | +227 |
- ),+ #' |
|
| 145 | -! | +||
| 228 | +
- encoding = div(+ #' @return (`character`)\cr |
||
| 146 | +229 |
- ### Reporter+ #' vector of HTML icons corresponding to data type in each column. |
|
| 147 | -! | +||
| 230 | +
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ #' @keywords internal |
||
| 148 | +231 |
- ###+ #' |
|
| 149 | -! | +||
| 232 | +
- tags$label("Encodings", class = "text-primary"),
+ #' @examples |
||
| 150 | -! | +||
| 233 | +
- teal.transform::datanames_input(args[c("ref", "vars")]),
+ #' teal.modules.general:::variable_type_icons(c( |
||
| 151 | -! | +||
| 234 | +
- teal.transform::data_extract_ui(+ #' "integer", "numeric", "logical", "Date", "POSIXct", "POSIXlt", |
||
| 152 | -! | +||
| 235 | +
- id = ns("ref"),
+ #' "factor", "character", "unknown", "" |
||
| 153 | -! | +||
| 236 | +
- label = "Reference variable",+ #' )) |
||
| 154 | -! | +||
| 237 | +
- data_extract_spec = args$ref,+ variable_type_icons <- function(var_type) {
|
||
| 155 | +238 | ! |
- is_single_dataset = is_single_dataset_value+ checkmate::assert_character(var_type, any.missing = FALSE) |
| 156 | +239 |
- ),+ |
|
| 157 | +240 | ! |
- teal.transform::data_extract_ui(+ class_to_icon <- list( |
| 158 | +241 | ! |
- id = ns("vars"),
+ numeric = "arrow-up-1-9", |
| 159 | +242 | ! |
- label = "Associated variables",+ integer = "arrow-up-1-9", |
| 160 | +243 | ! |
- data_extract_spec = args$vars,+ logical = "pause", |
| 161 | +244 | ! |
- is_single_dataset = is_single_dataset_value- |
-
| 162 | -- |
- ),+ Date = "calendar", |
|
| 163 | +245 | ! |
- checkboxInput(+ POSIXct = "calendar", |
| 164 | +246 | ! |
- ns("association"),
+ POSIXlt = "calendar", |
| 165 | +247 | ! |
- "Association with reference variable",+ factor = "chart-bar", |
| 166 | +248 | ! |
- value = args$show_association- |
-
| 167 | -- |
- ),+ character = "keyboard", |
|
| 168 | +249 | ! |
- checkboxInput(+ primary_key = "key", |
| 169 | +250 | ! |
- ns("show_dist"),
+ unknown = "circle-question" |
| 170 | -! | +||
| 251 | +
- "Scaled frequencies",+ ) |
||
| 171 | +252 | ! |
- value = FALSE+ class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome"))) |
| 172 | +253 |
- ),+ |
|
| 173 | +254 | ! |
- checkboxInput(+ res <- unname(vapply( |
| 174 | +255 | ! |
- ns("log_transformation"),
+ var_type, |
| 175 | +256 | ! |
- "Log transformed",+ FUN.VALUE = character(1), |
| 176 | +257 | ! |
- value = FALSE- |
-
| 177 | -- |
- ),+ FUN = function(class) {
|
|
| 178 | +258 | ! |
- teal.widgets::panel_group(+ if (class == "") {
|
| 179 | +259 | ! |
- teal.widgets::panel_item(+ class |
| 180 | +260 | ! |
- title = "Plot settings",+ } else if (is.null(class_to_icon[[class]])) {
|
| 181 | +261 | ! |
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Scatterplot opacity:", c(0.5, 0, 1), ticks = FALSE),
+ class_to_icon[["unknown"]] |
| 182 | -! | +||
| 262 | +
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Scatterplot points size:", c(2, 1, 8), ticks = FALSE),
+ } else {
|
||
| 183 | +263 | ! |
- checkboxInput(ns("swap_axes"), "Swap axes", value = FALSE),
+ class_to_icon[[class]] |
| 184 | -! | +||
| 264 | +
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = FALSE),
+ } |
||
| 185 | -! | +||
| 265 | +
- selectInput(+ } |
||
| 186 | -! | +||
| 266 | +
- inputId = ns("distribution_theme"),
+ )) |
||
| 187 | -! | +||
| 267 | +
- label = "Distribution theme (by ggplot):",+ |
||
| 188 | +268 | ! |
- choices = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
+ return(res) |
| 189 | -! | +||
| 269 | +
- selected = args$distribution_theme,+ } |
||
| 190 | -! | +||
| 270 | +
- multiple = FALSE+ |
||
| 191 | +271 |
- ),+ #' Include `CSS` files from `/inst/css/` package directory to application header |
|
| 192 | -! | +||
| 272 | +
- selectInput(+ #' |
||
| 193 | -! | +||
| 273 | +
- inputId = ns("association_theme"),
+ #' `system.file` should not be used to access files in other packages, it does |
||
| 194 | -! | +||
| 274 | +
- label = "Association theme (by ggplot):",+ #' not work with `devtools`. Therefore, we redefine this method in each package |
||
| 195 | -! | +||
| 275 | +
- choices = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void", "test"),
+ #' as needed. Thus, we do not export this method |
||
| 196 | -! | +||
| 276 | +
- selected = args$association_theme,+ #' |
||
| 197 | -! | +||
| 277 | +
- multiple = FALSE+ #' @param pattern (`character`) pattern of files to be included |
||
| 198 | +278 |
- )+ #' |
|
| 199 | +279 |
- )+ #' @return HTML code that includes `CSS` files |
|
| 200 | +280 |
- )+ #' @keywords internal |
|
| 201 | +281 |
- ),+ include_css_files <- function(pattern = "*") {
|
|
| 202 | +282 | ! |
- forms = tagList(+ css_files <- list.files( |
| 203 | +283 | ! |
- teal.widgets::verbatim_popup_ui(ns("warning"), "Show Warnings"),
+ system.file("css", package = "teal.modules.general", mustWork = TRUE),
|
| 204 | +284 | ! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ pattern = pattern, full.names = TRUE |
| 205 | +285 |
- ),+ ) |
|
| 206 | +286 | ! |
- pre_output = args$pre_output,+ if (length(css_files) == 0) {
|
| 207 | +287 | ! |
- post_output = args$post_output+ return(NULL) |
| 208 | +288 |
- )+ }+ |
+ |
| 289 | +! | +
+ return(shiny::singleton(shiny::tags$head(lapply(css_files, shiny::includeCSS)))) |
|
| 209 | +290 |
} |
|
| 210 | +291 | ||
| 211 | +292 |
- srv_tm_g_association <- function(id,+ |
|
| 212 | +293 |
- data,+ #' Get Label Attributes of Variables in a \code{data.frame}
|
|
| 213 | +294 |
- reporter,+ #' |
|
| 214 | +295 |
- filter_panel_api,+ #' Variable labels can be stored as a \code{label} attribute for each variable.
|
|
| 215 | +296 |
- ref,+ #' This functions returns a named character vector with the variable labels |
|
| 216 | +297 |
- vars,+ #' (empty sting if not specified) |
|
| 217 | +298 |
- plot_height,+ #' |
|
| 218 | +299 |
- plot_width,+ #' @param x a \code{data.frame} object
|
|
| 219 | +300 |
- ggplot2_args) {
+ #' @param fill boolean in case the \code{label} attribute does not exist if
|
|
| 220 | -! | +||
| 301 | +
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ #' \code{TRUE} the variable names is returned, otherwise \code{NA}
|
||
| 221 | -! | +||
| 302 | +
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")+ #' |
||
| 222 | -! | +||
| 303 | +
- checkmate::assert_class(data, "tdata")+ #' @return a named character vector with the variable labels, the names |
||
| 223 | -! | +||
| 304 | +
- moduleServer(id, function(input, output, session) {
+ #' correspond to the variable names |
||
| 224 | -! | +||
| 305 | +
- selector_list <- teal.transform::data_extract_multiple_srv(+ #' |
||
| 225 | -! | +||
| 306 | +
- data_extract = list(ref = ref, vars = vars),+ #' @note the `formatters` package is the source of the function. |
||
| 226 | -! | +||
| 307 | +
- datasets = data,+ #' |
||
| 227 | -! | +||
| 308 | +
- select_validation_rule = list(+ #' @keywords internal |
||
| 228 | -! | +||
| 309 | +
- ref = shinyvalidate::compose_rules(+ var_labels <- function(x, fill = FALSE) {
|
||
| 229 | +310 | ! |
- shinyvalidate::sv_required("A reference variable needs to be selected."),
+ stopifnot(is.data.frame(x)) |
| 230 | +311 | ! |
- ~ if ((.) %in% selector_list()$vars()$select) {
+ if (NCOL(x) == 0) {
|
| 231 | +312 | ! |
- "Associated variables and reference variable cannot overlap"+ return(character()) |
| 232 | +313 |
- }+ } |
|
| 233 | +314 |
- ),- |
- |
| 234 | -! | -
- vars = shinyvalidate::compose_rules(- |
- |
| 235 | -! | -
- shinyvalidate::sv_required("An associated variable needs to be selected."),
+
|
|
| 236 | +315 | ! |
- ~ if (length(selector_list()$ref()$select) != 0 && selector_list()$ref()$select %in% (.)) {
+ y <- Map(function(col, colname) {
|
| 237 | +316 | ! |
- "Associated variables and reference variable cannot overlap"- |
-
| 238 | -- |
- }- |
- |
| 239 | -- |
- )+ label <- attr(col, "label") |
|
| 240 | +317 |
- )+ |
|
| 241 | -+ | ||
| 318 | +! |
- )+ if (is.null(label)) {
|
|
| 242 | -+ | ||
| 319 | +! |
-
+ if (fill) {
|
|
| 243 | +320 | ! |
- iv_r <- reactive({
+ colname |
| 244 | -! | +||
| 321 | +
- iv <- shinyvalidate::InputValidator$new()+ } else {
|
||
| 245 | +322 | ! |
- teal.transform::compose_and_enable_validators(iv, selector_list)+ NA_character_ |
| 246 | +323 |
- })+ } |
|
| 247 | +324 |
-
+ } else {
|
|
| 248 | +325 | ! |
- anl_merged_input <- teal.transform::merge_expression_srv(+ if (!is.character(label) && !(length(label) == 1)) {
|
| 249 | +326 | ! |
- datasets = data,+ stop("label for variable ", colname, "is not a character string")
|
| 250 | -! | +||
| 327 | +
- selector_list = selector_list,+ } |
||
| 251 | +328 | ! |
- join_keys = get_join_keys(data)+ as.vector(label) |
| 252 | +329 |
- )+ }+ |
+ |
| 330 | +! | +
+ }, x, colnames(x)) |
|
| 253 | +331 | ||
| 254 | +332 | ! |
- anl_merged_q <- reactive({
+ labels <- unlist(y, recursive = FALSE, use.names = TRUE) |
| 255 | -! | +||
| 333 | +
- req(anl_merged_input())+ |
||
| 256 | +334 | ! |
- teal.code::new_qenv(tdata2env(data), code = get_code_tdata(data)) %>%+ if (!is.character(labels)) {
|
| 257 | +335 | ! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))+ stop("label extraction failed")
|
| 258 | +336 |
- })+ } |
|
| 259 | +337 | ||
| 260 | -! | -
- merged <- list(- |
- |
| 261 | +338 | ! |
- anl_input_r = anl_merged_input,+ labels |
| 262 | -! | +||
| 339 | +
- anl_q_r = anl_merged_q+ } |
||
| 263 | +340 |
- )+ |
|
| 264 | +341 |
-
+ #' Get a string with java-script code checking if the specific tab is clicked |
|
| 265 | -! | +||
| 342 | +
- output_q <- reactive({
+ #' @description will be the input for `shiny::conditionalPanel()` |
||
| 266 | -! | +||
| 343 | +
- teal::validate_inputs(iv_r())+ #' @param id `character(1)` the id of the tab panel with tabs. |
||
| 267 | +344 |
-
+ #' @param name `character(1)` the name of the tab. |
|
| 268 | -! | +||
| 345 | +
- ANL <- merged$anl_q_r()[["ANL"]] # nolint+ #' @keywords internal |
||
| 269 | -! | +||
| 346 | +
- teal::validate_has_data(ANL, 3)+ is_tab_active_js <- function(id, name) {
|
||
| 270 | +347 |
-
+ # supporting the bs3 and higher version at the same time |
|
| 271 | +348 | ! |
- vars_names <- merged$anl_input_r()$columns_source$vars+ sprintf( |
| 272 | -+ | ||
| 349 | +! |
-
+ "$(\"#%1$s > li.active\").text().trim() == '%2$s' || $(\"#%1$s > li a.active\").text().trim() == '%2$s'", |
|
| 273 | +350 | ! |
- ref_name <- as.vector(merged$anl_input_r()$columns_source$ref)+ id, name |
| 274 | -! | +||
| 351 | +
- association <- input$association+ ) |
||
| 275 | -! | +||
| 352 | +
- show_dist <- input$show_dist+ } |
||
| 276 | -! | +
| 1 | +
- log_transformation <- input$log_transformation+ #' Data Table Viewer Teal Module |
||
| 277 | -! | +||
| 2 | +
- rotate_xaxis_labels <- input$rotate_xaxis_labels+ #' |
||
| 278 | -! | +||
| 3 | +
- swap_axes <- input$swap_axes+ #' A data table viewer shows the data using a paginated table. |
||
| 279 | -! | +||
| 4 | +
- distribution_theme <- input$distribution_theme+ #' @md |
||
| 280 | -! | +||
| 5 | +
- association_theme <- input$association_theme+ #' |
||
| 281 | +6 |
-
+ #' @inheritParams teal::module |
|
| 282 | -! | +||
| 7 | +
- is_scatterplot <- is.numeric(ANL[[ref_name]]) && any(vapply(ANL[vars_names], is.numeric, logical(1)))+ #' @inheritParams shared_params |
||
| 283 | -! | +||
| 8 | +
- if (is_scatterplot) {
+ #' @param variables_selected (`list`) A named list of character vectors of the variables (i.e. columns) |
||
| 284 | -! | +||
| 9 | +
- shinyjs::show("alpha")
+ #' which should be initially shown for each dataset. Names of list elements should correspond to the names |
||
| 285 | -! | +||
| 10 | +
- shinyjs::show("size")
+ #' of the datasets available in the app. If no entry is specified for a dataset, the first six variables from that |
||
| 286 | -! | +||
| 11 | +
- alpha <- input$alpha # nolint+ #' dataset will initially be shown. |
||
| 287 | -! | +||
| 12 | +
- size <- input$size+ #' @param datasets_selected (`character`) A vector of datasets which should be |
||
| 288 | +13 |
- } else {
+ #' shown and in what order. Names in the vector have to correspond with datasets names. |
|
| 289 | -! | +||
| 14 | +
- shinyjs::hide("alpha")
+ #' If vector of length zero (default) then all datasets are shown. |
||
| 290 | -! | +||
| 15 | +
- shinyjs::hide("size")
+ #' @param dt_args (named `list`) Additional arguments to be passed to `DT::datatable` |
||
| 291 | -! | +||
| 16 | +
- alpha <- 0.5+ #' (must not include `data` or `options`). |
||
| 292 | -! | +||
| 17 | +
- size <- 2+ #' @param dt_options (named `list`) The `options` argument to `DT::datatable`. By default |
||
| 293 | +18 |
- }+ #' `list(searching = FALSE, pageLength = 30, lengthMenu = c(5, 15, 30, 100), scrollX = TRUE)` |
|
| 294 | +19 |
-
+ #' @param server_rendering (`logical`) should the data table be rendered server side |
|
| 295 | -! | +||
| 20 | +
- teal::validate_has_data(ANL[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE)+ #' (see `server` argument of `DT::renderDataTable()`) |
||
| 296 | +21 |
-
+ #' @details |
|
| 297 | +22 |
- # reference+ #' The `DT` package has an option `DT.TOJSON_ARGS` to show `Inf` and `NA` in data tables. If this is something |
|
| 298 | -! | +||
| 23 | +
- ref_class <- class(ANL[[ref_name]])+ #' you require then set `options(DT.TOJSON_ARGS = list(na = "string"))` before running the module. |
||
| 299 | -! | +||
| 24 | +
- if (is.numeric(ANL[[ref_name]]) && log_transformation) {
+ #' Note though that sorting of numeric columns with `NA`/`Inf` will be lexicographic not numerical. |
||
| 300 | +25 |
- # works for both integers and doubles+ #' @export |
|
| 301 | -! | +||
| 26 | +
- ref_cl_name <- call("log", as.name(ref_name))
+ #' @examples |
||
| 302 | -! | +||
| 27 | +
- ref_cl_lbl <- varname_w_label(ref_name, ANL, prefix = "Log of ")+ #' |
||
| 303 | +28 |
- } else {
+ #' ADSL <- teal.modules.general::rADSL |
|
| 304 | +29 |
- # silently ignore when non-numeric even if `log` is selected because some+ #' |
|
| 305 | +30 |
- # variables may be numeric and others not+ #' app <- teal::init( |
|
| 306 | -! | +||
| 31 | +
- ref_cl_name <- as.name(ref_name)+ #' data = teal.data::cdisc_data( |
||
| 307 | -! | +||
| 32 | +
- ref_cl_lbl <- varname_w_label(ref_name, ANL)+ #' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
|
||
| 308 | +33 |
- }+ #' check = TRUE |
|
| 309 | +34 |
-
+ #' ), |
|
| 310 | -! | +||
| 35 | +
- user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ #' modules = teal::modules( |
||
| 311 | -! | +||
| 36 | +
- user_plot = ggplot2_args[["Bivariate1"]],+ #' teal.modules.general::tm_data_table( |
||
| 312 | -! | +||
| 37 | +
- user_default = ggplot2_args$default+ #' variables_selected = list(ADSL = c("STUDYID", "USUBJID", "SUBJID", "SITEID", "AGE", "SEX")),
|
||
| 313 | +38 |
- )+ #' dt_args = list(caption = "ADSL Table Caption") |
|
| 314 | +39 |
-
+ #' ) |
|
| 315 | -! | +||
| 40 | +
- ref_call <- bivariate_plot_call(+ #' ) |
||
| 316 | -! | +||
| 41 | +
- data_name = "ANL",+ #' ) |
||
| 317 | -! | +||
| 42 | +
- x = ref_cl_name,+ #' if (interactive()) {
|
||
| 318 | -! | +||
| 43 | +
- x_class = ref_class,+ #' shinyApp(app$ui, app$server) |
||
| 319 | -! | +||
| 44 | +
- x_label = ref_cl_lbl,+ #' } |
||
| 320 | -! | +||
| 45 | +
- freq = !show_dist,+ tm_data_table <- function(label = "Data Table", |
||
| 321 | -! | +||
| 46 | +
- theme = distribution_theme,+ variables_selected = list(), |
||
| 322 | -! | +||
| 47 | +
- rotate_xaxis_labels = rotate_xaxis_labels,+ datasets_selected = character(0), |
||
| 323 | -! | +||
| 48 | +
- swap_axes = FALSE,+ dt_args = list(), |
||
| 324 | -! | +||
| 49 | +
- size = size,+ dt_options = list( |
||
| 325 | -! | +||
| 50 | +
- alpha = alpha,+ searching = FALSE, |
||
| 326 | -! | +||
| 51 | +
- ggplot2_args = user_ggplot2_args+ pageLength = 30, |
||
| 327 | +52 |
- )+ lengthMenu = c(5, 15, 30, 100), |
|
| 328 | +53 | ++ |
+ scrollX = TRUE+ |
+
| 54 |
-
+ ), |
||
| 329 | +55 |
- # association+ server_rendering = FALSE, |
|
| 330 | -! | +||
| 56 | +
- ref_class_cov <- ifelse(association, ref_class, "NULL")+ pre_output = NULL, |
||
| 331 | +57 |
-
+ post_output = NULL) {
|
|
| 332 | +58 | ! |
- print_call <- quote(print(p))+ logger::log_info("Initializing tm_data_table")
|
| 333 | -+ | ||
| 59 | +! |
-
+ checkmate::assert_string(label) |
|
| 334 | +60 | ! |
- var_calls <- lapply(vars_names, function(var_i) {
+ checkmate::assert_list(variables_selected, min.len = 0, types = "character", names = "named") |
| 335 | +61 | ! |
- var_class <- class(ANL[[var_i]])+ if (length(variables_selected) > 0) {
|
| 336 | +62 | ! |
- if (is.numeric(ANL[[var_i]]) && log_transformation) {
+ lapply(seq_along(variables_selected), function(i) {
|
| 337 | -+ | ||
| 63 | +! |
- # works for both integers and doubles+ checkmate::assert_character(variables_selected[[i]], min.chars = 1, min.len = 1) |
|
| 338 | +64 | ! |
- var_cl_name <- call("log", as.name(var_i))
+ if (!is.null(names(variables_selected[[i]]))) {
|
| 339 | +65 | ! |
- var_cl_lbl <- varname_w_label(var_i, ANL, prefix = "Log of ")+ checkmate::assert_names(names(variables_selected[[i]])) |
| 340 | +66 |
- } else {
+ } |
|
| 341 | +67 |
- # silently ignore when non-numeric even if `log` is selected because some+ }) |
|
| 342 | +68 |
- # variables may be numeric and others not+ } |
|
| 343 | +69 | ! |
- var_cl_name <- as.name(var_i)+ checkmate::assert_character(datasets_selected, min.len = 0, min.chars = 1) |
| 344 | +70 | ! |
- var_cl_lbl <- varname_w_label(var_i, ANL)- |
-
| 345 | -- |
- }+ checkmate::assert_list(dt_options, names = "named") |
|
| 346 | -+ | ||
| 71 | +! |
-
+ checkmate::assert( |
|
| 347 | +72 | ! |
- user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(+ checkmate::check_list(dt_args, len = 0), |
| 348 | +73 | ! |
- user_plot = ggplot2_args[["Bivariate2"]],+ checkmate::check_subset(names(dt_args), choices = names(formals(DT::datatable))) |
| 349 | -! | +||
| 74 | +
- user_default = ggplot2_args$default+ ) |
||
| 350 | +75 |
- )+ + |
+ |
| 76 | +! | +
+ checkmate::assert_flag(server_rendering) |
|
| 351 | +77 | ||
| 352 | +78 | ! |
- bivariate_plot_call(+ module( |
| 353 | +79 | ! |
- data_name = "ANL",+ label, |
| 354 | +80 | ! |
- x = ref_cl_name,+ server = srv_page_data_table, |
| 355 | +81 | ! |
- y = var_cl_name,+ ui = ui_page_data_table, |
| 356 | +82 | ! |
- x_class = ref_class_cov,+ datanames = if (length(datasets_selected) == 0) "all" else datasets_selected, |
| 357 | +83 | ! |
- y_class = var_class,+ server_args = list( |
| 358 | +84 | ! |
- x_label = ref_cl_lbl,+ datasets_selected = datasets_selected, |
| 359 | +85 | ! |
- y_label = var_cl_lbl,+ dt_args = dt_args, |
| 360 | +86 | ! |
- theme = association_theme,+ dt_options = dt_options, |
| 361 | +87 | ! |
- freq = !show_dist,+ server_rendering = server_rendering+ |
+
| 88 | ++ |
+ ), |
|
| 362 | +89 | ! |
- rotate_xaxis_labels = rotate_xaxis_labels,+ ui_args = list( |
| 363 | +90 | ! |
- swap_axes = swap_axes,+ selected = variables_selected, |
| 364 | +91 | ! |
- alpha = alpha,+ datasets_selected = datasets_selected, |
| 365 | +92 | ! |
- size = size,+ pre_output = pre_output, |
| 366 | +93 | ! |
- ggplot2_args = user_ggplot2_args+ post_output = post_output |
| 367 | +94 |
- )+ ) |
|
| 368 | +95 |
- })+ ) |
|
| 369 | +96 | ++ |
+ }+ |
+
| 97 | |||
| 370 | +98 |
- # helper function to format variable name+ |
|
| 371 | -! | +||
| 99 | +
- format_varnames <- function(x) {
+ # ui page module |
||
| 372 | -! | +||
| 100 | +
- if (is.numeric(ANL[[x]]) && log_transformation) {
+ ui_page_data_table <- function(id, |
||
| 373 | -! | +||
| 101 | +
- varname_w_label(x, ANL, prefix = "Log of ")+ data, |
||
| 374 | +102 |
- } else {
+ selected,+ |
+ |
| 103 | ++ |
+ datasets_selected,+ |
+ |
| 104 | ++ |
+ pre_output = NULL,+ |
+ |
| 105 | ++ |
+ post_output = NULL) {
|
|
| 375 | +106 | ! |
- varname_w_label(x, ANL)+ ns <- NS(id) |
| 376 | +107 |
- }+ + |
+ |
| 108 | +! | +
+ datanames <- names(data) |
|
| 377 | +109 |
- }+ |
|
| 378 | +110 | ! |
- new_title <-+ if (!identical(datasets_selected, character(0))) {
|
| 379 | +111 | ! |
- if (association) {
+ stopifnot(all(datasets_selected %in% datanames)) |
| 380 | +112 | ! |
- switch(as.character(length(vars_names)),+ datanames <- datasets_selected+ |
+
| 113 | ++ |
+ }+ |
+ |
| 114 | ++ | + | |
| 381 | +115 | ! |
- "0" = sprintf("Value distribution for %s", ref_cl_lbl),
+ shiny::tagList( |
| 382 | +116 | ! |
- "1" = sprintf(+ include_css_files("custom"),
|
| 383 | +117 | ! |
- "Association between %s and %s",+ teal.widgets::standard_layout( |
| 384 | +118 | ! |
- ref_cl_lbl,+ output = teal.widgets::white_small_well( |
| 385 | +119 | ! |
- format_varnames(vars_names)+ fluidRow( |
| 386 | -+ | ||
| 120 | +! |
- ),+ column( |
|
| 387 | +121 | ! |
- sprintf(+ width = 12, |
| 388 | +122 | ! |
- "Associations between %s and: %s",+ checkboxInput( |
| 389 | +123 | ! |
- ref_cl_lbl,+ ns("if_distinct"),
|
| 390 | +124 | ! |
- paste(lapply(vars_names, format_varnames), collapse = ", ")+ "Show only distinct rows:",+ |
+
| 125 | +! | +
+ value = FALSE |
|
| 391 | +126 |
) |
|
| 392 | +127 |
) |
|
| 393 | +128 |
- } else {
+ ), |
|
| 394 | +129 | ! |
- switch(as.character(length(vars_names)),+ fluidRow( |
| 395 | +130 | ! |
- "0" = sprintf("Value distribution for %s", ref_cl_lbl),
+ class = "mb-8", |
| 396 | +131 | ! |
- sprintf(+ column( |
| 397 | +132 | ! |
- "Value distributions for %s and %s",+ width = 12, |
| 398 | +133 | ! |
- ref_cl_lbl,+ do.call( |
| 399 | +134 | ! |
- paste(lapply(vars_names, format_varnames), collapse = ", ")+ tabsetPanel, |
| 400 | -+ | ||
| 135 | +! |
- )+ lapply( |
|
| 401 | -+ | ||
| 136 | +! |
- )+ datanames, |
|
| 402 | -+ | ||
| 137 | +! |
- }+ function(x) {
|
|
| 403 | -+ | ||
| 138 | +! |
-
+ dataset <- isolate(data[[x]]()) |
|
| 404 | +139 | ! |
- teal.code::eval_code(+ choices <- names(dataset) |
| 405 | +140 | ! |
- merged$anl_q_r(),+ labels <- vapply( |
| 406 | +141 | ! |
- substitute(+ dataset, |
| 407 | +142 | ! |
- expr = title <- new_title,+ function(x) ifelse(is.null(attr(x, "label")), "", attr(x, "label")), |
| 408 | +143 | ! |
- env = list(new_title = new_title)+ character(1) |
| 409 | +144 |
- )+ )+ |
+ |
| 145 | +! | +
+ names(choices) <- ifelse(+ |
+ |
| 146 | +! | +
+ is.na(labels) | labels == "",+ |
+ |
| 147 | +! | +
+ choices,+ |
+ |
| 148 | +! | +
+ paste(choices, labels, sep = ": ") |
|
| 410 | +149 |
- ) %>%+ ) |
|
| 411 | +150 | ! |
- teal.code::eval_code(+ selected <- if (!is.null(selected[[x]])) {
|
| 412 | +151 | ! |
- substitute(+ selected[[x]]+ |
+
| 152 | ++ |
+ } else {
|
|
| 413 | +153 | ! |
- expr = {
+ utils::head(choices)+ |
+
| 154 | ++ |
+ } |
|
| 414 | +155 | ! |
- plots <- plot_calls+ tabPanel( |
| 415 | +156 | ! |
- p <- tern::stack_grobs(grobs = lapply(plots, ggplotGrob))+ title = x, |
| 416 | +157 | ! |
- grid::grid.newpage()+ column( |
| 417 | +158 | ! |
- grid::grid.draw(p)+ width = 12, |
| 418 | -+ | ||
| 159 | +! |
- },+ div( |
|
| 419 | +160 | ! |
- env = list(+ class = "mt-4", |
| 420 | +161 | ! |
- plot_calls = do.call(+ ui_data_table( |
| 421 | +162 | ! |
- "call",+ id = ns(x), |
| 422 | +163 | ! |
- c(list("list", ref_call), var_calls),
+ choices = choices, |
| 423 | +164 | ! |
- quote = TRUE+ selected = selected |
| 424 | +165 |
- )+ ) |
|
| 425 | +166 |
- )+ ) |
|
| 426 | +167 |
- )+ ) |
|
| 427 | +168 |
- )+ ) |
|
| 428 | +169 |
- })+ } |
|
| 429 | +170 | - - | -|
| 430 | -! | -
- plot_r <- shiny::reactive({
- |
- |
| 431 | -! | -
- shiny::req(iv_r()$is_valid())- |
- |
| 432 | -! | -
- output_q()[["p"]]+ ) |
|
| 433 | +171 |
- })+ ) |
|
| 434 | +172 | - - | -|
| 435 | -! | -
- pws <- teal.widgets::plot_with_settings_srv(+ ) |
|
| 436 | -! | +||
| 173 | +
- id = "myplot",+ ) |
||
| 437 | -! | +||
| 174 | +
- plot_r = plot_r,+ ), |
||
| 438 | +175 | ! |
- height = plot_height,+ pre_output = pre_output, |
| 439 | +176 | ! |
- width = plot_width+ post_output = post_output |
| 440 | +177 |
) |
|
| 441 | +178 | - - | -|
| 442 | -! | -
- output$title <- renderText({
+ ) |
|
| 443 | -! | +||
| 179 | +
- teal.code::dev_suppress(output_q()[["title"]])+ } |
||
| 444 | +180 |
- })+ |
|
| 445 | +181 | ||
| 446 | -! | +||
| 182 | +
- teal.widgets::verbatim_popup_srv(+ # server page module |
||
| 447 | -! | +||
| 183 | +
- id = "warning",+ srv_page_data_table <- function(id, |
||
| 448 | -! | +||
| 184 | +
- verbatim_content = reactive(teal.code::get_warnings(output_q())),+ data, |
||
| 449 | -! | +||
| 185 | +
- title = "Warning",+ datasets_selected, |
||
| 450 | -! | +||
| 186 | +
- disabled = reactive(is.null(teal.code::get_warnings(output_q())))+ dt_args, |
||
| 451 | +187 |
- )+ dt_options, |
|
| 452 | +188 |
-
+ server_rendering) {
|
|
| 453 | +189 | ! |
- teal.widgets::verbatim_popup_srv(+ checkmate::assert_class(data, "tdata") |
| 454 | +190 | ! |
- id = "rcode",+ moduleServer(id, function(input, output, session) {
|
| 455 | +191 | ! |
- verbatim_content = reactive(teal.code::get_code(output_q())),+ if_filtered <- reactive(as.logical(input$if_filtered)) |
| 456 | +192 | ! |
- title = "Association Plot"+ if_distinct <- reactive(as.logical(input$if_distinct)) |
| 457 | +193 |
- )+ |
|
| 458 | -+ | ||
| 194 | +! |
-
+ datanames <- names(data) |
|
| 459 | +195 |
- ### REPORTER+ |
|
| 460 | +196 | ! |
- if (with_reporter) {
+ lapply( |
| 461 | +197 | ! |
- card_fun <- function(comment) {
+ datanames, |
| 462 | +198 | ! |
- card <- teal::TealReportCard$new()+ function(x) {
|
| 463 | +199 | ! |
- card$set_name("Association Plot")
+ srv_data_table( |
| 464 | +200 | ! |
- card$append_text("Association Plot", "header2")
+ id = x, |
| 465 | +201 | ! |
- if (with_filter) card$append_fs(filter_panel_api$get_filter_state())+ data = data, |
| 466 | +202 | ! |
- card$append_text("Plot", "header3")
+ dataname = x, |
| 467 | +203 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ if_filtered = if_filtered, |
| 468 | +204 | ! |
- if (!comment == "") {
+ if_distinct = if_distinct, |
| 469 | +205 | ! |
- card$append_text("Comment", "header3")
+ dt_args = dt_args, |
| 470 | +206 | ! |
- card$append_text(comment)- |
-
| 471 | -- |
- }+ dt_options = dt_options, |
|
| 472 | +207 | ! |
- card$append_src(paste(teal.code::get_code(output_q()), collapse = "\n"))+ server_rendering = server_rendering |
| 473 | -! | +||
| 208 | +
- card+ ) |
||
| 474 | +209 |
} |
|
| 475 | -! | +||
| 210 | +
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ ) |
||
| 476 | +211 |
- }+ }) |
|
| 477 | +212 |
- ###+ } |
|
| 478 | +213 |
- })+ |
|
| 479 | +214 |
- }+ ui_data_table <- function(id, |
| 1 | +215 |
- #' Data Table Viewer Teal Module+ choices, |
|
| 2 | +216 |
- #'+ selected) {
|
|
| 3 | -+ | ||
| 217 | +! |
- #' A data table viewer shows the data using a paginated table.+ ns <- NS(id) |
|
| 4 | +218 |
- #' @md+ |
|
| 5 | -+ | ||
| 219 | +! |
- #'+ if (!is.null(selected)) {
|
|
| 6 | -+ | ||
| 220 | +! |
- #' @inheritParams teal::module+ all_choices <- choices |
|
| 7 | -+ | ||
| 221 | +! |
- #' @inheritParams shared_params+ choices <- c(selected, setdiff(choices, selected)) |
|
| 8 | -+ | ||
| 222 | +! |
- #' @param variables_selected (`list`) A named list of character vectors of the variables (i.e. columns)+ names(choices) <- names(all_choices)[match(choices, all_choices)] |
|
| 9 | +223 |
- #' which should be initially shown for each dataset. Names of list elements should correspond to the names+ } |
|
| 10 | +224 |
- #' of the datasets available in the app. If no entry is specified for a dataset, the first six variables from that+ |
|
| 11 | -+ | ||
| 225 | +! |
- #' dataset will initially be shown.+ tagList( |
|
| 12 | -+ | ||
| 226 | +! |
- #' @param datasets_selected (`character`) A vector of datasets which should be+ teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")),
|
|
| 13 | -+ | ||
| 227 | +! |
- #' shown and in what order. Names in the vector have to correspond with datasets names.+ fluidRow( |
|
| 14 | -+ | ||
| 228 | +! |
- #' If vector of length zero (default) then all datasets are shown.+ teal.widgets::optionalSelectInput( |
|
| 15 | -+ | ||
| 229 | +! |
- #' @param dt_args (named `list`) Additional arguments to be passed to `DT::datatable`+ ns("variables"),
|
|
| 16 | -+ | ||
| 230 | +! |
- #' (must not include `data` or `options`).+ "Select variables:", |
|
| 17 | -+ | ||
| 231 | +! |
- #' @param dt_options (named `list`) The `options` argument to `DT::datatable`. By default+ choices = choices, |
|
| 18 | -+ | ||
| 232 | +! |
- #' `list(searching = FALSE, pageLength = 30, lengthMenu = c(5, 15, 30, 100), scrollX = TRUE)`+ selected = selected, |
|
| 19 | -+ | ||
| 233 | +! |
- #' @param server_rendering (`logical`) should the data table be rendered server side+ multiple = TRUE, |
|
| 20 | -+ | ||
| 234 | +! |
- #' (see `server` argument of `DT::renderDataTable()`)+ width = "100%" |
|
| 21 | +235 |
- #' @details+ ) |
|
| 22 | +236 |
- #' The `DT` package has an option `DT.TOJSON_ARGS` to show `Inf` and `NA` in data tables. If this is something+ ), |
|
| 23 | -+ | ||
| 237 | +! |
- #' you require then set `options(DT.TOJSON_ARGS = list(na = "string"))` before running the module.+ fluidRow(+ |
+ |
| 238 | +! | +
+ DT::dataTableOutput(ns("data_table"), width = "100%")
|
|
| 24 | +239 |
- #' Note though that sorting of numeric columns with `NA`/`Inf` will be lexicographic not numerical.+ ) |
|
| 25 | +240 |
- #' @export+ ) |
|
| 26 | +241 |
- #' @examples+ } |
|
| 27 | +242 |
- #'+ |
|
| 28 | +243 |
- #' ADSL <- teal.modules.general::rADSL+ srv_data_table <- function(id, |
|
| 29 | +244 |
- #'+ data, |
|
| 30 | +245 |
- #' app <- teal::init(+ dataname, |
|
| 31 | +246 |
- #' data = teal.data::cdisc_data(+ if_filtered, |
|
| 32 | +247 |
- #' teal.data::cdisc_dataset("ADSL", ADSL, code = "ADSL <- teal.modules.general::rADSL"),
+ if_distinct, |
|
| 33 | +248 |
- #' check = TRUE+ dt_args, |
|
| 34 | +249 |
- #' ),+ dt_options, |
|
| 35 | +250 |
- #' modules = teal::modules(+ server_rendering) {
|
|
| 36 | -+ | ||
| 251 | +! |
- #' teal.modules.general::tm_data_table(+ moduleServer(id, function(input, output, session) {
|
|
| 37 | -+ | ||
| 252 | +! |
- #' variables_selected = list(ADSL = c("STUDYID", "USUBJID", "SUBJID", "SITEID", "AGE", "SEX")),
+ iv <- shinyvalidate::InputValidator$new() |
|
| 38 | -+ | ||
| 253 | +! |
- #' dt_args = list(caption = "ADSL Table Caption")+ iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names"))
|
|
| 39 | -+ | ||
| 254 | +! |
- #' )+ iv$add_rule("variables", shinyvalidate::sv_in_set(
|
|
| 40 | -+ | ||
| 255 | +! |
- #' )+ set = names(data[[dataname]]()), message_fmt = "Not all selected variables exist in the data" |
|
| 41 | +256 |
- #' )+ )) |
|
| 42 | -+ | ||
| 257 | +! |
- #' if (interactive()) {
+ iv$enable() |
|
| 43 | +258 |
- #' shinyApp(app$ui, app$server)+ |
|
| 44 | -+ | ||
| 259 | +! |
- #' }+ output$data_table <- DT::renderDataTable(server = server_rendering, {
|
|
| 45 | -+ | ||
| 260 | +! |
- tm_data_table <- function(label = "Data Table",+ teal::validate_inputs(iv) |
|
| 46 | +261 |
- variables_selected = list(),+ |
|
| 47 | -+ | ||
| 262 | +! |
- datasets_selected = character(0),+ df <- data[[dataname]]() |
|
| 48 | -+ | ||
| 263 | +! |
- dt_args = list(),+ variables <- input$variables |
|
| 49 | +264 |
- dt_options = list(+ |
|
| 50 | -+ | ||
| 265 | +! |
- searching = FALSE,+ teal::validate_has_data(df, min_nrow = 1L, msg = paste("data", dataname, "is empty"))
|
|
| 51 | +266 |
- pageLength = 30,+ |
|
| 52 | -+ | ||
| 267 | +! |
- lengthMenu = c(5, 15, 30, 100),+ dataframe_selected <- if (if_distinct()) {
|
|
| 53 | -+ | ||
| 268 | +! |
- scrollX = TRUE+ dplyr::count(df, dplyr::across(tidyselect::all_of(variables))) |
|
| 54 | +269 |
- ),+ } else {
|
|
| 55 | -+ | ||
| 270 | +! |
- server_rendering = FALSE,+ df[variables] |
|
| 56 | +271 |
- pre_output = NULL,+ } |
|
| 57 | +272 |
- post_output = NULL) {
+
|
|
| 58 | +273 | ! |
- logger::log_info("Initializing tm_data_table")
+ dt_args$options <- dt_options |
| 59 | +274 | ! |
- checkmate::assert_string(label)+ if (!is.null(input$dt_rows)) {
|
| 60 | +275 | ! |
- checkmate::assert_list(variables_selected, min.len = 0, types = "character", names = "named")+ dt_args$options$pageLength <- input$dt_rows # nolint |
| 61 | -! | +||
| 276 | +
- if (length(variables_selected) > 0) {
+ } |
||
| 62 | +277 | ! |
- lapply(seq_along(variables_selected), function(i) {
+ dt_args$data <- dataframe_selected |
| 63 | -! | +||
| 278 | +
- checkmate::assert_character(variables_selected[[i]], min.chars = 1, min.len = 1)+ |
||
| 64 | +279 | ! |
- if (!is.null(names(variables_selected[[i]]))) {
+ do.call(DT::datatable, dt_args) |
| 65 | -! | +||
| 280 | +
- checkmate::assert_names(names(variables_selected[[i]]))+ }) |
||
| 66 | +281 |
- }+ }) |
|
| 67 | +282 |
- })+ } |
| 68 | +1 |
- }+ #' Front page module |
|
| 69 | -! | +||
| 2 | +
- checkmate::assert_character(datasets_selected, min.len = 0, min.chars = 1)+ #' |
||
| 70 | -! | +||
| 3 | +
- checkmate::assert_list(dt_options, names = "named")+ #' @description This `teal` module creates a simple front page for `teal` applications |
||
| 71 | -! | +||
| 4 | +
- checkmate::assert(+ #' |
||
| 72 | -! | +||
| 5 | +
- checkmate::check_list(dt_args, len = 0),+ #' @inheritParams teal::module |
||
| 73 | -! | +||
| 6 | +
- checkmate::check_subset(names(dt_args), choices = names(formals(DT::datatable)))+ #' @param header_text `character vector` text to be shown at the top of the module, for each |
||
| 74 | +7 |
- )+ #' element, if named the name is shown first in bold as a header followed by the value. The first |
|
| 75 | +8 |
-
+ #' element's header is displayed larger than the others |
|
| 76 | -! | +||
| 9 | +
- checkmate::assert_flag(server_rendering)+ #' @param tables `named list of dataframes` tables to be shown in the module |
||
| 77 | +10 |
-
+ #' @param additional_tags `shiny.tag.list` or `html` additional shiny tags or `html` to be included after the table, |
|
| 78 | -! | +||
| 11 | +
- module(+ #' for example to include an image, `tagList(tags$img(src = "image.png"))` or to include further `html`, |
||
| 79 | -! | +||
| 12 | +
- label,+ #' `HTML("html text here")`
|
||
| 80 | -! | +||
| 13 | +
- server = srv_page_data_table,+ #' @param footnotes `character vector` text to be shown at the bottom of the module, for each |
||
| 81 | -! | +||
| 14 | +
- ui = ui_page_data_table,+ #' element, if named the name is shown first in bold, followed by the value |
||
| 82 | -! | +||
| 15 | +
- datanames = if (length(datasets_selected) == 0) "all" else datasets_selected,+ #' @param show_metadata `logical` should the metadata of the datasets be available on the module? |
||
| 83 | -! | +||
| 16 | +
- server_args = list(+ #' @return A `teal` module to be used in `teal` applications |
||
| 84 | -! | +||
| 17 | +
- datasets_selected = datasets_selected,+ #' @export |
||
| 85 | -! | +||
| 18 | +
- dt_args = dt_args,+ #' @examples |
||
| 86 | -! | +||
| 19 | +
- dt_options = dt_options,+ #' |
||
| 87 | -! | +||
| 20 | +
- server_rendering = server_rendering+ #' table_1 <- data.frame(Info = c("A", "B"), Text = c("A", "B"))
|
||
| 88 | +21 |
- ),+ #' table_2 <- data.frame(`Column 1` = c("C", "D"), `Column 2` = c(5.5, 6.6), `Column 3` = c("A", "B"))
|
|
| 89 | -! | +||
| 22 | +
- ui_args = list(+ #' table_3 <- data.frame(Info = c("E", "F"), Text = c("G", "H"))
|
||
| 90 | -! | +||
| 23 | +
- selected = variables_selected,+ #' |
||
| 91 | -! | +||
| 24 | +
- datasets_selected = datasets_selected,+ #' table_input <- list( |
||
| 92 | -! | +||
| 25 | +
- pre_output = pre_output,+ #' "Table 1" = table_1, |
||
| 93 | -! | +||
| 26 | +
- post_output = post_output+ #' "Table 2" = table_2, |
||
| 94 | +27 |
- )+ #' "Table 3" = table_3 |
|
| 95 | +28 |
- )+ #' ) |
|
| 96 | +29 |
- }+ #' |
|
| 97 | +30 |
-
+ #' ADSL <- teal.modules.general::rADSL |
|
| 98 | +31 |
-
+ #' app <- teal::init( |
|
| 99 | +32 |
- # ui page module+ #' data = teal.data::cdisc_data( |
|
| 100 | +33 |
- ui_page_data_table <- function(id,+ #' teal.data::cdisc_dataset("ADSL", ADSL,
|
|
| 101 | +34 |
- data,+ #' code = "ADSL <- teal.modules.general::rADSL", |
|
| 102 | +35 |
- selected,+ #' metadata = list("Author" = "NEST team", "data_source" = "synthetic data")
|
|
| 103 | +36 |
- datasets_selected,+ #' ), |
|
| 104 | +37 |
- pre_output = NULL,+ #' check = TRUE |
|
| 105 | +38 |
- post_output = NULL) {
+ #' ), |
|
| 106 | -! | +||
| 39 | +
- ns <- NS(id)+ #' modules = teal::modules( |
||
| 107 | +40 |
-
+ #' teal.modules.general::tm_front_page( |
|
| 108 | -! | +||
| 41 | +
- datanames <- names(data)+ #' header_text = c( |
||
| 109 | +42 |
-
+ #' "Important information" = "It can go here.", |
|
| 110 | -! | +||
| 43 | +
- if (!identical(datasets_selected, character(0))) {
+ #' "Other information" = "Can go here." |
||
| 111 | -! | +||
| 44 | +
- stopifnot(all(datasets_selected %in% datanames))+ #' ), |
||
| 112 | -! | +||
| 45 | +
- datanames <- datasets_selected+ #' tables = table_input, |
||
| 113 | +46 |
- }+ #' additional_tags = HTML("Additional HTML or shiny tags go here <br>"),
+ |
+ |
| 47 | ++ |
+ #' footnotes = c("X" = "is the first footnote", "Y is the second footnote"),
|
|
| 114 | +48 |
-
+ #' show_metadata = TRUE |
|
| 115 | -! | +||
| 49 | +
- shiny::tagList(+ #' ) |
||
| 116 | -! | +||
| 50 | +
- include_css_files("custom"),
+ #' ), |
||
| 117 | -! | +||
| 51 | +
- teal.widgets::standard_layout(+ #' header = tags$h1("Sample Application"),
|
||
| 118 | -! | +||
| 52 | +
- output = teal.widgets::white_small_well(+ #' footer = tags$p("Application footer"),
|
||
| 119 | -! | +||
| 53 | +
- fluidRow(+ #' ) |
||
| 120 | -! | +||
| 54 | +
- column(+ #' if (interactive()) {
|
||
| 121 | -! | +||
| 55 | +
- width = 12,+ #' shinyApp(app$ui, app$server) |
||
| 122 | -! | +||
| 56 | +
- checkboxInput(+ #' } |
||
| 123 | -! | +||
| 57 | +
- ns("if_distinct"),
+ tm_front_page <- function(label = "Front page", |
||
| 124 | -! | +||
| 58 | +
- "Show only distinct rows:",+ header_text = character(0), |
||
| 125 | -! | +||
| 59 | +
- value = FALSE+ tables = list(), |
||
| 126 | +60 |
- )+ additional_tags = tagList(), |
|
| 127 | +61 |
- )+ footnotes = character(0), |
|
| 128 | +62 |
- ),+ show_metadata = FALSE) {
|
|
| 129 | +63 | ! |
- fluidRow(+ checkmate::assert_string(label) |
| 130 | +64 | ! |
- class = "mb-8",+ checkmate::assert_character(header_text, min.len = 0, any.missing = FALSE) |
| 131 | +65 | ! |
- column(+ checkmate::assert_list(tables, types = "data.frame", names = "named", any.missing = FALSE) |
| 132 | +66 | ! |
- width = 12,+ checkmate::assert_multi_class(additional_tags, classes = c("shiny.tag.list", "html"))
|
| 133 | +67 | ! |
- do.call(+ checkmate::assert_character(footnotes, min.len = 0, any.missing = FALSE) |
| 134 | +68 | ! |
- tabsetPanel,+ checkmate::assert_flag(show_metadata) |
| 135 | -! | +||
| 69 | +
- lapply(+ |
||
| 136 | +70 | ! |
- datanames,+ logger::log_info("Initializing tm_front_page")
|
| 137 | +71 | ! |
- function(x) {
+ args <- as.list(environment()) |
| 138 | -! | +||
| 72 | +
- dataset <- isolate(data[[x]]())+ |
||
| 139 | +73 | ! |
- choices <- names(dataset)+ module( |
| 140 | +74 | ! |
- labels <- vapply(+ label = label, |
| 141 | +75 | ! |
- dataset,+ server = srv_front_page, |
| 142 | +76 | ! |
- function(x) ifelse(is.null(attr(x, "label")), "", attr(x, "label")),+ ui = ui_front_page, |
| 143 | +77 | ! |
- character(1)+ ui_args = args, |
| 144 | -+ | ||
| 78 | +! |
- )+ server_args = list(tables = tables, show_metadata = show_metadata), |
|
| 145 | +79 | ! |
- names(choices) <- ifelse(+ datanames = if (show_metadata) "all" else NULL |
| 146 | -! | +||
| 80 | +
- is.na(labels) | labels == "",+ ) |
||
| 147 | -! | +||
| 81 | +
- choices,+ } |
||
| 148 | -! | +||
| 82 | +
- paste(choices, labels, sep = ": ")+ |
||
| 149 | +83 |
- )+ ui_front_page <- function(id, ...) {
|
|
| 150 | +84 | ! |
- selected <- if (!is.null(selected[[x]])) {
+ args <- list(...) |
| 151 | +85 | ! |
- selected[[x]]+ ns <- NS(id) |
| 152 | +86 |
- } else {
+
|
|
| 153 | +87 | ! |
- utils::head(choices)- |
-
| 154 | -- |
- }+ tagList( |
|
| 155 | +88 | ! |
- tabPanel(+ include_css_files("custom"),
|
| 156 | +89 | ! |
- title = x,+ tags$div( |
| 157 | +90 | ! |
- column(+ id = "front_page_content", |
| 158 | +91 | ! |
- width = 12,+ class = "ml-8", |
| 159 | +92 | ! |
- div(+ tags$div( |
| 160 | +93 | ! |
- class = "mt-4",+ id = "front_page_headers", |
| 161 | +94 | ! |
- ui_data_table(+ get_header_tags(args$header_text) |
| 162 | -! | +||
| 95 | +
- id = ns(x),+ ), |
||
| 163 | +96 | ! |
- choices = choices,+ tags$div( |
| 164 | +97 | ! |
- selected = selected+ id = "front_page_tables", |
| 165 | -+ | ||
| 98 | +! |
- )+ class = "ml-4", |
|
| 166 | -+ | ||
| 99 | +! |
- )+ get_table_tags(args$tables, ns) |
|
| 167 | +100 |
- )+ ), |
|
| 168 | -+ | ||
| 101 | +! |
- )+ tags$div( |
|
| 169 | -+ | ||
| 102 | +! |
- }+ id = "front_page_custom_html", |
|
| 170 | -+ | ||
| 103 | +! |
- )+ class = "my-4", |
|
| 171 | -+ | ||
| 104 | +! |
- )+ args$additional_tags |
|
| 172 | +105 |
- )+ ), |
|
| 173 | -+ | ||
| 106 | +! |
- )+ if (args$show_metadata) {
|
|
| 174 | -+ | ||
| 107 | +! |
- ),+ tags$div( |
|
| 175 | +108 | ! |
- pre_output = pre_output,+ id = "front_page_metabutton", |
| 176 | +109 | ! |
- post_output = post_output+ class = "m-4", |
| 177 | -+ | ||
| 110 | +! |
- )+ actionButton(ns("metadata_button"), "Show metadata")
|
|
| 178 | +111 |
- )+ ) |
|
| 179 | +112 |
- }+ }, |
|
| 180 | -+ | ||
| 113 | +! |
-
+ tags$footer( |
|
| 181 | -+ | ||
| 114 | +! |
-
+ class = ".small", |
|
| 182 | -+ | ||
| 115 | +! |
- # server page module+ get_footer_tags(args$footnotes) |
|
| 183 | +116 |
- srv_page_data_table <- function(id,+ ) |
|
| 184 | +117 |
- data,+ ) |
|
| 185 | +118 |
- datasets_selected,+ ) |
|
| 186 | +119 |
- dt_args,+ } |
|
| 187 | +120 |
- dt_options,+ |
|
| 188 | +121 |
- server_rendering) {
- |
- |
| 189 | -! | -
- checkmate::assert_class(data, "tdata")- |
- |
| 190 | -! | -
- moduleServer(id, function(input, output, session) {
+ get_header_tags <- function(header_text) {
|
|
| 191 | +122 | ! |
- if_filtered <- reactive(as.logical(input$if_filtered))+ if (length(header_text) == 0) {
|
| 192 | +123 | ! |
- if_distinct <- reactive(as.logical(input$if_distinct))+ return(list()) |
| 193 | +124 | - - | -|
| 194 | -! | -
- datanames <- names(data)+ } |
|
| 195 | +125 | ||
| 196 | -! | -
- lapply(- |
- |
| 197 | -! | -
- datanames,- |
- |
| 198 | -! | -
- function(x) {
- |
- |
| 199 | -! | -
- srv_data_table(- |
- |
| 200 | -! | -
- id = x,- |
- |
| 201 | -! | -
- data = data,- |
- |
| 202 | -! | -
- dataname = x,- |
- |
| 203 | +126 | ! |
- if_filtered = if_filtered,+ get_single_header_tags <- function(header_text, p_text, header_tag = tags$h4) {
|
| 204 | +127 | ! |
- if_distinct = if_distinct,+ tagList( |
| 205 | +128 | ! |
- dt_args = dt_args,+ tags$div( |
| 206 | +129 | ! |
- dt_options = dt_options,+ if (!is.null(header_text) && nchar(header_text) > 0) header_tag(header_text), |
| 207 | +130 | ! |
- server_rendering = server_rendering+ tags$p(p_text) |
| 208 | +131 |
- )+ ) |
|
| 209 | +132 |
- }+ ) |
|
| 210 | +133 |
- )+ } |
|
| 211 | +134 |
- })+ |
|
| 212 | -+ | ||
| 135 | +! |
- }+ header_tags <- get_single_header_tags(names(header_text[1]), header_text[1], header_tag = tags$h3) |
|
| 213 | -+ | ||
| 136 | +! |
-
+ c(header_tags, mapply(get_single_header_tags, utils::tail(names(header_text), -1), utils::tail(header_text, -1))) |
|
| 214 | +137 |
- ui_data_table <- function(id,+ } |
|
| 215 | +138 |
- choices,+ |
|
| 216 | +139 |
- selected) {
+ get_table_tags <- function(tables, ns) {
|
|
| 217 | +140 | ! |
- ns <- NS(id)+ if (length(tables) == 0) {
+ |
+
| 141 | +! | +
+ return(list()) |
|
| 218 | +142 |
-
+ } |
|
| 219 | +143 | ! |
- if (!is.null(selected)) {
+ table_tags <- c(lapply(seq_along(tables), function(idx) {
|
| 220 | +144 | ! |
- all_choices <- choices+ list( |
| 221 | +145 | ! |
- choices <- c(selected, setdiff(choices, selected))+ tableOutput(ns(paste0("table_", idx)))
+ |
+
| 146 | ++ |
+ )+ |
+ |
| 147 | ++ |
+ })) |
|
| 222 | +148 | ! |
- names(choices) <- names(all_choices)[match(choices, all_choices)]+ return(table_tags) |
| 223 | +149 |
- }+ } |
|
| 224 | +150 | ||
| 225 | -! | +||
| 151 | +
- tagList(+ get_footer_tags <- function(footnotes) {
|
||
| 226 | +152 | ! |
- teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")),
+ if (length(footnotes) == 0) {
|
| 227 | +153 | ! |
- fluidRow(+ return(list())+ |
+
| 154 | ++ |
+ } |
|
| 228 | +155 | ! |
- teal.widgets::optionalSelectInput(+ bold_texts <- if (is.null(names(footnotes))) rep("", length(footnotes)) else names(footnotes)
|
| 229 | +156 | ! |
- ns("variables"),
+ footnote_tags <- mapply(function(bold_text, value) {
|
| 230 | +157 | ! |
- "Select variables:",+ list( |
| 231 | +158 | ! |
- choices = choices,+ tags$div( |
| 232 | +159 | ! |
- selected = selected,+ tags$b(bold_text), |
| 233 | +160 | ! |
- multiple = TRUE,+ value, |
| 234 | +161 | ! |
- width = "100%"+ tags$br() |
| 235 | +162 |
) |
|
| 236 | +163 |
- ),+ ) |
|
| 237 | +164 | ! |
- fluidRow(+ }, bold_text = bold_texts, value = footnotes) |
| 238 | -! | +||
| 165 | +
- DT::dataTableOutput(ns("data_table"), width = "100%")
+ } |
||
| 239 | +166 |
- )+ |
|
| 240 | +167 |
- )+ srv_front_page <- function(id, data, tables, show_metadata) {
|
|
| 241 | -+ | ||
| 168 | +! |
- }+ checkmate::assert_class(data, "tdata")+ |
+ |
| 169 | +! | +
+ moduleServer(id, function(input, output, session) {
+ |
+ |
| 170 | +! | +
+ ns <- session$ns |
|
| 242 | +171 | ||
| 243 | -+ | ||
| 172 | +! |
- srv_data_table <- function(id,+ lapply(seq_along(tables), function(idx) {
|
|
| 244 | -+ | ||
| 173 | +! |
- data,+ output[[paste0("table_", idx)]] <- renderTable(
|
|
| 245 | -+ | ||
| 174 | +! |
- dataname,+ tables[[idx]], |
|
| 246 | -+ | ||
| 175 | +! |
- if_filtered,+ bordered = TRUE, |
|
| 247 | -+ | ||
| 176 | +! |
- if_distinct,+ caption = names(tables)[idx],+ |
+ |
| 177 | +! | +
+ caption.placement = "top" |
|
| 248 | +178 |
- dt_args,+ ) |
|
| 249 | +179 |
- dt_options,+ }) |
|
| 250 | +180 |
- server_rendering) {
+
|
|
| 251 | +181 | ! |
- moduleServer(id, function(input, output, session) {
+ if (show_metadata) {
|
| 252 | +182 | ! |
- iv <- shinyvalidate::InputValidator$new()+ observeEvent( |
| 253 | +183 | ! |
- iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names"))
+ input$metadata_button, showModal( |
| 254 | +184 | ! |
- iv$add_rule("variables", shinyvalidate::sv_in_set(
+ modalDialog( |
| 255 | +185 | ! |
- set = names(data[[dataname]]()), message_fmt = "Not all selected variables exist in the data"+ title = "Metadata", |
| 256 | -+ | ||
| 186 | +! |
- ))+ dataTableOutput(ns("metadata_table")),
|
|
| 257 | +187 | ! |
- iv$enable()+ size = "l",+ |
+
| 188 | +! | +
+ easyClose = TRUE |
|
| 258 | +189 |
-
+ ) |
|
| 259 | -! | +||
| 190 | +
- output$data_table <- DT::renderDataTable(server = server_rendering, {
+ ) |
||
| 260 | -! | +||
| 191 | +
- teal::validate_inputs(iv)+ ) |
||
| 261 | +192 | ||
| 262 | +193 | ! |
- df <- data[[dataname]]()+ metadata_data_frame <- reactive({
|
| 263 | +194 | ! |
- variables <- input$variables+ convert_metadata_to_dataframe( |
| 264 | -+ | ||
| 195 | +! |
-
+ lapply(names(data), function(dataname) get_metadata(data, dataname)), |
|
| 265 | +196 | ! |
- teal::validate_has_data(df, min_nrow = 1L, msg = paste("data", dataname, "is empty"))
+ names(data) |
| 266 | +197 | ++ |
+ )+ |
+
| 198 | ++ |
+ })+ |
+ |
| 199 | |||
| 267 | +200 | ! |
- dataframe_selected <- if (if_distinct()) {
+ output$metadata_table <- renderDataTable({
|
| 268 | +201 | ! |
- dplyr::count(df, dplyr::across(tidyselect::all_of(variables)))+ validate(need(nrow(metadata_data_frame()) > 0, "The data has no associated metadata"))+ |
+
| 202 | +! | +
+ metadata_data_frame() |
|
| 269 | +203 |
- } else {
+ }) |
|
| 270 | -! | +||
| 204 | +
- df[variables]+ } |
||
| 271 | +205 |
- }+ }) |
|
| 272 | +206 | ++ |
+ }+ |
+
| 207 | |||
| 273 | -! | +||
| 208 | +
- dt_args$options <- dt_options+ # take a list of metadata, one item per dataset (raw_metadata each element from datasets$get_metadata()) |
||
| 274 | -! | +||
| 209 | +
- if (!is.null(input$dt_rows)) {
+ # and the corresponding datanames and output a data.frame with columns {Dataset, Name, Value}.
|
||
| 275 | -! | +||
| 210 | +
- dt_args$options$pageLength <- input$dt_rows # nolint+ # which are, the Dataset the metadata came from, the metadata's name and value |
||
| 276 | +211 |
- }+ convert_metadata_to_dataframe <- function(raw_metadata, datanames) {
|
|
| 277 | -! | +||
| 212 | +4x |
- dt_args$data <- dataframe_selected+ output <- mapply(function(metadata, dataname) {
|
|
| 278 | -+ | ||
| 213 | +6x |
-
+ if (is.null(metadata)) {
|
|
| 279 | -! | +||
| 214 | +2x |
- do.call(DT::datatable, dt_args)+ return(data.frame(Dataset = character(0), Name = character(0), Value = character(0))) |
|
| 280 | +215 |
- })+ }+ |
+ |
| 216 | +4x | +
+ return(data.frame(+ |
+ |
| 217 | +4x | +
+ Dataset = dataname,+ |
+ |
| 218 | +4x | +
+ Name = names(metadata),+ |
+ |
| 219 | +4x | +
+ Value = unname(unlist(lapply(metadata, as.character))) |
|
| 281 | +220 |
- })+ ))+ |
+ |
| 221 | +4x | +
+ }, raw_metadata, datanames, SIMPLIFY = FALSE)+ |
+ |
| 222 | +4x | +
+ do.call(rbind, output) |
|
| 282 | +223 |
}diff --git a/main/coverage-report/lib/datatables-binding-0.28/datatables.js b/main/coverage-report/lib/datatables-binding-0.30/datatables.js similarity index 99% rename from main/coverage-report/lib/datatables-binding-0.28/datatables.js rename to main/coverage-report/lib/datatables-binding-0.30/datatables.js index aee8ab54a..d968d8be0 100644 --- a/main/coverage-report/lib/datatables-binding-0.28/datatables.js +++ b/main/coverage-report/lib/datatables-binding-0.30/datatables.js @@ -2,7 +2,7 @@ // some helper functions: using a global object DTWidget so that it can be used // in JS() code, e.g. datatable(options = list(foo = JS('code'))); unlike R's -// dynamic scoping, when 'code' is eval()'ed, JavaScript does not know objects +// dynamic scoping, when 'code' is eval'ed, JavaScript does not know objects // from the "parent frame", e.g. JS('DTWidget') will not work unless it was made // a global object var DTWidget = {}; @@ -493,7 +493,9 @@ HTMLWidgets.widget({ $input.parent().hide(); $x.show().trigger('show'); filter[0].selectize.focus(); }, input: function() { - if ($input.val() === '') filter[0].selectize.setValue([]); + var v1 = JSON.stringify(filter[0].selectize.getValue()), v2 = $input.val(); + if (v1 === '[]') v1 = ''; + if (v1 !== v2) filter[0].selectize.setValue(v2 === '' ? [] : JSON.parse(v2)); } }); var $input2 = $x.children('select'); @@ -1398,7 +1400,7 @@ HTMLWidgets.widget({ console.log('The search keyword for column ' + i + ' is undefined') return; } - $(td).find('input').first().val(v); + $(td).find('input').first().val(v).trigger('input'); searchColumn(i, v); }); table.draw(); |