- | 1309 |
+ 1314 |
|
}
@@ -9281,14 +9316,14 @@ teal.modules.general coverage - 3.44%
-
+
| 1 |
|
- #' `teal` module: Scatterplot
+ #' `teal` module: Variable browser
|
@@ -9302,1988 +9337,1988 @@ teal.modules.general coverage - 3.44%
3 |
|
- #' Generates a customizable scatterplot using `ggplot2`.
+ #' Module provides provides a detailed summary and visualization of variable distributions
|
| 4 |
|
- #' This module allows users to select variables for the x and y axes,
+ #' for `data.frame` objects, with interactive features to customize analysis.
|
| 5 |
|
- #' color and size encodings, faceting options, and more. It supports log transformations,
+ #'
|
| 6 |
|
- #' trend line additions, and dynamic adjustments of point opacity and size through UI controls.
+ #' Numeric columns with fewer than 30 distinct values can be treated as either discrete
|
| 7 |
|
- #'
+ #' or continuous with a checkbox allowing users to switch how they are treated(if < 6 unique values
|
| 8 |
|
- #' @note For more examples, please see the vignette "Using scatterplot" via
+ #' then the default is discrete, otherwise it is continuous).
|
| 9 |
|
- #' `vignette("using-scatterplot", package = "teal.modules.general")`.
+ #'
|
| 10 |
|
- #'
+ #' @inheritParams teal::module
|
| 11 |
|
- #' @inheritParams teal::module
+ #' @inheritParams shared_params
|
| 12 |
|
- #' @inheritParams shared_params
+ #' @param parent_dataname (`character(1)`) string specifying a parent dataset.
|
| 13 |
|
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) Specifies
+ #' If it exists in `datasets_selected`then an extra checkbox will be shown to
|
| 14 |
|
- #' variable names selected to plot along the x-axis by default.
+ #' allow users to not show variables in other datasets which exist in this `dataname`.
|
| 15 |
|
- #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) Specifies
+ #' This is typically used to remove `ADSL` columns in `CDISC` data.
|
| 16 |
|
- #' variable names selected to plot along the y-axis by default.
+ #' In non `CDISC` data this can be ignored. Defaults to `"ADSL"`.
|
| 17 |
|
- #' @param color_by (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
+ #' @param datasets_selected (`character`) vector of datasets which should be
|
| 18 |
|
- #' defines the color encoding. If `NULL` then no color encoding option will be displayed.
+ #' shown, in order. Names must correspond with datasets names.
|
| 19 |
|
- #' @param size_by (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
+ #' If vector of length zero (default) then all datasets are shown.
|
| 20 |
|
- #' defines the point size encoding. If `NULL` then no size encoding option will be displayed.
+ #' Note: Only `data.frame` objects are compatible; using other types will cause an error.
|
| 21 |
|
- #' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
+ #'
|
| 22 |
|
- #' specifies the variable(s) for faceting rows.
+ #' @inherit shared_params return
|
| 23 |
|
- #' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
+ #'
|
| 24 |
|
- #' specifies the variable(s) for faceting columns.
+ #' @examplesShinylive
|
| 25 |
|
- #' @param shape (`character`) optional, character vector with the names of the
+ #' library(teal.modules.general)
|
| 26 |
|
- #' shape, e.g. `c("triangle", "square", "circle")`. It defaults to `shape_names`. This is a complete list from
+ #' interactive <- function() TRUE
|
| 27 |
|
- #' `vignette("ggplot2-specs", package="ggplot2")`.
+ #' {{ next_example }}
|
| 28 |
|
- #' @param max_deg (`integer`) optional, maximum degree for the polynomial trend line. Must not be less than 1.
+ # nolint start: line_length_linter.
|
| 29 |
|
- #' @param table_dec (`integer`) optional, number of decimal places used to round numeric values in the table.
+ #' @examplesIf require("sparkline", quietly = TRUE) && require("htmlwidgets", quietly = TRUE) && require("jsonlite", quietly = TRUE)
|
| 30 |
|
- #'
+ # nolint end: line_length_linter.
|
| 31 |
|
- #' @inherit shared_params return
+ #' # general data example
|
| 32 |
|
- #'
+ #' data <- teal_data()
|
| 33 |
|
- #' @examples
+ #' data <- within(data, {
|
| 34 |
|
- #' library(teal.widgets)
+ #' iris <- iris
|
| 35 |
|
- #'
+ #' mtcars <- mtcars
|
| 36 |
|
- #' # general data example
+ #' women <- women
|
| 37 |
|
- #' data <- teal_data()
+ #' faithful <- faithful
|
| 38 |
|
- #' data <- within(data, {
+ #' CO2 <- CO2
|
| 39 |
|
- #' require(nestcolor)
+ #' })
|
| 40 |
|
- #' CO2 <- CO2
+ #' datanames(data) <- c("iris", "mtcars", "women", "faithful", "CO2")
|
| 41 |
|
- #' })
+ #'
|
| 42 |
|
- #' datanames(data) <- "CO2"
+ #' app <- init(
|
| 43 |
|
- #'
+ #' data = data,
|
| 44 |
|
- #' app <- init(
+ #' modules = modules(
|
| 45 |
|
- #' data = data,
+ #' tm_variable_browser(
|
| 46 |
|
- #' modules = modules(
+ #' label = "Variable browser"
|
| 47 |
|
- #' tm_g_scatterplot(
+ #' )
|
| 48 |
|
- #' label = "Scatterplot Choices",
+ #' )
|
| 49 |
|
- #' x = data_extract_spec(
+ #' )
|
| 50 |
|
- #' dataname = "CO2",
+ #' if (interactive()) {
|
| 51 |
|
- #' select = select_spec(
+ #' shinyApp(app$ui, app$server)
|
| 52 |
|
- #' label = "Select variable:",
+ #' }
|
| 53 |
|
- #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
+ #'
|
| 54 |
|
- #' selected = "conc",
+ #' @examplesShinylive
|
| 55 |
|
- #' multiple = FALSE,
+ #' library(teal.modules.general)
|
| 56 |
|
- #' fixed = FALSE
+ #' interactive <- function() TRUE
|
| 57 |
|
- #' )
+ #' {{ next_example }}
|
| 58 |
|
- #' ),
+ # nolint start: line_length_linter.
|
| 59 |
|
- #' y = data_extract_spec(
+ #' @examplesIf require("sparkline", quietly = TRUE) && require("htmlwidgets", quietly = TRUE) && require("jsonlite", quietly = TRUE)
|
| 60 |
|
- #' dataname = "CO2",
+ # nolint end: line_length_linter.
|
| 61 |
|
- #' select = select_spec(
+ #' # CDISC example data
|
| 62 |
|
- #' label = "Select variable:",
+ #' library(sparkline)
|
| 63 |
|
- #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
+ #' data <- teal_data()
|
| 64 |
|
- #' selected = "uptake",
+ #' data <- within(data, {
|
| 65 |
|
- #' multiple = FALSE,
+ #' ADSL <- rADSL
|
| 66 |
|
- #' fixed = FALSE
+ #' ADTTE <- rADTTE
|
| 67 |
|
- #' )
+ #' })
|
| 68 |
|
- #' ),
+ #' datanames(data) <- c("ADSL", "ADTTE")
|
| 69 |
|
- #' color_by = data_extract_spec(
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
|
| 70 |
|
- #' dataname = "CO2",
+ #'
|
| 71 |
|
- #' select = select_spec(
+ #' app <- init(
|
| 72 |
|
- #' label = "Select variable:",
+ #' data = data,
|
| 73 |
|
- #' choices = variable_choices(
+ #' modules = modules(
|
| 74 |
|
- #' data[["CO2"]],
+ #' tm_variable_browser(
|
| 75 |
|
- #' c("Plant", "Type", "Treatment", "conc", "uptake")
+ #' label = "Variable browser"
|
| 76 |
|
- #' ),
+ #' )
|
| 77 |
|
- #' selected = NULL,
+ #' )
|
| 78 |
|
- #' multiple = FALSE,
+ #' )
|
| 79 |
|
- #' fixed = FALSE
+ #' if (interactive()) {
|
| 80 |
|
- #' )
+ #' shinyApp(app$ui, app$server)
|
| 81 |
|
- #' ),
+ #' }
|
| 82 |
|
- #' size_by = data_extract_spec(
+ #'
|
| 83 |
|
- #' dataname = "CO2",
+ #' @export
|
| 84 |
|
- #' select = select_spec(
+ #'
|
| 85 |
|
- #' label = "Select variable:",
+ tm_variable_browser <- function(label = "Variable Browser",
|
| 86 |
|
- #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
+ datasets_selected = character(0),
|
| 87 |
|
- #' selected = "uptake",
+ parent_dataname = "ADSL",
|
| 88 |
|
- #' multiple = FALSE,
+ pre_output = NULL,
|
| 89 |
|
- #' fixed = FALSE
+ post_output = NULL,
|
| 90 |
|
- #' )
+ ggplot2_args = teal.widgets::ggplot2_args()) {
|
-
+
| 91 |
- |
+ ! |
- #' ),
+ message("Initializing tm_variable_browser")
|
| 92 |
|
- #' row_facet = data_extract_spec(
+
|
| 93 |
|
- #' dataname = "CO2",
+ # Requires Suggested packages
|
-
+
| 94 |
- |
+ ! |
- #' select = select_spec(
+ if (!requireNamespace("sparkline", quietly = TRUE)) {
|
-
+
| 95 |
- |
+ ! |
- #' label = "Select variable:",
+ stop("Cannot load sparkline - please install the package or restart your session.")
|
| 96 |
|
- #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
+ }
|
-
+
| 97 |
- |
+ ! |
- #' selected = NULL,
+ if (!requireNamespace("htmlwidgets", quietly = TRUE)) {
|
-
+
| 98 |
- |
+ ! |
- #' multiple = FALSE,
+ stop("Cannot load htmlwidgets - please install the package or restart your session.")
|
| 99 |
|
- #' fixed = FALSE
+ }
|
-
+
| 100 |
- |
+ ! |
- #' )
+ if (!requireNamespace("jsonlite", quietly = TRUE)) {
|
-
+
| 101 |
- |
+ ! |
- #' ),
+ stop("Cannot load jsonlite - please install the package or restart your session.")
|
| 102 |
|
- #' col_facet = data_extract_spec(
+ }
|
| 103 |
|
- #' dataname = "CO2",
+
|
| 104 |
|
- #' select = select_spec(
+ # Start of assertions
|
-
+
| 105 |
- |
+ ! |
- #' label = "Select variable:",
+ checkmate::assert_string(label)
|
-
+
| 106 |
- |
+ ! |
- #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
+ checkmate::assert_character(datasets_selected)
|
-
+
| 107 |
- |
+ ! |
- #' selected = NULL,
+ checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1)
|
-
+
| 108 |
- |
+ ! |
- #' multiple = FALSE,
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
-
+
| 109 |
- |
+ ! |
- #' fixed = FALSE
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
-
+
| 110 |
- |
+ ! |
- #' )
+ checkmate::assert_class(ggplot2_args, "ggplot2_args")
|
| 111 |
|
- #' ),
+ # End of assertions
|
| 112 |
|
- #' ggplot2_args = ggplot2_args(
+
|
-
+
| 113 |
- |
+ ! |
- #' labs = list(subtitle = "Plot generated by Scatterplot Module")
+ datasets_selected <- unique(datasets_selected)
|
| 114 |
|
- #' )
+
|
-
+
| 115 |
- |
+ ! |
- #' )
+ ans <- module(
|
-
+
| 116 |
- |
+ ! |
- #' )
+ label,
|
-
+
| 117 |
- |
+ ! |
- #' )
+ server = srv_variable_browser,
|
-
+
| 118 |
- |
+ ! |
- #' if (interactive()) {
+ ui = ui_variable_browser,
|
-
+
| 119 |
- |
+ ! |
- #' shinyApp(app$ui, app$server)
+ datanames = "all",
|
-
+
| 120 |
- |
+ ! |
- #' }
+ server_args = list(
|
-
+
| 121 |
- |
+ ! |
- #'
+ datasets_selected = datasets_selected,
|
-
+
| 122 |
- |
+ ! |
- #' # CDISC data example
+ parent_dataname = parent_dataname,
|
-
+
| 123 |
- |
+ ! |
- #' data <- teal_data()
+ ggplot2_args = ggplot2_args
|
| 124 |
|
- #' data <- within(data, {
+ ),
|
-
+
| 125 |
- |
+ ! |
- #' require(nestcolor)
+ ui_args = list(
|
-
+
| 126 |
- |
+ ! |
- #' ADSL <- rADSL
+ pre_output = pre_output,
|
-
+
| 127 |
- |
+ ! |
- #' })
+ post_output = post_output
|
| 128 |
|
- #' datanames(data) <- c("ADSL")
+ )
|
| 129 |
|
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
+ )
|
| 130 |
|
- #'
+ # `shiny` inputs are stored properly but the majority of the module is state of `datatable` which is not stored.
|
-
+
| 131 |
- |
+ ! |
- #' app <- init(
+ attr(ans, "teal_bookmarkable") <- NULL
|
-
+
| 132 |
- |
+ ! |
- #' data = data,
+ ans
|
| 133 |
|
- #' modules = modules(
+ }
|
| 134 |
|
- #' tm_g_scatterplot(
+
|
| 135 |
|
- #' label = "Scatterplot Choices",
+ # UI function for the variable browser module
|
| 136 |
|
- #' x = data_extract_spec(
+ ui_variable_browser <- function(id,
|
| 137 |
|
- #' dataname = "ADSL",
+ pre_output = NULL,
|
| 138 |
|
- #' select = select_spec(
+ post_output = NULL) {
|
-
+
| 139 |
- |
+ ! |
- #' label = "Select variable:",
+ ns <- NS(id)
|
| 140 |
|
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")),
+
|
-
+
| 141 |
- |
+ ! |
- #' selected = "AGE",
+ tagList(
|
-
+
| 142 |
- |
+ ! |
- #' multiple = FALSE,
+ include_css_files("custom"),
|
-
+
| 143 |
- |
+ ! |
- #' fixed = FALSE
+ shinyjs::useShinyjs(),
|
-
+
| 144 |
- |
+ ! |
- #' )
+ teal.widgets::standard_layout(
|
-
+
| 145 |
- |
+ ! |
- #' ),
+ output = fluidRow(
|
-
+
| 146 |
- |
+ ! |
- #' y = data_extract_spec(
+ htmlwidgets::getDependency("sparkline"), # needed for sparklines to work
|
-
+
| 147 |
- |
+ ! |
- #' dataname = "ADSL",
+ column(
|
-
+
| 148 |
- |
+ ! |
- #' select = select_spec(
+ 6,
|
| 149 |
|
- #' label = "Select variable:",
+ # variable browser
|
-
+
| 150 |
- |
+ ! |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")),
+ teal.widgets::white_small_well(
|
-
+
| 151 |
- |
+ ! |
- #' selected = "BMRKR1",
+ uiOutput(ns("ui_variable_browser")),
|
-
+
| 152 |
- |
+ ! |
- #' multiple = FALSE,
+ shinyjs::hidden({
|
-
+
| 153 |
- |
+ ! |
- #' fixed = FALSE
+ checkboxInput(ns("show_parent_vars"), "Show parent dataset variables", value = FALSE)
|
| 154 |
|
- #' )
+ })
|
| 155 |
|
- #' ),
+ )
|
| 156 |
|
- #' color_by = data_extract_spec(
+ ),
|
-
+
| 157 |
- |
+ ! |
- #' dataname = "ADSL",
+ column(
|
-
+
| 158 |
- |
+ ! |
- #' select = select_spec(
+ 6,
|
-
+
| 159 |
- |
+ ! |
- #' label = "Select variable:",
+ teal.widgets::white_small_well(
|
| 160 |
|
- #' choices = variable_choices(
+ ### Reporter
|
-
+
| 161 |
- |
+ ! |
- #' data[["ADSL"]],
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 162 |
|
- #' c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1")
+ ###
|
-
+
| 163 |
- |
+ ! |
- #' ),
+ tags$div(
|
-
+
| 164 |
- |
+ ! |
- #' selected = NULL,
+ class = "block",
|
-
+
| 165 |
- |
+ ! |
- #' multiple = FALSE,
+ uiOutput(ns("ui_histogram_display"))
|
| 166 |
|
- #' fixed = FALSE
+ ),
|
-
+
| 167 |
- |
+ ! |
- #' )
+ tags$div(
|
-
+
| 168 |
- |
+ ! |
- #' ),
+ class = "block",
|
-
+
| 169 |
- |
+ ! |
- #' size_by = data_extract_spec(
+ uiOutput(ns("ui_numeric_display"))
|
| 170 |
|
- #' dataname = "ADSL",
+ ),
|
-
+
| 171 |
- |
+ ! |
- #' select = select_spec(
+ teal.widgets::plot_with_settings_ui(ns("variable_plot")),
|
-
+
| 172 |
- |
+ ! |
- #' label = "Select variable:",
+ tags$br(),
|
| 173 |
|
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
+ # input user-defined text size
|
-
+
| 174 |
- |
+ ! |
- #' selected = "AGE",
+ teal.widgets::panel_item(
|
-
+
| 175 |
- |
+ ! |
- #' multiple = FALSE,
+ title = "Plot settings",
|
-
+
| 176 |
- |
+ ! |
- #' fixed = FALSE
+ collapsed = TRUE,
|
-
+
| 177 |
- |
+ ! |
- #' )
+ selectInput(
|
-
+
| 178 |
- |
+ ! |
- #' ),
+ inputId = ns("ggplot_theme"), label = "ggplot2 theme",
|
-
+
| 179 |
- |
+ ! |
- #' row_facet = data_extract_spec(
+ choices = ggplot_themes,
|
-
+
| 180 |
- |
+ ! |
- #' dataname = "ADSL",
+ selected = "grey"
|
| 181 |
|
- #' select = select_spec(
+ ),
|
-
+
| 182 |
- |
+ ! |
- #' label = "Select variable:",
+ fluidRow(
|
-
+
| 183 |
- |
+ ! |
- #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")),
+ column(6, sliderInput(
|
-
+
| 184 |
- |
+ ! |
- #' selected = NULL,
+ inputId = ns("font_size"), label = "font size",
|
-
+
| 185 |
- |
+ ! |
- #' multiple = FALSE,
+ min = 5L, max = 30L, value = 15L, step = 1L, ticks = FALSE
|
| 186 |
|
- #' fixed = FALSE
+ )),
|
-
+
| 187 |
- |
+ ! |
- #' )
+ column(6, sliderInput(
|
-
+
| 188 |
- |
+ ! |
- #' ),
+ inputId = ns("label_rotation"), label = "rotate x labels",
|
-
+
| 189 |
- |
+ ! |
- #' col_facet = data_extract_spec(
+ min = 0L, max = 90L, value = 45L, step = 1, ticks = FALSE
|
| 190 |
|
- #' dataname = "ADSL",
+ ))
|
| 191 |
|
- #' select = select_spec(
+ )
|
| 192 |
|
- #' label = "Select variable:",
+ ),
|
-
+
| 193 |
- |
+ ! |
- #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")),
+ tags$br(),
|
-
+
| 194 |
- |
+ ! |
- #' selected = NULL,
+ teal.widgets::get_dt_rows(ns("variable_summary_table"), ns("variable_summary_table_rows")),
|
-
+
| 195 |
- |
+ ! |
- #' multiple = FALSE,
+ DT::dataTableOutput(ns("variable_summary_table"))
|
| 196 |
|
- #' fixed = FALSE
+ )
|
| 197 |
|
- #' )
+ )
|
| 198 |
|
- #' ),
+ ),
|
-
+
| 199 |
- |
+ ! |
- #' ggplot2_args = ggplot2_args(
+ pre_output = pre_output,
|
-
+
| 200 |
- |
+ ! |
- #' labs = list(subtitle = "Plot generated by Scatterplot Module")
+ post_output = post_output
|
| 201 |
|
- #' )
+ )
|
| 202 |
|
- #' )
+ )
|
| 203 |
|
- #' )
+ }
|
| 204 |
|
- #' )
+
|
| 205 |
|
- #' if (interactive()) {
+ # Server function for the variable browser module
|
| 206 |
|
- #' shinyApp(app$ui, app$server)
+ srv_variable_browser <- function(id,
|
| 207 |
|
- #' }
+ data,
|
| 208 |
|
- #'
+ reporter,
|
| 209 |
|
- #' @export
+ filter_panel_api,
|
| 210 |
|
- #'
+ datasets_selected, parent_dataname, ggplot2_args) {
|
-
+
| 211 |
- |
+ ! |
- tm_g_scatterplot <- function(label = "Scatterplot",
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
|
-
+
| 212 |
- |
+ ! |
- x,
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
|
-
+
| 213 |
- |
+ ! |
- y,
+ checkmate::assert_class(data, "reactive")
|
-
+
| 214 |
- |
+ ! |
- color_by = NULL,
+ checkmate::assert_class(isolate(data()), "teal_data")
|
-
+
| 215 |
- |
+ ! |
- size_by = NULL,
+ moduleServer(id, function(input, output, session) {
|
-
+
| 216 |
- |
+ ! |
- row_facet = NULL,
+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
|
| 217 |
|
- col_facet = NULL,
+
|
| 218 |
|
- plot_height = c(600, 200, 2000),
+ # if there are < this number of unique records then a numeric
|
| 219 |
|
- plot_width = NULL,
+ # variable can be treated as a factor and all factors with < this groups
|
| 220 |
|
- alpha = c(1, 0, 1),
+ # have their values plotted
|
-
+
| 221 |
- |
+ ! |
- shape = shape_names,
+ .unique_records_for_factor <- 30
|
| 222 |
|
- size = c(5, 1, 15),
+ # if there are < this number of unique records then a numeric
|
| 223 |
|
- max_deg = 5L,
+ # variable is by default treated as a factor
|
-
+
| 224 |
- |
+ ! |
- rotate_xaxis_labels = FALSE,
+ .unique_records_default_as_factor <- 6 # nolint: object_length.
|
| 225 |
|
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+
|
-
+
| 226 |
- |
+ ! |
- pre_output = NULL,
+ varname_numeric_as_factor <- reactiveValues()
|
| 227 |
|
- post_output = NULL,
+
|
-
+
| 228 |
- |
+ ! |
- table_dec = 4,
+ datanames <- isolate(teal.data::datanames(data()))
|
-
+
| 229 |
- |
+ ! |
- ggplot2_args = teal.widgets::ggplot2_args()) {
+ datanames <- Filter(function(name) {
|
| 230 |
! |
- message("Initializing tm_g_scatterplot")
+ is.data.frame(isolate(data())[[name]])
|
-
+
| 231 |
- |
+ ! |
-
+ }, datanames)
|
| 232 |
|
- # Requires Suggested packages
+
|
| 233 |
! |
- extra_packages <- c("ggpmisc", "ggExtra", "colourpicker")
+ checkmate::assert_character(datasets_selected)
|
| 234 |
! |
- missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages)
+ checkmate::assert_subset(datasets_selected, datanames)
|
| 235 |
! |
- if (length(missing_packages) > 0L) {
+ if (!identical(datasets_selected, character(0))) {
|
| 236 |
! |
- stop(sprintf(
+ checkmate::assert_subset(datasets_selected, datanames)
|
| 237 |
! |
- "Cannot load package(s): %s.\nInstall or restart your session.",
+ datanames <- datasets_selected
|
-
+
| 238 |
- ! |
+ |
- toString(missing_packages)
+ }
|
| 239 |
|
- ))
+
|
-
+
| 240 |
- |
+ ! |
- }
+ output$ui_variable_browser <- renderUI({
|
-
+
| 241 |
- |
+ ! |
-
+ ns <- session$ns
|
-
+
| 242 |
- |
+ ! |
- # Normalize the parameters
+ do.call(
|
| 243 |
! |
- if (inherits(x, "data_extract_spec")) x <- list(x)
+ tabsetPanel,
|
| 244 |
! |
- if (inherits(y, "data_extract_spec")) y <- list(y)
+ c(
|
| 245 |
! |
- if (inherits(color_by, "data_extract_spec")) color_by <- list(color_by)
+ id = ns("tabset_panel"),
|
| 246 |
! |
- if (inherits(size_by, "data_extract_spec")) size_by <- list(size_by)
+ do.call(
|
| 247 |
! |
- if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)
+ tagList,
|
| 248 |
! |
- if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)
+ lapply(datanames, function(dataname) {
|
| 249 |
! |
- if (is.double(max_deg)) max_deg <- as.integer(max_deg)
+ tabPanel(
|
-
+
| 250 |
- |
+ ! |
-
+ dataname,
|
-
+
| 251 |
- |
+ ! |
- # Start of assertions
+ tags$div(
|
| 252 |
! |
- checkmate::assert_string(label)
+ class = "mt-4",
|
| 253 |
! |
- checkmate::assert_list(x, types = "data_extract_spec")
+ textOutput(ns(paste0("dataset_summary_", dataname)))
|
-
+
| 254 |
- ! |
+ |
- checkmate::assert_list(y, types = "data_extract_spec")
+ ),
|
| 255 |
! |
- checkmate::assert_list(color_by, types = "data_extract_spec", null.ok = TRUE)
+ tags$div(
|
| 256 |
! |
- checkmate::assert_list(size_by, types = "data_extract_spec", null.ok = TRUE)
+ class = "mt-4",
|
-
+
| 257 |
- |
+ ! |
-
+ teal.widgets::get_dt_rows(
|
| 258 |
! |
- checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)
+ ns(paste0("variable_browser_", dataname)),
|
| 259 |
! |
- assert_single_selection(row_facet)
+ ns(paste0("variable_browser_", dataname, "_rows"))
|
| 260 |
|
-
+ ),
|
| 261 |
! |
- checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)
+ DT::dataTableOutput(ns(paste0("variable_browser_", dataname)), width = "100%")
|
-
+
| 262 |
- ! |
+ |
- assert_single_selection(col_facet)
+ )
|
| 263 |
|
-
+ )
|
-
+
| 264 |
- ! |
+ |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
+ })
|
-
+
| 265 |
- ! |
+ |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
+ )
|
-
+
| 266 |
- ! |
+ |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
+ )
|
-
+
| 267 |
- ! |
+ |
- checkmate::assert_numeric(
+ )
|
-
+
| 268 |
- ! |
+ |
- plot_width[1],
+ })
|
-
+
| 269 |
- ! |
+ |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
+
|
| 270 |
|
- )
+ # conditionally display checkbox
|
-
+
| 271 |
- |
+ ! |
-
+ shinyjs::toggle(
|
| 272 |
! |
- if (length(alpha) == 1) {
+ id = "show_parent_vars",
|
| 273 |
! |
- checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE)
+ condition = length(parent_dataname) > 0 && parent_dataname %in% datanames
|
| 274 |
|
- } else {
+ )
|
-
+
| 275 |
- ! |
+ |
- checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE)
+
|
| 276 |
! |
- checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")
+ columns_names <- new.env()
|
| 277 |
|
- }
+
|
| 278 |
|
-
+ # plot_var$data holds the name of the currently selected dataset
|
-
+
| 279 |
- ! |
+ |
- checkmate::assert_character(shape)
+ # plot_var$variable[[<dataset_name>]] holds the name of the currently selected
|
| 280 |
|
-
+ # variable for dataset <dataset_name>
|
| 281 |
! |
- if (length(size) == 1) {
+ plot_var <- reactiveValues(data = NULL, variable = list())
|
-
+
| 282 |
- ! |
+ |
- checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE)
+
|
-
+
| 283 |
- |
+ ! |
- } else {
+ establish_updating_selection(datanames, input, plot_var, columns_names)
|
-
+
| 284 |
- ! |
+ |
- checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE)
+
|
-
+
| 285 |
- ! |
+ |
- checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")
+ # validations
|
-
+
| 286 |
- |
+ ! |
- }
+ validation_checks <- validate_input(input, plot_var, data)
|
@@ -11293,25 +11328,25 @@ teal.modules.general coverage - 3.44%
-
+
| 288 |
- ! |
+ |
- checkmate::assert_int(max_deg, lower = 1L)
+ # data_for_analysis is a list with two elements: a column from a dataset and the column label
|
| 289 |
! |
- checkmate::assert_flag(rotate_xaxis_labels)
+ plotted_data <- reactive({
|
| 290 |
! |
- ggtheme <- match.arg(ggtheme)
+ validation_checks()
|
@@ -11325,14 +11360,14 @@ teal.modules.general coverage - 3.44%
292 |
! |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ get_plotted_data(input, plot_var, data)
|
-
+
| 293 |
- ! |
+ |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ })
|
@@ -11346,210 +11381,210 @@ teal.modules.general coverage - 3.44%
295 |
! |
- checkmate::assert_scalar(table_dec)
+ treat_numeric_as_factor <- reactive({
|
| 296 |
! |
- checkmate::assert_class(ggplot2_args, "ggplot2_args")
+ if (is_num_var_short(.unique_records_for_factor, input, plotted_data)) {
|
-
+
| 297 |
- |
+ ! |
- # End of assertions
+ input$numeric_as_factor
|
| 298 |
|
-
+ } else {
|
-
+
| 299 |
- |
+ ! |
- # Make UI args
+ FALSE
|
-
+
| 300 |
- ! |
+ |
- args <- as.list(environment())
+ }
|
| 301 |
|
-
+ })
|
-
+
| 302 |
- ! |
+ |
- data_extract_list <- list(
+
|
| 303 |
! |
- x = x,
+ render_tabset_panel_content(
|
| 304 |
! |
- y = y,
+ input = input,
|
| 305 |
! |
- color_by = color_by,
+ output = output,
|
| 306 |
! |
- size_by = size_by,
+ data = data,
|
| 307 |
! |
- row_facet = row_facet,
+ datanames = datanames,
|
| 308 |
! |
- col_facet = col_facet
+ parent_dataname = parent_dataname,
|
-
+
| 309 |
- |
+ ! |
- )
+ columns_names = columns_names,
|
-
+
| 310 |
- |
+ ! |
-
+ plot_var = plot_var
|
-
+
| 311 |
- ! |
+ |
- ans <- module(
+ )
|
-
+
| 312 |
- ! |
+ |
- label = label,
+ # add used-defined text size to ggplot arguments passed from caller frame
|
| 313 |
! |
- server = srv_g_scatterplot,
+ all_ggplot2_args <- reactive({
|
| 314 |
! |
- ui = ui_g_scatterplot,
+ user_text <- teal.widgets::ggplot2_args(
|
| 315 |
! |
- ui_args = args,
+ theme = list(
|
| 316 |
! |
- server_args = c(
+ "text" = ggplot2::element_text(size = input[["font_size"]]),
|
| 317 |
! |
- data_extract_list,
+ "axis.text.x" = ggplot2::element_text(angle = input[["label_rotation"]], hjust = 1)
|
-
+
| 318 |
- ! |
+ |
- list(plot_height = plot_height, plot_width = plot_width, table_dec = table_dec, ggplot2_args = ggplot2_args)
+ )
|
| 319 |
|
- ),
+ )
|
| 320 |
! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)
+ user_theme <- utils::getFromNamespace(sprintf("theme_%s", input[["ggplot_theme"]]), ns = "ggplot2")
|
-
+
| 321 |
- |
+ ! |
- )
+ user_theme <- user_theme()
|
-
+
| 322 |
- ! |
+ |
- attr(ans, "teal_bookmarkable") <- TRUE
+ # temporary fix to circumvent assertion issue with resolve_ggplot2_args
|
-
+
| 323 |
- ! |
+ |
- ans
+ # drop problematic elements
|
-
+
| 324 |
- |
+ ! |
- }
+ user_theme <- user_theme[grep("strip.text.y.left", names(user_theme), fixed = TRUE, invert = TRUE)]
|
@@ -11559,487 +11594,487 @@ teal.modules.general coverage - 3.44%
-
+
| 326 |
- |
+ ! |
- # UI function for the scatterplot module
+ teal.widgets::resolve_ggplot2_args(
|
-
+
| 327 |
- |
+ ! |
- ui_g_scatterplot <- function(id, ...) {
+ user_plot = user_text,
|
| 328 |
! |
- args <- list(...)
+ user_default = teal.widgets::ggplot2_args(theme = user_theme),
|
| 329 |
! |
- ns <- NS(id)
+ module_plot = ggplot2_args
|
-
+
| 330 |
- ! |
+ |
- is_single_dataset_value <- teal.transform::is_single_dataset(
+ )
|
-
+
| 331 |
- ! |
+ |
- args$x, args$y, args$color_by, args$size_by, args$row_facet, args$col_facet
+ })
|
| 332 |
|
- )
+
|
-
+
| 333 |
- |
+ ! |
-
+ output$ui_numeric_display <- renderUI({
|
| 334 |
! |
- tagList(
+ validation_checks()
|
| 335 |
! |
- include_css_files("custom"),
+ dataname <- input$tabset_panel
|
| 336 |
! |
- teal.widgets::standard_layout(
+ varname <- plot_var$variable[[dataname]]
|
| 337 |
! |
- output = teal.widgets::white_small_well(
+ df <- data()[[dataname]]
|
-
+
| 338 |
- ! |
+ |
- teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")),
+
|
| 339 |
! |
- tags$h1(tags$strong("Selected points:"), class = "text-center font-150p"),
+ numeric_ui <- tagList(
|
| 340 |
! |
- teal.widgets::get_dt_rows(ns("data_table"), ns("data_table_rows")),
+ fluidRow(
|
| 341 |
! |
- DT::dataTableOutput(ns("data_table"), width = "100%")
+ tags$div(
|
-
+
| 342 |
- |
+ ! |
- ),
+ class = "col-md-4",
|
| 343 |
! |
- encoding = tags$div(
+ tags$br(),
|
-
+
| 344 |
- |
+ ! |
- ### Reporter
+ shinyWidgets::switchInput(
|
| 345 |
! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ inputId = session$ns("display_density"),
|
-
+
| 346 |
- |
+ ! |
- ###
+ label = "Show density",
|
| 347 |
! |
- tags$label("Encodings", class = "text-primary"),
+ value = `if`(is.null(isolate(input$display_density)), TRUE, isolate(input$display_density)),
|
| 348 |
! |
- teal.transform::datanames_input(args[c("x", "y", "color_by", "size_by", "row_facet", "col_facet")]),
+ width = "50%",
|
| 349 |
! |
- teal.transform::data_extract_ui(
+ labelWidth = "100px",
|
| 350 |
! |
- id = ns("x"),
+ handleWidth = "50px"
|
-
+
| 351 |
- ! |
+ |
- label = "X variable",
+ )
|
-
+
| 352 |
- ! |
+ |
- data_extract_spec = args$x,
+ ),
|
| 353 |
! |
- is_single_dataset = is_single_dataset_value
+ tags$div(
|
-
+
| 354 |
- |
+ ! |
- ),
+ class = "col-md-4",
|
| 355 |
! |
- checkboxInput(ns("log_x"), "Use log transformation", value = FALSE),
+ tags$br(),
|
| 356 |
! |
- conditionalPanel(
+ shinyWidgets::switchInput(
|
| 357 |
! |
- condition = paste0("input['", ns("log_x"), "'] == true"),
+ inputId = session$ns("remove_outliers"),
|
| 358 |
! |
- radioButtons(
+ label = "Remove outliers",
|
| 359 |
! |
- ns("log_x_base"),
+ value = `if`(is.null(isolate(input$remove_outliers)), FALSE, isolate(input$remove_outliers)),
|
| 360 |
! |
- label = NULL,
+ width = "50%",
|
| 361 |
! |
- inline = TRUE,
+ labelWidth = "100px",
|
| 362 |
! |
- choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
+ handleWidth = "50px"
|
| 363 |
|
- )
+ )
|
| 364 |
|
- ),
+ ),
|
| 365 |
! |
- teal.transform::data_extract_ui(
+ tags$div(
|
| 366 |
! |
- id = ns("y"),
+ class = "col-md-4",
|
| 367 |
! |
- label = "Y variable",
+ uiOutput(session$ns("outlier_definition_slider_ui"))
|
-
+
| 368 |
- ! |
+ |
- data_extract_spec = args$y,
+ )
|
-
+
| 369 |
- ! |
+ |
- is_single_dataset = is_single_dataset_value
+ ),
|
-
+
| 370 |
- |
+ ! |
- ),
+ tags$div(
|
| 371 |
! |
- checkboxInput(ns("log_y"), "Use log transformation", value = FALSE),
+ class = "ml-4",
|
| 372 |
! |
- conditionalPanel(
+ uiOutput(session$ns("ui_density_help")),
|
| 373 |
! |
- condition = paste0("input['", ns("log_y"), "'] == true"),
+ uiOutput(session$ns("ui_outlier_help"))
|
-
+
| 374 |
- ! |
+ |
- radioButtons(
+ )
|
-
+
| 375 |
- ! |
+ |
- ns("log_y_base"),
+ )
|
-
+
| 376 |
- ! |
+ |
- label = NULL,
+
|
| 377 |
! |
- inline = TRUE,
+ observeEvent(input$numeric_as_factor, ignoreInit = TRUE, {
|
| 378 |
! |
- choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
+ varname_numeric_as_factor[[plot_var$variable[[dataname]]]] <- input$numeric_as_factor
|
| 379 |
|
- )
+ })
|
| 380 |
|
- ),
+
|
| 381 |
! |
- if (!is.null(args$color_by)) {
+ if (is.numeric(df[[varname]])) {
|
| 382 |
! |
- teal.transform::data_extract_ui(
+ unique_entries <- length(unique(df[[varname]]))
|
| 383 |
! |
- id = ns("color_by"),
+ if (unique_entries < .unique_records_for_factor && unique_entries > 0) {
|
| 384 |
! |
- label = "Color by variable",
+ list(
|
| 385 |
! |
- data_extract_spec = args$color_by,
+ checkboxInput(
|
| 386 |
! |
- is_single_dataset = is_single_dataset_value
+ session$ns("numeric_as_factor"),
|
-
+
| 387 |
- |
+ ! |
- )
+ "Treat variable as factor",
|
-
+
| 388 |
- |
+ ! |
- },
+ value = `if`(
|
| 389 |
! |
- if (!is.null(args$size_by)) {
+ is.null(varname_numeric_as_factor[[varname]]),
|
| 390 |
! |
- teal.transform::data_extract_ui(
+ unique_entries < .unique_records_default_as_factor,
|
| 391 |
! |
- id = ns("size_by"),
+ varname_numeric_as_factor[[varname]]
|
-
+
| 392 |
- ! |
+ |
- label = "Size by variable",
+ )
|
-
+
| 393 |
- ! |
+ |
- data_extract_spec = args$size_by,
+ ),
|
| 394 |
! |
- is_single_dataset = is_single_dataset_value
+ conditionalPanel("!input.numeric_as_factor", ns = session$ns, numeric_ui)
|
@@ -12049,977 +12084,977 @@ teal.modules.general coverage - 3.44%
)
-
+
| 396 |
- |
+ ! |
- },
+ } else if (unique_entries > 0) {
|
| 397 |
! |
- if (!is.null(args$row_facet)) {
+ numeric_ui
|
-
+
| 398 |
- ! |
+ |
- teal.transform::data_extract_ui(
+ }
|
-
+
| 399 |
- ! |
+ |
- id = ns("row_facet"),
+ } else {
|
| 400 |
! |
- label = "Row facetting",
+ NULL
|
-
+
| 401 |
- ! |
+ |
- data_extract_spec = args$row_facet,
+ }
|
-
+
| 402 |
- ! |
+ |
- is_single_dataset = is_single_dataset_value
+ })
|
| 403 |
|
- )
+
|
-
+
| 404 |
- |
+ ! |
- },
+ output$ui_histogram_display <- renderUI({
|
| 405 |
! |
- if (!is.null(args$col_facet)) {
+ validation_checks()
|
| 406 |
! |
- teal.transform::data_extract_ui(
+ dataname <- input$tabset_panel
|
| 407 |
! |
- id = ns("col_facet"),
+ varname <- plot_var$variable[[dataname]]
|
| 408 |
! |
- label = "Column facetting",
+ df <- data()[[dataname]]
|
-
+
| 409 |
- ! |
+ |
- data_extract_spec = args$col_facet,
+
|
| 410 |
! |
- is_single_dataset = is_single_dataset_value
+ numeric_ui <- tagList(fluidRow(
|
-
+
| 411 |
- |
+ ! |
- )
+ tags$div(
|
-
+
| 412 |
- |
+ ! |
- },
+ class = "col-md-4",
|
| 413 |
! |
- teal.widgets::panel_group(
+ shinyWidgets::switchInput(
|
| 414 |
! |
- teal.widgets::panel_item(
+ inputId = session$ns("remove_NA_hist"),
|
| 415 |
! |
- title = "Plot settings",
+ label = "Remove NA values",
|
| 416 |
! |
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
+ value = FALSE,
|
| 417 |
! |
- teal.widgets::optionalSelectInput(
+ width = "50%",
|
| 418 |
! |
- inputId = ns("shape"),
+ labelWidth = "100px",
|
| 419 |
! |
- label = "Points shape:",
+ handleWidth = "50px"
|
-
+
| 420 |
- ! |
+ |
- choices = args$shape,
+ )
|
-
+
| 421 |
- ! |
+ |
- selected = args$shape[1],
+ )
|
-
+
| 422 |
- ! |
+ |
- multiple = FALSE
+ ))
|
| 423 |
|
- ),
+
|
| 424 |
! |
- colourpicker::colourInput(ns("color"), "Points color:", "black"),
+ var <- df[[varname]]
|
| 425 |
! |
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE, step = .1),
+ if (anyNA(var) && (is.factor(var) || is.character(var) || is.logical(var))) {
|
| 426 |
! |
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
+ groups <- unique(as.character(var))
|
| 427 |
! |
- checkboxInput(ns("add_density"), "Add marginal density", value = FALSE),
+ len_groups <- length(groups)
|
| 428 |
! |
- checkboxInput(ns("rug_plot"), "Include rug plot", value = FALSE),
+ if (len_groups >= .unique_records_for_factor) {
|
| 429 |
! |
- checkboxInput(ns("show_count"), "Show N (number of observations)", value = FALSE),
+ NULL
|
-
+
| 430 |
- ! |
+ |
- shinyjs::hidden(helpText(id = ns("line_msg"), "Trendline needs numeric X and Y variables")),
+ } else {
|
| 431 |
! |
- teal.widgets::optionalSelectInput(ns("smoothing_degree"), "Smoothing degree", seq_len(args$max_deg)),
+ numeric_ui
|
-
+
| 432 |
- ! |
+ |
- shinyjs::hidden(teal.widgets::optionalSelectInput(ns("color_sub"), label = "", multiple = TRUE)),
+ }
|
-
+
| 433 |
- ! |
+ |
- teal.widgets::optionalSliderInputValMinMax(ns("ci"), "Confidence", c(.95, .8, .99), ticks = FALSE),
+ } else {
|
| 434 |
! |
- shinyjs::hidden(checkboxInput(ns("show_form"), "Show formula", value = TRUE)),
+ NULL
|
-
+
| 435 |
- ! |
+ |
- shinyjs::hidden(checkboxInput(ns("show_r2"), "Show adj-R Squared", value = TRUE)),
+ }
|
-
+
| 436 |
- ! |
+ |
- uiOutput(ns("num_na_removed")),
+ })
|
-
+
| 437 |
- ! |
+ |
- tags$div(
+
|
| 438 |
! |
- id = ns("label_pos"),
+ output$outlier_definition_slider_ui <- renderUI({
|
| 439 |
! |
- tags$div(tags$strong("Stats position")),
+ req(input$remove_outliers)
|
| 440 |
! |
- tags$div(class = "inline-block w-10", helpText("Left")),
+ sliderInput(
|
| 441 |
! |
- tags$div(
+ inputId = session$ns("outlier_definition_slider"),
|
| 442 |
! |
- class = "inline-block w-70",
+ tags$div(
|
| 443 |
! |
- teal.widgets::optionalSliderInput(
+ class = "teal-tooltip",
|
| 444 |
! |
- ns("pos"),
+ tagList(
|
| 445 |
! |
- label = NULL,
+ "Outlier definition:",
|
| 446 |
! |
- min = 0, max = 1, value = .99, ticks = FALSE, step = .01
+ icon("circle-info"),
|
-
+
| 447 |
- |
+ ! |
- )
+ tags$span(
|
-
+
| 448 |
- |
+ ! |
- ),
+ class = "tooltiptext",
|
| 449 |
! |
- tags$div(class = "inline-block w-10", helpText("Right"))
+ paste(
|
-
+
| 450 |
- |
+ ! |
- ),
+ "Use the slider to choose the cut-off value to define outliers; the larger the value the",
|
| 451 |
! |
- teal.widgets::optionalSliderInput(
+ "further below Q1/above Q3 points have to be in order to be classed as outliers"
|
-
+
| 452 |
- ! |
+ |
- ns("label_size"), "Stats font size",
+ )
|
-
+
| 453 |
- ! |
+ |
- min = 3, max = 10, value = 5, ticks = FALSE, step = .1
+ )
|
| 454 |
|
- ),
+ )
|
-
+
| 455 |
- ! |
+ |
- if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
+ ),
|
| 456 |
! |
- checkboxInput(ns("free_scales"), "Free scales", value = FALSE)
+ min = 1,
|
-
+
| 457 |
- |
+ ! |
- },
+ max = 5,
|
| 458 |
! |
- selectInput(
+ value = 3,
|
| 459 |
! |
- inputId = ns("ggtheme"),
+ step = 0.5
|
-
+
| 460 |
- ! |
+ |
- label = "Theme (by ggplot):",
+ )
|
-
+
| 461 |
- ! |
+ |
- choices = ggplot_themes,
+ })
|
-
+
| 462 |
- ! |
+ |
- selected = args$ggtheme,
+
|
| 463 |
! |
- multiple = FALSE
+ output$ui_density_help <- renderUI({
|
-
+
| 464 |
- |
+ ! |
- )
+ req(is.logical(input$display_density))
|
-
+
| 465 |
- |
+ ! |
- )
+ if (input$display_density) {
|
-
+
| 466 |
- |
+ ! |
- )
+ tags$small(helpText(paste(
|
-
+
| 467 |
- |
+ ! |
- ),
+ "Kernel density estimation with gaussian kernel",
|
| 468 |
! |
- forms = tagList(
+ "and bandwidth function bw.nrd0 (R default)"
|
-
+
| 469 |
- ! |
+ |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ )))
|
| 470 |
|
- ),
+ } else {
|
| 471 |
! |
- pre_output = args$pre_output,
+ NULL
|
-
+
| 472 |
- ! |
+ |
- post_output = args$post_output
+ }
|
| 473 |
|
- )
+ })
|
| 474 |
|
- )
+
|
-
+
| 475 |
- |
+ ! |
- }
+ output$ui_outlier_help <- renderUI({
|
-
+
| 476 |
- |
+ ! |
-
+ req(is.logical(input$remove_outliers), input$outlier_definition_slider)
|
-
+
| 477 |
- |
+ ! |
- # Server function for the scatterplot module
+ if (input$remove_outliers) {
|
-
+
| 478 |
- |
+ ! |
- srv_g_scatterplot <- function(id,
+ tags$small(
|
-
+
| 479 |
- |
+ ! |
- data,
+ helpText(
|
-
+
| 480 |
- |
+ ! |
- reporter,
+ withMathJax(paste0(
|
-
+
| 481 |
- |
+ ! |
- filter_panel_api,
+ "Outlier data points (\\( X \\lt Q1 - ", input$outlier_definition_slider, "\\times IQR \\) or
|
-
+
| 482 |
- |
+ ! |
- x,
+ \\(Q3 + ", input$outlier_definition_slider, "\\times IQR \\lt X\\))
|
-
+
| 483 |
- |
+ ! |
- y,
+ have not been displayed on the graph and will not be used for any kernel density estimations, ",
|
-
+
| 484 |
- |
+ ! |
- color_by,
+ "although their values remain in the statisics table below."
|
| 485 |
|
- size_by,
+ ))
|
| 486 |
|
- row_facet,
+ )
|
| 487 |
|
- col_facet,
+ )
|
| 488 |
|
- plot_height,
+ } else {
|
-
+
| 489 |
- |
+ ! |
- plot_width,
+ NULL
|
| 490 |
|
- table_dec,
+ }
|
| 491 |
|
- ggplot2_args) {
+ })
|
-
+
| 492 |
- ! |
+ |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
+
|
-
+
| 493 |
- ! |
+ |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
+
|
| 494 |
! |
- checkmate::assert_class(data, "reactive")
+ variable_plot_r <- reactive({
|
| 495 |
! |
- checkmate::assert_class(isolate(data()), "teal_data")
+ display_density <- `if`(is.null(input$display_density), FALSE, input$display_density)
|
| 496 |
! |
- moduleServer(id, function(input, output, session) {
+ remove_outliers <- `if`(is.null(input$remove_outliers), FALSE, input$remove_outliers)
|
-
+
| 497 |
- ! |
+ |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
+
|
-
+
| 498 |
- |
+ ! |
-
+ if (remove_outliers) {
|
| 499 |
! |
- data_extract <- list(
+ req(input$outlier_definition_slider)
|
| 500 |
! |
- x = x,
+ outlier_definition <- as.numeric(input$outlier_definition_slider)
|
-
+
| 501 |
- ! |
+ |
- y = y,
+ } else {
|
| 502 |
! |
- color_by = color_by,
+ outlier_definition <- 0
|
-
+
| 503 |
- ! |
+ |
- size_by = size_by,
+ }
|
-
+
| 504 |
- ! |
+ |
- row_facet = row_facet,
+
|
| 505 |
! |
- col_facet = col_facet
+ plot_var_summary(
|
-
+
| 506 |
- |
+ ! |
- )
+ var = plotted_data()$data,
|
-
+
| 507 |
- |
+ ! |
-
+ var_lab = plotted_data()$var_description,
|
| 508 |
! |
- rule_diff <- function(other) {
+ wrap_character = 15,
|
| 509 |
! |
- function(value) {
+ numeric_as_factor = treat_numeric_as_factor(),
|
| 510 |
! |
- othervalue <- selector_list()[[other]]()[["select"]]
+ remove_NA_hist = input$remove_NA_hist,
|
| 511 |
! |
- if (!is.null(othervalue)) {
+ display_density = display_density,
|
| 512 |
! |
- if (identical(value, othervalue)) {
+ outlier_definition = outlier_definition,
|
| 513 |
! |
- "Row and column facetting variables must be different."
+ records_for_factor = .unique_records_for_factor,
|
-
+
| 514 |
- |
+ ! |
- }
+ ggplot2_args = all_ggplot2_args()
|
| 515 |
|
- }
+ )
|
| 516 |
|
- }
+ })
|
| 517 |
|
- }
+
|
-
+
| 518 |
- |
+ ! |
-
+ pws <- teal.widgets::plot_with_settings_srv(
|
| 519 |
! |
- selector_list <- teal.transform::data_extract_multiple_srv(
+ id = "variable_plot",
|
| 520 |
! |
- data_extract = data_extract,
+ plot_r = variable_plot_r,
|
| 521 |
! |
- datasets = data,
+ height = c(500, 200, 2000)
|
-
+
| 522 |
- ! |
+ |
- select_validation_rule = list(
+ )
|
-
+
| 523 |
- ! |
+ |
- x = ~ if (length(.) != 1) "Please select exactly one x var.",
+
|
| 524 |
! |
- y = ~ if (length(.) != 1) "Please select exactly one y var.",
+ output$variable_summary_table <- DT::renderDataTable({
|
| 525 |
! |
- color_by = ~ if (length(.) > 1) "There cannot be more than 1 color variable.",
+ var_summary_table(
|
| 526 |
! |
- size_by = ~ if (length(.) > 1) "There cannot be more than 1 size variable.",
+ plotted_data()$data,
|
| 527 |
! |
- row_facet = shinyvalidate::compose_rules(
+ treat_numeric_as_factor(),
|
| 528 |
! |
- shinyvalidate::sv_optional(),
+ input$variable_summary_table_rows,
|
| 529 |
! |
- rule_diff("col_facet")
+ if (!is.null(input$remove_outliers) && input$remove_outliers) {
|
-
+
| 530 |
- |
+ ! |
- ),
+ req(input$outlier_definition_slider)
|
| 531 |
! |
- col_facet = shinyvalidate::compose_rules(
+ as.numeric(input$outlier_definition_slider)
|
-
+
| 532 |
- ! |
+ |
- shinyvalidate::sv_optional(),
+ } else {
|
| 533 |
! |
- rule_diff("row_facet")
+ 0
|
| 534 |
|
- )
+ }
|
@@ -13033,7 +13068,7 @@ teal.modules.general coverage - 3.44%
536 |
|
- )
+ })
|
@@ -13043,1887 +13078,1887 @@ teal.modules.general coverage - 3.44%
-
+
| 538 |
- ! |
+ |
- iv_r <- reactive({
+ ### REPORTER
|
| 539 |
! |
- iv_facet <- shinyvalidate::InputValidator$new()
+ if (with_reporter) {
|
| 540 |
! |
- iv <- shinyvalidate::InputValidator$new()
+ card_fun <- function(comment) {
|
| 541 |
! |
- teal.transform::compose_and_enable_validators(iv, selector_list)
+ card <- teal::TealReportCard$new()
|
-
+
| 542 |
- |
+ ! |
- })
+ card$set_name("Variable Browser Plot")
|
| 543 |
! |
- iv_facet <- shinyvalidate::InputValidator$new()
+ card$append_text("Variable Browser Plot", "header2")
|
| 544 |
! |
- iv_facet$add_rule("add_density", ~ if (
+ if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
|
| 545 |
! |
- isTRUE(.) &&
+ card$append_text("Plot", "header3")
|
-
+
| 546 |
- |
+ ! |
- (
+ card$append_plot(variable_plot_r(), dim = pws$dim())
|
| 547 |
! |
- length(selector_list()$row_facet()$select) > 0L ||
+ if (!comment == "") {
|
| 548 |
! |
- length(selector_list()$col_facet()$select) > 0L
+ card$append_text("Comment", "header3")
|
-
+
| 549 |
- |
+ ! |
- )
+ card$append_text(comment)
|
| 550 |
|
- ) {
+ }
|
| 551 |
! |
- "Cannot add marginal density when Row or Column facetting has been selected"
+ card
|
| 552 |
|
- })
+ }
|
| 553 |
! |
- iv_facet$enable()
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 554 |
|
-
+ }
|
-
+
| 555 |
- ! |
+ |
- anl_merged_input <- teal.transform::merge_expression_srv(
+ ###
|
-
+
| 556 |
- ! |
+ |
- selector_list = selector_list,
+ })
|
-
+
| 557 |
- ! |
+ |
- datasets = data,
+ }
|
-
+
| 558 |
- ! |
+ |
- merge_function = "dplyr::inner_join"
+
|
| 559 |
|
- )
+ #' Summarize NAs.
|
| 560 |
|
-
+ #'
|
-
+
| 561 |
- ! |
+ |
- anl_merged_q <- reactive({
+ #' Summarizes occurrence of missing values in vector.
|
-
+
| 562 |
- ! |
+ |
- req(anl_merged_input())
+ #' @param x vector of any type and length
|
-
+
| 563 |
- ! |
+ |
- data() %>%
+ #' @return Character string describing `NA` occurrence.
|
-
+
| 564 |
- ! |
+ |
- teal.code::eval_code(as.expression(anl_merged_input()$expr)) %>%
+ #' @keywords internal
|
-
+
| 565 |
- ! |
+ |
- teal.code::eval_code(quote(ANL)) # used to display table when running show-r-code code
+ var_missings_info <- function(x) {
|
-
+
| 566 |
- |
+ ! |
- })
+ sprintf("%s [%s%%]", sum(is.na(x)), round(mean(is.na(x) * 100), 2))
|
| 567 |
|
-
+ }
|
-
+
| 568 |
- ! |
+ |
- merged <- list(
+
|
-
+
| 569 |
- ! |
+ |
- anl_input_r = anl_merged_input,
+ #' Summarizes variable
|
-
+
| 570 |
- ! |
+ |
- anl_q_r = anl_merged_q
+ #'
|
| 571 |
|
- )
+ #' Creates html summary with statistics relevant to data type. For numeric values it returns central
|
| 572 |
|
-
+ #' tendency measures, for factor returns level counts, for Date date range, for other just
|
-
+
| 573 |
- ! |
+ |
- trend_line_is_applicable <- reactive({
+ #' number of levels.
|
-
+
| 574 |
- ! |
+ |
- ANL <- merged$anl_q_r()[["ANL"]]
+ #'
|
-
+
| 575 |
- ! |
+ |
- x_var <- as.vector(merged$anl_input_r()$columns_source$x)
+ #' @param x vector of any type
|
-
+
| 576 |
- ! |
+ |
- y_var <- as.vector(merged$anl_input_r()$columns_source$y)
+ #' @param numeric_as_factor `logical` should the numeric variable be treated as a factor
|
-
+
| 577 |
- ! |
+ |
- length(x_var) > 0 && length(y_var) > 0 && is.numeric(ANL[[x_var]]) && is.numeric(ANL[[y_var]])
+ #' @param dt_rows `numeric` current/latest `DT` page length
|
| 578 |
|
- })
+ #' @param outlier_definition If 0 no outliers are removed, otherwise
|
| 579 |
|
-
+ #' outliers (those more than `outlier_definition*IQR below/above Q1/Q3` be removed)
|
-
+
| 580 |
- ! |
+ |
- add_trend_line <- reactive({
+ #' @return text with simple statistics.
|
-
+
| 581 |
- ! |
+ |
- smoothing_degree <- as.integer(input$smoothing_degree)
+ #' @keywords internal
|
-
+
| 582 |
- ! |
+ |
- trend_line_is_applicable() && length(smoothing_degree) > 0
+ var_summary_table <- function(x, numeric_as_factor, dt_rows, outlier_definition) {
|
-
+
| 583 |
- |
+ ! |
- })
+ if (is.null(dt_rows)) {
|
-
+
| 584 |
- |
+ ! |
-
+ dt_rows <- 10
|
-
+
| 585 |
- ! |
+ |
- if (!is.null(color_by)) {
+ }
|
| 586 |
! |
- observeEvent(
+ if (is.numeric(x) && !numeric_as_factor) {
|
| 587 |
! |
- eventExpr = merged$anl_input_r()$columns_source$color_by,
+ req(!any(is.infinite(x)))
|
-
+
| 588 |
- ! |
+ |
- handlerExpr = {
+
|
| 589 |
! |
- color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by)
+ x <- remove_outliers_from(x, outlier_definition)
|
-
+
| 590 |
- ! |
+ |
- if (length(color_by_var) > 0) {
+
|
| 591 |
! |
- shinyjs::hide("color")
+ qvals <- round(stats::quantile(x, na.rm = TRUE, probs = c(0.25, 0.5, 0.75), type = 2), 2)
|
| 592 |
|
- } else {
+ # classical central tendency measures
|
-
+
| 593 |
- ! |
+ |
- shinyjs::show("color")
+
|
-
+
| 594 |
- |
+ ! |
- }
+ summary <-
|
-
+
| 595 |
- |
+ ! |
- }
+ data.frame(
|
-
+
| 596 |
- |
+ ! |
- )
+ Statistic = c("min", "Q1", "median", "mean", "Q3", "max", "sd", "n"),
|
-
+
| 597 |
- |
+ ! |
- }
+ Value = c(
|
-
+
| 598 |
- |
+ ! |
-
+ round(min(x, na.rm = TRUE), 2),
|
| 599 |
! |
- output$num_na_removed <- renderUI({
+ qvals[1],
|
| 600 |
! |
- if (add_trend_line()) {
+ qvals[2],
|
| 601 |
! |
- ANL <- merged$anl_q_r()[["ANL"]]
+ round(mean(x, na.rm = TRUE), 2),
|
| 602 |
! |
- x_var <- as.vector(merged$anl_input_r()$columns_source$x)
+ qvals[3],
|
| 603 |
! |
- y_var <- as.vector(merged$anl_input_r()$columns_source$y)
+ round(max(x, na.rm = TRUE), 2),
|
| 604 |
! |
- if ((num_total_na <- nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)]))) > 0) {
+ round(stats::sd(x, na.rm = TRUE), 2),
|
| 605 |
! |
- tags$div(paste(num_total_na, "row(s) with missing values were removed"), tags$hr())
+ length(x[!is.na(x)])
|
| 606 |
|
- }
+ )
|
| 607 |
|
- }
+ )
|
| 608 |
|
- })
+
|
-
+
| 609 |
- |
+ ! |
-
+ DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows))
|
| 610 |
! |
- observeEvent(
+ } else if (is.factor(x) || is.character(x) || (is.numeric(x) && numeric_as_factor) || is.logical(x)) {
|
-
+
| 611 |
- ! |
+ |
- eventExpr = merged$anl_input_r()$columns_source[c("col_facet", "row_facet")],
+ # make sure factor is ordered numeric
|
| 612 |
! |
- handlerExpr = {
+ if (is.numeric(x)) {
|
| 613 |
! |
- if (
+ x <- factor(x, levels = sort(unique(x)))
|
-
+
| 614 |
- ! |
+ |
- length(merged$anl_input_r()$columns_source$col_facet) == 0 &&
+ }
|
-
+
| 615 |
- ! |
+ |
- length(merged$anl_input_r()$columns_source$row_facet) == 0
+
|
-
+
| 616 |
- |
+ ! |
- ) {
+ level_counts <- table(x)
|
| 617 |
! |
- shinyjs::hide("free_scales")
+ max_levels_signif <- nchar(level_counts)
|
| 618 |
|
- } else {
+
|
| 619 |
! |
- shinyjs::show("free_scales")
+ if (!all(is.na(x))) {
|
-
+
| 620 |
- |
+ ! |
- }
+ levels <- names(level_counts)
|
-
+
| 621 |
- |
+ ! |
- }
+ counts <- sprintf(
|
-
+
| 622 |
- |
+ ! |
- )
+ "%s [%.2f%%]",
|
-
+
| 623 |
- |
+ ! |
-
+ format(level_counts, width = max_levels_signif), prop.table(level_counts) * 100
|
-
+
| 624 |
- ! |
+ |
- output_q <- reactive({
+ )
|
-
+
| 625 |
- ! |
+ |
- teal::validate_inputs(iv_r(), iv_facet)
+ } else {
|
-
+
| 626 |
- |
+ ! |
-
+ levels <- character(0)
|
| 627 |
! |
- ANL <- merged$anl_q_r()[["ANL"]]
+ counts <- numeric(0)
|
| 628 |
|
-
+ }
|
-
+
| 629 |
- ! |
+ |
- x_var <- as.vector(merged$anl_input_r()$columns_source$x)
+
|
| 630 |
! |
- y_var <- as.vector(merged$anl_input_r()$columns_source$y)
+ summary <- data.frame(
|
| 631 |
! |
- color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by)
+ Level = levels,
|
| 632 |
! |
- size_by_var <- as.vector(merged$anl_input_r()$columns_source$size_by)
+ Count = counts,
|
| 633 |
! |
- row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
+ stringsAsFactors = FALSE
|
-
+
| 634 |
- ! |
+ |
- character(0)
+ )
|
| 635 |
|
- } else {
+
|
-
+
| 636 |
+ |
+
+ # sort the dataset in decreasing order of counts (needed as character variables default to alphabetical)
+ |
+
+
+ | 637 |
! |
- as.vector(merged$anl_input_r()$columns_source$row_facet)
+ summary <- summary[order(summary$Count, decreasing = TRUE), ]
|
- | 637 |
+ 638 |
|
- }
+
|
- | 638 |
+ 639 |
! |
- col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
+ dom_opts <- if (nrow(summary) <= 10) {
|
- | 639 |
+ 640 |
! |
- character(0)
+ "<t>"
|
- | 640 |
+ 641 |
|
- } else {
+ } else {
|
- | 641 |
+ 642 |
! |
- as.vector(merged$anl_input_r()$columns_source$col_facet)
+ "<lf<t>ip>"
|
- | 642 |
- |
-
- }
- |
-
-
| 643 |
- ! |
+ |
- alpha <- input$alpha
+ }
|
| 644 |
! |
- size <- input$size
+ DT::datatable(summary, rownames = FALSE, options = list(dom = dom_opts, pageLength = dt_rows))
|
| 645 |
! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels
+ } else if (inherits(x, "Date") || inherits(x, "POSIXct") || inherits(x, "POSIXlt")) {
|
| 646 |
! |
- add_density <- input$add_density
+ summary <-
|
| 647 |
! |
- ggtheme <- input$ggtheme
+ data.frame(
|
| 648 |
! |
- rug_plot <- input$rug_plot
+ Statistic = c("min", "median", "max"),
|
| 649 |
! |
- color <- input$color
+ Value = c(
|
| 650 |
! |
- shape <- `if`(is.null(input$shape) || identical(input$shape, ""), "circle", input$shape)
+ min(x, na.rm = TRUE),
|
| 651 |
! |
- smoothing_degree <- as.integer(input$smoothing_degree)
+ stats::median(x, na.rm = TRUE),
|
| 652 |
! |
- ci <- input$ci
+ max(x, na.rm = TRUE)
|
| 653 |
|
-
+ )
|
-
+
| 654 |
- ! |
+ |
- log_x <- input$log_x
+ )
|
| 655 |
! |
- log_y <- input$log_y
+ DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows))
|
| 656 |
|
-
+ } else {
|
| 657 |
! |
- validate(need(
+ NULL
|
-
+
| 658 |
- ! |
+ |
- length(row_facet_name) == 0 || inherits(ANL[[row_facet_name]], c("character", "factor", "Date", "integer")),
+ }
|
-
+
| 659 |
- ! |
+ |
- "`Row facetting` variable must be of class `character`, `factor`, `Date`, or `integer`"
+ }
|
| 660 |
|
- ))
+
|
-
+
| 661 |
- ! |
+ |
- validate(need(
+ #' Plot variable
|
-
+
| 662 |
- ! |
+ |
- length(col_facet_name) == 0 || inherits(ANL[[col_facet_name]], c("character", "factor", "Date", "integer")),
+ #'
|
-
+
| 663 |
- ! |
+ |
- "`Column facetting` variable must be of class `character`, `factor`, `Date`, or `integer`"
+ #' Creates summary plot with statistics relevant to data type.
|
| 664 |
|
- ))
+ #'
|
| 665 |
|
-
+ #' @inheritParams shared_params
|
-
+
| 666 |
- ! |
+ |
- if (add_density && length(color_by_var) > 0) {
+ #' @param var vector of any type to be plotted. For numeric variables it produces histogram with
|
-
+
| 667 |
- ! |
+ |
- validate(need(
+ #' density line, for factors it creates frequency plot
|
-
+
| 668 |
- ! |
+ |
- !is.numeric(ANL[[color_by_var]]),
+ #' @param var_lab text describing selected variable to be displayed on the plot
|
-
+
| 669 |
- ! |
+ |
- "Marginal plots cannot be produced when the points are colored by numeric variables.
+ #' @param wrap_character (`numeric`) number of characters at which to wrap text values of `var`
|
-
+
| 670 |
- ! |
+ |
- \n Uncheck the 'Add marginal density' checkbox to display the plot."
+ #' @param numeric_as_factor (`logical`) should the numeric variable be treated as a factor
|
| 671 |
|
- ))
+ #' @param display_density (`logical`) should density estimation be displayed for numeric values
|
-
+
| 672 |
- ! |
+ |
- validate(need(
+ #' @param remove_NA_hist (`logical`) should `NA` values be removed for histogram of factor like variables
|
| 673 |
|
- !(
+ #' @param outlier_definition if 0 no outliers are removed, otherwise
|
-
+
| 674 |
- ! |
+ |
- inherits(ANL[[color_by_var]], "Date") ||
+ #' outliers (those more than outlier_definition*IQR below/above Q1/Q3 be removed)
|
-
+
| 675 |
- ! |
+ |
- inherits(ANL[[color_by_var]], "POSIXct") ||
+ #' @param records_for_factor (`numeric`) if the number of factor levels is >= than this value then
|
-
+
| 676 |
- ! |
+ |
- inherits(ANL[[color_by_var]], "POSIXlt")
+ #' a graph of the factors isn't shown, only a list of values
|
| 677 |
|
- ),
+ #'
|
-
+
| 678 |
- ! |
+ |
- "Marginal plots cannot be produced when the points are colored by Date or POSIX variables.
+ #' @return plot
|
-
+
| 679 |
- ! |
+ |
- \n Uncheck the 'Add marginal density' checkbox to display the plot."
+ #' @keywords internal
|
| 680 |
|
- ))
+ plot_var_summary <- function(var,
|
| 681 |
|
- }
+ var_lab,
|
| 682 |
|
-
+ wrap_character = NULL,
|
-
+
| 683 |
- ! |
+ |
- teal::validate_has_data(ANL[, c(x_var, y_var)], 10, complete = TRUE, allow_inf = FALSE)
+ numeric_as_factor,
|
| 684 |
|
-
+ display_density = is.numeric(var),
|
-
+
| 685 |
- ! |
+ |
- if (log_x) {
+ remove_NA_hist = FALSE, # nolint: object_name.
|
-
+
| 686 |
- ! |
+ |
- validate(
+ outlier_definition,
|
-
+
| 687 |
- ! |
+ |
- need(
+ records_for_factor,
|
-
+
| 688 |
- ! |
+ |
- is.numeric(ANL[[x_var]]) && all(
+ ggplot2_args) {
|
| 689 |
! |
- ANL[[x_var]] > 0 | is.na(ANL[[x_var]])
+ checkmate::assert_character(var_lab)
|
-
+
| 690 |
- |
+ ! |
- ),
+ checkmate::assert_numeric(wrap_character, null.ok = TRUE)
|
| 691 |
! |
- "X variable can only be log transformed if variable is numeric and all values are positive."
+ checkmate::assert_flag(numeric_as_factor)
|
-
+
| 692 |
- |
+ ! |
- )
+ checkmate::assert_flag(display_density)
|
-
+
| 693 |
- |
+ ! |
- )
+ checkmate::assert_logical(remove_NA_hist, null.ok = TRUE)
|
-
+
| 694 |
- |
+ ! |
- }
+ checkmate::assert_number(outlier_definition, lower = 0, finite = TRUE)
|
| 695 |
! |
- if (log_y) {
+ checkmate::assert_integerish(records_for_factor, lower = 0, len = 1, any.missing = FALSE)
|
| 696 |
! |
- validate(
+ checkmate::assert_class(ggplot2_args, "ggplot2_args")
|
-
+
| 697 |
- ! |
+ |
- need(
+
|
| 698 |
! |
- is.numeric(ANL[[y_var]]) && all(
+ grid::grid.newpage()
|
-
+
| 699 |
- ! |
+ |
- ANL[[y_var]] > 0 | is.na(ANL[[y_var]])
+
|
-
+
| 700 |
- |
+ ! |
- ),
+ plot_main <- if (is.factor(var) || is.character(var) || is.logical(var)) {
|
| 701 |
! |
- "Y variable can only be log transformed if variable is numeric and all values are positive."
+ groups <- unique(as.character(var))
|
-
+
| 702 |
- |
+ ! |
- )
+ len_groups <- length(groups)
|
-
+
| 703 |
- |
+ ! |
- )
+ if (len_groups >= records_for_factor) {
|
-
+
| 704 |
- |
+ ! |
- }
+ grid::textGrob(
|
-
+
| 705 |
- |
+ ! |
-
+ sprintf(
|
| 706 |
! |
- facet_cl <- facet_ggplot_call(
+ "%s unique values\n%s:\n %s\n ...\n %s",
|
| 707 |
! |
- row_facet_name,
+ len_groups,
|
| 708 |
! |
- col_facet_name,
+ var_lab,
|
| 709 |
! |
- free_x_scales = isTRUE(input$free_scales),
+ paste(utils::head(groups), collapse = ",\n "),
|
| 710 |
! |
- free_y_scales = isTRUE(input$free_scales)
+ paste(utils::tail(groups), collapse = ",\n ")
|
| 711 |
|
- )
+ ),
|
-
+
| 712 |
- |
+ ! |
-
+ x = grid::unit(1, "line"),
|
| 713 |
! |
- point_sizes <- if (length(size_by_var) > 0) {
+ y = grid::unit(1, "npc") - grid::unit(1, "line"),
|
| 714 |
! |
- validate(need(is.numeric(ANL[[size_by_var]]), "Variable to size by must be numeric"))
+ just = c("left", "top")
|
-
+
| 715 |
- ! |
+ |
- substitute(
+ )
|
-
+
| 716 |
- ! |
+ |
- expr = size * ANL[[size_by_var]] / max(ANL[[size_by_var]], na.rm = TRUE),
+ } else {
|
| 717 |
! |
- env = list(size = size, size_by_var = size_by_var)
+ if (!is.null(wrap_character)) {
|
-
+
| 718 |
- |
+ ! |
- )
+ var <- stringr::str_wrap(var, width = wrap_character)
|
| 719 |
|
- } else {
+ }
|
| 720 |
! |
- size
+ var <- if (isTRUE(remove_NA_hist)) as.vector(stats::na.omit(var)) else var
|
-
+
| 721 |
- |
+ ! |
- }
+ ggplot(data.frame(var), aes(x = forcats::fct_infreq(as.factor(var)))) +
|
-
+
| 722 |
- |
+ ! |
-
+ geom_bar(
|
| 723 |
! |
- plot_q <- merged$anl_q_r()
+ stat = "count", aes(fill = ifelse(is.na(var), "withcolor", "")), show.legend = FALSE
|
| 724 |
|
-
+ ) +
|
| 725 |
! |
- if (log_x) {
+ scale_fill_manual(values = c("gray50", "tan"))
|
-
+
| 726 |
- ! |
+ |
- log_x_fn <- input$log_x_base
+ }
|
| 727 |
! |
- plot_q <- teal.code::eval_code(
+ } else if (is.numeric(var)) {
|
| 728 |
! |
- object = plot_q,
+ validate(need(any(!is.na(var)), "No data left to visualize."))
|
-
+
| 729 |
- ! |
+ |
- code = substitute(
+
|
-
+
| 730 |
- ! |
+ |
- expr = ANL[, log_x_var] <- log_x_fn(ANL[, x_var]),
+ # Filter out NA
|
| 731 |
! |
- env = list(
+ var <- var[which(!is.na(var))]
|
-
+
| 732 |
- ! |
+ |
- x_var = x_var,
+
|
| 733 |
! |
- log_x_fn = as.name(log_x_fn),
+ validate(need(!any(is.infinite(var)), "Cannot display graph when data includes infinite values"))
|
-
+
| 734 |
- ! |
+ |
- log_x_var = paste0(log_x_fn, "_", x_var)
+
|
-
+
| 735 |
- |
+ ! |
- )
+ if (numeric_as_factor) {
|
-
+
| 736 |
- |
+ ! |
- )
+ var <- factor(var)
|
-
+
| 737 |
- |
+ ! |
- )
+ ggplot(NULL, aes(x = var)) +
|
-
+
| 738 |
- |
+ ! |
- }
+ geom_histogram(stat = "count")
|
| 739 |
|
-
+ } else {
|
-
+
| 740 |
- ! |
+ |
- if (log_y) {
+ # remove outliers
|
| 741 |
! |
- log_y_fn <- input$log_y_base
+ if (outlier_definition != 0) {
|
| 742 |
! |
- plot_q <- teal.code::eval_code(
+ number_records <- length(var)
|
| 743 |
! |
- object = plot_q,
+ var <- remove_outliers_from(var, outlier_definition)
|
| 744 |
! |
- code = substitute(
+ number_outliers <- number_records - length(var)
|
| 745 |
! |
- expr = ANL[, log_y_var] <- log_y_fn(ANL[, y_var]),
+ outlier_text <- paste0(
|
| 746 |
! |
- env = list(
+ number_outliers, " outliers (",
|
| 747 |
! |
- y_var = y_var,
+ round(number_outliers / number_records * 100, 2),
|
| 748 |
! |
- log_y_fn = as.name(log_y_fn),
+ "% of non-missing records) not shown"
|
-
+
| 749 |
- ! |
+ |
- log_y_var = paste0(log_y_fn, "_", y_var)
+ )
|
-
+
| 750 |
- |
+ ! |
- )
+ validate(need(
|
-
+
| 751 |
- |
+ ! |
- )
+ length(var) > 1,
|
-
+
| 752 |
- |
+ ! |
- )
+ "At least two data points must remain after removing outliers for this graph to be displayed"
|
| 753 |
|
- }
+ ))
|
| 754 |
|
-
+ }
|
-
+
| 755 |
- ! |
+ |
- pre_pro_anl <- if (input$show_count) {
+ ## histogram
|
| 756 |
! |
- paste0(
+ binwidth <- get_bin_width(var)
|
| 757 |
! |
- "ANL %>% dplyr::group_by(",
+ p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) +
|
| 758 |
! |
- paste(
+ geom_histogram(binwidth = binwidth) +
|
| 759 |
! |
- c(
+ scale_y_continuous(
|
| 760 |
! |
- if (length(color_by_var) > 0 && inherits(ANL[[color_by_var]], c("factor", "character"))) color_by_var,
+ sec.axis = sec_axis(
|
| 761 |
! |
- row_facet_name,
+ trans = ~ . / nrow(data.frame(var = var)),
|
| 762 |
! |
- col_facet_name
+ labels = scales::percent,
|
-
+
| 763 |
- |
+ ! |
- ),
+ name = "proportion (in %)"
|
-
+
| 764 |
- ! |
+ |
- collapse = ", "
+ )
|
| 765 |
|
- ),
+ )
|
-
+
| 766 |
- ! |
+ |
- ") %>% dplyr::mutate(n = dplyr::n()) %>% dplyr::ungroup()"
+
|
-
+
| 767 |
- |
+ ! |
- )
+ if (display_density) {
|
-
+
| 768 |
- |
+ ! |
- } else {
+ p <- p + geom_density(aes(y = after_stat(count * binwidth)))
|
-
+
| 769 |
- ! |
+ |
- "ANL"
+ }
|
| 770 |
|
- }
+
|
-
+
| 771 |
- |
+ ! |
-
+ if (outlier_definition != 0) {
|
| 772 |
! |
- plot_call <- substitute(expr = pre_pro_anl %>% ggplot(), env = list(pre_pro_anl = str2lang(pre_pro_anl)))
+ p <- p + annotate(
|
-
+
| 773 |
- |
+ ! |
-
+ geom = "text",
|
| 774 |
! |
- plot_call <- if (length(color_by_var) == 0) {
+ label = outlier_text,
|
| 775 |
! |
- substitute(
+ x = Inf, y = Inf,
|
| 776 |
! |
- expr = plot_call +
+ hjust = 1.02, vjust = 1.2,
|
| 777 |
! |
- ggplot2::aes(x = x_name, y = y_name) +
+ color = "black",
|
-
+
| 778 |
- ! |
+ |
- ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value, color = color_value),
+ # explicitly modify geom text size according
|
| 779 |
! |
- env = list(
+ size = ggplot2_args[["theme"]][["text"]][["size"]] / 3.5
|
-
+
| 780 |
- ! |
+ |
- plot_call = plot_call,
+ )
|
-
+
| 781 |
- ! |
+ |
- x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var),
+ }
|
| 782 |
! |
- y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var),
+ p
|
-
+
| 783 |
- ! |
+ |
- alpha_value = alpha,
+ }
|
| 784 |
! |
- point_sizes = point_sizes,
+ } else if (inherits(var, "Date") || inherits(var, "POSIXct") || inherits(var, "POSIXlt")) {
|
| 785 |
! |
- shape_value = shape,
+ var_num <- as.numeric(var)
|
| 786 |
! |
- color_value = color
+ binwidth <- get_bin_width(var_num, 1)
|
-
+
| 787 |
- |
+ ! |
- )
+ p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) +
|
-
+
| 788 |
- |
+ ! |
- )
+ geom_histogram(binwidth = binwidth)
|
| 789 |
|
- } else {
+ } else {
|
| 790 |
! |
- substitute(
+ grid::textGrob(
|
| 791 |
! |
- expr = plot_call +
+ paste(strwrap(
|
| 792 |
! |
- ggplot2::aes(x = x_name, y = y_name, color = color_by_var_name) +
+ utils::capture.output(utils::str(var)),
|
| 793 |
! |
- ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value),
+ width = .9 * grid::convertWidth(grid::unit(1, "npc"), "char", TRUE)
|
| 794 |
! |
- env = list(
+ ), collapse = "\n"),
|
| 795 |
! |
- plot_call = plot_call,
+ x = grid::unit(1, "line"), y = grid::unit(1, "npc") - grid::unit(1, "line"), just = c("left", "top")
|
-
+
| 796 |
- ! |
+ |
- x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var),
+ )
|
-
+
| 797 |
- ! |
+ |
- y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var),
+ }
|
-
+
| 798 |
- ! |
+ |
- color_by_var_name = as.name(color_by_var),
+
|
| 799 |
! |
- alpha_value = alpha,
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(
|
| 800 |
! |
- point_sizes = point_sizes,
+ labs = list(x = var_lab)
|
-
+
| 801 |
- ! |
+ |
- shape_value = shape
+ )
|
| 802 |
|
- )
+ ###
|
-
+
| 803 |
- |
+ ! |
- )
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
|
-
+
| 804 |
- |
+ ! |
- }
+ ggplot2_args,
|
-
+
| 805 |
- |
+ ! |
-
+ module_plot = dev_ggplot2_args
|
-
+
| 806 |
- ! |
+ |
- if (rug_plot) plot_call <- substitute(expr = plot_call + geom_rug(), env = list(plot_call = plot_call))
+ )
|
@@ -14937,973 +14972,973 @@ teal.modules.general coverage - 3.44%
808 |
! |
- plot_label_generator <- function(rhs_formula = quote(y ~ 1),
+ if (is.ggplot(plot_main)) {
|
| 809 |
! |
- show_form = input$show_form,
+ if (is.numeric(var) && !numeric_as_factor) {
|
-
+
| 810 |
- ! |
+ |
- show_r2 = input$show_r2,
+ # numeric not as factor
|
| 811 |
! |
- show_count = input$show_count,
+ plot_main <- plot_main +
|
| 812 |
! |
- pos = input$pos,
+ theme_light() +
|
| 813 |
! |
- label_size = input$label_size) {
+ list(
|
| 814 |
! |
- stopifnot(sum(show_form, show_r2, show_count) >= 1)
+ labs = do.call("labs", all_ggplot2_args$labs),
|
| 815 |
! |
- aes_label <- paste0(
+ theme = do.call("theme", all_ggplot2_args$theme)
|
-
+
| 816 |
- ! |
+ |
- "aes(",
+ )
|
-
+
| 817 |
- ! |
+ |
- if (show_count) "n = n, ",
+ } else {
|
-
+
| 818 |
- ! |
+ |
- "label = ",
+ # factor low number of levels OR numeric as factor OR Date
|
| 819 |
! |
- if (sum(show_form, show_r2, show_count) > 1) "paste(",
+ plot_main <- plot_main +
|
| 820 |
! |
- paste(
+ theme_light() +
|
| 821 |
! |
- c(
+ list(
|
| 822 |
! |
- if (show_form) "stat(eq.label)",
+ labs = do.call("labs", all_ggplot2_args$labs),
|
| 823 |
! |
- if (show_r2) "stat(adj.rr.label)",
+ theme = do.call("theme", all_ggplot2_args$theme)
|
-
+
| 824 |
- ! |
+ |
- if (show_count) "paste('N ~`=`~', n)"
+ )
|
| 825 |
|
- ),
+ }
|
| 826 |
! |
- collapse = ", "
+ plot_main <- ggplotGrob(plot_main)
|
| 827 |
|
- ),
+ }
|
-
+
| 828 |
- ! |
+ |
- if (sum(show_form, show_r2, show_count) > 1) ", sep = '*\", \"*'))" else ")"
+
|
-
+
| 829 |
- |
+ ! |
- )
+ grid::grid.draw(plot_main)
|
| 830 |
! |
- label_geom <- substitute(
+ plot_main
|
-
+
| 831 |
- ! |
+ |
- expr = ggpmisc::stat_poly_eq(
+ }
|
-
+
| 832 |
- ! |
+ |
- mapping = aes_label,
+
|
-
+
| 833 |
- ! |
+ |
- formula = rhs_formula,
+ is_num_var_short <- function(.unique_records_for_factor, input, data_for_analysis) {
|
| 834 |
! |
- parse = TRUE,
+ length(unique(data_for_analysis()$data)) < .unique_records_for_factor && !is.null(input$numeric_as_factor)
|
-
+
| 835 |
- ! |
+ |
- label.x = pos,
+ }
|
-
+
| 836 |
- ! |
+ |
- size = label_size
+
|
| 837 |
|
- ),
+ #' Validates the variable browser inputs
|
-
+
| 838 |
- ! |
+ |
- env = list(
+ #'
|
-
+
| 839 |
- ! |
+ |
- rhs_formula = rhs_formula,
+ #' @param input (`session$input`) the `shiny` session input
|
-
+
| 840 |
- ! |
+ |
- pos = pos,
+ #' @param plot_var (`list`) list of a data frame and an array of variable names
|
-
+
| 841 |
- ! |
+ |
- aes_label = str2lang(aes_label),
+ #' @param data (`teal_data`) the datasets passed to the module
|
-
+
| 842 |
- ! |
+ |
- label_size = label_size
+ #'
|
| 843 |
|
- )
+ #' @returns `logical` TRUE if validations pass; a `shiny` validation error otherwise
|
| 844 |
|
- )
+ #' @keywords internal
|
-
+
| 845 |
- ! |
+ |
- substitute(
+ validate_input <- function(input, plot_var, data) {
|
| 846 |
! |
- expr = plot_call + label_geom,
+ reactive({
|
| 847 |
! |
- env = list(
+ dataset_name <- req(input$tabset_panel)
|
| 848 |
! |
- plot_call = plot_call,
+ varname <- plot_var$variable[[dataset_name]]
|
-
+
| 849 |
- ! |
+ |
- label_geom = label_geom
+
|
-
+
| 850 |
- |
+ ! |
- )
+ validate(need(dataset_name, "No data selected"))
|
-
+
| 851 |
- |
+ ! |
- )
+ validate(need(varname, "No variable selected"))
|
-
+
| 852 |
- |
+ ! |
- }
+ df <- data()[[dataset_name]]
|
-
+
| 853 |
- |
+ ! |
-
+ teal::validate_has_data(df, 1)
|
| 854 |
! |
- if (trend_line_is_applicable()) {
+ teal::validate_has_variable(varname = varname, data = df, "Variable not available")
|
-
+
| 855 |
- ! |
+ |
- shinyjs::hide("line_msg")
+
|
| 856 |
! |
- shinyjs::show("smoothing_degree")
+ TRUE
|
-
+
| 857 |
- ! |
+ |
- if (!add_trend_line()) {
+ })
|
-
+
| 858 |
- ! |
+ |
- shinyjs::hide("ci")
+ }
|
-
+
| 859 |
- ! |
+ |
- shinyjs::hide("color_sub")
+
|
-
+
| 860 |
- ! |
+ |
- shinyjs::hide("show_form")
+ get_plotted_data <- function(input, plot_var, data) {
|
| 861 |
! |
- shinyjs::hide("show_r2")
+ dataset_name <- input$tabset_panel
|
| 862 |
! |
- if (input$show_count) {
+ varname <- plot_var$variable[[dataset_name]]
|
| 863 |
! |
- plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE)
+ df <- data()[[dataset_name]]
|
-
+
| 864 |
- ! |
+ |
- shinyjs::show("label_pos")
+
|
| 865 |
! |
- shinyjs::show("label_size")
+ var_description <- teal.data::col_labels(df)[[varname]]
|
-
+
| 866 |
- |
+ ! |
- } else {
+ list(data = df[[varname]], var_description = var_description)
|
-
+
| 867 |
- ! |
+ |
- shinyjs::hide("label_pos")
+ }
|
-
+
| 868 |
- ! |
+ |
- shinyjs::hide("label_size")
+
|
| 869 |
|
- }
+ #' Renders the left-hand side `tabset` panel of the module
|
| 870 |
|
- } else {
+ #'
|
-
+
| 871 |
- ! |
+ |
- shinyjs::show("ci")
+ #' @param datanames (`character`) the name of the dataset
|
-
+
| 872 |
- ! |
+ |
- shinyjs::show("show_form")
+ #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from
|
-
+
| 873 |
- ! |
+ |
- shinyjs::show("show_r2")
+ #' @param data (`teal_data`) the object containing all datasets
|
-
+
| 874 |
- ! |
+ |
- if (nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)])) > 0) {
+ #' @param input (`session$input`) the `shiny` session input
|
-
+
| 875 |
- ! |
+ |
- plot_q <- teal.code::eval_code(
+ #' @param output (`session$output`) the `shiny` session output
|
-
+
| 876 |
- ! |
+ |
- plot_q,
+ #' @param columns_names (`environment`) the environment containing bindings for each dataset
|
-
+
| 877 |
- ! |
+ |
- substitute(
+ #' @param plot_var (`list`) the list containing the currently selected dataset (tab) and its column names
|
-
+
| 878 |
- ! |
+ |
- expr = ANL <- dplyr::filter(ANL, !is.na(x_var) & !is.na(y_var)),
+ #' @keywords internal
|
-
+
| 879 |
- ! |
+ |
- env = list(x_var = as.name(x_var), y_var = as.name(y_var))
+ render_tabset_panel_content <- function(datanames, parent_dataname, output, data, input, columns_names, plot_var) {
|
-
+
| 880 |
- |
+ ! |
- )
+ lapply(datanames, render_single_tab,
|
-
+
| 881 |
- |
+ ! |
- )
+ input = input,
|
-
+
| 882 |
- |
+ ! |
- }
+ output = output,
|
| 883 |
! |
- rhs_formula <- substitute(
+ data = data,
|
| 884 |
! |
- expr = y ~ poly(x, smoothing_degree, raw = TRUE),
+ parent_dataname = parent_dataname,
|
| 885 |
! |
- env = list(smoothing_degree = smoothing_degree)
+ columns_names = columns_names,
|
-
+
| 886 |
- |
+ ! |
- )
+ plot_var = plot_var
|
-
+
| 887 |
- ! |
+ |
- if (input$show_form || input$show_r2 || input$show_count) {
+ )
|
-
+
| 888 |
- ! |
+ |
- plot_call <- plot_label_generator(rhs_formula = rhs_formula)
+ }
|
-
+
| 889 |
- ! |
+ |
- shinyjs::show("label_pos")
+
|
-
+
| 890 |
- ! |
+ |
- shinyjs::show("label_size")
+ #' Renders a single tab in the left-hand side tabset panel
|
| 891 |
|
- } else {
+ #'
|
-
+
| 892 |
- ! |
+ |
- shinyjs::hide("label_pos")
+ #' Renders a single tab in the left-hand side tabset panel. The rendered tab contains
|
-
+
| 893 |
- ! |
+ |
- shinyjs::hide("label_size")
+ #' information about one dataset out of many presented in the module.
|
| 894 |
|
- }
+ #'
|
-
+
| 895 |
- ! |
+ |
- plot_call <- substitute(
+ #' @param dataset_name (`character`) the name of the dataset contained in the rendered tab
|
-
+
| 896 |
- ! |
+ |
- expr = plot_call + ggplot2::geom_smooth(formula = rhs_formula, se = TRUE, level = ci, method = "lm"),
+ #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from
|
-
+
| 897 |
- ! |
+ |
- env = list(plot_call = plot_call, rhs_formula = rhs_formula, ci = ci)
+ #' @inheritParams render_tabset_panel_content
|
| 898 |
|
- )
+ #' @keywords internal
|
| 899 |
|
- }
+ render_single_tab <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
|
-
+
| 900 |
- |
+ ! |
- } else {
+ render_tab_header(dataset_name, output, data)
|
-
+
| 901 |
- ! |
+ |
- shinyjs::hide("smoothing_degree")
+
|
| 902 |
! |
- shinyjs::hide("ci")
+ render_tab_table(
|
| 903 |
! |
- shinyjs::hide("color_sub")
+ dataset_name = dataset_name,
|
| 904 |
! |
- shinyjs::hide("show_form")
+ parent_dataname = parent_dataname,
|
| 905 |
! |
- shinyjs::hide("show_r2")
+ output = output,
|
| 906 |
! |
- if (input$show_count) {
+ data = data,
|
| 907 |
! |
- plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE)
+ input = input,
|
| 908 |
! |
- shinyjs::show("label_pos")
+ columns_names = columns_names,
|
| 909 |
! |
- shinyjs::show("label_size")
+ plot_var = plot_var
|
| 910 |
|
- } else {
+ )
|
-
+
| 911 |
- ! |
+ |
- shinyjs::hide("label_pos")
+ }
|
-
+
| 912 |
- ! |
+ |
- shinyjs::hide("label_size")
+
|
| 913 |
|
- }
+ #' Renders the text headlining a single tab in the left-hand side tabset panel
|
-
+
| 914 |
- ! |
+ |
- shinyjs::show("line_msg")
+ #'
|
| 915 |
|
- }
+ #' @param dataset_name (`character`) the name of the dataset of the tab
|
| 916 |
|
-
+ #' @inheritParams render_tabset_panel_content
|
-
+
| 917 |
- ! |
+ |
- if (!is.null(facet_cl)) {
+ #' @keywords internal
|
-
+
| 918 |
- ! |
+ |
- plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))
+ render_tab_header <- function(dataset_name, output, data) {
|
-
+
| 919 |
- |
+ ! |
- }
+ dataset_ui_id <- paste0("dataset_summary_", dataset_name)
|
-
+
| 920 |
- |
+ ! |
-
+ output[[dataset_ui_id]] <- renderText({
|
| 921 |
! |
- y_label <- varname_w_label(
+ df <- data()[[dataset_name]]
|
| 922 |
! |
- y_var,
+ join_keys <- teal.data::join_keys(data())
|
| 923 |
! |
- ANL,
+ if (!is.null(join_keys)) {
|
| 924 |
! |
- prefix = if (log_y) paste(log_y_fn, "(") else NULL,
+ key <- teal.data::join_keys(data())[dataset_name, dataset_name]
|
-
+
| 925 |
- ! |
+ |
- suffix = if (log_y) ")" else NULL
+ } else {
|
-
+
| 926 |
- |
+ ! |
- )
+ key <- NULL
|
-
+
| 927 |
- ! |
+ |
- x_label <- varname_w_label(
+ }
|
| 928 |
! |
- x_var,
+ sprintf(
|
| 929 |
! |
- ANL,
+ "Dataset with %s unique key rows and %s variables",
|
| 930 |
! |
- prefix = if (log_x) paste(log_x_fn, "(") else NULL,
+ nrow(unique(`if`(length(key) > 0, df[, key, drop = FALSE], df))),
|
| 931 |
! |
- suffix = if (log_x) ")" else NULL
+ ncol(df)
|
| 932 |
|
- )
+ )
|
| 933 |
|
-
+ })
|
-
+
| 934 |
- ! |
+ |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(
+ }
|
-
+
| 935 |
- ! |
+ |
- labs = list(y = y_label, x = x_label),
+
|
-
+
| 936 |
- ! |
+ |
- theme = list(legend.position = "bottom")
+ #' Renders the table for a single dataset in the left-hand side tabset panel
|
| 937 |
|
- )
+ #'
|
| 938 |
|
-
+ #' The table contains column names, column labels,
|
-
+
| 939 |
- ! |
+ |
- if (rotate_xaxis_labels) {
+ #' small summary about NA values and `sparkline` (if appropriate).
|
-
+
| 940 |
- ! |
+ |
- dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1))
+ #'
|
| 941 |
|
- }
+ #' @param dataset_name (`character`) the name of the dataset
|
| 942 |
|
-
+ #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from
|
-
+
| 943 |
- ! |
+ |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
+ #' @inheritParams render_tabset_panel_content
|
-
+
| 944 |
- ! |
+ |
- user_plot = ggplot2_args,
+ #' @keywords internal
|
-
+
| 945 |
- ! |
+ |
- module_plot = dev_ggplot2_args
+ render_tab_table <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
|
-
+
| 946 |
- |
+ ! |
- )
+ table_ui_id <- paste0("variable_browser_", dataset_name)
|
@@ -15917,14 +15952,14 @@ teal.modules.general coverage - 3.44%
948 |
! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = ggtheme)
+ output[[table_ui_id]] <- DT::renderDataTable({
|
-
+
| 949 |
- |
+ ! |
-
+ df <- data()[[dataset_name]]
|
@@ -15938,203 +15973,203 @@ teal.modules.general coverage - 3.44%
951 |
! |
- if (add_density) {
+ get_vars_df <- function(input, dataset_name, parent_name, data) {
|
| 952 |
! |
- plot_call <- substitute(
+ data_cols <- colnames(df)
|
| 953 |
! |
- expr = ggExtra::ggMarginal(
+ if (isTRUE(input$show_parent_vars)) {
|
| 954 |
! |
- plot_call + labs + ggthemes + themes,
+ data_cols
|
| 955 |
! |
- type = "density",
+ } else if (dataset_name != parent_name && parent_name %in% names(data)) {
|
| 956 |
! |
- groupColour = group_colour
+ setdiff(data_cols, colnames(data()[[parent_name]]))
|
| 957 |
|
- ),
+ } else {
|
| 958 |
! |
- env = list(
+ data_cols
|
-
+
| 959 |
- ! |
+ |
- plot_call = plot_call,
+ }
|
-
+
| 960 |
- ! |
+ |
- group_colour = if (length(color_by_var) > 0) TRUE else FALSE,
+ }
|
-
+
| 961 |
- ! |
+ |
- labs = parsed_ggplot2_args$labs,
+
|
| 962 |
! |
- ggthemes = parsed_ggplot2_args$ggtheme,
+ if (length(parent_dataname) > 0) {
|
| 963 |
! |
- themes = parsed_ggplot2_args$theme
+ df_vars <- get_vars_df(input, dataset_name, parent_dataname, data)
|
-
+
| 964 |
- |
+ ! |
- )
+ df <- df[df_vars]
|
| 965 |
|
- )
+ }
|
| 966 |
|
- } else {
+
|
| 967 |
! |
- plot_call <- substitute(
+ if (is.null(df) || ncol(df) == 0) {
|
| 968 |
! |
- expr = plot_call +
+ columns_names[[dataset_name]] <- character(0)
|
| 969 |
! |
- labs +
+ df_output <- data.frame(
|
| 970 |
! |
- ggthemes +
+ Type = character(0),
|
| 971 |
! |
- themes,
+ Variable = character(0),
|
| 972 |
! |
- env = list(
+ Label = character(0),
|
| 973 |
! |
- plot_call = plot_call,
+ Missings = character(0),
|
| 974 |
! |
- labs = parsed_ggplot2_args$labs,
+ Sparklines = character(0),
|
| 975 |
! |
- ggthemes = parsed_ggplot2_args$ggtheme,
+ stringsAsFactors = FALSE
|
-
+
| 976 |
- ! |
+ |
- themes = parsed_ggplot2_args$theme
+ )
|
| 977 |
|
- )
+ } else {
|
| 978 |
|
- )
+ # extract data variable labels
|
-
+
| 979 |
- |
+ ! |
- }
+ labels <- teal.data::col_labels(df)
|
@@ -16148,7 +16183,7 @@ teal.modules.general coverage - 3.44%
981 |
! |
- plot_call <- substitute(expr = p <- plot_call, env = list(plot_call = plot_call))
+ columns_names[[dataset_name]] <- names(labels)
|
@@ -16158,340 +16193,340 @@ teal.modules.general coverage - 3.44%
-
+
| 983 |
- ! |
+ |
- teal.code::eval_code(plot_q, plot_call) %>%
+ # calculate number of missing values
|
| 984 |
! |
- teal.code::eval_code(quote(print(p)))
+ missings <- vapply(
|
-
+
| 985 |
- |
+ ! |
- })
+ df,
|
-
+
| 986 |
- |
+ ! |
-
+ var_missings_info,
|
| 987 |
! |
- plot_r <- reactive(output_q()[["p"]])
+ FUN.VALUE = character(1),
|
-
+
| 988 |
- |
+ ! |
-
+ USE.NAMES = FALSE
|
| 989 |
|
- # Insert the plot into a plot_with_settings module from teal.widgets
+ )
|
-
+
| 990 |
- ! |
+ |
- pws <- teal.widgets::plot_with_settings_srv(
+
|
-
+
| 991 |
- ! |
+ |
- id = "scatter_plot",
+ # get icons proper for the data types
|
| 992 |
! |
- plot_r = plot_r,
+ icons <- vapply(df, function(x) class(x)[1L], character(1L))
|
-
+
| 993 |
- ! |
+ |
- height = plot_height,
+
|
| 994 |
! |
- width = plot_width,
+ join_keys <- teal.data::join_keys(data())
|
| 995 |
! |
- brushing = TRUE
+ if (!is.null(join_keys)) {
|
-
+
| 996 |
- |
+ ! |
- )
+ icons[intersect(join_keys[dataset_name, dataset_name], colnames(df))] <- "primary_key"
|
| 997 |
|
-
+ }
|
| 998 |
! |
- output$data_table <- DT::renderDataTable({
+ icons <- variable_type_icons(icons)
|
-
+
| 999 |
- ! |
+ |
- plot_brush <- pws$brush()
+
|
| 1000 |
|
-
+ # generate sparklines
|
| 1001 |
! |
- if (!is.null(plot_brush)) {
+ sparklines_html <- vapply(
|
| 1002 |
! |
- validate(need(!input$add_density, "Brushing feature is currently not supported when plot has marginal density"))
+ df,
|
-
+
| 1003 |
- |
+ ! |
- }
+ create_sparklines,
|
-
+
| 1004 |
- |
+ ! |
-
+ FUN.VALUE = character(1),
|
| 1005 |
! |
- merged_data <- isolate(teal.code::dev_suppress(output_q()[["ANL"]]))
+ USE.NAMES = FALSE
|
| 1006 |
|
-
+ )
|
-
+
| 1007 |
- ! |
+ |
- brushed_df <- teal.widgets::clean_brushedPoints(merged_data, plot_brush)
+
|
| 1008 |
! |
- numeric_cols <- names(brushed_df)[
+ df_output <- data.frame(
|
| 1009 |
! |
- vapply(brushed_df, function(x) is.numeric(x) && !is.integer(x), FUN.VALUE = logical(1))
+ Type = icons,
|
-
+
| 1010 |
- |
+ ! |
- ]
+ Variable = names(labels),
|
-
+
| 1011 |
- |
+ ! |
-
+ Label = labels,
|
| 1012 |
! |
- if (length(numeric_cols) > 0) {
+ Missings = missings,
|
| 1013 |
! |
- DT::formatRound(
+ Sparklines = sparklines_html,
|
| 1014 |
! |
- DT::datatable(brushed_df,
+ stringsAsFactors = FALSE
|
-
+
| 1015 |
- ! |
+ |
- rownames = FALSE,
+ )
|
-
+
| 1016 |
- ! |
+ |
- options = list(scrollX = TRUE, pageLength = input$data_table_rows)
+ }
|
| 1017 |
|
- ),
+
|
-
+
| 1018 |
- ! |
+ |
- numeric_cols,
+ # Select row 1 as default / fallback
|
| 1019 |
! |
- table_dec
+ selected_ix <- 1
|
| 1020 |
|
- )
+ # Define starting page index (base-0 index of the first item on page
|
| 1021 |
|
- } else {
+ # note: in many cases it's not the item itself
|
| 1022 |
! |
- DT::datatable(brushed_df, rownames = FALSE, options = list(scrollX = TRUE, pageLength = input$data_table_rows))
+ selected_page_ix <- 0
|
| 1023 |
|
- }
+
|
| 1024 |
|
- })
+ # Retrieve current selected variable if any
|
-
+
| 1025 |
- |
+ ! |
-
+ isolated_variable <- isolate(plot_var$variable[[dataset_name]])
|
-
+
| 1026 |
- ! |
+ |
- teal.widgets::verbatim_popup_srv(
+
|
| 1027 |
! |
- id = "rcode",
+ if (!is.null(isolated_variable)) {
|
| 1028 |
! |
- verbatim_content = reactive(teal.code::get_code(output_q())),
+ index <- which(columns_names[[dataset_name]] == isolated_variable)[1]
|
| 1029 |
! |
- title = "R Code for scatterplot"
+ if (!is.null(index) && !is.na(index) && length(index) > 0) selected_ix <- index
|
| 1030 |
|
- )
+ }
|
@@ -16505,25515 +16540,25704 @@ teal.modules.general coverage - 3.44%
1032 |
|
- ### REPORTER
+ # Retrieve the index of the first item of the current page
|
-
+
| 1033 |
- ! |
+ |
- if (with_reporter) {
+ # it works with varying number of entries on the page (10, 25, ...)
|
| 1034 |
! |
- card_fun <- function(comment, label) {
+ table_id_sel <- paste0("variable_browser_", dataset_name, "_state")
|
| 1035 |
! |
- card <- teal::report_card_template(
+ dt_state <- isolate(input[[table_id_sel]])
|
| 1036 |
! |
- title = "Scatter Plot",
+ if (selected_ix != 1 && !is.null(dt_state)) {
|
| 1037 |
! |
- label = label,
+ selected_page_ix <- floor(selected_ix / dt_state$length) * dt_state$length
|
-
+
| 1038 |
- ! |
+ |
- with_filter = with_filter,
+ }
|
-
+
| 1039 |
- ! |
+ |
- filter_panel_api = filter_panel_api
+
|
-
+
| 1040 |
- |
+ ! |
- )
+ DT::datatable(
|
| 1041 |
! |
- card$append_text("Plot", "header3")
+ df_output,
|
| 1042 |
! |
- card$append_plot(plot_r(), dim = pws$dim())
+ escape = FALSE,
|
| 1043 |
! |
- if (!comment == "") {
+ rownames = FALSE,
|
| 1044 |
! |
- card$append_text("Comment", "header3")
+ selection = list(mode = "single", target = "row", selected = selected_ix),
|
| 1045 |
! |
- card$append_text(comment)
+ options = list(
|
-
+
| 1046 |
- |
+ ! |
- }
+ fnDrawCallback = htmlwidgets::JS("function() { HTMLWidgets.staticRender(); }"),
|
| 1047 |
! |
- card$append_src(teal.code::get_code(output_q()))
+ pageLength = input[[paste0(table_ui_id, "_rows")]],
|
| 1048 |
! |
- card
+ displayStart = selected_page_ix
|
| 1049 |
|
- }
+ )
|
-
+
| 1050 |
- ! |
+ |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ )
|
| 1051 |
|
- }
+ })
|
| 1052 |
|
- ###
+ }
|
| 1053 |
|
- })
+
|
| 1054 |
|
- }
+ #' Creates observers updating the currently selected column
|
-
-
-
-
-
-
- | 1 |
+ 1055 |
|
- #' `teal` module: Scatterplot and regression analysis
+ #'
|
- | 2 |
+ 1056 |
|
- #'
+ #' The created observers update the column currently selected in the left-hand side
|
- | 3 |
+ 1057 |
|
- #' Module for visualizing regression analysis, including scatterplots and
+ #' tabset panel.
|
- | 4 |
+ 1058 |
|
- #' various regression diagnostics plots.
+ #'
|
- | 5 |
+ 1059 |
|
- #' It allows users to explore the relationship between a set of regressors and a response variable,
+ #' @note
|
- | 6 |
+ 1060 |
|
- #' visualize residuals, and identify outliers.
+ #' Creates an observer for each dataset (each tab in the tabset panel).
|
- | 7 |
+ 1061 |
|
#'
|
- | 8 |
+ 1062 |
|
- #' @note For more examples, please see the vignette "Using regression plots" via
+ #' @inheritParams render_tabset_panel_content
|
- | 9 |
+ 1063 |
|
- #' `vignette("using-regression-plots", package = "teal.modules.general")`.
+ #' @keywords internal
|
- | 10 |
+ 1064 |
|
- #'
+ establish_updating_selection <- function(datanames, input, plot_var, columns_names) {
|
-
- | 11 |
- |
+
+ | 1065 |
+ ! |
- #' @inheritParams teal::module
+ lapply(datanames, function(dataset_name) {
|
-
- | 12 |
- |
+
+ | 1066 |
+ ! |
- #' @inheritParams shared_params
+ table_ui_id <- paste0("variable_browser_", dataset_name)
|
-
- | 13 |
- |
+
+ | 1067 |
+ ! |
- #' @param regressor (`data_extract_spec` or `list` of multiple `data_extract_spec`)
+ table_id_sel <- paste0(table_ui_id, "_rows_selected")
|
-
- | 14 |
- |
+
+ | 1068 |
+ ! |
- #' Regressor variables from an incoming dataset with filtering and selecting.
+ observeEvent(input[[table_id_sel]], {
|
-
- | 15 |
- |
+
+ | 1069 |
+ ! |
- #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`)
+ plot_var$data <- dataset_name
|
-
- | 16 |
- |
+
+ | 1070 |
+ ! |
- #' Response variables from an incoming dataset with filtering and selecting.
+ plot_var$variable[[dataset_name]] <- columns_names[[dataset_name]][input[[table_id_sel]]]
|
- | 17 |
+ 1071 |
|
- #' @param default_outlier_label (`character`) optional, default column selected to label outliers.
+ })
|
- | 18 |
+ 1072 |
|
- #' @param default_plot_type (`numeric`) optional, defaults to "Response vs Regressor".
+ })
|
- | 19 |
+ 1073 |
|
- #' 1. Response vs Regressor
+ }
|
- | 20 |
+ 1074 |
|
- #' 2. Residuals vs Fitted
+
|
- | 21 |
+ 1075 |
|
- #' 3. Normal Q-Q
+ get_bin_width <- function(x_vec, scaling_factor = 2) {
|
-
- | 22 |
- |
+
+ | 1076 |
+ ! |
- #' 4. Scale-Location
+ x_vec <- x_vec[!is.na(x_vec)]
|
-
- | 23 |
- |
+
+ | 1077 |
+ ! |
- #' 5. Cook's distance
+ qntls <- stats::quantile(x_vec, probs = c(0.1, 0.25, 0.75, 0.9), type = 2)
|
-
- | 24 |
- |
+
+ | 1078 |
+ ! |
- #' 6. Residuals vs Leverage
+ iqr <- qntls[3] - qntls[2]
|
-
- | 25 |
- |
+
+ | 1079 |
+ ! |
- #' 7. Cook's dist vs Leverage
+ binwidth <- max(scaling_factor * iqr / length(x_vec) ^ (1 / 3), sqrt(qntls[4] - qntls[1])) # styler: off
|
-
- | 26 |
- |
+
+ | 1080 |
+ ! |
- #' @param label_segment_threshold (`numeric(1)` or `numeric(3)`)
+ binwidth <- ifelse(binwidth == 0, 1, binwidth)
|
- | 27 |
+ 1081 |
|
- #' Minimum distance between label and point on the plot that triggers the creation of
+ # to ensure at least two bins when variable span is very small
|
-
- | 28 |
- |
+
+ | 1082 |
+ ! |
- #' a line segment between the two.
+ x_span <- diff(range(x_vec))
|
-
- | 29 |
- |
+
+ | 1083 |
+ ! |
- #' This may happen when the label cannot be placed next to the point as it overlaps another
+ if (isTRUE(x_span / binwidth >= 2)) binwidth else x_span / 2
|
- | 30 |
+ 1084 |
|
- #' label or point.
+ }
|
- | 31 |
+ 1085 |
|
- #' The value is used as the `min.segment.length` parameter to the [ggrepel::geom_text_repel()] function.
+
|
- | 32 |
+ 1086 |
|
- #'
+ #' Removes the outlier observation from an array
|
- | 33 |
+ 1087 |
|
- #' It can take the following forms:
+ #'
|
- | 34 |
+ 1088 |
|
- #' - `numeric(1)`: Fixed value used for the minimum distance and the slider is not presented in the UI.
+ #' @param var (`numeric`) a numeric vector
|
- | 35 |
+ 1089 |
|
- #' - `numeric(3)`: A slider is presented in the UI (under "Plot settings") to adjust the minimum distance dynamically.
+ #' @param outlier_definition (`numeric`) if `0` then no outliers are removed, otherwise
|
- | 36 |
+ 1090 |
|
- #'
+ #' outliers (those more than `outlier_definition*IQR below/above Q1/Q3`) are removed
|
- | 37 |
+ 1091 |
|
- #' It takes the form of `c(value, min, max)` and it is passed to the `value_min_max`
+ #' @returns (`numeric`) vector without the outlier values
|
- | 38 |
+ 1092 |
|
- #' argument in `teal.widgets::optionalSliderInputValMinMax`.
+ #' @keywords internal
|
- | 39 |
+ 1093 |
|
- #'
+ remove_outliers_from <- function(var, outlier_definition) {
|
-
- | 40 |
- |
+
+ | 1094 |
+ 3x |
- #' @templateVar ggnames `r regression_names`
+ if (outlier_definition == 0) {
|
-
- | 41 |
- |
+
+ | 1095 |
+ 1x |
- #' @template ggplot2_args_multi
+ return(var)
|
- | 42 |
+ 1096 |
|
- #'
+ }
|
-
- | 43 |
- |
+
+ | 1097 |
+ 2x |
- #' @inherit shared_params return
+ q1_q3 <- stats::quantile(var, probs = c(0.25, 0.75), type = 2, na.rm = TRUE)
|
-
- | 44 |
- |
+
+ | 1098 |
+ 2x |
- #'
+ iqr <- q1_q3[2] - q1_q3[1]
|
-
- | 45 |
- |
+
+ | 1099 |
+ 2x |
- #' @examples
+ var[var >= q1_q3[1] - outlier_definition * iqr & var <= q1_q3[2] + outlier_definition * iqr]
|
- | 46 |
+ 1100 |
|
- #' # general data example
+ }
|
- | 47 |
+ 1101 |
|
- #' library(teal.widgets)
+
|
- | 48 |
+ 1102 |
|
- #'
+
|
- | 49 |
+ 1103 |
|
- #' data <- teal_data()
+ # sparklines ----
|
- | 50 |
+ 1104 |
|
- #' data <- within(data, {
+
|
- | 51 |
+ 1105 |
|
- #' require(nestcolor)
+ #' S3 generic for `sparkline` widget HTML
|
- | 52 |
+ 1106 |
|
- #' CO2 <- CO2
+ #'
|
- | 53 |
+ 1107 |
|
- #' })
+ #' Generates the `sparkline` HTML code corresponding to the input array.
|
- | 54 |
+ 1108 |
|
- #' datanames(data) <- c("CO2")
+ #' For numeric variables creates a box plot, for character and factors - bar plot.
|
- | 55 |
+ 1109 |
|
- #'
+ #' Produces an empty string for variables of other types.
|
- | 56 |
+ 1110 |
|
- #' app <- init(
+ #'
|
- | 57 |
+ 1111 |
|
- #' data = data,
+ #' @param arr vector of any type and length
|
- | 58 |
+ 1112 |
|
- #' modules = modules(
+ #' @param width `numeric` the width of the `sparkline` widget (pixels)
|
- | 59 |
+ 1113 |
|
- #' tm_a_regression(
+ #' @param bar_spacing `numeric` the spacing between the bars (in pixels)
|
- | 60 |
+ 1114 |
|
- #' label = "Regression",
+ #' @param bar_width `numeric` the width of the bars (in pixels)
|
- | 61 |
+ 1115 |
|
- #' response = data_extract_spec(
+ #' @param ... `list` additional options passed to bar plots of `jquery.sparkline`;
|
- | 62 |
+ 1116 |
|
- #' dataname = "CO2",
+ #' see [`jquery.sparkline docs`](https://omnipotent.net/jquery.sparkline/#common)
|
- | 63 |
+ 1117 |
|
- #' select = select_spec(
+ #'
|
- | 64 |
+ 1118 |
|
- #' label = "Select variable:",
+ #' @return Character string containing HTML code of the `sparkline` HTML widget.
|
- | 65 |
+ 1119 |
|
- #' choices = "uptake",
+ #' @keywords internal
|
- | 66 |
+ 1120 |
|
- #' selected = "uptake",
+ create_sparklines <- function(arr, width = 150, ...) {
|
-
- | 67 |
- |
+
+ | 1121 |
+ ! |
- #' multiple = FALSE,
+ if (all(is.null(arr))) {
|
-
- | 68 |
- |
+
+ | 1122 |
+ ! |
- #' fixed = TRUE
+ return("")
|
- | 69 |
+ 1123 |
|
- #' )
+ }
|
-
- | 70 |
- |
+
+ | 1124 |
+ ! |
- #' ),
+ UseMethod("create_sparklines")
|
- | 71 |
+ 1125 |
|
- #' regressor = data_extract_spec(
+ }
|
- | 72 |
+ 1126 |
|
- #' dataname = "CO2",
+
|
- | 73 |
+ 1127 |
|
- #' select = select_spec(
+ #' @rdname create_sparklines
|
- | 74 |
+ 1128 |
|
- #' label = "Select variables:",
+ #' @keywords internal
|
- | 75 |
+ 1129 |
|
- #' choices = variable_choices(data[["CO2"]], c("conc", "Treatment")),
+ #' @export
|
- | 76 |
+ 1130 |
|
- #' selected = "conc",
+ create_sparklines.logical <- function(arr, ...) {
|
-
- | 77 |
- |
+
+ | 1131 |
+ ! |
- #' multiple = TRUE,
+ create_sparklines(as.factor(arr))
|
- | 78 |
+ 1132 |
|
- #' fixed = FALSE
+ }
|
- | 79 |
+ 1133 |
|
- #' )
+
|
- | 80 |
+ 1134 |
|
- #' ),
+ #' @rdname create_sparklines
|
- | 81 |
+ 1135 |
|
- #' ggplot2_args = ggplot2_args(
+ #' @keywords internal
|
- | 82 |
+ 1136 |
|
- #' labs = list(subtitle = "Plot generated by Regression Module")
+ #' @export
|
- | 83 |
+ 1137 |
|
- #' )
+ create_sparklines.numeric <- function(arr, width = 150, ...) {
|
-
- | 84 |
- |
+
+ | 1138 |
+ ! |
- #' )
+ if (any(is.infinite(arr))) {
|
-
- | 85 |
- |
+
+ | 1139 |
+ ! |
- #' )
+ return(as.character(tags$code("infinite values", class = "text-blue")))
|
- | 86 |
+ 1140 |
|
- #' )
+ }
|
-
- | 87 |
- |
+
+ | 1141 |
+ ! |
- #' if (interactive()) {
+ if (length(arr) > 100000) {
|
-
- | 88 |
- |
+
+ | 1142 |
+ ! |
- #' shinyApp(app$ui, app$server)
+ return(as.character(tags$code("Too many rows (>100000)", class = "text-blue")))
|
- | 89 |
+ 1143 |
|
- #' }
+ }
|
- | 90 |
+ 1144 |
|
- #'
+
|
-
- | 91 |
- |
+
+ | 1145 |
+ ! |
- #' # CDISC data example
+ arr <- arr[!is.na(arr)]
|
-
- | 92 |
- |
+
+ | 1146 |
+ ! |
- #' library(teal.widgets)
+ sparkline::spk_chr(unname(arr), type = "box", width = width, ...)
|
- | 93 |
+ 1147 |
|
- #'
+ }
|
- | 94 |
+ 1148 |
|
- #' data <- teal_data()
+
|
- | 95 |
+ 1149 |
|
- #' data <- within(data, {
+ #' @rdname create_sparklines
|
- | 96 |
+ 1150 |
|
- #' require(nestcolor)
+ #' @keywords internal
|
- | 97 |
+ 1151 |
|
- #' ADSL <- rADSL
+ #' @export
|
- | 98 |
+ 1152 |
|
- #' })
+ create_sparklines.character <- function(arr, ...) {
|
-
- | 99 |
- |
+
+ | 1153 |
+ ! |
- #' datanames(data) <- "ADSL"
+ return(create_sparklines(as.factor(arr)))
|
- | 100 |
+ 1154 |
|
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
+ }
|
- | 101 |
+ 1155 |
|
- #'
+
|
- | 102 |
+ 1156 |
|
- #' app <- init(
+
|
- | 103 |
+ 1157 |
|
- #' data = data,
+ #' @rdname create_sparklines
|
- | 104 |
+ 1158 |
|
- #' modules = modules(
+ #' @keywords internal
|
- | 105 |
+ 1159 |
|
- #' tm_a_regression(
+ #' @export
|
- | 106 |
+ 1160 |
|
- #' label = "Regression",
+ create_sparklines.factor <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
|
-
- | 107 |
- |
+
+ | 1161 |
+ ! |
- #' response = data_extract_spec(
+ decreasing_order <- TRUE
|
- | 108 |
+ 1162 |
|
- #' dataname = "ADSL",
+
|
-
- | 109 |
- |
+
+ | 1163 |
+ ! |
- #' select = select_spec(
+ counts <- table(arr)
|
-
- | 110 |
- |
+
+ | 1164 |
+ ! |
- #' label = "Select variable:",
+ if (length(counts) >= 100) {
|
-
- | 111 |
- |
+
+ | 1165 |
+ ! |
- #' choices = "BMRKR1",
+ return(as.character(tags$code("> 99 levels", class = "text-blue")))
|
-
- | 112 |
- |
+
+ | 1166 |
+ ! |
- #' selected = "BMRKR1",
+ } else if (length(counts) == 0) {
|
-
- | 113 |
- |
+
+ | 1167 |
+ ! |
- #' multiple = FALSE,
+ return(as.character(tags$code("no levels", class = "text-blue")))
|
-
- | 114 |
- |
+
+ | 1168 |
+ ! |
- #' fixed = TRUE
+ } else if (length(counts) == 1) {
|
-
- | 115 |
- |
+
+ | 1169 |
+ ! |
- #' )
+ return(as.character(tags$code("one level", class = "text-blue")))
|
- | 116 |
+ 1170 |
|
- #' ),
+ }
|
- | 117 |
+ 1171 |
|
- #' regressor = data_extract_spec(
+
|
- | 118 |
+ 1172 |
|
- #' dataname = "ADSL",
+ # Summarize the occurences of different levels
|
- | 119 |
+ 1173 |
|
- #' select = select_spec(
+ # and get the maximum and minimum number of occurences
|
- | 120 |
+ 1174 |
|
- #' label = "Select variables:",
+ # This is needed for the sparkline to correctly display the bar plots
|
- | 121 |
+ 1175 |
|
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "SEX", "RACE")),
+ # Otherwise they are cropped
|
-
- | 122 |
- |
+
+ | 1176 |
+ ! |
- #' selected = "AGE",
+ counts <- sort(counts, decreasing = decreasing_order, method = "radix")
|
-
- | 123 |
- |
+
+ | 1177 |
+ ! |
- #' multiple = TRUE,
+ max_value <- if (decreasing_order) counts[1] else counts[length[counts]]
|
-
- | 124 |
- |
+
+ | 1178 |
+ ! |
- #' fixed = FALSE
+ max_value <- unname(max_value)
|
- | 125 |
+ 1179 |
|
- #' )
+
|
-
- | 126 |
- |
+
+ | 1180 |
+ ! |
- #' ),
+ sparkline::spk_chr(
|
-
- | 127 |
- |
+
+ | 1181 |
+ ! |
- #' ggplot2_args = ggplot2_args(
+ unname(counts),
|
-
- | 128 |
- |
+
+ | 1182 |
+ ! |
- #' labs = list(subtitle = "Plot generated by Regression Module")
+ type = "bar",
|
-
- | 129 |
- |
+
+ | 1183 |
+ ! |
- #' )
+ chartRangeMin = 0,
|
-
- | 130 |
- |
+
+ | 1184 |
+ ! |
- #' )
+ chartRangeMax = max_value,
|
-
- | 131 |
- |
+
+ | 1185 |
+ ! |
- #' )
+ width = width,
|
-
- | 132 |
- |
+
+ | 1186 |
+ ! |
- #' )
+ barWidth = bar_width,
|
-
- | 133 |
- |
+
+ | 1187 |
+ ! |
- #' if (interactive()) {
+ barSpacing = bar_spacing,
|
-
- | 134 |
- |
+
+ | 1188 |
+ ! |
- #' shinyApp(app$ui, app$server)
+ tooltipFormatter = custom_sparkline_formatter(names(counts), as.vector(counts))
|
- | 135 |
+ 1189 |
|
- #' }
+ )
|
- | 136 |
+ 1190 |
|
- #'
+ }
|
- | 137 |
+ 1191 |
|
- #' @export
+
|
- | 138 |
+ 1192 |
|
- #'
+ #' @rdname create_sparklines
|
- | 139 |
+ 1193 |
|
- tm_a_regression <- function(label = "Regression Analysis",
+ #' @keywords internal
|
- | 140 |
+ 1194 |
|
- regressor,
+ #' @export
|
- | 141 |
+ 1195 |
|
- response,
+ create_sparklines.Date <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
|
-
- | 142 |
- |
-
- plot_height = c(600, 200, 2000),
- |
-
-
- | 143 |
- |
-
- plot_width = NULL,
- |
-
-
- | 144 |
- |
-
- alpha = c(1, 0, 1),
- |
-
-
- | 145 |
- |
-
- size = c(2, 1, 8),
- |
-
-
- | 146 |
- |
-
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
- |
-
-
- | 147 |
- |
-
- ggplot2_args = teal.widgets::ggplot2_args(),
- |
-
-
- | 148 |
- |
-
- pre_output = NULL,
- |
-
-
- | 149 |
- |
-
- post_output = NULL,
- |
-
-
- | 150 |
- |
-
- default_plot_type = 1,
- |
-
-
- | 151 |
- |
-
- default_outlier_label = "USUBJID",
- |
-
-
- | 152 |
- |
+
+ | 1196 |
+ ! |
- label_segment_threshold = c(0.5, 0, 10)) {
+ arr_num <- as.numeric(arr)
|
- | 153 |
+ 1197 |
! |
- message("Initializing tm_a_regression")
+ arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")
|
-
- | 154 |
- |
+
+ | 1198 |
+ ! |
-
+ binwidth <- get_bin_width(arr_num, 1)
|
-
- | 155 |
- |
+
+ | 1199 |
+ ! |
- # Normalize the parameters
+ bins <- floor(diff(range(arr_num)) / binwidth) + 1
|
- | 156 |
+ 1200 |
! |
- if (inherits(regressor, "data_extract_spec")) regressor <- list(regressor)
+ if (all(is.na(bins))) {
|
- | 157 |
+ 1201 |
! |
- if (inherits(response, "data_extract_spec")) response <- list(response)
+ return(as.character(tags$code("only NA", class = "text-blue")))
|
- | 158 |
+ 1202 |
! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)
+ } else if (bins == 1) {
|
-
- | 159 |
- |
+
+ | 1203 |
+ ! |
-
+ return(as.character(tags$code("one date", class = "text-blue")))
|
- | 160 |
+ 1204 |
|
- # Start of assertions
+ }
|
- | 161 |
+ 1205 |
! |
- checkmate::assert_string(label)
+ counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))
|
- | 162 |
+ 1206 |
! |
- checkmate::assert_list(regressor, types = "data_extract_spec")
+ max_value <- max(counts)
|
- | 163 |
+ 1207 |
|
|
- | 164 |
+ 1208 |
! |
- checkmate::assert_list(response, types = "data_extract_spec")
+ start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))
|
- | 165 |
+ 1209 |
! |
- assert_single_selection(response)
+ labels_start <- as.character(as.Date(arr_num[start_bins], origin = as.Date("1970-01-01")))
+ |
+
+
+ | 1210 |
+ ! |
+
+ labels <- paste("Start:", labels_start)
|
- | 166 |
+ 1211 |
|
|
- | 167 |
+ 1212 |
! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
+ sparkline::spk_chr(
|
- | 168 |
+ 1213 |
! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
- |
-
-
- | 169 |
- |
-
-
+ unname(counts),
|
- | 170 |
+ 1214 |
! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
+ type = "bar",
|
- | 171 |
+ 1215 |
! |
- checkmate::assert_numeric(
+ chartRangeMin = 0,
|
- | 172 |
+ 1216 |
! |
- plot_width[1],
+ chartRangeMax = max_value,
|
- | 173 |
+ 1217 |
! |
- lower = plot_width[2],
+ width = width,
|
- | 174 |
+ 1218 |
! |
- upper = plot_width[3],
+ barWidth = bar_width,
|
- | 175 |
+ 1219 |
! |
- null.ok = TRUE,
+ barSpacing = bar_spacing,
|
- | 176 |
+ 1220 |
! |
- .var.name = "plot_width"
+ tooltipFormatter = custom_sparkline_formatter(labels, counts)
|
- | 177 |
+ 1221 |
|
)
|
- | 178 |
+ 1222 |
|
-
- |
-
-
- | 179 |
- ! |
-
- if (length(alpha) == 1) {
- |
-
-
- | 180 |
- ! |
-
- checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE)
+ }
|
- | 181 |
+ 1223 |
|
- } else {
+
|
-
- | 182 |
- ! |
+
+ | 1224 |
+ |
- checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE)
+ #' @rdname create_sparklines
|
-
- | 183 |
- ! |
+
+ | 1225 |
+ |
- checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")
+ #' @keywords internal
|
- | 184 |
+ 1226 |
|
- }
+ #' @export
|
- | 185 |
+ 1227 |
|
-
+ create_sparklines.POSIXct <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
|
- | 186 |
+ 1228 |
! |
- if (length(size) == 1) {
+ arr_num <- as.numeric(arr)
|
- | 187 |
+ 1229 |
! |
- checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE)
- |
-
-
- | 188 |
- |
-
- } else {
+ arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")
|
- | 189 |
+ 1230 |
! |
- checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE)
+ binwidth <- get_bin_width(arr_num, 1)
|
- | 190 |
+ 1231 |
! |
- checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")
- |
-
-
- | 191 |
- |
-
- }
- |
-
-
- | 192 |
- |
-
-
+ bins <- floor(diff(range(arr_num)) / binwidth) + 1
|
- | 193 |
+ 1232 |
! |
- ggtheme <- match.arg(ggtheme)
- |
-
-
- | 194 |
- |
-
-
+ if (all(is.na(bins))) {
|
- | 195 |
+ 1233 |
! |
- plot_choices <- c(
+ return(as.character(tags$code("only NA", class = "text-blue")))
|
- | 196 |
+ 1234 |
! |
- "Response vs Regressor", "Residuals vs Fitted", "Normal Q-Q", "Scale-Location",
+ } else if (bins == 1) {
|
- | 197 |
+ 1235 |
! |
- "Cook's distance", "Residuals vs Leverage", "Cook's dist vs Leverage"
+ return(as.character(tags$code("one date-time", class = "text-blue")))
|
- | 198 |
+ 1236 |
|
- )
+ }
|
- | 199 |
+ 1237 |
! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")
+ counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))
|
- | 200 |
+ 1238 |
! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ max_value <- max(counts)
|
- | 201 |
+ 1239 |
|
|
- | 202 |
- ! |
-
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
- |
-
-
- | 203 |
+ 1240 |
! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))
|
- | 204 |
+ 1241 |
! |
- checkmate::assert_choice(default_plot_type, seq.int(1L, length(plot_choices)))
+ labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
|
- | 205 |
+ 1242 |
! |
- checkmate::assert_string(default_outlier_label)
+ labels <- paste("Start:", labels_start)
|
- | 206 |
+ 1243 |
|
|
- | 207 |
+ 1244 |
! |
- if (length(label_segment_threshold) == 1) {
+ sparkline::spk_chr(
|
- | 208 |
+ 1245 |
! |
- checkmate::assert_numeric(label_segment_threshold, any.missing = FALSE, finite = TRUE)
+ unname(counts),
|
-
- | 209 |
- |
+
+ | 1246 |
+ ! |
- } else {
+ type = "bar",
|
- | 210 |
+ 1247 |
! |
- checkmate::assert_numeric(label_segment_threshold, len = 3, any.missing = FALSE, finite = TRUE)
+ chartRangeMin = 0,
|
- | 211 |
+ 1248 |
! |
- checkmate::assert_numeric(
+ chartRangeMax = max_value,
|
- | 212 |
+ 1249 |
! |
- label_segment_threshold[1],
+ width = width,
|
- | 213 |
+ 1250 |
! |
- lower = label_segment_threshold[2],
+ barWidth = bar_width,
|
- | 214 |
+ 1251 |
! |
- upper = label_segment_threshold[3],
+ barSpacing = bar_spacing,
|
- | 215 |
+ 1252 |
! |
- .var.name = "label_segment_threshold"
+ tooltipFormatter = custom_sparkline_formatter(labels, counts)
|
- | 216 |
+ 1253 |
|
- )
+ )
|
- | 217 |
+ 1254 |
|
- }
+ }
|
- | 218 |
+ 1255 |
|
- # End of assertions
+
|
- | 219 |
+ 1256 |
|
-
+ #' @rdname create_sparklines
|
- | 220 |
+ 1257 |
|
- # Make UI args
+ #' @keywords internal
|
-
- | 221 |
- ! |
+
+ | 1258 |
+ |
- args <- as.list(environment())
+ #' @export
|
-
- | 222 |
- ! |
+
+ | 1259 |
+ |
- args[["plot_choices"]] <- plot_choices
+ create_sparklines.POSIXlt <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
|
- | 223 |
+ 1260 |
! |
- data_extract_list <- list(
+ arr_num <- as.numeric(arr)
|
- | 224 |
+ 1261 |
! |
- regressor = regressor,
+ arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")
|
- | 225 |
+ 1262 |
! |
- response = response
- |
-
-
- | 226 |
- |
-
- )
- |
-
-
- | 227 |
- |
-
-
+ binwidth <- get_bin_width(arr_num, 1)
|
- | 228 |
+ 1263 |
! |
- ans <- module(
+ bins <- floor(diff(range(arr_num)) / binwidth) + 1
|
- | 229 |
+ 1264 |
! |
- label = label,
+ if (all(is.na(bins))) {
|
- | 230 |
+ 1265 |
! |
- server = srv_a_regression,
+ return(as.character(tags$code("only NA", class = "text-blue")))
|
- | 231 |
+ 1266 |
! |
- ui = ui_a_regression,
+ } else if (bins == 1) {
|
- | 232 |
+ 1267 |
! |
- ui_args = args,
+ return(as.character(tags$code("one date-time", class = "text-blue")))
|
-
- | 233 |
- ! |
+
+ | 1268 |
+ |
- server_args = c(
+ }
|
- | 234 |
+ 1269 |
! |
- data_extract_list,
+ counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))
|
- | 235 |
+ 1270 |
! |
- list(
+ max_value <- max(counts)
|
-
- | 236 |
- ! |
+
+ | 1271 |
+ |
- plot_height = plot_height,
+
|
- | 237 |
+ 1272 |
! |
- plot_width = plot_width,
+ start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))
|
- | 238 |
+ 1273 |
! |
- default_outlier_label = default_outlier_label,
+ labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
|
- | 239 |
+ 1274 |
! |
- ggplot2_args = ggplot2_args
- |
-
-
- | 240 |
- |
-
- )
+ labels <- paste("Start:", labels_start)
|
- | 241 |
+ 1275 |
|
- ),
+
|
- | 242 |
+ 1276 |
! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)
+ sparkline::spk_chr(
|
-
- | 243 |
- |
+
+ | 1277 |
+ ! |
- )
+ unname(counts),
|
- | 244 |
+ 1278 |
! |
- attr(ans, "teal_bookmarkable") <- FALSE
+ type = "bar",
|
- | 245 |
+ 1279 |
! |
- ans
- |
-
-
- | 246 |
- |
-
- }
- |
-
-
- | 247 |
- |
-
-
+ chartRangeMin = 0,
|
-
- | 248 |
- |
+
+ | 1280 |
+ ! |
- # UI function for the regression module
+ chartRangeMax = max_value,
|
-
- | 249 |
- |
+
+ | 1281 |
+ ! |
- ui_a_regression <- function(id, ...) {
+ width = width,
|
- | 250 |
+ 1282 |
! |
- ns <- NS(id)
+ barWidth = bar_width,
|
- | 251 |
+ 1283 |
! |
- args <- list(...)
+ barSpacing = bar_spacing,
|
- | 252 |
+ 1284 |
! |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$regressor, args$response)
+ tooltipFormatter = custom_sparkline_formatter(labels, counts)
|
- | 253 |
+ 1285 |
|
-
- |
-
-
- | 254 |
- ! |
-
- teal.widgets::standard_layout(
+ )
|
-
- | 255 |
- ! |
+
+ | 1286 |
+ |
- output = teal.widgets::white_small_well(tags$div(
+ }
|
-
- | 256 |
- ! |
+
+ | 1287 |
+ |
- teal.widgets::plot_with_settings_ui(id = ns("myplot")),
+
|
-
- | 257 |
- ! |
+
+ | 1288 |
+ |
- tags$div(verbatimTextOutput(ns("text")))
+ #' @rdname create_sparklines
|
- | 258 |
+ 1289 |
|
- )),
+ #' @keywords internal
|
-
- | 259 |
- ! |
+
+ | 1290 |
+ |
- encoding = tags$div(
+ #' @export
|
- | 260 |
+ 1291 |
|
- ### Reporter
+ create_sparklines.default <- function(arr, width = 150, ...) {
|
- | 261 |
+ 1292 |
! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ as.character(tags$code("unsupported variable type", class = "text-blue"))
|
- | 262 |
+ 1293 |
|
- ###
+ }
|
-
- | 263 |
- ! |
+
+ | 1294 |
+ |
- tags$label("Encodings", class = "text-primary"),
+
|
-
- | 264 |
- ! |
+
+ | 1295 |
+ |
- teal.transform::datanames_input(args[c("response", "regressor")]),
+
|
-
- | 265 |
- ! |
+
+ | 1296 |
+ |
- teal.transform::data_extract_ui(
+ custom_sparkline_formatter <- function(labels, counts) {
|
- | 266 |
+ 1297 |
! |
- id = ns("response"),
+ htmlwidgets::JS(
|
- | 267 |
+ 1298 |
! |
- label = "Response variable",
+ sprintf(
|
- | 268 |
+ 1299 |
! |
- data_extract_spec = args$response,
+ "function(sparkline, options, field) {
|
- | 269 |
+ 1300 |
! |
- is_single_dataset = is_single_dataset_value
+ return 'ID: ' + %s[field[0].offset] + '<br>' + 'Count: ' + %s[field[0].offset];
|
- | 270 |
+ 1301 |
|
- ),
+ }",
|
- | 271 |
+ 1302 |
! |
- teal.transform::data_extract_ui(
+ jsonlite::toJSON(labels),
|
- | 272 |
+ 1303 |
! |
- id = ns("regressor"),
+ jsonlite::toJSON(counts)
|
-
- | 273 |
- ! |
+
+ | 1304 |
+ |
- label = "Regressor variables",
+ )
|
-
- | 274 |
- ! |
+
+ | 1305 |
+ |
- data_extract_spec = args$regressor,
+ )
|
-
- | 275 |
- ! |
+
+ | 1306 |
+ |
- is_single_dataset = is_single_dataset_value
+ }
|
+
+
+
+
+
+
- | 276 |
+ 1 |
|
- ),
+ #' `teal` module: Outliers analysis
|
-
- | 277 |
- ! |
+
+ | 2 |
+ |
- radioButtons(
+ #'
|
-
- | 278 |
- ! |
+
+ | 3 |
+ |
- ns("plot_type"),
+ #' Module to analyze and identify outliers using different methods
|
-
- | 279 |
- ! |
+
+ | 4 |
+ |
- label = "Plot type:",
+ #' such as IQR, Z-score, and Percentiles, and offers visualizations including
|
-
- | 280 |
- ! |
+
+ | 5 |
+ |
- choices = args$plot_choices,
+ #' box plots, density plots, and cumulative distribution plots to help interpret the outliers.
|
-
- | 281 |
- ! |
+
+ | 6 |
+ |
- selected = args$plot_choices[args$default_plot_type]
+ #'
|
- | 282 |
+ 7 |
|
- ),
+ #' @inheritParams teal::module
|
-
- | 283 |
- ! |
+
+ | 8 |
+ |
- checkboxInput(ns("show_outlier"), label = "Display outlier labels", value = TRUE),
+ #' @inheritParams shared_params
|
-
- | 284 |
- ! |
+
+ | 9 |
+ |
- conditionalPanel(
+ #'
|
-
- | 285 |
- ! |
+
+ | 10 |
+ |
- condition = "input['show_outlier']",
+ #' @param outlier_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)
|
-
- | 286 |
- ! |
+
+ | 11 |
+ |
- ns = ns,
+ #' Specifies variable(s) to be analyzed for outliers.
|
-
- | 287 |
- ! |
+
+ | 12 |
+ |
- teal.widgets::optionalSliderInput(
+ #' @param categorical_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
|
-
- | 288 |
- ! |
+
+ | 13 |
+ |
- ns("outlier"),
+ #' specifies the categorical variable(s) to split the selected outlier variables on.
|
-
- | 289 |
- ! |
+
+ | 14 |
+ |
- tags$div(
+ #'
|
-
- | 290 |
- ! |
+
+ | 15 |
+ |
- class = "teal-tooltip",
+ #' @templateVar ggnames "Boxplot","Density Plot","Cumulative Distribution Plot"
|
-
- | 291 |
- ! |
+
+ | 16 |
+ |
- tagList(
+ #' @template ggplot2_args_multi
|
-
- | 292 |
- ! |
+
+ | 17 |
+ |
- "Outlier definition:",
+ #'
|
-
- | 293 |
- ! |
+
+ | 18 |
+ |
- icon("circle-info"),
+ #' @inherit shared_params return
|
-
- | 294 |
- ! |
+
+ | 19 |
+ |
- tags$span(
+ #'
|
-
- | 295 |
- ! |
+
+ | 20 |
+ |
- class = "tooltiptext",
+ #' @examplesShinylive
|
-
- | 296 |
- ! |
+
+ | 21 |
+ |
- paste(
+ #' library(teal.modules.general)
|
-
- | 297 |
- ! |
+
+ | 22 |
+ |
- "Use the slider to choose the cut-off value to define outliers.",
+ #' interactive <- function() TRUE
|
-
- | 298 |
- ! |
+
+ | 23 |
+ |
- "Points with a Cook's distance greater than",
+ #' {{ next_example }}
|
-
- | 299 |
- ! |
+
+ | 24 |
+ |
- "the value on the slider times the mean of the Cook's distance of the dataset will have labels."
+ #' @examples
|
- | 300 |
+ 25 |
|
- )
+ #' # general data example
|
- | 301 |
+ 26 |
|
- )
+ #' data <- teal_data()
|
- | 302 |
+ 27 |
|
- )
+ #' data <- within(data, {
|
- | 303 |
+ 28 |
|
- ),
+ #' CO2 <- CO2
|
-
- | 304 |
- ! |
+
+ | 29 |
+ |
- min = 1, max = 10, value = 9, ticks = FALSE, step = .1
+ #' CO2[["primary_key"]] <- seq_len(nrow(CO2))
|
- | 305 |
+ 30 |
|
- ),
+ #' })
|
-
- | 306 |
- ! |
+
+ | 31 |
+ |
- teal.widgets::optionalSelectInput(
+ #' datanames(data) <- "CO2"
|
-
- | 307 |
- ! |
+
+ | 32 |
+ |
- ns("label_var"),
+ #' join_keys(data) <- join_keys(join_key("CO2", "CO2", "primary_key"))
|
-
- | 308 |
- ! |
+
+ | 33 |
+ |
- multiple = FALSE,
+ #'
|
-
- | 309 |
- ! |
+
+ | 34 |
+ |
- label = "Outlier label"
+ #' vars <- choices_selected(variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")))
|
- | 310 |
+ 35 |
|
- )
+ #'
|
- | 311 |
+ 36 |
|
- ),
+ #' app <- init(
|
-
- | 312 |
- ! |
+
+ | 37 |
+ |
- teal.widgets::panel_group(
+ #' data = data,
|
-
- | 313 |
- ! |
+
+ | 38 |
+ |
- teal.widgets::panel_item(
+ #' modules = modules(
|
-
- | 314 |
- ! |
+
+ | 39 |
+ |
- title = "Plot settings",
+ #' tm_outliers(
|
-
- | 315 |
- ! |
+
+ | 40 |
+ |
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
+ #' outlier_var = list(
|
-
- | 316 |
- ! |
+
+ | 41 |
+ |
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE),
+ #' data_extract_spec(
|
-
- | 317 |
- ! |
+
+ | 42 |
+ |
- teal.widgets::optionalSliderInputValMinMax(
+ #' dataname = "CO2",
|
-
- | 318 |
- ! |
+
+ | 43 |
+ |
- inputId = ns("label_min_segment"),
+ #' select = select_spec(
|
-
- | 319 |
- ! |
+
+ | 44 |
+ |
- label = tags$div(
+ #' label = "Select variable:",
|
-
- | 320 |
- ! |
+
+ | 45 |
+ |
- class = "teal-tooltip",
+ #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
|
-
- | 321 |
- ! |
+
+ | 46 |
+ |
- tagList(
+ #' selected = "uptake",
|
-
- | 322 |
- ! |
+
+ | 47 |
+ |
- "Label min. segment:",
+ #' multiple = FALSE,
|
-
- | 323 |
- ! |
+
+ | 48 |
+ |
- icon("circle-info"),
+ #' fixed = FALSE
|
-
- | 324 |
- ! |
+
+ | 49 |
+ |
- tags$span(
+ #' )
|
-
- | 325 |
- ! |
+
+ | 50 |
+ |
- class = "tooltiptext",
+ #' )
|
-
- | 326 |
- ! |
+
+ | 51 |
+ |
- paste(
+ #' ),
|
-
- | 327 |
- ! |
+
+ | 52 |
+ |
- "Use the slider to choose the cut-off value to define minimum distance between label and point",
+ #' categorical_var = list(
|
-
- | 328 |
- ! |
+
+ | 53 |
+ |
- "that generates a line segment.",
+ #' data_extract_spec(
|
-
- | 329 |
- ! |
+
+ | 54 |
+ |
- "It's only valid when 'Display outlier labels' is checked."
+ #' dataname = "CO2",
|
- | 330 |
+ 55 |
|
- )
+ #' filter = filter_spec(
|
- | 331 |
+ 56 |
|
- )
+ #' vars = vars,
|
- | 332 |
+ 57 |
|
- )
+ #' choices = value_choices(data[["CO2"]], vars$selected),
|
- | 333 |
+ 58 |
|
- ),
+ #' selected = value_choices(data[["CO2"]], vars$selected),
|
-
- | 334 |
- ! |
+
+ | 59 |
+ |
- value_min_max = args$label_segment_threshold,
+ #' multiple = TRUE
|
- | 335 |
+ 60 |
|
- # Extra parameters to sliderInput
+ #' )
|
-
- | 336 |
- ! |
+
+ | 61 |
+ |
- ticks = FALSE,
+ #' )
|
-
- | 337 |
- ! |
+
+ | 62 |
+ |
- step = .1,
+ #' )
|
-
- | 338 |
- ! |
+
+ | 63 |
+ |
- round = FALSE
+ #' )
|
- | 339 |
+ 64 |
|
- ),
+ #' )
|
-
- | 340 |
- ! |
+
+ | 65 |
+ |
- selectInput(
+ #' )
|
-
- | 341 |
- ! |
+
+ | 66 |
+ |
- inputId = ns("ggtheme"),
+ #' if (interactive()) {
|
-
- | 342 |
- ! |
+
+ | 67 |
+ |
- label = "Theme (by ggplot):",
+ #' shinyApp(app$ui, app$server)
|
-
- | 343 |
- ! |
+
+ | 68 |
+ |
- choices = ggplot_themes,
+ #' }
|
-
- | 344 |
- ! |
+
+ | 69 |
+ |
- selected = args$ggtheme,
+ #'
|
-
- | 345 |
- ! |
+
+ | 70 |
+ |
- multiple = FALSE
+ #' @examplesShinylive
|
- | 346 |
+ 71 |
|
- )
+ #' library(teal.modules.general)
|
- | 347 |
+ 72 |
|
- )
+ #' interactive <- function() TRUE
|
- | 348 |
+ 73 |
|
- )
+ #' {{ next_example }}
|
- | 349 |
+ 74 |
|
- ),
+ #' @examples
|
-
- | 350 |
- ! |
+
+ | 75 |
+ |
- forms = tagList(
+ #' # CDISC data example
|
-
- | 351 |
- ! |
+
+ | 76 |
+ |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ #' data <- teal_data()
|
- | 352 |
+ 77 |
|
- ),
+ #' data <- within(data, {
|
-
- | 353 |
- ! |
+
+ | 78 |
+ |
- pre_output = args$pre_output,
+ #' ADSL <- rADSL
|
-
- | 354 |
- ! |
+
+ | 79 |
+ |
- post_output = args$post_output
+ #' })
|
- | 355 |
+ 80 |
|
- )
+ #' datanames(data) <- "ADSL"
|
- | 356 |
+ 81 |
|
- }
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
|
- | 357 |
+ 82 |
|
-
+ #'
|
- | 358 |
+ 83 |
|
- # Server function for the regression module
+ #' fact_vars_adsl <- names(Filter(isTRUE, sapply(data[["ADSL"]], is.factor)))
|
- | 359 |
+ 84 |
|
- srv_a_regression <- function(id,
+ #' vars <- choices_selected(variable_choices(data[["ADSL"]], fact_vars_adsl))
|
- | 360 |
+ 85 |
|
- data,
+ #'
|
- | 361 |
+ 86 |
|
- reporter,
+ #' app <- init(
|
- | 362 |
+ 87 |
|
- filter_panel_api,
+ #' data = data,
|
- | 363 |
+ 88 |
|
- response,
+ #' modules = modules(
|
- | 364 |
+ 89 |
|
- regressor,
+ #' tm_outliers(
|
- | 365 |
+ 90 |
|
- plot_height,
+ #' outlier_var = list(
|
- | 366 |
+ 91 |
|
- plot_width,
+ #' data_extract_spec(
|
- | 367 |
+ 92 |
|
- ggplot2_args,
+ #' dataname = "ADSL",
|
- | 368 |
+ 93 |
|
- default_outlier_label) {
+ #' select = select_spec(
|
-
- | 369 |
- ! |
+
+ | 94 |
+ |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
+ #' label = "Select variable:",
|
-
- | 370 |
- ! |
+
+ | 95 |
+ |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
|
-
- | 371 |
- ! |
+
+ | 96 |
+ |
- checkmate::assert_class(data, "reactive")
+ #' selected = "AGE",
|
-
- | 372 |
- ! |
+
+ | 97 |
+ |
- checkmate::assert_class(isolate(data()), "teal_data")
+ #' multiple = FALSE,
|
-
- | 373 |
- ! |
+
+ | 98 |
+ |
- moduleServer(id, function(input, output, session) {
+ #' fixed = FALSE
|
-
- | 374 |
- ! |
+
+ | 99 |
+ |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
+ #' )
|
- | 375 |
+ 100 |
|
-
+ #' )
|
-
- | 376 |
- ! |
+
+ | 101 |
+ |
- ns <- session$ns
+ #' ),
|
- | 377 |
+ 102 |
|
-
+ #' categorical_var = list(
|
-
- | 378 |
- ! |
+
+ | 103 |
+ |
- rule_rvr1 <- function(value) {
+ #' data_extract_spec(
|
-
- | 379 |
- ! |
+
+ | 104 |
+ |
- if (isTRUE(input$plot_type == "Response vs Regressor")) {
+ #' dataname = "ADSL",
|
-
- | 380 |
- ! |
+
+ | 105 |
+ |
- if (length(value) > 1L) {
+ #' filter = filter_spec(
|
-
- | 381 |
- ! |
+
+ | 106 |
+ |
- "This plot can only have one regressor."
+ #' vars = vars,
|
- | 382 |
+ 107 |
|
- }
+ #' choices = value_choices(data[["ADSL"]], vars$selected),
|
- | 383 |
+ 108 |
|
- }
+ #' selected = value_choices(data[["ADSL"]], vars$selected),
|
- | 384 |
+ 109 |
|
- }
+ #' multiple = TRUE
|
-
- | 385 |
- ! |
+
+ | 110 |
+ |
- rule_rvr2 <- function(other) {
+ #' )
|
-
- | 386 |
- ! |
+
+ | 111 |
+ |
- function(value) {
+ #' )
|
-
- | 387 |
- ! |
+
+ | 112 |
+ |
- if (isTRUE(input$plot_type == "Response vs Regressor")) {
+ #' )
|
-
- | 388 |
- ! |
+
+ | 113 |
+ |
- otherval <- selector_list()[[other]]()$select
+ #' )
|
-
- | 389 |
- ! |
+
+ | 114 |
+ |
- if (isTRUE(value == otherval)) {
+ #' )
|
-
- | 390 |
- ! |
+
+ | 115 |
+ |
- "Response and Regressor must be different."
+ #' )
|
- | 391 |
+ 116 |
|
- }
+ #' if (interactive()) {
|
- | 392 |
+ 117 |
|
- }
+ #' shinyApp(app$ui, app$server)
|
- | 393 |
+ 118 |
|
- }
+ #' }
|
- | 394 |
+ 119 |
|
- }
+ #'
|
- | 395 |
+ 120 |
|
-
+ #' @export
|
-
- | 396 |
- ! |
+
+ | 121 |
+ |
- selector_list <- teal.transform::data_extract_multiple_srv(
+ #'
|
-
- | 397 |
- ! |
+
+ | 122 |
+ |
- data_extract = list(response = response, regressor = regressor),
+ tm_outliers <- function(label = "Outliers Module",
|
-
- | 398 |
- ! |
+
+ | 123 |
+ |
- datasets = data,
+ outlier_var,
|
-
- | 399 |
- ! |
+
+ | 124 |
+ |
- select_validation_rule = list(
+ categorical_var = NULL,
|
-
- | 400 |
- ! |
+
+ | 125 |
+ |
- regressor = shinyvalidate::compose_rules(
+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
-
- | 401 |
- ! |
+
+ | 126 |
+ |
- shinyvalidate::sv_required("At least one regressor should be selected."),
+ ggplot2_args = teal.widgets::ggplot2_args(),
|
-
- | 402 |
- ! |
+
+ | 127 |
+ |
- rule_rvr1,
- |
-
-
- | 403 |
- ! |
-
- rule_rvr2("response")
+ plot_height = c(600, 200, 2000),
|
- | 404 |
+ 128 |
|
- ),
- |
-
-
- | 405 |
- ! |
-
- response = shinyvalidate::compose_rules(
- |
-
-
- | 406 |
- ! |
-
- shinyvalidate::sv_required("At least one response should be selected."),
+ plot_width = NULL,
|
-
- | 407 |
- ! |
+
+ | 129 |
+ |
- rule_rvr2("regressor")
+ pre_output = NULL,
|
- | 408 |
+ 130 |
|
- )
+ post_output = NULL) {
|
-
- | 409 |
- |
+
+ | 131 |
+ ! |
- )
+ message("Initializing tm_outliers")
|
- | 410 |
+ 132 |
|
- )
+
|
- | 411 |
+ 133 |
|
-
+ # Normalize the parameters
|
- | 412 |
+ 134 |
! |
- iv_r <- reactive({
+ if (inherits(outlier_var, "data_extract_spec")) outlier_var <- list(outlier_var)
|
- | 413 |
+ 135 |
! |
- iv <- shinyvalidate::InputValidator$new()
+ if (inherits(categorical_var, "data_extract_spec")) categorical_var <- list(categorical_var)
|
- | 414 |
+ 136 |
! |
- teal.transform::compose_and_enable_validators(iv, selector_list)
+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)
|
- | 415 |
+ 137 |
|
- })
+
|
- | 416 |
+ 138 |
|
-
+ # Start of assertions
|
- | 417 |
+ 139 |
! |
- iv_out <- shinyvalidate::InputValidator$new()
+ checkmate::assert_string(label)
|
- | 418 |
+ 140 |
! |
- iv_out$condition(~ isTRUE(input$show_outlier))
+ checkmate::assert_list(outlier_var, types = "data_extract_spec")
|
-
- | 419 |
- ! |
+
+ | 141 |
+ |
- iv_out$add_rule("label_var", shinyvalidate::sv_required("Please provide an `Outlier label` variable"))
+
|
- | 420 |
+ 142 |
! |
- iv_out$enable()
+ checkmate::assert_list(categorical_var, types = "data_extract_spec", null.ok = TRUE)
|
-
- | 421 |
- |
+
+ | 143 |
+ ! |
-
+ if (is.list(categorical_var)) {
|
- | 422 |
+ 144 |
! |
- anl_merged_input <- teal.transform::merge_expression_srv(
+ lapply(categorical_var, function(x) {
|
- | 423 |
+ 145 |
! |
- selector_list = selector_list,
+ if (length(x$filter) > 1L) {
|
- | 424 |
+ 146 |
! |
- datasets = data
+ stop("tm_outliers: categorical_var data_extract_specs may only specify one filter_spec", call. = FALSE)
|
- | 425 |
+ 147 |
|
- )
+ }
|
- | 426 |
+ 148 |
|
-
+ })
|
-
- | 427 |
- ! |
+
+ | 149 |
+ |
- regression_var <- reactive({
+ }
+ |
+
+
+ | 150 |
+ |
+
+
|
- | 428 |
+ 151 |
! |
- teal::validate_inputs(iv_r())
+ ggtheme <- match.arg(ggtheme)
|
- | 429 |
+ 152 |
|
|
- | 430 |
+ 153 |
! |
- list(
+ plot_choices <- c("Boxplot", "Density Plot", "Cumulative Distribution Plot")
|
- | 431 |
+ 154 |
! |
- response = as.vector(anl_merged_input()$columns_source$response),
+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args")
|
- | 432 |
+ 155 |
! |
- regressor = as.vector(anl_merged_input()$columns_source$regressor)
+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
- | 433 |
+ 156 |
|
- )
+
|
-
- | 434 |
- |
+
+ | 157 |
+ ! |
- })
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
|
-
- | 435 |
- |
+
+ | 158 |
+ ! |
-
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
|
- | 436 |
+ 159 |
! |
- anl_merged_q <- reactive({
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
|
- | 437 |
+ 160 |
! |
- req(anl_merged_input())
+ checkmate::assert_numeric(
|
- | 438 |
+ 161 |
! |
- data() %>%
+ plot_width[1],
|
- | 439 |
+ 162 |
! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))
+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
|
- | 440 |
+ 163 |
|
- })
+ )
|
- | 441 |
+ 164 |
|
|
-
- | 442 |
- |
-
- # sets qenv object and populates it with data merge call and fit expression
- |
-
- | 443 |
+ 165 |
! |
- fit_r <- reactive({
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
- | 444 |
+ 166 |
! |
- ANL <- anl_merged_q()[["ANL"]]
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
-
- | 445 |
- ! |
+
+ | 167 |
+ |
- teal::validate_has_data(ANL, 10)
+ # End of assertions
|
- | 446 |
+ 168 |
|
|
+
+ | 169 |
+ |
+
+ # Make UI args
+ |
+
- | 447 |
+ 170 |
! |
- validate(need(is.numeric(ANL[regression_var()$response][[1]]), "Response variable should be numeric."))
+ args <- as.list(environment())
|
- | 448 |
+ 171 |
|
|
- | 449 |
+ 172 |
! |
- teal::validate_has_data(
+ data_extract_list <- list(
|
- | 450 |
+ 173 |
! |
- ANL[, c(regression_var()$response, regression_var()$regressor)], 10,
+ outlier_var = outlier_var,
|
- | 451 |
+ 174 |
! |
- complete = TRUE, allow_inf = FALSE
+ categorical_var = categorical_var
|
- | 452 |
+ 175 |
|
- )
+ )
|
- | 453 |
+ 176 |
|
|
- | 454 |
+ 177 |
! |
- form <- stats::as.formula(
+ ans <- module(
|
- | 455 |
+ 178 |
! |
- paste(
+ label = label,
|
- | 456 |
+ 179 |
! |
- regression_var()$response,
+ server = srv_outliers,
|
- | 457 |
+ 180 |
! |
- paste(
+ server_args = c(
|
- | 458 |
+ 181 |
! |
- regression_var()$regressor,
+ data_extract_list,
|
- | 459 |
+ 182 |
! |
- collapse = " + "
+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)
|
- | 460 |
+ 183 |
|
- ),
+ ),
|
- | 461 |
+ 184 |
! |
- sep = " ~ "
+ ui = ui_outliers,
|
-
- | 462 |
- |
+
+ | 185 |
+ ! |
- )
+ ui_args = args,
|
-
- | 463 |
- |
+
+ | 186 |
+ ! |
- )
+ datanames = teal.transform::get_extract_datanames(data_extract_list)
|
- | 464 |
+ 187 |
|
-
+ )
|
- | 465 |
+ 188 |
! |
- if (input$show_outlier) {
+ attr(ans, "teal_bookmarkable") <- TRUE
|
- | 466 |
+ 189 |
! |
- opts <- teal.transform::variable_choices(ANL)
+ ans
|
-
- | 467 |
- ! |
+
+ | 190 |
+ |
- selected <- if (!is.null(isolate(input$label_var)) && isolate(input$label_var) %in% as.character(opts)) {
+ }
|
-
- | 468 |
- ! |
+
+ | 191 |
+ |
- isolate(input$label_var)
+
|
- | 469 |
+ 192 |
|
- } else {
+ # UI function for the outliers module
|
-
- | 470 |
- ! |
+
+ | 193 |
+ |
- if (length(opts[as.character(opts) == default_outlier_label]) == 0) {
+ ui_outliers <- function(id, ...) {
|
- | 471 |
+ 194 |
! |
- opts[[1]]
+ args <- list(...)
|
-
- | 472 |
- |
+
+ | 195 |
+ ! |
- } else {
+ ns <- NS(id)
|
- | 473 |
+ 196 |
! |
- opts[as.character(opts) == default_outlier_label]
+ is_single_dataset_value <- teal.transform::is_single_dataset(args$outlier_var, args$categorical_var)
|
- | 474 |
+ 197 |
|
- }
+
|
-
- | 475 |
- |
+
+ | 198 |
+ ! |
- }
+ teal.widgets::standard_layout(
|
- | 476 |
+ 199 |
! |
- teal.widgets::updateOptionalSelectInput(
+ output = teal.widgets::white_small_well(
|
- | 477 |
+ 200 |
! |
- session = session,
+ uiOutput(ns("total_outliers")),
|
- | 478 |
+ 201 |
! |
- inputId = "label_var",
+ DT::dataTableOutput(ns("summary_table")),
|
- | 479 |
+ 202 |
! |
- choices = opts,
+ uiOutput(ns("total_missing")),
|
- | 480 |
+ 203 |
! |
- selected = restoreInput(ns("label_var"), selected)
+ tags$br(), tags$hr(),
|
-
- | 481 |
- |
+
+ | 204 |
+ ! |
- )
+ tabsetPanel(
|
-
- | 482 |
- |
+
+ | 205 |
+ ! |
-
+ id = ns("tabs"),
|
- | 483 |
+ 206 |
! |
- data <- fortify(stats::lm(form, data = ANL))
+ tabPanel(
|
- | 484 |
+ 207 |
! |
- cooksd <- data$.cooksd[!is.nan(data$.cooksd)]
+ "Boxplot",
|
- | 485 |
+ 208 |
! |
- max_outlier <- max(ceiling(max(cooksd) / mean(cooksd)), 2)
+ teal.widgets::plot_with_settings_ui(id = ns("box_plot"))
|
-
- | 486 |
- ! |
+
+ | 209 |
+ |
- cur_outlier <- isolate(input$outlier)
+ ),
|
- | 487 |
+ 210 |
! |
- updateSliderInput(
+ tabPanel(
|
- | 488 |
+ 211 |
! |
- session = session,
+ "Density Plot",
|
- | 489 |
+ 212 |
! |
- inputId = "outlier",
+ teal.widgets::plot_with_settings_ui(id = ns("density_plot"))
|
-
- | 490 |
- ! |
+
+ | 213 |
+ |
- min = 1,
+ ),
|
- | 491 |
+ 214 |
! |
- max = max_outlier,
+ tabPanel(
|
- | 492 |
+ 215 |
! |
- value = restoreInput(ns("outlier"), if (cur_outlier < max_outlier) cur_outlier else max_outlier * .9)
+ "Cumulative Distribution Plot",
|
-
- | 493 |
- |
+
+ | 216 |
+ ! |
- )
+ teal.widgets::plot_with_settings_ui(id = ns("cum_density_plot"))
|
- | 494 |
+ 217 |
|
- }
+ )
|
- | 495 |
+ 218 |
|
-
+ ),
|
- | 496 |
+ 219 |
! |
- anl_merged_q() %>%
+ tags$br(), tags$hr(),
|
- | 497 |
+ 220 |
! |
- teal.code::eval_code(substitute(fit <- stats::lm(form, data = ANL), env = list(form = form))) %>%
+ uiOutput(ns("table_ui_wrap")),
|
- | 498 |
+ 221 |
! |
- teal.code::eval_code(quote({
+ DT::dataTableOutput(ns("table_ui"))
|
-
- | 499 |
- ! |
+
+ | 222 |
+ |
- for (regressor in names(fit$contrasts)) {
+ ),
|
- | 500 |
+ 223 |
! |
- alts <- paste0(levels(ANL[[regressor]]), collapse = "|")
+ encoding = tags$div(
|
-
- | 501 |
- ! |
+
+ | 224 |
+ |
- names(fit$coefficients) <- gsub(
+ ### Reporter
|
- | 502 |
+ 225 |
! |
- paste0("^(", regressor, ")(", alts, ")$"), paste0("\\1", ": ", "\\2"), names(fit$coefficients)
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
- | 503 |
+ 226 |
|
- )
+ ###
|
-
- | 504 |
- |
-
- }
+ |
+ | 227 |
+ ! |
+
+ tags$label("Encodings", class = "text-primary"),
|
-
- | 505 |
- |
+
+ | 228 |
+ ! |
- })) %>%
+ teal.transform::datanames_input(args[c("outlier_var", "categorical_var")]),
|
- | 506 |
+ 229 |
! |
- teal.code::eval_code(quote(summary(fit)))
+ teal.transform::data_extract_ui(
|
-
- | 507 |
- |
+
+ | 230 |
+ ! |
- })
+ id = ns("outlier_var"),
|
-
- | 508 |
- |
+
+ | 231 |
+ ! |
-
+ label = "Variable",
|
- | 509 |
+ 232 |
! |
- label_col <- reactive({
+ data_extract_spec = args$outlier_var,
|
- | 510 |
+ 233 |
! |
- teal::validate_inputs(iv_out)
+ is_single_dataset = is_single_dataset_value
|
- | 511 |
+ 234 |
|
-
+ ),
|
- | 512 |
+ 235 |
! |
- substitute(
+ if (!is.null(args$categorical_var)) {
|
- | 513 |
+ 236 |
! |
- expr = dplyr::if_else(
+ teal.transform::data_extract_ui(
|
- | 514 |
+ 237 |
! |
- data$.cooksd > outliers * mean(data$.cooksd, na.rm = TRUE),
+ id = ns("categorical_var"),
|
- | 515 |
+ 238 |
! |
- as.character(stats::na.omit(ANL)[[label_var]]),
+ label = "Categorical factor",
+ |
+
+
+ | 239 |
+ ! |
+
+ data_extract_spec = args$categorical_var,
+ |
+
+
+ | 240 |
+ ! |
+
+ is_single_dataset = is_single_dataset_value
|
- | 516 |
+ 241 |
|
- ""
+ )
|
- | 517 |
+ 242 |
|
- ) %>%
+ },
|
- | 518 |
+ 243 |
! |
- dplyr::if_else(is.na(.), "cooksd == NaN", .),
+ conditionalPanel(
|
- | 519 |
+ 244 |
! |
- env = list(outliers = input$outlier, label_var = input$label_var)
+ condition = paste0("input['", ns("tabs"), "'] == 'Boxplot'"),
|
-
- | 520 |
- |
+
+ | 245 |
+ ! |
- )
+ teal.widgets::optionalSelectInput(
|
-
- | 521 |
- |
+
+ | 246 |
+ ! |
- })
+ inputId = ns("boxplot_alts"),
|
-
- | 522 |
- |
+
+ | 247 |
+ ! |
-
+ label = "Plot type",
|
- | 523 |
+ 248 |
! |
- label_min_segment <- reactive({
+ choices = c("Box plot", "Violin plot"),
|
- | 524 |
+ 249 |
! |
- input$label_min_segment
+ selected = "Box plot",
+ |
+
+
+ | 250 |
+ ! |
+
+ multiple = FALSE
|
- | 525 |
+ 251 |
|
- })
+ )
|
- | 526 |
+ 252 |
|
-
+ ),
|
- | 527 |
+ 253 |
! |
- outlier_label <- reactive({
+ shinyjs::hidden(checkboxInput(ns("split_outliers"), "Define outliers based on group splitting", value = FALSE)),
|
- | 528 |
+ 254 |
! |
- substitute(
+ shinyjs::hidden(checkboxInput(ns("order_by_outlier"), "Re-order categories by outliers [by %]", value = FALSE)),
|
- | 529 |
+ 255 |
! |
- expr = ggrepel::geom_text_repel(
+ teal.widgets::panel_group(
|
- | 530 |
+ 256 |
! |
- label = label_col,
+ teal.widgets::panel_item(
|
- | 531 |
+ 257 |
! |
- color = "red",
+ title = "Method parameters",
|
- | 532 |
+ 258 |
! |
- hjust = 0,
+ collapsed = FALSE,
|
- | 533 |
+ 259 |
! |
- vjust = 1,
+ teal.widgets::optionalSelectInput(
|
- | 534 |
+ 260 |
! |
- max.overlaps = Inf,
+ inputId = ns("method"),
|
- | 535 |
+ 261 |
! |
- min.segment.length = label_min_segment,
+ label = "Method",
|
- | 536 |
+ 262 |
! |
- segment.alpha = 0.5,
+ choices = c("IQR", "Z-score", "Percentile"),
|
- | 537 |
+ 263 |
! |
- seed = 123
- |
-
-
- | 538 |
- |
-
- ),
+ selected = "IQR",
|
- | 539 |
+ 264 |
! |
- env = list(label_col = label_col(), label_min_segment = label_min_segment())
- |
-
-
- | 540 |
- |
-
- )
- |
-
-
- | 541 |
- |
-
- })
+ multiple = FALSE
|
- | 542 |
+ 265 |
|
-
+ ),
|
- | 543 |
+ 266 |
! |
- output_q <- reactive({
+ conditionalPanel(
|
- | 544 |
+ 267 |
! |
- alpha <- input$alpha
+ condition =
|
- | 545 |
+ 268 |
! |
- size <- input$size
+ paste0("input['", ns("method"), "'] == 'IQR'"),
|
- | 546 |
+ 269 |
! |
- ggtheme <- input$ggtheme
+ sliderInput(
|
- | 547 |
+ 270 |
! |
- input_type <- input$plot_type
+ ns("iqr_slider"),
|
- | 548 |
+ 271 |
! |
- show_outlier <- input$show_outlier
- |
-
-
- | 549 |
- |
-
-
+ "Outlier range:",
|
- | 550 |
+ 272 |
! |
- teal::validate_inputs(iv_r())
- |
-
-
- | 551 |
- |
-
-
+ min = 1,
|
- | 552 |
+ 273 |
! |
- plot_type_0 <- function() {
+ max = 5,
|
- | 553 |
+ 274 |
! |
- fit <- fit_r()[["fit"]]
+ value = 3,
|
- | 554 |
+ 275 |
! |
- ANL <- anl_merged_q()[["ANL"]]
+ step = 0.5
|
- | 555 |
+ 276 |
|
-
- |
-
-
- | 556 |
- ! |
-
- stopifnot(ncol(fit$model) == 2)
+ )
|
- | 557 |
+ 277 |
|
-
- |
-
-
- | 558 |
- ! |
-
- if (!is.factor(ANL[[regression_var()$regressor]])) {
+ ),
|
- | 559 |
+ 278 |
! |
- shinyjs::show("size")
+ conditionalPanel(
|
- | 560 |
+ 279 |
! |
- shinyjs::show("alpha")
+ condition =
|
- | 561 |
+ 280 |
! |
- plot <- substitute(
+ paste0("input['", ns("method"), "'] == 'Z-score'"),
|
- | 562 |
+ 281 |
! |
- env = list(
+ sliderInput(
|
- | 563 |
+ 282 |
! |
- regressor = regression_var()$regressor,
+ ns("zscore_slider"),
|
- | 564 |
+ 283 |
! |
- response = regression_var()$response,
+ "Outlier range:",
|
- | 565 |
+ 284 |
! |
- size = size,
+ min = 1,
|
- | 566 |
+ 285 |
! |
- alpha = alpha
- |
-
-
- | 567 |
- |
-
- ),
+ max = 5,
|
- | 568 |
+ 286 |
! |
- expr = ggplot(
+ value = 3,
|
- | 569 |
+ 287 |
! |
- fit$model[, 2:1],
+ step = 0.5
|
-
- | 570 |
- ! |
+
+ | 288 |
+ |
- aes_string(regressor, response)
+ )
|
- | 571 |
+ 289 |
|
- ) +
+ ),
|
- | 572 |
+ 290 |
! |
- geom_point(size = size, alpha = alpha) +
+ conditionalPanel(
|
- | 573 |
+ 291 |
! |
- stat_smooth(
+ condition =
|
- | 574 |
+ 292 |
! |
- method = "lm",
+ paste0("input['", ns("method"), "'] == 'Percentile'"),
|
- | 575 |
+ 293 |
! |
- formula = y ~ x,
+ sliderInput(
|
- | 576 |
+ 294 |
! |
- se = FALSE
- |
-
-
- | 577 |
- |
-
- )
+ ns("percentile_slider"),
|
-
- | 578 |
- |
+
+ | 295 |
+ ! |
- )
+ "Outlier range:",
|
- | 579 |
+ 296 |
! |
- if (show_outlier) {
+ min = 0.001,
|
- | 580 |
+ 297 |
! |
- plot <- substitute(
+ max = 0.5,
|
- | 581 |
+ 298 |
! |
- expr = plot + outlier_label,
+ value = 0.01,
|
- | 582 |
+ 299 |
! |
- env = list(plot = plot, outlier_label = outlier_label())
+ step = 0.001
|
- | 583 |
+ 300 |
|
)
|
- | 584 |
+ 301 |
|
- }
+ ),
+ |
+
+
+ | 302 |
+ ! |
+
+ uiOutput(ns("ui_outlier_help"))
|
- | 585 |
+ 303 |
|
- } else {
+ )
|
-
- | 586 |
- ! |
+
+ | 304 |
+ |
- shinyjs::hide("size")
+ ),
|
- | 587 |
+ 305 |
! |
- shinyjs::hide("alpha")
+ teal.widgets::panel_item(
|
- | 588 |
+ 306 |
! |
- plot <- substitute(
+ title = "Plot settings",
|
- | 589 |
+ 307 |
! |
- expr = ggplot(fit$model[, 2:1], aes_string(regressor, response)) +
+ selectInput(
|
- | 590 |
+ 308 |
! |
- geom_boxplot(),
+ inputId = ns("ggtheme"),
|
- | 591 |
+ 309 |
! |
- env = list(regressor = regression_var()$regressor, response = regression_var()$response)
+ label = "Theme (by ggplot):",
|
-
- | 592 |
- |
+
+ | 310 |
+ ! |
- )
+ choices = ggplot_themes,
|
- | 593 |
+ 311 |
! |
- if (show_outlier) {
+ selected = args$ggtheme,
|
- | 594 |
+ 312 |
! |
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))
+ multiple = FALSE
|
- | 595 |
+ 313 |
|
- }
+ )
|
- | 596 |
+ 314 |
|
- }
+ )
|
- | 597 |
+ 315 |
|
-
+ ),
|
- | 598 |
+ 316 |
! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
+ forms = tagList(
|
- | 599 |
+ 317 |
! |
- teal.widgets::resolve_ggplot2_args(
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
-
- | 600 |
- ! |
+
+ | 318 |
+ |
- user_plot = ggplot2_args[["Response vs Regressor"]],
+ ),
|
- | 601 |
+ 319 |
! |
- user_default = ggplot2_args$default,
+ pre_output = args$pre_output,
|
- | 602 |
+ 320 |
! |
- module_plot = teal.widgets::ggplot2_args(
+ post_output = args$post_output
|
-
- | 603 |
- ! |
+
+ | 321 |
+ |
- labs = list(
+ )
|
-
- | 604 |
- ! |
+
+ | 322 |
+ |
- title = "Response vs Regressor",
- |
-
-
- | 605 |
- ! |
-
- x = varname_w_label(regression_var()$regressor, ANL),
- |
-
-
- | 606 |
- ! |
-
- y = varname_w_label(regression_var()$response, ANL)
- |
-
-
- | 607 |
- |
-
- ),
- |
-
-
- | 608 |
- ! |
-
- theme = list()
+ }
|
- | 609 |
+ 323 |
|
- )
+
|
- | 610 |
+ 324 |
|
- ),
- |
-
-
- | 611 |
- ! |
-
- ggtheme = ggtheme
+ # Server function for the outliers module
|
- | 612 |
+ 325 |
|
- )
+ srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var,
|
- | 613 |
+ 326 |
|
-
- |
-
-
- | 614 |
- ! |
-
- teal.code::eval_code(
- |
-
-
- | 615 |
- ! |
-
- fit_r(),
+ categorical_var, plot_height, plot_width, ggplot2_args) {
|
- | 616 |
+ 327 |
! |
- substitute(
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
|
- | 617 |
+ 328 |
! |
- expr = {
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
|
- | 618 |
+ 329 |
! |
- class(fit$residuals) <- NULL
+ checkmate::assert_class(data, "reactive")
|
- | 619 |
+ 330 |
! |
- data <- fortify(fit)
+ checkmate::assert_class(isolate(data()), "teal_data")
|
- | 620 |
+ 331 |
! |
- g <- plot
+ moduleServer(id, function(input, output, session) {
|
- | 621 |
+ 332 |
! |
- print(g)
+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
|
- | 622 |
+ 333 |
|
- },
- |
-
-
- | 623 |
- ! |
-
- env = list(
+
|
- | 624 |
+ 334 |
! |
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
- |
-
-
- | 625 |
- |
-
- )
- |
-
-
- | 626 |
- |
-
- )
+ ns <- session$ns
|
- | 627 |
+ 335 |
|
- )
+
|
-
- | 628 |
- |
+
+ | 336 |
+ ! |
- }
+ vars <- list(outlier_var = outlier_var, categorical_var = categorical_var)
|
- | 629 |
+ 337 |
|
|
- | 630 |
+ 338 |
! |
- plot_base <- function() {
+ rule_diff <- function(other) {
|
- | 631 |
+ 339 |
! |
- base_fit <- fit_r()
+ function(value) {
|
- | 632 |
+ 340 |
! |
- teal.code::eval_code(
+ othervalue <- tryCatch(selector_list()[[other]]()[["select"]], error = function(e) NULL)
|
- | 633 |
+ 341 |
! |
- base_fit,
+ if (!is.null(othervalue) && identical(othervalue, value)) {
|
- | 634 |
+ 342 |
! |
- quote({
+ "`Variable` and `Categorical factor` cannot be the same"
|
-
- | 635 |
- ! |
+
+ | 343 |
+ |
- class(fit$residuals) <- NULL
+ }
|
- | 636 |
+ 344 |
|
-
+ }
|
-
- | 637 |
- ! |
+
+ | 345 |
+ |
- data <- ggplot2::fortify(fit)
+ }
|
- | 638 |
+ 346 |
|
|
- | 639 |
+ 347 |
! |
- smooth <- function(x, y) {
+ selector_list <- teal.transform::data_extract_multiple_srv(
|
- | 640 |
+ 348 |
! |
- as.data.frame(stats::lowess(x, y, f = 2 / 3, iter = 3))
+ data_extract = vars,
|
-
- | 641 |
- |
+
+ | 349 |
+ ! |
- }
+ datasets = data,
|
-
- | 642 |
- |
+
+ | 350 |
+ ! |
-
+ select_validation_rule = list(
|
- | 643 |
+ 351 |
! |
- smoothy_aes <- ggplot2::aes_string(x = "x", y = "y")
+ outlier_var = shinyvalidate::compose_rules(
|
-
- | 644 |
- |
+
+ | 352 |
+ ! |
-
+ shinyvalidate::sv_required("Please select a variable"),
|
- | 645 |
+ 353 |
! |
- reg_form <- deparse(fit$call[[2]])
+ rule_diff("categorical_var")
|
- | 646 |
+ 354 |
|
- })
+ ),
+ |
+
+
+ | 355 |
+ ! |
+
+ categorical_var = rule_diff("outlier_var")
|
- | 647 |
+ 356 |
|
- )
+ )
|
- | 648 |
+ 357 |
|
- }
+ )
|
- | 649 |
+ 358 |
|
|
- | 650 |
+ 359 |
! |
- plot_type_1 <- function(plot_base) {
+ iv_r <- reactive({
|
- | 651 |
+ 360 |
! |
- shinyjs::show("size")
+ iv <- shinyvalidate::InputValidator$new()
|
- | 652 |
+ 361 |
! |
- shinyjs::show("alpha")
+ iv$add_rule("method", shinyvalidate::sv_required("Please select a method"))
|
- | 653 |
+ 362 |
! |
- plot <- substitute(
+ iv$add_rule("boxplot_alts", shinyvalidate::sv_required("Please select Plot Type"))
|
- | 654 |
+ 363 |
! |
- expr = ggplot(data = data, aes(.fitted, .resid)) +
+ teal.transform::compose_and_enable_validators(iv, selector_list)
|
-
- | 655 |
- ! |
+
+ | 364 |
+ |
- geom_point(size = size, alpha = alpha) +
+ })
+ |
+
+
+ | 365 |
+ |
+
+
|
- | 656 |
+ 366 |
! |
- geom_hline(yintercept = 0, linetype = "dashed", size = 1) +
+ reactive_select_input <- reactive({
|
- | 657 |
+ 367 |
! |
- geom_line(data = smoothy, mapping = smoothy_aes),
+ if (is.null(selector_list()$categorical_var) || length(selector_list()$categorical_var()$select) == 0) {
|
- | 658 |
+ 368 |
! |
- env = list(size = size, alpha = alpha)
+ selector_list()[names(selector_list()) != "categorical_var"]
|
- | 659 |
+ 369 |
|
- )
+ } else {
|
- | 660 |
+ 370 |
! |
- if (show_outlier) {
+ selector_list()
|
-
- | 661 |
- ! |
+
+ | 371 |
+ |
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))
+ }
|
- | 662 |
+ 372 |
|
- }
+ })
|
- | 663 |
+ 373 |
|
|
- | 664 |
+ 374 |
! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
+ anl_merged_input <- teal.transform::merge_expression_srv(
|
- | 665 |
+ 375 |
! |
- teal.widgets::resolve_ggplot2_args(
+ selector_list = reactive_select_input,
|
- | 666 |
+ 376 |
! |
- user_plot = ggplot2_args[["Residuals vs Fitted"]],
+ datasets = data,
|
- | 667 |
+ 377 |
! |
- user_default = ggplot2_args$default,
+ merge_function = "dplyr::inner_join"
|
-
- | 668 |
- ! |
+
+ | 378 |
+ |
- module_plot = teal.widgets::ggplot2_args(
+ )
+ |
+
+
+ | 379 |
+ |
+
+
|
- | 669 |
+ 380 |
! |
- labs = list(
+ anl_merged_q <- reactive({
|
- | 670 |
+ 381 |
! |
- x = quote(paste0("Fitted values\nlm(", reg_form, ")")),
+ req(anl_merged_input())
|
- | 671 |
+ 382 |
! |
- y = "Residuals",
+ data() %>%
|
- | 672 |
+ 383 |
! |
- title = "Residuals vs Fitted"
+ teal.code::eval_code(as.expression(anl_merged_input()$expr))
|
- | 673 |
+ 384 |
|
- )
+ })
|
- | 674 |
+ 385 |
|
- )
+
|
-
- | 675 |
- |
+
+ | 386 |
+ ! |
- ),
+ merged <- list(
|
- | 676 |
+ 387 |
! |
- ggtheme = ggtheme
+ anl_input_r = anl_merged_input,
|
-
- | 677 |
- |
+
+ | 388 |
+ ! |
- )
+ anl_q_r = anl_merged_q
|
- | 678 |
+ 389 |
|
-
+ )
|
-
- | 679 |
- ! |
+
+ | 390 |
+ |
- teal.code::eval_code(
+
|
- | 680 |
+ 391 |
! |
- plot_base,
+ n_outlier_missing <- reactive({
|
- | 681 |
+ 392 |
! |
- substitute(
+ req(iv_r()$is_valid())
|
- | 682 |
+ 393 |
! |
- expr = {
+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)
|
- | 683 |
+ 394 |
! |
- smoothy <- smooth(data$.fitted, data$.resid)
+ ANL <- merged$anl_q_r()[["ANL"]]
|
- | 684 |
+ 395 |
! |
- g <- plot
+ sum(is.na(ANL[[outlier_var]]))
|
-
- | 685 |
- ! |
+
+ | 396 |
+ |
- print(g)
+ })
|
- | 686 |
+ 397 |
|
- },
+
|
-
- | 687 |
- ! |
+
+ | 398 |
+ |
- env = list(
+ # Used to create outlier table and the dropdown with additional columns
|
- | 688 |
+ 399 |
! |
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
- |
-
-
- | 689 |
- |
-
- )
+ dataname_first <- isolate(teal.data::datanames(data())[[1]])
|
- | 690 |
+ 400 |
|
- )
+
|
-
- | 691 |
- |
+
+ | 401 |
+ ! |
- )
+ common_code_q <- reactive({
|
-
- | 692 |
- |
+
+ | 402 |
+ ! |
- }
+ req(iv_r()$is_valid())
|
- | 693 |
+ 403 |
|
|
- | 694 |
+ 404 |
! |
- plot_type_2 <- function(plot_base) {
+ ANL <- merged$anl_q_r()[["ANL"]]
|
- | 695 |
+ 405 |
! |
- shinyjs::show("size")
+ qenv <- merged$anl_q_r()
+ |
+
+
+ | 406 |
+ |
+
+
|
- | 696 |
+ 407 |
! |
- shinyjs::show("alpha")
+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)
|
- | 697 |
+ 408 |
! |
- plot <- substitute(
+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)
|
- | 698 |
+ 409 |
! |
- expr = ggplot(data = data, aes(sample = .stdresid)) +
+ order_by_outlier <- input$order_by_outlier
|
- | 699 |
+ 410 |
! |
- stat_qq(size = size, alpha = alpha) +
+ method <- input$method
|
- | 700 |
+ 411 |
! |
- geom_abline(linetype = "dashed"),
+ split_outliers <- input$split_outliers
|
- | 701 |
+ 412 |
! |
- env = list(size = size, alpha = alpha)
+ teal::validate_has_data(
|
- | 702 |
+ 413 |
|
- )
+ # missing values in the categorical variable may be used to form a category of its own
|
- | 703 |
+ 414 |
! |
- if (show_outlier) {
+ `if`(
|
- | 704 |
+ 415 |
! |
- plot <- substitute(
+ length(categorical_var) == 0,
|
- | 705 |
+ 416 |
! |
- expr = plot +
+ ANL,
|
- | 706 |
+ 417 |
! |
- stat_qq(
+ ANL[, names(ANL) != categorical_var, drop = FALSE]
|
-
- | 707 |
- ! |
+
+ | 418 |
+ |
- geom = ggrepel::GeomTextRepel,
+ ),
|
- | 708 |
+ 419 |
! |
- label = label_col %>%
+ min_nrow = 10,
|
- | 709 |
+ 420 |
! |
- data.frame(label = .) %>%
+ complete = TRUE,
|
- | 710 |
+ 421 |
! |
- dplyr::filter(label != "cooksd == NaN") %>%
+ allow_inf = FALSE
+ |
+
+
+ | 422 |
+ |
+
+ )
|
- | 711 |
+ 423 |
! |
- unlist(),
+ validate(need(is.numeric(ANL[[outlier_var]]), "`Variable` is not numeric"))
|
- | 712 |
+ 424 |
! |
- color = "red",
+ validate(need(length(unique(ANL[[outlier_var]])) > 1, "Variable has no variation, i.e. only one unique value"))
+ |
+
+
+ | 425 |
+ |
+
+
+ |
+
+
+ | 426 |
+ |
+
+ # show/hide split_outliers
|
- | 713 |
+ 427 |
! |
- hjust = 0,
+ if (length(categorical_var) == 0) {
|
- | 714 |
+ 428 |
! |
- vjust = 0,
+ shinyjs::hide("split_outliers")
|
- | 715 |
+ 429 |
! |
- max.overlaps = Inf,
+ if (n_outlier_missing() > 0) {
|
- | 716 |
+ 430 |
! |
- min.segment.length = label_min_segment,
+ qenv <- teal.code::eval_code(
|
- | 717 |
+ 431 |
! |
- segment.alpha = .5,
+ qenv,
|
- | 718 |
+ 432 |
! |
- seed = 123
+ substitute(
|
-
- | 719 |
- |
+
+ | 433 |
+ ! |
- ),
+ expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)),
|
- | 720 |
+ 434 |
! |
- env = list(plot = plot, label_col = label_col(), label_min_segment = label_min_segment())
+ env = list(outlier_var_name = as.name(outlier_var))
|
- | 721 |
+ 435 |
+ |
+
+ )
+ |
+
+
+ | 436 |
|
)
|
- | 722 |
+ 437 |
|
}
|
- | 723 |
+ 438 |
|
-
+ } else {
|
- | 724 |
+ 439 |
! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
+ validate(need(
|
- | 725 |
+ 440 |
! |
- teal.widgets::resolve_ggplot2_args(
+ is.factor(ANL[[categorical_var]]) ||
|
- | 726 |
+ 441 |
! |
- user_plot = ggplot2_args[["Normal Q-Q"]],
+ is.character(ANL[[categorical_var]]) ||
|
- | 727 |
+ 442 |
! |
- user_default = ggplot2_args$default,
+ is.integer(ANL[[categorical_var]]),
|
- | 728 |
+ 443 |
! |
- module_plot = teal.widgets::ggplot2_args(
+ "`Categorical factor` must be `factor`, `character`, or `integer`"
+ |
+
+
+ | 444 |
+ |
+
+ ))
+ |
+
+
+ | 445 |
+ |
+
+
|
- | 729 |
+ 446 |
! |
- labs = list(
+ if (n_outlier_missing() > 0) {
|
- | 730 |
+ 447 |
! |
- x = quote(paste0("Theoretical Quantiles\nlm(", reg_form, ")")),
+ qenv <- teal.code::eval_code(
|
- | 731 |
+ 448 |
! |
- y = "Standardized residuals",
+ qenv,
|
- | 732 |
+ 449 |
! |
- title = "Normal Q-Q"
+ substitute(
+ |
+
+
+ | 450 |
+ ! |
+
+ expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)),
+ |
+
+
+ | 451 |
+ ! |
+
+ env = list(outlier_var_name = as.name(outlier_var))
|
- | 733 |
+ 452 |
|
- )
+ )
|
- | 734 |
+ 453 |
|
- )
+ )
|
- | 735 |
+ 454 |
|
- ),
+ }
|
- | 736 |
+ 455 |
! |
- ggtheme = ggtheme
+ shinyjs::show("split_outliers")
|
- | 737 |
+ 456 |
|
- )
+ }
|
- | 738 |
+ 457 |
|
|
+
+ | 458 |
+ |
+
+ # slider
+ |
+
- | 739 |
+ 459 |
! |
- teal.code::eval_code(
+ outlier_definition_param <- if (method == "IQR") {
|
- | 740 |
+ 460 |
! |
- plot_base,
+ input$iqr_slider
|
- | 741 |
+ 461 |
! |
- substitute(
+ } else if (method == "Z-score") {
|
- | 742 |
+ 462 |
! |
- expr = {
+ input$zscore_slider
|
- | 743 |
+ 463 |
! |
- g <- plot
+ } else if (method == "Percentile") {
|
- | 744 |
+ 464 |
! |
- print(g)
+ input$percentile_slider
|
- | 745 |
+ 465 |
|
- },
+ }
+ |
+
+
+ | 466 |
+ |
+
+
+ |
+
+
+ | 467 |
+ |
+
+ # this is utils function that converts a %>% NULL %>% b into a %>% b
|
- | 746 |
+ 468 |
! |
- env = list(
+ remove_pipe_null <- function(x) {
|
- | 747 |
+ 469 |
! |
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ if (length(x) == 1) {
|
-
- | 748 |
- |
+
+ | 470 |
+ ! |
- )
+ return(x)
|
- | 749 |
+ 471 |
|
- )
+ }
+ |
+
+
+ | 472 |
+ ! |
+
+ if (identical(x[[1]], as.name("%>%")) && is.null(x[[3]])) {
+ |
+
+
+ | 473 |
+ ! |
+
+ return(remove_pipe_null(x[[2]]))
|
- | 750 |
+ 474 |
|
- )
+ }
+ |
+
+
+ | 475 |
+ ! |
+
+ return(as.call(c(x[[1]], lapply(x[-1], remove_pipe_null))))
|
- | 751 |
+ 476 |
|
}
|
- | 752 |
+ 477 |
|
|
- | 753 |
+ 478 |
! |
- plot_type_3 <- function(plot_base) {
+ qenv <- teal.code::eval_code(
|
- | 754 |
+ 479 |
! |
- shinyjs::show("size")
+ qenv,
|
- | 755 |
+ 480 |
! |
- shinyjs::show("alpha")
+ substitute(
|
- | 756 |
+ 481 |
! |
- plot <- substitute(
+ expr = {
|
- | 757 |
+ 482 |
! |
- expr = ggplot(data = data, aes(.fitted, sqrt(abs(.stdresid)))) +
+ ANL_OUTLIER <- ANL %>%
|
- | 758 |
+ 483 |
! |
- geom_point(size = size, alpha = alpha) +
+ group_expr %>% # styler: off
|
- | 759 |
+ 484 |
! |
- geom_line(data = smoothy, mapping = smoothy_aes),
+ dplyr::mutate(is_outlier = {
|
- | 760 |
+ 485 |
! |
- env = list(size = size, alpha = alpha)
- |
-
-
- | 761 |
- |
-
- )
+ q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75))
|
- | 762 |
+ 486 |
! |
- if (show_outlier) {
+ iqr <- q1_q3[2] - q1_q3[1]
|
- | 763 |
+ 487 |
! |
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))
+ !(outlier_var_name >= q1_q3[1] - 1.5 * iqr & outlier_var_name <= q1_q3[2] + 1.5 * iqr)
|
- | 764 |
+ 488 |
|
- }
+ }) %>%
|
-
- | 765 |
- |
+
+ | 489 |
+ ! |
-
+ calculate_outliers %>% # styler: off
|
- | 766 |
+ 490 |
! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
+ ungroup_expr %>% # styler: off
|
- | 767 |
+ 491 |
! |
- teal.widgets::resolve_ggplot2_args(
+ dplyr::filter(is_outlier | is_outlier_selected) %>%
|
- | 768 |
+ 492 |
! |
- user_plot = ggplot2_args[["Scale-Location"]],
+ dplyr::select(-is_outlier)
|
-
- | 769 |
- ! |
+
+ | 493 |
+ |
- user_default = ggplot2_args$default,
+ },
|
- | 770 |
+ 494 |
! |
- module_plot = teal.widgets::ggplot2_args(
+ env = list(
|
- | 771 |
+ 495 |
! |
- labs = list(
+ calculate_outliers = if (method == "IQR") {
|
- | 772 |
+ 496 |
! |
- x = quote(paste0("Fitted values\nlm(", reg_form, ")")),
+ substitute(
|
- | 773 |
+ 497 |
! |
- y = quote(expression(sqrt(abs(`Standardized residuals`)))),
+ expr = dplyr::mutate(is_outlier_selected = {
|
- | 774 |
+ 498 |
! |
- title = "Scale-Location"
+ q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75))
|
-
- | 775 |
- |
+
+ | 499 |
+ ! |
- )
+ iqr <- q1_q3[2] - q1_q3[1]
|
- | 776 |
+ 500 |
|
- )
+ !(
|
-
- | 777 |
- |
+
+ | 501 |
+ ! |
- ),
+ outlier_var_name >= q1_q3[1] - outlier_definition_param * iqr &
|
- | 778 |
+ 502 |
! |
- ggtheme = ggtheme
+ outlier_var_name <= q1_q3[2] + outlier_definition_param * iqr
|
- | 779 |
+ 503 |
|
- )
+ )
|
- | 780 |
+ 504 |
|
-
+ }),
|
- | 781 |
+ 505 |
! |
- teal.code::eval_code(
+ env = list(
|
- | 782 |
+ 506 |
! |
- plot_base,
+ outlier_var_name = as.name(outlier_var),
|
- | 783 |
+ 507 |
! |
- substitute(
+ outlier_definition_param = outlier_definition_param
|
-
- | 784 |
- ! |
+
+ | 508 |
+ |
- expr = {
+ )
|
-
- | 785 |
- ! |
+
+ | 509 |
+ |
- smoothy <- smooth(data$.fitted, sqrt(abs(data$.stdresid)))
+ )
|
- | 786 |
+ 510 |
! |
- g <- plot
+ } else if (method == "Z-score") {
|
- | 787 |
+ 511 |
! |
- print(g)
+ substitute(
|
-
- | 788 |
- |
+
+ | 512 |
+ ! |
- },
+ expr = dplyr::mutate(
|
- | 789 |
+ 513 |
! |
- env = list(
+ is_outlier_selected = abs(outlier_var_name - mean(outlier_var_name)) /
|
- | 790 |
+ 514 |
! |
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ stats::sd(outlier_var_name) > outlier_definition_param
|
- | 791 |
+ 515 |
|
- )
+ ),
|
-
- | 792 |
- |
+
+ | 516 |
+ ! |
- )
+ env = list(
|
-
- | 793 |
- |
+
+ | 517 |
+ ! |
- )
+ outlier_var_name = as.name(outlier_var),
+ |
+
+
+ | 518 |
+ ! |
+
+ outlier_definition_param = outlier_definition_param
|
- | 794 |
+ 519 |
|
- }
+ )
|
- | 795 |
+ 520 |
|
-
+ )
|
- | 796 |
+ 521 |
! |
- plot_type_4 <- function(plot_base) {
+ } else if (method == "Percentile") {
|
- | 797 |
+ 522 |
! |
- shinyjs::hide("size")
+ substitute(
|
- | 798 |
+ 523 |
! |
- shinyjs::show("alpha")
+ expr = dplyr::mutate(
|
- | 799 |
+ 524 |
! |
- plot <- substitute(
+ is_outlier_selected = outlier_var_name < stats::quantile(outlier_var_name, outlier_definition_param) |
|
- | 800 |
+ 525 |
! |
- expr = ggplot(data = data, aes(seq_along(.cooksd), .cooksd)) +
+ outlier_var_name > stats::quantile(outlier_var_name, 1 - outlier_definition_param)
+ |
+
+
+ | 526 |
+ |
+
+ ),
|
- | 801 |
+ 527 |
! |
- geom_col(alpha = alpha),
+ env = list(
|
- | 802 |
+ 528 |
! |
- env = list(alpha = alpha)
+ outlier_var_name = as.name(outlier_var),
+ |
+
+
+ | 529 |
+ ! |
+
+ outlier_definition_param = outlier_definition_param
|
- | 803 |
+ 530 |
|
- )
+ )
|
-
- | 804 |
- ! |
+
+ | 531 |
+ |
- if (show_outlier) {
+ )
|
-
- | 805 |
- ! |
+
+ | 532 |
+ |
- plot <- substitute(
+ },
|
- | 806 |
+ 533 |
! |
- expr = plot +
+ outlier_var_name = as.name(outlier_var),
|
- | 807 |
+ 534 |
! |
- geom_hline(
+ group_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
|
- | 808 |
+ 535 |
! |
- yintercept = c(
+ substitute(dplyr::group_by(x), list(x = as.name(categorical_var)))
+ |
+
+
+ | 536 |
+ |
+
+ },
|
- | 809 |
+ 537 |
! |
- outlier * mean(data$.cooksd, na.rm = TRUE),
+ ungroup_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
|
- | 810 |
+ 538 |
! |
- mean(data$.cooksd, na.rm = TRUE)
+ substitute(dplyr::ungroup())
|
- | 811 |
+ 539 |
|
- ),
+ }
|
-
- | 812 |
- ! |
+
+ | 540 |
+ |
- color = "red",
+ )
+ |
+
+
+ | 541 |
+ |
+
+ ) %>%
|
- | 813 |
+ 542 |
! |
- linetype = "dashed"
+ remove_pipe_null()
|
- | 814 |
+ 543 |
|
- ) +
+ )
+ |
+
+
+ | 544 |
+ |
+
+
+ |
+
+
+ | 545 |
+ |
+
+ # ANL_OUTLIER_EXTENDED is the base table
|
- | 815 |
+ 546 |
! |
- geom_text(
+ qenv <- teal.code::eval_code(
|
- | 816 |
+ 547 |
! |
- aes(
+ qenv,
|
- | 817 |
+ 548 |
! |
- x = 0,
+ substitute(
|
- | 818 |
+ 549 |
! |
- y = mean(data$.cooksd, na.rm = TRUE),
+ expr = {
|
- | 819 |
+ 550 |
! |
- label = paste("mu", "=", round(mean(data$.cooksd, na.rm = TRUE), 4)),
+ ANL_OUTLIER_EXTENDED <- dplyr::left_join(
|
- | 820 |
+ 551 |
! |
- vjust = -1,
+ ANL_OUTLIER,
|
- | 821 |
+ 552 |
! |
- hjust = 0,
+ dplyr::select(
|
- | 822 |
+ 553 |
! |
- color = "red",
+ dataname,
|
- | 823 |
+ 554 |
! |
- angle = 90
+ dplyr::setdiff(names(dataname), dplyr::setdiff(names(ANL_OUTLIER), join_keys))
|
- | 824 |
+ 555 |
|
- ),
+ ),
|
- | 825 |
+ 556 |
! |
- parse = TRUE,
+ by = join_keys
|
-
- | 826 |
- ! |
+
+ | 557 |
+ |
- show.legend = FALSE
+ )
|
- | 827 |
+ 558 |
|
- ) +
+ },
|
- | 828 |
+ 559 |
! |
- outlier_label,
+ env = list(
|
- | 829 |
+ 560 |
! |
- env = list(plot = plot, outlier = input$outlier, outlier_label = outlier_label())
+ dataname = as.name(dataname_first),
|
-
- | 830 |
- |
+
+ | 561 |
+ ! |
- )
+ join_keys = as.character(teal.data::join_keys(data())[dataname_first, dataname_first])
|
- | 831 |
+ 562 |
|
- }
+ )
|
- | 832 |
+ 563 |
|
-
+ )
|
-
- | 833 |
- ! |
+
+ | 564 |
+ |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
+ )
|
-
- | 834 |
- ! |
+
+ | 565 |
+ |
- teal.widgets::resolve_ggplot2_args(
+
|
- | 835 |
+ 566 |
! |
- user_plot = ggplot2_args[["Cook's distance"]],
+ if (length(categorical_var) > 0) {
|
- | 836 |
+ 567 |
! |
- user_default = ggplot2_args$default,
+ qenv <- teal.code::eval_code(
|
- | 837 |
+ 568 |
! |
- module_plot = teal.widgets::ggplot2_args(
+ qenv,
|
- | 838 |
+ 569 |
! |
- labs = list(
+ substitute(
|
- | 839 |
+ 570 |
! |
- x = quote(paste0("Obs. number\nlm(", reg_form, ")")),
+ expr = summary_table_pre <- ANL_OUTLIER %>%
|
- | 840 |
+ 571 |
! |
- y = "Cook's distance",
+ dplyr::filter(is_outlier_selected) %>%
|
- | 841 |
+ 572 |
! |
- title = "Cook's distance"
- |
-
-
- | 842 |
- |
-
- )
- |
-
-
- | 843 |
- |
-
- )
- |
-
-
- | 844 |
- |
-
- ),
+ dplyr::select(outlier_var_name, categorical_var_name) %>%
|
- | 845 |
+ 573 |
! |
- ggtheme = ggtheme
- |
-
-
- | 846 |
- |
-
- )
- |
-
-
- | 847 |
- |
-
-
+ dplyr::group_by(categorical_var_name) %>%
|
- | 848 |
+ 574 |
! |
- teal.code::eval_code(
+ dplyr::summarise(n_outliers = dplyr::n()) %>%
|
- | 849 |
+ 575 |
! |
- plot_base,
+ dplyr::right_join(
|
- | 850 |
+ 576 |
! |
- substitute(
+ ANL %>%
|
- | 851 |
+ 577 |
! |
- expr = {
+ dplyr::select(outlier_var_name, categorical_var_name) %>%
|
- | 852 |
+ 578 |
! |
- g <- plot
+ dplyr::group_by(categorical_var_name) %>%
|
- | 853 |
+ 579 |
! |
- print(g)
- |
-
-
- | 854 |
- |
-
- },
+ dplyr::summarise(
|
- | 855 |
+ 580 |
! |
- env = list(
+ total_in_cat = dplyr::n(),
|
- | 856 |
+ 581 |
! |
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ n_na = sum(is.na(outlier_var_name) | is.na(categorical_var_name))
|
- | 857 |
+ 582 |
|
- )
+ ),
|
-
- | 858 |
- |
+
+ | 583 |
+ ! |
- )
+ by = categorical_var
|
- | 859 |
+ 584 |
|
- )
+ ) %>%
|
- | 860 |
+ 585 |
|
- }
+ # This is important as there may be categorical variables with natural orderings, e.g. AGE.
|
- | 861 |
+ 586 |
|
-
+ # The plots should be displayed by default in increasing order in these situations.
|
- | 862 |
+ 587 |
|
-
- |
-
-
- | 863 |
- ! |
-
- plot_type_5 <- function(plot_base) {
+ # dplyr::arrange will sort integer, factor, and character data types in the expected way.
|
- | 864 |
+ 588 |
! |
- shinyjs::show("size")
+ dplyr::arrange(categorical_var_name) %>%
|
- | 865 |
+ 589 |
! |
- shinyjs::show("alpha")
+ dplyr::mutate(
|
- | 866 |
+ 590 |
! |
- plot <- substitute(
+ n_outliers = dplyr::if_else(is.na(n_outliers), 0, as.numeric(n_outliers)),
|
- | 867 |
+ 591 |
! |
- expr = ggplot(data = data, aes(.hat, .stdresid)) +
+ display_str = dplyr::if_else(
|
- | 868 |
+ 592 |
! |
- geom_vline(
+ n_outliers > 0,
|
- | 869 |
+ 593 |
! |
- size = 1,
+ sprintf("%d [%.02f%%]", n_outliers, 100 * n_outliers / total_in_cat),
|
- | 870 |
+ 594 |
! |
- colour = "black",
+ "0"
|
-
- | 871 |
- ! |
+
+ | 595 |
+ |
- linetype = "dashed",
+ ),
|
- | 872 |
+ 596 |
! |
- xintercept = 0
- |
-
-
- | 873 |
- |
-
- ) +
+ display_str_na = dplyr::if_else(
|
- | 874 |
+ 597 |
! |
- geom_hline(
+ n_na > 0,
|
- | 875 |
+ 598 |
! |
- size = 1,
+ sprintf("%d [%.02f%%]", n_na, 100 * n_na / total_in_cat),
|
- | 876 |
+ 599 |
! |
- colour = "black",
+ "0"
|
-
- | 877 |
- ! |
+
+ | 600 |
+ |
- linetype = "dashed",
+ ),
|
- | 878 |
+ 601 |
! |
- yintercept = 0
+ order = seq_along(n_outliers)
|
- | 879 |
+ 602 |
|
- ) +
+ ),
|
- | 880 |
+ 603 |
! |
- geom_point(size = size, alpha = alpha) +
+ env = list(
|
- | 881 |
+ 604 |
! |
- geom_line(data = smoothy, mapping = smoothy_aes),
+ categorical_var = categorical_var,
|
- | 882 |
+ 605 |
! |
- env = list(size = size, alpha = alpha)
- |
-
-
- | 883 |
- |
-
- )
+ categorical_var_name = as.name(categorical_var),
|
- | 884 |
+ 606 |
! |
- if (show_outlier) {
+ outlier_var_name = as.name(outlier_var)
|
-
- | 885 |
- ! |
+
+ | 607 |
+ |
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))
+ )
|
- | 886 |
+ 608 |
|
- }
+ )
|
- | 887 |
+ 609 |
|
-
+ )
|
-
- | 888 |
- ! |
+
+ | 610 |
+ |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
+ # now to handle when user chooses to order based on amount of outliers
|
- | 889 |
+ 611 |
! |
- teal.widgets::resolve_ggplot2_args(
+ if (order_by_outlier) {
|
- | 890 |
+ 612 |
! |
- user_plot = ggplot2_args[["Residuals vs Leverage"]],
+ qenv <- teal.code::eval_code(
|
- | 891 |
+ 613 |
! |
- user_default = ggplot2_args$default,
+ qenv,
|
- | 892 |
+ 614 |
! |
- module_plot = teal.widgets::ggplot2_args(
+ quote(
|
- | 893 |
+ 615 |
! |
- labs = list(
+ summary_table_pre <- summary_table_pre %>%
|
- | 894 |
+ 616 |
! |
- x = quote(paste0("Standardized residuals\nlm(", reg_form, ")")),
+ dplyr::arrange(desc(n_outliers / total_in_cat)) %>%
|
- | 895 |
- ! |
-
- y = "Leverage",
- |
-
-
- | 896 |
+ 617 |
! |
- title = "Residuals vs Leverage"
- |
-
-
- | 897 |
- |
-
- )
+ dplyr::mutate(order = seq_len(nrow(summary_table_pre)))
|
- | 898 |
+ 618 |
|
)
|
- | 899 |
+ 619 |
|
- ),
- |
-
-
- | 900 |
- ! |
-
- ggtheme = ggtheme
+ )
|
- | 901 |
+ 620 |
|
- )
+ }
|
- | 902 |
+ 621 |
|
|
- | 903 |
+ 622 |
! |
- teal.code::eval_code(
+ qenv <- teal.code::eval_code(
|
- | 904 |
+ 623 |
! |
- plot_base,
+ qenv,
|
- | 905 |
+ 624 |
! |
substitute(
|
- | 906 |
+ 625 |
! |
expr = {
|
-
- | 907 |
- ! |
-
- smoothy <- smooth(data$.hat, data$.stdresid)
- |
-
-
- | 908 |
- ! |
+
+ | 626 |
+ |
- g <- plot
+ # In order for geom_rug to work properly when reordering takes place inside facet_grid,
|
-
- | 909 |
- ! |
+
+ | 627 |
+ |
- print(g)
+ # all tables must have the column used for reording.
|
- | 910 |
+ 628 |
|
- },
+ # In this case, the column used for reordering is `order`.
|
- | 911 |
+ 629 |
! |
- env = list(
+ ANL_OUTLIER <- dplyr::left_join(
|
- | 912 |
+ 630 |
! |
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
- |
-
-
- | 913 |
- |
-
- )
+ ANL_OUTLIER,
|
-
- | 914 |
- |
+
+ | 631 |
+ ! |
- )
+ summary_table_pre[, c("order", categorical_var)],
|
-
- | 915 |
- |
+
+ | 632 |
+ ! |
- )
+ by = categorical_var
|
- | 916 |
+ 633 |
|
- }
+ )
|
- | 917 |
+ 634 |
|
-
- |
-
-
- | 918 |
- ! |
-
- plot_type_6 <- function(plot_base) {
+ # so that x axis of plot aligns with columns of summary table, from most outliers to least by percentage
|
- | 919 |
+ 635 |
! |
- shinyjs::show("size")
+ ANL <- ANL %>%
|
- | 920 |
+ 636 |
! |
- shinyjs::show("alpha")
+ dplyr::left_join(
|
- | 921 |
+ 637 |
! |
- plot <- substitute(
+ dplyr::select(summary_table_pre, categorical_var_name, order),
|
- | 922 |
+ 638 |
! |
- expr = ggplot(data = data, aes(.hat, .cooksd)) +
+ by = categorical_var
|
-
- | 923 |
- ! |
+
+ | 639 |
+ |
- geom_vline(xintercept = 0, colour = NA) +
+ ) %>%
|
- | 924 |
+ 640 |
! |
- geom_abline(
+ dplyr::arrange(order)
|
- | 925 |
+ 641 |
! |
- slope = seq(0, 3, by = 0.5),
+ summary_table <- summary_table_pre %>%
|
- | 926 |
+ 642 |
! |
- colour = "black",
+ dplyr::select(
|
- | 927 |
+ 643 |
! |
- linetype = "dashed",
+ categorical_var_name,
|
- | 928 |
+ 644 |
! |
- size = 1
+ Outliers = display_str, Missings = display_str_na, Total = total_in_cat
|
- | 929 |
+ 645 |
|
- ) +
+ ) %>%
|
- | 930 |
+ 646 |
! |
- geom_line(data = smoothy, mapping = smoothy_aes) +
+ dplyr::mutate_all(as.character) %>%
|
- | 931 |
+ 647 |
! |
- geom_point(size = size, alpha = alpha),
+ tidyr::pivot_longer(-categorical_var_name) %>%
|
- | 932 |
+ 648 |
! |
- env = list(size = size, alpha = alpha)
- |
-
-
- | 933 |
- |
-
- )
+ tidyr::pivot_wider(names_from = categorical_var, values_from = value) %>%
|
- | 934 |
+ 649 |
! |
- if (show_outlier) {
+ tibble::column_to_rownames("name")
|
- | 935 |
+ 650 |
! |
- plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))
+ summary_table
|
- | 936 |
+ 651 |
|
- }
+ },
|
-
- | 937 |
- |
+
+ | 652 |
+ ! |
-
+ env = list(
|
- | 938 |
+ 653 |
! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
+ categorical_var = categorical_var,
|
- | 939 |
+ 654 |
! |
- teal.widgets::resolve_ggplot2_args(
+ categorical_var_name = as.name(categorical_var)
|
-
- | 940 |
- ! |
+
+ | 655 |
+ |
- user_plot = ggplot2_args[["Cook's dist vs Leverage"]],
+ )
|
-
- | 941 |
- ! |
+
+ | 656 |
+ |
- user_default = ggplot2_args$default,
+ )
|
-
- | 942 |
- ! |
+
+ | 657 |
+ |
- module_plot = teal.widgets::ggplot2_args(
+ )
|
-
- | 943 |
- ! |
+
+ | 658 |
+ |
- labs = list(
+ }
|
-
- | 944 |
- ! |
+
+ | 659 |
+ |
- x = quote(paste0("Leverage\nlm(", reg_form, ")")),
+
|
- | 945 |
+ 660 |
! |
- y = "Cooks's distance",
+ if (length(categorical_var) > 0 && nrow(qenv[["ANL_OUTLIER"]]) > 0) {
|
- | 946 |
+ 661 |
! |
- title = "Cook's dist vs Leverage"
+ shinyjs::show("order_by_outlier")
|
- | 947 |
+ 662 |
|
- )
+ } else {
+ |
+
+
+ | 663 |
+ ! |
+
+ shinyjs::hide("order_by_outlier")
|
- | 948 |
+ 664 |
|
- )
+ }
|
- | 949 |
+ 665 |
|
- ),
+
|
- | 950 |
+ 666 |
! |
- ggtheme = ggtheme
+ qenv
|
- | 951 |
+ 667 |
|
- )
+ })
|
- | 952 |
+ 668 |
|
|
- | 953 |
+ 669 |
! |
- teal.code::eval_code(
+ output$summary_table <- DT::renderDataTable(
|
- | 954 |
+ 670 |
! |
- plot_base,
+ expr = {
|
- | 955 |
+ 671 |
! |
- substitute(
+ if (iv_r()$is_valid()) {
|
- | 956 |
+ 672 |
! |
- expr = {
+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)
|
- | 957 |
+ 673 |
! |
- smoothy <- smooth(data$.hat, data$.cooksd)
+ if (!is.null(categorical_var)) {
|
- | 958 |
+ 674 |
! |
- g <- plot
+ DT::datatable(
|
- | 959 |
+ 675 |
! |
- print(g)
+ common_code_q()[["summary_table"]],
|
-
- | 960 |
- |
+
+ | 676 |
+ ! |
- },
+ options = list(
|
- | 961 |
+ 677 |
! |
- env = list(
+ dom = "t",
|
- | 962 |
+ 678 |
! |
- plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
+ autoWidth = TRUE,
|
-
- | 963 |
- |
+
+ | 679 |
+ ! |
- )
+ columnDefs = list(list(width = "200px", targets = "_all"))
|
- | 964 |
+ 680 |
|
- )
+ )
|
- | 965 |
+ 681 |
|
- )
+ )
|
- | 966 |
+ 682 |
|
- }
+ }
|
- | 967 |
+ 683 |
|
-
+ }
|
-
- | 968 |
- ! |
+
+ | 684 |
+ |
- qenv <- if (input_type == "Response vs Regressor") {
+ }
|
-
- | 969 |
- ! |
+
+ | 685 |
+ |
- plot_type_0()
+ )
|
- | 970 |
+ 686 |
|
- } else {
+
|
-
- | 971 |
- ! |
+
+ | 687 |
+ |
- plot_base_q <- plot_base()
+ # boxplot/violinplot # nolint commented_code
|
- | 972 |
+ 688 |
! |
- switch(input_type,
+ boxplot_q <- reactive({
|
- | 973 |
+ 689 |
! |
- "Residuals vs Fitted" = plot_base_q %>% plot_type_1(),
+ req(common_code_q())
|
- | 974 |
+ 690 |
! |
- "Normal Q-Q" = plot_base_q %>% plot_type_2(),
+ ANL <- common_code_q()[["ANL"]]
|
- | 975 |
+ 691 |
! |
- "Scale-Location" = plot_base_q %>% plot_type_3(),
+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]
|
-
- | 976 |
- ! |
+
+ | 692 |
+ |
- "Cook's distance" = plot_base_q %>% plot_type_4(),
+
|
- | 977 |
+ 693 |
! |
- "Residuals vs Leverage" = plot_base_q %>% plot_type_5(),
+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)
|
- | 978 |
+ 694 |
! |
- "Cook's dist vs Leverage" = plot_base_q %>% plot_type_6()
+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)
|
- | 979 |
+ 695 |
|
- )
+
|
- | 980 |
+ 696 |
|
- }
+ # validation
|
- | 981 |
+ 697 |
! |
- qenv
- |
-
-
- | 982 |
- |
-
- })
+ teal::validate_has_data(ANL, 1)
|
- | 983 |
+ 698 |
|
|
- | 984 |
+ 699 |
|
-
- |
-
-
- | 985 |
- ! |
-
- fitted <- reactive(output_q()[["fit"]])
+ # boxplot
|
- | 986 |
+ 700 |
! |
- plot_r <- reactive(output_q()[["g"]])
+ plot_call <- quote(ANL %>% ggplot())
|
- | 987 |
+ 701 |
|
|
-
- | 988 |
- |
+
+ | 702 |
+ ! |
- # Insert the plot into a plot_with_settings module from teal.widgets
+ plot_call <- if (input$boxplot_alts == "Box plot") {
|
- | 989 |
+ 703 |
! |
- pws <- teal.widgets::plot_with_settings_srv(
+ substitute(expr = plot_call + geom_boxplot(outlier.shape = NA), env = list(plot_call = plot_call))
|
- | 990 |
+ 704 |
! |
- id = "myplot",
+ } else if (input$boxplot_alts == "Violin plot") {
|
- | 991 |
+ 705 |
! |
- plot_r = plot_r,
+ substitute(expr = plot_call + geom_violin(), env = list(plot_call = plot_call))
|
-
- | 992 |
- ! |
+
+ | 706 |
+ |
- height = plot_height,
+ } else {
|
- | 993 |
+ 707 |
! |
- width = plot_width
+ NULL
|
- | 994 |
+ 708 |
|
- )
+ }
|
- | 995 |
+ 709 |
|
|
- | 996 |
+ 710 |
! |
- output$text <- renderText({
+ plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
|
- | 997 |
+ 711 |
! |
- req(iv_r()$is_valid())
+ inner_call <- substitute(
|
- | 998 |
+ 712 |
! |
- req(iv_out$is_valid())
+ expr = plot_call +
|
- | 999 |
+ 713 |
! |
- paste(utils::capture.output(summary(teal.code::dev_suppress(fitted())))[-1],
+ aes(x = "Entire dataset", y = outlier_var_name) +
|
- | 1000 |
+ 714 |
! |
- collapse = "\n"
+ scale_x_discrete(),
|
-
- | 1001 |
- |
+
+ | 715 |
+ ! |
- )
+ env = list(plot_call = plot_call, outlier_var_name = as.name(outlier_var))
|
- | 1002 |
+ 716 |
|
- })
+ )
|
-
- | 1003 |
- |
+
+ | 717 |
+ ! |
-
+ if (nrow(ANL_OUTLIER) > 0) {
|
- | 1004 |
+ 718 |
! |
- teal.widgets::verbatim_popup_srv(
+ substitute(
|
- | 1005 |
+ 719 |
! |
- id = "rcode",
+ expr = inner_call + geom_point(
|
- | 1006 |
+ 720 |
! |
- verbatim_content = reactive(teal.code::get_code(output_q())),
+ data = ANL_OUTLIER,
|
- | 1007 |
+ 721 |
! |
- title = "R code for the regression plot",
+ aes(x = "Entire dataset", y = outlier_var_name, color = is_outlier_selected)
|
- | 1008 |
+ 722 |
|
- )
+ ),
|
-
- | 1009 |
- |
+
+ | 723 |
+ ! |
-
+ env = list(inner_call = inner_call, outlier_var_name = as.name(outlier_var))
|
- | 1010 |
+ 724 |
|
- ### REPORTER
+ )
|
-
- | 1011 |
- ! |
+
+ | 725 |
+ |
- if (with_reporter) {
+ } else {
|
- | 1012 |
+ 726 |
! |
- card_fun <- function(comment, label) {
+ inner_call
|
-
- | 1013 |
- ! |
+
+ | 727 |
+ |
- card <- teal::report_card_template(
+ }
|
-
- | 1014 |
- ! |
+
+ | 728 |
+ |
- title = "Linear Regression Plot",
+ } else {
|
- | 1015 |
+ 729 |
! |
- label = label,
+ substitute(
|
- | 1016 |
+ 730 |
! |
- with_filter = with_filter,
+ expr = plot_call +
|
- | 1017 |
+ 731 |
! |
- filter_panel_api = filter_panel_api
- |
-
-
- | 1018 |
- |
-
- )
+ aes(y = outlier_var_name, x = reorder(categorical_var_name, order)) +
|
- | 1019 |
+ 732 |
! |
- card$append_text("Plot", "header3")
+ xlab(categorical_var) +
|
- | 1020 |
+ 733 |
! |
- card$append_plot(plot_r(), dim = pws$dim())
+ scale_x_discrete() +
|
- | 1021 |
+ 734 |
! |
- if (!comment == "") {
+ geom_point(
|
- | 1022 |
+ 735 |
! |
- card$append_text("Comment", "header3")
+ data = ANL_OUTLIER,
|
- | 1023 |
+ 736 |
! |
- card$append_text(comment)
+ aes(x = as.factor(categorical_var_name), y = outlier_var_name, color = is_outlier_selected)
|
- | 1024 |
+ 737 |
|
- }
+ ),
|
- | 1025 |
+ 738 |
! |
- card$append_src(teal.code::get_code(output_q()))
+ env = list(
|
- | 1026 |
+ 739 |
! |
- card
+ plot_call = plot_call,
|
-
- | 1027 |
- |
+
+ | 740 |
+ ! |
- }
+ outlier_var_name = as.name(outlier_var),
|
- | 1028 |
+ 741 |
! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ categorical_var_name = as.name(categorical_var),
|
-
- | 1029 |
- |
+
+ | 742 |
+ ! |
- }
+ categorical_var = categorical_var
|
- | 1030 |
+ 743 |
|
- ###
+ )
|
- | 1031 |
+ 744 |
|
- })
+ )
|
- | 1032 |
+ 745 |
|
- }
+ }
|
- | 1033 |
+ 746 |
|
|
-
- | 1034 |
- |
+
+ | 747 |
+ ! |
- regression_names <- paste0(
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(
|
-
- | 1035 |
- |
+
+ | 748 |
+ ! |
- '"Response vs Regressor", "Residuals vs Fitted", ',
+ labs = list(color = "Is outlier?"),
|
-
- | 1036 |
- |
+
+ | 749 |
+ ! |
- '"Scale-Location", "Cook\'s distance", "Residuals vs Leverage"", "Cook\'s dist vs Leverage"'
+ theme = list(legend.position = "top")
|
- | 1037 |
+ 750 |
|
- )
+ )
|
-
-
-
-
-
-
- | 1 |
+ 751 |
|
- #' `teal` module: Outliers analysis
+
|
-
- | 2 |
- |
+
+ | 752 |
+ ! |
- #'
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
|
-
- | 3 |
- |
+
+ | 753 |
+ ! |
- #' Module to analyze and identify outliers using different methods
+ user_plot = ggplot2_args[["Boxplot"]],
|
-
- | 4 |
- |
+
+ | 754 |
+ ! |
- #' such as IQR, Z-score, and Percentiles, and offers visualizations including
+ user_default = ggplot2_args$default,
|
-
- | 5 |
- |
+
+ | 755 |
+ ! |
- #' box plots, density plots, and cumulative distribution plots to help interpret the outliers.
+ module_plot = dev_ggplot2_args
|
- | 6 |
+ 756 |
|
- #'
+ )
|
- | 7 |
+ 757 |
|
- #' @inheritParams teal::module
+
|
-
- | 8 |
- |
+
+ | 758 |
+ ! |
- #' @inheritParams shared_params
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
|
-
- | 9 |
- |
+
+ | 759 |
+ ! |
- #'
+ all_ggplot2_args,
|
-
- | 10 |
- |
+
+ | 760 |
+ ! |
- #' @param outlier_var (`data_extract_spec` or `list` of multiple `data_extract_spec`)
+ ggtheme = input$ggtheme
|
- | 11 |
+ 761 |
|
- #' Specifies variable(s) to be analyzed for outliers.
+ )
|
- | 12 |
+ 762 |
|
- #' @param categorical_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
+
|
-
- | 13 |
- |
+
+ | 763 |
+ ! |
- #' specifies the categorical variable(s) to split the selected outlier variables on.
+ teal.code::eval_code(
|
-
- | 14 |
- |
+
+ | 764 |
+ ! |
- #'
+ common_code_q(),
|
-
- | 15 |
- |
+
+ | 765 |
+ ! |
- #' @templateVar ggnames "Boxplot","Density Plot","Cumulative Distribution Plot"
+ substitute(
|
-
- | 16 |
- |
+
+ | 766 |
+ ! |
- #' @template ggplot2_args_multi
+ expr = g <- plot_call +
|
-
- | 17 |
- |
+
+ | 767 |
+ ! |
- #'
+ scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
|
-
- | 18 |
- |
+
+ | 768 |
+ ! |
- #' @inherit shared_params return
+ labs + ggthemes + themes,
|
-
- | 19 |
- |
+
+ | 769 |
+ ! |
- #'
+ env = list(
|
-
- | 20 |
- |
+
+ | 770 |
+ ! |
- #' @examples
+ plot_call = plot_call,
|
-
- | 21 |
- |
+
+ | 771 |
+ ! |
- #' library(teal.widgets)
+ labs = parsed_ggplot2_args$labs,
|
-
- | 22 |
- |
+
+ | 772 |
+ ! |
- #'
+ ggthemes = parsed_ggplot2_args$ggtheme,
|
-
- | 23 |
- |
+
+ | 773 |
+ ! |
- #' # general data example
+ themes = parsed_ggplot2_args$theme
|
- | 24 |
+ 774 |
|
- #' data <- teal_data()
+ )
|
- | 25 |
+ 775 |
|
- #' data <- within(data, {
+ )
|
- | 26 |
+ 776 |
|
- #' CO2 <- CO2
+ ) %>%
|
-
- | 27 |
- |
+
+ | 777 |
+ ! |
- #' CO2[["primary_key"]] <- seq_len(nrow(CO2))
+ teal.code::eval_code(quote(print(g)))
|
- | 28 |
+ 778 |
|
- #' })
+ })
|
- | 29 |
+ 779 |
|
- #' datanames(data) <- "CO2"
+
|
- | 30 |
+ 780 |
|
- #' join_keys(data) <- join_keys(join_key("CO2", "CO2", "primary_key"))
+ # density plot
|
-
- | 31 |
- |
+
+ | 781 |
+ ! |
- #'
+ density_plot_q <- reactive({
|
-
- | 32 |
- |
+
+ | 782 |
+ ! |
- #' vars <- choices_selected(variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")))
+ ANL <- common_code_q()[["ANL"]]
|
-
- | 33 |
- |
+
+ | 783 |
+ ! |
- #'
+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]
|
- | 34 |
+ 784 |
|
- #' app <- init(
+
|
-
- | 35 |
- |
+
+ | 785 |
+ ! |
- #' data = data,
+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)
|
-
- | 36 |
- |
+
+ | 786 |
+ ! |
- #' modules = modules(
+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)
|
- | 37 |
+ 787 |
|
- #' tm_outliers(
+
|
- | 38 |
+ 788 |
|
- #' outlier_var = list(
+ # validation
|
-
- | 39 |
- |
+
+ | 789 |
+ ! |
- #' data_extract_spec(
+ teal::validate_has_data(ANL, 1)
|
- | 40 |
+ 790 |
|
- #' dataname = "CO2",
+ # plot
|
-
- | 41 |
- |
+
+ | 791 |
+ ! |
- #' select = select_spec(
+ plot_call <- substitute(
|
-
- | 42 |
- |
+
+ | 792 |
+ ! |
- #' label = "Select variable:",
+ expr = ANL %>%
|
-
- | 43 |
- |
+
+ | 793 |
+ ! |
- #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
+ ggplot(aes(x = outlier_var_name)) +
|
-
- | 44 |
- |
+
+ | 794 |
+ ! |
- #' selected = "uptake",
+ geom_density() +
|
-
- | 45 |
- |
+
+ | 795 |
+ ! |
- #' multiple = FALSE,
+ geom_rug(data = ANL_OUTLIER, aes(x = outlier_var_name, color = is_outlier_selected)) +
|
-
- | 46 |
- |
+
+ | 796 |
+ ! |
- #' fixed = FALSE
+ scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")),
|
-
- | 47 |
- |
+
+ | 797 |
+ ! |
- #' )
+ env = list(outlier_var_name = as.name(outlier_var))
|
- | 48 |
+ 798 |
|
- #' )
+ )
|
- | 49 |
+ 799 |
|
- #' ),
+
|
-
- | 50 |
- |
+
+ | 800 |
+ ! |
- #' categorical_var = list(
+ plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
|
-
- | 51 |
- |
+
+ | 801 |
+ ! |
- #' data_extract_spec(
+ substitute(expr = plot_call, env = list(plot_call = plot_call))
|
- | 52 |
+ 802 |
|
- #' dataname = "CO2",
+ } else {
|
-
- | 53 |
- |
+
+ | 803 |
+ ! |
- #' filter = filter_spec(
+ substitute(
|
-
- | 54 |
- |
+
+ | 804 |
+ ! |
- #' vars = vars,
+ expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)),
|
-
- | 55 |
- |
+
+ | 805 |
+ ! |
- #' choices = value_choices(data[["CO2"]], vars$selected),
+ env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var))
|
- | 56 |
+ 806 |
|
- #' selected = value_choices(data[["CO2"]], vars$selected),
+ )
|
- | 57 |
+ 807 |
|
- #' multiple = TRUE
+ }
|
- | 58 |
+ 808 |
|
- #' )
+
|
-
- | 59 |
- |
+
+ | 809 |
+ ! |
- #' )
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(
|
-
- | 60 |
- |
+
+ | 810 |
+ ! |
- #' ),
+ labs = list(color = "Is outlier?"),
|
-
- | 61 |
- |
+
+ | 811 |
+ ! |
- #' ggplot2_args = list(
+ theme = list(legend.position = "top")
|
- | 62 |
+ 812 |
|
- #' ggplot2_args(
+ )
|
- | 63 |
+ 813 |
|
- #' labs = list(subtitle = "Plot generated by Outliers Module")
+
|
-
- | 64 |
- |
+
+ | 814 |
+ ! |
- #' )
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
|
-
- | 65 |
- |
+
+ | 815 |
+ ! |
- #' )
+ user_plot = ggplot2_args[["Density Plot"]],
|
-
- | 66 |
- |
+
+ | 816 |
+ ! |
- #' )
+ user_default = ggplot2_args$default,
|
-
- | 67 |
- |
+
+ | 817 |
+ ! |
- #' )
+ module_plot = dev_ggplot2_args
|
- | 68 |
+ 818 |
|
- #' )
+ )
|
- | 69 |
+ 819 |
|
- #' if (interactive()) {
+
|
-
- | 70 |
- |
+
+ | 820 |
+ ! |
- #' shinyApp(app$ui, app$server)
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
|
-
- | 71 |
- |
+
+ | 821 |
+ ! |
- #' }
+ all_ggplot2_args,
|
-
- | 72 |
- |
+
+ | 822 |
+ ! |
- #'
+ ggtheme = input$ggtheme
|
- | 73 |
+ 823 |
|
- #' # CDISC data example
+ )
|
- | 74 |
+ 824 |
|
- #' data <- teal_data()
+
|
-
- | 75 |
- |
+
+ | 825 |
+ ! |
- #' data <- within(data, {
+ teal.code::eval_code(
|
-
- | 76 |
- |
+
+ | 826 |
+ ! |
- #' ADSL <- rADSL
+ common_code_q(),
|
-
- | 77 |
- |
+
+ | 827 |
+ ! |
- #' })
+ substitute(
|
-
- | 78 |
- |
+
+ | 828 |
+ ! |
- #' datanames(data) <- "ADSL"
+ expr = g <- plot_call + labs + ggthemes + themes,
|
-
- | 79 |
- |
+
+ | 829 |
+ ! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
+ env = list(
|
-
- | 80 |
- |
+
+ | 830 |
+ ! |
- #'
+ plot_call = plot_call,
|
-
- | 81 |
- |
+
+ | 831 |
+ ! |
- #' fact_vars_adsl <- names(Filter(isTRUE, sapply(data[["ADSL"]], is.factor)))
+ labs = parsed_ggplot2_args$labs,
|
-
- | 82 |
- |
+
+ | 832 |
+ ! |
- #' vars <- choices_selected(variable_choices(data[["ADSL"]], fact_vars_adsl))
+ themes = parsed_ggplot2_args$theme,
|
-
- | 83 |
- |
+
+ | 833 |
+ ! |
- #'
+ ggthemes = parsed_ggplot2_args$ggtheme
|
- | 84 |
+ 834 |
|
- #' app <- init(
+ )
|
- | 85 |
+ 835 |
|
- #' data = data,
+ )
|
- | 86 |
+ 836 |
|
- #' modules = modules(
+ ) %>%
|
-
- | 87 |
- |
+
+ | 837 |
+ ! |
- #' tm_outliers(
+ teal.code::eval_code(quote(print(g)))
|
- | 88 |
+ 838 |
|
- #' outlier_var = list(
+ })
|
- | 89 |
+ 839 |
|
- #' data_extract_spec(
+
|
- | 90 |
+ 840 |
|
- #' dataname = "ADSL",
+ # Cumulative distribution plot
|
-
- | 91 |
- |
+
+ | 841 |
+ ! |
- #' select = select_spec(
+ cumulative_plot_q <- reactive({
|
-
- | 92 |
- |
+
+ | 842 |
+ ! |
- #' label = "Select variable:",
+ ANL <- common_code_q()[["ANL"]]
|
-
- | 93 |
- |
+
+ | 843 |
+ ! |
- #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]
|
- | 94 |
+ 844 |
|
- #' selected = "AGE",
+
|
-
- | 95 |
- |
+
+ | 845 |
+ ! |
- #' multiple = FALSE,
+ qenv <- common_code_q()
|
- | 96 |
+ 846 |
|
- #' fixed = FALSE
+
|
-
- | 97 |
- |
+
+ | 847 |
+ ! |
- #' )
+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)
|
-
- | 98 |
- |
+
+ | 848 |
+ ! |
- #' )
+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)
|
- | 99 |
+ 849 |
|
- #' ),
+
|
- | 100 |
+ 850 |
|
- #' categorical_var = list(
+ # validation
|
-
- | 101 |
- |
+
+ | 851 |
+ ! |
- #' data_extract_spec(
+ teal::validate_has_data(ANL, 1)
|
- | 102 |
+ 852 |
|
- #' dataname = "ADSL",
+
|
- | 103 |
+ 853 |
|
- #' filter = filter_spec(
+ # plot
|
-
- | 104 |
- |
+
+ | 854 |
+ ! |
- #' vars = vars,
+ plot_call <- substitute(
|
-
- | 105 |
- |
+
+ | 855 |
+ ! |
- #' choices = value_choices(data[["ADSL"]], vars$selected),
+ expr = ANL %>% ggplot(aes(x = outlier_var_name)) +
|
-
- | 106 |
- |
+
+ | 856 |
+ ! |
- #' selected = value_choices(data[["ADSL"]], vars$selected),
+ stat_ecdf(),
|
-
- | 107 |
- |
+
+ | 857 |
+ ! |
- #' multiple = TRUE
+ env = list(outlier_var_name = as.name(outlier_var))
|
- | 108 |
+ 858 |
|
- #' )
+ )
|
-
- | 109 |
- |
+
+ | 859 |
+ ! |
- #' )
+ if (length(categorical_var) == 0) {
|
-
- | 110 |
- |
+
+ | 860 |
+ ! |
- #' ),
+ qenv <- teal.code::eval_code(
|
-
- | 111 |
- |
+
+ | 861 |
+ ! |
- #' ggplot2_args = list(
+ qenv,
|
-
- | 112 |
- |
+
+ | 862 |
+ ! |
- #' ggplot2_args(
+ substitute(
|
-
- | 113 |
- |
+
+ | 863 |
+ ! |
- #' labs = list(subtitle = "Plot generated by Outliers Module")
+ expr = {
|
-
- | 114 |
- |
+
+ | 864 |
+ ! |
- #' )
+ ecdf_df <- ANL %>%
|
-
- | 115 |
- |
+
+ | 865 |
+ ! |
- #' )
+ dplyr::mutate(
|
-
- | 116 |
- |
+
+ | 866 |
+ ! |
- #' )
+ y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]])
|
- | 117 |
+ 867 |
|
- #' )
+ )
|
- | 118 |
+ 868 |
|
- #' )
+
|
-
- | 119 |
- |
+
+ | 869 |
+ ! |
- #' if (interactive()) {
+ outlier_points <- dplyr::left_join(
|
-
- | 120 |
- |
+
+ | 870 |
+ ! |
- #' shinyApp(app$ui, app$server)
+ ecdf_df,
|
-
- | 121 |
- |
+
+ | 871 |
+ ! |
- #' }
+ ANL_OUTLIER,
|
-
- | 122 |
- |
+
+ | 872 |
+ ! |
- #'
+ by = dplyr::setdiff(names(ecdf_df), "y")
|
- | 123 |
+ 873 |
|
- #' @export
+ ) %>%
|
-
- | 124 |
- |
+
+ | 874 |
+ ! |
- #'
+ dplyr::filter(!is.na(is_outlier_selected))
|
- | 125 |
+ 875 |
|
- tm_outliers <- function(label = "Outliers Module",
+ },
|
-
- | 126 |
- |
-
- outlier_var,
- |
-
-
- | 127 |
- |
-
- categorical_var = NULL,
- |
-
-
- | 128 |
- |
-
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
- |
-
-
- | 129 |
- |
+
+ | 876 |
+ ! |
- ggplot2_args = teal.widgets::ggplot2_args(),
+ env = list(outlier_var = outlier_var)
|
- | 130 |
+ 877 |
|
- plot_height = c(600, 200, 2000),
+ )
|
- | 131 |
+ 878 |
|
- plot_width = NULL,
+ )
|
- | 132 |
+ 879 |
|
- pre_output = NULL,
+ } else {
|
-
- | 133 |
- |
+
+ | 880 |
+ ! |
- post_output = NULL) {
+ qenv <- teal.code::eval_code(
|
- | 134 |
+ 881 |
! |
- message("Initializing tm_outliers")
+ qenv,
|
-
- | 135 |
- |
+
+ | 882 |
+ ! |
-
+ substitute(
|
-
- | 136 |
- |
+
+ | 883 |
+ ! |
- # Normalize the parameters
+ expr = {
|
- | 137 |
+ 884 |
! |
- if (inherits(outlier_var, "data_extract_spec")) outlier_var <- list(outlier_var)
+ all_categories <- lapply(
|
- | 138 |
+ 885 |
! |
- if (inherits(categorical_var, "data_extract_spec")) categorical_var <- list(categorical_var)
+ unique(ANL[[categorical_var]]),
|
- | 139 |
+ 886 |
! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)
+ function(x) {
|
-
- | 140 |
- |
+
+ | 887 |
+ ! |
-
+ ANL <- ANL %>% dplyr::filter(get(categorical_var) == x)
|
-
- | 141 |
- |
+
+ | 888 |
+ ! |
- # Start of assertions
+ anl_outlier2 <- ANL_OUTLIER %>% dplyr::filter(get(categorical_var) == x)
|
- | 142 |
+ 889 |
! |
- checkmate::assert_string(label)
+ ecdf_df <- ANL %>%
|
- | 143 |
+ 890 |
! |
- checkmate::assert_list(outlier_var, types = "data_extract_spec")
+ dplyr::mutate(y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]]))
|
- | 144 |
+ 891 |
|
|
- | 145 |
+ 892 |
! |
- checkmate::assert_list(categorical_var, types = "data_extract_spec", null.ok = TRUE)
+ dplyr::left_join(
|
- | 146 |
+ 893 |
! |
- if (is.list(categorical_var)) {
+ ecdf_df,
|
- | 147 |
+ 894 |
! |
- lapply(categorical_var, function(x) {
+ anl_outlier2,
|
- | 148 |
+ 895 |
! |
- if (length(x$filter) > 1L) {
+ by = dplyr::setdiff(names(ecdf_df), "y")
+ |
+
+
+ | 896 |
+ |
+
+ ) %>%
|
- | 149 |
+ 897 |
! |
- stop("tm_outliers: categorical_var data_extract_specs may only specify one filter_spec", call. = FALSE)
+ dplyr::filter(!is.na(is_outlier_selected))
|
- | 150 |
+ 898 |
|
- }
+ }
|
- | 151 |
+ 899 |
|
- })
+ )
|
-
- | 152 |
- |
+
+ | 900 |
+ ! |
- }
+ outlier_points <- do.call(rbind, all_categories)
|
- | 153 |
+ 901 |
|
-
+ },
|
- | 154 |
+ 902 |
! |
- ggtheme <- match.arg(ggtheme)
+ env = list(categorical_var = categorical_var, outlier_var = outlier_var)
|
- | 155 |
+ 903 |
|
-
+ )
+ |
+
+
+ | 904 |
+ |
+
+ )
|
- | 156 |
+ 905 |
! |
- plot_choices <- c("Boxplot", "Density Plot", "Cumulative Distribution Plot")
+ plot_call <- substitute(
|
- | 157 |
+ 906 |
! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")
+ expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)),
|
- | 158 |
+ 907 |
! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var))
|
- | 159 |
+ 908 |
|
-
- |
-
-
- | 160 |
- ! |
-
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
+ )
|
-
- | 161 |
- ! |
+
+ | 909 |
+ |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
+ }
|
-
- | 162 |
- ! |
+
+ | 910 |
+ |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
+
|
- | 163 |
+ 911 |
! |
- checkmate::assert_numeric(
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(
|
- | 164 |
+ 912 |
! |
- plot_width[1],
+ labs = list(color = "Is outlier?"),
|
- | 165 |
+ 913 |
! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
+ theme = list(legend.position = "top")
|
- | 166 |
+ 914 |
|
- )
+ )
|
- | 167 |
+ 915 |
|
|
- | 168 |
+ 916 |
! |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
|
- | 169 |
+ 917 |
! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ user_plot = ggplot2_args[["Cumulative Distribution Plot"]],
|
-
- | 170 |
- |
+
+ | 918 |
+ ! |
- # End of assertions
+ user_default = ggplot2_args$default,
|
-
- | 171 |
- |
+
+ | 919 |
+ ! |
-
+ module_plot = dev_ggplot2_args
|
- | 172 |
+ 920 |
|
- # Make UI args
- |
-
-
- | 173 |
- ! |
-
- args <- as.list(environment())
+ )
|
- | 174 |
+ 921 |
|
|
- | 175 |
+ 922 |
! |
- data_extract_list <- list(
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
|
- | 176 |
+ 923 |
! |
- outlier_var = outlier_var,
+ all_ggplot2_args,
|
- | 177 |
+ 924 |
! |
- categorical_var = categorical_var
+ ggtheme = input$ggtheme
|
- | 178 |
+ 925 |
|
- )
+ )
|
- | 179 |
+ 926 |
|
|
- | 180 |
+ 927 |
! |
- ans <- module(
+ teal.code::eval_code(
|
- | 181 |
+ 928 |
! |
- label = label,
+ qenv,
|
- | 182 |
+ 929 |
! |
- server = srv_outliers,
+ substitute(
|
- | 183 |
+ 930 |
! |
- server_args = c(
+ expr = g <- plot_call +
|
- | 184 |
+ 931 |
! |
- data_extract_list,
+ geom_point(data = outlier_points, aes(x = outlier_var_name, y = y, color = is_outlier_selected)) +
|
- | 185 |
+ 932 |
! |
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)
- |
-
-
- | 186 |
- |
-
- ),
+ scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
|
- | 187 |
+ 933 |
! |
- ui = ui_outliers,
+ labs + ggthemes + themes,
|
- | 188 |
+ 934 |
! |
- ui_args = args,
+ env = list(
|
- | 189 |
+ 935 |
! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)
+ plot_call = plot_call,
|
-
- | 190 |
- |
+
+ | 936 |
+ ! |
- )
+ outlier_var_name = as.name(outlier_var),
|
- | 191 |
+ 937 |
! |
- attr(ans, "teal_bookmarkable") <- TRUE
+ labs = parsed_ggplot2_args$labs,
|
- | 192 |
+ 938 |
! |
- ans
+ themes = parsed_ggplot2_args$theme,
|
-
- | 193 |
- |
+
+ | 939 |
+ ! |
- }
+ ggthemes = parsed_ggplot2_args$ggtheme
|
- | 194 |
+ 940 |
|
-
+ )
|
- | 195 |
+ 941 |
|
- # UI function for the outliers module
+ )
|
- | 196 |
+ 942 |
|
- ui_outliers <- function(id, ...) {
- |
-
-
- | 197 |
- ! |
-
- args <- list(...)
+ ) %>%
|
- | 198 |
+ 943 |
! |
- ns <- NS(id)
+ teal.code::eval_code(quote(print(g)))
|
-
- | 199 |
- ! |
+
+ | 944 |
+ |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$outlier_var, args$categorical_var)
+ })
|
- | 200 |
+ 945 |
|
|
- | 201 |
+ 946 |
! |
- teal.widgets::standard_layout(
+ final_q <- reactive({
|
- | 202 |
+ 947 |
! |
- output = teal.widgets::white_small_well(
+ req(input$tabs)
|
- | 203 |
+ 948 |
! |
- uiOutput(ns("total_outliers")),
+ tab_type <- input$tabs
|
- | 204 |
+ 949 |
! |
- DT::dataTableOutput(ns("summary_table")),
+ result_q <- if (tab_type == "Boxplot") {
|
- | 205 |
+ 950 |
! |
- uiOutput(ns("total_missing")),
+ boxplot_q()
|
- | 206 |
+ 951 |
! |
- tags$br(), tags$hr(),
+ } else if (tab_type == "Density Plot") {
|
- | 207 |
+ 952 |
! |
- tabsetPanel(
+ density_plot_q()
|
- | 208 |
+ 953 |
! |
- id = ns("tabs"),
+ } else if (tab_type == "Cumulative Distribution Plot") {
|
- | 209 |
+ 954 |
! |
- tabPanel(
+ cumulative_plot_q()
|
-
- | 210 |
- ! |
+
+ | 955 |
+ |
- "Boxplot",
+ }
|
-
- | 211 |
- ! |
+
+ | 956 |
+ |
- teal.widgets::plot_with_settings_ui(id = ns("box_plot"))
+ # used to display table when running show-r-code code
|
- | 212 |
+ 957 |
|
- ),
+ # added after the plots so that a change in selected columns doesn't affect
+ |
+
+
+ | 958 |
+ |
+
+ # brush selection.
|
- | 213 |
+ 959 |
! |
- tabPanel(
+ teal.code::eval_code(
|
- | 214 |
+ 960 |
! |
- "Density Plot",
+ result_q,
|
- | 215 |
+ 961 |
! |
- teal.widgets::plot_with_settings_ui(id = ns("density_plot"))
+ substitute(
|
-
- | 216 |
- |
+
+ | 962 |
+ ! |
- ),
+ expr = {
|
- | 217 |
+ 963 |
! |
- tabPanel(
+ columns_index <- union(
|
- | 218 |
+ 964 |
! |
- "Cumulative Distribution Plot",
+ setdiff(names(ANL_OUTLIER), c("is_outlier_selected", "order")),
|
- | 219 |
+ 965 |
! |
- teal.widgets::plot_with_settings_ui(id = ns("cum_density_plot"))
+ table_columns
|
- | 220 |
+ 966 |
|
- )
+ )
+ |
+
+
+ | 967 |
+ ! |
+
+ ANL_OUTLIER_EXTENDED[ANL_OUTLIER_EXTENDED$is_outlier_selected, columns_index]
|
- | 221 |
+ 968 |
|
- ),
+ },
|
- | 222 |
+ 969 |
! |
- tags$br(), tags$hr(),
+ env = list(
|
- | 223 |
+ 970 |
! |
- uiOutput(ns("table_ui_wrap")),
+ table_columns = input$table_ui_columns
|
-
- | 224 |
- ! |
+
+ | 971 |
+ |
- DT::dataTableOutput(ns("table_ui"))
+ )
|
- | 225 |
+ 972 |
|
- ),
+ )
|
-
- | 226 |
- ! |
+
+ | 973 |
+ |
- encoding = tags$div(
+ )
|
- | 227 |
+ 974 |
|
- ### Reporter
+ })
|
-
- | 228 |
- ! |
+
+ | 975 |
+ |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+
|
- | 229 |
+ 976 |
|
- ###
+ # slider text
|
- | 230 |
+ 977 |
! |
- tags$label("Encodings", class = "text-primary"),
+ output$ui_outlier_help <- renderUI({
|
- | 231 |
+ 978 |
! |
- teal.transform::datanames_input(args[c("outlier_var", "categorical_var")]),
+ req(input$method)
|
- | 232 |
+ 979 |
! |
- teal.transform::data_extract_ui(
+ if (input$method == "IQR") {
|
- | 233 |
+ 980 |
! |
- id = ns("outlier_var"),
+ req(input$iqr_slider)
|
- | 234 |
+ 981 |
! |
- label = "Variable",
+ tags$small(
|
- | 235 |
+ 982 |
! |
- data_extract_spec = args$outlier_var,
+ withMathJax(
|
- | 236 |
+ 983 |
! |
- is_single_dataset = is_single_dataset_value
+ helpText(
|
-
- | 237 |
- |
+
+ | 984 |
+ ! |
- ),
+ "Outlier data points (\\(x \\lt Q1 - ", input$iqr_slider, "\\times IQR\\) or \\(
|
- | 238 |
+ 985 |
! |
- if (!is.null(args$categorical_var)) {
+ Q3 + ", input$iqr_slider, "\\times IQR \\lt x\\))
|
- | 239 |
+ 986 |
! |
- teal.transform::data_extract_ui(
+ are displayed in red on the plot and can be visualized in the table below."
|
-
- | 240 |
- ! |
+
+ | 987 |
+ |
- id = ns("categorical_var"),
+ ),
|
- | 241 |
+ 988 |
! |
- label = "Categorical factor",
+ if (input$split_outliers) {
|
- | 242 |
+ 989 |
! |
- data_extract_spec = args$categorical_var,
+ withMathJax(helpText("Note: Quantiles are calculated per group."))
|
-
- | 243 |
- ! |
+
+ | 990 |
+ |
- is_single_dataset = is_single_dataset_value
+ }
|
- | 244 |
+ 991 |
|
- )
+ )
|
- | 245 |
+ 992 |
|
- },
+ )
|
- | 246 |
+ 993 |
! |
- conditionalPanel(
+ } else if (input$method == "Z-score") {
|
- | 247 |
+ 994 |
! |
- condition = paste0("input['", ns("tabs"), "'] == 'Boxplot'"),
+ req(input$zscore_slider)
|
- | 248 |
+ 995 |
! |
- teal.widgets::optionalSelectInput(
+ tags$small(
|
- | 249 |
+ 996 |
! |
- inputId = ns("boxplot_alts"),
+ withMathJax(
|
- | 250 |
+ 997 |
! |
- label = "Plot type",
+ helpText(
|
- | 251 |
+ 998 |
! |
- choices = c("Box plot", "Violin plot"),
+ "Outlier data points (\\(Zscore(x) < -", input$zscore_slider,
|
- | 252 |
+ 999 |
! |
- selected = "Box plot",
+ "\\) or \\(", input$zscore_slider, "< Zscore(x) \\))
|
- | 253 |
+ 1000 |
! |
- multiple = FALSE
+ are displayed in red on the plot and can be visualized in the table below."
|
- | 254 |
+ 1001 |
|
- )
+ ),
|
-
- | 255 |
- |
+
+ | 1002 |
+ ! |
- ),
+ if (input$split_outliers) {
|
- | 256 |
+ 1003 |
! |
- shinyjs::hidden(checkboxInput(ns("split_outliers"), "Define outliers based on group splitting", value = FALSE)),
+ withMathJax(helpText(" Note: Z-scores are calculated per group."))
|
-
- | 257 |
- ! |
+
+ | 1004 |
+ |
- shinyjs::hidden(checkboxInput(ns("order_by_outlier"), "Re-order categories by outliers [by %]", value = FALSE)),
+ }
|
-
- | 258 |
- ! |
+
+ | 1005 |
+ |
- teal.widgets::panel_group(
+ )
|
-
- | 259 |
- ! |
+
+ | 1006 |
+ |
- teal.widgets::panel_item(
+ )
|
- | 260 |
+ 1007 |
! |
- title = "Method parameters",
+ } else if (input$method == "Percentile") {
|
- | 261 |
+ 1008 |
! |
- collapsed = FALSE,
+ req(input$percentile_slider)
|
- | 262 |
+ 1009 |
! |
- teal.widgets::optionalSelectInput(
+ tags$small(
|
- | 263 |
+ 1010 |
! |
- inputId = ns("method"),
+ withMathJax(
|
- | 264 |
+ 1011 |
! |
- label = "Method",
+ helpText(
|
- | 265 |
+ 1012 |
! |
- choices = c("IQR", "Z-score", "Percentile"),
+ "Outlier/extreme data points (\\( Percentile(x) <", input$percentile_slider,
|
- | 266 |
+ 1013 |
! |
- selected = "IQR",
+ "\\) or \\(", 1 - input$percentile_slider, " < Percentile(x) \\))
|
- | 267 |
+ 1014 |
! |
- multiple = FALSE
+ are displayed in red on the plot and can be visualized in the table below."
|
- | 268 |
+ 1015 |
|
- ),
+ ),
|
- | 269 |
+ 1016 |
! |
- conditionalPanel(
+ if (input$split_outliers) {
|
- | 270 |
+ 1017 |
! |
- condition =
+ withMathJax(helpText("Note: Percentiles are calculated per group."))
|
-
- | 271 |
- ! |
+
+ | 1018 |
+ |
- paste0("input['", ns("method"), "'] == 'IQR'"),
+ }
|
-
- | 272 |
- ! |
+
+ | 1019 |
+ |
- sliderInput(
+ )
|
-
- | 273 |
- ! |
+
+ | 1020 |
+ |
- ns("iqr_slider"),
+ )
+ |
+
+
+ | 1021 |
+ |
+
+ }
+ |
+
+
+ | 1022 |
+ |
+
+ })
+ |
+
+
+ | 1023 |
+ |
+
+
|
- | 274 |
+ 1024 |
! |
- "Outlier range:",
+ boxplot_r <- reactive({
|
- | 275 |
+ 1025 |
! |
- min = 1,
+ teal::validate_inputs(iv_r())
|
- | 276 |
+ 1026 |
! |
- max = 5,
+ boxplot_q()[["g"]]
+ |
+
+
+ | 1027 |
+ |
+
+ })
|
- | 277 |
+ 1028 |
! |
- value = 3,
+ density_plot_r <- reactive({
|
- | 278 |
+ 1029 |
! |
- step = 0.5
+ teal::validate_inputs(iv_r())
|
-
- | 279 |
- |
+
+ | 1030 |
+ ! |
- )
+ density_plot_q()[["g"]]
|
- | 280 |
+ 1031 |
|
- ),
+ })
|
- | 281 |
+ 1032 |
! |
- conditionalPanel(
+ cumulative_plot_r <- reactive({
|
- | 282 |
+ 1033 |
! |
- condition =
+ teal::validate_inputs(iv_r())
|
- | 283 |
+ 1034 |
! |
- paste0("input['", ns("method"), "'] == 'Z-score'"),
+ cumulative_plot_q()[["g"]]
|
-
- | 284 |
- ! |
+
+ | 1035 |
+ |
- sliderInput(
+ })
+ |
+
+
+ | 1036 |
+ |
+
+
|
- | 285 |
+ 1037 |
! |
- ns("zscore_slider"),
+ box_pws <- teal.widgets::plot_with_settings_srv(
|
- | 286 |
+ 1038 |
! |
- "Outlier range:",
+ id = "box_plot",
|
- | 287 |
+ 1039 |
! |
- min = 1,
+ plot_r = boxplot_r,
|
- | 288 |
+ 1040 |
! |
- max = 5,
+ height = plot_height,
|
- | 289 |
+ 1041 |
! |
- value = 3,
+ width = plot_width,
|
- | 290 |
+ 1042 |
! |
- step = 0.5
+ brushing = TRUE
|
- | 291 |
+ 1043 |
|
- )
+ )
|
- | 292 |
+ 1044 |
|
- ),
+
|
- | 293 |
+ 1045 |
! |
- conditionalPanel(
+ density_pws <- teal.widgets::plot_with_settings_srv(
|
- | 294 |
+ 1046 |
! |
- condition =
+ id = "density_plot",
|
- | 295 |
+ 1047 |
! |
- paste0("input['", ns("method"), "'] == 'Percentile'"),
+ plot_r = density_plot_r,
|
- | 296 |
+ 1048 |
! |
- sliderInput(
+ height = plot_height,
|
- | 297 |
+ 1049 |
! |
- ns("percentile_slider"),
+ width = plot_width,
|
- | 298 |
+ 1050 |
! |
- "Outlier range:",
+ brushing = TRUE
|
-
- | 299 |
- ! |
+
+ | 1051 |
+ |
- min = 0.001,
+ )
+ |
+
+
+ | 1052 |
+ |
+
+
|
- | 300 |
+ 1053 |
! |
- max = 0.5,
+ cum_density_pws <- teal.widgets::plot_with_settings_srv(
|
- | 301 |
+ 1054 |
! |
- value = 0.01,
+ id = "cum_density_plot",
|
- | 302 |
+ 1055 |
! |
- step = 0.001
+ plot_r = cumulative_plot_r,
|
-
- | 303 |
- |
+
+ | 1056 |
+ ! |
- )
+ height = plot_height,
|
-
- | 304 |
- |
+
+ | 1057 |
+ ! |
- ),
+ width = plot_width,
|
- | 305 |
+ 1058 |
! |
- uiOutput(ns("ui_outlier_help"))
+ brushing = TRUE
|
- | 306 |
+ 1059 |
|
- )
+ )
|
- | 307 |
+ 1060 |
|
- ),
+
|
- | 308 |
+ 1061 |
! |
- teal.widgets::panel_item(
+ choices <- reactive(teal.transform::variable_choices(data()[[dataname_first]]))
+ |
+
+
+ | 1062 |
+ |
+
+
|
- | 309 |
+ 1063 |
! |
- title = "Plot settings",
+ observeEvent(common_code_q(), {
|
- | 310 |
+ 1064 |
! |
- selectInput(
+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]
|
- | 311 |
+ 1065 |
! |
- inputId = ns("ggtheme"),
+ teal.widgets::updateOptionalSelectInput(
|
- | 312 |
+ 1066 |
! |
- label = "Theme (by ggplot):",
+ session,
|
- | 313 |
+ 1067 |
! |
- choices = ggplot_themes,
+ inputId = "table_ui_columns",
|
- | 314 |
+ 1068 |
! |
- selected = args$ggtheme,
+ choices = dplyr::setdiff(choices(), names(ANL_OUTLIER)),
|
- | 315 |
+ 1069 |
! |
- multiple = FALSE
+ selected = restoreInput(ns("table_ui_columns"), isolate(input$table_ui_columns))
|
- | 316 |
+ 1070 |
|
- )
+ )
|
- | 317 |
+ 1071 |
|
- )
+ })
|
- | 318 |
+ 1072 |
|
- ),
+
|
- | 319 |
+ 1073 |
! |
- forms = tagList(
+ output$table_ui <- DT::renderDataTable(
|
- | 320 |
+ 1074 |
! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ expr = {
|
-
- | 321 |
- |
+
+ | 1075 |
+ ! |
- ),
+ tab <- input$tabs
|
- | 322 |
+ 1076 |
! |
- pre_output = args$pre_output,
+ req(tab) # tab is NULL upon app launch, hence will crash without this statement
|
- | 323 |
+ 1077 |
! |
- post_output = args$post_output
+ req(iv_r()$is_valid()) # Same validation as output$table_ui_wrap
|
-
- | 324 |
- |
+
+ | 1078 |
+ ! |
- )
+ outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)
|
-
- | 325 |
- |
+
+ | 1079 |
+ ! |
- }
+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)
|
- | 326 |
+ 1080 |
|
|
-
- | 327 |
- |
+
+ | 1081 |
+ ! |
- # Server function for the outliers module
+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]
|
-
- | 328 |
- |
+
+ | 1082 |
+ ! |
- srv_outliers <- function(id, data, reporter, filter_panel_api, outlier_var,
+ ANL_OUTLIER_EXTENDED <- common_code_q()[["ANL_OUTLIER_EXTENDED"]]
+ |
+
+
+ | 1083 |
+ ! |
+
+ ANL <- common_code_q()[["ANL"]]
|
- | 329 |
+ 1084 |
|
- categorical_var, plot_height, plot_width, ggplot2_args) {
+
|
- | 330 |
+ 1085 |
! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
+ plot_brush <- if (tab == "Boxplot") {
|
- | 331 |
+ 1086 |
! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
+ boxplot_r()
|
- | 332 |
+ 1087 |
! |
- checkmate::assert_class(data, "reactive")
+ box_pws$brush()
|
- | 333 |
+ 1088 |
! |
- checkmate::assert_class(isolate(data()), "teal_data")
+ } else if (tab == "Density Plot") {
|
- | 334 |
+ 1089 |
! |
- moduleServer(id, function(input, output, session) {
+ density_plot_r()
|
- | 335 |
+ 1090 |
! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
+ density_pws$brush()
|
-
- | 336 |
- |
+
+ | 1091 |
+ ! |
-
+ } else if (tab == "Cumulative Distribution Plot") {
|
- | 337 |
+ 1092 |
! |
- ns <- session$ns
+ cumulative_plot_r()
+ |
+
+
+ | 1093 |
+ ! |
+
+ cum_density_pws$brush()
|
- | 338 |
+ 1094 |
+ |
+
+ }
+ |
+
+
+ | 1095 |
|
|
+
+ | 1096 |
+ |
+
+ # removing unused column ASAP
+ |
+
- | 339 |
+ 1097 |
! |
- vars <- list(outlier_var = outlier_var, categorical_var = categorical_var)
+ ANL_OUTLIER$order <- ANL$order <- NULL
|
- | 340 |
+ 1098 |
|
|
- | 341 |
+ 1099 |
! |
- rule_diff <- function(other) {
+ display_table <- if (!is.null(plot_brush)) {
|
- | 342 |
+ 1100 |
! |
- function(value) {
+ if (length(categorical_var) > 0) {
|
-
- | 343 |
- ! |
+
+ | 1101 |
+ |
- othervalue <- tryCatch(selector_list()[[other]]()[["select"]], error = function(e) NULL)
+ # due to reordering, the x-axis label may be changed to something like "reorder(categorical_var, order)"
|
- | 344 |
+ 1102 |
! |
- if (!is.null(othervalue) && identical(othervalue, value)) {
+ if (tab == "Boxplot") {
|
- | 345 |
+ 1103 |
! |
- "`Variable` and `Categorical factor` cannot be the same"
- |
-
-
- | 346 |
- |
-
- }
+ plot_brush$mapping$x <- categorical_var
|
- | 347 |
+ 1104 |
|
- }
+ } else {
|
- | 348 |
+ 1105 |
|
- }
+ # the other plots use facetting
|
- | 349 |
+ 1106 |
|
-
+ # so it is panelvar1 that gets relabelled to "reorder(categorical_var, order)"
|
- | 350 |
+ 1107 |
! |
- selector_list <- teal.transform::data_extract_multiple_srv(
+ plot_brush$mapping$panelvar1 <- categorical_var
|
-
- | 351 |
- ! |
+
+ | 1108 |
+ |
- data_extract = vars,
+ }
|
-
- | 352 |
- ! |
+
+ | 1109 |
+ |
- datasets = data,
+ } else {
|
- | 353 |
+ 1110 |
! |
- select_validation_rule = list(
+ if (tab == "Boxplot") {
|
-
- | 354 |
- ! |
+
+ | 1111 |
+ |
- outlier_var = shinyvalidate::compose_rules(
+ # in boxplot with no categorical variable, there is no column in ANL that would correspond to x-axis
|
-
- | 355 |
- ! |
+
+ | 1112 |
+ |
- shinyvalidate::sv_required("Please select a variable"),
+ # so a column needs to be inserted with the value "Entire dataset" because that's the label used in plot
|
- | 356 |
+ 1113 |
! |
- rule_diff("categorical_var")
+ ANL[[plot_brush$mapping$x]] <- "Entire dataset"
|
- | 357 |
+ 1114 |
|
- ),
+ }
|
-
- | 358 |
- ! |
+
+ | 1115 |
+ |
- categorical_var = rule_diff("outlier_var")
+ }
|
- | 359 |
+ 1116 |
|
- )
+
|
- | 360 |
+ 1117 |
|
- )
+ # in density and cumulative plots, ANL does not have a column corresponding to y-axis.
|
- | 361 |
+ 1118 |
|
-
+ # so they need to be computed and attached to ANL
|
- | 362 |
+ 1119 |
! |
- iv_r <- reactive({
+ if (tab == "Density Plot") {
|
- | 363 |
+ 1120 |
! |
- iv <- shinyvalidate::InputValidator$new()
+ plot_brush$mapping$y <- "density"
|
- | 364 |
+ 1121 |
! |
- iv$add_rule("method", shinyvalidate::sv_required("Please select a method"))
+ ANL$density <- plot_brush$ymin
|
-
- | 365 |
- ! |
+
+ | 1122 |
+ |
- iv$add_rule("boxplot_alts", shinyvalidate::sv_required("Please select Plot Type"))
+ # either ymin or ymax will work
|
- | 366 |
+ 1123 |
! |
- teal.transform::compose_and_enable_validators(iv, selector_list)
+ } else if (tab == "Cumulative Distribution Plot") {
|
-
- | 367 |
- |
+
+ | 1124 |
+ ! |
- })
+ plot_brush$mapping$y <- "cdf"
|
-
- | 368 |
- |
+
+ | 1125 |
+ ! |
-
+ if (length(categorical_var) > 0) {
|
- | 369 |
+ 1126 |
! |
- reactive_select_input <- reactive({
+ ANL <- ANL %>%
|
- | 370 |
+ 1127 |
! |
- if (is.null(selector_list()$categorical_var) || length(selector_list()$categorical_var()$select) == 0) {
+ dplyr::group_by(!!as.name(plot_brush$mapping$panelvar1)) %>%
|
- | 371 |
+ 1128 |
! |
- selector_list()[names(selector_list()) != "categorical_var"]
+ dplyr::mutate(cdf = stats::ecdf(!!as.name(outlier_var))(!!as.name(outlier_var)))
|
- | 372 |
+ 1129 |
|
- } else {
+ } else {
|
- | 373 |
+ 1130 |
! |
- selector_list()
+ ANL$cdf <- stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]])
|
- | 374 |
+ 1131 |
|
- }
+ }
|
- | 375 |
+ 1132 |
|
- })
+ }
|
- | 376 |
+ 1133 |
|
|
- | 377 |
+ 1134 |
! |
- anl_merged_input <- teal.transform::merge_expression_srv(
+ brushed_rows <- brushedPoints(ANL, plot_brush)
|
- | 378 |
+ 1135 |
! |
- selector_list = reactive_select_input,
+ if (nrow(brushed_rows) > 0) {
|
-
- | 379 |
- ! |
+
+ | 1136 |
+ |
- datasets = data,
+ # now we need to remove extra column from ANL so that it will have the same columns as ANL_OUTLIER
|
-
- | 380 |
- ! |
+
+ | 1137 |
+ |
- merge_function = "dplyr::inner_join"
+ # so that dplyr::intersect will work
|
-
- | 381 |
- |
+
+ | 1138 |
+ ! |
- )
+ if (tab == "Density Plot") {
|
-
- | 382 |
- |
+
+ | 1139 |
+ ! |
-
+ brushed_rows$density <- NULL
|
- | 383 |
+ 1140 |
! |
- anl_merged_q <- reactive({
+ } else if (tab == "Cumulative Distribution Plot") {
|
- | 384 |
+ 1141 |
! |
- req(anl_merged_input())
+ brushed_rows$cdf <- NULL
|
- | 385 |
+ 1142 |
! |
- data() %>%
+ } else if (tab == "Boxplot" && length(categorical_var) == 0) {
|
- | 386 |
+ 1143 |
! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))
+ brushed_rows[[plot_brush$mapping$x]] <- NULL
|
- | 387 |
+ 1144 |
|
- })
+ }
|
- | 388 |
+ 1145 |
|
-
+ # is_outlier_selected is part of ANL_OUTLIER so needed here
|
- | 389 |
+ 1146 |
! |
- merged <- list(
+ brushed_rows$is_outlier_selected <- TRUE
|
- | 390 |
+ 1147 |
! |
- anl_input_r = anl_merged_input,
+ dplyr::intersect(ANL_OUTLIER, brushed_rows)
+ |
+
+
+ | 1148 |
+ |
+
+ } else {
|
- | 391 |
+ 1149 |
! |
- anl_q_r = anl_merged_q
+ ANL_OUTLIER[0, ]
|
- | 392 |
+ 1150 |
|
- )
+ }
|
- | 393 |
+ 1151 |
|
-
- |
-
-
- | 394 |
- ! |
-
- n_outlier_missing <- reactive({
+ } else {
|
- | 395 |
+ 1152 |
! |
- req(iv_r()$is_valid())
+ ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ]
|
-
- | 396 |
- ! |
+
+ | 1153 |
+ |
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)
+ }
|
-
- | 397 |
- ! |
+
+ | 1154 |
+ |
- ANL <- merged$anl_q_r()[["ANL"]]
+
|
- | 398 |
+ 1155 |
! |
- sum(is.na(ANL[[outlier_var]]))
- |
-
-
- | 399 |
- |
-
- })
+ display_table$is_outlier_selected <- NULL
|
- | 400 |
+ 1156 |
|
|
- | 401 |
+ 1157 |
|
- # Used to create outlier table and the dropdown with additional columns
+ # Extend the brushed ANL_OUTLIER with additional columns
|
- | 402 |
+ 1158 |
! |
- dataname_first <- isolate(teal.data::datanames(data())[[1]])
+ dplyr::left_join(
|
-
- | 403 |
- |
+
+ | 1159 |
+ ! |
-
+ display_table,
|
- | 404 |
+ 1160 |
! |
- common_code_q <- reactive({
+ dplyr::select(ANL_OUTLIER_EXTENDED, -"is_outlier_selected"),
|
- | 405 |
+ 1161 |
! |
- req(iv_r()$is_valid())
+ by = names(display_table)
|
- | 406 |
+ 1162 |
|
-
- |
-
-
- | 407 |
- ! |
-
- ANL <- merged$anl_q_r()[["ANL"]]
+ ) %>%
|
- | 408 |
+ 1163 |
! |
- qenv <- merged$anl_q_r()
+ dplyr::select(union(names(display_table), input$table_ui_columns))
|
- | 409 |
+ 1164 |
|
-
+ },
|
- | 410 |
+ 1165 |
! |
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)
+ options = list(
|
- | 411 |
+ 1166 |
! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)
+ searching = FALSE, language = list(
|
- | 412 |
+ 1167 |
! |
- order_by_outlier <- input$order_by_outlier
+ zeroRecords = "The brushed area does not contain outlier observations for the currently defined threshold"
|
-
- | 413 |
- ! |
+
+ | 1168 |
+ |
- method <- input$method
+ ),
|
- | 414 |
+ 1169 |
! |
- split_outliers <- input$split_outliers
+ pageLength = input$table_ui_rows
|
-
- | 415 |
- ! |
+
+ | 1170 |
+ |
- teal::validate_has_data(
+ )
|
- | 416 |
+ 1171 |
|
- # missing values in the categorical variable may be used to form a category of its own
+ )
|
-
- | 417 |
- ! |
+
+ | 1172 |
+ |
- `if`(
+
|
- | 418 |
+ 1173 |
! |
- length(categorical_var) == 0,
+ output$total_outliers <- renderUI({
|
- | 419 |
- ! |
-
- ANL,
- |
-
-
- | 420 |
- ! |
-
- ANL[, names(ANL) != categorical_var, drop = FALSE]
- |
-
-
- | 421 |
- |
-
- ),
- |
-
-
- | 422 |
- ! |
-
- min_nrow = 10,
- |
-
-
- | 423 |
+ 1174 |
! |
- complete = TRUE,
+ req(iv_r()$is_valid())
|
- | 424 |
+ 1175 |
! |
- allow_inf = FALSE
- |
-
-
- | 425 |
- |
-
- )
+ ANL <- merged$anl_q_r()[["ANL"]]
|
- | 426 |
+ 1176 |
! |
- validate(need(is.numeric(ANL[[outlier_var]]), "`Variable` is not numeric"))
+ ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]
|
- | 427 |
+ 1177 |
! |
- validate(need(length(unique(ANL[[outlier_var]])) > 1, "Variable has no variation, i.e. only one unique value"))
- |
-
-
- | 428 |
- |
-
-
- |
-
-
- | 429 |
- |
-
- # show/hide split_outliers
+ teal::validate_has_data(ANL, 1)
|
- | 430 |
+ 1178 |
! |
- if (length(categorical_var) == 0) {
+ ANL_OUTLIER_SELECTED <- ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ]
|
- | 431 |
+ 1179 |
! |
- shinyjs::hide("split_outliers")
+ tags$h5(
|
- | 432 |
+ 1180 |
! |
- if (n_outlier_missing() > 0) {
+ sprintf(
|
- | 433 |
+ 1181 |
! |
- qenv <- teal.code::eval_code(
+ "%s %d / %d [%.02f%%]",
|
- | 434 |
+ 1182 |
! |
- qenv,
+ "Total number of outlier(s):",
|
- | 435 |
+ 1183 |
! |
- substitute(
+ nrow(ANL_OUTLIER_SELECTED),
|
- | 436 |
+ 1184 |
! |
- expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)),
+ nrow(ANL),
|
- | 437 |
+ 1185 |
! |
- env = list(outlier_var_name = as.name(outlier_var))
+ 100 * nrow(ANL_OUTLIER_SELECTED) / nrow(ANL)
|
- | 438 |
+ 1186 |
|
- )
+ )
|
- | 439 |
+ 1187 |
|
- )
+ )
|
- | 440 |
+ 1188 |
|
- }
+ })
|
- | 441 |
+ 1189 |
|
- } else {
- |
-
-
- | 442 |
- ! |
-
- validate(need(
+
|
- | 443 |
+ 1190 |
! |
- is.factor(ANL[[categorical_var]]) ||
+ output$total_missing <- renderUI({
|
- | 444 |
+ 1191 |
! |
- is.character(ANL[[categorical_var]]) ||
+ if (n_outlier_missing() > 0) {
|
- | 445 |
+ 1192 |
! |
- is.integer(ANL[[categorical_var]]),
+ ANL <- merged$anl_q_r()[["ANL"]]
|
- | 446 |
+ 1193 |
! |
- "`Categorical factor` must be `factor`, `character`, or `integer`"
- |
-
-
- | 447 |
- |
-
- ))
- |
-
-
- | 448 |
- |
-
-
+ helpText(
|
- | 449 |
+ 1194 |
! |
- if (n_outlier_missing() > 0) {
+ sprintf(
|
- | 450 |
+ 1195 |
! |
- qenv <- teal.code::eval_code(
+ "%s %d / %d [%.02f%%]",
|
- | 451 |
+ 1196 |
! |
- qenv,
+ "Total number of row(s) with missing values:",
|
- | 452 |
+ 1197 |
! |
- substitute(
+ n_outlier_missing(),
|
- | 453 |
+ 1198 |
! |
- expr = ANL <- ANL %>% dplyr::filter(!is.na(outlier_var_name)),
+ nrow(ANL),
|
- | 454 |
+ 1199 |
! |
- env = list(outlier_var_name = as.name(outlier_var))
- |
-
-
- | 455 |
- |
-
- )
+ 100 * (n_outlier_missing()) / nrow(ANL)
|
- | 456 |
+ 1200 |
|
)
|
- | 457 |
+ 1201 |
|
- }
- |
-
-
- | 458 |
- ! |
-
- shinyjs::show("split_outliers")
+ )
|
- | 459 |
+ 1202 |
|
}
|
- | 460 |
+ 1203 |
|
-
+ })
|
- | 461 |
+ 1204 |
|
- # slider
+
|
- | 462 |
+ 1205 |
! |
- outlier_definition_param <- if (method == "IQR") {
+ output$table_ui_wrap <- renderUI({
|
- | 463 |
+ 1206 |
! |
- input$iqr_slider
+ req(iv_r()$is_valid())
|
- | 464 |
+ 1207 |
! |
- } else if (method == "Z-score") {
+ tagList(
|
- | 465 |
+ 1208 |
! |
- input$zscore_slider
+ teal.widgets::optionalSelectInput(
|
- | 466 |
+ 1209 |
! |
- } else if (method == "Percentile") {
+ inputId = ns("table_ui_columns"),
|
- | 467 |
+ 1210 |
! |
- input$percentile_slider
- |
-
-
- | 468 |
- |
-
- }
- |
-
-
- | 469 |
- |
-
-
- |
-
-
- | 470 |
- |
-
- # this is utils function that converts a %>% NULL %>% b into a %>% b
+ label = "Choose additional columns",
|
- | 471 |
+ 1211 |
! |
- remove_pipe_null <- function(x) {
+ choices = NULL,
|
- | 472 |
+ 1212 |
! |
- if (length(x) == 1) {
+ selected = NULL,
|
- | 473 |
+ 1213 |
! |
- return(x)
+ multiple = TRUE
|
- | 474 |
+ 1214 |
|
- }
+ ),
|
- | 475 |
+ 1215 |
! |
- if (identical(x[[1]], as.name("%>%")) && is.null(x[[3]])) {
+ tags$h4("Outlier Table"),
|
- | 476 |
+ 1216 |
! |
- return(remove_pipe_null(x[[2]]))
+ teal.widgets::get_dt_rows(ns("table_ui"), ns("table_ui_rows"))
|
- | 477 |
+ 1217 |
|
- }
- |
-
-
- | 478 |
- ! |
-
- return(as.call(c(x[[1]], lapply(x[-1], remove_pipe_null))))
+ )
|
- | 479 |
+ 1218 |
|
- }
+ })
|
- | 480 |
+ 1219 |
|
|
- | 481 |
+ 1220 |
! |
- qenv <- teal.code::eval_code(
+ teal.widgets::verbatim_popup_srv(
|
- | 482 |
+ 1221 |
! |
- qenv,
+ id = "rcode",
|
- | 483 |
+ 1222 |
! |
- substitute(
+ verbatim_content = reactive(teal.code::get_code(final_q())),
|
- | 484 |
+ 1223 |
! |
- expr = {
+ title = "Show R Code for Outlier"
|
-
- | 485 |
- ! |
+
+ | 1224 |
+ |
- ANL_OUTLIER <- ANL %>%
+ )
|
-
- | 486 |
- ! |
+
+ | 1225 |
+ |
- group_expr %>% # styler: off
+
|
-
- | 487 |
- ! |
+
+ | 1226 |
+ |
- dplyr::mutate(is_outlier = {
+ ### REPORTER
|
- | 488 |
+ 1227 |
! |
- q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75))
+ if (with_reporter) {
|
- | 489 |
+ 1228 |
! |
- iqr <- q1_q3[2] - q1_q3[1]
+ card_fun <- function(comment, label) {
|
- | 490 |
+ 1229 |
! |
- !(outlier_var_name >= q1_q3[1] - 1.5 * iqr & outlier_var_name <= q1_q3[2] + 1.5 * iqr)
+ tab_type <- input$tabs
|
-
- | 491 |
- |
+
+ | 1230 |
+ ! |
- }) %>%
+ card <- teal::report_card_template(
|
- | 492 |
+ 1231 |
! |
- calculate_outliers %>% # styler: off
+ title = paste0("Outliers - ", tab_type),
|
- | 493 |
+ 1232 |
! |
- ungroup_expr %>% # styler: off
+ label = label,
|
- | 494 |
+ 1233 |
! |
- dplyr::filter(is_outlier | is_outlier_selected) %>%
+ with_filter = with_filter,
|
- | 495 |
+ 1234 |
! |
- dplyr::select(-is_outlier)
+ filter_panel_api = filter_panel_api
|
- | 496 |
+ 1235 |
|
- },
- |
-
-
- | 497 |
- ! |
-
- env = list(
+ )
|
- | 498 |
+ 1236 |
! |
- calculate_outliers = if (method == "IQR") {
+ categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)
|
- | 499 |
+ 1237 |
! |
- substitute(
+ if (length(categorical_var) > 0) {
|
- | 500 |
+ 1238 |
! |
- expr = dplyr::mutate(is_outlier_selected = {
+ summary_table <- common_code_q()[["summary_table"]]
|
- | 501 |
+ 1239 |
! |
- q1_q3 <- stats::quantile(outlier_var_name, probs = c(0.25, 0.75))
+ card$append_text("Summary Table", "header3")
|
- | 502 |
+ 1240 |
! |
- iqr <- q1_q3[2] - q1_q3[1]
+ card$append_table(summary_table)
|
- | 503 |
+ 1241 |
|
- !(
+ }
|
- | 504 |
+ 1242 |
! |
- outlier_var_name >= q1_q3[1] - outlier_definition_param * iqr &
+ card$append_text("Plot", "header3")
|
- | 505 |
+ 1243 |
! |
- outlier_var_name <= q1_q3[2] + outlier_definition_param * iqr
+ if (tab_type == "Boxplot") {
|
-
- | 506 |
- |
+
+ | 1244 |
+ ! |
- )
+ card$append_plot(boxplot_r(), dim = box_pws$dim())
|
-
- | 507 |
- |
+
+ | 1245 |
+ ! |
- }),
+ } else if (tab_type == "Density Plot") {
|
- | 508 |
+ 1246 |
! |
- env = list(
+ card$append_plot(density_plot_r(), dim = density_pws$dim())
|
- | 509 |
+ 1247 |
! |
- outlier_var_name = as.name(outlier_var),
+ } else if (tab_type == "Cumulative Distribution Plot") {
|
- | 510 |
+ 1248 |
! |
- outlier_definition_param = outlier_definition_param
+ card$append_plot(cumulative_plot_r(), dim = cum_density_pws$dim())
|
- | 511 |
+ 1249 |
|
- )
+ }
|
-
- | 512 |
- |
+
+ | 1250 |
+ ! |
- )
+ if (!comment == "") {
|
- | 513 |
+ 1251 |
! |
- } else if (method == "Z-score") {
+ card$append_text("Comment", "header3")
|
- | 514 |
+ 1252 |
! |
- substitute(
+ card$append_text(comment)
|
-
- | 515 |
- ! |
+
+ | 1253 |
+ |
- expr = dplyr::mutate(
+ }
|
- | 516 |
+ 1254 |
! |
- is_outlier_selected = abs(outlier_var_name - mean(outlier_var_name)) /
+ card$append_src(teal.code::get_code(final_q()))
|
- | 517 |
+ 1255 |
! |
- stats::sd(outlier_var_name) > outlier_definition_param
+ card
|
- | 518 |
+ 1256 |
|
- ),
- |
-
-
- | 519 |
- ! |
-
- env = list(
+ }
|
- | 520 |
+ 1257 |
! |
- outlier_var_name = as.name(outlier_var),
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
-
- | 521 |
- ! |
+
+ | 1258 |
+ |
- outlier_definition_param = outlier_definition_param
+ }
|
- | 522 |
+ 1259 |
|
- )
+ ###
|
- | 523 |
+ 1260 |
|
- )
+ })
|
-
- | 524 |
- ! |
+
+ | 1261 |
+ |
- } else if (method == "Percentile") {
+ }
|
-
- | 525 |
- ! |
+
+
+
+
+
+
+
+ | 1 |
+ |
- substitute(
+ #' `teal` module: Scatterplot and regression analysis
|
-
- | 526 |
- ! |
+
+ | 2 |
+ |
- expr = dplyr::mutate(
+ #'
|
-
- | 527 |
- ! |
+
+ | 3 |
+ |
- is_outlier_selected = outlier_var_name < stats::quantile(outlier_var_name, outlier_definition_param) |
+ #' Module for visualizing regression analysis, including scatterplots and
|
-
- | 528 |
- ! |
+
+ | 4 |
+ |
- outlier_var_name > stats::quantile(outlier_var_name, 1 - outlier_definition_param)
+ #' various regression diagnostics plots.
|
- | 529 |
+ 5 |
|
- ),
+ #' It allows users to explore the relationship between a set of regressors and a response variable,
|
-
- | 530 |
- ! |
+
+ | 6 |
+ |
- env = list(
+ #' visualize residuals, and identify outliers.
|
-
- | 531 |
- ! |
+
+ | 7 |
+ |
- outlier_var_name = as.name(outlier_var),
+ #'
|
-
- | 532 |
- ! |
+
+ | 8 |
+ |
- outlier_definition_param = outlier_definition_param
+ #' @note For more examples, please see the vignette "Using regression plots" via
|
- | 533 |
+ 9 |
|
- )
+ #' `vignette("using-regression-plots", package = "teal.modules.general")`.
|
- | 534 |
+ 10 |
|
- )
+ #'
|
- | 535 |
+ 11 |
|
- },
+ #' @inheritParams teal::module
|
-
- | 536 |
- ! |
+
+ | 12 |
+ |
- outlier_var_name = as.name(outlier_var),
+ #' @inheritParams shared_params
|
-
- | 537 |
- ! |
+
+ | 13 |
+ |
- group_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
+ #' @param regressor (`data_extract_spec` or `list` of multiple `data_extract_spec`)
|
-
- | 538 |
- ! |
+
+ | 14 |
+ |
- substitute(dplyr::group_by(x), list(x = as.name(categorical_var)))
+ #' Regressor variables from an incoming dataset with filtering and selecting.
|
- | 539 |
+ 15 |
|
- },
+ #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`)
|
-
- | 540 |
- ! |
+
+ | 16 |
+ |
- ungroup_expr = if (isTRUE(split_outliers) && length(categorical_var) != 0) {
+ #' Response variables from an incoming dataset with filtering and selecting.
|
-
- | 541 |
- ! |
+
+ | 17 |
+ |
- substitute(dplyr::ungroup())
+ #' @param default_outlier_label (`character`) optional, default column selected to label outliers.
|
- | 542 |
+ 18 |
|
- }
+ #' @param default_plot_type (`numeric`) optional, defaults to "Response vs Regressor".
|
- | 543 |
+ 19 |
|
- )
+ #' 1. Response vs Regressor
|
- | 544 |
+ 20 |
|
- ) %>%
+ #' 2. Residuals vs Fitted
|
-
- | 545 |
- ! |
+
+ | 21 |
+ |
- remove_pipe_null()
+ #' 3. Normal Q-Q
|
- | 546 |
+ 22 |
|
- )
+ #' 4. Scale-Location
|
- | 547 |
+ 23 |
|
-
+ #' 5. Cook's distance
|
- | 548 |
+ 24 |
|
- # ANL_OUTLIER_EXTENDED is the base table
+ #' 6. Residuals vs Leverage
|
-
- | 549 |
- ! |
+
+ | 25 |
+ |
- qenv <- teal.code::eval_code(
+ #' 7. Cook's dist vs Leverage
|
-
- | 550 |
- ! |
+
+ | 26 |
+ |
- qenv,
+ #' @param label_segment_threshold (`numeric(1)` or `numeric(3)`)
|
-
- | 551 |
- ! |
+
+ | 27 |
+ |
- substitute(
+ #' Minimum distance between label and point on the plot that triggers the creation of
|
-
- | 552 |
- ! |
+
+ | 28 |
+ |
- expr = {
+ #' a line segment between the two.
|
-
- | 553 |
- ! |
+
+ | 29 |
+ |
- ANL_OUTLIER_EXTENDED <- dplyr::left_join(
+ #' This may happen when the label cannot be placed next to the point as it overlaps another
|
-
- | 554 |
- ! |
+
+ | 30 |
+ |
- ANL_OUTLIER,
+ #' label or point.
|
-
- | 555 |
- ! |
+
+ | 31 |
+ |
- dplyr::select(
+ #' The value is used as the `min.segment.length` parameter to the [ggrepel::geom_text_repel()] function.
|
-
- | 556 |
- ! |
+
+ | 32 |
+ |
- dataname,
+ #'
|
-
- | 557 |
- ! |
+
+ | 33 |
+ |
- dplyr::setdiff(names(dataname), dplyr::setdiff(names(ANL_OUTLIER), join_keys))
+ #' It can take the following forms:
|
- | 558 |
+ 34 |
|
- ),
+ #' - `numeric(1)`: Fixed value used for the minimum distance and the slider is not presented in the UI.
|
-
- | 559 |
- ! |
+
+ | 35 |
+ |
- by = join_keys
+ #' - `numeric(3)`: A slider is presented in the UI (under "Plot settings") to adjust the minimum distance dynamically.
|
- | 560 |
+ 36 |
|
- )
+ #'
|
- | 561 |
+ 37 |
|
- },
+ #' It takes the form of `c(value, min, max)` and it is passed to the `value_min_max`
|
-
- | 562 |
- ! |
+
+ | 38 |
+ |
- env = list(
+ #' argument in `teal.widgets::optionalSliderInputValMinMax`.
|
-
- | 563 |
- ! |
+
+ | 39 |
+ |
- dataname = as.name(dataname_first),
+ #'
|
-
- | 564 |
- ! |
+
+ | 40 |
+ |
- join_keys = as.character(teal.data::join_keys(data())[dataname_first, dataname_first])
+ #' @templateVar ggnames `r regression_names`
|
- | 565 |
+ 41 |
|
- )
+ #' @template ggplot2_args_multi
|
- | 566 |
+ 42 |
|
- )
+ #'
|
- | 567 |
+ 43 |
|
- )
+ #' @inherit shared_params return
|
- | 568 |
+ 44 |
|
-
+ #'
|
-
- | 569 |
- ! |
+
+ | 45 |
+ |
- if (length(categorical_var) > 0) {
+ #' @examplesShinylive
|
-
- | 570 |
- ! |
+
+ | 46 |
+ |
- qenv <- teal.code::eval_code(
+ #' library(teal.modules.general)
|
-
- | 571 |
- ! |
+
+ | 47 |
+ |
- qenv,
+ #' interactive <- function() TRUE
|
-
- | 572 |
- ! |
+
+ | 48 |
+ |
- substitute(
+ #' {{ next_example }}
|
-
- | 573 |
- ! |
+
+ | 49 |
+ |
- expr = summary_table_pre <- ANL_OUTLIER %>%
+ #' @examples
|
-
- | 574 |
- ! |
+
+ | 50 |
+ |
- dplyr::filter(is_outlier_selected) %>%
+ #' # general data example
|
-
- | 575 |
- ! |
+
+ | 51 |
+ |
- dplyr::select(outlier_var_name, categorical_var_name) %>%
+ #' data <- teal_data()
|
-
- | 576 |
- ! |
+
+ | 52 |
+ |
- dplyr::group_by(categorical_var_name) %>%
+ #' data <- within(data, {
|
-
- | 577 |
- ! |
+
+ | 53 |
+ |
- dplyr::summarise(n_outliers = dplyr::n()) %>%
+ #' require(nestcolor)
|
-
- | 578 |
- ! |
+
+ | 54 |
+ |
- dplyr::right_join(
+ #' CO2 <- CO2
|
-
- | 579 |
- ! |
+
+ | 55 |
+ |
- ANL %>%
+ #' })
|
-
- | 580 |
- ! |
+
+ | 56 |
+ |
- dplyr::select(outlier_var_name, categorical_var_name) %>%
+ #' datanames(data) <- c("CO2")
|
-
- | 581 |
- ! |
+
+ | 57 |
+ |
- dplyr::group_by(categorical_var_name) %>%
+ #'
|
-
- | 582 |
- ! |
+
+ | 58 |
+ |
- dplyr::summarise(
+ #' app <- init(
|
-
- | 583 |
- ! |
+
+ | 59 |
+ |
- total_in_cat = dplyr::n(),
+ #' data = data,
|
-
- | 584 |
- ! |
+
+ | 60 |
+ |
- n_na = sum(is.na(outlier_var_name) | is.na(categorical_var_name))
+ #' modules = modules(
|
- | 585 |
+ 61 |
|
- ),
+ #' tm_a_regression(
|
-
- | 586 |
- ! |
+
+ | 62 |
+ |
- by = categorical_var
+ #' label = "Regression",
|
- | 587 |
+ 63 |
|
- ) %>%
+ #' response = data_extract_spec(
|
- | 588 |
+ 64 |
|
- # This is important as there may be categorical variables with natural orderings, e.g. AGE.
+ #' dataname = "CO2",
|
- | 589 |
+ 65 |
|
- # The plots should be displayed by default in increasing order in these situations.
+ #' select = select_spec(
|
- | 590 |
+ 66 |
|
- # dplyr::arrange will sort integer, factor, and character data types in the expected way.
+ #' label = "Select variable:",
|
-
- | 591 |
- ! |
+
+ | 67 |
+ |
- dplyr::arrange(categorical_var_name) %>%
+ #' choices = "uptake",
|
-
- | 592 |
- ! |
+
+ | 68 |
+ |
- dplyr::mutate(
+ #' selected = "uptake",
|
-
- | 593 |
- ! |
+
+ | 69 |
+ |
- n_outliers = dplyr::if_else(is.na(n_outliers), 0, as.numeric(n_outliers)),
+ #' multiple = FALSE,
|
-
- | 594 |
- ! |
+
+ | 70 |
+ |
- display_str = dplyr::if_else(
+ #' fixed = TRUE
|
-
- | 595 |
- ! |
+
+ | 71 |
+ |
- n_outliers > 0,
+ #' )
|
-
- | 596 |
- ! |
+
+ | 72 |
+ |
- sprintf("%d [%.02f%%]", n_outliers, 100 * n_outliers / total_in_cat),
+ #' ),
|
-
- | 597 |
- ! |
+
+ | 73 |
+ |
- "0"
+ #' regressor = data_extract_spec(
|
- | 598 |
+ 74 |
|
- ),
+ #' dataname = "CO2",
|
-
- | 599 |
- ! |
+
+ | 75 |
+ |
- display_str_na = dplyr::if_else(
+ #' select = select_spec(
|
-
- | 600 |
- ! |
+
+ | 76 |
+ |
- n_na > 0,
+ #' label = "Select variables:",
|
-
- | 601 |
- ! |
+
+ | 77 |
+ |
- sprintf("%d [%.02f%%]", n_na, 100 * n_na / total_in_cat),
+ #' choices = variable_choices(data[["CO2"]], c("conc", "Treatment")),
|
-
- | 602 |
- ! |
+
+ | 78 |
+ |
- "0"
+ #' selected = "conc",
|
- | 603 |
+ 79 |
|
- ),
+ #' multiple = TRUE,
|
-
- | 604 |
- ! |
+
+ | 80 |
+ |
- order = seq_along(n_outliers)
+ #' fixed = FALSE
|
- | 605 |
+ 81 |
|
- ),
+ #' )
|
-
- | 606 |
- ! |
+
+ | 82 |
+ |
- env = list(
+ #' )
|
-
- | 607 |
- ! |
+
+ | 83 |
+ |
- categorical_var = categorical_var,
+ #' )
|
-
- | 608 |
- ! |
+
+ | 84 |
+ |
- categorical_var_name = as.name(categorical_var),
+ #' )
|
-
- | 609 |
- ! |
+
+ | 85 |
+ |
- outlier_var_name = as.name(outlier_var)
+ #' )
|
- | 610 |
+ 86 |
|
- )
+ #' if (interactive()) {
|
- | 611 |
+ 87 |
|
- )
+ #' shinyApp(app$ui, app$server)
|
- | 612 |
+ 88 |
|
- )
+ #' }
|
- | 613 |
+ 89 |
|
- # now to handle when user chooses to order based on amount of outliers
+ #'
|
-
- | 614 |
- ! |
+
+ | 90 |
+ |
- if (order_by_outlier) {
+ #' @examplesShinylive
|
-
- | 615 |
- ! |
+
+ | 91 |
+ |
- qenv <- teal.code::eval_code(
+ #' library(teal.modules.general)
|
-
- | 616 |
- ! |
+
+ | 92 |
+ |
- qenv,
+ #' interactive <- function() TRUE
|
-
- | 617 |
- ! |
+
+ | 93 |
+ |
- quote(
+ #' {{ next_example }}
|
-
- | 618 |
- ! |
+
+ | 94 |
+ |
- summary_table_pre <- summary_table_pre %>%
+ #' @examples
|
-
- | 619 |
- ! |
+
+ | 95 |
+ |
- dplyr::arrange(desc(n_outliers / total_in_cat)) %>%
+ #' # CDISC data example
|
-
- | 620 |
- ! |
+
+ | 96 |
+ |
- dplyr::mutate(order = seq_len(nrow(summary_table_pre)))
+ #' data <- teal_data()
|
- | 621 |
+ 97 |
|
- )
+ #' data <- within(data, {
|
- | 622 |
+ 98 |
|
- )
+ #' require(nestcolor)
|
- | 623 |
+ 99 |
|
- }
+ #' ADSL <- rADSL
|
- | 624 |
+ 100 |
|
-
+ #' })
|
-
- | 625 |
- ! |
+
+ | 101 |
+ |
- qenv <- teal.code::eval_code(
+ #' datanames(data) <- "ADSL"
|
-
- | 626 |
- ! |
+
+ | 102 |
+ |
- qenv,
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
|
-
- | 627 |
- ! |
+
+ | 103 |
+ |
- substitute(
+ #'
|
-
- | 628 |
- ! |
+
+ | 104 |
+ |
- expr = {
+ #' app <- init(
|
- | 629 |
+ 105 |
|
- # In order for geom_rug to work properly when reordering takes place inside facet_grid,
+ #' data = data,
|
- | 630 |
+ 106 |
|
- # all tables must have the column used for reording.
+ #' modules = modules(
|
- | 631 |
+ 107 |
|
- # In this case, the column used for reordering is `order`.
+ #' tm_a_regression(
|
-
- | 632 |
- ! |
+
+ | 108 |
+ |
- ANL_OUTLIER <- dplyr::left_join(
+ #' label = "Regression",
|
-
- | 633 |
- ! |
+
+ | 109 |
+ |
- ANL_OUTLIER,
+ #' response = data_extract_spec(
|
-
- | 634 |
- ! |
+
+ | 110 |
+ |
- summary_table_pre[, c("order", categorical_var)],
+ #' dataname = "ADSL",
|
-
- | 635 |
- ! |
+
+ | 111 |
+ |
- by = categorical_var
+ #' select = select_spec(
|
- | 636 |
+ 112 |
|
- )
+ #' label = "Select variable:",
|
- | 637 |
+ 113 |
|
- # so that x axis of plot aligns with columns of summary table, from most outliers to least by percentage
+ #' choices = "BMRKR1",
|
-
- | 638 |
- ! |
+
+ | 114 |
+ |
- ANL <- ANL %>%
+ #' selected = "BMRKR1",
|
-
- | 639 |
- ! |
+
+ | 115 |
+ |
- dplyr::left_join(
+ #' multiple = FALSE,
|
-
- | 640 |
- ! |
+
+ | 116 |
+ |
- dplyr::select(summary_table_pre, categorical_var_name, order),
+ #' fixed = TRUE
|
-
- | 641 |
- ! |
+
+ | 117 |
+ |
- by = categorical_var
+ #' )
|
- | 642 |
+ 118 |
|
- ) %>%
+ #' ),
|
-
- | 643 |
- ! |
+
+ | 119 |
+ |
- dplyr::arrange(order)
+ #' regressor = data_extract_spec(
|
-
- | 644 |
- ! |
+
+ | 120 |
+ |
- summary_table <- summary_table_pre %>%
+ #' dataname = "ADSL",
|
-
- | 645 |
- ! |
+
+ | 121 |
+ |
- dplyr::select(
+ #' select = select_spec(
|
-
- | 646 |
- ! |
+
+ | 122 |
+ |
- categorical_var_name,
+ #' label = "Select variables:",
|
-
- | 647 |
- ! |
+
+ | 123 |
+ |
- Outliers = display_str, Missings = display_str_na, Total = total_in_cat
+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "SEX", "RACE")),
|
- | 648 |
+ 124 |
|
- ) %>%
+ #' selected = "AGE",
|
-
- | 649 |
- ! |
+
+ | 125 |
+ |
- dplyr::mutate_all(as.character) %>%
+ #' multiple = TRUE,
|
-
- | 650 |
- ! |
+
+ | 126 |
+ |
- tidyr::pivot_longer(-categorical_var_name) %>%
+ #' fixed = FALSE
|
-
- | 651 |
- ! |
+
+ | 127 |
+ |
- tidyr::pivot_wider(names_from = categorical_var, values_from = value) %>%
+ #' )
|
-
- | 652 |
- ! |
+
+ | 128 |
+ |
- tibble::column_to_rownames("name")
+ #' )
|
-
- | 653 |
- ! |
+
+ | 129 |
+ |
- summary_table
+ #' )
|
- | 654 |
+ 130 |
|
- },
+ #' )
|
-
- | 655 |
- ! |
+
+ | 131 |
+ |
- env = list(
+ #' )
|
-
- | 656 |
- ! |
+
+ | 132 |
+ |
- categorical_var = categorical_var,
+ #' if (interactive()) {
|
-
- | 657 |
- ! |
+
+ | 133 |
+ |
- categorical_var_name = as.name(categorical_var)
+ #' shinyApp(app$ui, app$server)
|
- | 658 |
+ 134 |
|
- )
+ #' }
|
- | 659 |
+ 135 |
|
- )
+ #'
|
- | 660 |
+ 136 |
|
- )
+ #' @export
|
- | 661 |
+ 137 |
|
- }
+ #'
|
- | 662 |
+ 138 |
|
-
+ tm_a_regression <- function(label = "Regression Analysis",
|
-
- | 663 |
- ! |
+
+ | 139 |
+ |
- if (length(categorical_var) > 0 && nrow(qenv[["ANL_OUTLIER"]]) > 0) {
+ regressor,
|
-
- | 664 |
- ! |
+
+ | 140 |
+ |
- shinyjs::show("order_by_outlier")
+ response,
|
- | 665 |
+ 141 |
|
- } else {
+ plot_height = c(600, 200, 2000),
|
-
- | 666 |
- ! |
+
+ | 142 |
+ |
- shinyjs::hide("order_by_outlier")
+ plot_width = NULL,
|
- | 667 |
+ 143 |
|
- }
+ alpha = c(1, 0, 1),
|
- | 668 |
+ 144 |
|
-
+ size = c(2, 1, 8),
|
-
- | 669 |
- ! |
+
+ | 145 |
+ |
- qenv
+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
- | 670 |
+ 146 |
|
- })
+ ggplot2_args = teal.widgets::ggplot2_args(),
|
- | 671 |
+ 147 |
|
-
+ pre_output = NULL,
|
-
- | 672 |
- ! |
+
+ | 148 |
+ |
- output$summary_table <- DT::renderDataTable(
+ post_output = NULL,
|
-
- | 673 |
- ! |
+
+ | 149 |
+ |
- expr = {
+ default_plot_type = 1,
|
-
- | 674 |
- ! |
+
+ | 150 |
+ |
- if (iv_r()$is_valid()) {
+ default_outlier_label = "USUBJID",
|
-
- | 675 |
- ! |
+
+ | 151 |
+ |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)
+ label_segment_threshold = c(0.5, 0, 10)) {
|
- | 676 |
+ 152 |
! |
- if (!is.null(categorical_var)) {
+ message("Initializing tm_a_regression")
|
-
- | 677 |
- ! |
+
+ | 153 |
+ |
- DT::datatable(
+
|
-
- | 678 |
- ! |
+
+ | 154 |
+ |
- common_code_q()[["summary_table"]],
+ # Normalize the parameters
|
- | 679 |
+ 155 |
! |
- options = list(
+ if (inherits(regressor, "data_extract_spec")) regressor <- list(regressor)
|
- | 680 |
+ 156 |
! |
- dom = "t",
+ if (inherits(response, "data_extract_spec")) response <- list(response)
|
- | 681 |
+ 157 |
! |
- autoWidth = TRUE,
+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)
|
-
- | 682 |
- ! |
+
+ | 158 |
+ |
- columnDefs = list(list(width = "200px", targets = "_all"))
+
|
- | 683 |
+ 159 |
|
- )
+ # Start of assertions
|
-
- | 684 |
- |
+
+ | 160 |
+ ! |
- )
+ checkmate::assert_string(label)
|
-
- | 685 |
- |
+
+ | 161 |
+ ! |
- }
+ checkmate::assert_list(regressor, types = "data_extract_spec")
|
- | 686 |
+ 162 |
|
- }
+
|
-
- | 687 |
- |
+
+ | 163 |
+ ! |
- }
+ checkmate::assert_list(response, types = "data_extract_spec")
|
-
- | 688 |
- |
+
+ | 164 |
+ ! |
- )
+ assert_single_selection(response)
|
- | 689 |
+ 165 |
|
|
+
+ | 166 |
+ ! |
+
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
+ |
+
+
+ | 167 |
+ ! |
+
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
+ |
+
- | 690 |
+ 168 |
|
- # boxplot/violinplot # nolint commented_code
+
|
- | 691 |
+ 169 |
! |
- boxplot_q <- reactive({
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
|
- | 692 |
+ 170 |
! |
- req(common_code_q())
+ checkmate::assert_numeric(
|
- | 693 |
+ 171 |
! |
- ANL <- common_code_q()[["ANL"]]
+ plot_width[1],
|
- | 694 |
+ 172 |
! |
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]
+ lower = plot_width[2],
|
-
- | 695 |
- |
+
+ | 173 |
+ ! |
-
+ upper = plot_width[3],
|
- | 696 |
+ 174 |
! |
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)
+ null.ok = TRUE,
|
- | 697 |
+ 175 |
! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)
+ .var.name = "plot_width"
|
- | 698 |
+ 176 |
|
-
+ )
|
- | 699 |
+ 177 |
|
- # validation
+
|
- | 700 |
+ 178 |
! |
- teal::validate_has_data(ANL, 1)
+ if (length(alpha) == 1) {
|
-
- | 701 |
- |
+
+ | 179 |
+ ! |
-
+ checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE)
|
- | 702 |
+ 180 |
|
- # boxplot
+ } else {
|
- | 703 |
+ 181 |
! |
- plot_call <- quote(ANL %>% ggplot())
+ checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE)
|
-
- | 704 |
- |
+
+ | 182 |
+ ! |
-
+ checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")
|
-
- | 705 |
- ! |
+
+ | 183 |
+ |
- plot_call <- if (input$boxplot_alts == "Box plot") {
+ }
|
-
- | 706 |
- ! |
+
+ | 184 |
+ |
- substitute(expr = plot_call + geom_boxplot(outlier.shape = NA), env = list(plot_call = plot_call))
+
|
- | 707 |
+ 185 |
! |
- } else if (input$boxplot_alts == "Violin plot") {
+ if (length(size) == 1) {
|
- | 708 |
+ 186 |
! |
- substitute(expr = plot_call + geom_violin(), env = list(plot_call = plot_call))
+ checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE)
|
- | 709 |
+ 187 |
|
- } else {
+ } else {
|
- | 710 |
+ 188 |
! |
- NULL
+ checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE)
|
-
- | 711 |
- |
+
+ | 189 |
+ ! |
- }
+ checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")
|
- | 712 |
+ 190 |
|
-
+ }
|
-
- | 713 |
- ! |
+
+ | 191 |
+ |
- plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
+
|
- | 714 |
+ 192 |
! |
- inner_call <- substitute(
+ ggtheme <- match.arg(ggtheme)
|
-
- | 715 |
- ! |
+
+ | 193 |
+ |
- expr = plot_call +
+
|
- | 716 |
+ 194 |
! |
- aes(x = "Entire dataset", y = outlier_var_name) +
+ plot_choices <- c(
|
- | 717 |
+ 195 |
! |
- scale_x_discrete(),
+ "Response vs Regressor", "Residuals vs Fitted", "Normal Q-Q", "Scale-Location",
|
- | 718 |
+ 196 |
! |
- env = list(plot_call = plot_call, outlier_var_name = as.name(outlier_var))
+ "Cook's distance", "Residuals vs Leverage", "Cook's dist vs Leverage"
|
- | 719 |
+ 197 |
|
- )
+ )
|
- | 720 |
+ 198 |
! |
- if (nrow(ANL_OUTLIER) > 0) {
+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args")
|
- | 721 |
+ 199 |
! |
- substitute(
+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
-
- | 722 |
- ! |
+
+ | 200 |
+ |
- expr = inner_call + geom_point(
+
|
- | 723 |
+ 201 |
! |
- data = ANL_OUTLIER,
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
- | 724 |
+ 202 |
! |
- aes(x = "Entire dataset", y = outlier_var_name, color = is_outlier_selected)
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
-
- | 725 |
- |
+
+ | 203 |
+ ! |
- ),
+ checkmate::assert_choice(default_plot_type, seq.int(1L, length(plot_choices)))
|
- | 726 |
+ 204 |
! |
- env = list(inner_call = inner_call, outlier_var_name = as.name(outlier_var))
+ checkmate::assert_string(default_outlier_label)
|
- | 727 |
+ 205 |
|
- )
+
|
-
- | 728 |
- |
+
+ | 206 |
+ ! |
- } else {
+ if (length(label_segment_threshold) == 1) {
|
- | 729 |
+ 207 |
! |
- inner_call
+ checkmate::assert_numeric(label_segment_threshold, any.missing = FALSE, finite = TRUE)
|
- | 730 |
+ 208 |
|
- }
+ } else {
|
-
- | 731 |
- |
+
+ | 209 |
+ ! |
- } else {
+ checkmate::assert_numeric(label_segment_threshold, len = 3, any.missing = FALSE, finite = TRUE)
|
- | 732 |
+ 210 |
! |
- substitute(
+ checkmate::assert_numeric(
|
- | 733 |
+ 211 |
! |
- expr = plot_call +
+ label_segment_threshold[1],
|
- | 734 |
+ 212 |
! |
- aes(y = outlier_var_name, x = reorder(categorical_var_name, order)) +
+ lower = label_segment_threshold[2],
|
- | 735 |
+ 213 |
! |
- xlab(categorical_var) +
+ upper = label_segment_threshold[3],
|
- | 736 |
+ 214 |
! |
- scale_x_discrete() +
+ .var.name = "label_segment_threshold"
|
-
- | 737 |
- ! |
+
+ | 215 |
+ |
- geom_point(
+ )
|
-
- | 738 |
- ! |
+
+ | 216 |
+ |
- data = ANL_OUTLIER,
+ }
|
-
- | 739 |
- ! |
+
+ | 217 |
+ |
- aes(x = as.factor(categorical_var_name), y = outlier_var_name, color = is_outlier_selected)
+ # End of assertions
|
- | 740 |
+ 218 |
|
- ),
+
+ |
+
+
+ | 219 |
+ |
+
+ # Make UI args
|
- | 741 |
+ 220 |
! |
- env = list(
+ args <- as.list(environment())
|
- | 742 |
+ 221 |
! |
- plot_call = plot_call,
+ args[["plot_choices"]] <- plot_choices
|
- | 743 |
+ 222 |
! |
- outlier_var_name = as.name(outlier_var),
+ data_extract_list <- list(
|
- | 744 |
+ 223 |
! |
- categorical_var_name = as.name(categorical_var),
+ regressor = regressor,
|
- | 745 |
+ 224 |
! |
- categorical_var = categorical_var
+ response = response
|
- | 746 |
+ 225 |
|
- )
+ )
|
- | 747 |
+ 226 |
|
- )
+
|
-
- | 748 |
- |
+
+ | 227 |
+ ! |
- }
+ ans <- module(
|
-
- | 749 |
- |
+
+ | 228 |
+ ! |
-
+ label = label,
|
- | 750 |
+ 229 |
! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(
+ server = srv_a_regression,
|
- | 751 |
+ 230 |
! |
- labs = list(color = "Is outlier?"),
+ ui = ui_a_regression,
|
- | 752 |
+ 231 |
! |
- theme = list(legend.position = "top")
+ ui_args = args,
|
-
- | 753 |
- |
+
+ | 232 |
+ ! |
- )
+ server_args = c(
|
-
- | 754 |
- |
+
+ | 233 |
+ ! |
-
+ data_extract_list,
|
- | 755 |
+ 234 |
! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
+ list(
|
- | 756 |
+ 235 |
! |
- user_plot = ggplot2_args[["Boxplot"]],
+ plot_height = plot_height,
|
- | 757 |
+ 236 |
! |
- user_default = ggplot2_args$default,
+ plot_width = plot_width,
|
- | 758 |
+ 237 |
! |
- module_plot = dev_ggplot2_args
+ default_outlier_label = default_outlier_label,
+ |
+
+
+ | 238 |
+ ! |
+
+ ggplot2_args = ggplot2_args
|
- | 759 |
+ 239 |
|
)
|
- | 760 |
+ 240 |
|
-
+ ),
|
- | 761 |
+ 241 |
! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
+ datanames = teal.transform::get_extract_datanames(data_extract_list)
+ |
+
+
+ | 242 |
+ |
+
+ )
|
- | 762 |
+ 243 |
! |
- all_ggplot2_args,
+ attr(ans, "teal_bookmarkable") <- FALSE
|
- | 763 |
+ 244 |
! |
- ggtheme = input$ggtheme
+ ans
|
- | 764 |
+ 245 |
|
- )
+ }
|
- | 765 |
+ 246 |
|
|
-
- | 766 |
- ! |
+
+ | 247 |
+ |
- teal.code::eval_code(
+ # UI function for the regression module
|
-
- | 767 |
- ! |
+
+ | 248 |
+ |
- common_code_q(),
+ ui_a_regression <- function(id, ...) {
|
- | 768 |
+ 249 |
! |
- substitute(
+ ns <- NS(id)
|
- | 769 |
+ 250 |
! |
- expr = g <- plot_call +
+ args <- list(...)
|
- | 770 |
+ 251 |
! |
- scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
+ is_single_dataset_value <- teal.transform::is_single_dataset(args$regressor, args$response)
|
-
- | 771 |
- ! |
+
+ | 252 |
+ |
- labs + ggthemes + themes,
+
|
- | 772 |
+ 253 |
! |
- env = list(
+ teal.widgets::standard_layout(
|
- | 773 |
+ 254 |
! |
- plot_call = plot_call,
+ output = teal.widgets::white_small_well(tags$div(
|
- | 774 |
+ 255 |
! |
- labs = parsed_ggplot2_args$labs,
- |
-
-
- | 775 |
- ! |
-
- ggthemes = parsed_ggplot2_args$ggtheme,
+ teal.widgets::plot_with_settings_ui(id = ns("myplot")),
|
- | 776 |
+ 256 |
! |
- themes = parsed_ggplot2_args$theme
+ tags$div(verbatimTextOutput(ns("text")))
|
- | 777 |
+ 257 |
|
- )
+ )),
|
-
- | 778 |
- |
+
+ | 258 |
+ ! |
- )
+ encoding = tags$div(
|
- | 779 |
+ 259 |
|
- ) %>%
+ ### Reporter
|
- | 780 |
+ 260 |
! |
- teal.code::eval_code(quote(print(g)))
- |
-
-
- | 781 |
- |
-
- })
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
- | 782 |
+ 261 |
|
-
+ ###
|
-
- | 783 |
- |
+
+ | 262 |
+ ! |
- # density plot
+ tags$label("Encodings", class = "text-primary"),
|
- | 784 |
+ 263 |
! |
- density_plot_q <- reactive({
+ teal.transform::datanames_input(args[c("response", "regressor")]),
|
- | 785 |
+ 264 |
! |
- ANL <- common_code_q()[["ANL"]]
+ teal.transform::data_extract_ui(
|
- | 786 |
+ 265 |
! |
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]
+ id = ns("response"),
|
-
- | 787 |
- |
+
+ | 266 |
+ ! |
-
+ label = "Response variable",
|
- | 788 |
+ 267 |
! |
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)
+ data_extract_spec = args$response,
|
- | 789 |
+ 268 |
! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)
+ is_single_dataset = is_single_dataset_value
|
- | 790 |
+ 269 |
|
-
+ ),
|
-
- | 791 |
- |
+
+ | 270 |
+ ! |
- # validation
+ teal.transform::data_extract_ui(
|
- | 792 |
+ 271 |
! |
- teal::validate_has_data(ANL, 1)
+ id = ns("regressor"),
|
-
- | 793 |
- |
+
+ | 272 |
+ ! |
- # plot
+ label = "Regressor variables",
|
- | 794 |
+ 273 |
! |
- plot_call <- substitute(
+ data_extract_spec = args$regressor,
|
- | 795 |
+ 274 |
! |
- expr = ANL %>%
+ is_single_dataset = is_single_dataset_value
|
-
- | 796 |
- ! |
+
+ | 275 |
+ |
- ggplot(aes(x = outlier_var_name)) +
+ ),
|
- | 797 |
+ 276 |
! |
- geom_density() +
+ radioButtons(
|
- | 798 |
+ 277 |
! |
- geom_rug(data = ANL_OUTLIER, aes(x = outlier_var_name, color = is_outlier_selected)) +
+ ns("plot_type"),
|
- | 799 |
+ 278 |
! |
- scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")),
+ label = "Plot type:",
|
- | 800 |
+ 279 |
! |
- env = list(outlier_var_name = as.name(outlier_var))
+ choices = args$plot_choices,
|
-
- | 801 |
- |
+
+ | 280 |
+ ! |
- )
+ selected = args$plot_choices[args$default_plot_type]
|
- | 802 |
+ 281 |
|
-
+ ),
|
- | 803 |
+ 282 |
! |
- plot_call <- if (identical(categorical_var, character(0)) || is.null(categorical_var)) {
+ checkboxInput(ns("show_outlier"), label = "Display outlier labels", value = TRUE),
|
- | 804 |
+ 283 |
! |
- substitute(expr = plot_call, env = list(plot_call = plot_call))
- |
-
-
- | 805 |
- |
-
- } else {
+ conditionalPanel(
|
- | 806 |
+ 284 |
! |
- substitute(
+ condition = "input['show_outlier']",
|
- | 807 |
+ 285 |
! |
- expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)),
+ ns = ns,
|
- | 808 |
+ 286 |
! |
- env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var))
+ teal.widgets::optionalSliderInput(
|
-
- | 809 |
- |
+
+ | 287 |
+ ! |
- )
+ ns("outlier"),
|
-
- | 810 |
- |
+
+ | 288 |
+ ! |
- }
+ tags$div(
|
-
- | 811 |
- |
+
+ | 289 |
+ ! |
-
+ class = "teal-tooltip",
|
- | 812 |
+ 290 |
! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(
+ tagList(
|
- | 813 |
+ 291 |
! |
- labs = list(color = "Is outlier?"),
+ "Outlier definition:",
|
- | 814 |
+ 292 |
! |
- theme = list(legend.position = "top")
+ icon("circle-info"),
|
-
- | 815 |
- |
+
+ | 293 |
+ ! |
- )
+ tags$span(
|
-
- | 816 |
- |
+
+ | 294 |
+ ! |
-
+ class = "tooltiptext",
|
- | 817 |
+ 295 |
! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
+ paste(
|
- | 818 |
+ 296 |
! |
- user_plot = ggplot2_args[["Density Plot"]],
+ "Use the slider to choose the cut-off value to define outliers.",
|
- | 819 |
+ 297 |
! |
- user_default = ggplot2_args$default,
+ "Points with a Cook's distance greater than",
|
- | 820 |
+ 298 |
! |
- module_plot = dev_ggplot2_args
+ "the value on the slider times the mean of the Cook's distance of the dataset will have labels."
|
- | 821 |
+ 299 |
|
- )
+ )
|
- | 822 |
+ 300 |
|
-
+ )
|
-
- | 823 |
- ! |
+
+ | 301 |
+ |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
+ )
|
-
- | 824 |
- ! |
+
+ | 302 |
+ |
- all_ggplot2_args,
+ ),
|
- | 825 |
+ 303 |
! |
- ggtheme = input$ggtheme
- |
-
-
- | 826 |
- |
-
- )
+ min = 1, max = 10, value = 9, ticks = FALSE, step = .1
|
- | 827 |
+ 304 |
|
-
+ ),
|
- | 828 |
+ 305 |
! |
- teal.code::eval_code(
+ teal.widgets::optionalSelectInput(
|
- | 829 |
+ 306 |
! |
- common_code_q(),
+ ns("label_var"),
|
- | 830 |
+ 307 |
! |
- substitute(
+ multiple = FALSE,
|
- | 831 |
+ 308 |
! |
- expr = g <- plot_call + labs + ggthemes + themes,
+ label = "Outlier label"
|
-
- | 832 |
- ! |
+
+ | 309 |
+ |
- env = list(
+ )
|
-
- | 833 |
- ! |
+
+ | 310 |
+ |
- plot_call = plot_call,
+ ),
|
- | 834 |
+ 311 |
! |
- labs = parsed_ggplot2_args$labs,
+ teal.widgets::panel_group(
|
- | 835 |
+ 312 |
! |
- themes = parsed_ggplot2_args$theme,
+ teal.widgets::panel_item(
|
- | 836 |
+ 313 |
! |
- ggthemes = parsed_ggplot2_args$ggtheme
+ title = "Plot settings",
|
-
- | 837 |
- |
+
+ | 314 |
+ ! |
- )
+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
|
-
- | 838 |
- |
+
+ | 315 |
+ ! |
- )
+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE),
|
-
- | 839 |
- |
+
+ | 316 |
+ ! |
- ) %>%
+ teal.widgets::optionalSliderInputValMinMax(
|
- | 840 |
+ 317 |
! |
- teal.code::eval_code(quote(print(g)))
+ inputId = ns("label_min_segment"),
|
-
- | 841 |
- |
+
+ | 318 |
+ ! |
- })
+ label = tags$div(
|
-
- | 842 |
- |
+
+ | 319 |
+ ! |
-
+ class = "teal-tooltip",
|
-
- | 843 |
- |
+
+ | 320 |
+ ! |
- # Cumulative distribution plot
+ tagList(
|
- | 844 |
+ 321 |
! |
- cumulative_plot_q <- reactive({
+ "Label min. segment:",
|
- | 845 |
+ 322 |
! |
- ANL <- common_code_q()[["ANL"]]
+ icon("circle-info"),
|
- | 846 |
+ 323 |
! |
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]
+ tags$span(
|
-
- | 847 |
- |
+
+ | 324 |
+ ! |
-
+ class = "tooltiptext",
|
- | 848 |
+ 325 |
! |
- qenv <- common_code_q()
+ paste(
|
-
- | 849 |
- |
+
+ | 326 |
+ ! |
-
+ "Use the slider to choose the cut-off value to define minimum distance between label and point",
|
- | 850 |
+ 327 |
! |
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)
+ "that generates a line segment.",
|
- | 851 |
+ 328 |
! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)
+ "It's only valid when 'Display outlier labels' is checked."
|
- | 852 |
+ 329 |
|
-
+ )
|
- | 853 |
+ 330 |
|
- # validation
- |
-
-
- | 854 |
- ! |
-
- teal::validate_has_data(ANL, 1)
+ )
|
- | 855 |
+ 331 |
|
-
+ )
|
- | 856 |
+ 332 |
|
- # plot
+ ),
|
- | 857 |
+ 333 |
! |
- plot_call <- substitute(
+ value_min_max = args$label_segment_threshold,
+ |
+
+
+ | 334 |
+ |
+
+ # Extra parameters to sliderInput
|
- | 858 |
+ 335 |
! |
- expr = ANL %>% ggplot(aes(x = outlier_var_name)) +
+ ticks = FALSE,
|
- | 859 |
+ 336 |
! |
- stat_ecdf(),
+ step = .1,
|
- | 860 |
+ 337 |
! |
- env = list(outlier_var_name = as.name(outlier_var))
+ round = FALSE
|
- | 861 |
+ 338 |
|
- )
+ ),
|
- | 862 |
+ 339 |
! |
- if (length(categorical_var) == 0) {
+ selectInput(
|
- | 863 |
+ 340 |
! |
- qenv <- teal.code::eval_code(
+ inputId = ns("ggtheme"),
|
- | 864 |
+ 341 |
! |
- qenv,
+ label = "Theme (by ggplot):",
|
- | 865 |
+ 342 |
! |
- substitute(
+ choices = ggplot_themes,
|
- | 866 |
+ 343 |
! |
- expr = {
+ selected = args$ggtheme,
|
- | 867 |
+ 344 |
! |
- ecdf_df <- ANL %>%
+ multiple = FALSE
|
-
- | 868 |
- ! |
+
+ | 345 |
+ |
- dplyr::mutate(
+ )
|
-
- | 869 |
- ! |
+
+ | 346 |
+ |
- y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]])
+ )
|
- | 870 |
+ 347 |
|
- )
+ )
|
- | 871 |
+ 348 |
|
-
+ ),
|
- | 872 |
+ 349 |
! |
- outlier_points <- dplyr::left_join(
+ forms = tagList(
|
- | 873 |
+ 350 |
! |
- ecdf_df,
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ |
+
+
+ | 351 |
+ |
+
+ ),
|
- | 874 |
+ 352 |
! |
- ANL_OUTLIER,
+ pre_output = args$pre_output,
|
- | 875 |
+ 353 |
! |
- by = dplyr::setdiff(names(ecdf_df), "y")
+ post_output = args$post_output
|
- | 876 |
+ 354 |
|
- ) %>%
+ )
|
-
- | 877 |
- ! |
+
+ | 355 |
+ |
- dplyr::filter(!is.na(is_outlier_selected))
+ }
|
- | 878 |
+ 356 |
|
- },
+
|
-
- | 879 |
- ! |
+
+ | 357 |
+ |
- env = list(outlier_var = outlier_var)
+ # Server function for the regression module
|
- | 880 |
+ 358 |
|
- )
+ srv_a_regression <- function(id,
|
- | 881 |
+ 359 |
|
- )
+ data,
|
- | 882 |
+ 360 |
|
- } else {
+ reporter,
|
-
- | 883 |
- ! |
+
+ | 361 |
+ |
- qenv <- teal.code::eval_code(
+ filter_panel_api,
|
-
- | 884 |
- ! |
+
+ | 362 |
+ |
- qenv,
+ response,
|
-
- | 885 |
- ! |
+
+ | 363 |
+ |
- substitute(
+ regressor,
|
-
- | 886 |
- ! |
+
+ | 364 |
+ |
- expr = {
+ plot_height,
|
-
- | 887 |
- ! |
+
+ | 365 |
+ |
- all_categories <- lapply(
+ plot_width,
+ |
+
+
+ | 366 |
+ |
+
+ ggplot2_args,
+ |
+
+
+ | 367 |
+ |
+
+ default_outlier_label) {
|
- | 888 |
+ 368 |
! |
- unique(ANL[[categorical_var]]),
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
|
- | 889 |
+ 369 |
! |
- function(x) {
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
|
- | 890 |
+ 370 |
! |
- ANL <- ANL %>% dplyr::filter(get(categorical_var) == x)
+ checkmate::assert_class(data, "reactive")
|
- | 891 |
+ 371 |
! |
- anl_outlier2 <- ANL_OUTLIER %>% dplyr::filter(get(categorical_var) == x)
+ checkmate::assert_class(isolate(data()), "teal_data")
|
- | 892 |
+ 372 |
! |
- ecdf_df <- ANL %>%
+ moduleServer(id, function(input, output, session) {
|
- | 893 |
+ 373 |
! |
- dplyr::mutate(y = stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]]))
+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
|
- | 894 |
+ 374 |
|
|
- | 895 |
+ 375 |
! |
- dplyr::left_join(
+ ns <- session$ns
|
-
- | 896 |
- ! |
+
+ | 376 |
+ |
- ecdf_df,
+
|
- | 897 |
+ 377 |
! |
- anl_outlier2,
+ rule_rvr1 <- function(value) {
|
- | 898 |
+ 378 |
! |
- by = dplyr::setdiff(names(ecdf_df), "y")
+ if (isTRUE(input$plot_type == "Response vs Regressor")) {
|
-
- | 899 |
- |
+
+ | 379 |
+ ! |
- ) %>%
+ if (length(value) > 1L) {
|
- | 900 |
+ 380 |
! |
- dplyr::filter(!is.na(is_outlier_selected))
+ "This plot can only have one regressor."
|
- | 901 |
+ 381 |
|
- }
+ }
|
- | 902 |
+ 382 |
|
- )
- |
-
-
- | 903 |
- ! |
-
- outlier_points <- do.call(rbind, all_categories)
+ }
|
- | 904 |
+ 383 |
|
- },
+ }
|
- | 905 |
+ 384 |
! |
- env = list(categorical_var = categorical_var, outlier_var = outlier_var)
+ rule_rvr2 <- function(other) {
|
-
- | 906 |
- |
+
+ | 385 |
+ ! |
- )
+ function(value) {
|
-
- | 907 |
- |
+
+ | 386 |
+ ! |
- )
+ if (isTRUE(input$plot_type == "Response vs Regressor")) {
|
- | 908 |
+ 387 |
! |
- plot_call <- substitute(
+ otherval <- selector_list()[[other]]()$select
|
- | 909 |
+ 388 |
! |
- expr = plot_call + facet_grid(~ reorder(categorical_var_name, order)),
+ if (isTRUE(value == otherval)) {
|
- | 910 |
+ 389 |
! |
- env = list(plot_call = plot_call, categorical_var_name = as.name(categorical_var))
+ "Response and Regressor must be different."
|
- | 911 |
+ 390 |
|
- )
+ }
|
- | 912 |
+ 391 |
+ |
+
+ }
+ |
+
+
+ | 392 |
|
}
|
- | 913 |
+ 393 |
|
-
+ }
|
-
- | 914 |
- ! |
+
+ | 394 |
+ |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(
+
|
- | 915 |
+ 395 |
! |
- labs = list(color = "Is outlier?"),
+ selector_list <- teal.transform::data_extract_multiple_srv(
|
- | 916 |
+ 396 |
! |
- theme = list(legend.position = "top")
+ data_extract = list(response = response, regressor = regressor),
|
-
- | 917 |
- |
+
+ | 397 |
+ ! |
- )
+ datasets = data,
|
-
- | 918 |
- |
+
+ | 398 |
+ ! |
-
+ select_validation_rule = list(
|
- | 919 |
+ 399 |
! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
+ regressor = shinyvalidate::compose_rules(
|
- | 920 |
+ 400 |
! |
- user_plot = ggplot2_args[["Cumulative Distribution Plot"]],
+ shinyvalidate::sv_required("At least one regressor should be selected."),
|
- | 921 |
+ 401 |
! |
- user_default = ggplot2_args$default,
+ rule_rvr1,
|
- | 922 |
+ 402 |
! |
- module_plot = dev_ggplot2_args
+ rule_rvr2("response")
|
- | 923 |
+ 403 |
|
- )
+ ),
|
-
- | 924 |
- |
+
+ | 404 |
+ ! |
-
+ response = shinyvalidate::compose_rules(
|
- | 925 |
+ 405 |
! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
+ shinyvalidate::sv_required("At least one response should be selected."),
|
- | 926 |
+ 406 |
! |
- all_ggplot2_args,
+ rule_rvr2("regressor")
|
-
- | 927 |
- ! |
+
+ | 407 |
+ |
- ggtheme = input$ggtheme
+ )
|
- | 928 |
+ 408 |
|
)
|
- | 929 |
+ 409 |
|
-
+ )
|
-
- | 930 |
- ! |
+
+ | 410 |
+ |
- teal.code::eval_code(
+
|
- | 931 |
+ 411 |
! |
- qenv,
+ iv_r <- reactive({
|
- | 932 |
+ 412 |
! |
- substitute(
+ iv <- shinyvalidate::InputValidator$new()
|
- | 933 |
+ 413 |
! |
- expr = g <- plot_call +
+ teal.transform::compose_and_enable_validators(iv, selector_list)
|
-
- | 934 |
- ! |
+
+ | 414 |
+ |
- geom_point(data = outlier_points, aes(x = outlier_var_name, y = y, color = is_outlier_selected)) +
+ })
|
-
- | 935 |
- ! |
+
+ | 415 |
+ |
- scale_color_manual(values = c("TRUE" = "red", "FALSE" = "black")) +
+
|
- | 936 |
+ 416 |
! |
- labs + ggthemes + themes,
+ iv_out <- shinyvalidate::InputValidator$new()
|
- | 937 |
+ 417 |
! |
- env = list(
+ iv_out$condition(~ isTRUE(input$show_outlier))
|
- | 938 |
+ 418 |
! |
- plot_call = plot_call,
+ iv_out$add_rule("label_var", shinyvalidate::sv_required("Please provide an `Outlier label` variable"))
|
- | 939 |
+ 419 |
! |
- outlier_var_name = as.name(outlier_var),
+ iv_out$enable()
|
-
- | 940 |
- ! |
+
+ | 420 |
+ |
- labs = parsed_ggplot2_args$labs,
+
|
- | 941 |
+ 421 |
! |
- themes = parsed_ggplot2_args$theme,
+ anl_merged_input <- teal.transform::merge_expression_srv(
|
- | 942 |
+ 422 |
! |
- ggthemes = parsed_ggplot2_args$ggtheme
+ selector_list = selector_list,
|
-
- | 943 |
- |
+
+ | 423 |
+ ! |
- )
+ datasets = data
|
- | 944 |
+ 424 |
|
- )
+ )
|
- | 945 |
+ 425 |
|
- ) %>%
+
|
- | 946 |
+ 426 |
! |
- teal.code::eval_code(quote(print(g)))
+ regression_var <- reactive({
|
-
- | 947 |
- |
+
+ | 427 |
+ ! |
- })
+ teal::validate_inputs(iv_r())
|
- | 948 |
+ 428 |
|
|
- | 949 |
+ 429 |
! |
- final_q <- reactive({
+ list(
|
- | 950 |
+ 430 |
! |
- req(input$tabs)
+ response = as.vector(anl_merged_input()$columns_source$response),
|
- | 951 |
+ 431 |
! |
- tab_type <- input$tabs
+ regressor = as.vector(anl_merged_input()$columns_source$regressor)
|
-
- | 952 |
- ! |
+
+ | 432 |
+ |
- result_q <- if (tab_type == "Boxplot") {
+ )
|
-
- | 953 |
- ! |
+
+ | 433 |
+ |
- boxplot_q()
+ })
|
-
- | 954 |
- ! |
+
+ | 434 |
+ |
- } else if (tab_type == "Density Plot") {
+
|
- | 955 |
+ 435 |
! |
- density_plot_q()
+ anl_merged_q <- reactive({
|
- | 956 |
+ 436 |
! |
- } else if (tab_type == "Cumulative Distribution Plot") {
+ req(anl_merged_input())
|
- | 957 |
+ 437 |
! |
- cumulative_plot_q()
+ data() %>%
|
-
- | 958 |
- |
+
+ | 438 |
+ ! |
- }
+ teal.code::eval_code(as.expression(anl_merged_input()$expr))
|
- | 959 |
+ 439 |
|
- # used to display table when running show-r-code code
+ })
|
- | 960 |
+ 440 |
|
- # added after the plots so that a change in selected columns doesn't affect
+
|
- | 961 |
+ 441 |
|
- # brush selection.
+ # sets qenv object and populates it with data merge call and fit expression
|
- | 962 |
+ 442 |
! |
- teal.code::eval_code(
+ fit_r <- reactive({
|
- | 963 |
+ 443 |
! |
- result_q,
+ ANL <- anl_merged_q()[["ANL"]]
|
- | 964 |
+ 444 |
! |
- substitute(
+ teal::validate_has_data(ANL, 10)
|
-
- | 965 |
- ! |
+
+ | 445 |
+ |
- expr = {
+
|
- | 966 |
+ 446 |
! |
- columns_index <- union(
+ validate(need(is.numeric(ANL[regression_var()$response][[1]]), "Response variable should be numeric."))
+ |
+
+
+ | 447 |
+ |
+
+
|
- | 967 |
+ 448 |
! |
- setdiff(names(ANL_OUTLIER), c("is_outlier_selected", "order")),
+ teal::validate_has_data(
|
- | 968 |
+ 449 |
! |
- table_columns
+ ANL[, c(regression_var()$response, regression_var()$regressor)], 10,
+ |
+
+
+ | 450 |
+ ! |
+
+ complete = TRUE, allow_inf = FALSE
|
- | 969 |
+ 451 |
|
- )
+ )
+ |
+
+
+ | 452 |
+ |
+
+
|
- | 970 |
+ 453 |
! |
- ANL_OUTLIER_EXTENDED[ANL_OUTLIER_EXTENDED$is_outlier_selected, columns_index]
+ form <- stats::as.formula(
|
-
- | 971 |
- |
+
+ | 454 |
+ ! |
- },
+ paste(
|
- | 972 |
+ 455 |
! |
- env = list(
+ regression_var()$response,
|
- | 973 |
+ 456 |
! |
- table_columns = input$table_ui_columns
+ paste(
|
-
- | 974 |
- |
+
+ | 457 |
+ ! |
- )
+ regression_var()$regressor,
|
-
- | 975 |
- |
+
+ | 458 |
+ ! |
- )
+ collapse = " + "
|
- | 976 |
+ 459 |
|
- )
+ ),
+ |
+
+
+ | 460 |
+ ! |
+
+ sep = " ~ "
|
- | 977 |
+ 461 |
|
- })
+ )
|
- | 978 |
+ 462 |
|
-
+ )
|
- | 979 |
+ 463 |
|
- # slider text
+
|
- | 980 |
+ 464 |
! |
- output$ui_outlier_help <- renderUI({
+ if (input$show_outlier) {
|
- | 981 |
+ 465 |
! |
- req(input$method)
+ opts <- teal.transform::variable_choices(ANL)
|
- | 982 |
+ 466 |
! |
- if (input$method == "IQR") {
+ selected <- if (!is.null(isolate(input$label_var)) && isolate(input$label_var) %in% as.character(opts)) {
|
- | 983 |
+ 467 |
! |
- req(input$iqr_slider)
+ isolate(input$label_var)
|
-
- | 984 |
- ! |
+
+ | 468 |
+ |
- tags$small(
+ } else {
|
- | 985 |
+ 469 |
! |
- withMathJax(
+ if (length(opts[as.character(opts) == default_outlier_label]) == 0) {
|
- | 986 |
+ 470 |
! |
- helpText(
+ opts[[1]]
|
-
- | 987 |
- ! |
+
+ | 471 |
+ |
- "Outlier data points (\\(x \\lt Q1 - ", input$iqr_slider, "\\times IQR\\) or \\(
+ } else {
|
- | 988 |
+ 472 |
! |
- Q3 + ", input$iqr_slider, "\\times IQR \\lt x\\))
+ opts[as.character(opts) == default_outlier_label]
|
-
- | 989 |
- ! |
+
+ | 473 |
+ |
- are displayed in red on the plot and can be visualized in the table below."
+ }
|
- | 990 |
+ 474 |
|
- ),
+ }
|
- | 991 |
+ 475 |
! |
- if (input$split_outliers) {
+ teal.widgets::updateOptionalSelectInput(
|
- | 992 |
+ 476 |
! |
- withMathJax(helpText("Note: Quantiles are calculated per group."))
+ session = session,
|
-
- | 993 |
- |
+
+ | 477 |
+ ! |
- }
+ inputId = "label_var",
|
-
- | 994 |
- |
+
+ | 478 |
+ ! |
- )
+ choices = opts,
+ |
+
+
+ | 479 |
+ ! |
+
+ selected = restoreInput(ns("label_var"), selected)
|
- | 995 |
+ 480 |
|
)
|
-
- | 996 |
- ! |
+
+ | 481 |
+ |
- } else if (input$method == "Z-score") {
+
|
- | 997 |
+ 482 |
! |
- req(input$zscore_slider)
+ data <- fortify(stats::lm(form, data = ANL))
|
- | 998 |
+ 483 |
! |
- tags$small(
+ cooksd <- data$.cooksd[!is.nan(data$.cooksd)]
|
- | 999 |
+ 484 |
! |
- withMathJax(
+ max_outlier <- max(ceiling(max(cooksd) / mean(cooksd)), 2)
|
- | 1000 |
+ 485 |
! |
- helpText(
+ cur_outlier <- isolate(input$outlier)
|
- | 1001 |
+ 486 |
! |
- "Outlier data points (\\(Zscore(x) < -", input$zscore_slider,
+ updateSliderInput(
|
- | 1002 |
+ 487 |
! |
- "\\) or \\(", input$zscore_slider, "< Zscore(x) \\))
+ session = session,
|
- | 1003 |
+ 488 |
! |
- are displayed in red on the plot and can be visualized in the table below."
+ inputId = "outlier",
|
-
- | 1004 |
- |
+
+ | 489 |
+ ! |
- ),
+ min = 1,
|
- | 1005 |
+ 490 |
! |
- if (input$split_outliers) {
+ max = max_outlier,
|
- | 1006 |
+ 491 |
! |
- withMathJax(helpText(" Note: Z-scores are calculated per group."))
+ value = restoreInput(ns("outlier"), if (cur_outlier < max_outlier) cur_outlier else max_outlier * .9)
|
- | 1007 |
+ 492 |
|
- }
+ )
|
- | 1008 |
+ 493 |
|
- )
+ }
|
- | 1009 |
+ 494 |
|
- )
+
|
- | 1010 |
+ 495 |
! |
- } else if (input$method == "Percentile") {
+ anl_merged_q() %>%
|
- | 1011 |
+ 496 |
! |
- req(input$percentile_slider)
+ teal.code::eval_code(substitute(fit <- stats::lm(form, data = ANL), env = list(form = form))) %>%
|
- | 1012 |
+ 497 |
! |
- tags$small(
+ teal.code::eval_code(quote({
|
- | 1013 |
+ 498 |
! |
- withMathJax(
+ for (regressor in names(fit$contrasts)) {
|
- | 1014 |
+ 499 |
! |
- helpText(
+ alts <- paste0(levels(ANL[[regressor]]), collapse = "|")
|
- | 1015 |
+ 500 |
! |
- "Outlier/extreme data points (\\( Percentile(x) <", input$percentile_slider,
+ names(fit$coefficients) <- gsub(
|
- | 1016 |
+ 501 |
! |
- "\\) or \\(", 1 - input$percentile_slider, " < Percentile(x) \\))
+ paste0("^(", regressor, ")(", alts, ")$"), paste0("\\1", ": ", "\\2"), names(fit$coefficients)
|
-
- | 1017 |
- ! |
+
+ | 502 |
+ |
- are displayed in red on the plot and can be visualized in the table below."
+ )
|
- | 1018 |
+ 503 |
|
- ),
+ }
|
-
- | 1019 |
- ! |
+
+ | 504 |
+ |
- if (input$split_outliers) {
+ })) %>%
|
- | 1020 |
+ 505 |
! |
- withMathJax(helpText("Note: Percentiles are calculated per group."))
+ teal.code::eval_code(quote(summary(fit)))
|
- | 1021 |
+ 506 |
|
- }
+ })
|
- | 1022 |
+ 507 |
|
- )
+
|
-
- | 1023 |
- |
+
+ | 508 |
+ ! |
- )
+ label_col <- reactive({
|
-
- | 1024 |
- |
+
+ | 509 |
+ ! |
- }
+ teal::validate_inputs(iv_out)
|
- | 1025 |
+ 510 |
|
- })
+
|
-
- | 1026 |
- |
+
+ | 511 |
+ ! |
-
+ substitute(
|
- | 1027 |
+ 512 |
! |
- boxplot_r <- reactive({
+ expr = dplyr::if_else(
|
- | 1028 |
+ 513 |
! |
- teal::validate_inputs(iv_r())
+ data$.cooksd > outliers * mean(data$.cooksd, na.rm = TRUE),
|
- | 1029 |
+ 514 |
! |
- boxplot_q()[["g"]]
+ as.character(stats::na.omit(ANL)[[label_var]]),
|
- | 1030 |
+ 515 |
|
- })
+ ""
|
-
- | 1031 |
- ! |
+
+ | 516 |
+ |
- density_plot_r <- reactive({
+ ) %>%
|
- | 1032 |
+ 517 |
! |
- teal::validate_inputs(iv_r())
+ dplyr::if_else(is.na(.), "cooksd == NaN", .),
|
- | 1033 |
+ 518 |
! |
- density_plot_q()[["g"]]
+ env = list(outliers = input$outlier, label_var = input$label_var)
|
- | 1034 |
+ 519 |
+ |
+
+ )
+ |
+
+
+ | 520 |
|
})
|
-
- | 1035 |
- ! |
+
+ | 521 |
+ |
- cumulative_plot_r <- reactive({
+
|
- | 1036 |
+ 522 |
! |
- teal::validate_inputs(iv_r())
+ label_min_segment <- reactive({
|
- | 1037 |
+ 523 |
! |
- cumulative_plot_q()[["g"]]
+ input$label_min_segment
|
- | 1038 |
+ 524 |
|
})
|
- | 1039 |
+ 525 |
|
|
- | 1040 |
+ 526 |
! |
- box_pws <- teal.widgets::plot_with_settings_srv(
+ outlier_label <- reactive({
|
- | 1041 |
+ 527 |
! |
- id = "box_plot",
+ substitute(
|
- | 1042 |
+ 528 |
! |
- plot_r = boxplot_r,
+ expr = ggrepel::geom_text_repel(
|
- | 1043 |
+ 529 |
! |
- height = plot_height,
+ label = label_col,
|
- | 1044 |
+ 530 |
! |
- width = plot_width,
+ color = "red",
|
- | 1045 |
+ 531 |
! |
- brushing = TRUE
+ hjust = 0,
|
-
- | 1046 |
- |
+
+ | 532 |
+ ! |
- )
+ vjust = 1,
|
-
- | 1047 |
- |
+
+ | 533 |
+ ! |
-
+ max.overlaps = Inf,
|
- | 1048 |
+ 534 |
! |
- density_pws <- teal.widgets::plot_with_settings_srv(
+ min.segment.length = label_min_segment,
|
- | 1049 |
+ 535 |
! |
- id = "density_plot",
+ segment.alpha = 0.5,
|
- | 1050 |
+ 536 |
! |
- plot_r = density_plot_r,
+ seed = 123
|
-
- | 1051 |
- ! |
+
+ | 537 |
+ |
- height = plot_height,
+ ),
|
- | 1052 |
+ 538 |
! |
- width = plot_width,
+ env = list(label_col = label_col(), label_min_segment = label_min_segment())
|
-
- | 1053 |
- ! |
+
+ | 539 |
+ |
- brushing = TRUE
+ )
|
- | 1054 |
+ 540 |
|
- )
+ })
|
- | 1055 |
+ 541 |
|
|
- | 1056 |
+ 542 |
! |
- cum_density_pws <- teal.widgets::plot_with_settings_srv(
+ output_q <- reactive({
|
- | 1057 |
+ 543 |
! |
- id = "cum_density_plot",
+ alpha <- input$alpha
|
- | 1058 |
+ 544 |
! |
- plot_r = cumulative_plot_r,
+ size <- input$size
|
- | 1059 |
+ 545 |
! |
- height = plot_height,
+ ggtheme <- input$ggtheme
|
- | 1060 |
+ 546 |
! |
- width = plot_width,
+ input_type <- input$plot_type
|
- | 1061 |
+ 547 |
! |
- brushing = TRUE
- |
-
-
- | 1062 |
- |
-
- )
+ show_outlier <- input$show_outlier
|
- | 1063 |
+ 548 |
|
|
- | 1064 |
+ 549 |
! |
- choices <- reactive(teal.transform::variable_choices(data()[[dataname_first]]))
+ teal::validate_inputs(iv_r())
|
- | 1065 |
+ 550 |
|
|
- | 1066 |
- ! |
-
- observeEvent(common_code_q(), {
- |
-
-
- | 1067 |
- ! |
-
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]
- |
-
-
- | 1068 |
+ 551 |
! |
- teal.widgets::updateOptionalSelectInput(
+ plot_type_0 <- function() {
|
- | 1069 |
+ 552 |
! |
- session,
+ fit <- fit_r()[["fit"]]
|
- | 1070 |
+ 553 |
! |
- inputId = "table_ui_columns",
+ ANL <- anl_merged_q()[["ANL"]]
|
-
- | 1071 |
- ! |
+
+ | 554 |
+ |
- choices = dplyr::setdiff(choices(), names(ANL_OUTLIER)),
+
|
- | 1072 |
+ 555 |
! |
- selected = restoreInput(ns("table_ui_columns"), isolate(input$table_ui_columns))
+ stopifnot(ncol(fit$model) == 2)
|
- | 1073 |
+ 556 |
|
- )
+
|
-
- | 1074 |
- |
+
+ | 557 |
+ ! |
- })
+ if (!is.factor(ANL[[regression_var()$regressor]])) {
|
-
- | 1075 |
- |
+
+ | 558 |
+ ! |
-
+ shinyjs::show("size")
|
- | 1076 |
+ 559 |
! |
- output$table_ui <- DT::renderDataTable(
+ shinyjs::show("alpha")
|
- | 1077 |
+ 560 |
! |
- expr = {
+ plot <- substitute(
|
- | 1078 |
+ 561 |
! |
- tab <- input$tabs
+ env = list(
|
- | 1079 |
+ 562 |
! |
- req(tab) # tab is NULL upon app launch, hence will crash without this statement
+ regressor = regression_var()$regressor,
|
- | 1080 |
+ 563 |
! |
- req(iv_r()$is_valid()) # Same validation as output$table_ui_wrap
+ response = regression_var()$response,
|
- | 1081 |
+ 564 |
! |
- outlier_var <- as.vector(merged$anl_input_r()$columns_source$outlier_var)
+ size = size,
|
- | 1082 |
+ 565 |
! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)
+ alpha = alpha
|
- | 1083 |
+ 566 |
|
-
+ ),
|
- | 1084 |
+ 567 |
! |
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]
+ expr = ggplot(
|
- | 1085 |
+ 568 |
! |
- ANL_OUTLIER_EXTENDED <- common_code_q()[["ANL_OUTLIER_EXTENDED"]]
+ fit$model[, 2:1],
|
- | 1086 |
+ 569 |
! |
- ANL <- common_code_q()[["ANL"]]
+ aes_string(regressor, response)
|
- | 1087 |
+ 570 |
|
-
+ ) +
|
- | 1088 |
+ 571 |
! |
- plot_brush <- if (tab == "Boxplot") {
+ geom_point(size = size, alpha = alpha) +
|
- | 1089 |
+ 572 |
! |
- boxplot_r()
+ stat_smooth(
|
- | 1090 |
+ 573 |
! |
- box_pws$brush()
+ method = "lm",
|
- | 1091 |
+ 574 |
! |
- } else if (tab == "Density Plot") {
+ formula = y ~ x,
|
- | 1092 |
+ 575 |
! |
- density_plot_r()
+ se = FALSE
+ |
+
+
+ | 576 |
+ |
+
+ )
+ |
+
+
+ | 577 |
+ |
+
+ )
|
- | 1093 |
+ 578 |
! |
- density_pws$brush()
+ if (show_outlier) {
|
- | 1094 |
+ 579 |
! |
- } else if (tab == "Cumulative Distribution Plot") {
+ plot <- substitute(
|
- | 1095 |
+ 580 |
! |
- cumulative_plot_r()
+ expr = plot + outlier_label,
|
- | 1096 |
+ 581 |
! |
- cum_density_pws$brush()
+ env = list(plot = plot, outlier_label = outlier_label())
|
- | 1097 |
+ 582 |
|
- }
+ )
|
- | 1098 |
+ 583 |
|
-
+ }
|
- | 1099 |
+ 584 |
|
- # removing unused column ASAP
+ } else {
|
- | 1100 |
+ 585 |
! |
- ANL_OUTLIER$order <- ANL$order <- NULL
+ shinyjs::hide("size")
|
-
- | 1101 |
- |
+
+ | 586 |
+ ! |
-
+ shinyjs::hide("alpha")
|
- | 1102 |
+ 587 |
! |
- display_table <- if (!is.null(plot_brush)) {
+ plot <- substitute(
|
- | 1103 |
+ 588 |
! |
- if (length(categorical_var) > 0) {
+ expr = ggplot(fit$model[, 2:1], aes_string(regressor, response)) +
+ |
+
+
+ | 589 |
+ ! |
+
+ geom_boxplot(),
+ |
+
+
+ | 590 |
+ ! |
+
+ env = list(regressor = regression_var()$regressor, response = regression_var()$response)
|
- | 1104 |
+ 591 |
|
- # due to reordering, the x-axis label may be changed to something like "reorder(categorical_var, order)"
+ )
|
- | 1105 |
+ 592 |
! |
- if (tab == "Boxplot") {
+ if (show_outlier) {
|
- | 1106 |
+ 593 |
! |
- plot_brush$mapping$x <- categorical_var
+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))
|
- | 1107 |
+ 594 |
|
- } else {
+ }
|
- | 1108 |
+ 595 |
|
- # the other plots use facetting
+ }
|
- | 1109 |
+ 596 |
|
- # so it is panelvar1 that gets relabelled to "reorder(categorical_var, order)"
+
|
- | 1110 |
+ 597 |
! |
- plot_brush$mapping$panelvar1 <- categorical_var
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
|
-
- | 1111 |
- |
+
+ | 598 |
+ ! |
- }
+ teal.widgets::resolve_ggplot2_args(
|
-
- | 1112 |
- |
+
+ | 599 |
+ ! |
- } else {
+ user_plot = ggplot2_args[["Response vs Regressor"]],
|
- | 1113 |
+ 600 |
! |
- if (tab == "Boxplot") {
+ user_default = ggplot2_args$default,
|
-
- | 1114 |
- |
+
+ | 601 |
+ ! |
- # in boxplot with no categorical variable, there is no column in ANL that would correspond to x-axis
+ module_plot = teal.widgets::ggplot2_args(
|
-
- | 1115 |
- |
+
+ | 602 |
+ ! |
- # so a column needs to be inserted with the value "Entire dataset" because that's the label used in plot
+ labs = list(
|
- | 1116 |
+ 603 |
! |
- ANL[[plot_brush$mapping$x]] <- "Entire dataset"
+ title = "Response vs Regressor",
|
-
- | 1117 |
- |
+
+ | 604 |
+ ! |
- }
+ x = varname_w_label(regression_var()$regressor, ANL),
|
-
- | 1118 |
- |
+
+ | 605 |
+ ! |
- }
+ y = varname_w_label(regression_var()$response, ANL)
|
- | 1119 |
+ 606 |
|
-
+ ),
+ |
+
+
+ | 607 |
+ ! |
+
+ theme = list()
|
- | 1120 |
+ 608 |
|
- # in density and cumulative plots, ANL does not have a column corresponding to y-axis.
+ )
|
- | 1121 |
+ 609 |
|
- # so they need to be computed and attached to ANL
+ ),
|
- | 1122 |
+ 610 |
! |
- if (tab == "Density Plot") {
+ ggtheme = ggtheme
|
-
- | 1123 |
- ! |
+
+ | 611 |
+ |
- plot_brush$mapping$y <- "density"
+ )
+ |
+
+
+ | 612 |
+ |
+
+
|
- | 1124 |
+ 613 |
! |
- ANL$density <- plot_brush$ymin
+ teal.code::eval_code(
|
-
- | 1125 |
- |
+
+ | 614 |
+ ! |
- # either ymin or ymax will work
+ fit_r(),
|
- | 1126 |
+ 615 |
! |
- } else if (tab == "Cumulative Distribution Plot") {
+ substitute(
|
- | 1127 |
+ 616 |
! |
- plot_brush$mapping$y <- "cdf"
+ expr = {
|
- | 1128 |
+ 617 |
! |
- if (length(categorical_var) > 0) {
+ class(fit$residuals) <- NULL
|
- | 1129 |
+ 618 |
! |
- ANL <- ANL %>%
+ data <- fortify(fit)
|
- | 1130 |
+ 619 |
! |
- dplyr::group_by(!!as.name(plot_brush$mapping$panelvar1)) %>%
+ g <- plot
|
- | 1131 |
+ 620 |
! |
- dplyr::mutate(cdf = stats::ecdf(!!as.name(outlier_var))(!!as.name(outlier_var)))
+ print(g)
|
- | 1132 |
+ 621 |
|
- } else {
+ },
|
- | 1133 |
+ 622 |
! |
- ANL$cdf <- stats::ecdf(ANL[[outlier_var]])(ANL[[outlier_var]])
+ env = list(
|
-
- | 1134 |
- |
+
+ | 623 |
+ ! |
- }
+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
- | 1135 |
+ 624 |
|
- }
+ )
|
- | 1136 |
+ 625 |
|
-
- |
-
-
- | 1137 |
- ! |
-
- brushed_rows <- brushedPoints(ANL, plot_brush)
+ )
|
-
- | 1138 |
- ! |
+
+ | 626 |
+ |
- if (nrow(brushed_rows) > 0) {
+ )
|
- | 1139 |
+ 627 |
|
- # now we need to remove extra column from ANL so that it will have the same columns as ANL_OUTLIER
+ }
|
- | 1140 |
+ 628 |
|
- # so that dplyr::intersect will work
+
|
- | 1141 |
+ 629 |
! |
- if (tab == "Density Plot") {
+ plot_base <- function() {
|
- | 1142 |
+ 630 |
! |
- brushed_rows$density <- NULL
+ base_fit <- fit_r()
|
- | 1143 |
+ 631 |
! |
- } else if (tab == "Cumulative Distribution Plot") {
+ teal.code::eval_code(
|
- | 1144 |
+ 632 |
! |
- brushed_rows$cdf <- NULL
+ base_fit,
|
- | 1145 |
+ 633 |
! |
- } else if (tab == "Boxplot" && length(categorical_var) == 0) {
+ quote({
|
- | 1146 |
+ 634 |
! |
- brushed_rows[[plot_brush$mapping$x]] <- NULL
+ class(fit$residuals) <- NULL
|
- | 1147 |
+ 635 |
|
- }
+
+ |
+
+
+ | 636 |
+ ! |
+
+ data <- ggplot2::fortify(fit)
|
- | 1148 |
+ 637 |
|
- # is_outlier_selected is part of ANL_OUTLIER so needed here
+
|
- | 1149 |
+ 638 |
! |
- brushed_rows$is_outlier_selected <- TRUE
+ smooth <- function(x, y) {
|
- | 1150 |
+ 639 |
! |
- dplyr::intersect(ANL_OUTLIER, brushed_rows)
+ as.data.frame(stats::lowess(x, y, f = 2 / 3, iter = 3))
|
- | 1151 |
+ 640 |
|
- } else {
+ }
|
-
- | 1152 |
- ! |
+
+ | 641 |
+ |
- ANL_OUTLIER[0, ]
+
|
-
- | 1153 |
- |
+
+ | 642 |
+ ! |
- }
+ smoothy_aes <- ggplot2::aes_string(x = "x", y = "y")
|
- | 1154 |
+ 643 |
|
- } else {
+
|
- | 1155 |
+ 644 |
! |
- ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ]
+ reg_form <- deparse(fit$call[[2]])
|
- | 1156 |
+ 645 |
|
- }
+ })
|
- | 1157 |
+ 646 |
|
-
- |
-
-
- | 1158 |
- ! |
-
- display_table$is_outlier_selected <- NULL
+ )
|
- | 1159 |
+ 647 |
|
-
+ }
|
- | 1160 |
+ 648 |
|
- # Extend the brushed ANL_OUTLIER with additional columns
+
|
- | 1161 |
+ 649 |
! |
- dplyr::left_join(
+ plot_type_1 <- function(plot_base) {
|
- | 1162 |
+ 650 |
! |
- display_table,
+ shinyjs::show("size")
|
- | 1163 |
+ 651 |
! |
- dplyr::select(ANL_OUTLIER_EXTENDED, -"is_outlier_selected"),
+ shinyjs::show("alpha")
|
- | 1164 |
+ 652 |
! |
- by = names(display_table)
- |
-
-
- | 1165 |
- |
-
- ) %>%
+ plot <- substitute(
|
- | 1166 |
+ 653 |
! |
- dplyr::select(union(names(display_table), input$table_ui_columns))
+ expr = ggplot(data = data, aes(.fitted, .resid)) +
|
-
- | 1167 |
- |
+
+ | 654 |
+ ! |
- },
+ geom_point(size = size, alpha = alpha) +
|
- | 1168 |
+ 655 |
! |
- options = list(
+ geom_hline(yintercept = 0, linetype = "dashed", size = 1) +
|
- | 1169 |
+ 656 |
! |
- searching = FALSE, language = list(
+ geom_line(data = smoothy, mapping = smoothy_aes),
|
- | 1170 |
+ 657 |
! |
- zeroRecords = "The brushed area does not contain outlier observations for the currently defined threshold"
+ env = list(size = size, alpha = alpha)
|
- | 1171 |
+ 658 |
|
- ),
+ )
|
- | 1172 |
+ 659 |
! |
- pageLength = input$table_ui_rows
+ if (show_outlier) {
|
-
- | 1173 |
- |
+
+ | 660 |
+ ! |
- )
+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))
|
- | 1174 |
+ 661 |
|
- )
+ }
|
- | 1175 |
+ 662 |
|
|
- | 1176 |
+ 663 |
! |
- output$total_outliers <- renderUI({
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
|
- | 1177 |
+ 664 |
! |
- req(iv_r()$is_valid())
+ teal.widgets::resolve_ggplot2_args(
|
- | 1178 |
+ 665 |
! |
- ANL <- merged$anl_q_r()[["ANL"]]
+ user_plot = ggplot2_args[["Residuals vs Fitted"]],
|
- | 1179 |
+ 666 |
! |
- ANL_OUTLIER <- common_code_q()[["ANL_OUTLIER"]]
+ user_default = ggplot2_args$default,
|
- | 1180 |
+ 667 |
! |
- teal::validate_has_data(ANL, 1)
+ module_plot = teal.widgets::ggplot2_args(
|
- | 1181 |
+ 668 |
! |
- ANL_OUTLIER_SELECTED <- ANL_OUTLIER[ANL_OUTLIER$is_outlier_selected, ]
+ labs = list(
|
- | 1182 |
+ 669 |
! |
- tags$h5(
+ x = quote(paste0("Fitted values\nlm(", reg_form, ")")),
|
- | 1183 |
+ 670 |
! |
- sprintf(
+ y = "Residuals",
|
- | 1184 |
+ 671 |
! |
- "%s %d / %d [%.02f%%]",
+ title = "Residuals vs Fitted"
|
-
- | 1185 |
- ! |
+
+ | 672 |
+ |
- "Total number of outlier(s):",
+ )
|
-
- | 1186 |
- ! |
+
+ | 673 |
+ |
- nrow(ANL_OUTLIER_SELECTED),
+ )
|
-
- | 1187 |
- ! |
+
+ | 674 |
+ |
- nrow(ANL),
+ ),
|
- | 1188 |
+ 675 |
! |
- 100 * nrow(ANL_OUTLIER_SELECTED) / nrow(ANL)
+ ggtheme = ggtheme
|
- | 1189 |
+ 676 |
|
)
|
- | 1190 |
- |
-
- )
- |
-
-
- | 1191 |
- |
-
- })
- |
-
-
- | 1192 |
+ 677 |
|
|
- | 1193 |
+ 678 |
! |
- output$total_missing <- renderUI({
+ teal.code::eval_code(
|
- | 1194 |
+ 679 |
! |
- if (n_outlier_missing() > 0) {
+ plot_base,
|
- | 1195 |
+ 680 |
! |
- ANL <- merged$anl_q_r()[["ANL"]]
+ substitute(
|
- | 1196 |
+ 681 |
! |
- helpText(
+ expr = {
|
- | 1197 |
+ 682 |
! |
- sprintf(
+ smoothy <- smooth(data$.fitted, data$.resid)
|
- | 1198 |
+ 683 |
! |
- "%s %d / %d [%.02f%%]",
+ g <- plot
|
- | 1199 |
+ 684 |
! |
- "Total number of row(s) with missing values:",
+ print(g)
|
-
- | 1200 |
- ! |
+
+ | 685 |
+ |
- n_outlier_missing(),
+ },
|
- | 1201 |
+ 686 |
! |
- nrow(ANL),
+ env = list(
|
- | 1202 |
+ 687 |
! |
- 100 * (n_outlier_missing()) / nrow(ANL)
+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
- | 1203 |
+ 688 |
|
- )
+ )
|
- | 1204 |
+ 689 |
|
- )
+ )
|
- | 1205 |
+ 690 |
|
- }
+ )
|
- | 1206 |
+ 691 |
|
- })
+ }
|
- | 1207 |
+ 692 |
|
|
- | 1208 |
- ! |
-
- output$table_ui_wrap <- renderUI({
- |
-
-
- | 1209 |
+ 693 |
! |
- req(iv_r()$is_valid())
+ plot_type_2 <- function(plot_base) {
|
- | 1210 |
+ 694 |
! |
- tagList(
+ shinyjs::show("size")
|
- | 1211 |
+ 695 |
! |
- teal.widgets::optionalSelectInput(
+ shinyjs::show("alpha")
|
- | 1212 |
+ 696 |
! |
- inputId = ns("table_ui_columns"),
+ plot <- substitute(
|
- | 1213 |
+ 697 |
! |
- label = "Choose additional columns",
+ expr = ggplot(data = data, aes(sample = .stdresid)) +
|
- | 1214 |
+ 698 |
! |
- choices = NULL,
+ stat_qq(size = size, alpha = alpha) +
|
- | 1215 |
+ 699 |
! |
- selected = NULL,
+ geom_abline(linetype = "dashed"),
|
- | 1216 |
+ 700 |
! |
- multiple = TRUE
+ env = list(size = size, alpha = alpha)
|
- | 1217 |
+ 701 |
|
- ),
+ )
|
- | 1218 |
+ 702 |
! |
- tags$h4("Outlier Table"),
+ if (show_outlier) {
|
- | 1219 |
+ 703 |
! |
- teal.widgets::get_dt_rows(ns("table_ui"), ns("table_ui_rows"))
+ plot <- substitute(
|
-
- | 1220 |
- |
+
+ | 704 |
+ ! |
- )
+ expr = plot +
|
-
- | 1221 |
- |
+
+ | 705 |
+ ! |
- })
+ stat_qq(
|
-
- | 1222 |
- |
+
+ | 706 |
+ ! |
-
+ geom = ggrepel::GeomTextRepel,
|
- | 1223 |
+ 707 |
! |
- teal.widgets::verbatim_popup_srv(
+ label = label_col %>%
|
- | 1224 |
+ 708 |
! |
- id = "rcode",
+ data.frame(label = .) %>%
|
- | 1225 |
+ 709 |
! |
- verbatim_content = reactive(teal.code::get_code(final_q())),
+ dplyr::filter(label != "cooksd == NaN") %>%
|
- | 1226 |
+ 710 |
! |
- title = "Show R Code for Outlier"
+ unlist(),
|
-
- | 1227 |
- |
+
+ | 711 |
+ ! |
- )
+ color = "red",
|
-
- | 1228 |
- |
+
+ | 712 |
+ ! |
-
+ hjust = 0,
|
-
- | 1229 |
- |
+
+ | 713 |
+ ! |
- ### REPORTER
+ vjust = 0,
|
- | 1230 |
+ 714 |
! |
- if (with_reporter) {
+ max.overlaps = Inf,
|
- | 1231 |
+ 715 |
! |
- card_fun <- function(comment, label) {
+ min.segment.length = label_min_segment,
|
- | 1232 |
+ 716 |
! |
- tab_type <- input$tabs
+ segment.alpha = .5,
|
- | 1233 |
+ 717 |
! |
- card <- teal::report_card_template(
+ seed = 123
|
-
- | 1234 |
- ! |
+
+ | 718 |
+ |
- title = paste0("Outliers - ", tab_type),
+ ),
|
- | 1235 |
+ 719 |
! |
- label = label,
+ env = list(plot = plot, label_col = label_col(), label_min_segment = label_min_segment())
|
-
- | 1236 |
- ! |
+
+ | 720 |
+ |
- with_filter = with_filter,
+ )
|
-
- | 1237 |
- ! |
+
+ | 721 |
+ |
- filter_panel_api = filter_panel_api
+ }
|
- | 1238 |
+ 722 |
|
- )
+
|
- | 1239 |
+ 723 |
! |
- categorical_var <- as.vector(merged$anl_input_r()$columns_source$categorical_var)
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
|
- | 1240 |
+ 724 |
! |
- if (length(categorical_var) > 0) {
+ teal.widgets::resolve_ggplot2_args(
|
- | 1241 |
+ 725 |
! |
- summary_table <- common_code_q()[["summary_table"]]
+ user_plot = ggplot2_args[["Normal Q-Q"]],
|
- | 1242 |
+ 726 |
! |
- card$append_text("Summary Table", "header3")
+ user_default = ggplot2_args$default,
|
- | 1243 |
+ 727 |
! |
- card$append_table(summary_table)
+ module_plot = teal.widgets::ggplot2_args(
|
-
- | 1244 |
- |
+
+ | 728 |
+ ! |
- }
+ labs = list(
|
- | 1245 |
+ 729 |
! |
- card$append_text("Plot", "header3")
+ x = quote(paste0("Theoretical Quantiles\nlm(", reg_form, ")")),
|
- | 1246 |
+ 730 |
! |
- if (tab_type == "Boxplot") {
+ y = "Standardized residuals",
|
- | 1247 |
+ 731 |
! |
- card$append_plot(boxplot_r(), dim = box_pws$dim())
+ title = "Normal Q-Q"
|
-
- | 1248 |
- ! |
+
+ | 732 |
+ |
- } else if (tab_type == "Density Plot") {
+ )
|
-
- | 1249 |
- ! |
+
+ | 733 |
+ |
- card$append_plot(density_plot_r(), dim = density_pws$dim())
+ )
|
-
- | 1250 |
- ! |
+
+ | 734 |
+ |
- } else if (tab_type == "Cumulative Distribution Plot") {
+ ),
|
- | 1251 |
+ 735 |
! |
- card$append_plot(cumulative_plot_r(), dim = cum_density_pws$dim())
+ ggtheme = ggtheme
|
- | 1252 |
+ 736 |
|
- }
+ )
+ |
+
+
+ | 737 |
+ |
+
+
|
- | 1253 |
+ 738 |
! |
- if (!comment == "") {
+ teal.code::eval_code(
|
- | 1254 |
+ 739 |
! |
- card$append_text("Comment", "header3")
+ plot_base,
|
- | 1255 |
+ 740 |
! |
- card$append_text(comment)
+ substitute(
|
-
- | 1256 |
- |
+
+ | 741 |
+ ! |
- }
+ expr = {
|
- | 1257 |
+ 742 |
! |
- card$append_src(teal.code::get_code(final_q()))
+ g <- plot
|
- | 1258 |
+ 743 |
! |
- card
+ print(g)
|
- | 1259 |
+ 744 |
|
- }
+ },
|
- | 1260 |
+ 745 |
! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ env = list(
+ |
+
+
+ | 746 |
+ ! |
+
+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
- | 1261 |
+ 747 |
|
- }
+ )
|
- | 1262 |
+ 748 |
|
- ###
+ )
|
- | 1263 |
+ 749 |
|
- })
+ )
|
- | 1264 |
+ 750 |
|
- }
+ }
|
-
-
-
-
-
-
- | 1 |
+ 751 |
|
- #' `teal` module: File viewer
+
|
-
- | 2 |
- |
+
+ | 752 |
+ ! |
- #'
+ plot_type_3 <- function(plot_base) {
|
-
- | 3 |
- |
+
+ | 753 |
+ ! |
- #' The file viewer module provides a tool to view static files.
+ shinyjs::show("size")
|
-
- | 4 |
- |
+
+ | 754 |
+ ! |
- #' Supported formats include text formats, `PDF`, `PNG` `APNG`,
+ shinyjs::show("alpha")
|
-
- | 5 |
- |
+
+ | 755 |
+ ! |
- #' `JPEG` `SVG`, `WEBP`, `GIF` and `BMP`.
+ plot <- substitute(
|
-
- | 6 |
- |
+
+ | 756 |
+ ! |
- #'
+ expr = ggplot(data = data, aes(.fitted, sqrt(abs(.stdresid)))) +
|
-
- | 7 |
- |
+
+ | 757 |
+ ! |
- #' @inheritParams teal::module
+ geom_point(size = size, alpha = alpha) +
|
-
- | 8 |
- |
+
+ | 758 |
+ ! |
- #' @inheritParams shared_params
+ geom_line(data = smoothy, mapping = smoothy_aes),
|
-
- | 9 |
- |
+
+ | 759 |
+ ! |
- #' @param input_path (`list`) of the input paths, optional. Each element can be:
+ env = list(size = size, alpha = alpha)
|
- | 10 |
+ 760 |
|
- #'
+ )
|
-
- | 11 |
- |
+
+ | 761 |
+ ! |
- #' Paths can be specified as absolute paths or relative to the running directory of the application.
+ if (show_outlier) {
|
-
- | 12 |
- |
+
+ | 762 |
+ ! |
- #' Default to the current working directory if not supplied.
+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))
|
- | 13 |
+ 763 |
|
- #'
+ }
|
- | 14 |
+ 764 |
|
- #' @inherit shared_params return
+
|
-
- | 15 |
- |
+
+ | 765 |
+ ! |
- #'
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
|
-
- | 16 |
- |
+
+ | 766 |
+ ! |
- #' @examples
+ teal.widgets::resolve_ggplot2_args(
|
-
- | 17 |
- |
+
+ | 767 |
+ ! |
- #' data <- teal_data()
+ user_plot = ggplot2_args[["Scale-Location"]],
|
-
- | 18 |
- |
+
+ | 768 |
+ ! |
- #' data <- within(data, {
+ user_default = ggplot2_args$default,
|
-
- | 19 |
- |
+
+ | 769 |
+ ! |
- #' data <- data.frame(1)
+ module_plot = teal.widgets::ggplot2_args(
|
-
- | 20 |
- |
+
+ | 770 |
+ ! |
- #' })
+ labs = list(
|
-
- | 21 |
- |
+
+ | 771 |
+ ! |
- #' datanames(data) <- c("data")
+ x = quote(paste0("Fitted values\nlm(", reg_form, ")")),
|
-
- | 22 |
- |
+
+ | 772 |
+ ! |
- #'
+ y = quote(expression(sqrt(abs(`Standardized residuals`)))),
|
-
- | 23 |
- |
+
+ | 773 |
+ ! |
- #' app <- init(
+ title = "Scale-Location"
|
- | 24 |
+ 774 |
|
- #' data = data,
+ )
|
- | 25 |
+ 775 |
|
- #' modules = modules(
+ )
|
- | 26 |
+ 776 |
|
- #' tm_file_viewer(
+ ),
|
-
- | 27 |
- |
+
+ | 777 |
+ ! |
- #' input_path = list(
+ ggtheme = ggtheme
|
- | 28 |
+ 778 |
|
- #' folder = system.file("sample_files", package = "teal.modules.general"),
+ )
|
- | 29 |
+ 779 |
|
- #' png = system.file("sample_files/sample_file.png", package = "teal.modules.general"),
+
|
-
- | 30 |
- |
+
+ | 780 |
+ ! |
- #' txt = system.file("sample_files/sample_file.txt", package = "teal.modules.general"),
+ teal.code::eval_code(
|
-
- | 31 |
- |
+
+ | 781 |
+ ! |
- #' url = "https://fda.gov/files/drugs/published/Portable-Document-Format-Specifications.pdf"
+ plot_base,
|
-
- | 32 |
- |
+
+ | 782 |
+ ! |
- #' )
+ substitute(
|
-
- | 33 |
- |
+
+ | 783 |
+ ! |
- #' )
+ expr = {
|
-
- | 34 |
- |
+
+ | 784 |
+ ! |
- #' )
+ smoothy <- smooth(data$.fitted, sqrt(abs(data$.stdresid)))
|
-
- | 35 |
- |
+
+ | 785 |
+ ! |
- #' )
+ g <- plot
|
-
- | 36 |
- |
+
+ | 786 |
+ ! |
- #' if (interactive()) {
+ print(g)
|
- | 37 |
+ 787 |
|
- #' shinyApp(app$ui, app$server)
+ },
|
-
- | 38 |
- |
+
+ | 788 |
+ ! |
- #' }
+ env = list(
|
-
- | 39 |
- |
+
+ | 789 |
+ ! |
- #'
+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
- | 40 |
+ 790 |
|
- #' @export
+ )
|
- | 41 |
+ 791 |
|
- #'
+ )
|
- | 42 |
+ 792 |
|
- tm_file_viewer <- function(label = "File Viewer Module",
+ )
|
- | 43 |
+ 793 |
|
- input_path = list("Current Working Directory" = ".")) {
- |
-
-
- | 44 |
- ! |
-
- message("Initializing tm_file_viewer")
+ }
|
- | 45 |
+ 794 |
|
|
-
- | 46 |
- |
-
- # Normalize the parameters
- |
-
- | 47 |
+ 795 |
! |
- if (length(label) == 0 || identical(label, "")) label <- " "
+ plot_type_4 <- function(plot_base) {
|
- | 48 |
+ 796 |
! |
- if (length(input_path) == 0 || identical(input_path, "")) input_path <- list()
- |
-
-
- | 49 |
- |
-
-
- |
-
-
- | 50 |
- |
-
- # Start of assertions
+ shinyjs::hide("size")
|
- | 51 |
+ 797 |
! |
- checkmate::assert_string(label)
+ shinyjs::show("alpha")
|
-
- | 52 |
- |
+
+ | 798 |
+ ! |
-
+ plot <- substitute(
|
- | 53 |
+ 799 |
! |
- checkmate::assert(
+ expr = ggplot(data = data, aes(seq_along(.cooksd), .cooksd)) +
|
- | 54 |
+ 800 |
! |
- checkmate::check_list(input_path, types = "character", min.len = 0),
+ geom_col(alpha = alpha),
|
- | 55 |
+ 801 |
! |
- checkmate::check_character(input_path, min.len = 1)
+ env = list(alpha = alpha)
|
- | 56 |
+ 802 |
|
- )
+ )
|
- | 57 |
+ 803 |
! |
- if (length(input_path) > 0) {
+ if (show_outlier) {
|
- | 58 |
+ 804 |
! |
- valid_url <- function(url_input, timeout = 2) {
+ plot <- substitute(
|
- | 59 |
+ 805 |
! |
- con <- try(url(url_input), silent = TRUE)
+ expr = plot +
|
- | 60 |
+ 806 |
! |
- check <- suppressWarnings(try(open.connection(con, open = "rt", timeout = timeout), silent = TRUE)[1])
+ geom_hline(
|
- | 61 |
+ 807 |
! |
- try(close.connection(con), silent = TRUE)
+ yintercept = c(
|
- | 62 |
+ 808 |
! |
- is.null(check)
+ outlier * mean(data$.cooksd, na.rm = TRUE),
+ |
+
+
+ | 809 |
+ ! |
+
+ mean(data$.cooksd, na.rm = TRUE)
|
- | 63 |
+ 810 |
|
- }
+ ),
|
- | 64 |
+ 811 |
! |
- idx <- vapply(input_path, function(x) file.exists(x) || valid_url(x), logical(1))
+ color = "red",
+ |
+
+
+ | 812 |
+ ! |
+
+ linetype = "dashed"
|
- | 65 |
+ 813 |
|
-
+ ) +
|
- | 66 |
+ 814 |
! |
- if (!all(idx)) {
+ geom_text(
|
- | 67 |
+ 815 |
! |
- warning(
+ aes(
|
- | 68 |
+ 816 |
! |
- paste0(
+ x = 0,
|
- | 69 |
+ 817 |
! |
- "Non-existent file or url path. Please provide valid paths for:\n",
+ y = mean(data$.cooksd, na.rm = TRUE),
|
- | 70 |
+ 818 |
! |
- paste0(input_path[!idx], collapse = "\n")
+ label = paste("mu", "=", round(mean(data$.cooksd, na.rm = TRUE), 4)),
|
-
- | 71 |
- |
+
+ | 819 |
+ ! |
- )
+ vjust = -1,
|
-
- | 72 |
- |
+
+ | 820 |
+ ! |
- )
+ hjust = 0,
|
-
- | 73 |
- |
+
+ | 821 |
+ ! |
- }
+ color = "red",
|
- | 74 |
+ 822 |
! |
- input_path <- input_path[idx]
+ angle = 90
|
- | 75 |
+ 823 |
|
- } else {
+ ),
|
- | 76 |
+ 824 |
! |
- warning(
+ parse = TRUE,
|
- | 77 |
+ 825 |
! |
- "No file or url paths were provided."
+ show.legend = FALSE
|
- | 78 |
+ 826 |
|
- )
+ ) +
|
-
- | 79 |
- |
+
+ | 827 |
+ ! |
- }
+ outlier_label,
|
-
- | 80 |
- |
+
+ | 828 |
+ ! |
- # End of assertions
+ env = list(plot = plot, outlier = input$outlier, outlier_label = outlier_label())
|
- | 81 |
+ 829 |
|
-
+ )
|
- | 82 |
+ 830 |
|
- # Make UI args
- |
-
-
- | 83 |
- ! |
-
- args <- as.list(environment())
+ }
|
- | 84 |
+ 831 |
|
|
- | 85 |
+ 832 |
! |
- ans <- module(
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
|
- | 86 |
+ 833 |
! |
- label = label,
+ teal.widgets::resolve_ggplot2_args(
|
- | 87 |
+ 834 |
! |
- server = srv_viewer,
+ user_plot = ggplot2_args[["Cook's distance"]],
|
- | 88 |
+ 835 |
! |
- server_args = list(input_path = input_path),
+ user_default = ggplot2_args$default,
|
- | 89 |
+ 836 |
! |
- ui = ui_viewer,
+ module_plot = teal.widgets::ggplot2_args(
|
- | 90 |
+ 837 |
! |
- ui_args = args,
+ labs = list(
|
- | 91 |
+ 838 |
! |
- datanames = NULL
- |
-
-
- | 92 |
- |
-
- )
+ x = quote(paste0("Obs. number\nlm(", reg_form, ")")),
|
- | 93 |
+ 839 |
! |
- attr(ans, "teal_bookmarkable") <- FALSE
+ y = "Cook's distance",
|
- | 94 |
+ 840 |
! |
- ans
- |
-
-
- | 95 |
- |
-
- }
+ title = "Cook's distance"
|
- | 96 |
+ 841 |
|
-
+ )
|
- | 97 |
+ 842 |
|
- # UI function for the file viewer module
+ )
|
- | 98 |
+ 843 |
|
- ui_viewer <- function(id, ...) {
- |
-
-
- | 99 |
- ! |
-
- args <- list(...)
+ ),
|
- | 100 |
+ 844 |
! |
- ns <- NS(id)
+ ggtheme = ggtheme
|
- | 101 |
+ 845 |
|
-
- |
-
-
- | 102 |
- ! |
-
- tagList(
- |
-
-
- | 103 |
- ! |
-
- include_css_files("custom"),
- |
-
-
- | 104 |
- ! |
-
- teal.widgets::standard_layout(
- |
-
-
- | 105 |
- ! |
-
- output = tags$div(
- |
-
-
- | 106 |
- ! |
-
- uiOutput(ns("output"))
+ )
|
- | 107 |
+ 846 |
|
- ),
- |
-
-
- | 108 |
- ! |
-
- encoding = tags$div(
+
|
- | 109 |
+ 847 |
! |
- class = "file_viewer_encoding",
+ teal.code::eval_code(
|
- | 110 |
+ 848 |
! |
- tags$label("Encodings", class = "text-primary"),
+ plot_base,
|
- | 111 |
+ 849 |
! |
- shinyTree::shinyTree(
+ substitute(
|
- | 112 |
+ 850 |
! |
- ns("tree"),
+ expr = {
|
- | 113 |
+ 851 |
! |
- dragAndDrop = FALSE,
+ g <- plot
|
- | 114 |
+ 852 |
! |
- sort = FALSE,
+ print(g)
|
-
- | 115 |
- ! |
+
+ | 853 |
+ |
- wholerow = TRUE,
+ },
|
- | 116 |
+ 854 |
! |
- theme = "proton",
+ env = list(
|
- | 117 |
+ 855 |
! |
- multiple = FALSE
+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
- | 118 |
+ 856 |
|
- )
+ )
|
- | 119 |
+ 857 |
|
- )
+ )
|
- | 120 |
+ 858 |
|
- )
+ )
|
- | 121 |
+ 859 |
|
- )
+ }
|
- | 122 |
+ 860 |
|
- }
+
|
- | 123 |
+ 861 |
|
|
-
- | 124 |
- |
+
+ | 862 |
+ ! |
- # Server function for the file viewer module
+ plot_type_5 <- function(plot_base) {
|
-
- | 125 |
- |
+
+ | 863 |
+ ! |
- srv_viewer <- function(id, input_path) {
+ shinyjs::show("size")
|
- | 126 |
+ 864 |
! |
- moduleServer(id, function(input, output, session) {
+ shinyjs::show("alpha")
|
- | 127 |
+ 865 |
! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
+ plot <- substitute(
|
-
- | 128 |
- |
+
+ | 866 |
+ ! |
-
+ expr = ggplot(data = data, aes(.hat, .stdresid)) +
|
- | 129 |
+ 867 |
! |
- temp_dir <- tempfile()
+ geom_vline(
|
- | 130 |
+ 868 |
! |
- if (!dir.exists(temp_dir)) {
+ size = 1,
|
- | 131 |
+ 869 |
! |
- dir.create(temp_dir, recursive = TRUE)
+ colour = "black",
|
-
- | 132 |
- |
+
+ | 870 |
+ ! |
- }
+ linetype = "dashed",
|
- | 133 |
+ 871 |
! |
- addResourcePath(basename(temp_dir), temp_dir)
+ xintercept = 0
|
- | 134 |
+ 872 |
|
-
+ ) +
|
- | 135 |
+ 873 |
! |
- test_path_text <- function(selected_path, type) {
+ geom_hline(
|
- | 136 |
+ 874 |
! |
- out <- tryCatch(
+ size = 1,
|
- | 137 |
+ 875 |
! |
- expr = {
+ colour = "black",
|
- | 138 |
+ 876 |
! |
- if (type != "url") {
+ linetype = "dashed",
|
- | 139 |
+ 877 |
! |
- selected_path <- normalizePath(selected_path, winslash = "/")
+ yintercept = 0
|
- | 140 |
+ 878 |
|
- }
+ ) +
|
- | 141 |
+ 879 |
! |
- readLines(con = selected_path)
- |
-
-
- | 142 |
- |
-
- },
+ geom_point(size = size, alpha = alpha) +
|
- | 143 |
+ 880 |
! |
- error = function(cond) FALSE,
+ geom_line(data = smoothy, mapping = smoothy_aes),
|
- | 144 |
+ 881 |
! |
- warning = function(cond) {
+ env = list(size = size, alpha = alpha)
|
-
- | 145 |
- ! |
+
+ | 882 |
+ |
- `if`(grepl("^incomplete final line found on", cond[[1]]), suppressWarnings(eval(cond[[2]])), FALSE)
+ )
|
-
- | 146 |
- |
+
+ | 883 |
+ ! |
- }
+ if (show_outlier) {
|
-
- | 147 |
- |
+
+ | 884 |
+ ! |
- )
+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))
|
- | 148 |
+ 885 |
|
- }
+ }
|
- | 149 |
+ 886 |
|
|
- | 150 |
- ! |
-
- handle_connection_type <- function(selected_path) {
- |
-
-
- | 151 |
+ 887 |
! |
- file_extension <- tools::file_ext(selected_path)
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
|
- | 152 |
+ 888 |
! |
- file_class <- suppressWarnings(file(selected_path))
+ teal.widgets::resolve_ggplot2_args(
|
- | 153 |
+ 889 |
! |
- close(file_class)
- |
-
-
- | 154 |
- |
-
-
+ user_plot = ggplot2_args[["Residuals vs Leverage"]],
|
- | 155 |
+ 890 |
! |
- output_text <- test_path_text(selected_path, type = class(file_class)[1])
- |
-
-
- | 156 |
- |
-
-
+ user_default = ggplot2_args$default,
|
- | 157 |
+ 891 |
! |
- if (class(file_class)[1] == "url") {
+ module_plot = teal.widgets::ggplot2_args(
|
- | 158 |
+ 892 |
! |
- list(selected_path = selected_path, output_text = output_text)
- |
-
-
- | 159 |
- |
-
- } else {
+ labs = list(
|
- | 160 |
+ 893 |
! |
- file.copy(normalizePath(selected_path, winslash = "/"), temp_dir)
+ x = quote(paste0("Standardized residuals\nlm(", reg_form, ")")),
|
- | 161 |
+ 894 |
! |
- selected_path <- file.path(basename(temp_dir), basename(selected_path))
+ y = "Leverage",
|
- | 162 |
+ 895 |
! |
- list(selected_path = selected_path, output_text = output_text)
+ title = "Residuals vs Leverage"
|
- | 163 |
+ 896 |
|
- }
+ )
|
- | 164 |
+ 897 |
|
- }
+ )
|
- | 165 |
+ 898 |
|
-
+ ),
|
- | 166 |
+ 899 |
! |
- display_file <- function(selected_path) {
+ ggtheme = ggtheme
|
-
- | 167 |
- ! |
+
+ | 900 |
+ |
- con_type <- handle_connection_type(selected_path)
+ )
+ |
+
+
+ | 901 |
+ |
+
+
|
- | 168 |
+ 902 |
! |
- file_extension <- tools::file_ext(selected_path)
+ teal.code::eval_code(
|
- | 169 |
+ 903 |
! |
- if (file_extension %in% c("png", "apng", "jpg", "jpeg", "svg", "gif", "webp", "bmp")) {
+ plot_base,
|
- | 170 |
+ 904 |
! |
- tags$img(src = con_type$selected_path, alt = "file does not exist")
+ substitute(
|
- | 171 |
+ 905 |
! |
- } else if (file_extension == "pdf") {
+ expr = {
|
- | 172 |
+ 906 |
! |
- tags$embed(
+ smoothy <- smooth(data$.hat, data$.stdresid)
|
- | 173 |
+ 907 |
! |
- class = "embed_pdf",
+ g <- plot
|
- | 174 |
+ 908 |
! |
- src = con_type$selected_path
+ print(g)
|
- | 175 |
+ 909 |
|
- )
+ },
|
- | 176 |
+ 910 |
! |
- } else if (!isFALSE(con_type$output_text[1])) {
+ env = list(
|
- | 177 |
+ 911 |
! |
- tags$pre(paste0(con_type$output_text, collapse = "\n"))
+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
- | 178 |
+ 912 |
|
- } else {
+ )
|
-
- | 179 |
- ! |
+
+ | 913 |
+ |
- tags$p("Please select a supported format.")
+ )
|
- | 180 |
+ 914 |
|
- }
+ )
|
- | 181 |
+ 915 |
|
- }
+ }
|
- | 182 |
+ 916 |
|
|
- | 183 |
+ 917 |
! |
- tree_list <- function(file_or_dir) {
+ plot_type_6 <- function(plot_base) {
|
- | 184 |
+ 918 |
! |
- nested_list <- lapply(file_or_dir, function(path) {
+ shinyjs::show("size")
|
- | 185 |
+ 919 |
! |
- file_class <- suppressWarnings(file(path))
+ shinyjs::show("alpha")
|
- | 186 |
+ 920 |
! |
- close(file_class)
+ plot <- substitute(
|
- | 187 |
+ 921 |
! |
- if (class(file_class)[[1]] != "url") {
+ expr = ggplot(data = data, aes(.hat, .cooksd)) +
|
- | 188 |
+ 922 |
! |
- isdir <- file.info(path)$isdir
+ geom_vline(xintercept = 0, colour = NA) +
|
- | 189 |
+ 923 |
! |
- if (!isdir) {
+ geom_abline(
|
- | 190 |
+ 924 |
! |
- structure(path, ancestry = path, sticon = "file")
+ slope = seq(0, 3, by = 0.5),
|
-
- | 191 |
- |
+
+ | 925 |
+ ! |
- } else {
+ colour = "black",
|
- | 192 |
+ 926 |
! |
- files <- list.files(path, full.names = TRUE, include.dirs = TRUE)
+ linetype = "dashed",
|
- | 193 |
+ 927 |
! |
- out <- lapply(files, function(x) tree_list(x))
+ size = 1
+ |
+
+
+ | 928 |
+ |
+
+ ) +
|
- | 194 |
+ 929 |
! |
- out <- unlist(out, recursive = FALSE)
+ geom_line(data = smoothy, mapping = smoothy_aes) +
|
- | 195 |
+ 930 |
! |
- if (length(files) > 0) names(out) <- basename(files)
+ geom_point(size = size, alpha = alpha),
|
- | 196 |
+ 931 |
! |
- out
+ env = list(size = size, alpha = alpha)
|
- | 197 |
+ 932 |
|
- }
+ )
|
-
- | 198 |
- |
+
+ | 933 |
+ ! |
- } else {
+ if (show_outlier) {
|
- | 199 |
+ 934 |
! |
- structure(path, ancestry = path, sticon = "file")
+ plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label()))
|
- | 200 |
+ 935 |
|
}
|
- | 201 |
+ 936 |
|
- })
+
|
-
- | 202 |
- |
+
+ | 937 |
+ ! |
-
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
|
- | 203 |
+ 938 |
! |
- missing_labels <- if (is.null(names(nested_list))) seq_along(nested_list) else which(names(nested_list) == "")
+ teal.widgets::resolve_ggplot2_args(
|
- | 204 |
+ 939 |
! |
- names(nested_list)[missing_labels] <- file_or_dir[missing_labels]
+ user_plot = ggplot2_args[["Cook's dist vs Leverage"]],
|
- | 205 |
+ 940 |
! |
- nested_list
+ user_default = ggplot2_args$default,
|
-
- | 206 |
- |
+
+ | 941 |
+ ! |
- }
+ module_plot = teal.widgets::ggplot2_args(
|
-
- | 207 |
- |
+
+ | 942 |
+ ! |
-
+ labs = list(
|
- | 208 |
+ 943 |
! |
- output$tree <- shinyTree::renderTree({
+ x = quote(paste0("Leverage\nlm(", reg_form, ")")),
|
- | 209 |
+ 944 |
! |
- if (length(input_path) > 0) {
+ y = "Cooks's distance",
|
- | 210 |
+ 945 |
! |
- tree_list(input_path)
+ title = "Cook's dist vs Leverage"
|
- | 211 |
+ 946 |
|
- } else {
+ )
|
-
- | 212 |
- ! |
+
+ | 947 |
+ |
- list("Empty Path" = NULL)
+ )
|
- | 213 |
+ 948 |
|
- }
+ ),
+ |
+
+
+ | 949 |
+ ! |
+
+ ggtheme = ggtheme
|
- | 214 |
+ 950 |
|
- })
+ )
|
- | 215 |
+ 951 |
|
|
- | 216 |
+ 952 |
! |
- output$output <- renderUI({
+ teal.code::eval_code(
|
- | 217 |
+ 953 |
! |
- validate(
+ plot_base,
|
- | 218 |
+ 954 |
! |
- need(
+ substitute(
|
- | 219 |
+ 955 |
! |
- length(shinyTree::get_selected(input$tree)) > 0,
+ expr = {
|
- | 220 |
+ 956 |
! |
- "Please select a file."
+ smoothy <- smooth(data$.hat, data$.cooksd)
|
-
- | 221 |
- |
+
+ | 957 |
+ ! |
- )
+ g <- plot
|
-
- | 222 |
- |
+
+ | 958 |
+ ! |
- )
+ print(g)
|
- | 223 |
+ 959 |
|
-
- |
-
-
- | 224 |
- ! |
-
- obj <- shinyTree::get_selected(input$tree, format = "names")[[1]]
+ },
|
- | 225 |
+ 960 |
! |
- repo <- attr(obj, "ancestry")
+ env = list(
|
- | 226 |
+ 961 |
! |
- repo_collapsed <- if (length(repo) > 1) paste0(repo, collapse = "/") else repo
+ plot = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args))
|
-
- | 227 |
- ! |
+
+ | 962 |
+ |
- is_not_named <- file.exists(file.path(c(repo_collapsed, obj[1])))[1]
+ )
|
- | 228 |
+ 963 |
|
-
+ )
|
-
- | 229 |
- ! |
+
+ | 964 |
+ |
- if (is_not_named) {
+ )
|
-
- | 230 |
- ! |
+
+ | 965 |
+ |
- selected_path <- do.call("file.path", as.list(c(repo, obj[1])))
+ }
|
- | 231 |
+ 966 |
|
- } else {
+
|
- | 232 |
+ 967 |
! |
- if (length(repo) == 0) {
+ qenv <- if (input_type == "Response vs Regressor") {
|
- | 233 |
+ 968 |
! |
- selected_path <- do.call("file.path", as.list(attr(input$tree[[obj[1]]], "ancestry")))
+ plot_type_0()
|
- | 234 |
+ 969 |
|
- } else {
+ } else {
|
- | 235 |
+ 970 |
! |
- selected_path <- do.call("file.path", as.list(attr(input$tree[[repo]][[obj[1]]], "ancestry")))
+ plot_base_q <- plot_base()
|
-
- | 236 |
- |
+
+ | 971 |
+ ! |
- }
+ switch(input_type,
|
-
- | 237 |
- |
+
+ | 972 |
+ ! |
- }
+ "Residuals vs Fitted" = plot_base_q %>% plot_type_1(),
|
-
- | 238 |
- |
+
+ | 973 |
+ ! |
-
+ "Normal Q-Q" = plot_base_q %>% plot_type_2(),
|
- | 239 |
+ 974 |
! |
- validate(
+ "Scale-Location" = plot_base_q %>% plot_type_3(),
|
- | 240 |
+ 975 |
! |
- need(
+ "Cook's distance" = plot_base_q %>% plot_type_4(),
|
- | 241 |
+ 976 |
! |
- !isTRUE(file.info(selected_path)$isdir) && length(selected_path) > 0,
+ "Residuals vs Leverage" = plot_base_q %>% plot_type_5(),
|
- | 242 |
+ 977 |
! |
- "Please select a single file."
+ "Cook's dist vs Leverage" = plot_base_q %>% plot_type_6()
|
- | 243 |
+ 978 |
|
)
|
- | 244 |
+ 979 |
|
- )
+ }
|
- | 245 |
+ 980 |
! |
- display_file(selected_path)
+ qenv
|
- | 246 |
+ 981 |
|
})
|
- | 247 |
+ 982 |
|
|
-
- | 248 |
- ! |
+
+ | 983 |
+ |
- onStop(function() {
+
|
- | 249 |
+ 984 |
! |
- removeResourcePath(basename(temp_dir))
+ fitted <- reactive(output_q()[["fit"]])
|
- | 250 |
+ 985 |
! |
- unlink(temp_dir)
+ plot_r <- reactive(output_q()[["g"]])
|
- | 251 |
+ 986 |
|
- })
+
|
- | 252 |
+ 987 |
|
- })
+ # Insert the plot into a plot_with_settings module from teal.widgets
|
-
- | 253 |
- |
+
+ | 988 |
+ ! |
- }
+ pws <- teal.widgets::plot_with_settings_srv(
|
-
-
-
-
-
-
-
- | 1 |
- |
+
+ | 989 |
+ ! |
- #' `teal` module: Univariate and bivariate visualizations
+ id = "myplot",
|
-
- | 2 |
- |
+
+ | 990 |
+ ! |
- #'
+ plot_r = plot_r,
|
-
- | 3 |
- |
+
+ | 991 |
+ ! |
- #' Module enables the creation of univariate and bivariate plots,
+ height = plot_height,
|
-
- | 4 |
- |
+
+ | 992 |
+ ! |
- #' facilitating the exploration of data distributions and relationships between two variables.
+ width = plot_width
|
- | 5 |
+ 993 |
|
- #'
+ )
|
- | 6 |
+ 994 |
|
- #' This is a general module to visualize 1 & 2 dimensional data.
+
|
-
- | 7 |
- |
+
+ | 995 |
+ ! |
- #'
+ output$text <- renderText({
|
-
- | 8 |
- |
+
+ | 996 |
+ ! |
- #' @note
+ req(iv_r()$is_valid())
|
-
- | 9 |
- |
+
+ | 997 |
+ ! |
- #' For more examples, please see the vignette "Using bivariate plot" via
+ req(iv_out$is_valid())
|
-
- | 10 |
- |
+
+ | 998 |
+ ! |
- #' `vignette("using-bivariate-plot", package = "teal.modules.general")`.
+ paste(utils::capture.output(summary(teal.code::dev_suppress(fitted())))[-1],
|
-
- | 11 |
- |
+
+ | 999 |
+ ! |
- #'
+ collapse = "\n"
|
- | 12 |
+ 1000 |
|
- #' @inheritParams teal::module
+ )
|
- | 13 |
+ 1001 |
|
- #' @inheritParams shared_params
+ })
|
- | 14 |
+ 1002 |
|
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)
+
|
-
- | 15 |
- |
+
+ | 1003 |
+ ! |
- #' Variable names selected to plot along the x-axis by default.
+ teal.widgets::verbatim_popup_srv(
|
-
- | 16 |
- |
+
+ | 1004 |
+ ! |
- #' Can be numeric, factor or character.
+ id = "rcode",
|
-
- | 17 |
- |
+
+ | 1005 |
+ ! |
- #' No empty selections are allowed.
+ verbatim_content = reactive(teal.code::get_code(output_q())),
|
-
- | 18 |
- |
+
+ | 1006 |
+ ! |
- #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`)
+ title = "R code for the regression plot",
|
- | 19 |
+ 1007 |
|
- #' Variable names selected to plot along the y-axis by default.
+ )
|
- | 20 |
+ 1008 |
|
- #' Can be numeric, factor or character.
+
|
- | 21 |
+ 1009 |
|
- #' @param use_density (`logical`) optional, indicates whether to plot density (`TRUE`) or frequency (`FALSE`).
+ ### REPORTER
|
-
- | 22 |
- |
+
+ | 1010 |
+ ! |
- #' Defaults to frequency (`FALSE`).
+ if (with_reporter) {
|
-
- | 23 |
- |
+
+ | 1011 |
+ ! |
- #' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
+ card_fun <- function(comment, label) {
|
-
- | 24 |
- |
+
+ | 1012 |
+ ! |
- #' specification of the data variable(s) to use for faceting rows.
+ card <- teal::report_card_template(
|
-
- | 25 |
- |
+
+ | 1013 |
+ ! |
- #' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
+ title = "Linear Regression Plot",
|
-
- | 26 |
- |
+
+ | 1014 |
+ ! |
- #' specification of the data variable(s) to use for faceting columns.
+ label = label,
|
-
- | 27 |
- |
+
+ | 1015 |
+ ! |
- #' @param facet (`logical`) optional, specifies whether the facet encodings `ui` elements are toggled
+ with_filter = with_filter,
|
-
- | 28 |
- |
+
+ | 1016 |
+ ! |
- #' on and shown to the user by default. Defaults to `TRUE` if either `row_facet` or `column_facet`
+ filter_panel_api = filter_panel_api
|
- | 29 |
+ 1017 |
|
- #' are supplied.
+ )
|
-
- | 30 |
- |
+
+ | 1018 |
+ ! |
- #' @param color_settings (`logical`) Whether coloring, filling and size should be applied
+ card$append_text("Plot", "header3")
|
-
- | 31 |
- |
+
+ | 1019 |
+ ! |
- #' and `UI` tool offered to the user.
+ card$append_plot(plot_r(), dim = pws$dim())
|
-
- | 32 |
- |
+
+ | 1020 |
+ ! |
- #' @param color (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
+ if (!comment == "") {
|
-
- | 33 |
- |
+
+ | 1021 |
+ ! |
- #' specification of the data variable(s) selected for the outline color inside the coloring settings.
+ card$append_text("Comment", "header3")
|
-
- | 34 |
- |
+
+ | 1022 |
+ ! |
- #' It will be applied when `color_settings` is set to `TRUE`.
+ card$append_text(comment)
|
- | 35 |
+ 1023 |
|
- #' @param fill (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
+ }
|
-
- | 36 |
- |
+
+ | 1024 |
+ ! |
- #' specification of the data variable(s) selected for the fill color inside the coloring settings.
+ card$append_src(teal.code::get_code(output_q()))
+ |
+
+
+ | 1025 |
+ ! |
+
+ card
|
- | 37 |
+ 1026 |
|
- #' It will be applied when `color_settings` is set to `TRUE`.
+ }
+ |
+
+
+ | 1027 |
+ ! |
+
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
- | 38 |
+ 1028 |
|
- #' @param size (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
+ }
|
- | 39 |
+ 1029 |
|
- #' specification of the data variable(s) selected for the size of `geom_point` plots inside the coloring settings.
+ ###
|
- | 40 |
+ 1030 |
|
- #' It will be applied when `color_settings` is set to `TRUE`.
+ })
|
- | 41 |
+ 1031 |
|
- #' @param free_x_scales (`logical`) optional, whether X scaling shall be changeable.
+ }
|
- | 42 |
+ 1032 |
|
- #' Does not allow scaling to be changed by default (`FALSE`).
+
|
- | 43 |
+ 1033 |
|
- #' @param free_y_scales (`logical`) optional, whether Y scaling shall be changeable.
+ regression_names <- paste0(
|
- | 44 |
+ 1034 |
|
- #' Does not allow scaling to be changed by default (`FALSE`).
+ '"Response vs Regressor", "Residuals vs Fitted", ',
|
- | 45 |
+ 1035 |
|
- #' @param swap_axes (`logical`) optional, whether to swap X and Y axes. Defaults to `FALSE`.
+ '"Scale-Location", "Cook\'s distance", "Residuals vs Leverage"", "Cook\'s dist vs Leverage"'
|
- | 46 |
+ 1036 |
|
- #'
+ )
|
+
+
+
+
+
+
- | 47 |
+ 1 |
|
- #' @inherit shared_params return
+ #' `teal` module: Stack plots of variables and show association with reference variable
|
- | 48 |
+ 2 |
|
#'
|
- | 49 |
+ 3 |
|
- #' @examples
+ #' Module provides functionality for visualizing the distribution of variables and
|
- | 50 |
+ 4 |
|
- #' library(teal.widgets)
+ #' their association with a reference variable.
|
- | 51 |
+ 5 |
|
- #'
+ #' It supports configuring the appearance of the plots, including themes and whether to show associations.
|
- | 52 |
+ 6 |
|
- #' # general data example
+ #'
|
- | 53 |
+ 7 |
|
- #' data <- teal_data()
+ #'
|
- | 54 |
+ 8 |
|
- #' data <- within(data, {
+ #' @note For more examples, please see the vignette "Using association plot" via
|
- | 55 |
+ 9 |
|
- #' require(nestcolor)
+ #' `vignette("using-association-plot", package = "teal.modules.general")`.
|
- | 56 |
+ 10 |
|
- #' CO2 <- data.frame(CO2)
+ #'
|
- | 57 |
+ 11 |
|
- #' })
+ #' @inheritParams teal::module
|
- | 58 |
+ 12 |
|
- #' datanames(data) <- c("CO2")
+ #' @inheritParams shared_params
|
- | 59 |
+ 13 |
|
- #'
+ #' @param ref (`data_extract_spec` or `list` of multiple `data_extract_spec`)
|
- | 60 |
+ 14 |
|
- #' app <- init(
+ #' Reference variable, must accepts a `data_extract_spec` with `select_spec(multiple = FALSE)`
|
- | 61 |
+ 15 |
|
- #' data = data,
+ #' to ensure single selection option.
|
- | 62 |
+ 16 |
|
- #' modules = tm_g_bivariate(
+ #' @param vars (`data_extract_spec` or `list` of multiple `data_extract_spec`)
|
- | 63 |
+ 17 |
|
- #' x = data_extract_spec(
+ #' Variables to be associated with the reference variable.
|
- | 64 |
+ 18 |
|
- #' dataname = "CO2",
+ #' @param show_association (`logical`) optional, whether show association of `vars`
|
- | 65 |
+ 19 |
|
- #' select = select_spec(
+ #' with reference variable. Defaults to `TRUE`.
|
- | 66 |
+ 20 |
|
- #' label = "Select variable:",
+ #' @param distribution_theme,association_theme (`character`) optional, `ggplot2` themes to be used by default.
|
- | 67 |
+ 21 |
|
- #' choices = variable_choices(data[["CO2"]]),
+ #' Default to `"gray"`.
|
- | 68 |
+ 22 |
|
- #' selected = "conc",
+ #'
|
- | 69 |
+ 23 |
|
- #' fixed = FALSE
+ #' @templateVar ggnames "Bivariate1", "Bivariate2"
|
- | 70 |
+ 24 |
|
- #' )
+ #' @template ggplot2_args_multi
|
- | 71 |
+ 25 |
|
- #' ),
+ #'
|
- | 72 |
+ 26 |
|
- #' y = data_extract_spec(
+ #' @inherit shared_params return
|
- | 73 |
+ 27 |
|
- #' dataname = "CO2",
+ #'
|
- | 74 |
+ 28 |
|
- #' select = select_spec(
+ #' @examplesShinylive
|
- | 75 |
+ 29 |
|
- #' label = "Select variable:",
+ #' library(teal.modules.general)
|
- | 76 |
+ 30 |
|
- #' choices = variable_choices(data[["CO2"]]),
+ #' interactive <- function() TRUE
|
- | 77 |
+ 31 |
|
- #' selected = "uptake",
+ #' {{ next_example }}
|
- | 78 |
+ 32 |
|
- #' multiple = FALSE,
+ #' @examples
|
- | 79 |
+ 33 |
|
- #' fixed = FALSE
+ #' # general data example
|
- | 80 |
+ 34 |
|
- #' )
+ #' data <- teal_data()
|
- | 81 |
+ 35 |
|
- #' ),
+ #' data <- within(data, {
|
- | 82 |
+ 36 |
|
- #' row_facet = data_extract_spec(
+ #' require(nestcolor)
|
- | 83 |
+ 37 |
|
- #' dataname = "CO2",
+ #' CO2 <- CO2
|
- | 84 |
+ 38 |
|
- #' select = select_spec(
+ #' factors <- names(Filter(isTRUE, vapply(CO2, is.factor, logical(1L))))
|
- | 85 |
+ 39 |
|
- #' label = "Select variable:",
+ #' CO2[factors] <- lapply(CO2[factors], as.character)
|
- | 86 |
+ 40 |
|
- #' choices = variable_choices(data[["CO2"]]),
+ #' })
|
- | 87 |
+ 41 |
|
- #' selected = "Type",
+ #' datanames(data) <- c("CO2")
|
- | 88 |
+ 42 |
|
- #' fixed = FALSE
+ #'
|
- | 89 |
+ 43 |
|
- #' )
+ #' app <- init(
|
- | 90 |
+ 44 |
|
- #' ),
+ #' data = data,
|
- | 91 |
+ 45 |
|
- #' col_facet = data_extract_spec(
+ #' modules = modules(
|
- | 92 |
+ 46 |
|
- #' dataname = "CO2",
+ #' tm_g_association(
|
- | 93 |
+ 47 |
|
- #' select = select_spec(
+ #' ref = data_extract_spec(
|
- | 94 |
+ 48 |
|
- #' label = "Select variable:",
+ #' dataname = "CO2",
|
- | 95 |
+ 49 |
|
- #' choices = variable_choices(data[["CO2"]]),
+ #' select = select_spec(
|
- | 96 |
+ 50 |
|
- #' selected = "Treatment",
+ #' label = "Select variable:",
|
- | 97 |
+ 51 |
|
- #' fixed = FALSE
+ #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
|
- | 98 |
+ 52 |
|
- #' )
+ #' selected = "Plant",
|
- | 99 |
+ 53 |
|
- #' ),
+ #' fixed = FALSE
|
- | 100 |
+ 54 |
|
- #' ggplot2_args = ggplot2_args(
+ #' )
|
- | 101 |
+ 55 |
|
- #' labs = list(subtitle = "Plot generated by Bivariate Module")
+ #' ),
|
- | 102 |
+ 56 |
|
- #' )
+ #' vars = data_extract_spec(
|
- | 103 |
+ 57 |
|
- #' )
+ #' dataname = "CO2",
|
- | 104 |
+ 58 |
|
- #' )
+ #' select = select_spec(
|
- | 105 |
+ 59 |
|
- #' if (interactive()) {
+ #' label = "Select variables:",
|
- | 106 |
+ 60 |
|
- #' shinyApp(app$ui, app$server)
+ #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
|
- | 107 |
+ 61 |
|
- #' }
+ #' selected = "Treatment",
|
- | 108 |
+ 62 |
|
- #'
+ #' multiple = TRUE,
|
- | 109 |
+ 63 |
|
- #'
+ #' fixed = FALSE
|
- | 110 |
+ 64 |
|
- #' # CDISC data example
+ #' )
|
- | 111 |
+ 65 |
|
- #' data <- teal_data()
+ #' )
|
- | 112 |
+ 66 |
|
- #' data <- within(data, {
+ #' )
|
- | 113 |
+ 67 |
|
- #' require(nestcolor)
+ #' )
|
- | 114 |
+ 68 |
|
- #' ADSL <- rADSL
+ #' )
|
- | 115 |
+ 69 |
|
- #' })
+ #' if (interactive()) {
|
- | 116 |
+ 70 |
|
- #' datanames(data) <- c("ADSL")
+ #' shinyApp(app$ui, app$server)
|
- | 117 |
+ 71 |
|
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
+ #' }
|
- | 118 |
+ 72 |
|
#'
|
- | 119 |
+ 73 |
|
- #' app <- init(
+ #' @examplesShinylive
|
- | 120 |
+ 74 |
|
- #' data = data,
+ #' library(teal.modules.general)
|
- | 121 |
+ 75 |
|
- #' modules = tm_g_bivariate(
+ #' interactive <- function() TRUE
|
- | 122 |
+ 76 |
|
- #' x = data_extract_spec(
+ #' {{ next_example }}
|
- | 123 |
+ 77 |
|
- #' dataname = "ADSL",
+ #' @examples
|
- | 124 |
+ 78 |
|
- #' select = select_spec(
+ #' # CDISC data example
|
- | 125 |
+ 79 |
|
- #' label = "Select variable:",
+ #' data <- teal_data()
|
- | 126 |
+ 80 |
|
- #' choices = variable_choices(data[["ADSL"]]),
+ #' data <- within(data, {
|
- | 127 |
+ 81 |
|
- #' selected = "AGE",
+ #' require(nestcolor)
|
- | 128 |
+ 82 |
|
- #' fixed = FALSE
+ #' ADSL <- rADSL
|
- | 129 |
+ 83 |
|
- #' )
+ #' })
|
- | 130 |
+ 84 |
|
- #' ),
+ #' datanames(data) <- "ADSL"
|
- | 131 |
+ 85 |
|
- #' y = data_extract_spec(
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
|
- | 132 |
+ 86 |
|
- #' dataname = "ADSL",
+ #'
|
- | 133 |
+ 87 |
|
- #' select = select_spec(
+ #' app <- init(
|
- | 134 |
+ 88 |
|
- #' label = "Select variable:",
+ #' data = data,
|
- | 135 |
+ 89 |
|
- #' choices = variable_choices(data[["ADSL"]]),
+ #' modules = modules(
|
- | 136 |
+ 90 |
|
- #' selected = "SEX",
+ #' tm_g_association(
|
- | 137 |
+ 91 |
|
- #' multiple = FALSE,
+ #' ref = data_extract_spec(
|
- | 138 |
+ 92 |
|
- #' fixed = FALSE
+ #' dataname = "ADSL",
|
- | 139 |
+ 93 |
|
- #' )
+ #' select = select_spec(
|
- | 140 |
+ 94 |
|
- #' ),
+ #' label = "Select variable:",
|
- | 141 |
+ 95 |
|
- #' row_facet = data_extract_spec(
+ #' choices = variable_choices(
|
- | 142 |
+ 96 |
|
- #' dataname = "ADSL",
+ #' data[["ADSL"]],
|
- | 143 |
+ 97 |
|
- #' select = select_spec(
+ #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
|
- | 144 |
+ 98 |
|
- #' label = "Select variable:",
+ #' ),
|
- | 145 |
+ 99 |
|
- #' choices = variable_choices(data[["ADSL"]]),
+ #' selected = "RACE",
|
- | 146 |
+ 100 |
|
- #' selected = "ARM",
+ #' fixed = FALSE
|
- | 147 |
+ 101 |
|
- #' fixed = FALSE
+ #' )
|
- | 148 |
+ 102 |
|
- #' )
+ #' ),
|
- | 149 |
+ 103 |
|
- #' ),
+ #' vars = data_extract_spec(
|
- | 150 |
+ 104 |
|
- #' col_facet = data_extract_spec(
+ #' dataname = "ADSL",
|
- | 151 |
+ 105 |
|
- #' dataname = "ADSL",
+ #' select = select_spec(
|
- | 152 |
+ 106 |
|
- #' select = select_spec(
+ #' label = "Select variables:",
|
- | 153 |
+ 107 |
|
- #' label = "Select variable:",
+ #' choices = variable_choices(
|
- | 154 |
+ 108 |
|
- #' choices = variable_choices(data[["ADSL"]]),
+ #' data[["ADSL"]],
|
- | 155 |
+ 109 |
|
- #' selected = "COUNTRY",
+ #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
|
- | 156 |
+ 110 |
|
- #' fixed = FALSE
+ #' ),
|
- | 157 |
+ 111 |
|
- #' )
+ #' selected = "BMRKR2",
|
- | 158 |
+ 112 |
|
- #' ),
+ #' multiple = TRUE,
|
- | 159 |
+ 113 |
|
- #' ggplot2_args = ggplot2_args(
+ #' fixed = FALSE
|
- | 160 |
+ 114 |
|
- #' labs = list(subtitle = "Plot generated by Bivariate Module")
+ #' )
|
- | 161 |
+ 115 |
+ |
+
+ #' )
+ |
+
+
+ | 116 |
|
#' )
|
- | 162 |
+ 117 |
|
#' )
|
- | 163 |
+ 118 |
|
#' )
|
- | 164 |
+ 119 |
|
#' if (interactive()) {
|
- | 165 |
+ 120 |
|
#' shinyApp(app$ui, app$server)
|
- | 166 |
+ 121 |
|
#' }
|
- | 167 |
+ 122 |
|
#'
|
- | 168 |
+ 123 |
|
#' @export
|
- | 169 |
+ 124 |
|
#'
|
- | 170 |
+ 125 |
|
- tm_g_bivariate <- function(label = "Bivariate Plots",
+ tm_g_association <- function(label = "Association",
|
- | 171 |
+ 126 |
|
- x,
+ ref,
|
- | 172 |
+ 127 |
|
- y,
+ vars,
|
- | 173 |
+ 128 |
|
- row_facet = NULL,
+ show_association = TRUE,
|
- | 174 |
+ 129 |
|
- col_facet = NULL,
+ plot_height = c(600, 400, 5000),
|
- | 175 |
+ 130 |
|
- facet = !is.null(row_facet) || !is.null(col_facet),
+ plot_width = NULL,
|
- | 176 |
+ 131 |
|
- color = NULL,
+ distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
|
- | 177 |
+ 132 |
|
- fill = NULL,
+ association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
|
- | 178 |
+ 133 |
|
- size = NULL,
+ pre_output = NULL,
|
- | 179 |
+ 134 |
|
- use_density = FALSE,
+ post_output = NULL,
|
- | 180 |
+ 135 |
|
- color_settings = FALSE,
+ ggplot2_args = teal.widgets::ggplot2_args()) {
|
-
- | 181 |
- |
+
+ | 136 |
+ ! |
- free_x_scales = FALSE,
+ message("Initializing tm_g_association")
|
- | 182 |
+ 137 |
|
- free_y_scales = FALSE,
+
|
- | 183 |
+ 138 |
|
- plot_height = c(600, 200, 2000),
+ # Normalize the parameters
|
-
- | 184 |
- |
+
+ | 139 |
+ ! |
- plot_width = NULL,
+ if (inherits(ref, "data_extract_spec")) ref <- list(ref)
|
-
- | 185 |
- |
+
+ | 140 |
+ ! |
- rotate_xaxis_labels = FALSE,
+ if (inherits(vars, "data_extract_spec")) vars <- list(vars)
|
-
- | 186 |
- |
+
+ | 141 |
+ ! |
- swap_axes = FALSE,
+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)
|
- | 187 |
+ 142 |
|
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+
|
- | 188 |
+ 143 |
|
- ggplot2_args = teal.widgets::ggplot2_args(),
+ # Start of assertions
|
-
- | 189 |
- |
+
+ | 144 |
+ ! |
- pre_output = NULL,
+ checkmate::assert_string(label)
|
- | 190 |
+ 145 |
|
- post_output = NULL) {
+
|
-
- | 191 |
- 18x |
+
+ | 146 |
+ ! |
- message("Initializing tm_g_bivariate")
+ checkmate::assert_list(ref, types = "data_extract_spec")
+ |
+
+
+ | 147 |
+ ! |
+
+ if (!all(vapply(ref, function(x) !x$select$multiple, logical(1)))) {
+ |
+
+
+ | 148 |
+ ! |
+
+ stop("'ref' should not allow multiple selection")
|
- | 192 |
+ 149 |
|
-
+ }
|
- | 193 |
+ 150 |
|
- # Normalize the parameters
+
|
-
- | 194 |
- 14x |
+
+ | 151 |
+ ! |
- if (inherits(x, "data_extract_spec")) x <- list(x)
+ checkmate::assert_list(vars, types = "data_extract_spec")
|
-
- | 195 |
- 13x |
+
+ | 152 |
+ ! |
- if (inherits(y, "data_extract_spec")) y <- list(y)
+ checkmate::assert_flag(show_association)
|
-
- | 196 |
- 1x |
+
+ | 153 |
+ |
- if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)
+
|
-
- | 197 |
- 1x |
+
+ | 154 |
+ ! |
- if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
|
-
- | 198 |
- 1x |
+
+ | 155 |
+ ! |
- if (inherits(color, "data_extract_spec")) color <- list(color)
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
|
-
- | 199 |
- 1x |
+
+ | 156 |
+ ! |
- if (inherits(fill, "data_extract_spec")) fill <- list(fill)
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
|
-
- | 200 |
- 1x |
+
+ | 157 |
+ ! |
- if (inherits(size, "data_extract_spec")) size <- list(size)
+ checkmate::assert_numeric(
|
-
- | 201 |
- |
+
+ | 158 |
+ ! |
-
+ plot_width[1],
|
-
- | 202 |
- |
+
+ | 159 |
+ ! |
- # Start of assertions
+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
|
-
- | 203 |
- 18x |
+
+ | 160 |
+ |
- checkmate::assert_string(label)
+ )
|
- | 204 |
+ 161 |
|
|
-
- | 205 |
- 18x |
+
+ | 162 |
+ ! |
- checkmate::assert_list(x, types = "data_extract_spec")
+ distribution_theme <- match.arg(distribution_theme)
|
-
- | 206 |
- 18x |
+
+ | 163 |
+ ! |
- assert_single_selection(x)
+ association_theme <- match.arg(association_theme)
|
- | 207 |
+ 164 |
|
|
-
- | 208 |
- 16x |
+
+ | 165 |
+ ! |
- checkmate::assert_list(y, types = "data_extract_spec")
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
-
- | 209 |
- 16x |
+
+ | 166 |
+ ! |
- assert_single_selection(y)
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
- | 210 |
+ 167 |
|
|
-
- | 211 |
- 14x |
+
+ | 168 |
+ ! |
- checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)
+ plot_choices <- c("Bivariate1", "Bivariate2")
|
-
- | 212 |
- 14x |
+
+ | 169 |
+ ! |
- assert_single_selection(row_facet)
+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args")
+ |
+
+
+ | 170 |
+ ! |
+
+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
- | 213 |
+ 171 |
+ |
+
+ # End of assertions
+ |
+
+
+ | 172 |
|
|
-
- | 214 |
- 14x |
+
+ | 173 |
+ |
- checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)
+ # Make UI args
|
-
- | 215 |
- 14x |
+
+ | 174 |
+ ! |
- assert_single_selection(col_facet)
+ args <- as.list(environment())
|
- | 216 |
+ 175 |
|
|
-
- | 217 |
- 14x |
+
+ | 176 |
+ ! |
- checkmate::assert_flag(facet)
+ data_extract_list <- list(
|
-
- | 218 |
- |
+
+ | 177 |
+ ! |
-
+ ref = ref,
|
-
- | 219 |
- 14x |
+
+ | 178 |
+ ! |
- checkmate::assert_list(color, types = "data_extract_spec", null.ok = TRUE)
+ vars = vars
|
-
- | 220 |
- 14x |
+
+ | 179 |
+ |
- assert_single_selection(color)
+ )
|
- | 221 |
+ 180 |
|
|
-
- | 222 |
- 14x |
+
+ | 181 |
+ ! |
- checkmate::assert_list(fill, types = "data_extract_spec", null.ok = TRUE)
+ ans <- module(
|
-
- | 223 |
- 14x |
+
+ | 182 |
+ ! |
- assert_single_selection(fill)
+ label = label,
|
-
- | 224 |
- |
+
+ | 183 |
+ ! |
-
+ server = srv_tm_g_association,
|
-
- | 225 |
- 14x |
+
+ | 184 |
+ ! |
- checkmate::assert_list(size, types = "data_extract_spec", null.ok = TRUE)
+ ui = ui_tm_g_association,
|
-
- | 226 |
- 14x |
+
+ | 185 |
+ ! |
- assert_single_selection(size)
+ ui_args = args,
|
-
- | 227 |
- |
+
+ | 186 |
+ ! |
-
+ server_args = c(
|
-
- | 228 |
- 14x |
+
+ | 187 |
+ ! |
- checkmate::assert_flag(use_density)
+ data_extract_list,
|
-
- | 229 |
- |
+
+ | 188 |
+ ! |
-
+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)
|
- | 230 |
+ 189 |
|
- # Determines color, fill & size if they are not explicitly set
+ ),
|
-
- | 231 |
- 14x |
+
+ | 190 |
+ ! |
- checkmate::assert_flag(color_settings)
+ datanames = teal.transform::get_extract_datanames(data_extract_list)
|
-
- | 232 |
- 14x |
+
+ | 191 |
+ |
- if (color_settings) {
+ )
|
-
- | 233 |
- 2x |
+
+ | 192 |
+ ! |
- if (is.null(color)) {
+ attr(ans, "teal_bookmarkable") <- TRUE
|
-
- | 234 |
- 2x |
+
+ | 193 |
+ ! |
- color <- x
+ ans
|
-
- | 235 |
- 2x |
+
+ | 194 |
+ |
- color[[1]]$select <- teal.transform::select_spec(choices = color[[1]]$select$choices, selected = NULL)
+ }
|
- | 236 |
+ 195 |
|
- }
+
|
-
+
+ | 196 |
+ |
+
+ # UI function for the association module
+ |
+
+
+ | 197 |
+ |
+
+ ui_tm_g_association <- function(id, ...) {
+ |
+
+
+ | 198 |
+ ! |
+
+ ns <- NS(id)
+ |
+
+
+ | 199 |
+ ! |
+
+ args <- list(...)
+ |
+
+
+ | 200 |
+ ! |
+
+ is_single_dataset_value <- teal.transform::is_single_dataset(args$ref, args$vars)
+ |
+
+
+ | 201 |
+ |
+
+
+ |
+
+
+ | 202 |
+ ! |
+
+ teal.widgets::standard_layout(
+ |
+
+
+ | 203 |
+ ! |
+
+ output = teal.widgets::white_small_well(
+ |
+
+
+ | 204 |
+ ! |
+
+ textOutput(ns("title")),
+ |
+
+
+ | 205 |
+ ! |
+
+ tags$br(),
+ |
+
+
+ | 206 |
+ ! |
+
+ teal.widgets::plot_with_settings_ui(id = ns("myplot"))
+ |
+
+
+ | 207 |
+ |
+
+ ),
+ |
+
+
+ | 208 |
+ ! |
+
+ encoding = tags$div(
+ |
+
+
+ | 209 |
+ |
+
+ ### Reporter
+ |
+
+
+ | 210 |
+ ! |
+
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ |
+
+
+ | 211 |
+ |
+
+ ###
+ |
+
+
+ | 212 |
+ ! |
+
+ tags$label("Encodings", class = "text-primary"),
+ |
+
+
+ | 213 |
+ ! |
+
+ teal.transform::datanames_input(args[c("ref", "vars")]),
+ |
+
+
+ | 214 |
+ ! |
+
+ teal.transform::data_extract_ui(
+ |
+
+
+ | 215 |
+ ! |
+
+ id = ns("ref"),
+ |
+
+
+ | 216 |
+ ! |
+
+ label = "Reference variable",
+ |
+
+
+ | 217 |
+ ! |
+
+ data_extract_spec = args$ref,
+ |
+
+
+ | 218 |
+ ! |
+
+ is_single_dataset = is_single_dataset_value
+ |
+
+
+ | 219 |
+ |
+
+ ),
+ |
+
+
+ | 220 |
+ ! |
+
+ teal.transform::data_extract_ui(
+ |
+
+
+ | 221 |
+ ! |
+
+ id = ns("vars"),
+ |
+
+
+ | 222 |
+ ! |
+
+ label = "Associated variables",
+ |
+
+
+ | 223 |
+ ! |
+
+ data_extract_spec = args$vars,
+ |
+
+
+ | 224 |
+ ! |
+
+ is_single_dataset = is_single_dataset_value
+ |
+
+
+ | 225 |
+ |
+
+ ),
+ |
+
+
+ | 226 |
+ ! |
+
+ checkboxInput(
+ |
+
+
+ | 227 |
+ ! |
+
+ ns("association"),
+ |
+
+
+ | 228 |
+ ! |
+
+ "Association with reference variable",
+ |
+
+
+ | 229 |
+ ! |
+
+ value = args$show_association
+ |
+
+
+ | 230 |
+ |
+
+ ),
+ |
+
+
+ | 231 |
+ ! |
+
+ checkboxInput(
+ |
+
+
+ | 232 |
+ ! |
+
+ ns("show_dist"),
+ |
+
+
+ | 233 |
+ ! |
+
+ "Scaled frequencies",
+ |
+
+
+ | 234 |
+ ! |
+
+ value = FALSE
+ |
+
+
+ | 235 |
+ |
+
+ ),
+ |
+
+
+ | 236 |
+ ! |
+
+ checkboxInput(
+ |
+
+
| 237 |
- 2x |
+ ! |
- if (is.null(fill)) {
+ ns("log_transformation"),
|
-
+
| 238 |
- 2x |
+ ! |
- fill <- x
+ "Log transformed",
|
-
+
| 239 |
- 2x |
+ ! |
- fill[[1]]$select <- teal.transform::select_spec(choices = fill[[1]]$select$choices, selected = NULL)
+ value = FALSE
|
| 240 |
|
- }
+ ),
|
-
+
| 241 |
- 2x |
+ ! |
- if (is.null(size)) {
+ teal.widgets::panel_group(
|
-
+
| 242 |
- 2x |
+ ! |
- size <- x
+ teal.widgets::panel_item(
|
-
+
| 243 |
- 2x |
+ ! |
- size[[1]]$select <- teal.transform::select_spec(choices = size[[1]]$select$choices, selected = NULL)
+ title = "Plot settings",
|
-
+
| 244 |
- |
+ ! |
- }
+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Scatterplot opacity:", c(0.5, 0, 1), ticks = FALSE),
|
-
+
| 245 |
- |
+ ! |
- } else {
+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Scatterplot points size:", c(2, 1, 8), ticks = FALSE),
|
-
+
| 246 |
- 12x |
+ ! |
- if (!is.null(c(color, fill, size))) {
+ checkboxInput(ns("swap_axes"), "Swap axes", value = FALSE),
|
-
+
| 247 |
- 3x |
+ ! |
- stop("'color_settings' argument needs to be set to TRUE if 'color', 'fill', and/or 'size' is/are supplied.")
+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = FALSE),
|
-
+
| 248 |
- |
+ ! |
- }
+ selectInput(
|
-
+
| 249 |
- |
+ ! |
- }
+ inputId = ns("distribution_theme"),
|
-
+
| 250 |
- |
+ ! |
-
+ label = "Distribution theme (by ggplot):",
|
-
+
| 251 |
- 11x |
+ ! |
- checkmate::assert_flag(free_x_scales)
+ choices = ggplot_themes,
|
-
+
| 252 |
- 11x |
+ ! |
- checkmate::assert_flag(free_y_scales)
+ selected = args$distribution_theme,
|
-
+
| 253 |
- |
+ ! |
-
+ multiple = FALSE
|
-
+
| 254 |
- 11x |
+ |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
+ ),
|
-
+
| 255 |
- 10x |
+ ! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
+ selectInput(
|
-
+
| 256 |
- 8x |
+ ! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
+ inputId = ns("association_theme"),
|
-
+
| 257 |
- 7x |
+ ! |
- checkmate::assert_numeric(
+ label = "Association theme (by ggplot):",
|
-
+
| 258 |
- 7x |
+ ! |
- plot_width[1],
+ choices = ggplot_themes,
|
-
+
| 259 |
- 7x |
+ ! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
+ selected = args$association_theme,
|
-
+
| 260 |
- |
+ ! |
- )
+ multiple = FALSE
|
| 261 |
|
-
+ )
|
-
+
| 262 |
- 5x |
+ |
- checkmate::assert_flag(rotate_xaxis_labels)
+ )
|
-
+
| 263 |
- 5x |
+ |
- checkmate::assert_flag(swap_axes)
+ )
|
| 264 |
|
-
+ ),
|
-
+
| 265 |
- 5x |
+ ! |
- ggtheme <- match.arg(ggtheme)
+ forms = tagList(
|
-
+
| 266 |
- 5x |
+ ! |
- checkmate::assert_class(ggplot2_args, "ggplot2_args")
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
| 267 |
|
-
+ ),
|
-
+
| 268 |
- 5x |
+ ! |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ pre_output = args$pre_output,
|
-
+
| 269 |
- 5x |
+ ! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ post_output = args$post_output
|
| 270 |
|
- # End of assertions
+ )
|
| 271 |
|
-
+ }
|
| 272 |
|
- # Make UI args
+
|
-
+
| 273 |
- 5x |
+ |
- args <- as.list(environment())
+ # Server function for the association module
|
| 274 |
|
-
+ srv_tm_g_association <- function(id,
|
-
+
| 275 |
- 5x |
+ |
- data_extract_list <- list(
+ data,
|
-
+
| 276 |
- 5x |
+ |
- x = x,
+ reporter,
|
-
+
| 277 |
- 5x |
+ |
- y = y,
+ filter_panel_api,
|
-
+
| 278 |
- 5x |
+ |
- row_facet = row_facet,
+ ref,
|
-
+
| 279 |
- 5x |
+ |
- col_facet = col_facet,
+ vars,
|
-
+
| 280 |
- 5x |
+ |
- color_settings = color_settings,
+ plot_height,
|
-
+
| 281 |
- 5x |
+ |
- color = color,
+ plot_width,
|
-
+
| 282 |
- 5x |
+ |
- fill = fill,
+ ggplot2_args) {
|
-
+
| 283 |
- 5x |
+ ! |
- size = size
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
|
-
+
| 284 |
- |
+ ! |
- )
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
|
-
+
| 285 |
- |
+ ! |
-
+ checkmate::assert_class(data, "reactive")
|
-
+
| 286 |
- 5x |
+ ! |
- ans <- module(
+ checkmate::assert_class(isolate(data()), "teal_data")
|
-
+
| 287 |
- 5x |
+ |
- label = label,
+
|
-
+
| 288 |
- 5x |
+ ! |
- server = srv_g_bivariate,
+ moduleServer(id, function(input, output, session) {
|
-
+
| 289 |
- 5x |
+ ! |
- ui = ui_g_bivariate,
+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
|
-
+
| 290 |
- 5x |
+ |
- ui_args = args,
+
|
-
+
| 291 |
- 5x |
+ ! |
- server_args = c(
+ selector_list <- teal.transform::data_extract_multiple_srv(
|
-
+
| 292 |
- 5x |
+ ! |
- data_extract_list,
+ data_extract = list(ref = ref, vars = vars),
|
-
+
| 293 |
- 5x |
+ ! |
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)
+ datasets = data,
|
-
+
| 294 |
- |
+ ! |
- ),
+ select_validation_rule = list(
|
-
+
| 295 |
- 5x |
+ ! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)
+ ref = shinyvalidate::compose_rules(
|
-
+
| 296 |
- |
+ ! |
- )
+ shinyvalidate::sv_required("A reference variable needs to be selected."),
|
-
+
| 297 |
- 5x |
+ ! |
- attr(ans, "teal_bookmarkable") <- TRUE
+ ~ if ((.) %in% selector_list()$vars()$select) {
|
-
+
| 298 |
- 5x |
+ ! |
- ans
+ "Associated variables and reference variable cannot overlap"
|
| 299 |
|
- }
+ }
|
| 300 |
|
-
+ ),
|
-
+
| 301 |
- |
+ ! |
- # UI function for the bivariate module
+ vars = shinyvalidate::compose_rules(
|
-
+
| 302 |
- |
+ ! |
- ui_g_bivariate <- function(id, ...) {
+ shinyvalidate::sv_required("An associated variable needs to be selected."),
|
| 303 |
! |
- args <- list(...)
+ ~ if (length(selector_list()$ref()$select) != 0 && selector_list()$ref()$select %in% (.)) {
|
| 304 |
! |
- is_single_dataset_value <- teal.transform::is_single_dataset(
+ "Associated variables and reference variable cannot overlap"
|
-
+
| 305 |
- ! |
+ |
- args$x, args$y, args$row_facet, args$col_facet, args$color, args$fill, args$size
+ }
|
| 306 |
|
- )
+ )
|
| 307 |
|
-
+ )
|
-
+
| 308 |
- ! |
+ |
- ns <- NS(id)
+ )
|
-
+
| 309 |
- ! |
+ |
- teal.widgets::standard_layout(
+
|
| 310 |
! |
- output = teal.widgets::white_small_well(
+ iv_r <- reactive({
|
| 311 |
! |
- tags$div(teal.widgets::plot_with_settings_ui(id = ns("myplot")))
+ iv <- shinyvalidate::InputValidator$new()
|
-
+
| 312 |
- |
+ ! |
- ),
+ teal.transform::compose_and_enable_validators(iv, selector_list)
|
-
+
| 313 |
- ! |
+ |
- encoding = tags$div(
+ })
|
| 314 |
|
- ### Reporter
+
|
| 315 |
! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ anl_merged_input <- teal.transform::merge_expression_srv(
|
-
+
| 316 |
- |
+ ! |
- ###
+ datasets = data,
|
| 317 |
! |
- tags$label("Encodings", class = "text-primary"),
+ selector_list = selector_list
|
-
+
| 318 |
- ! |
+ |
- teal.transform::datanames_input(args[c("x", "y", "row_facet", "col_facet", "color", "fill", "size")]),
+ )
|
-
+
| 319 |
- ! |
+ |
- teal.transform::data_extract_ui(
+
|
| 320 |
! |
- id = ns("x"),
+ anl_merged_q <- reactive({
|
| 321 |
! |
- label = "X variable",
+ req(anl_merged_input())
|
| 322 |
! |
- data_extract_spec = args$x,
+ data() %>% teal.code::eval_code(as.expression(anl_merged_input()$expr))
|
-
+
| 323 |
- ! |
+ |
- is_single_dataset = is_single_dataset_value
+ })
|
| 324 |
|
- ),
+
|
| 325 |
! |
- teal.transform::data_extract_ui(
+ merged <- list(
|
| 326 |
! |
- id = ns("y"),
+ anl_input_r = anl_merged_input,
|
| 327 |
! |
- label = "Y variable",
+ anl_q_r = anl_merged_q
|
-
+
| 328 |
- ! |
+ |
- data_extract_spec = args$y,
+ )
|
-
+
| 329 |
- ! |
+ |
- is_single_dataset = is_single_dataset_value
+
|
-
+
| 330 |
- |
+ ! |
- ),
+ output_q <- reactive({
|
| 331 |
! |
- conditionalPanel(
+ teal::validate_inputs(iv_r())
|
-
+
| 332 |
- ! |
+ |
- condition =
+
|
| 333 |
! |
- "$(\"button[data-id*='-x-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ||
+ ANL <- merged$anl_q_r()[["ANL"]]
|
| 334 |
! |
- $(\"button[data-id*='-y-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ",
+ teal::validate_has_data(ANL, 3)
|
-
+
| 335 |
- ! |
+ |
- shinyWidgets::radioGroupButtons(
+
|
| 336 |
! |
- inputId = ns("use_density"),
+ vars_names <- merged$anl_input_r()$columns_source$vars
|
-
+
| 337 |
- ! |
+ |
- label = NULL,
+
|
| 338 |
! |
- choices = c("frequency", "density"),
+ ref_name <- as.vector(merged$anl_input_r()$columns_source$ref)
|
| 339 |
! |
- selected = ifelse(args$use_density, "density", "frequency"),
+ association <- input$association
|
| 340 |
! |
- justified = TRUE
+ show_dist <- input$show_dist
|
-
+
| 341 |
- |
+ ! |
- )
+ log_transformation <- input$log_transformation
|
-
+
| 342 |
- |
+ ! |
- ),
+ rotate_xaxis_labels <- input$rotate_xaxis_labels
|
| 343 |
! |
- if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
+ swap_axes <- input$swap_axes
|
| 344 |
! |
- tags$div(
+ distribution_theme <- input$distribution_theme
|
| 345 |
! |
- class = "data-extract-box",
+ association_theme <- input$association_theme
|
-
+
| 346 |
- ! |
+ |
- tags$label("Facetting"),
+
|
| 347 |
! |
- shinyWidgets::switchInput(inputId = ns("facetting"), value = args$facet, size = "mini"),
+ is_scatterplot <- is.numeric(ANL[[ref_name]]) && any(vapply(ANL[vars_names], is.numeric, logical(1)))
|
| 348 |
! |
- conditionalPanel(
+ if (is_scatterplot) {
|
| 349 |
! |
- condition = paste0("input['", ns("facetting"), "']"),
+ shinyjs::show("alpha")
|
| 350 |
! |
- tags$div(
+ shinyjs::show("size")
|
| 351 |
! |
- if (!is.null(args$row_facet)) {
+ alpha <- input$alpha
|
| 352 |
! |
- teal.transform::data_extract_ui(
+ size <- input$size
|
-
+
| 353 |
- ! |
+ |
- id = ns("row_facet"),
+ } else {
|
| 354 |
! |
- label = "Row facetting variable",
+ shinyjs::hide("alpha")
|
| 355 |
! |
- data_extract_spec = args$row_facet,
+ shinyjs::hide("size")
|
| 356 |
! |
- is_single_dataset = is_single_dataset_value
+ alpha <- 0.5
|
-
+
| 357 |
- |
+ ! |
- )
+ size <- 2
|
| 358 |
|
- },
+ }
|
-
+
| 359 |
- ! |
+ |
- if (!is.null(args$col_facet)) {
+
|
| 360 |
! |
- teal.transform::data_extract_ui(
+ teal::validate_has_data(ANL[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE)
|
-
+
| 361 |
- ! |
+ |
- id = ns("col_facet"),
+
|
-
+
| 362 |
- ! |
+ |
- label = "Column facetting variable",
+ # reference
|
| 363 |
! |
- data_extract_spec = args$col_facet,
+ ref_class <- class(ANL[[ref_name]])[1]
|
| 364 |
! |
- is_single_dataset = is_single_dataset_value
+ if (is.numeric(ANL[[ref_name]]) && log_transformation) {
|
| 365 |
|
- )
+ # works for both integers and doubles
|
-
+
| 366 |
- |
+ ! |
- },
+ ref_cl_name <- call("log", as.name(ref_name))
|
| 367 |
! |
- checkboxInput(ns("free_x_scales"), "free x scales", value = args$free_x_scales),
+ ref_cl_lbl <- varname_w_label(ref_name, ANL, prefix = "Log of ")
|
-
+
| 368 |
- ! |
+ |
- checkboxInput(ns("free_y_scales"), "free y scales", value = args$free_y_scales)
+ } else {
|
| 369 |
|
- )
+ # silently ignore when non-numeric even if `log` is selected because some
|
| 370 |
|
- )
+ # variables may be numeric and others not
|
-
+
| 371 |
- |
+ ! |
- )
+ ref_cl_name <- as.name(ref_name)
|
-
+
| 372 |
- |
+ ! |
- },
+ ref_cl_lbl <- varname_w_label(ref_name, ANL)
|
-
+
| 373 |
- ! |
+ |
- if (args$color_settings) {
+ }
|
| 374 |
|
- # Put a grey border around the coloring settings
+
|
| 375 |
! |
- tags$div(
+ user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
|
| 376 |
! |
- class = "data-extract-box",
+ user_plot = ggplot2_args[["Bivariate1"]],
|
| 377 |
! |
- tags$label("Color settings"),
+ user_default = ggplot2_args$default
|
-
+
| 378 |
- ! |
+ |
- shinyWidgets::switchInput(inputId = ns("coloring"), value = TRUE, size = "mini"),
+ )
|
-
+
| 379 |
- ! |
+ |
- conditionalPanel(
+
|
| 380 |
! |
- condition = paste0("input['", ns("coloring"), "']"),
+ ref_call <- bivariate_plot_call(
|
| 381 |
! |
- tags$div(
+ data_name = "ANL",
|
| 382 |
! |
- teal.transform::data_extract_ui(
+ x = ref_cl_name,
|
| 383 |
! |
- id = ns("color"),
+ x_class = ref_class,
|
| 384 |
! |
- label = "Outline color by variable",
+ x_label = ref_cl_lbl,
|
| 385 |
! |
- data_extract_spec = args$color,
+ freq = !show_dist,
|
| 386 |
! |
- is_single_dataset = is_single_dataset_value
+ theme = distribution_theme,
|
-
+
| 387 |
- |
+ ! |
- ),
+ rotate_xaxis_labels = rotate_xaxis_labels,
|
| 388 |
! |
- teal.transform::data_extract_ui(
+ swap_axes = FALSE,
|
| 389 |
! |
- id = ns("fill"),
+ size = size,
|
| 390 |
! |
- label = "Fill color by variable",
+ alpha = alpha,
|
| 391 |
! |
- data_extract_spec = args$fill,
+ ggplot2_args = user_ggplot2_args
|
-
+
| 392 |
- ! |
+ |
- is_single_dataset = is_single_dataset_value
+ )
|
| 393 |
|
- ),
+
|
-
+
| 394 |
- ! |
+ |
- tags$div(
+ # association
|
| 395 |
! |
- id = ns("size_settings"),
+ ref_class_cov <- ifelse(association, ref_class, "NULL")
|
-
+
| 396 |
- ! |
+ |
- teal.transform::data_extract_ui(
+
|
| 397 |
! |
- id = ns("size"),
+ print_call <- quote(print(p))
|
-
+
| 398 |
- ! |
+ |
- label = "Size of points by variable (only if x and y are numeric)",
+
|
| 399 |
! |
- data_extract_spec = args$size,
+ var_calls <- lapply(vars_names, function(var_i) {
|
| 400 |
! |
- is_single_dataset = is_single_dataset_value
+ var_class <- class(ANL[[var_i]])[1]
|
-
+
| 401 |
- |
+ ! |
- )
+ if (is.numeric(ANL[[var_i]]) && log_transformation) {
|
| 402 |
|
- )
+ # works for both integers and doubles
|
-
+
| 403 |
- |
+ ! |
- )
+ var_cl_name <- call("log", as.name(var_i))
|
-
+
| 404 |
- |
+ ! |
- )
+ var_cl_lbl <- varname_w_label(var_i, ANL, prefix = "Log of ")
|
| 405 |
|
- )
+ } else {
|
| 406 |
|
- },
+ # silently ignore when non-numeric even if `log` is selected because some
|
-
+
| 407 |
- ! |
+ |
- teal.widgets::panel_group(
+ # variables may be numeric and others not
|
| 408 |
! |
- teal.widgets::panel_item(
+ var_cl_name <- as.name(var_i)
|
| 409 |
! |
- title = "Plot settings",
+ var_cl_lbl <- varname_w_label(var_i, ANL)
|
-
+
| 410 |
- ! |
+ |
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
+ }
|
-
+
| 411 |
- ! |
+ |
- checkboxInput(ns("swap_axes"), "Swap axes", value = args$swap_axes),
+
|
| 412 |
! |
- selectInput(
+ user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
|
| 413 |
! |
- inputId = ns("ggtheme"),
+ user_plot = ggplot2_args[["Bivariate2"]],
|
| 414 |
! |
- label = "Theme (by ggplot):",
+ user_default = ggplot2_args$default
|
-
+
| 415 |
+ |
+
+ )
+ |
+
+
+ | 416 |
+ |
+
+
+ |
+
+
+ | 417 |
! |
- choices = ggplot_themes,
+ bivariate_plot_call(
|
- | 416 |
+ 418 |
! |
- selected = args$ggtheme,
+ data_name = "ANL",
|
- | 417 |
+ 419 |
! |
- multiple = FALSE
+ x = ref_cl_name,
+ |
+
+
+ | 420 |
+ ! |
+
+ y = var_cl_name,
+ |
+
+
+ | 421 |
+ ! |
+
+ x_class = ref_class_cov,
+ |
+
+
+ | 422 |
+ ! |
+
+ y_class = var_class,
+ |
+
+
+ | 423 |
+ ! |
+
+ x_label = ref_cl_lbl,
+ |
+
+
+ | 424 |
+ ! |
+
+ y_label = var_cl_lbl,
+ |
+
+
+ | 425 |
+ ! |
+
+ theme = association_theme,
+ |
+
+
+ | 426 |
+ ! |
+
+ freq = !show_dist,
+ |
+
+
+ | 427 |
+ ! |
+
+ rotate_xaxis_labels = rotate_xaxis_labels,
+ |
+
+
+ | 428 |
+ ! |
+
+ swap_axes = swap_axes,
+ |
+
+
+ | 429 |
+ ! |
+
+ alpha = alpha,
+ |
+
+
+ | 430 |
+ ! |
+
+ size = size,
+ |
+
+
+ | 431 |
+ ! |
+
+ ggplot2_args = user_ggplot2_args
|
- | 418 |
+ 432 |
|
- ),
+ )
+ |
+
+
+ | 433 |
+ |
+
+ })
+ |
+
+
+ | 434 |
+ |
+
+
+ |
+
+
+ | 435 |
+ |
+
+ # helper function to format variable name
|
- | 419 |
+ 436 |
+ ! |
+
+ format_varnames <- function(x) {
+ |
+
+
+ | 437 |
+ ! |
+
+ if (is.numeric(ANL[[x]]) && log_transformation) {
+ |
+
+
+ | 438 |
+ ! |
+
+ varname_w_label(x, ANL, prefix = "Log of ")
+ |
+
+
+ | 439 |
+ |
+
+ } else {
+ |
+
+
+ | 440 |
+ ! |
+
+ varname_w_label(x, ANL)
+ |
+
+
+ | 441 |
+ |
+
+ }
+ |
+
+
+ | 442 |
+ |
+
+ }
+ |
+
+
+ | 443 |
+ ! |
+
+ new_title <-
+ |
+
+
+ | 444 |
+ ! |
+
+ if (association) {
+ |
+
+
+ | 445 |
+ ! |
+
+ switch(as.character(length(vars_names)),
+ |
+
+
+ | 446 |
+ ! |
+
+ "0" = sprintf("Value distribution for %s", ref_cl_lbl),
+ |
+
+
+ | 447 |
! |
- sliderInput(
+ "1" = sprintf(
|
- | 420 |
+ 448 |
! |
- ns("alpha"), "Opacity Scatterplot:",
+ "Association between %s and %s",
|
- | 421 |
+ 449 |
! |
- min = 0, max = 1,
+ ref_cl_lbl,
|
- | 422 |
+ 450 |
! |
- step = .05, value = .5, ticks = FALSE
+ format_varnames(vars_names)
|
- | 423 |
+ 451 |
|
- ),
+ ),
|
- | 424 |
+ 452 |
! |
- sliderInput(
+ sprintf(
|
- | 425 |
+ 453 |
! |
- ns("fixed_size"), "Scatterplot point size:",
+ "Associations between %s and: %s",
|
- | 426 |
+ 454 |
! |
- min = 1, max = 8,
+ ref_cl_lbl,
|
- | 427 |
+ 455 |
! |
- step = 1, value = 2, ticks = FALSE
+ paste(lapply(vars_names, format_varnames), collapse = ", ")
|
- | 428 |
+ 456 |
|
- ),
- |
-
-
- | 429 |
- ! |
-
- checkboxInput(ns("add_lines"), "Add lines"),
+ )
|
- | 430 |
+ 457 |
|
- )
+ )
|
- | 431 |
+ 458 |
|
- )
+ } else {
|
-
- | 432 |
- |
+
+ | 459 |
+ ! |
- ),
+ switch(as.character(length(vars_names)),
|
- | 433 |
+ 460 |
! |
- forms = tagList(
+ "0" = sprintf("Value distribution for %s", ref_cl_lbl),
|
- | 434 |
+ 461 |
! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ sprintf(
|
-
- | 435 |
- |
+
+ | 462 |
+ ! |
- ),
+ "Value distributions for %s and %s",
|
- | 436 |
+ 463 |
! |
- pre_output = args$pre_output,
+ ref_cl_lbl,
|
- | 437 |
+ 464 |
! |
- post_output = args$post_output
+ paste(lapply(vars_names, format_varnames), collapse = ", ")
|
- | 438 |
+ 465 |
|
- )
+ )
|
- | 439 |
+ 466 |
|
- }
+ )
|
- | 440 |
+ 467 |
|
-
+ }
|
- | 441 |
+ 468 |
|
- # Server function for the bivariate module
+
|
-
- | 442 |
- |
+
+ | 469 |
+ ! |
- srv_g_bivariate <- function(id,
+ teal.code::eval_code(
|
-
- | 443 |
- |
+
+ | 470 |
+ ! |
- data,
+ merged$anl_q_r(),
|
-
- | 444 |
- |
+
+ | 471 |
+ ! |
- reporter,
+ substitute(
|
-
- | 445 |
- |
+
+ | 472 |
+ ! |
- filter_panel_api,
+ expr = title <- new_title,
|
-
- | 446 |
- |
+
+ | 473 |
+ ! |
- x,
+ env = list(new_title = new_title)
|
- | 447 |
+ 474 |
|
- y,
+ )
|
- | 448 |
+ 475 |
|
- row_facet,
+ ) %>%
|
-
- | 449 |
- |
+
+ | 476 |
+ ! |
- col_facet,
+ teal.code::eval_code(
|
-
- | 450 |
- |
+
+ | 477 |
+ ! |
- color_settings = FALSE,
+ substitute(
|
-
- | 451 |
- |
+
+ | 478 |
+ ! |
- color,
+ expr = {
|
-
- | 452 |
- |
+
+ | 479 |
+ ! |
- fill,
+ plots <- plot_calls
|
-
- | 453 |
- |
+
+ | 480 |
+ ! |
- size,
+ p <- tern::stack_grobs(grobs = lapply(plots, ggplotGrob))
|
-
- | 454 |
- |
+
+ | 481 |
+ ! |
- plot_height,
+ grid::grid.newpage()
|
-
- | 455 |
- |
+
+ | 482 |
+ ! |
- plot_width,
+ grid::grid.draw(p)
|
- | 456 |
+ 483 |
|
- ggplot2_args) {
+ },
|
- | 457 |
+ 484 |
! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
+ env = list(
|
- | 458 |
+ 485 |
! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
+ plot_calls = do.call(
|
- | 459 |
+ 486 |
! |
- checkmate::assert_class(data, "reactive")
+ "call",
|
- | 460 |
+ 487 |
! |
- checkmate::assert_class(isolate(data()), "teal_data")
+ c(list("list", ref_call), var_calls),
|
- | 461 |
+ 488 |
! |
- moduleServer(id, function(input, output, session) {
+ quote = TRUE
|
-
- | 462 |
- ! |
+
+ | 489 |
+ |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
+ )
|
- | 463 |
+ 490 |
|
-
+ )
|
-
- | 464 |
- ! |
+
+ | 491 |
+ |
- ns <- session$ns
+ )
|
- | 465 |
+ 492 |
+ |
+
+ )
+ |
+
+
+ | 493 |
+ |
+
+ })
+ |
+
+
+ | 494 |
|
|
- | 466 |
+ 495 |
! |
- data_extract <- list(
+ plot_r <- reactive({
|
- | 467 |
+ 496 |
! |
- x = x, y = y, row_facet = row_facet, col_facet = col_facet,
+ req(iv_r()$is_valid())
|
- | 468 |
+ 497 |
! |
- color = color, fill = fill, size = size
+ output_q()[["p"]]
|
- | 469 |
+ 498 |
|
- )
+ })
|
- | 470 |
+ 499 |
|
|
- | 471 |
+ 500 |
! |
- rule_var <- function(other) {
+ pws <- teal.widgets::plot_with_settings_srv(
|
- | 472 |
+ 501 |
! |
- function(value) {
+ id = "myplot",
|
- | 473 |
+ 502 |
! |
- othervalue <- selector_list()[[other]]()$select
+ plot_r = plot_r,
|
- | 474 |
+ 503 |
! |
- if (length(value) == 0L && length(othervalue) == 0L) {
+ height = plot_height,
|
- | 475 |
+ 504 |
! |
- "Please select at least one of x-variable or y-variable"
+ width = plot_width
|
- | 476 |
+ 505 |
|
- }
+ )
|
- | 477 |
+ 506 |
|
- }
+
|
-
- | 478 |
- |
+
+ | 507 |
+ ! |
- }
+ output$title <- renderText({
|
- | 479 |
+ 508 |
! |
- rule_diff <- function(other) {
+ teal.code::dev_suppress(output_q()[["title"]])
|
-
- | 480 |
- ! |
+
+ | 509 |
+ |
- function(value) {
+ })
+ |
+
+
+ | 510 |
+ |
+
+
|
- | 481 |
+ 511 |
! |
- othervalue <- selector_list()[[other]]()[["select"]]
+ teal.widgets::verbatim_popup_srv(
|
- | 482 |
+ 512 |
! |
- if (!is.null(othervalue)) {
+ id = "rcode",
|
- | 483 |
+ 513 |
! |
- if (identical(value, othervalue)) {
+ verbatim_content = reactive(teal.code::get_code(output_q())),
|
- | 484 |
+ 514 |
! |
- "Row and column facetting variables must be different."
+ title = "Association Plot"
|
- | 485 |
+ 515 |
|
- }
+ )
|
- | 486 |
+ 516 |
|
- }
+
|
- | 487 |
+ 517 |
|
- }
+ ### REPORTER
|
-
- | 488 |
- |
+
+ | 518 |
+ ! |
- }
+ if (with_reporter) {
|
-
- | 489 |
- |
+
+ | 519 |
+ ! |
-
+ card_fun <- function(comment, label) {
|
- | 490 |
+ 520 |
! |
- selector_list <- teal.transform::data_extract_multiple_srv(
+ card <- teal::report_card_template(
|
- | 491 |
+ 521 |
! |
- data_extract = data_extract,
+ title = "Association Plot",
|
- | 492 |
+ 522 |
! |
- datasets = data,
+ label = label,
|
- | 493 |
+ 523 |
! |
- select_validation_rule = list(
+ with_filter = with_filter,
|
- | 494 |
+ 524 |
! |
- x = rule_var("y"),
+ filter_panel_api = filter_panel_api
+ |
+
+
+ | 525 |
+ |
+
+ )
|
- | 495 |
+ 526 |
! |
- y = rule_var("x"),
+ card$append_text("Plot", "header3")
|
- | 496 |
+ 527 |
! |
- row_facet = shinyvalidate::compose_rules(
+ card$append_plot(plot_r(), dim = pws$dim())
|
- | 497 |
+ 528 |
! |
- shinyvalidate::sv_optional(),
+ if (!comment == "") {
|
- | 498 |
+ 529 |
! |
- rule_diff("col_facet")
+ card$append_text("Comment", "header3")
+ |
+
+
+ | 530 |
+ ! |
+
+ card$append_text(comment)
|
- | 499 |
+ 531 |
|
- ),
+ }
|
- | 500 |
+ 532 |
! |
- col_facet = shinyvalidate::compose_rules(
+ card$append_src(teal.code::get_code(output_q()))
|
- | 501 |
+ 533 |
! |
- shinyvalidate::sv_optional(),
+ card
+ |
+
+
+ | 534 |
+ |
+
+ }
|
- | 502 |
+ 535 |
! |
- rule_diff("row_facet")
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
- | 503 |
+ 536 |
|
- )
+ }
|
- | 504 |
+ 537 |
|
- )
+ ###
|
- | 505 |
+ 538 |
|
- )
+ })
|
- | 506 |
+ 539 |
|
-
+ }
|
-
- | 507 |
- ! |
+
+
+
+
+
+
+
+ | 1 |
+ |
- iv_r <- reactive({
+ #' `teal` module: Scatterplot matrix
|
-
- | 508 |
- ! |
+
+ | 2 |
+ |
- iv_facet <- shinyvalidate::InputValidator$new()
+ #'
|
-
- | 509 |
- ! |
+
+ | 3 |
+ |
- iv_child <- teal.transform::compose_and_enable_validators(iv_facet, selector_list,
+ #' Generates a scatterplot matrix from selected `variables` from datasets.
|
-
- | 510 |
- ! |
+
+ | 4 |
+ |
+
+ #' Each plot within the matrix represents the relationship between two variables,
+ |
+
+
+ | 5 |
+ |
- validator_names = c("row_facet", "col_facet")
+ #' providing the overview of correlations and distributions across selected data.
|
- | 511 |
+ 6 |
|
- )
+ #'
|
-
- | 512 |
- ! |
+
+ | 7 |
+ |
- iv_child$condition(~ isTRUE(input$facetting))
+ #' @note For more examples, please see the vignette "Using scatterplot matrix" via
|
- | 513 |
+ 8 |
|
-
+ #' `vignette("using-scatterplot-matrix", package = "teal.modules.general")`.
|
-
- | 514 |
- ! |
+
+ | 9 |
+ |
- iv <- shinyvalidate::InputValidator$new()
+ #'
|
-
- | 515 |
- ! |
+
+ | 10 |
+ |
- iv$add_validator(iv_child)
+ #' @inheritParams teal::module
|
-
- | 516 |
- ! |
+
+ | 11 |
+ |
- teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = c("x", "y"))
+ #' @inheritParams tm_g_scatterplot
|
- | 517 |
+ 12 |
|
- })
+ #' @inheritParams shared_params
|
- | 518 |
+ 13 |
|
-
+ #'
|
-
- | 519 |
- ! |
+
+ | 14 |
+ |
- anl_merged_input <- teal.transform::merge_expression_srv(
+ #' @param variables (`data_extract_spec` or `list` of multiple `data_extract_spec`)
|
-
- | 520 |
- ! |
+
+ | 15 |
+ |
- selector_list = selector_list,
+ #' Specifies plotting variables from an incoming dataset with filtering and selecting. In case of
|
-
- | 521 |
- ! |
+
+ | 16 |
+ |
- datasets = data
+ #' `data_extract_spec` use `select_spec(..., ordered = TRUE)` if plot elements should be
|
- | 522 |
+ 17 |
|
- )
+ #' rendered according to selection order.
|
- | 523 |
+ 18 |
|
-
+ #'
|
-
- | 524 |
- ! |
+
+ | 19 |
+ |
- anl_merged_q <- reactive({
+ #' @inherit shared_params return
|
-
- | 525 |
- ! |
+
+ | 20 |
+ |
- req(anl_merged_input())
+ #'
|
-
- | 526 |
- ! |
+
+ | 21 |
+ |
- data() %>%
+ #' @examplesShinylive
|
-
- | 527 |
- ! |
+
+ | 22 |
+ |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))
+ #' library(teal.modules.general)
|
- | 528 |
+ 23 |
|
- })
+ #' interactive <- function() TRUE
|
- | 529 |
+ 24 |
|
-
+ #' {{ next_example }}
|
-
- | 530 |
- ! |
+
+ | 25 |
+ |
- merged <- list(
+ #' @examplesIf require("lattice", quietly = TRUE)
|
-
- | 531 |
- ! |
+
+ | 26 |
+ |
- anl_input_r = anl_merged_input,
+ #' # general data example
|
-
- | 532 |
- ! |
+
+ | 27 |
+ |
- anl_q_r = anl_merged_q
+ #' data <- teal_data()
|
- | 533 |
+ 28 |
|
- )
+ #' data <- within(data, {
|
- | 534 |
+ 29 |
|
-
+ #' countries <- data.frame(
|
-
- | 535 |
- ! |
+
+ | 30 |
+ |
- output_q <- reactive({
+ #' id = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
|
-
- | 536 |
- ! |
+
+ | 31 |
+ |
- teal::validate_inputs(iv_r())
+ #' government = factor(
|
- | 537 |
+ 32 |
|
-
+ #' c(2, 2, 2, 1, 2, 2, 1, 1, 1, 2),
|
-
- | 538 |
- ! |
+
+ | 33 |
+ |
- ANL <- merged$anl_q_r()[["ANL"]]
+ #' labels = c("Monarchy", "Republic")
|
-
- | 539 |
- ! |
+
+ | 34 |
+ |
- teal::validate_has_data(ANL, 3)
+ #' ),
|
- | 540 |
+ 35 |
|
-
+ #' language_family = factor(
|
-
- | 541 |
- ! |
+
+ | 36 |
+ |
- x_col_vec <- as.vector(merged$anl_input_r()$columns_source$x)
+ #' c(1, 3, 3, 3, 3, 2, 1, 1, 3, 1),
|
-
- | 542 |
- ! |
+
+ | 37 |
+ |
- x_name <- `if`(is.null(x_col_vec), character(0), x_col_vec)
+ #' labels = c("Germanic", "Hellenic", "Romance")
|
-
- | 543 |
- ! |
+
+ | 38 |
+ |
- y_col_vec <- as.vector(merged$anl_input_r()$columns_source$y)
+ #' ),
|
-
- | 544 |
- ! |
+
+ | 39 |
+ |
- y_name <- `if`(is.null(y_col_vec), character(0), y_col_vec)
+ #' population = c(83, 67, 60, 47, 10, 11, 17, 11, 0.6, 9),
|
- | 545 |
+ 40 |
|
-
+ #' area = c(357, 551, 301, 505, 92, 132, 41, 30, 2.6, 83),
|
-
- | 546 |
- ! |
+
+ | 41 |
+ |
- row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet)
+ #' gdp = c(3.4, 2.7, 2.1, 1.4, 0.3, 0.2, 0.7, 0.5, 0.1, 0.4),
|
-
- | 547 |
- ! |
+
+ | 42 |
+ |
- col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet)
+ #' debt = c(2.1, 2.3, 2.4, 2.6, 2.3, 2.4, 2.3, 2.4, 2.3, 2.4)
|
-
- | 548 |
- ! |
+
+ | 43 |
+ |
- color_name <- if ("color" %in% names(merged$anl_input_r()$columns_source)) {
+ #' )
|
-
- | 549 |
- ! |
+
+ | 44 |
+ |
- as.vector(merged$anl_input_r()$columns_source$color)
+ #' sales <- data.frame(
|
- | 550 |
+ 45 |
|
- } else {
+ #' id = 1:50,
|
-
- | 551 |
- ! |
+
+ | 46 |
+ |
- character(0)
+ #' country_id = sample(
|
- | 552 |
+ 47 |
|
- }
+ #' c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
|
-
- | 553 |
- ! |
+
+ | 48 |
+ |
- fill_name <- if ("fill" %in% names(merged$anl_input_r()$columns_source)) {
+ #' size = 50,
|
-
- | 554 |
- ! |
+
+ | 49 |
+ |
- as.vector(merged$anl_input_r()$columns_source$fill)
+ #' replace = TRUE
|
- | 555 |
+ 50 |
|
- } else {
+ #' ),
|
-
- | 556 |
- ! |
+
+ | 51 |
+ |
- character(0)
+ #' year = sort(sample(2010:2020, 50, replace = TRUE)),
|
- | 557 |
+ 52 |
|
- }
+ #' venue = sample(c("small", "medium", "large", "online"), 50, replace = TRUE),
|
-
- | 558 |
- ! |
+
+ | 53 |
+ |
- size_name <- if ("size" %in% names(merged$anl_input_r()$columns_source)) {
+ #' cancelled = sample(c(TRUE, FALSE), 50, replace = TRUE),
|
-
- | 559 |
- ! |
+
+ | 54 |
+ |
- as.vector(merged$anl_input_r()$columns_source$size)
+ #' quantity = rnorm(50, 100, 20),
|
- | 560 |
+ 55 |
|
- } else {
+ #' costs = rnorm(50, 80, 20),
|
-
- | 561 |
- ! |
+
+ | 56 |
+ |
- character(0)
+ #' profit = rnorm(50, 20, 10)
|
- | 562 |
+ 57 |
|
- }
+ #' )
|
- | 563 |
+ 58 |
|
-
+ #' })
|
-
- | 564 |
- ! |
+
+ | 59 |
+ |
- use_density <- input$use_density == "density"
+ #' datanames(data) <- c("countries", "sales")
|
-
- | 565 |
- ! |
+
+ | 60 |
+ |
- free_x_scales <- input$free_x_scales
+ #' join_keys(data) <- join_keys(
|
-
- | 566 |
- ! |
+
+ | 61 |
+ |
- free_y_scales <- input$free_y_scales
+ #' join_key("countries", "countries", "id"),
|
-
- | 567 |
- ! |
+
+ | 62 |
+ |
- ggtheme <- input$ggtheme
+ #' join_key("sales", "sales", "id"),
|
-
- | 568 |
- ! |
+
+ | 63 |
+ |
- rotate_xaxis_labels <- input$rotate_xaxis_labels
+ #' join_key("countries", "sales", c("id" = "country_id"))
|
-
- | 569 |
- ! |
+
+ | 64 |
+ |
- swap_axes <- input$swap_axes
+ #' )
|
- | 570 |
+ 65 |
|
-
+ #'
|
-
- | 571 |
- ! |
+
+ | 66 |
+ |
- is_scatterplot <- all(vapply(ANL[c(x_name, y_name)], is.numeric, logical(1))) &&
+ #' app <- init(
|
-
- | 572 |
- ! |
+
+ | 67 |
+ |
- length(x_name) > 0 && length(y_name) > 0
+ #' data = data,
|
- | 573 |
+ 68 |
|
-
+ #' modules = modules(
|
-
- | 574 |
- ! |
+
+ | 69 |
+ |
- if (is_scatterplot) {
+ #' tm_g_scatterplotmatrix(
|
-
- | 575 |
- ! |
+
+ | 70 |
+ |
- shinyjs::show("alpha")
+ #' label = "Scatterplot matrix",
|
-
- | 576 |
- ! |
+
+ | 71 |
+ |
- alpha <- input$alpha
+ #' variables = list(
|
-
- | 577 |
- ! |
+
+ | 72 |
+ |
- shinyjs::show("add_lines")
+ #' data_extract_spec(
|
- | 578 |
+ 73 |
|
-
+ #' dataname = "countries",
|
-
- | 579 |
- ! |
+
+ | 74 |
+ |
- if (color_settings && input$coloring) {
+ #' select = select_spec(
|
-
- | 580 |
- ! |
+
+ | 75 |
+ |
- shinyjs::hide("fixed_size")
+ #' label = "Select variables:",
|
-
- | 581 |
- ! |
+
+ | 76 |
+ |
- shinyjs::show("size_settings")
+ #' choices = variable_choices(data[["countries"]]),
|
-
- | 582 |
- ! |
+
+ | 77 |
+ |
- size <- NULL
+ #' selected = c("area", "gdp", "debt"),
|
- | 583 |
+ 78 |
|
- } else {
+ #' multiple = TRUE,
|
-
- | 584 |
- ! |
+
+ | 79 |
+ |
- shinyjs::show("fixed_size")
+ #' ordered = TRUE,
|
-
- | 585 |
- ! |
+
+ | 80 |
+ |
- size <- input$fixed_size
+ #' fixed = FALSE
|
- | 586 |
+ 81 |
|
- }
+ #' )
|
- | 587 |
+ 82 |
|
- } else {
+ #' ),
|
-
- | 588 |
- ! |
+
+ | 83 |
+ |
- shinyjs::hide("add_lines")
+ #' data_extract_spec(
|
-
- | 589 |
- ! |
+
+ | 84 |
+ |
- updateCheckboxInput(session, "add_lines", value = restoreInput(ns("add_lines"), FALSE))
+ #' dataname = "sales",
|
-
- | 590 |
- ! |
+
+ | 85 |
+ |
- shinyjs::hide("alpha")
+ #' filter = filter_spec(
|
-
- | 591 |
- ! |
+
+ | 86 |
+ |
- shinyjs::hide("fixed_size")
+ #' label = "Select variable:",
|
-
- | 592 |
- ! |
+
+ | 87 |
+ |
- shinyjs::hide("size_settings")
+ #' vars = "country_id",
|
-
- | 593 |
- ! |
+
+ | 88 |
+ |
- alpha <- 1
+ #' choices = value_choices(data[["sales"]], "country_id"),
|
-
- | 594 |
- ! |
+
+ | 89 |
+ |
- size <- NULL
+ #' selected = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
|
- | 595 |
+ 90 |
|
- }
+ #' multiple = TRUE
|
- | 596 |
+ 91 |
|
-
+ #' ),
|
-
- | 597 |
- ! |
+
+ | 92 |
+ |
- teal::validate_has_data(ANL[, c(x_name, y_name), drop = FALSE], 3, complete = TRUE, allow_inf = FALSE)
+ #' select = select_spec(
|
- | 598 |
+ 93 |
|
-
+ #' label = "Select variables:",
|
-
- | 599 |
- ! |
+
+ | 94 |
+ |
- cl <- bivariate_plot_call(
+ #' choices = variable_choices(data[["sales"]], c("quantity", "costs", "profit")),
|
-
- | 600 |
- ! |
+
+ | 95 |
+ |
- data_name = "ANL",
+ #' selected = c("quantity", "costs", "profit"),
|
-
- | 601 |
- ! |
+
+ | 96 |
+ |
- x = x_name,
+ #' multiple = TRUE,
|
-
- | 602 |
- ! |
+
+ | 97 |
+ |
- y = y_name,
+ #' ordered = TRUE,
|
-
- | 603 |
- ! |
+
+ | 98 |
+ |
- x_class = ifelse(!identical(x_name, character(0)), class(ANL[[x_name]]), "NULL"),
+ #' fixed = FALSE
|
-
- | 604 |
- ! |
+
+ | 99 |
+ |
- y_class = ifelse(!identical(y_name, character(0)), class(ANL[[y_name]]), "NULL"),
+ #' )
|
-
- | 605 |
- ! |
+
+ | 100 |
+ |
- x_label = varname_w_label(x_name, ANL),
+ #' )
|
-
- | 606 |
- ! |
+
+ | 101 |
+ |
- y_label = varname_w_label(y_name, ANL),
+ #' )
|
-
- | 607 |
- ! |
+
+ | 102 |
+ |
- freq = !use_density,
+ #' )
|
-
- | 608 |
- ! |
+
+ | 103 |
+ |
- theme = ggtheme,
+ #' )
|
-
- | 609 |
- ! |
+
+ | 104 |
+ |
- rotate_xaxis_labels = rotate_xaxis_labels,
+ #' )
|
-
- | 610 |
- ! |
+
+ | 105 |
+ |
- swap_axes = swap_axes,
+ #' if (interactive()) {
|
-
- | 611 |
- ! |
+
+ | 106 |
+ |
- alpha = alpha,
+ #' shinyApp(app$ui, app$server)
|
-
- | 612 |
- ! |
+
+ | 107 |
+ |
- size = size,
+ #' }
|
-
- | 613 |
- ! |
+
+ | 108 |
+ |
- ggplot2_args = ggplot2_args
+ #'
|
- | 614 |
+ 109 |
|
- )
+ #' @examplesShinylive
|
- | 615 |
+ 110 |
|
-
+ #' library(teal.modules.general)
|
-
- | 616 |
- ! |
+
+ | 111 |
+ |
- facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name)))
+ #' interactive <- function() TRUE
|
- | 617 |
+ 112 |
|
-
+ #' {{ next_example }}
|
-
- | 618 |
- ! |
+
+ | 113 |
+ |
- if (facetting) {
+ #' @examplesIf require("lattice", quietly = TRUE)
|
-
- | 619 |
- ! |
+
+ | 114 |
+ |
- facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name, free_x_scales, free_y_scales)
+ #' # CDISC data example
|
- | 620 |
+ 115 |
|
-
+ #' data <- teal_data()
|
-
- | 621 |
- ! |
+
+ | 116 |
+ |
- if (!is.null(facet_cl)) {
+ #' data <- within(data, {
|
-
- | 622 |
- ! |
+
+ | 117 |
+ |
- cl <- call("+", cl, facet_cl)
+ #' ADSL <- rADSL
|
- | 623 |
+ 118 |
|
- }
+ #' ADRS <- rADRS
|
- | 624 |
+ 119 |
|
- }
+ #' })
|
- | 625 |
+ 120 |
|
-
+ #' datanames(data) <- c("ADSL", "ADRS")
|
-
- | 626 |
- ! |
+
+ | 121 |
+ |
- if (input$add_lines) {
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
|
-
- | 627 |
- ! |
+
+ | 122 |
+ |
- cl <- call("+", cl, quote(geom_line(size = 1)))
+ #'
|
- | 628 |
+ 123 |
|
- }
+ #' app <- init(
|
- | 629 |
+ 124 |
|
-
+ #' data = data,
|
-
- | 630 |
- ! |
+
+ | 125 |
+ |
- coloring_cl <- NULL
+ #' modules = modules(
|
-
- | 631 |
- ! |
+
+ | 126 |
+ |
- if (color_settings) {
+ #' tm_g_scatterplotmatrix(
|
-
- | 632 |
- ! |
+
+ | 127 |
+ |
- if (input$coloring) {
+ #' label = "Scatterplot matrix",
|
-
- | 633 |
- ! |
+
+ | 128 |
+ |
- coloring_cl <- coloring_ggplot_call(
+ #' variables = list(
|
-
- | 634 |
- ! |
+
+ | 129 |
+ |
- colour = color_name,
+ #' data_extract_spec(
|
-
- | 635 |
- ! |
+
+ | 130 |
+ |
- fill = fill_name,
+ #' dataname = "ADSL",
|
-
- | 636 |
- ! |
+
+ | 131 |
+ |
- size = size_name,
+ #' select = select_spec(
|
-
- | 637 |
- ! |
+
+ | 132 |
+ |
- is_point = any(grepl("geom_point", cl %>% deparse()))
+ #' label = "Select variables:",
|
- | 638 |
+ 133 |
|
- )
+ #' choices = variable_choices(data[["ADSL"]]),
|
-
- | 639 |
- ! |
+
+ | 134 |
+ |
- legend_lbls <- substitute(
+ #' selected = c("AGE", "RACE", "SEX"),
|
-
- | 640 |
- ! |
+
+ | 135 |
+ |
- expr = labs(color = color_name, fill = fill_name, size = size_name),
+ #' multiple = TRUE,
|
-
- | 641 |
- ! |
+
+ | 136 |
+ |
- env = list(
+ #' ordered = TRUE,
|
-
- | 642 |
- ! |
+
+ | 137 |
+ |
- color_name = varname_w_label(color_name, ANL),
+ #' fixed = FALSE
|
-
- | 643 |
- ! |
+
+ | 138 |
+ |
- fill_name = varname_w_label(fill_name, ANL),
+ #' )
|
-
- | 644 |
- ! |
+
+ | 139 |
+ |
- size_name = varname_w_label(size_name, ANL)
+ #' ),
|
- | 645 |
+ 140 |
|
- )
+ #' data_extract_spec(
|
- | 646 |
+ 141 |
|
- )
+ #' dataname = "ADRS",
|
- | 647 |
+ 142 |
|
- }
+ #' filter = filter_spec(
|
-
- | 648 |
- ! |
+
+ | 143 |
+ |
- if (!is.null(coloring_cl)) {
+ #' label = "Select endpoints:",
|
-
- | 649 |
- ! |
+
+ | 144 |
+ |
- cl <- call("+", call("+", cl, coloring_cl), legend_lbls)
+ #' vars = c("PARAMCD", "AVISIT"),
|
- | 650 |
+ 145 |
|
- }
+ #' choices = value_choices(data[["ADRS"]], c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")),
|
- | 651 |
+ 146 |
|
- }
+ #' selected = "INVET - END OF INDUCTION",
|
- | 652 |
+ 147 |
|
-
+ #' multiple = TRUE
|
- | 653 |
+ 148 |
|
- # Add labels to facets
+ #' ),
|
-
- | 654 |
- ! |
+
+ | 149 |
+ |
- nulled_row_facet_name <- varname_w_label(row_facet_name, ANL)
+ #' select = select_spec(
|
-
- | 655 |
- ! |
+
+ | 150 |
+ |
- nulled_col_facet_name <- varname_w_label(col_facet_name, ANL)
+ #' label = "Select variables:",
|
-
- | 656 |
- ! |
+
+ | 151 |
+ |
- without_facet <- (is.null(nulled_row_facet_name) && is.null(nulled_col_facet_name)) || !facetting
+ #' choices = variable_choices(data[["ADRS"]]),
|
- | 657 |
+ 152 |
|
-
+ #' selected = c("AGE", "AVAL", "ADY"),
|
-
- | 658 |
- ! |
+
+ | 153 |
+ |
- print_call <- if (without_facet) {
+ #' multiple = TRUE,
|
-
- | 659 |
- ! |
+
+ | 154 |
+ |
- quote(print(p))
+ #' ordered = TRUE,
|
- | 660 |
+ 155 |
|
- } else {
+ #' fixed = FALSE
|
-
- | 661 |
- ! |
+
+ | 156 |
+ |
- substitute(
+ #' )
|
-
- | 662 |
- ! |
+
+ | 157 |
+ |
- expr = {
+ #' )
|
- | 663 |
+ 158 |
|
- # Add facetting labels
+ #' )
|
- | 664 |
+ 159 |
|
- # optional: grid.newpage() # nolint: commented_code.
+ #' )
|
- | 665 |
+ 160 |
|
- # Prefixed with teal.modules.general as its usage will appear in "Show R code"
+ #' )
|
-
- | 666 |
- ! |
+
+ | 161 |
+ |
- p <- teal.modules.general::add_facet_labels(
+ #' )
|
-
- | 667 |
- ! |
+
+ | 162 |
+ |
- p,
+ #' if (interactive()) {
|
-
- | 668 |
- ! |
+
+ | 163 |
+ |
- xfacet_label = nulled_col_facet_name,
+ #' shinyApp(app$ui, app$server)
|
-
- | 669 |
- ! |
+
+ | 164 |
+ |
- yfacet_label = nulled_row_facet_name
+ #' }
|
- | 670 |
+ 165 |
|
- )
+ #'
|
-
- | 671 |
- ! |
+
+ | 166 |
+ |
- grid::grid.newpage()
+ #' @export
|
-
- | 672 |
- ! |
+
+ | 167 |
+ |
- grid::grid.draw(p)
+ #'
|
- | 673 |
+ 168 |
|
- },
+ tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix",
|
-
- | 674 |
- ! |
+
+ | 169 |
+ |
- env = list(nulled_col_facet_name = nulled_col_facet_name, nulled_row_facet_name = nulled_row_facet_name)
+ variables,
|
- | 675 |
+ 170 |
|
- )
+ plot_height = c(600, 200, 2000),
|
- | 676 |
+ 171 |
|
- }
+ plot_width = NULL,
|
- | 677 |
+ 172 |
|
-
+ pre_output = NULL,
|
-
- | 678 |
- ! |
+
+ | 173 |
+ |
- teal.code::eval_code(merged$anl_q_r(), substitute(expr = p <- cl, env = list(cl = cl))) %>%
+ post_output = NULL) {
|
- | 679 |
+ 174 |
! |
- teal.code::eval_code(print_call)
+ message("Initializing tm_g_scatterplotmatrix")
|
- | 680 |
+ 175 |
|
- })
+
|
- | 681 |
+ 176 |
|
-
+ # Requires Suggested packages
|
- | 682 |
+ 177 |
! |
- plot_r <- reactive({
+ if (!requireNamespace("lattice", quietly = TRUE)) {
|
- | 683 |
+ 178 |
! |
- output_q()[["p"]]
+ stop("Cannot load lattice - please install the package or restart your session.")
|
- | 684 |
+ 179 |
|
- })
+ }
|
- | 685 |
+ 180 |
|
|
-
- | 686 |
- ! |
+
+ | 181 |
+ |
- pws <- teal.widgets::plot_with_settings_srv(
+ # Normalize the parameters
|
- | 687 |
+ 182 |
! |
- id = "myplot",
+ if (inherits(variables, "data_extract_spec")) variables <- list(variables)
|
-
- | 688 |
- ! |
+
+ | 183 |
+ |
- plot_r = plot_r,
+
|
-
- | 689 |
- ! |
+
+ | 184 |
+ |
- height = plot_height,
+ # Start of assertions
|
- | 690 |
+ 185 |
! |
- width = plot_width
+ checkmate::assert_string(label)
|
-
- | 691 |
- |
+
+ | 186 |
+ ! |
- )
+ checkmate::assert_list(variables, types = "data_extract_spec")
|
- | 692 |
+ 187 |
|
|
- | 693 |
+ 188 |
! |
- teal.widgets::verbatim_popup_srv(
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
|
- | 694 |
+ 189 |
! |
- id = "rcode",
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
|
- | 695 |
+ 190 |
! |
- verbatim_content = reactive(teal.code::get_code(output_q())),
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
|
- | 696 |
+ 191 |
! |
- title = "Bivariate Plot"
+ checkmate::assert_numeric(
|
-
- | 697 |
- |
+
+ | 192 |
+ ! |
- )
+ plot_width[1],
|
-
- | 698 |
- |
+
+ | 193 |
+ ! |
-
+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
|
- | 699 |
+ 194 |
|
- ### REPORTER
+ )
|
-
- | 700 |
- ! |
+
+ | 195 |
+ |
- if (with_reporter) {
+
|
- | 701 |
+ 196 |
! |
- card_fun <- function(comment, label) {
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
- | 702 |
+ 197 |
! |
- card <- teal::report_card_template(
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
-
- | 703 |
- ! |
+
+ | 198 |
+ |
- title = "Bivariate Plot",
+ # End of assertions
|
-
- | 704 |
- ! |
+
+ | 199 |
+ |
- label = label,
+
|
-
- | 705 |
- ! |
+
+ | 200 |
+ |
- with_filter = with_filter,
+ # Make UI args
|
- | 706 |
+ 201 |
! |
- filter_panel_api = filter_panel_api
+ args <- as.list(environment())
|
- | 707 |
+ 202 |
|
- )
+
|
- | 708 |
+ 203 |
! |
- card$append_text("Plot", "header3")
+ ans <- module(
|
- | 709 |
+ 204 |
! |
- card$append_plot(plot_r(), dim = pws$dim())
+ label = label,
|
- | 710 |
+ 205 |
! |
- if (!comment == "") {
+ server = srv_g_scatterplotmatrix,
|
- | 711 |
+ 206 |
! |
- card$append_text("Comment", "header3")
+ ui = ui_g_scatterplotmatrix,
|
- | 712 |
+ 207 |
! |
- card$append_text(comment)
- |
-
-
- | 713 |
- |
-
- }
+ ui_args = args,
|
- | 714 |
+ 208 |
! |
- card$append_src(teal.code::get_code(output_q()))
+ server_args = list(variables = variables, plot_height = plot_height, plot_width = plot_width),
|
- | 715 |
+ 209 |
! |
- card
+ datanames = teal.transform::get_extract_datanames(variables)
|
- | 716 |
+ 210 |
|
- }
+ )
|
- | 717 |
+ 211 |
! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
- |
-
-
- | 718 |
- |
-
- }
- |
-
-
- | 719 |
- |
-
- ###
+ attr(ans, "teal_bookmarkable") <- TRUE
|
-
- | 720 |
- |
+
+ | 212 |
+ ! |
- })
+ ans
|
- | 721 |
+ 213 |
|
}
|
- | 722 |
+ 214 |
|
|
- | 723 |
+ 215 |
|
- # Get Substituted ggplot call
+ # UI function for the scatterplot matrix module
|
- | 724 |
+ 216 |
|
- bivariate_plot_call <- function(data_name,
+ ui_g_scatterplotmatrix <- function(id, ...) {
|
-
- | 725 |
- |
+
+ | 217 |
+ ! |
- x = character(0),
+ args <- list(...)
|
-
- | 726 |
- |
+
+ | 218 |
+ ! |
- y = character(0),
+ is_single_dataset_value <- teal.transform::is_single_dataset(args$variables)
|
-
- | 727 |
- |
+
+ | 219 |
+ ! |
- x_class = "NULL",
+ ns <- NS(id)
|
-
- | 728 |
- |
+
+ | 220 |
+ ! |
- y_class = "NULL",
+ teal.widgets::standard_layout(
|
-
- | 729 |
- |
+
+ | 221 |
+ ! |
- x_label = NULL,
+ output = teal.widgets::white_small_well(
|
-
- | 730 |
- |
+
+ | 222 |
+ ! |
- y_label = NULL,
+ textOutput(ns("message")),
|
-
- | 731 |
- |
+
+ | 223 |
+ ! |
- freq = TRUE,
+ tags$br(),
|
-
- | 732 |
- |
+
+ | 224 |
+ ! |
- theme = "gray",
+ teal.widgets::plot_with_settings_ui(id = ns("myplot"))
|
- | 733 |
+ 225 |
|
- rotate_xaxis_labels = FALSE,
+ ),
|
-
- | 734 |
- |
+
+ | 226 |
+ ! |
- swap_axes = FALSE,
+ encoding = tags$div(
|
- | 735 |
+ 227 |
|
- alpha = double(0),
+ ### Reporter
|
-
- | 736 |
- |
+
+ | 228 |
+ ! |
- size = 2,
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
- | 737 |
+ 229 |
|
- ggplot2_args = teal.widgets::ggplot2_args()) {
+ ###
|
- | 738 |
+ 230 |
! |
- supported_types <- c("NULL", "numeric", "integer", "factor", "character", "logical", "ordered")
+ tags$label("Encodings", class = "text-primary"),
|
- | 739 |
+ 231 |
! |
- validate(need(x_class %in% supported_types, paste0("Data type '", x_class, "' is not supported.")))
+ teal.transform::datanames_input(args$variables),
|
- | 740 |
+ 232 |
! |
- validate(need(y_class %in% supported_types, paste0("Data type '", y_class, "' is not supported.")))
- |
-
-
- | 741 |
- |
-
-
- |
-
-
- | 742 |
- |
-
-
+ teal.transform::data_extract_ui(
|
- | 743 |
+ 233 |
! |
- if (identical(x, character(0))) {
+ id = ns("variables"),
|
- | 744 |
+ 234 |
! |
- x <- x_label <- "-"
+ label = "Variables",
|
-
- | 745 |
- |
+
+ | 235 |
+ ! |
- } else {
+ data_extract_spec = args$variables,
|
- | 746 |
+ 236 |
! |
- x <- if (is.call(x)) x else as.name(x)
+ is_single_dataset = is_single_dataset_value
|
- | 747 |
+ 237 |
|
- }
+ ),
|
- | 748 |
+ 238 |
! |
- if (identical(y, character(0))) {
+ tags$hr(),
|
- | 749 |
+ 239 |
! |
- y <- y_label <- "-"
- |
-
-
- | 750 |
- |
-
- } else {
+ teal.widgets::panel_group(
|
- | 751 |
+ 240 |
! |
- y <- if (is.call(y)) y else as.name(y)
- |
-
-
- | 752 |
- |
-
- }
+ teal.widgets::panel_item(
|
-
- | 753 |
- |
+
+ | 241 |
+ ! |
-
+ title = "Plot settings",
|
- | 754 |
+ 242 |
! |
- cl <- bivariate_ggplot_call(
+ sliderInput(
|
- | 755 |
+ 243 |
! |
- x_class = x_class,
+ ns("alpha"), "Opacity:",
|
- | 756 |
+ 244 |
! |
- y_class = y_class,
+ min = 0, max = 1,
|
- | 757 |
+ 245 |
! |
- freq = freq,
+ step = .05, value = .5, ticks = FALSE
+ |
+
+
+ | 246 |
+ |
+
+ ),
|
- | 758 |
+ 247 |
! |
- theme = theme,
+ sliderInput(
|
- | 759 |
+ 248 |
! |
- rotate_xaxis_labels = rotate_xaxis_labels,
+ ns("cex"), "Points size:",
|
- | 760 |
+ 249 |
! |
- swap_axes = swap_axes,
+ min = 0.2, max = 3,
|
- | 761 |
+ 250 |
! |
- alpha = alpha,
+ step = .05, value = .65, ticks = FALSE
|
-
- | 762 |
- ! |
+
+ | 251 |
+ |
- size = size,
+ ),
|
- | 763 |
+ 252 |
! |
- ggplot2_args = ggplot2_args,
+ checkboxInput(ns("cor"), "Add Correlation", value = FALSE),
|
- | 764 |
+ 253 |
! |
- x = x,
+ radioButtons(
|
- | 765 |
+ 254 |
! |
- y = y,
+ ns("cor_method"), "Select Correlation Method",
|
- | 766 |
+ 255 |
! |
- xlab = x_label,
+ choiceNames = c("Pearson", "Kendall", "Spearman"),
|
- | 767 |
+ 256 |
! |
- ylab = y_label,
+ choiceValues = c("pearson", "kendall", "spearman"),
|
- | 768 |
+ 257 |
! |
- data_name = data_name
+ inline = TRUE
|
- | 769 |
+ 258 |
|
- )
+ ),
|
-
- | 770 |
- |
+
+ | 259 |
+ ! |
- }
+ checkboxInput(ns("cor_na_omit"), "Omit Missing Values", value = TRUE)
|
- | 771 |
+ 260 |
|
-
+ )
|
- | 772 |
+ 261 |
|
- # Create ggplot part of plot call
+ )
|
- | 773 |
+ 262 |
|
- # Due to the type of the x and y variable the plot type is chosen
+ ),
|
-
- | 774 |
- |
+
+ | 263 |
+ ! |
- bivariate_ggplot_call <- function(x_class,
+ forms = tagList(
|
-
- | 775 |
- |
+
+ | 264 |
+ ! |
- y_class,
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
- | 776 |
+ 265 |
|
- freq = TRUE,
+ ),
|
-
- | 777 |
- |
+
+ | 266 |
+ ! |
- theme = "gray",
+ pre_output = args$pre_output,
|
-
- | 778 |
- |
+
+ | 267 |
+ ! |
- rotate_xaxis_labels = FALSE,
+ post_output = args$post_output
|
- | 779 |
+ 268 |
|
- swap_axes = FALSE,
+ )
|
- | 780 |
+ 269 |
|
- size = double(0),
+ }
|
- | 781 |
+ 270 |
|
- alpha = double(0),
+
|
- | 782 |
+ 271 |
|
- x = NULL,
+ # Server function for the scatterplot matrix module
|
- | 783 |
+ 272 |
|
- y = NULL,
+ srv_g_scatterplotmatrix <- function(id, data, reporter, filter_panel_api, variables, plot_height, plot_width) {
|
-
- | 784 |
- |
+
+ | 273 |
+ ! |
- xlab = "-",
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
|
-
- | 785 |
- |
+
+ | 274 |
+ ! |
- ylab = "-",
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
|
-
- | 786 |
- |
+
+ | 275 |
+ ! |
- data_name = "ANL",
+ checkmate::assert_class(data, "reactive")
|
-
- | 787 |
- |
+
+ | 276 |
+ ! |
- ggplot2_args = teal.widgets::ggplot2_args()) {
+ checkmate::assert_class(isolate(data()), "teal_data")
|
-
- | 788 |
- 42x |
+
+ | 277 |
+ ! |
- x_class <- switch(x_class,
+ moduleServer(id, function(input, output, session) {
|
-
- | 789 |
- 42x |
+
+ | 278 |
+ ! |
- "character" = ,
+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
|
-
- | 790 |
- 42x |
+
+ | 279 |
+ |
- "ordered" = ,
+
|
-
- | 791 |
- 42x |
+
+ | 280 |
+ ! |
- "logical" = ,
+ selector_list <- teal.transform::data_extract_multiple_srv(
|
-
- | 792 |
- 42x |
+
+ | 281 |
+ ! |
- "factor" = "factor",
+ data_extract = list(variables = variables),
|
-
- | 793 |
- 42x |
+
+ | 282 |
+ ! |
- "integer" = ,
+ datasets = data,
|
-
- | 794 |
- 42x |
+
+ | 283 |
+ ! |
- "numeric" = "numeric",
+ select_validation_rule = list(
|
-
- | 795 |
- 42x |
+
+ | 284 |
+ ! |
- "NULL" = "NULL",
+ variables = ~ if (length(.) <= 1) "Please select at least 2 columns."
|
-
- | 796 |
- 42x |
+
+ | 285 |
+ |
- stop("unsupported x_class: ", x_class)
+ )
|
- | 797 |
+ 286 |
|
- )
+ )
|
-
- | 798 |
- 42x |
+
+ | 287 |
+ |
- y_class <- switch(y_class,
+
|
-
- | 799 |
- 42x |
+
+ | 288 |
+ ! |
- "character" = ,
+ iv_r <- reactive({
|
-
- | 800 |
- 42x |
+
+ | 289 |
+ ! |
- "ordered" = ,
+ iv <- shinyvalidate::InputValidator$new()
|
-
- | 801 |
- 42x |
+
+ | 290 |
+ ! |
- "logical" = ,
+ teal.transform::compose_and_enable_validators(iv, selector_list)
|
-
- | 802 |
- 42x |
+
+ | 291 |
+ |
- "factor" = "factor",
+ })
|
-
- | 803 |
- 42x |
+
+ | 292 |
+ |
- "integer" = ,
+
|
-
- | 804 |
- 42x |
+
+ | 293 |
+ ! |
- "numeric" = "numeric",
+ anl_merged_input <- teal.transform::merge_expression_srv(
|
-
- | 805 |
- 42x |
+
+ | 294 |
+ ! |
- "NULL" = "NULL",
+ datasets = data,
|
-
- | 806 |
- 42x |
+
+ | 295 |
+ ! |
- stop("unsupported y_class: ", y_class)
+ selector_list = selector_list
|
- | 807 |
+ 296 |
|
- )
+ )
|
- | 808 |
+ 297 |
|
|
-
- | 809 |
- 42x |
+
+ | 298 |
+ ! |
- if (all(c(x_class, y_class) == "NULL")) {
+ anl_merged_q <- reactive({
|
- | 810 |
+ 299 |
! |
- stop("either x or y is required")
+ req(anl_merged_input())
|
-
- | 811 |
- |
+
+ | 300 |
+ ! |
- }
+ data() %>%
+ |
+
+
+ | 301 |
+ ! |
+
+ teal.code::eval_code(as.expression(anl_merged_input()$expr))
|
- | 812 |
+ 302 |
|
-
+ })
|
-
- | 813 |
- 42x |
+
+ | 303 |
+ |
- reduce_plot_call <- function(...) {
+
|
-
- | 814 |
- 104x |
+
+ | 304 |
+ ! |
- args <- Filter(Negate(is.null), list(...))
+ merged <- list(
|
-
- | 815 |
- 104x |
+
+ | 305 |
+ ! |
- Reduce(function(x, y) call("+", x, y), args)
+ anl_input_r = anl_merged_input,
|
-
- | 816 |
- |
+
+ | 306 |
+ ! |
- }
+ anl_q_r = anl_merged_q
|
- | 817 |
+ 307 |
|
-
- |
-
-
- | 818 |
- 42x |
-
- plot_call <- substitute(ggplot(data_name), env = list(data_name = as.name(data_name)))
+ )
|
- | 819 |
+ 308 |
|
|
- | 820 |
+ 309 |
|
- # Single data plots
+ # plot
|
-
- | 821 |
- 42x |
+
+ | 310 |
+ ! |
- if (x_class == "numeric" && y_class == "NULL") {
+ output_q <- reactive({
|
-
- | 822 |
- 6x |
+
+ | 311 |
+ ! |
- plot_call <- reduce_plot_call(plot_call, substitute(aes(x = xval), env = list(xval = x)))
+ teal::validate_inputs(iv_r())
|
- | 823 |
+ 312 |
|
|
-
- | 824 |
- 6x |
-
- if (freq) {
- |
-
-
- | 825 |
- 4x |
-
- plot_call <- reduce_plot_call(
- |
-
-
- | 826 |
- 4x |
-
- plot_call,
- |
-
-
- | 827 |
- 4x |
-
- quote(geom_histogram(bins = 30)),
- |
-
-
- | 828 |
- 4x |
+
+ | 313 |
+ ! |
- quote(ylab("Frequency"))
+ qenv <- merged$anl_q_r()
|
-
- | 829 |
- |
+
+ | 314 |
+ ! |
- )
+ ANL <- qenv[["ANL"]]
|
- | 830 |
+ 315 |
|
- } else {
+
|
-
- | 831 |
- 2x |
+
+ | 316 |
+ ! |
- plot_call <- reduce_plot_call(
+ cols_names <- merged$anl_input_r()$columns_source$variables
|
-
- | 832 |
- 2x |
+
+ | 317 |
+ ! |
- plot_call,
+ alpha <- input$alpha
|
-
- | 833 |
- 2x |
+
+ | 318 |
+ ! |
- quote(geom_histogram(bins = 30, aes(y = after_stat(density)))),
+ cex <- input$cex
|
-
- | 834 |
- 2x |
+
+ | 319 |
+ ! |
- quote(geom_density(aes(y = after_stat(density)))),
+ add_cor <- input$cor
|
-
- | 835 |
- 2x |
+
+ | 320 |
+ ! |
- quote(ylab("Density"))
+ cor_method <- input$cor_method
|
-
- | 836 |
- |
+
+ | 321 |
+ ! |
- )
+ cor_na_omit <- input$cor_na_omit
|
- | 837 |
+ 322 |
|
- }
+
|
-
- | 838 |
- 36x |
+
+ | 323 |
+ ! |
- } else if (x_class == "NULL" && y_class == "numeric") {
+ cor_na_action <- if (isTruthy(cor_na_omit)) {
|
-
- | 839 |
- 6x |
+
+ | 324 |
+ ! |
- plot_call <- reduce_plot_call(plot_call, substitute(aes(x = yval), env = list(yval = y)))
+ "na.omit"
|
- | 840 |
+ 325 |
|
-
+ } else {
|
-
- | 841 |
- 6x |
+
+ | 326 |
+ ! |
- if (freq) {
+ "na.fail"
|
-
- | 842 |
- 4x |
+
+ | 327 |
+ |
- plot_call <- reduce_plot_call(
+ }
|
-
- | 843 |
- 4x |
+
+ | 328 |
+ |
- plot_call,
+
|
-
- | 844 |
- 4x |
+
+ | 329 |
+ ! |
- quote(geom_histogram(bins = 30)),
+ teal::validate_has_data(ANL, 10)
|
-
- | 845 |
- 4x |
+
+ | 330 |
+ ! |
- quote(ylab("Frequency"))
+ teal::validate_has_data(ANL[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE)
|
- | 846 |
+ 331 |
|
- )
+
|
- | 847 |
+ 332 |
|
- } else {
+ # get labels and proper variable names
|
-
- | 848 |
- 2x |
+
+ | 333 |
+ ! |
- plot_call <- reduce_plot_call(
+ varnames <- varname_w_label(cols_names, ANL, wrap_width = 20)
|
-
- | 849 |
- 2x |
+
+ | 334 |
+ |
- plot_call,
+
|
-
- | 850 |
- 2x |
+
+ | 335 |
+ |
- quote(geom_histogram(bins = 30, aes(y = after_stat(density)))),
+ # check character columns. If any, then those are converted to factors
|
-
- | 851 |
- 2x |
+
+ | 336 |
+ ! |
- quote(geom_density(aes(y = after_stat(density)))),
+ check_char <- vapply(ANL[, cols_names], is.character, logical(1))
|
-
- | 852 |
- 2x |
+
+ | 337 |
+ ! |
- quote(ylab("Density"))
+ if (any(check_char)) {
|
-
- | 853 |
- |
+
+ | 338 |
+ ! |
- )
+ qenv <- teal.code::eval_code(
|
-
- | 854 |
- |
+
+ | 339 |
+ ! |
- }
+ qenv,
|
-
- | 855 |
- 30x |
+
+ | 340 |
+ ! |
- } else if (x_class == "factor" && y_class == "NULL") {
+ substitute(
|
-
- | 856 |
- 4x |
+
+ | 341 |
+ ! |
- plot_call <- reduce_plot_call(plot_call, substitute(aes(x = xval), env = list(xval = x)))
+ expr = ANL <- ANL[, cols_names] %>%
|
-
- | 857 |
- |
+
+ | 342 |
+ ! |
-
+ dplyr::mutate_if(is.character, as.factor) %>%
|
-
- | 858 |
- 4x |
+
+ | 343 |
+ ! |
- if (freq) {
+ droplevels(),
|
-
- | 859 |
- 2x |
+
+ | 344 |
+ ! |
- plot_call <- reduce_plot_call(
+ env = list(cols_names = cols_names)
|
-
- | 860 |
- 2x |
+
+ | 345 |
+ |
- plot_call,
+ )
|
-
- | 861 |
- 2x |
+
+ | 346 |
+ |
- quote(geom_bar()),
+ )
|
-
- | 862 |
- 2x |
+
+ | 347 |
+ |
- quote(ylab("Frequency"))
+ } else {
|
-
- | 863 |
- |
+
+ | 348 |
+ ! |
- )
+ qenv <- teal.code::eval_code(
|
-
- | 864 |
- |
+
+ | 349 |
+ ! |
- } else {
+ qenv,
|
-
- | 865 |
- 2x |
+
+ | 350 |
+ ! |
- plot_call <- reduce_plot_call(
+ substitute(
|
-
- | 866 |
- 2x |
+
+ | 351 |
+ ! |
- plot_call,
+ expr = ANL <- ANL[, cols_names] %>%
|
-
- | 867 |
- 2x |
+
+ | 352 |
+ ! |
- quote(geom_bar(aes(y = after_stat(prop), group = 1))),
+ droplevels(),
|
-
- | 868 |
- 2x |
+
+ | 353 |
+ ! |
- quote(ylab("Fraction"))
+ env = list(cols_names = cols_names)
|
- | 869 |
+ 354 |
|
- )
+ )
|
- | 870 |
+ 355 |
|
- }
+ )
|
-
- | 871 |
- 26x |
+
+ | 356 |
+ |
- } else if (x_class == "NULL" && y_class == "factor") {
+ }
|
-
- | 872 |
- 4x |
+
+ | 357 |
+ |
- plot_call <- reduce_plot_call(plot_call, substitute(aes(x = yval), env = list(yval = y)))
+
|
- | 873 |
+ 358 |
|
|
-
- | 874 |
- 4x |
+
+ | 359 |
+ |
- if (freq) {
+ # create plot
|
-
- | 875 |
- 2x |
+
+ | 360 |
+ ! |
- plot_call <- reduce_plot_call(
+ if (add_cor) {
|
-
- | 876 |
- 2x |
+
+ | 361 |
+ ! |
- plot_call,
+ shinyjs::show("cor_method")
|
-
- | 877 |
- 2x |
+
+ | 362 |
+ ! |
- quote(geom_bar()),
+ shinyjs::show("cor_use")
|
-
- | 878 |
- 2x |
+
+ | 363 |
+ ! |
- quote(ylab("Frequency"))
+ shinyjs::show("cor_na_omit")
|
- | 879 |
+ 364 |
|
- )
+
|
-
- | 880 |
- |
+
+ | 365 |
+ ! |
- } else {
+ qenv <- teal.code::eval_code(
|
-
- | 881 |
- 2x |
+
+ | 366 |
+ ! |
- plot_call <- reduce_plot_call(
+ qenv,
|
-
- | 882 |
- 2x |
+
+ | 367 |
+ ! |
- plot_call,
+ substitute(
|
-
- | 883 |
- 2x |
+
+ | 368 |
+ ! |
- quote(geom_bar(aes(y = after_stat(prop), group = 1))),
+ expr = {
|
-
- | 884 |
- 2x |
+
+ | 369 |
+ ! |
- quote(ylab("Fraction"))
+ g <- lattice::splom(
|
-
- | 885 |
- |
+
+ | 370 |
+ ! |
- )
+ ANL,
|
-
- | 886 |
- |
+
+ | 371 |
+ ! |
- }
+ varnames = varnames_value,
|
-
- | 887 |
- |
+
+ | 372 |
+ ! |
- # Numeric Plots
+ panel = function(x, y, ...) {
|
-
- | 888 |
- 22x |
+
+ | 373 |
+ ! |
- } else if (x_class == "numeric" && y_class == "numeric") {
+ lattice::panel.splom(x = x, y = y, ...)
|
-
- | 889 |
- 2x |
+
+ | 374 |
+ ! |
- plot_call <- reduce_plot_call(
+ cpl <- lattice::current.panel.limits()
|
-
- | 890 |
- 2x |
+
+ | 375 |
+ ! |
- plot_call,
+ lattice::panel.text(
|
-
- | 891 |
- 2x |
+
+ | 376 |
+ ! |
- substitute(aes(x = xval, y = yval), env = list(xval = x, yval = y)),
+ mean(cpl$xlim),
|
-
- | 892 |
- |
+
+ | 377 |
+ ! |
- # pch = 21 for consistent coloring behaviour b/w all geoms (outline and fill properties)
+ mean(cpl$ylim),
|
-
- | 893 |
- 2x |
+
+ | 378 |
+ ! |
- `if`(
+ get_scatterplotmatrix_stats(
|
-
- | 894 |
- 2x |
+
+ | 379 |
+ ! |
- !is.null(size),
+ x,
|
-
- | 895 |
- 2x |
+
+ | 380 |
+ ! |
- substitute(
+ y,
|
-
- | 896 |
- 2x |
+
+ | 381 |
+ ! |
- geom_point(alpha = alphaval, size = sizeval, pch = 21),
+ .f = stats::cor.test,
|
-
- | 897 |
- 2x |
+
+ | 382 |
+ ! |
- env = list(alphaval = alpha, sizeval = size)
+ .f_args = list(method = cor_method, na.action = cor_na_action)
|
- | 898 |
+ 383 |
|
- ),
- |
-
-
- | 899 |
- 2x |
-
- substitute(
+ ),
|
-
- | 900 |
- 2x |
+
+ | 384 |
+ ! |
- geom_point(alpha = alphaval, pch = 21),
+ alpha = 0.6,
|
-
- | 901 |
- 2x |
+
+ | 385 |
+ ! |
- env = list(alphaval = alpha)
+ fontsize = 18,
|
-
- | 902 |
- |
+
+ | 386 |
+ ! |
- )
+ fontface = "bold"
|
- | 903 |
+ 387 |
|
- )
+ )
|
- | 904 |
+ 388 |
|
- )
+ },
|
-
- | 905 |
- 20x |
+
+ | 389 |
+ ! |
- } else if ((x_class == "numeric" && y_class == "factor") || (x_class == "factor" && y_class == "numeric")) {
+ pch = 16,
|
-
- | 906 |
- 6x |
+
+ | 390 |
+ ! |
- plot_call <- reduce_plot_call(
+ alpha = alpha_value,
|
-
- | 907 |
- 6x |
+
+ | 391 |
+ ! |
- plot_call,
+ cex = cex_value
|
-
- | 908 |
- 6x |
+
+ | 392 |
+ |
- substitute(aes(x = xval, y = yval), env = list(xval = x, yval = y)),
+ )
|
-
- | 909 |
- 6x |
+
+ | 393 |
+ ! |
- quote(geom_boxplot())
+ print(g)
|
- | 910 |
+ 394 |
|
- )
+ },
|
-
- | 911 |
- |
+
+ | 395 |
+ ! |
- # Factor and character plots
+ env = list(
|
-
- | 912 |
- 14x |
+
+ | 396 |
+ ! |
- } else if (x_class == "factor" && y_class == "factor") {
+ varnames_value = varnames,
|
-
- | 913 |
- 14x |
+
+ | 397 |
+ ! |
- plot_call <- reduce_plot_call(
+ cor_method = cor_method,
|
-
- | 914 |
- 14x |
+
+ | 398 |
+ ! |
- plot_call,
+ cor_na_action = cor_na_action,
|
-
- | 915 |
- 14x |
+
+ | 399 |
+ ! |
- substitute(
+ alpha_value = alpha,
|
-
- | 916 |
- 14x |
+
+ | 400 |
+ ! |
- ggmosaic::geom_mosaic(aes(x = ggmosaic::product(xval), fill = yval), na.rm = TRUE),
+ cex_value = cex
|
-
- | 917 |
- 14x |
+
+ | 401 |
+ |
- env = list(xval = x, yval = y)
+ )
|
- | 918 |
+ 402 |
|
- )
+ )
|
- | 919 |
+ 403 |
|
- )
+ )
|
- | 920 |
+ 404 |
|
- } else {
+ } else {
|
- | 921 |
+ 405 |
! |
- stop("x y type combination not allowed")
+ shinyjs::hide("cor_method")
|
-
- | 922 |
- |
+
+ | 406 |
+ ! |
- }
+ shinyjs::hide("cor_use")
|
-
- | 923 |
- |
+
+ | 407 |
+ ! |
-
+ shinyjs::hide("cor_na_omit")
|
-
- | 924 |
- 42x |
+
+ | 408 |
+ ! |
- labs_base <- if (x_class == "NULL") {
+ qenv <- teal.code::eval_code(
|
-
- | 925 |
- 10x |
+
+ | 409 |
+ ! |
- list(x = substitute(ylab, list(ylab = ylab)))
+ qenv,
|
-
- | 926 |
- 42x |
+
+ | 410 |
+ ! |
- } else if (y_class == "NULL") {
+ substitute(
|
-
- | 927 |
- 10x |
+
+ | 411 |
+ ! |
- list(x = substitute(xlab, list(xlab = xlab)))
+ expr = {
|
-
- | 928 |
- |
+
+ | 412 |
+ ! |
- } else {
+ g <- lattice::splom(ANL, varnames = varnames_value, pch = 16, alpha = alpha_value, cex = cex_value)
|
-
- | 929 |
- 22x |
+
+ | 413 |
+ ! |
- list(
+ g
|
-
- | 930 |
- 22x |
+
+ | 414 |
+ |
- x = substitute(xlab, list(xlab = xlab)),
+ },
|
-
- | 931 |
- 22x |
+
+ | 415 |
+ ! |
- y = substitute(ylab, list(ylab = ylab))
+ env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex)
|
- | 932 |
+ 416 |
|
- )
+ )
|
- | 933 |
+ 417 |
|
- }
+ )
|
- | 934 |
+ 418 |
|
-
+ }
|
-
- | 935 |
- 42x |
+
+ | 419 |
+ ! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(labs = labs_base)
+ qenv
|
- | 936 |
+ 420 |
|
-
+ })
|
-
- | 937 |
- 42x |
+
+ | 421 |
+ |
- if (rotate_xaxis_labels) {
+
|
- | 938 |
+ 422 |
! |
- dev_ggplot2_args$theme <- list(axis.text.x = quote(element_text(angle = 45, hjust = 1)))
+ plot_r <- reactive(output_q()[["g"]])
|
- | 939 |
+ 423 |
|
- }
+
|
- | 940 |
+ 424 |
|
-
+ # Insert the plot into a plot_with_settings module
|
-
- | 941 |
- 42x |
+
+ | 425 |
+ ! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
+ pws <- teal.widgets::plot_with_settings_srv(
|
-
- | 942 |
- 42x |
+
+ | 426 |
+ ! |
- user_plot = ggplot2_args,
+ id = "myplot",
|
-
- | 943 |
- 42x |
+
+ | 427 |
+ ! |
- module_plot = dev_ggplot2_args
+ plot_r = plot_r,
+ |
+
+
+ | 428 |
+ ! |
+
+ height = plot_height,
+ |
+
+
+ | 429 |
+ ! |
+
+ width = plot_width
|
- | 944 |
+ 430 |
|
- )
+ )
|
- | 945 |
+ 431 |
|
|
-
- | 946 |
- 42x |
+
+ | 432 |
+ |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = theme)
+ # show a message if conversion to factors took place
|
-
- | 947 |
- |
+
+ | 433 |
+ ! |
-
+ output$message <- renderText({
|
-
- | 948 |
- 42x |
+
+ | 434 |
+ ! |
- plot_call <- reduce_plot_call(
+ req(iv_r()$is_valid())
|
-
- | 949 |
- 42x |
+
+ | 435 |
+ ! |
- plot_call,
+ req(selector_list()$variables())
|
-
- | 950 |
- 42x |
+
+ | 436 |
+ ! |
- parsed_ggplot2_args$labs,
+ ANL <- merged$anl_q_r()[["ANL"]]
|
-
- | 951 |
- 42x |
+
+ | 437 |
+ ! |
- parsed_ggplot2_args$ggtheme,
+ cols_names <- unique(unname(do.call(c, merged$anl_input_r()$columns_source)))
|
-
- | 952 |
- 42x |
+
+ | 438 |
+ ! |
- parsed_ggplot2_args$theme
+ check_char <- vapply(ANL[, cols_names], is.character, logical(1))
|
-
- | 953 |
- |
+
+ | 439 |
+ ! |
- )
+ if (any(check_char)) {
|
-
- | 954 |
- |
+
+ | 440 |
+ ! |
-
+ is_single <- sum(check_char) == 1
|
-
- | 955 |
- 42x |
+
+ | 441 |
+ ! |
- if (swap_axes) {
+ paste(
|
- | 956 |
+ 442 |
! |
- plot_call <- reduce_plot_call(plot_call, quote(coord_flip()))
+ "Character",
|
-
- | 957 |
- |
+
+ | 443 |
+ ! |
- }
+ ifelse(is_single, "variable", "variables"),
|
-
- | 958 |
- |
+
+ | 444 |
+ ! |
-
+ paste0("(", paste(cols_names[check_char], collapse = ", "), ")"),
|
-
- | 959 |
- 42x |
+
+ | 445 |
+ ! |
- plot_call
+ ifelse(is_single, "was", "were"),
|
-
- | 960 |
- |
+
+ | 446 |
+ ! |
- }
+ "converted to",
+ |
+
+
+ | 447 |
+ ! |
+
+ ifelse(is_single, "factor.", "factors.")
|
- | 961 |
+ 448 |
|
-
+ )
|
- | 962 |
+ 449 |
|
- # Create facet call
+ } else {
|
- | 963 |
+ 450 |
|
- facet_ggplot_call <- function(row_facet = character(0),
+ ""
|
- | 964 |
+ 451 |
|
- col_facet = character(0),
+ }
|
- | 965 |
+ 452 |
|
- free_x_scales = FALSE,
+ })
|
- | 966 |
+ 453 |
|
- free_y_scales = FALSE) {
+
|
- | 967 |
+ 454 |
! |
- scales <- if (free_x_scales && free_y_scales) {
+ teal.widgets::verbatim_popup_srv(
|
- | 968 |
+ 455 |
! |
- "free"
+ id = "rcode",
|
- | 969 |
+ 456 |
! |
- } else if (free_x_scales) {
+ verbatim_content = reactive(teal.code::get_code(output_q())),
|
- | 970 |
+ 457 |
! |
- "free_x"
+ title = "Show R Code for Scatterplotmatrix"
|
-
- | 971 |
- ! |
+
+ | 458 |
+ |
- } else if (free_y_scales) {
+ )
|
-
- | 972 |
- ! |
+
+ | 459 |
+ |
- "free_y"
+
|
- | 973 |
+ 460 |
|
- } else {
+ ### REPORTER
|
- | 974 |
+ 461 |
! |
- "fixed"
+ if (with_reporter) {
|
-
- | 975 |
- |
+
+ | 462 |
+ ! |
- }
+ card_fun <- function(comment, label) {
|
-
- | 976 |
- |
+
+ | 463 |
+ ! |
-
+ card <- teal::report_card_template(
|
- | 977 |
+ 464 |
! |
- if (identical(row_facet, character(0)) && identical(col_facet, character(0))) {
+ title = "Scatter Plot Matrix",
|
- | 978 |
+ 465 |
! |
- NULL
+ label = label,
|
- | 979 |
+ 466 |
! |
- } else if (!identical(row_facet, character(0)) && !identical(col_facet, character(0))) {
+ with_filter = with_filter,
|
- | 980 |
+ 467 |
! |
- call(
+ filter_panel_api = filter_panel_api
+ |
+
+
+ | 468 |
+ |
+
+ )
|
- | 981 |
+ 469 |
! |
- "facet_grid",
+ card$append_text("Plot", "header3")
|
- | 982 |
+ 470 |
! |
- rows = call_fun_dots("vars", row_facet),
+ card$append_plot(plot_r(), dim = pws$dim())
+ |
+
+
+ | 471 |
+ ! |
+
+ if (!comment == "") {
|
- | 983 |
+ 472 |
! |
- cols = call_fun_dots("vars", col_facet),
+ card$append_text("Comment", "header3")
|
- | 984 |
+ 473 |
! |
- scales = scales
+ card$append_text(comment)
|
- | 985 |
+ 474 |
|
- )
+ }
|
- | 986 |
+ 475 |
! |
- } else if (identical(row_facet, character(0)) && !identical(col_facet, character(0))) {
+ card$append_src(teal.code::get_code(output_q()))
|
- | 987 |
+ 476 |
! |
- call("facet_grid", cols = call_fun_dots("vars", col_facet), scales = scales)
+ card
|
-
- | 988 |
- ! |
+
+ | 477 |
+ |
- } else if (!identical(row_facet, character(0)) && identical(col_facet, character(0))) {
+ }
|
- | 989 |
+ 478 |
! |
- call("facet_grid", rows = call_fun_dots("vars", row_facet), scales = scales)
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
- | 990 |
+ 479 |
|
- }
+ }
|
- | 991 |
+ 480 |
|
- }
+ ###
|
- | 992 |
+ 481 |
|
-
+ })
|
- | 993 |
+ 482 |
|
- coloring_ggplot_call <- function(colour,
+ }
|
- | 994 |
+ 483 |
|
- fill,
+
|
- | 995 |
+ 484 |
|
- size,
+ #' Get stats for x-y pairs in scatterplot matrix
|
- | 996 |
+ 485 |
|
- is_point = FALSE) {
+ #'
|
- | 997 |
+ 486 |
|
- if (
+ #' Uses [stats::cor.test()] per default for all numerical input variables and converts results
|
-
- | 998 |
- 15x |
+
+ | 487 |
+ |
- !identical(colour, character(0)) &&
+ #' to character vector.
|
-
- | 999 |
- 15x |
+
+ | 488 |
+ |
- !identical(fill, character(0)) &&
+ #' Could be extended if different stats for different variable types are needed.
|
-
- | 1000 |
- 15x |
+
+ | 489 |
+ |
- is_point &&
+ #' Meant to be called from [lattice::panel.text()].
|
-
- | 1001 |
- 15x |
+
+ | 490 |
+ |
- !identical(size, character(0))
+ #'
|
- | 1002 |
+ 491 |
|
- ) {
+ #' Presently we need to use a formula input for `stats::cor.test` because
|
-
- | 1003 |
- 1x |
+
+ | 492 |
+ |
- substitute(
+ #' `na.fail` only gets evaluated when a formula is passed (see below).
|
-
- | 1004 |
- 1x |
+
+ | 493 |
+ |
- expr = aes(colour = colour_name, fill = fill_name, size = size_name),
+ #' ```
|
-
- | 1005 |
- 1x |
+
+ | 494 |
+ |
- env = list(colour_name = as.name(colour), fill_name = as.name(fill), size_name = as.name(size))
+ #' x = c(1,3,5,7,NA)
|
- | 1006 |
+ 495 |
|
- )
+ #' y = c(3,6,7,8,1)
|
- | 1007 |
+ 496 |
|
- } else if (
+ #' stats::cor.test(x, y, na.action = "na.fail")
|
-
- | 1008 |
- 14x |
+
+ | 497 |
+ |
- identical(colour, character(0)) &&
+ #' stats::cor.test(~ x + y, na.action = "na.fail")
|
-
- | 1009 |
- 14x |
+
+ | 498 |
+ |
- !identical(fill, character(0)) &&
+ #' ```
|
-
- | 1010 |
- 14x |
+
+ | 499 |
+ |
- is_point &&
+ #'
|
-
- | 1011 |
- 14x |
+
+ | 500 |
+ |
- identical(size, character(0))
+ #' @param x,y (`numeric`) vectors of data values. `x` and `y` must have the same length.
|
- | 1012 |
+ 501 |
|
- ) {
+ #' @param .f (`function`) function that accepts x and y as formula input `~ x + y`.
|
-
- | 1013 |
- 1x |
+
+ | 502 |
+ |
- substitute(expr = aes(fill = fill_name), env = list(fill_name = as.name(fill)))
+ #' Default `stats::cor.test`.
|
- | 1014 |
+ 503 |
|
- } else if (
+ #' @param .f_args (`list`) of arguments to be passed to `.f`.
|
-
- | 1015 |
- 13x |
+
+ | 504 |
+ |
- !identical(colour, character(0)) &&
+ #' @param round_stat (`integer(1)`) optional, number of decimal places to use when rounding the estimate.
|
-
- | 1016 |
- 13x |
+
+ | 505 |
+ |
- !identical(fill, character(0)) &&
+ #' @param round_pval (`integer(1)`) optional, number of decimal places to use when rounding the p-value.
|
-
- | 1017 |
- 13x |
+
+ | 506 |
+ |
- (!is_point || identical(size, character(0)))
+ #'
|
- | 1018 |
+ 507 |
|
- ) {
+ #' @return Character with stats. For [stats::cor.test()] correlation coefficient and p-value.
|
-
- | 1019 |
- 3x |
+
+ | 508 |
+ |
- substitute(
+ #'
|
-
- | 1020 |
- 3x |
+
+ | 509 |
+ |
- expr = aes(colour = colour_name, fill = fill_name),
+ #' @examples
|
-
- | 1021 |
- 3x |
+
+ | 510 |
+ |
- env = list(colour_name = as.name(colour), fill_name = as.name(fill))
+ #' set.seed(1)
|
- | 1022 |
+ 511 |
|
- )
+ #' x <- runif(25, 0, 1)
|
- | 1023 |
+ 512 |
|
- } else if (
+ #' y <- runif(25, 0, 1)
|
-
- | 1024 |
- 10x |
+
+ | 513 |
+ |
- !identical(colour, character(0)) &&
+ #' x[c(3, 10, 18)] <- NA
|
-
- | 1025 |
- 10x |
+
+ | 514 |
+ |
- identical(fill, character(0)) &&
+ #'
|
-
- | 1026 |
- 10x |
+
+ | 515 |
+ |
- (!is_point || identical(size, character(0)))
+ #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson"))
|
- | 1027 |
+ 516 |
|
- ) {
+ #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(
|
-
- | 1028 |
- 1x |
+
+ | 517 |
+ |
- substitute(expr = aes(colour = colour_name), env = list(colour_name = as.name(colour)))
+ #' method = "pearson",
|
- | 1029 |
+ 518 |
|
- } else if (
+ #' na.action = na.fail
|
-
- | 1030 |
- 9x |
+
+ | 519 |
+ |
- identical(colour, character(0)) &&
+ #' ))
|
-
- | 1031 |
- 9x |
+
+ | 520 |
+ |
- !identical(fill, character(0)) &&
+ #'
|
-
- | 1032 |
- 9x |
+
+ | 521 |
+ |
- (!is_point || identical(size, character(0)))
+ #' @export
|
- | 1033 |
+ 522 |
|
- ) {
+ #'
|
-
- | 1034 |
- 2x |
+
+ | 523 |
+ |
- substitute(expr = aes(fill = fill_name), env = list(fill_name = as.name(fill)))
+ get_scatterplotmatrix_stats <- function(x, y,
|
- | 1035 |
+ 524 |
|
- } else if (
+ .f = stats::cor.test,
|
-
- | 1036 |
- 7x |
+
+ | 525 |
+ |
- identical(colour, character(0)) &&
+ .f_args = list(),
|
-
- | 1037 |
- 7x |
+
+ | 526 |
+ |
- identical(fill, character(0)) &&
+ round_stat = 2,
+ |
+
+
+ | 527 |
+ |
+
+ round_pval = 4) {
|
- | 1038 |
- 7x |
+ 528 |
+ 6x |
- is_point &&
+ if (is.numeric(x) && is.numeric(y)) {
|
- | 1039 |
- 7x |
+ 529 |
+ 3x |
- !identical(size, character(0))
+ stat <- tryCatch(do.call(.f, c(list(~ x + y), .f_args)), error = function(e) NA)
|
- | 1040 |
+ 530 |
|
- ) {
+
|
- | 1041 |
+ 531 |
+ 3x |
+
+ if (anyNA(stat)) {
+ |
+
+
+ | 532 |
1x |
- substitute(expr = aes(size = size_name), env = list(size_name = as.name(size)))
+ return("NA")
|
-
- | 1042 |
- |
+
+ | 533 |
+ 2x |
- } else if (
+ } else if (all(c("estimate", "p.value") %in% names(stat))) {
|
- | 1043 |
- 6x |
+ 534 |
+ 2x |
- !identical(colour, character(0)) &&
+ return(paste(
|
- | 1044 |
- 6x |
+ 535 |
+ 2x |
- identical(fill, character(0)) &&
+ c(
|
- | 1045 |
- 6x |
+ 536 |
+ 2x |
- is_point &&
+ paste0(names(stat$estimate), ":", round(stat$estimate, round_stat)),
|
- | 1046 |
- 6x |
+ 537 |
+ 2x |
- !identical(size, character(0))
+ paste0("P:", round(stat$p.value, round_pval))
|
- | 1047 |
+ 538 |
|
- ) {
+ ),
|
- | 1048 |
- 1x |
+ 539 |
+ 2x |
- substitute(
+ collapse = "\n"
|
-
- | 1049 |
- 1x |
+
+ | 540 |
+ |
- expr = aes(colour = colour_name, size = size_name),
+ ))
|
-
- | 1050 |
- 1x |
+
+ | 541 |
+ |
- env = list(colour_name = as.name(colour), size_name = as.name(size))
+ } else {
|
-
- | 1051 |
- |
+
+ | 542 |
+ ! |
- )
+ stop("function not supported")
|
- | 1052 |
+ 543 |
|
- } else if (
+ }
|
-
- | 1053 |
- 5x |
+
+ | 544 |
+ |
- identical(colour, character(0)) &&
+ } else {
|
- | 1054 |
- 5x |
+ 545 |
+ 3x |
- !identical(fill, character(0)) &&
+ if ("method" %in% names(.f_args)) {
|
- | 1055 |
- 5x |
+ 546 |
+ 3x |
- is_point &&
+ if (.f_args$method == "pearson") {
|
- | 1056 |
- 5x |
+ 547 |
+ 1x |
- !identical(size, character(0))
+ return("cor:-")
|
- | 1057 |
+ 548 |
|
- ) {
+ }
|
- | 1058 |
+ 549 |
+ 2x |
+
+ if (.f_args$method == "kendall") {
+ |
+
+
+ | 550 |
1x |
- substitute(
+ return("tau:-")
+ |
+
+
+ | 551 |
+ |
+
+ }
|
- | 1059 |
+ 552 |
1x |
- expr = aes(colour = colour_name, fill = fill_name, size = size_name),
+ if (.f_args$method == "spearman") {
|
- | 1060 |
+ 553 |
1x |
- env = list(colour_name = as.name(fill), fill_name = as.name(fill), size_name = as.name(size))
+ return("rho:-")
|
- | 1061 |
+ 554 |
|
- )
+ }
|
- | 1062 |
+ 555 |
|
- } else {
+ }
|
-
- | 1063 |
- 4x |
+
+ | 556 |
+ ! |
- NULL
+ return("-")
|
- | 1064 |
+ 557 |
|
}
|
- | 1065 |
+ 558 |
|
}
@@ -42022,14 +42246,14 @@ teal.modules.general coverage - 3.44%
|
-
+
| 1 |
|
- #' `teal` module: Variable browser
+ #' `teal` module: Data table viewer
|
@@ -42043,2261 +42267,2261 @@ teal.modules.general coverage - 3.44%
3 |
|
- #' Module provides provides a detailed summary and visualization of variable distributions
+ #' Module provides a dynamic and interactive way to view `data.frame`s in a `teal` application.
|
| 4 |
|
- #' for `data.frame` objects, with interactive features to customize analysis.
+ #' It uses the `DT` package to display data tables in a paginated, searchable, and sortable format,
|
| 5 |
|
- #'
+ #' which helps to enhance data exploration and analysis.
|
| 6 |
|
- #' Numeric columns with fewer than 30 distinct values can be treated as either discrete
+ #'
|
| 7 |
|
- #' or continuous with a checkbox allowing users to switch how they are treated(if < 6 unique values
+ #' The `DT` package has an option `DT.TOJSON_ARGS` to show `Inf` and `NA` in data tables.
|
| 8 |
|
- #' then the default is discrete, otherwise it is continuous).
+ #' Configure the `DT.TOJSON_ARGS` option via
|
| 9 |
|
- #'
+ #' `options(DT.TOJSON_ARGS = list(na = "string"))` before running the module.
|
| 10 |
|
- #' @inheritParams teal::module
+ #' Note though that sorting of numeric columns with `NA`/`Inf` will be lexicographic not numerical.
|
| 11 |
|
- #' @inheritParams shared_params
+ #'
|
| 12 |
|
- #' @param parent_dataname (`character(1)`) string specifying a parent dataset.
+ #' @inheritParams teal::module
|
| 13 |
|
- #' If it exists in `datasets_selected`then an extra checkbox will be shown to
+ #' @inheritParams shared_params
|
| 14 |
|
- #' allow users to not show variables in other datasets which exist in this `dataname`.
+ #' @param variables_selected (`named list`) Character vectors of the variables (i.e. columns)
|
| 15 |
|
- #' This is typically used to remove `ADSL` columns in `CDISC` data.
+ #' which should be initially shown for each dataset.
|
| 16 |
|
- #' In non `CDISC` data this can be ignored. Defaults to `"ADSL"`.
+ #' Names of list elements should correspond to the names of the datasets available in the app.
|
| 17 |
|
- #' @param datasets_selected (`character`) vector of datasets which should be
+ #' If no entry is specified for a dataset, the first six variables from that
|
| 18 |
|
- #' shown, in order. Names must correspond with datasets names.
+ #' dataset will initially be shown.
|
| 19 |
|
- #' If vector of length zero (default) then all datasets are shown.
+ #' @param datasets_selected (`character`) A vector of datasets which should be
|
| 20 |
|
- #' Note: Only `data.frame` objects are compatible; using other types will cause an error.
+ #' shown and in what order. Names in the vector have to correspond with datasets names.
|
| 21 |
|
- #'
+ #' If vector of `length == 0` (default) then all datasets are shown.
|
| 22 |
|
- #' @inherit shared_params return
+ #' Note: Only datasets of the `data.frame` class are compatible.
|
| 23 |
|
- #'
+ #' @param dt_args (`named list`) Additional arguments to be passed to [DT::datatable()]
|
| 24 |
|
- #' @examples
+ #' (must not include `data` or `options`).
|
| 25 |
|
- #' library(teal.widgets)
+ #' @param dt_options (`named list`) The `options` argument to `DT::datatable`. By default
|
| 26 |
|
- #'
+ #' `list(searching = FALSE, pageLength = 30, lengthMenu = c(5, 15, 30, 100), scrollX = TRUE)`
|
| 27 |
|
- #' # Module specification used in apps below
+ #' @param server_rendering (`logical`) should the data table be rendered server side
|
| 28 |
|
- #' tm_variable_browser_module <- tm_variable_browser(
+ #' (see `server` argument of [DT::renderDataTable()])
|
| 29 |
|
- #' label = "Variable browser",
+ #'
|
| 30 |
|
- #' ggplot2_args = ggplot2_args(
+ #' @inherit shared_params return
|
| 31 |
|
- #' labs = list(subtitle = "Plot generated by Variable Browser Module")
+ #'
|
| 32 |
|
- #' )
+ #' @examplesShinylive
|
| 33 |
|
- #' )
+ #' library(teal.modules.general)
|
| 34 |
|
- #'
+ #' interactive <- function() TRUE
|
| 35 |
|
- #' # general data example
+ #' {{ next_example }}
|
| 36 |
|
- #' data <- teal_data()
+ #' @examples
|
| 37 |
|
- #' data <- within(data, {
+ #' # general data example
|
| 38 |
|
- #' iris <- iris
+ #' data <- teal_data()
|
| 39 |
|
- #' mtcars <- mtcars
+ #' data <- within(data, {
|
| 40 |
|
- #' women <- women
+ #' require(nestcolor)
|
| 41 |
|
- #' faithful <- faithful
+ #' iris <- iris
|
| 42 |
|
- #' CO2 <- CO2
+ #' })
|
| 43 |
|
- #' })
+ #' datanames(data) <- c("iris")
|
| 44 |
|
- #' datanames(data) <- c("iris", "mtcars", "women", "faithful", "CO2")
+ #'
|
| 45 |
|
- #'
+ #' app <- init(
|
| 46 |
|
- #' app <- init(
+ #' data = data,
|
| 47 |
|
- #' data = data,
+ #' modules = modules(
|
| 48 |
|
- #' modules = modules(tm_variable_browser_module)
+ #' tm_data_table(
|
| 49 |
|
- #' )
+ #' variables_selected = list(
|
| 50 |
|
- #' if (interactive()) {
+ #' iris = c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width", "Species")
|
| 51 |
|
- #' shinyApp(app$ui, app$server)
+ #' ),
|
| 52 |
|
- #' }
+ #' dt_args = list(caption = "IRIS Table Caption")
|
| 53 |
|
- #'
+ #' )
|
| 54 |
|
- #' # CDISC example data
+ #' )
|
| 55 |
|
- #' data <- teal_data()
+ #' )
|
| 56 |
|
- #' data <- within(data, {
+ #' if (interactive()) {
|
| 57 |
|
- #' ADSL <- rADSL
+ #' shinyApp(app$ui, app$server)
|
| 58 |
|
- #' ADTTE <- rADTTE
+ #' }
|
| 59 |
|
- #' })
+ #'
|
| 60 |
|
- #' datanames(data) <- c("ADSL", "ADTTE")
+ #' @examplesShinylive
|
| 61 |
|
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
+ #' library(teal.modules.general)
|
| 62 |
|
- #'
+ #' interactive <- function() TRUE
|
| 63 |
|
- #' app <- init(
+ #' {{ next_example }}
|
| 64 |
|
- #' data = data,
+ #' @examples
|
| 65 |
|
- #' modules = modules(tm_variable_browser_module)
+ #' # CDISC data example
|
| 66 |
|
- #' )
+ #' data <- teal_data()
|
| 67 |
|
- #' if (interactive()) {
+ #' data <- within(data, {
|
| 68 |
|
- #' shinyApp(app$ui, app$server)
+ #' require(nestcolor)
|
| 69 |
|
- #' }
+ #' ADSL <- rADSL
|
| 70 |
|
- #'
+ #' })
|
| 71 |
|
- #' @export
+ #' datanames(data) <- "ADSL"
|
| 72 |
|
- #'
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
|
| 73 |
|
- tm_variable_browser <- function(label = "Variable Browser",
+ #'
|
| 74 |
|
- datasets_selected = character(0),
+ #' app <- init(
|
| 75 |
|
- parent_dataname = "ADSL",
+ #' data = data,
|
| 76 |
|
- pre_output = NULL,
+ #' modules = modules(
|
| 77 |
|
- post_output = NULL,
+ #' tm_data_table(
|
| 78 |
|
- ggplot2_args = teal.widgets::ggplot2_args()) {
+ #' variables_selected = list(ADSL = c("STUDYID", "USUBJID", "SUBJID", "SITEID", "AGE", "SEX")),
|
-
+
| 79 |
- ! |
+ |
- message("Initializing tm_variable_browser")
+ #' dt_args = list(caption = "ADSL Table Caption")
|
| 80 |
|
-
+ #' )
|
| 81 |
|
- # Requires Suggested packages
+ #' )
|
-
+
| 82 |
- ! |
+ |
- if (!requireNamespace("sparkline", quietly = TRUE)) {
+ #' )
|
-
+
| 83 |
- ! |
+ |
- stop("Cannot load sparkline - please install the package or restart your session.")
+ #' if (interactive()) {
|
| 84 |
|
- }
+ #' shinyApp(app$ui, app$server)
|
-
+
| 85 |
- ! |
+ |
- if (!requireNamespace("htmlwidgets", quietly = TRUE)) {
+ #' }
|
-
+
| 86 |
- ! |
+ |
- stop("Cannot load htmlwidgets - please install the package or restart your session.")
+ #'
|
| 87 |
|
- }
+ #' @export
|
-
+
| 88 |
- ! |
+ |
- if (!requireNamespace("jsonlite", quietly = TRUE)) {
+ #'
|
-
+
| 89 |
- ! |
+ |
- stop("Cannot load jsonlite - please install the package or restart your session.")
+ tm_data_table <- function(label = "Data Table",
|
| 90 |
|
- }
+ variables_selected = list(),
|
| 91 |
|
-
+ datasets_selected = character(0),
|
| 92 |
|
- # Start of assertions
+ dt_args = list(),
|
-
+
| 93 |
- ! |
+ |
- checkmate::assert_string(label)
+ dt_options = list(
|
-
+
| 94 |
- ! |
+ |
- checkmate::assert_character(datasets_selected)
+ searching = FALSE,
|
-
+
| 95 |
- ! |
+ |
- checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1)
+ pageLength = 30,
|
-
+
| 96 |
- ! |
+ |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ lengthMenu = c(5, 15, 30, 100),
|
-
+
| 97 |
- ! |
+ |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ scrollX = TRUE
|
-
+
| 98 |
- ! |
+ |
- checkmate::assert_class(ggplot2_args, "ggplot2_args")
+ ),
|
| 99 |
|
- # End of assertions
+ server_rendering = FALSE,
|
| 100 |
|
-
+ pre_output = NULL,
|
-
+
| 101 |
- ! |
+ |
- datasets_selected <- unique(datasets_selected)
+ post_output = NULL) {
|
-
+
| 102 |
- |
+ ! |
-
+ message("Initializing tm_data_table")
|
-
+
| 103 |
- ! |
+ |
- ans <- module(
+
|
-
+
| 104 |
- ! |
+ |
- label,
+ # Start of assertions
|
| 105 |
! |
- server = srv_variable_browser,
+ checkmate::assert_string(label)
|
-
+
| 106 |
- ! |
+ |
- ui = ui_variable_browser,
+
|
| 107 |
! |
- datanames = "all",
+ checkmate::assert_list(variables_selected, min.len = 0, types = "character", names = "named")
|
| 108 |
! |
- server_args = list(
+ if (length(variables_selected) > 0) {
|
| 109 |
! |
- datasets_selected = datasets_selected,
+ lapply(seq_along(variables_selected), function(i) {
|
| 110 |
! |
- parent_dataname = parent_dataname,
+ checkmate::assert_character(variables_selected[[i]], min.chars = 1, min.len = 1)
|
| 111 |
! |
- ggplot2_args = ggplot2_args
+ if (!is.null(names(variables_selected[[i]]))) {
|
-
+
| 112 |
- |
+ ! |
- ),
+ checkmate::assert_names(names(variables_selected[[i]]))
|
-
+
| 113 |
- ! |
+ |
- ui_args = list(
+ }
|
-
+
| 114 |
- ! |
+ |
- pre_output = pre_output,
+ })
|
-
+
| 115 |
- ! |
+ |
- post_output = post_output
+ }
|
| 116 |
|
- )
+
|
-
+
| 117 |
- |
+ ! |
- )
+ checkmate::assert_character(datasets_selected, min.len = 0, min.chars = 1)
|
-
+
| 118 |
- |
+ ! |
- # `shiny` inputs are stored properly but the majority of the module is state of `datatable` which is not stored.
+ checkmate::assert(
|
| 119 |
! |
- attr(ans, "teal_bookmarkable") <- NULL
+ checkmate::check_list(dt_args, len = 0),
|
| 120 |
! |
- ans
+ checkmate::check_subset(names(dt_args), choices = names(formals(DT::datatable)))
|
| 121 |
|
- }
+ )
|
-
+
| 122 |
- |
+ ! |
-
+ checkmate::assert_list(dt_options, names = "named")
|
-
+
| 123 |
- |
+ ! |
- # UI function for the variable browser module
+ checkmate::assert_flag(server_rendering)
|
-
+
| 124 |
- |
+ ! |
- ui_variable_browser <- function(id,
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
-
+
| 125 |
- |
+ ! |
- pre_output = NULL,
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 126 |
|
- post_output = NULL) {
+ # End of assertions
|
-
+
| 127 |
- ! |
+ |
- ns <- NS(id)
+
|
-
+
| 128 |
- |
+ ! |
-
+ ans <- module(
|
| 129 |
! |
- tagList(
+ label,
|
| 130 |
! |
- include_css_files("custom"),
+ server = srv_page_data_table,
|
| 131 |
! |
- shinyjs::useShinyjs(),
+ ui = ui_page_data_table,
|
| 132 |
! |
- teal.widgets::standard_layout(
+ datanames = if (length(datasets_selected) == 0) "all" else datasets_selected,
|
| 133 |
! |
- output = fluidRow(
+ server_args = list(
|
| 134 |
! |
- htmlwidgets::getDependency("sparkline"), # needed for sparklines to work
+ variables_selected = variables_selected,
|
| 135 |
! |
- column(
+ datasets_selected = datasets_selected,
|
| 136 |
! |
- 6,
+ dt_args = dt_args,
|
-
+
| 137 |
- |
+ ! |
- # variable browser
+ dt_options = dt_options,
|
| 138 |
! |
- teal.widgets::white_small_well(
+ server_rendering = server_rendering
|
-
+
| 139 |
- ! |
+ |
- uiOutput(ns("ui_variable_browser")),
+ ),
|
| 140 |
! |
- shinyjs::hidden({
+ ui_args = list(
|
| 141 |
! |
- checkboxInput(ns("show_parent_vars"), "Show parent dataset variables", value = FALSE)
+ pre_output = pre_output,
|
-
+
| 142 |
- |
+ ! |
- })
+ post_output = post_output
|
| 143 |
|
- )
+ )
|
| 144 |
|
- ),
+ )
|
| 145 |
! |
- column(
+ attr(ans, "teal_bookmarkable") <- TRUE
|
| 146 |
! |
- 6,
+ ans
|
-
+
| 147 |
- ! |
+ |
- teal.widgets::white_small_well(
+ }
|
| 148 |
|
- ### Reporter
+
|
-
+
| 149 |
- ! |
+ |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ # UI page module
|
| 150 |
|
- ###
+ ui_page_data_table <- function(id,
|
-
+
| 151 |
- ! |
+ |
- tags$div(
+ pre_output = NULL,
|
-
+
| 152 |
- ! |
+ |
- class = "block",
+ post_output = NULL) {
|
| 153 |
! |
- uiOutput(ns("ui_histogram_display"))
+ ns <- NS(id)
|
| 154 |
|
- ),
+
|
| 155 |
! |
- tags$div(
+ tagList(
|
| 156 |
! |
- class = "block",
+ include_css_files("custom"),
|
| 157 |
! |
- uiOutput(ns("ui_numeric_display"))
+ teal.widgets::standard_layout(
|
-
+
| 158 |
- |
+ ! |
- ),
+ output = teal.widgets::white_small_well(
|
| 159 |
! |
- teal.widgets::plot_with_settings_ui(ns("variable_plot")),
+ fluidRow(
|
| 160 |
! |
- tags$br(),
+ column(
|
-
+
| 161 |
- |
+ ! |
- # input user-defined text size
+ width = 12,
|
| 162 |
! |
- teal.widgets::panel_item(
+ checkboxInput(
|
| 163 |
! |
- title = "Plot settings",
+ ns("if_distinct"),
|
| 164 |
! |
- collapsed = TRUE,
+ "Show only distinct rows:",
|
| 165 |
! |
- selectInput(
+ value = FALSE
|
-
+
| 166 |
- ! |
+ |
- inputId = ns("ggplot_theme"), label = "ggplot2 theme",
+ )
|
-
+
| 167 |
- ! |
+ |
- choices = ggplot_themes,
+ )
|
-
+
| 168 |
- ! |
+ |
- selected = "grey"
+ ),
|
-
+
| 169 |
- |
+ ! |
- ),
+ fluidRow(
|
| 170 |
! |
- fluidRow(
+ class = "mb-8",
|
| 171 |
! |
- column(6, sliderInput(
+ column(
|
| 172 |
! |
- inputId = ns("font_size"), label = "font size",
+ width = 12,
|
| 173 |
! |
- min = 5L, max = 30L, value = 15L, step = 1L, ticks = FALSE
+ uiOutput(ns("dataset_table"))
|
| 174 |
|
- )),
+ )
|
-
+
| 175 |
- ! |
+ |
- column(6, sliderInput(
+ )
|
-
+
| 176 |
- ! |
+ |
- inputId = ns("label_rotation"), label = "rotate x labels",
+ ),
|
| 177 |
! |
- min = 0L, max = 90L, value = 45L, step = 1, ticks = FALSE
+ pre_output = pre_output,
|
-
+
| 178 |
- |
+ ! |
- ))
+ post_output = post_output
|
| 179 |
|
- )
+ )
|
| 180 |
|
- ),
+ )
|
-
+
| 181 |
- ! |
+ |
- tags$br(),
+ }
|
-
+
| 182 |
- ! |
+ |
- teal.widgets::get_dt_rows(ns("variable_summary_table"), ns("variable_summary_table_rows")),
+
|
-
+
| 183 |
- ! |
+ |
- DT::dataTableOutput(ns("variable_summary_table"))
+ # Server page module
|
| 184 |
|
- )
+ srv_page_data_table <- function(id,
|
| 185 |
|
- )
+ data,
|
| 186 |
|
- ),
+ datasets_selected,
|
-
+
| 187 |
- ! |
+ |
- pre_output = pre_output,
+ variables_selected,
|
-
+
| 188 |
- ! |
+ |
- post_output = post_output
+ dt_args,
|
| 189 |
|
- )
+ dt_options,
|
| 190 |
|
- )
+ server_rendering) {
|
-
+
| 191 |
- |
+ ! |
- }
+ checkmate::assert_class(data, "reactive")
|
-
+
| 192 |
- |
+ ! |
-
+ checkmate::assert_class(isolate(data()), "teal_data")
|
-
+
| 193 |
- |
+ ! |
- # Server function for the variable browser module
+ moduleServer(id, function(input, output, session) {
|
-
+
| 194 |
- |
+ ! |
- srv_variable_browser <- function(id,
+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
|
| 195 |
|
- data,
+
|
-
+
| 196 |
- |
+ ! |
- reporter,
+ if_filtered <- reactive(as.logical(input$if_filtered))
|
-
+
| 197 |
- |
+ ! |
- filter_panel_api,
+ if_distinct <- reactive(as.logical(input$if_distinct))
|
| 198 |
|
- datasets_selected, parent_dataname, ggplot2_args) {
+
|
| 199 |
! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
+ datanames <- isolate(teal.data::datanames(data()))
|
| 200 |
! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
+ datanames <- Filter(function(name) {
|
| 201 |
! |
- checkmate::assert_class(data, "reactive")
+ is.data.frame(isolate(data())[[name]])
|
| 202 |
! |
- checkmate::assert_class(isolate(data()), "teal_data")
+ }, datanames)
|
-
+
| 203 |
- ! |
+ |
- moduleServer(id, function(input, output, session) {
+
|
| 204 |
! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
+ if (!identical(datasets_selected, character(0))) {
|
-
+
| 205 |
- |
+ ! |
-
+ checkmate::assert_subset(datasets_selected, datanames)
|
-
+
| 206 |
- |
+ ! |
- # if there are < this number of unique records then a numeric
+ datanames <- datasets_selected
|
| 207 |
|
- # variable can be treated as a factor and all factors with < this groups
+ }
|
| 208 |
|
- # have their values plotted
+
|
| 209 |
! |
- .unique_records_for_factor <- 30
+ output$dataset_table <- renderUI({
|
-
+
| 210 |
- |
+ ! |
- # if there are < this number of unique records then a numeric
+ do.call(
|
-
+
| 211 |
- |
+ ! |
- # variable is by default treated as a factor
+ tabsetPanel,
|
| 212 |
! |
- .unique_records_default_as_factor <- 6 # nolint: object_length.
+ c(
|
-
+
| 213 |
- |
+ ! |
-
+ list(id = session$ns("dataname_tab")),
|
| 214 |
! |
- varname_numeric_as_factor <- reactiveValues()
+ lapply(
|
-
+
| 215 |
- |
+ ! |
-
+ datanames,
|
| 216 |
! |
- datanames <- isolate(teal.data::datanames(data()))
+ function(x) {
|
| 217 |
! |
- datanames <- Filter(function(name) {
+ dataset <- isolate(data()[[x]])
|
| 218 |
! |
- is.data.frame(isolate(data())[[name]])
+ choices <- names(dataset)
|
| 219 |
! |
- }, datanames)
+ labels <- vapply(
|
-
+
| 220 |
- |
+ ! |
-
+ dataset,
|
| 221 |
! |
- checkmate::assert_character(datasets_selected)
+ function(x) ifelse(is.null(attr(x, "label")), "", attr(x, "label")),
|
| 222 |
! |
- checkmate::assert_subset(datasets_selected, datanames)
+ character(1)
|
-
+
| 223 |
- ! |
+ |
- if (!identical(datasets_selected, character(0))) {
+ )
|
| 224 |
! |
- checkmate::assert_subset(datasets_selected, datanames)
+ names(choices) <- ifelse(
|
| 225 |
! |
- datanames <- datasets_selected
+ is.na(labels) | labels == "",
|
-
+
| 226 |
- |
+ ! |
- }
+ choices,
|
-
+
| 227 |
- |
+ ! |
-
+ paste(choices, labels, sep = ": ")
|
-
+
| 228 |
- ! |
+ |
- output$ui_variable_browser <- renderUI({
+ )
|
| 229 |
! |
- ns <- session$ns
+ variables_selected <- if (!is.null(variables_selected[[x]])) {
|
| 230 |
! |
- do.call(
+ variables_selected[[x]]
|
-
+
| 231 |
- ! |
+ |
- tabsetPanel,
+ } else {
|
| 232 |
! |
- c(
+ utils::head(choices)
|
-
+
| 233 |
- ! |
+ |
- id = ns("tabset_panel"),
+ }
|
| 234 |
! |
- do.call(
+ tabPanel(
|
| 235 |
! |
- tagList,
+ title = x,
|
| 236 |
! |
- lapply(datanames, function(dataname) {
+ column(
|
| 237 |
! |
- tabPanel(
+ width = 12,
|
| 238 |
! |
- dataname,
+ div(
|
| 239 |
! |
- tags$div(
+ class = "mt-4",
|
| 240 |
! |
- class = "mt-4",
+ ui_data_table(
|
| 241 |
! |
- textOutput(ns(paste0("dataset_summary_", dataname)))
+ id = session$ns(x),
|
-
+
| 242 |
- |
+ ! |
- ),
+ choices = choices,
|
| 243 |
! |
- tags$div(
+ selected = variables_selected
|
-
+
| 244 |
- ! |
+ |
- class = "mt-4",
+ )
|
-
+
| 245 |
- ! |
+ |
- teal.widgets::get_dt_rows(
+ )
|
-
+
| 246 |
- ! |
+ |
- ns(paste0("variable_browser_", dataname)),
+ )
|
-
+
| 247 |
- ! |
+ |
- ns(paste0("variable_browser_", dataname, "_rows"))
+ )
|
| 248 |
|
- ),
+ }
|
-
+
| 249 |
- ! |
+ |
- DT::dataTableOutput(ns(paste0("variable_browser_", dataname)), width = "100%")
+ )
|
| 250 |
|
- )
+ )
|
| 251 |
|
- )
+ )
|
| 252 |
|
- })
+ })
|
| 253 |
|
- )
+
|
-
+
| 254 |
- |
+ ! |
- )
+ lapply(
|
-
+
| 255 |
- |
+ ! |
- )
+ datanames,
|
-
+
| 256 |
- |
+ ! |
- })
+ function(x) {
|
-
+
| 257 |
- |
+ ! |
-
+ srv_data_table(
|
-
+
| 258 |
- |
+ ! |
- # conditionally display checkbox
+ id = x,
|
| 259 |
! |
- shinyjs::toggle(
+ data = data,
|
| 260 |
! |
- id = "show_parent_vars",
+ dataname = x,
|
| 261 |
! |
- condition = length(parent_dataname) > 0 && parent_dataname %in% datanames
+ if_filtered = if_filtered,
|
-
+
| 262 |
- |
+ ! |
- )
+ if_distinct = if_distinct,
|
-
+
| 263 |
- |
+ ! |
-
+ dt_args = dt_args,
|
| 264 |
! |
- columns_names <- new.env()
+ dt_options = dt_options,
|
-
+
| 265 |
- |
+ ! |
-
+ server_rendering = server_rendering
|
| 266 |
|
- # plot_var$data holds the name of the currently selected dataset
+ )
|
| 267 |
|
- # plot_var$variable[[<dataset_name>]] holds the name of the currently selected
+ }
|
| 268 |
|
- # variable for dataset <dataset_name>
+ )
|
-
+
| 269 |
- ! |
+ |
- plot_var <- reactiveValues(data = NULL, variable = list())
+ })
|
| 270 |
|
-
+ }
|
-
+
| 271 |
- ! |
+ |
- establish_updating_selection(datanames, input, plot_var, columns_names)
+
|
| 272 |
|
-
+ # UI function for the data_table module
|
| 273 |
|
- # validations
+ ui_data_table <- function(id,
|
-
+
| 274 |
- ! |
+ |
- validation_checks <- validate_input(input, plot_var, data)
+ choices,
|
| 275 |
|
-
+ selected) {
|
-
+
| 276 |
- |
+ ! |
- # data_for_analysis is a list with two elements: a column from a dataset and the column label
+ ns <- NS(id)
|
-
+
| 277 |
- ! |
+ |
- plotted_data <- reactive({
+
|
| 278 |
! |
- validation_checks()
+ if (!is.null(selected)) {
|
-
+
| 279 |
- |
+ ! |
-
+ all_choices <- choices
|
| 280 |
! |
- get_plotted_data(input, plot_var, data)
+ choices <- c(selected, setdiff(choices, selected))
|
-
+
| 281 |
- |
+ ! |
- })
+ names(choices) <- names(all_choices)[match(choices, all_choices)]
|
| 282 |
|
-
+ }
|
-
+
| 283 |
- ! |
+ |
- treat_numeric_as_factor <- reactive({
+
|
| 284 |
! |
- if (is_num_var_short(.unique_records_for_factor, input, plotted_data)) {
+ tagList(
|
| 285 |
! |
- input$numeric_as_factor
+ teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")),
|
-
+
| 286 |
- |
+ ! |
- } else {
+ fluidRow(
|
| 287 |
! |
- FALSE
+ teal.widgets::optionalSelectInput(
|
-
+
| 288 |
- |
+ ! |
- }
+ ns("variables"),
|
-
+
| 289 |
- |
+ ! |
- })
+ "Select variables:",
|
-
+
| 290 |
- |
+ ! |
-
+ choices = choices,
|
| 291 |
! |
- render_tabset_panel_content(
+ selected = selected,
|
| 292 |
! |
- input = input,
+ multiple = TRUE,
|
| 293 |
! |
- output = output,
+ width = "100%"
|
-
+
| 294 |
- ! |
+ |
- data = data,
+ )
|
-
+
| 295 |
- ! |
+ |
- datanames = datanames,
+ ),
|
| 296 |
! |
- parent_dataname = parent_dataname,
+ fluidRow(
|
| 297 |
! |
- columns_names = columns_names,
+ DT::dataTableOutput(ns("data_table"), width = "100%")
|
-
+
| 298 |
- ! |
+ |
- plot_var = plot_var
+ )
|
| 299 |
|
- )
+ )
|
| 300 |
|
- # add used-defined text size to ggplot arguments passed from caller frame
+ }
|
-
+
| 301 |
- ! |
+ |
- all_ggplot2_args <- reactive({
+
|
-
+
| 302 |
- ! |
+ |
- user_text <- teal.widgets::ggplot2_args(
+ # Server function for the data_table module
|
-
+
| 303 |
- ! |
+ |
- theme = list(
+ srv_data_table <- function(id,
|
-
+
| 304 |
- ! |
+ |
- "text" = ggplot2::element_text(size = input[["font_size"]]),
+ data,
|
-
+
| 305 |
- ! |
+ |
- "axis.text.x" = ggplot2::element_text(angle = input[["label_rotation"]], hjust = 1)
+ dataname,
|
| 306 |
|
- )
+ if_filtered,
|
| 307 |
|
- )
+ if_distinct,
|
-
+
| 308 |
- ! |
+ |
- user_theme <- utils::getFromNamespace(sprintf("theme_%s", input[["ggplot_theme"]]), ns = "ggplot2")
+ dt_args,
|
-
+
| 309 |
- ! |
+ |
- user_theme <- user_theme()
+ dt_options,
|
| 310 |
|
- # temporary fix to circumvent assertion issue with resolve_ggplot2_args
+ server_rendering) {
|
-
+
| 311 |
- |
+ ! |
- # drop problematic elements
+ moduleServer(id, function(input, output, session) {
|
| 312 |
! |
- user_theme <- user_theme[grep("strip.text.y.left", names(user_theme), fixed = TRUE, invert = TRUE)]
+ iv <- shinyvalidate::InputValidator$new()
|
-
+
| 313 |
- |
+ ! |
-
+ iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names"))
|
| 314 |
! |
- teal.widgets::resolve_ggplot2_args(
+ iv$add_rule("variables", shinyvalidate::sv_in_set(
|
| 315 |
! |
- user_plot = user_text,
+ set = names(isolate(data())[[dataname]]), message_fmt = "Not all selected variables exist in the data"
|
-
+
| 316 |
- ! |
+ |
- user_default = teal.widgets::ggplot2_args(theme = user_theme),
+ ))
|
| 317 |
! |
- module_plot = ggplot2_args
+ iv$enable()
|
| 318 |
|
- )
+
|
-
+
| 319 |
- |
+ ! |
- })
+ output$data_table <- DT::renderDataTable(server = server_rendering, {
|
-
+
| 320 |
- |
+ ! |
-
+ teal::validate_inputs(iv)
|
-
+
| 321 |
- ! |
+ |
- output$ui_numeric_display <- renderUI({
+
|
| 322 |
! |
- validation_checks()
+ df <- data()[[dataname]]
|
| 323 |
! |
- dataname <- input$tabset_panel
+ variables <- input$variables
|
-
+
| 324 |
- ! |
+ |
- varname <- plot_var$variable[[dataname]]
+
|
| 325 |
! |
- df <- data()[[dataname]]
+ teal::validate_has_data(df, min_nrow = 1L, msg = paste("data", dataname, "is empty"))
|
@@ -44311,19692 +44535,19831 @@ teal.modules.general coverage - 3.44%
327 |
! |
- numeric_ui <- tagList(
+ dataframe_selected <- if (if_distinct()) {
|
| 328 |
! |
- fluidRow(
+ dplyr::count(df, dplyr::across(dplyr::all_of(variables)))
|
-
+
| 329 |
- ! |
+ |
- tags$div(
+ } else {
|
| 330 |
! |
- class = "col-md-4",
+ df[variables]
|
-
+
| 331 |
- ! |
+ |
- tags$br(),
+ }
|
-
+
| 332 |
- ! |
+ |
- shinyWidgets::switchInput(
+
|
| 333 |
! |
- inputId = session$ns("display_density"),
+ dt_args$options <- dt_options
|
| 334 |
! |
- label = "Show density",
+ if (!is.null(input$dt_rows)) {
|
| 335 |
! |
- value = `if`(is.null(isolate(input$display_density)), TRUE, isolate(input$display_density)),
+ dt_args$options$pageLength <- input$dt_rows
|
-
+
| 336 |
- ! |
+ |
- width = "50%",
+ }
|
| 337 |
! |
- labelWidth = "100px",
+ dt_args$data <- dataframe_selected
|
-
+
| 338 |
- ! |
+ |
- handleWidth = "50px"
+
|
-
+
| 339 |
- |
+ ! |
- )
+ do.call(DT::datatable, dt_args)
|
| 340 |
|
- ),
+ })
|
-
+
| 341 |
- ! |
+ |
- tags$div(
+ })
|
-
+
| 342 |
- ! |
-
- class = "col-md-4",
- |
-
-
- | 343 |
- ! |
-
- tags$br(),
- |
-
-
- | 344 |
- ! |
-
- shinyWidgets::switchInput(
- |
-
-
- | 345 |
- ! |
-
- inputId = session$ns("remove_outliers"),
- |
-
-
- | 346 |
- ! |
-
- label = "Remove outliers",
- |
-
-
- | 347 |
- ! |
-
- value = `if`(is.null(isolate(input$remove_outliers)), FALSE, isolate(input$remove_outliers)),
- |
-
-
- | 348 |
- ! |
-
- width = "50%",
- |
-
-
- | 349 |
- ! |
-
- labelWidth = "100px",
- |
-
-
- | 350 |
- ! |
+ |
- handleWidth = "50px"
+ }
|
+
+
+
+
+
+
- | 351 |
+ 1 |
|
- )
+ #' `teal` module: Cross-table
|
- | 352 |
+ 2 |
|
- ),
- |
-
-
- | 353 |
- ! |
-
- tags$div(
- |
-
-
- | 354 |
- ! |
-
- class = "col-md-4",
- |
-
-
- | 355 |
- ! |
-
- uiOutput(session$ns("outlier_definition_slider_ui"))
+ #'
|
- | 356 |
+ 3 |
|
- )
+ #' Generates a simple cross-table of two variables from a dataset with custom
|
- | 357 |
+ 4 |
|
- ),
+ #' options for showing percentages and sub-totals.
|
-
- | 358 |
- ! |
+
+ | 5 |
+ |
- tags$div(
+ #'
|
-
- | 359 |
- ! |
+
+ | 6 |
+ |
- class = "ml-4",
+ #' @inheritParams teal::module
|
-
- | 360 |
- ! |
+
+ | 7 |
+ |
- uiOutput(session$ns("ui_density_help")),
+ #' @inheritParams shared_params
|
-
- | 361 |
- ! |
+
+ | 8 |
+ |
- uiOutput(session$ns("ui_outlier_help"))
+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)
|
- | 362 |
+ 9 |
|
- )
+ #' Object with all available choices with pre-selected option for variable X - row values.
|
- | 363 |
+ 10 |
|
- )
+ #' In case of `data_extract_spec` use `select_spec(..., ordered = TRUE)` if table elements should be
|
- | 364 |
+ 11 |
|
-
+ #' rendered according to selection order.
|
-
- | 365 |
- ! |
+
+ | 12 |
+ |
- observeEvent(input$numeric_as_factor, ignoreInit = TRUE, {
+ #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`)
|
-
- | 366 |
- ! |
+
+ | 13 |
+ |
- varname_numeric_as_factor[[plot_var$variable[[dataname]]]] <- input$numeric_as_factor
+ #' Object with all available choices with pre-selected option for variable Y - column values.
|
- | 367 |
+ 14 |
|
- })
+ #'
|
- | 368 |
+ 15 |
|
-
+ #' `data_extract_spec` must not allow multiple selection in this case.
|
-
- | 369 |
- ! |
+
+ | 16 |
+ |
- if (is.numeric(df[[varname]])) {
+ #' @param show_percentage (`logical(1)`)
|
-
- | 370 |
- ! |
+
+ | 17 |
+ |
- unique_entries <- length(unique(df[[varname]]))
+ #' Indicates whether to show percentages (relevant only when `x` is a `factor`).
|
-
- | 371 |
- ! |
+
+ | 18 |
+ |
- if (unique_entries < .unique_records_for_factor && unique_entries > 0) {
+ #' Defaults to `TRUE`.
|
-
- | 372 |
- ! |
+
+ | 19 |
+ |
- list(
+ #' @param show_total (`logical(1)`)
|
-
- | 373 |
- ! |
+
+ | 20 |
+ |
- checkboxInput(
+ #' Indicates whether to show total column.
|
-
- | 374 |
- ! |
+
+ | 21 |
+ |
- session$ns("numeric_as_factor"),
+ #' Defaults to `TRUE`.
|
-
- | 375 |
- ! |
+
+ | 22 |
+ |
- "Treat variable as factor",
+ #'
|
-
- | 376 |
- ! |
+
+ | 23 |
+ |
- value = `if`(
+ #' @note For more examples, please see the vignette "Using cross table" via
|
-
- | 377 |
- ! |
+
+ | 24 |
+ |
- is.null(varname_numeric_as_factor[[varname]]),
+ #' `vignette("using-cross-table", package = "teal.modules.general")`.
|
-
- | 378 |
- ! |
+
+ | 25 |
+ |
- unique_entries < .unique_records_default_as_factor,
+ #'
|
-
- | 379 |
- ! |
+
+ | 26 |
+ |
- varname_numeric_as_factor[[varname]]
+ #' @inherit shared_params return
|
- | 380 |
+ 27 |
|
- )
+ #'
|
- | 381 |
+ 28 |
|
- ),
+ #' @examplesShinylive
|
-
- | 382 |
- ! |
+
+ | 29 |
+ |
- conditionalPanel("!input.numeric_as_factor", ns = session$ns, numeric_ui)
+ #' library(teal.modules.general)
|
- | 383 |
+ 30 |
|
- )
+ #' interactive <- function() TRUE
|
-
- | 384 |
- ! |
+
+ | 31 |
+ |
- } else if (unique_entries > 0) {
+ #' {{ next_example }}
|
-
- | 385 |
- ! |
+
+ | 32 |
+ |
- numeric_ui
+ #' @examplesIf require("rtables", quietly = TRUE)
|
- | 386 |
+ 33 |
|
- }
+ #' # general data example
|
- | 387 |
+ 34 |
|
- } else {
+ #' data <- teal_data()
|
-
- | 388 |
- ! |
+
+ | 35 |
+ |
- NULL
+ #' data <- within(data, {
|
- | 389 |
+ 36 |
|
- }
+ #' mtcars <- mtcars
|
- | 390 |
+ 37 |
|
- })
+ #' for (v in c("cyl", "vs", "am", "gear")) {
|
- | 391 |
+ 38 |
|
-
+ #' mtcars[[v]] <- as.factor(mtcars[[v]])
|
-
- | 392 |
- ! |
+
+ | 39 |
+ |
- output$ui_histogram_display <- renderUI({
+ #' }
|
-
- | 393 |
- ! |
+
+ | 40 |
+ |
- validation_checks()
+ #' mtcars[["primary_key"]] <- seq_len(nrow(mtcars))
|
-
- | 394 |
- ! |
+
+ | 41 |
+ |
- dataname <- input$tabset_panel
+ #' })
|
-
- | 395 |
- ! |
+
+ | 42 |
+ |
- varname <- plot_var$variable[[dataname]]
+ #' datanames(data) <- "mtcars"
|
-
- | 396 |
- ! |
+
+ | 43 |
+ |
- df <- data()[[dataname]]
+ #' join_keys(data) <- join_keys(join_key("mtcars", "mtcars", "primary_key"))
|
- | 397 |
+ 44 |
|
-
+ #'
|
-
- | 398 |
- ! |
+
+ | 45 |
+ |
- numeric_ui <- tagList(fluidRow(
+ #' app <- init(
|
-
- | 399 |
- ! |
+
+ | 46 |
+ |
- tags$div(
+ #' data = data,
|
-
- | 400 |
- ! |
+
+ | 47 |
+ |
- class = "col-md-4",
+ #' modules = modules(
|
-
- | 401 |
- ! |
+
+ | 48 |
+ |
- shinyWidgets::switchInput(
+ #' tm_t_crosstable(
|
-
- | 402 |
- ! |
+
+ | 49 |
+ |
- inputId = session$ns("remove_NA_hist"),
+ #' label = "Cross Table",
|
-
- | 403 |
- ! |
+
+ | 50 |
+ |
- label = "Remove NA values",
+ #' x = data_extract_spec(
|
-
- | 404 |
- ! |
+
+ | 51 |
+ |
- value = FALSE,
+ #' dataname = "mtcars",
|
-
- | 405 |
- ! |
+
+ | 52 |
+ |
- width = "50%",
+ #' select = select_spec(
|
-
- | 406 |
- ! |
+
+ | 53 |
+ |
- labelWidth = "100px",
+ #' label = "Select variable:",
|
-
- | 407 |
- ! |
+
+ | 54 |
+ |
- handleWidth = "50px"
+ #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
|
- | 408 |
+ 55 |
|
- )
+ #' selected = c("cyl", "gear"),
|
- | 409 |
+ 56 |
|
- )
+ #' multiple = TRUE,
|
- | 410 |
+ 57 |
|
- ))
+ #' ordered = TRUE,
|
- | 411 |
+ 58 |
|
-
+ #' fixed = FALSE
|
-
- | 412 |
- ! |
+
+ | 59 |
+ |
- var <- df[[varname]]
+ #' )
|
-
- | 413 |
- ! |
+
+ | 60 |
+ |
- if (anyNA(var) && (is.factor(var) || is.character(var) || is.logical(var))) {
+ #' ),
|
-
- | 414 |
- ! |
+
+ | 61 |
+ |
- groups <- unique(as.character(var))
+ #' y = data_extract_spec(
|
-
- | 415 |
- ! |
+
+ | 62 |
+ |
- len_groups <- length(groups)
+ #' dataname = "mtcars",
|
-
- | 416 |
- ! |
+
+ | 63 |
+ |
- if (len_groups >= .unique_records_for_factor) {
+ #' select = select_spec(
|
-
- | 417 |
- ! |
+
+ | 64 |
+ |
- NULL
+ #' label = "Select variable:",
|
- | 418 |
+ 65 |
|
- } else {
+ #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
|
-
- | 419 |
- ! |
+
+ | 66 |
+ |
- numeric_ui
+ #' selected = "vs",
|
- | 420 |
+ 67 |
|
- }
+ #' multiple = FALSE,
|
- | 421 |
+ 68 |
|
- } else {
+ #' fixed = FALSE
|
-
- | 422 |
- ! |
+
+ | 69 |
+ |
- NULL
+ #' )
|
- | 423 |
+ 70 |
|
- }
+ #' )
|
- | 424 |
+ 71 |
|
- })
+ #' )
|
- | 425 |
+ 72 |
|
-
+ #' )
|
-
- | 426 |
- ! |
+
+ | 73 |
+ |
- output$outlier_definition_slider_ui <- renderUI({
+ #' )
|
-
- | 427 |
- ! |
+
+ | 74 |
+ |
- req(input$remove_outliers)
+ #' if (interactive()) {
|
-
- | 428 |
- ! |
+
+ | 75 |
+ |
- sliderInput(
+ #' shinyApp(app$ui, app$server)
|
-
- | 429 |
- ! |
+
+ | 76 |
+ |
- inputId = session$ns("outlier_definition_slider"),
+ #' }
|
-
- | 430 |
- ! |
+
+ | 77 |
+ |
- tags$div(
+ #'
|
-
- | 431 |
- ! |
+
+ | 78 |
+ |
- class = "teal-tooltip",
+ #' @examplesShinylive
|
-
- | 432 |
- ! |
+
+ | 79 |
+ |
- tagList(
+ #' library(teal.modules.general)
|
-
- | 433 |
- ! |
+
+ | 80 |
+ |
- "Outlier definition:",
+ #' interactive <- function() TRUE
|
-
- | 434 |
- ! |
+
+ | 81 |
+ |
- icon("circle-info"),
+ #' {{ next_example }}
|
-
- | 435 |
- ! |
+
+ | 82 |
+ |
- tags$span(
+ #' @examplesIf require("rtables", quietly = TRUE)
|
-
- | 436 |
- ! |
+
+ | 83 |
+ |
- class = "tooltiptext",
+ #' # CDISC data example
|
-
- | 437 |
- ! |
+
+ | 84 |
+ |
- paste(
+ #' data <- teal_data()
|
-
- | 438 |
- ! |
+
+ | 85 |
+ |
- "Use the slider to choose the cut-off value to define outliers; the larger the value the",
+ #' data <- within(data, {
|
-
- | 439 |
- ! |
+
+ | 86 |
+ |
- "further below Q1/above Q3 points have to be in order to be classed as outliers"
+ #' ADSL <- rADSL
|
- | 440 |
+ 87 |
|
- )
+ #' })
|
- | 441 |
+ 88 |
|
- )
+ #' datanames(data) <- "ADSL"
|
- | 442 |
+ 89 |
|
- )
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
|
- | 443 |
+ 90 |
|
- ),
+ #'
|
-
- | 444 |
- ! |
+
+ | 91 |
+ |
- min = 1,
+ #' app <- init(
|
-
- | 445 |
- ! |
+
+ | 92 |
+ |
- max = 5,
+ #' data = data,
|
-
- | 446 |
- ! |
+
+ | 93 |
+ |
- value = 3,
+ #' modules = modules(
|
-
- | 447 |
- ! |
+
+ | 94 |
+ |
- step = 0.5
+ #' tm_t_crosstable(
|
- | 448 |
+ 95 |
|
- )
+ #' label = "Cross Table",
|
- | 449 |
+ 96 |
|
- })
+ #' x = data_extract_spec(
|
- | 450 |
+ 97 |
|
-
+ #' dataname = "ADSL",
|
-
- | 451 |
- ! |
+
+ | 98 |
+ |
- output$ui_density_help <- renderUI({
+ #' select = select_spec(
|
-
- | 452 |
- ! |
+
+ | 99 |
+ |
- req(is.logical(input$display_density))
+ #' label = "Select variable:",
|
-
- | 453 |
- ! |
+
+ | 100 |
+ |
- if (input$display_density) {
+ #' choices = variable_choices(data[["ADSL"]], subset = function(data) {
|
-
- | 454 |
- ! |
+
+ | 101 |
+ |
- tags$small(helpText(paste(
+ #' idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt"))
|
-
- | 455 |
- ! |
+
+ | 102 |
+ |
- "Kernel density estimation with gaussian kernel",
+ #' return(names(data)[idx])
|
-
- | 456 |
- ! |
+
+ | 103 |
+ |
- "and bandwidth function bw.nrd0 (R default)"
+ #' }),
|
- | 457 |
+ 104 |
|
- )))
+ #' selected = "COUNTRY",
|
- | 458 |
+ 105 |
|
- } else {
+ #' multiple = TRUE,
|
-
- | 459 |
- ! |
+
+ | 106 |
+ |
- NULL
+ #' ordered = TRUE,
|
- | 460 |
+ 107 |
|
- }
+ #' fixed = FALSE
|
- | 461 |
+ 108 |
|
- })
+ #' )
|
- | 462 |
+ 109 |
|
-
+ #' ),
|
-
- | 463 |
- ! |
+
+ | 110 |
+ |
- output$ui_outlier_help <- renderUI({
+ #' y = data_extract_spec(
|
-
- | 464 |
- ! |
+
+ | 111 |
+ |
- req(is.logical(input$remove_outliers), input$outlier_definition_slider)
+ #' dataname = "ADSL",
|
-
- | 465 |
- ! |
+
+ | 112 |
+ |
- if (input$remove_outliers) {
+ #' select = select_spec(
|
-
- | 466 |
- ! |
+
+ | 113 |
+ |
- tags$small(
+ #' label = "Select variable:",
|
-
- | 467 |
- ! |
+
+ | 114 |
+ |
- helpText(
+ #' choices = variable_choices(data[["ADSL"]], subset = function(data) {
|
-
- | 468 |
- ! |
+
+ | 115 |
+ |
- withMathJax(paste0(
+ #' idx <- vapply(data, is.factor, logical(1))
|
-
- | 469 |
- ! |
+
+ | 116 |
+ |
- "Outlier data points (\\( X \\lt Q1 - ", input$outlier_definition_slider, "\\times IQR \\) or
+ #' return(names(data)[idx])
|
-
- | 470 |
- ! |
+
+ | 117 |
+ |
- \\(Q3 + ", input$outlier_definition_slider, "\\times IQR \\lt X\\))
+ #' }),
|
-
- | 471 |
- ! |
+
+ | 118 |
+ |
- have not been displayed on the graph and will not be used for any kernel density estimations, ",
+ #' selected = "SEX",
|
-
- | 472 |
- ! |
+
+ | 119 |
+ |
- "although their values remain in the statisics table below."
+ #' multiple = FALSE,
|
- | 473 |
+ 120 |
|
- ))
+ #' fixed = FALSE
|
- | 474 |
+ 121 |
|
- )
+ #' )
|
- | 475 |
+ 122 |
|
- )
+ #' )
|
- | 476 |
+ 123 |
|
- } else {
+ #' )
|
-
- | 477 |
- ! |
+
+ | 124 |
+ |
- NULL
+ #' )
|
- | 478 |
+ 125 |
|
- }
+ #' )
|
- | 479 |
+ 126 |
|
- })
+ #' if (interactive()) {
|
- | 480 |
+ 127 |
|
-
+ #' shinyApp(app$ui, app$server)
|
- | 481 |
+ 128 |
|
-
+ #' }
|
-
- | 482 |
- ! |
+
+ | 129 |
+ |
- variable_plot_r <- reactive({
+ #'
|
-
- | 483 |
- ! |
+
+ | 130 |
+ |
- display_density <- `if`(is.null(input$display_density), FALSE, input$display_density)
+ #' @export
|
-
- | 484 |
- ! |
+
+ | 131 |
+ |
- remove_outliers <- `if`(is.null(input$remove_outliers), FALSE, input$remove_outliers)
+ #'
|
- | 485 |
+ 132 |
|
-
+ tm_t_crosstable <- function(label = "Cross Table",
|
-
- | 486 |
- ! |
+
+ | 133 |
+ |
- if (remove_outliers) {
+ x,
|
-
- | 487 |
- ! |
+
+ | 134 |
+ |
- req(input$outlier_definition_slider)
+ y,
|
-
- | 488 |
- ! |
+
+ | 135 |
+ |
- outlier_definition <- as.numeric(input$outlier_definition_slider)
+ show_percentage = TRUE,
|
- | 489 |
+ 136 |
|
- } else {
+ show_total = TRUE,
|
-
- | 490 |
- ! |
+
+ | 137 |
+ |
- outlier_definition <- 0
+ pre_output = NULL,
|
- | 491 |
+ 138 |
|
- }
+ post_output = NULL,
|
- | 492 |
+ 139 |
|
-
+ basic_table_args = teal.widgets::basic_table_args()) {
|
- | 493 |
+ 140 |
! |
- plot_var_summary(
+ message("Initializing tm_t_crosstable")
|
-
- | 494 |
- ! |
+
+ | 141 |
+ |
- var = plotted_data()$data,
+
|
-
- | 495 |
- ! |
+
+ | 142 |
+ |
- var_lab = plotted_data()$var_description,
+ # Requires Suggested packages
|
- | 496 |
+ 143 |
! |
- wrap_character = 15,
+ if (!requireNamespace("rtables", quietly = TRUE)) {
|
- | 497 |
+ 144 |
! |
- numeric_as_factor = treat_numeric_as_factor(),
+ stop("Cannot load rtables - please install the package or restart your session.")
|
-
- | 498 |
- ! |
+
+ | 145 |
+ |
- remove_NA_hist = input$remove_NA_hist,
+ }
|
-
- | 499 |
- ! |
+
+ | 146 |
+ |
- display_density = display_density,
+
|
-
- | 500 |
- ! |
+
+ | 147 |
+ |
- outlier_definition = outlier_definition,
+ # Normalize the parameters
|
- | 501 |
+ 148 |
! |
- records_for_factor = .unique_records_for_factor,
+ if (inherits(x, "data_extract_spec")) x <- list(x)
|
- | 502 |
+ 149 |
! |
- ggplot2_args = all_ggplot2_args()
- |
-
-
- | 503 |
- |
-
- )
+ if (inherits(y, "data_extract_spec")) y <- list(y)
|
- | 504 |
+ 150 |
|
- })
+
|
- | 505 |
+ 151 |
|
-
- |
-
-
- | 506 |
- ! |
-
- pws <- teal.widgets::plot_with_settings_srv(
- |
-
-
- | 507 |
- ! |
-
- id = "variable_plot",
+ # Start of assertions
|
- | 508 |
+ 152 |
! |
- plot_r = variable_plot_r,
+ checkmate::assert_string(label)
|
- | 509 |
+ 153 |
! |
- height = c(500, 200, 2000)
- |
-
-
- | 510 |
- |
-
- )
+ checkmate::assert_list(x, types = "data_extract_spec")
|
- | 511 |
+ 154 |
|
|
- | 512 |
+ 155 |
! |
- output$variable_summary_table <- DT::renderDataTable({
+ checkmate::assert_list(y, types = "data_extract_spec")
|
- | 513 |
+ 156 |
! |
- var_summary_table(
+ assert_single_selection(y)
|
-
- | 514 |
- ! |
+
+ | 157 |
+ |
- plotted_data()$data,
+
|
- | 515 |
+ 158 |
! |
- treat_numeric_as_factor(),
+ checkmate::assert_flag(show_percentage)
|
- | 516 |
+ 159 |
! |
- input$variable_summary_table_rows,
+ checkmate::assert_flag(show_total)
|
- | 517 |
+ 160 |
! |
- if (!is.null(input$remove_outliers) && input$remove_outliers) {
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
- | 518 |
+ 161 |
! |
- req(input$outlier_definition_slider)
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
- | 519 |
+ 162 |
! |
- as.numeric(input$outlier_definition_slider)
+ checkmate::assert_class(basic_table_args, classes = "basic_table_args")
|
- | 520 |
+ 163 |
|
- } else {
- |
-
-
- | 521 |
- ! |
-
- 0
+ # End of assertions
|
- | 522 |
+ 164 |
|
- }
+
|
- | 523 |
+ 165 |
|
- )
+ # Make UI args
|
-
- | 524 |
- |
+
+ | 166 |
+ ! |
- })
+ ui_args <- as.list(environment())
|
- | 525 |
+ 167 |
|
|
-
- | 526 |
- |
-
- ### REPORTER
- |
-
- | 527 |
+ 168 |
! |
- if (with_reporter) {
+ server_args <- list(
|
- | 528 |
+ 169 |
! |
- card_fun <- function(comment) {
+ label = label,
|
- | 529 |
+ 170 |
! |
- card <- teal::TealReportCard$new()
+ x = x,
|
- | 530 |
+ 171 |
! |
- card$set_name("Variable Browser Plot")
+ y = y,
|
- | 531 |
+ 172 |
! |
- card$append_text("Variable Browser Plot", "header2")
+ basic_table_args = basic_table_args
|
-
- | 532 |
- ! |
+
+ | 173 |
+ |
- if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
+ )
|
-
- | 533 |
- ! |
+
+ | 174 |
+ |
- card$append_text("Plot", "header3")
+
|
- | 534 |
+ 175 |
! |
- card$append_plot(variable_plot_r(), dim = pws$dim())
+ ans <- module(
|
- | 535 |
+ 176 |
! |
- if (!comment == "") {
+ label = label,
|
- | 536 |
+ 177 |
! |
- card$append_text("Comment", "header3")
+ server = srv_t_crosstable,
|
- | 537 |
+ 178 |
! |
- card$append_text(comment)
- |
-
-
- | 538 |
- |
-
- }
+ ui = ui_t_crosstable,
|
- | 539 |
+ 179 |
! |
- card
+ ui_args = ui_args,
|
-
- | 540 |
- |
+
+ | 180 |
+ ! |
- }
+ server_args = server_args,
|
- | 541 |
+ 181 |
! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ datanames = teal.transform::get_extract_datanames(list(x = x, y = y))
|
- | 542 |
+ 182 |
|
- }
+ )
|
-
- | 543 |
- |
+
+ | 183 |
+ ! |
- ###
+ attr(ans, "teal_bookmarkable") <- TRUE
|
-
- | 544 |
- |
+
+ | 184 |
+ ! |
- })
+ ans
|
- | 545 |
+ 185 |
|
}
|
- | 546 |
+ 186 |
|
|
- | 547 |
- |
-
- #' Summarize NAs.
- |
-
-
- | 548 |
- |
-
- #'
- |
-
-
- | 549 |
- |
-
- #' Summarizes occurrence of missing values in vector.
- |
-
-
- | 550 |
- |
-
- #' @param x vector of any type and length
- |
-
-
- | 551 |
- |
-
- #' @return Character string describing `NA` occurrence.
- |
-
-
- | 552 |
+ 187 |
|
- #' @keywords internal
+ # UI function for the cross-table module
|
- | 553 |
+ 188 |
|
- var_missings_info <- function(x) {
+ ui_t_crosstable <- function(id, x, y, show_percentage, show_total, pre_output, post_output, ...) {
|
- | 554 |
+ 189 |
! |
- sprintf("%s [%s%%]", sum(is.na(x)), round(mean(is.na(x) * 100), 2))
+ ns <- NS(id)
|
-
- | 555 |
- |
+
+ | 190 |
+ ! |
- }
+ is_single_dataset <- teal.transform::is_single_dataset(x, y)
|
- | 556 |
+ 191 |
|
|
-
- | 557 |
- |
-
- #' Summarizes variable
- |
-
-
- | 558 |
- |
-
- #'
- |
-
-
- | 559 |
- |
-
- #' Creates html summary with statistics relevant to data type. For numeric values it returns central
- |
-
-
- | 560 |
- |
-
- #' tendency measures, for factor returns level counts, for Date date range, for other just
- |
-
-
- | 561 |
- |
-
- #' number of levels.
- |
-
-
- | 562 |
- |
+
+ | 192 |
+ ! |
- #'
+ join_default_options <- c(
|
-
- | 563 |
- |
+
+ | 193 |
+ ! |
- #' @param x vector of any type
+ "Full Join" = "dplyr::full_join",
|
-
- | 564 |
- |
+
+ | 194 |
+ ! |
- #' @param numeric_as_factor `logical` should the numeric variable be treated as a factor
+ "Inner Join" = "dplyr::inner_join",
|
-
- | 565 |
- |
+
+ | 195 |
+ ! |
- #' @param dt_rows `numeric` current/latest `DT` page length
+ "Left Join" = "dplyr::left_join",
|
-
- | 566 |
- |
+
+ | 196 |
+ ! |
- #' @param outlier_definition If 0 no outliers are removed, otherwise
+ "Right Join" = "dplyr::right_join"
|
- | 567 |
+ 197 |
|
- #' outliers (those more than `outlier_definition*IQR below/above Q1/Q3` be removed)
+ )
|
- | 568 |
+ 198 |
|
- #' @return text with simple statistics.
+
|
-
- | 569 |
- |
+
+ | 199 |
+ ! |
- #' @keywords internal
+ teal.widgets::standard_layout(
|
-
- | 570 |
- |
+
+ | 200 |
+ ! |
- var_summary_table <- function(x, numeric_as_factor, dt_rows, outlier_definition) {
+ output = teal.widgets::white_small_well(
|
- | 571 |
+ 201 |
! |
- if (is.null(dt_rows)) {
+ textOutput(ns("title")),
|
- | 572 |
+ 202 |
! |
- dt_rows <- 10
+ teal.widgets::table_with_settings_ui(ns("table"))
|
- | 573 |
+ 203 |
|
- }
+ ),
|
- | 574 |
+ 204 |
! |
- if (is.numeric(x) && !numeric_as_factor) {
+ encoding = tags$div(
+ |
+
+
+ | 205 |
+ |
+
+ ### Reporter
|
- | 575 |
+ 206 |
! |
- req(!any(is.infinite(x)))
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
- | 576 |
+ 207 |
|
-
+ ###
|
- | 577 |
+ 208 |
! |
- x <- remove_outliers_from(x, outlier_definition)
+ tags$label("Encodings", class = "text-primary"),
|
-
- | 578 |
- |
+
+ | 209 |
+ ! |
-
+ teal.transform::datanames_input(list(x, y)),
|
- | 579 |
+ 210 |
! |
- qvals <- round(stats::quantile(x, na.rm = TRUE, probs = c(0.25, 0.5, 0.75), type = 2), 2)
+ teal.transform::data_extract_ui(ns("x"), label = "Row values", x, is_single_dataset = is_single_dataset),
|
-
- | 580 |
- |
+
+ | 211 |
+ ! |
- # classical central tendency measures
+ teal.transform::data_extract_ui(ns("y"), label = "Column values", y, is_single_dataset = is_single_dataset),
|
-
- | 581 |
- |
+
+ | 212 |
+ ! |
-
+ teal.widgets::optionalSelectInput(
|
- | 582 |
+ 213 |
! |
- summary <-
+ ns("join_fun"),
|
- | 583 |
+ 214 |
! |
- data.frame(
+ label = "Row to Column type of join",
|
- | 584 |
+ 215 |
! |
- Statistic = c("min", "Q1", "median", "mean", "Q3", "max", "sd", "n"),
+ choices = join_default_options,
|
- | 585 |
+ 216 |
! |
- Value = c(
+ selected = join_default_options[1],
|
- | 586 |
+ 217 |
! |
- round(min(x, na.rm = TRUE), 2),
+ multiple = FALSE
|
-
- | 587 |
- ! |
+
+ | 218 |
+ |
- qvals[1],
+ ),
|
- | 588 |
+ 219 |
! |
- qvals[2],
+ tags$hr(),
|
- | 589 |
+ 220 |
! |
- round(mean(x, na.rm = TRUE), 2),
+ teal.widgets::panel_group(
|
- | 590 |
+ 221 |
! |
- qvals[3],
+ teal.widgets::panel_item(
|
- | 591 |
+ 222 |
! |
- round(max(x, na.rm = TRUE), 2),
+ title = "Table settings",
|
- | 592 |
+ 223 |
! |
- round(stats::sd(x, na.rm = TRUE), 2),
+ checkboxInput(ns("show_percentage"), "Show column percentage", value = show_percentage),
|
- | 593 |
+ 224 |
! |
- length(x[!is.na(x)])
+ checkboxInput(ns("show_total"), "Show total column", value = show_total)
|
- | 594 |
+ 225 |
|
)
|
- | 595 |
+ 226 |
|
)
|
- | 596 |
+ 227 |
|
-
+ ),
|
- | 597 |
+ 228 |
! |
- DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows))
+ forms = tagList(
|
- | 598 |
+ 229 |
! |
- } else if (is.factor(x) || is.character(x) || (is.numeric(x) && numeric_as_factor) || is.logical(x)) {
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
- | 599 |
+ 230 |
|
- # make sure factor is ordered numeric
+ ),
|
- | 600 |
+ 231 |
! |
- if (is.numeric(x)) {
+ pre_output = pre_output,
|
- | 601 |
+ 232 |
! |
- x <- factor(x, levels = sort(unique(x)))
+ post_output = post_output
|
- | 602 |
+ 233 |
|
- }
+ )
|
- | 603 |
+ 234 |
|
-
+ }
|
-
- | 604 |
- ! |
+
+ | 235 |
+ |
- level_counts <- table(x)
+
|
-
- | 605 |
- ! |
+
+ | 236 |
+ |
- max_levels_signif <- nchar(level_counts)
+ # Server function for the cross-table module
|
- | 606 |
+ 237 |
|
-
+ srv_t_crosstable <- function(id, data, reporter, filter_panel_api, label, x, y, basic_table_args) {
|
- | 607 |
+ 238 |
! |
- if (!all(is.na(x))) {
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
|
- | 608 |
+ 239 |
! |
- levels <- names(level_counts)
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
|
- | 609 |
+ 240 |
! |
- counts <- sprintf(
+ checkmate::assert_class(data, "reactive")
|
- | 610 |
+ 241 |
! |
- "%s [%.2f%%]",
+ checkmate::assert_class(isolate(data()), "teal_data")
|
- | 611 |
+ 242 |
! |
- format(level_counts, width = max_levels_signif), prop.table(level_counts) * 100
+ moduleServer(id, function(input, output, session) {
|
-
- | 612 |
- |
+
+ | 243 |
+ ! |
- )
+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
|
- | 613 |
+ 244 |
|
- } else {
+
|
- | 614 |
+ 245 |
! |
- levels <- character(0)
+ selector_list <- teal.transform::data_extract_multiple_srv(
|
- | 615 |
+ 246 |
! |
- counts <- numeric(0)
- |
-
-
- | 616 |
- |
-
- }
+ data_extract = list(x = x, y = y),
|
-
- | 617 |
- |
+
+ | 247 |
+ ! |
-
+ datasets = data,
|
- | 618 |
+ 248 |
! |
- summary <- data.frame(
+ select_validation_rule = list(
|
- | 619 |
+ 249 |
! |
- Level = levels,
+ x = shinyvalidate::sv_required("Please define column for row variable."),
|
- | 620 |
+ 250 |
! |
- Count = counts,
+ y = shinyvalidate::sv_required("Please define column for column variable.")
|
-
- | 621 |
- ! |
+
+ | 251 |
+ |
- stringsAsFactors = FALSE
+ )
|
- | 622 |
+ 252 |
|
)
|
- | 623 |
+ 253 |
|
|
-
- | 624 |
- |
+
+ | 254 |
+ ! |
- # sort the dataset in decreasing order of counts (needed as character variables default to alphabetical)
+ iv_r <- reactive({
|
- | 625 |
+ 255 |
! |
- summary <- summary[order(summary$Count, decreasing = TRUE), ]
+ iv <- shinyvalidate::InputValidator$new()
|
-
- | 626 |
- |
+
+ | 256 |
+ ! |
-
+ iv$add_rule("join_fun", function(value) {
|
- | 627 |
+ 257 |
! |
- dom_opts <- if (nrow(summary) <= 10) {
+ if (!identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
|
- | 628 |
+ 258 |
! |
- "<t>"
+ if (!shinyvalidate::input_provided(value)) {
+ |
+
+
+ | 259 |
+ ! |
+
+ "Please select a joining function."
|
- | 629 |
+ 260 |
|
- } else {
+ }
|
-
- | 630 |
- ! |
+
+ | 261 |
+ |
- "<lf<t>ip>"
+ }
|
- | 631 |
+ 262 |
|
- }
+ })
|
- | 632 |
+ 263 |
! |
- DT::datatable(summary, rownames = FALSE, options = list(dom = dom_opts, pageLength = dt_rows))
+ teal.transform::compose_and_enable_validators(iv, selector_list)
+ |
+
+
+ | 264 |
+ |
+
+ })
+ |
+
+
+ | 265 |
+ |
+
+
|
- | 633 |
+ 266 |
! |
- } else if (inherits(x, "Date") || inherits(x, "POSIXct") || inherits(x, "POSIXlt")) {
+ observeEvent(
|
- | 634 |
+ 267 |
! |
- summary <-
+ eventExpr = {
|
- | 635 |
+ 268 |
! |
- data.frame(
+ req(!is.null(selector_list()$x()) && !is.null(selector_list()$y()))
|
- | 636 |
+ 269 |
! |
- Statistic = c("min", "median", "max"),
+ list(selector_list()$x(), selector_list()$y())
+ |
+
+
+ | 270 |
+ |
+
+ },
|
- | 637 |
+ 271 |
! |
- Value = c(
+ handlerExpr = {
|
- | 638 |
+ 272 |
! |
- min(x, na.rm = TRUE),
+ if (identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
|
- | 639 |
+ 273 |
! |
- stats::median(x, na.rm = TRUE),
+ shinyjs::hide("join_fun")
+ |
+
+
+ | 274 |
+ |
+
+ } else {
|
- | 640 |
+ 275 |
! |
- max(x, na.rm = TRUE)
+ shinyjs::show("join_fun")
|
- | 641 |
+ 276 |
|
- )
+ }
|
- | 642 |
+ 277 |
|
- )
+ }
+ |
+
+
+ | 278 |
+ |
+
+ )
+ |
+
+
+ | 279 |
+ |
+
+
|
- | 643 |
+ 280 |
! |
- DT::datatable(summary, rownames = FALSE, options = list(dom = "<t>", pageLength = dt_rows))
+ merge_function <- reactive({
+ |
+
+
+ | 281 |
+ ! |
+
+ if (is.null(input$join_fun)) {
+ |
+
+
+ | 282 |
+ ! |
+
+ "dplyr::full_join"
|
- | 644 |
+ 283 |
|
- } else {
+ } else {
|
- | 645 |
+ 284 |
! |
- NULL
+ input$join_fun
|
- | 646 |
+ 285 |
|
- }
+ }
|
- | 647 |
+ 286 |
|
- }
+ })
|
- | 648 |
+ 287 |
|
|
-
- | 649 |
- |
+
+ | 288 |
+ ! |
- #' Plot variable
+ anl_merged_input <- teal.transform::merge_expression_srv(
|
-
- | 650 |
- |
+
+ | 289 |
+ ! |
- #'
+ datasets = data,
|
-
- | 651 |
- |
+
+ | 290 |
+ ! |
- #' Creates summary plot with statistics relevant to data type.
+ selector_list = selector_list,
|
-
- | 652 |
- |
+
+ | 291 |
+ ! |
- #'
+ merge_function = merge_function
|
- | 653 |
+ 292 |
|
- #' @inheritParams shared_params
+ )
|
- | 654 |
+ 293 |
|
- #' @param var vector of any type to be plotted. For numeric variables it produces histogram with
+
|
-
- | 655 |
- |
+
+ | 294 |
+ ! |
- #' density line, for factors it creates frequency plot
+ anl_merged_q <- reactive({
|
-
- | 656 |
- |
+
+ | 295 |
+ ! |
- #' @param var_lab text describing selected variable to be displayed on the plot
+ req(anl_merged_input())
|
-
- | 657 |
- |
+
+ | 296 |
+ ! |
- #' @param wrap_character (`numeric`) number of characters at which to wrap text values of `var`
+ data() %>%
|
-
- | 658 |
- |
+
+ | 297 |
+ ! |
- #' @param numeric_as_factor (`logical`) should the numeric variable be treated as a factor
+ teal.code::eval_code(as.expression(anl_merged_input()$expr))
|
- | 659 |
+ 298 |
|
- #' @param display_density (`logical`) should density estimation be displayed for numeric values
+ })
|
- | 660 |
+ 299 |
|
- #' @param remove_NA_hist (`logical`) should `NA` values be removed for histogram of factor like variables
+
|
-
- | 661 |
- |
+
+ | 300 |
+ ! |
- #' @param outlier_definition if 0 no outliers are removed, otherwise
+ merged <- list(
|
-
- | 662 |
- |
+
+ | 301 |
+ ! |
- #' outliers (those more than outlier_definition*IQR below/above Q1/Q3 be removed)
+ anl_input_r = anl_merged_input,
|
-
- | 663 |
- |
+
+ | 302 |
+ ! |
- #' @param records_for_factor (`numeric`) if the number of factor levels is >= than this value then
+ anl_q_r = anl_merged_q
|
- | 664 |
+ 303 |
|
- #' a graph of the factors isn't shown, only a list of values
+ )
|
- | 665 |
+ 304 |
|
- #'
+
|
-
- | 666 |
- |
+
+ | 305 |
+ ! |
- #' @return plot
+ output_q <- reactive({
|
-
- | 667 |
- |
+
+ | 306 |
+ ! |
- #' @keywords internal
+ teal::validate_inputs(iv_r())
|
-
- | 668 |
- |
+
+ | 307 |
+ ! |
- plot_var_summary <- function(var,
+ ANL <- merged$anl_q_r()[["ANL"]]
|
- | 669 |
+ 308 |
|
- var_lab,
+
|
- | 670 |
+ 309 |
|
- wrap_character = NULL,
+ # As this is a summary
|
-
- | 671 |
- |
+
+ | 310 |
+ ! |
- numeric_as_factor,
+ x_name <- as.vector(merged$anl_input_r()$columns_source$x)
|
-
- | 672 |
- |
+
+ | 311 |
+ ! |
- display_density = is.numeric(var),
+ y_name <- as.vector(merged$anl_input_r()$columns_source$y)
|
- | 673 |
+ 312 |
|
- remove_NA_hist = FALSE, # nolint: object_name.
+
|
-
- | 674 |
- |
+
+ | 313 |
+ ! |
- outlier_definition,
+ teal::validate_has_data(ANL, 3)
|
-
- | 675 |
- |
+
+ | 314 |
+ ! |
- records_for_factor,
+ teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE)
|
- | 676 |
+ 315 |
|
- ggplot2_args) {
+
|
- | 677 |
+ 316 |
! |
- checkmate::assert_character(var_lab)
+ is_allowed_class <- function(x) is.numeric(x) || is.factor(x) || is.character(x) || is.logical(x)
|
- | 678 |
+ 317 |
! |
- checkmate::assert_numeric(wrap_character, null.ok = TRUE)
+ validate(need(
|
- | 679 |
+ 318 |
! |
- checkmate::assert_flag(numeric_as_factor)
+ all(vapply(ANL[x_name], is_allowed_class, logical(1))),
|
- | 680 |
+ 319 |
! |
- checkmate::assert_flag(display_density)
+ "Selected row variable has an unsupported data type."
|
-
- | 681 |
- ! |
+
+ | 320 |
+ |
- checkmate::assert_logical(remove_NA_hist, null.ok = TRUE)
+ ))
|
- | 682 |
+ 321 |
! |
- checkmate::assert_number(outlier_definition, lower = 0, finite = TRUE)
+ validate(need(
|
- | 683 |
+ 322 |
! |
- checkmate::assert_integerish(records_for_factor, lower = 0, len = 1, any.missing = FALSE)
+ is_allowed_class(ANL[[y_name]]),
|
- | 684 |
+ 323 |
! |
- checkmate::assert_class(ggplot2_args, "ggplot2_args")
+ "Selected column variable has an unsupported data type."
|
- | 685 |
+ 324 |
|
-
- |
-
-
- | 686 |
- ! |
-
- grid::grid.newpage()
+ ))
|
- | 687 |
+ 325 |
|
|
- | 688 |
+ 326 |
! |
- plot_main <- if (is.factor(var) || is.character(var) || is.logical(var)) {
+ show_percentage <- input$show_percentage
|
- | 689 |
+ 327 |
! |
- groups <- unique(as.character(var))
+ show_total <- input$show_total
|
-
- | 690 |
- ! |
+
+ | 328 |
+ |
- len_groups <- length(groups)
+
|
- | 691 |
+ 329 |
! |
- if (len_groups >= records_for_factor) {
+ plot_title <- paste(
|
- | 692 |
+ 330 |
! |
- grid::textGrob(
+ "Cross-Table of",
|
- | 693 |
+ 331 |
! |
- sprintf(
+ paste0(varname_w_label(x_name, ANL), collapse = ", "),
|
- | 694 |
+ 332 |
! |
- "%s unique values\n%s:\n %s\n ...\n %s",
+ "(rows)", "vs.",
|
- | 695 |
+ 333 |
! |
- len_groups,
+ varname_w_label(y_name, ANL),
|
- | 696 |
+ 334 |
! |
- var_lab,
+ "(columns)"
|
-
- | 697 |
- ! |
+
+ | 335 |
+ |
- paste(utils::head(groups), collapse = ",\n "),
+ )
+ |
+
+
+ | 336 |
+ |
+
+
|
- | 698 |
+ 337 |
! |
- paste(utils::tail(groups), collapse = ",\n ")
+ labels_vec <- vapply(
|
-
- | 699 |
- |
+
+ | 338 |
+ ! |
- ),
+ x_name,
|
- | 700 |
+ 339 |
! |
- x = grid::unit(1, "line"),
+ varname_w_label,
|
- | 701 |
+ 340 |
! |
- y = grid::unit(1, "npc") - grid::unit(1, "line"),
+ character(1),
|
- | 702 |
+ 341 |
! |
- just = c("left", "top")
+ ANL
|
- | 703 |
+ 342 |
|
)
|
- | 704 |
+ 343 |
|
- } else {
+
|
- | 705 |
+ 344 |
! |
- if (!is.null(wrap_character)) {
+ teal.code::eval_code(
|
- | 706 |
+ 345 |
! |
- var <- stringr::str_wrap(var, width = wrap_character)
+ merged$anl_q_r(),
|
-
- | 707 |
- |
+
+ | 346 |
+ ! |
- }
+ substitute(
|
- | 708 |
+ 347 |
! |
- var <- if (isTRUE(remove_NA_hist)) as.vector(stats::na.omit(var)) else var
+ expr = {
|
- | 709 |
+ 348 |
! |
- ggplot(data.frame(var), aes(x = forcats::fct_infreq(as.factor(var)))) +
+ title <- plot_title
|
-
- | 710 |
- ! |
+
+ | 349 |
+ |
- geom_bar(
+ },
|
- | 711 |
+ 350 |
! |
- stat = "count", aes(fill = ifelse(is.na(var), "withcolor", "")), show.legend = FALSE
+ env = list(plot_title = plot_title)
|
- | 712 |
+ 351 |
|
- ) +
- |
-
-
- | 713 |
- ! |
-
- scale_fill_manual(values = c("gray50", "tan"))
+ )
|
- | 714 |
+ 352 |
|
- }
+ ) %>%
|
- | 715 |
+ 353 |
! |
- } else if (is.numeric(var)) {
+ teal.code::eval_code(
|
- | 716 |
+ 354 |
! |
- validate(need(any(!is.na(var)), "No data left to visualize."))
+ substitute(
|
-
- | 717 |
- |
+
+ | 355 |
+ ! |
-
+ expr = {
|
-
- | 718 |
- |
+
+ | 356 |
+ ! |
- # Filter out NA
+ lyt <- basic_tables %>%
|
- | 719 |
+ 357 |
! |
- var <- var[which(!is.na(var))]
+ split_call %>% # styler: off
|
-
- | 720 |
- |
+
+ | 358 |
+ ! |
-
+ rtables::add_colcounts() %>%
|
- | 721 |
+ 359 |
! |
- validate(need(!any(is.infinite(var)), "Cannot display graph when data includes infinite values"))
+ tern::analyze_vars(
|
-
- | 722 |
- |
+
+ | 360 |
+ ! |
-
+ vars = x_name,
|
- | 723 |
+ 361 |
! |
- if (numeric_as_factor) {
+ var_labels = labels_vec,
|
- | 724 |
+ 362 |
! |
- var <- factor(var)
+ na.rm = FALSE,
|
- | 725 |
+ 363 |
! |
- ggplot(NULL, aes(x = var)) +
+ denom = "N_col",
|
- | 726 |
+ 364 |
! |
- geom_histogram(stat = "count")
+ .stats = c("mean_sd", "median", "range", count_value)
|
- | 727 |
+ 365 |
|
- } else {
+ )
|
- | 728 |
+ 366 |
|
- # remove outliers
+ },
|
- | 729 |
+ 367 |
! |
- if (outlier_definition != 0) {
+ env = list(
|
- | 730 |
+ 368 |
! |
- number_records <- length(var)
+ basic_tables = teal.widgets::parse_basic_table_args(
|
- | 731 |
+ 369 |
! |
- var <- remove_outliers_from(var, outlier_definition)
+ basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args)
+ |
+
+
+ | 370 |
+ |
+
+ ),
|
- | 732 |
+ 371 |
! |
- number_outliers <- number_records - length(var)
+ split_call = if (show_total) {
|
- | 733 |
+ 372 |
! |
- outlier_text <- paste0(
+ substitute(
|
- | 734 |
+ 373 |
! |
- number_outliers, " outliers (",
+ expr = rtables::split_cols_by(
|
- | 735 |
+ 374 |
! |
- round(number_outliers / number_records * 100, 2),
+ y_name,
|
- | 736 |
+ 375 |
! |
- "% of non-missing records) not shown"
+ split_fun = rtables::add_overall_level(label = "Total", first = FALSE)
|
- | 737 |
+ 376 |
|
- )
+ ),
|
- | 738 |
+ 377 |
! |
- validate(need(
+ env = list(y_name = y_name)
+ |
+
+
+ | 378 |
+ |
+
+ )
+ |
+
+
+ | 379 |
+ |
+
+ } else {
|
- | 739 |
+ 380 |
! |
- length(var) > 1,
+ substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name))
+ |
+
+
+ | 381 |
+ |
+
+ },
|
- | 740 |
+ 382 |
! |
- "At least two data points must remain after removing outliers for this graph to be displayed"
+ x_name = x_name,
+ |
+
+
+ | 383 |
+ ! |
+
+ labels_vec = labels_vec,
+ |
+
+
+ | 384 |
+ ! |
+
+ count_value = ifelse(show_percentage, "count_fraction", "count")
|
- | 741 |
+ 385 |
|
- ))
+ )
|
- | 742 |
+ 386 |
|
- }
+ )
|
- | 743 |
+ 387 |
|
- ## histogram
+ ) %>%
|
- | 744 |
+ 388 |
! |
- binwidth <- get_bin_width(var)
+ teal.code::eval_code(
|
- | 745 |
+ 389 |
! |
- p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) +
+ substitute(
|
- | 746 |
+ 390 |
! |
- geom_histogram(binwidth = binwidth) +
+ expr = {
|
- | 747 |
+ 391 |
! |
- scale_y_continuous(
+ ANL <- tern::df_explicit_na(ANL)
|
- | 748 |
+ 392 |
! |
- sec.axis = sec_axis(
+ tbl <- rtables::build_table(lyt = lyt, df = ANL[order(ANL[[y_name]]), ])
|
- | 749 |
+ 393 |
! |
- trans = ~ . / nrow(data.frame(var = var)),
+ tbl
|
-
- | 750 |
- ! |
+
+ | 394 |
+ |
- labels = scales::percent,
+ },
|
- | 751 |
+ 395 |
! |
- name = "proportion (in %)"
+ env = list(y_name = y_name)
+ |
+
+
+ | 396 |
+ |
+
+ )
+ |
+
+
+ | 397 |
+ |
+
+ )
|
- | 752 |
+ 398 |
|
- )
+ })
|
- | 753 |
+ 399 |
|
- )
+
+ |
+
+
+ | 400 |
+ ! |
+
+ output$title <- renderText(output_q()[["title"]])
|
- | 754 |
+ 401 |
|
|
- | 755 |
+ 402 |
! |
- if (display_density) {
+ table_r <- reactive({
|
- | 756 |
+ 403 |
! |
- p <- p + geom_density(aes(y = after_stat(count * binwidth)))
+ req(iv_r()$is_valid())
+ |
+
+
+ | 404 |
+ ! |
+
+ output_q()[["tbl"]]
|
- | 757 |
+ 405 |
|
- }
+ })
|
- | 758 |
+ 406 |
|
|
- | 759 |
+ 407 |
! |
- if (outlier_definition != 0) {
+ teal.widgets::table_with_settings_srv(
|
- | 760 |
+ 408 |
! |
- p <- p + annotate(
+ id = "table",
|
- | 761 |
+ 409 |
! |
- geom = "text",
+ table_r = table_r
+ |
+
+
+ | 410 |
+ |
+
+ )
+ |
+
+
+ | 411 |
+ |
+
+
|
- | 762 |
+ 412 |
! |
- label = outlier_text,
+ teal.widgets::verbatim_popup_srv(
|
- | 763 |
+ 413 |
! |
- x = Inf, y = Inf,
+ id = "rcode",
|
- | 764 |
+ 414 |
! |
- hjust = 1.02, vjust = 1.2,
+ verbatim_content = reactive(teal.code::get_code(output_q())),
|
- | 765 |
+ 415 |
! |
- color = "black",
+ title = "Show R Code for Cross-Table"
|
- | 766 |
+ 416 |
|
- # explicitly modify geom text size according
- |
-
-
- | 767 |
- ! |
-
- size = ggplot2_args[["theme"]][["text"]][["size"]] / 3.5
+ )
|
- | 768 |
+ 417 |
|
- )
+
|
- | 769 |
+ 418 |
|
- }
+ ### REPORTER
|
- | 770 |
+ 419 |
! |
- p
+ if (with_reporter) {
|
-
- | 771 |
- |
+
+ | 420 |
+ ! |
- }
+ card_fun <- function(comment, label) {
|
- | 772 |
+ 421 |
! |
- } else if (inherits(var, "Date") || inherits(var, "POSIXct") || inherits(var, "POSIXlt")) {
+ card <- teal::report_card_template(
|
- | 773 |
+ 422 |
! |
- var_num <- as.numeric(var)
+ title = "Cross Table",
|
- | 774 |
+ 423 |
! |
- binwidth <- get_bin_width(var_num, 1)
+ label = label,
|
- | 775 |
+ 424 |
! |
- p <- ggplot(data = data.frame(var = var), aes(x = var, y = after_stat(count))) +
+ with_filter = with_filter,
|
- | 776 |
+ 425 |
! |
- geom_histogram(binwidth = binwidth)
+ filter_panel_api = filter_panel_api
|
- | 777 |
+ 426 |
|
- } else {
- |
-
-
- | 778 |
- ! |
-
- grid::textGrob(
+ )
|
- | 779 |
+ 427 |
! |
- paste(strwrap(
+ card$append_text("Table", "header3")
|
- | 780 |
+ 428 |
! |
- utils::capture.output(utils::str(var)),
+ card$append_table(table_r())
|
- | 781 |
+ 429 |
! |
- width = .9 * grid::convertWidth(grid::unit(1, "npc"), "char", TRUE)
+ if (!comment == "") {
|
- | 782 |
+ 430 |
! |
- ), collapse = "\n"),
+ card$append_text("Comment", "header3")
|
- | 783 |
+ 431 |
! |
- x = grid::unit(1, "line"), y = grid::unit(1, "npc") - grid::unit(1, "line"), just = c("left", "top")
+ card$append_text(comment)
|
- | 784 |
+ 432 |
|
- )
+ }
|
-
- | 785 |
- |
+
+ | 433 |
+ ! |
- }
+ card$append_src(teal.code::get_code(output_q()))
|
-
- | 786 |
- |
+
+ | 434 |
+ ! |
-
+ card
|
-
- | 787 |
- ! |
+
+ | 435 |
+ |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(
+ }
|
- | 788 |
+ 436 |
! |
- labs = list(x = var_lab)
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
- | 789 |
+ 437 |
|
- )
+ }
|
- | 790 |
+ 438 |
|
- ###
- |
-
-
- | 791 |
- ! |
-
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
+ ###
|
-
- | 792 |
- ! |
+
+ | 439 |
+ |
- ggplot2_args,
+ })
|
-
- | 793 |
- ! |
+
+ | 440 |
+ |
- module_plot = dev_ggplot2_args
+ }
|
+
+
+
+
+
+
- | 794 |
+ 1 |
|
- )
+ #' `teal` module: Front page
|
- | 795 |
+ 2 |
|
-
+ #'
|
-
- | 796 |
- ! |
+
+ | 3 |
+ |
- if (is.ggplot(plot_main)) {
+ #' Creates a simple front page for `teal` applications, displaying
|
-
- | 797 |
- ! |
+
+ | 4 |
+ |
- if (is.numeric(var) && !numeric_as_factor) {
+ #' introductory text, tables, additional `html` or `shiny` tags, and footnotes.
|
- | 798 |
+ 5 |
|
- # numeric not as factor
+ #'
|
-
- | 799 |
- ! |
+
+ | 6 |
+ |
- plot_main <- plot_main +
+ #' @inheritParams teal::module
|
-
- | 800 |
- ! |
+
+ | 7 |
+ |
- theme_light() +
+ #' @param header_text (`character` vector) text to be shown at the top of the module, for each
|
-
- | 801 |
- ! |
+
+ | 8 |
+ |
- list(
+ #' element, if named the name is shown first in bold as a header followed by the value. The first
|
-
- | 802 |
- ! |
+
+ | 9 |
+ |
- labs = do.call("labs", all_ggplot2_args$labs),
+ #' element's header is displayed larger than the others.
|
-
- | 803 |
- ! |
+
+ | 10 |
+ |
- theme = do.call("theme", all_ggplot2_args$theme)
+ #' @param tables (`named list` of `data.frame`s) tables to be shown in the module.
|
- | 804 |
+ 11 |
|
- )
+ #' @param additional_tags (`shiny.tag.list` or `html`) additional `shiny` tags or `html` to be included after the table,
|
- | 805 |
+ 12 |
|
- } else {
+ #' for example to include an image, `tagList(tags$img(src = "image.png"))` or to include further `html`,
|
- | 806 |
+ 13 |
|
- # factor low number of levels OR numeric as factor OR Date
+ #' `HTML("html text here")`.
|
-
- | 807 |
- ! |
+
+ | 14 |
+ |
- plot_main <- plot_main +
+ #' @param footnotes (`character` vector) of text to be shown at the bottom of the module, for each
|
-
- | 808 |
- ! |
+
+ | 15 |
+ |
- theme_light() +
+ #' element, if named the name is shown first in bold, followed by the value.
|
-
- | 809 |
- ! |
+
+ | 16 |
+ |
- list(
+ #' @param show_metadata (`logical`) indicating whether the metadata of the datasets be available on the module.
|
-
- | 810 |
- ! |
+
+ | 17 |
+ |
- labs = do.call("labs", all_ggplot2_args$labs),
+ #'
|
-
- | 811 |
- ! |
+
+ | 18 |
+ |
- theme = do.call("theme", all_ggplot2_args$theme)
+ #' @inherit shared_params return
|
- | 812 |
+ 19 |
|
- )
+ #'
|
- | 813 |
+ 20 |
|
- }
+ #' @examplesShinylive
|
-
- | 814 |
- ! |
+
+ | 21 |
+ |
- plot_main <- ggplotGrob(plot_main)
+ #' library(teal.modules.general)
|
- | 815 |
+ 22 |
|
- }
+ #' interactive <- function() TRUE
|
- | 816 |
+ 23 |
|
-
+ #' {{ next_example }}
|
-
- | 817 |
- ! |
+
+ | 24 |
+ |
- grid::grid.draw(plot_main)
+ #' @examples
|
-
- | 818 |
- ! |
+
+ | 25 |
+ |
- plot_main
+ #' data <- teal_data()
|
- | 819 |
+ 26 |
|
- }
+ #' data <- within(data, {
|
- | 820 |
+ 27 |
|
-
+ #' require(nestcolor)
|
- | 821 |
+ 28 |
|
- is_num_var_short <- function(.unique_records_for_factor, input, data_for_analysis) {
+ #' ADSL <- rADSL
|
-
- | 822 |
- ! |
+
+ | 29 |
+ |
- length(unique(data_for_analysis()$data)) < .unique_records_for_factor && !is.null(input$numeric_as_factor)
+ #' attr(ADSL, "metadata") <- list("Author" = "NEST team", "data_source" = "synthetic data")
|
- | 823 |
+ 30 |
|
- }
+ #' })
|
- | 824 |
+ 31 |
|
-
+ #' datanames(data) <- "ADSL"
|
- | 825 |
+ 32 |
|
- #' Validates the variable browser inputs
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
|
- | 826 |
+ 33 |
|
#'
|
- | 827 |
+ 34 |
|
- #' @param input (`session$input`) the `shiny` session input
+ #' table_1 <- data.frame(Info = c("A", "B"), Text = c("A", "B"))
|
- | 828 |
+ 35 |
|
- #' @param plot_var (`list`) list of a data frame and an array of variable names
+ #' table_2 <- data.frame(`Column 1` = c("C", "D"), `Column 2` = c(5.5, 6.6), `Column 3` = c("A", "B"))
|
- | 829 |
+ 36 |
|
- #' @param data (`teal_data`) the datasets passed to the module
+ #' table_3 <- data.frame(Info = c("E", "F"), Text = c("G", "H"))
|
- | 830 |
+ 37 |
|
#'
|
- | 831 |
+ 38 |
|
- #' @returns `logical` TRUE if validations pass; a `shiny` validation error otherwise
+ #' table_input <- list(
|
- | 832 |
+ 39 |
|
- #' @keywords internal
+ #' "Table 1" = table_1,
|
- | 833 |
+ 40 |
|
- validate_input <- function(input, plot_var, data) {
+ #' "Table 2" = table_2,
|
-
- | 834 |
- ! |
+
+ | 41 |
+ |
- reactive({
+ #' "Table 3" = table_3
|
-
- | 835 |
- ! |
+
+ | 42 |
+ |
- dataset_name <- req(input$tabset_panel)
+ #' )
|
-
- | 836 |
- ! |
+
+ | 43 |
+ |
- varname <- plot_var$variable[[dataset_name]]
+ #'
|
- | 837 |
+ 44 |
|
-
+ #' app <- init(
|
-
- | 838 |
- ! |
+
+ | 45 |
+ |
- validate(need(dataset_name, "No data selected"))
+ #' data = data,
|
-
- | 839 |
- ! |
+
+ | 46 |
+ |
- validate(need(varname, "No variable selected"))
+ #' modules = modules(
|
-
- | 840 |
- ! |
+
+ | 47 |
+ |
- df <- data()[[dataset_name]]
+ #' tm_front_page(
|
-
- | 841 |
- ! |
+
+ | 48 |
+ |
- teal::validate_has_data(df, 1)
+ #' header_text = c(
|
-
- | 842 |
- ! |
+
+ | 49 |
+ |
- teal::validate_has_variable(varname = varname, data = df, "Variable not available")
+ #' "Important information" = "It can go here.",
|
- | 843 |
+ 50 |
|
-
+ #' "Other information" = "Can go here."
|
-
- | 844 |
- ! |
+
+ | 51 |
+ |
- TRUE
+ #' ),
|
- | 845 |
+ 52 |
|
- })
+ #' tables = table_input,
|
- | 846 |
+ 53 |
|
- }
+ #' additional_tags = HTML("Additional HTML or shiny tags go here <br>"),
|
- | 847 |
+ 54 |
|
-
+ #' footnotes = c("X" = "is the first footnote", "Y is the second footnote"),
|
- | 848 |
+ 55 |
|
- get_plotted_data <- function(input, plot_var, data) {
+ #' show_metadata = TRUE
|
-
- | 849 |
- ! |
+
+ | 56 |
+ |
- dataset_name <- input$tabset_panel
+ #' )
|
-
- | 850 |
- ! |
+
+ | 57 |
+ |
- varname <- plot_var$variable[[dataset_name]]
+ #' ),
|
-
- | 851 |
- ! |
+
+ | 58 |
+ |
- df <- data()[[dataset_name]]
+ #' header = tags$h1("Sample Application"),
|
- | 852 |
+ 59 |
|
-
+ #' footer = tags$p("Application footer"),
|
-
- | 853 |
- ! |
+
+ | 60 |
+ |
- var_description <- teal.data::col_labels(df)[[varname]]
+ #' )
|
-
- | 854 |
- ! |
+
+ | 61 |
+ |
- list(data = df[[varname]], var_description = var_description)
+ #'
|
- | 855 |
+ 62 |
|
- }
+ #' if (interactive()) {
|
- | 856 |
+ 63 |
|
-
+ #' shinyApp(app$ui, app$server)
|
- | 857 |
+ 64 |
|
- #' Renders the left-hand side `tabset` panel of the module
+ #' }
|
- | 858 |
+ 65 |
|
#'
|
- | 859 |
+ 66 |
|
- #' @param datanames (`character`) the name of the dataset
+ #' @export
|
- | 860 |
+ 67 |
|
- #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from
+ #'
|
- | 861 |
+ 68 |
|
- #' @param data (`teal_data`) the object containing all datasets
+ tm_front_page <- function(label = "Front page",
|
- | 862 |
+ 69 |
|
- #' @param input (`session$input`) the `shiny` session input
+ header_text = character(0),
|
- | 863 |
+ 70 |
|
- #' @param output (`session$output`) the `shiny` session output
+ tables = list(),
|
- | 864 |
+ 71 |
|
- #' @param columns_names (`environment`) the environment containing bindings for each dataset
+ additional_tags = tagList(),
|
- | 865 |
+ 72 |
|
- #' @param plot_var (`list`) the list containing the currently selected dataset (tab) and its column names
+ footnotes = character(0),
|
- | 866 |
+ 73 |
|
- #' @keywords internal
+ show_metadata = FALSE) {
+ |
+
+
+ | 74 |
+ ! |
+
+ message("Initializing tm_front_page")
|
- | 867 |
+ 75 |
|
- render_tabset_panel_content <- function(datanames, parent_dataname, output, data, input, columns_names, plot_var) {
+
|
-
- | 868 |
- ! |
+
+ | 76 |
+ |
- lapply(datanames, render_single_tab,
+ # Start of assertions
|
- | 869 |
+ 77 |
! |
- input = input,
+ checkmate::assert_string(label)
|
- | 870 |
+ 78 |
! |
- output = output,
+ checkmate::assert_character(header_text, min.len = 0, any.missing = FALSE)
|
- | 871 |
+ 79 |
! |
- data = data,
+ checkmate::assert_list(tables, types = "data.frame", names = "named", any.missing = FALSE)
|
- | 872 |
+ 80 |
! |
- parent_dataname = parent_dataname,
+ checkmate::assert_multi_class(additional_tags, classes = c("shiny.tag.list", "html"))
|
- | 873 |
+ 81 |
! |
- columns_names = columns_names,
+ checkmate::assert_character(footnotes, min.len = 0, any.missing = FALSE)
|
- | 874 |
+ 82 |
! |
- plot_var = plot_var
+ checkmate::assert_flag(show_metadata)
|
- | 875 |
+ 83 |
|
- )
+ # End of assertions
|
- | 876 |
+ 84 |
|
- }
+
|
- | 877 |
+ 85 |
|
-
+ # Make UI args
|
-
- | 878 |
- |
+
+ | 86 |
+ ! |
- #' Renders a single tab in the left-hand side tabset panel
+ args <- as.list(environment())
|
- | 879 |
+ 87 |
|
- #'
+
|
-
- | 880 |
- |
+
+ | 88 |
+ ! |
- #' Renders a single tab in the left-hand side tabset panel. The rendered tab contains
+ ans <- module(
|
-
- | 881 |
- |
+
+ | 89 |
+ ! |
- #' information about one dataset out of many presented in the module.
+ label = label,
|
-
- | 882 |
- |
+
+ | 90 |
+ ! |
- #'
+ server = srv_front_page,
|
-
- | 883 |
- |
+
+ | 91 |
+ ! |
- #' @param dataset_name (`character`) the name of the dataset contained in the rendered tab
+ ui = ui_front_page,
|
-
- | 884 |
- |
+
+ | 92 |
+ ! |
- #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from
+ ui_args = args,
|
-
- | 885 |
- |
+
+ | 93 |
+ ! |
- #' @inheritParams render_tabset_panel_content
+ server_args = list(tables = tables, show_metadata = show_metadata),
|
-
- | 886 |
- |
+
+ | 94 |
+ ! |
- #' @keywords internal
+ datanames = if (show_metadata) "all" else NULL
|
- | 887 |
+ 95 |
|
- render_single_tab <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
+ )
|
- | 888 |
+ 96 |
! |
- render_tab_header(dataset_name, output, data)
+ attr(ans, "teal_bookmarkable") <- TRUE
+ |
+
+
+ | 97 |
+ ! |
+
+ ans
|
- | 889 |
+ 98 |
+ |
+
+ }
+ |
+
+
+ | 99 |
|
|
-
- | 890 |
- ! |
+
+ | 100 |
+ |
- render_tab_table(
+ # UI function for the front page module
|
-
- | 891 |
- ! |
+
+ | 101 |
+ |
- dataset_name = dataset_name,
+ ui_front_page <- function(id, ...) {
|
- | 892 |
+ 102 |
! |
- parent_dataname = parent_dataname,
+ args <- list(...)
|
- | 893 |
+ 103 |
! |
- output = output,
+ ns <- NS(id)
|
-
- | 894 |
- ! |
+
+ | 104 |
+ |
- data = data,
+
|
- | 895 |
+ 105 |
! |
- input = input,
+ tagList(
|
- | 896 |
+ 106 |
! |
- columns_names = columns_names,
+ include_css_files("custom"),
|
- | 897 |
+ 107 |
! |
- plot_var = plot_var
+ tags$div(
|
-
- | 898 |
- |
+
+ | 108 |
+ ! |
- )
+ id = "front_page_content",
|
-
- | 899 |
- |
+
+ | 109 |
+ ! |
- }
+ class = "ml-8",
|
-
- | 900 |
- |
+
+ | 110 |
+ ! |
-
+ tags$div(
|
-
- | 901 |
- |
+
+ | 111 |
+ ! |
- #' Renders the text headlining a single tab in the left-hand side tabset panel
+ id = "front_page_headers",
|
-
- | 902 |
- |
+
+ | 112 |
+ ! |
- #'
+ get_header_tags(args$header_text)
|
- | 903 |
+ 113 |
|
- #' @param dataset_name (`character`) the name of the dataset of the tab
+ ),
|
-
- | 904 |
- |
+
+ | 114 |
+ ! |
- #' @inheritParams render_tabset_panel_content
+ tags$div(
|
-
- | 905 |
- |
+
+ | 115 |
+ ! |
- #' @keywords internal
+ id = "front_page_tables",
|
-
- | 906 |
- |
+
+ | 116 |
+ ! |
- render_tab_header <- function(dataset_name, output, data) {
+ class = "ml-4",
|
- | 907 |
+ 117 |
! |
- dataset_ui_id <- paste0("dataset_summary_", dataset_name)
+ get_table_tags(args$tables, ns)
|
-
- | 908 |
- ! |
+
+ | 118 |
+ |
- output[[dataset_ui_id]] <- renderText({
+ ),
|
- | 909 |
+ 119 |
! |
- df <- data()[[dataset_name]]
+ tags$div(
|
- | 910 |
+ 120 |
! |
- join_keys <- teal.data::join_keys(data())
+ id = "front_page_custom_html",
|
- | 911 |
+ 121 |
! |
- if (!is.null(join_keys)) {
+ class = "my-4",
|
- | 912 |
+ 122 |
! |
- key <- teal.data::join_keys(data())[dataset_name, dataset_name]
+ args$additional_tags
|
- | 913 |
+ 123 |
|
- } else {
+ ),
|
- | 914 |
+ 124 |
! |
- key <- NULL
- |
-
-
- | 915 |
- |
-
- }
+ if (args$show_metadata) {
|
- | 916 |
+ 125 |
! |
- sprintf(
+ tags$div(
|
- | 917 |
+ 126 |
! |
- "Dataset with %s unique key rows and %s variables",
+ id = "front_page_metabutton",
|
- | 918 |
+ 127 |
! |
- nrow(unique(`if`(length(key) > 0, df[, key, drop = FALSE], df))),
+ class = "m-4",
|
- | 919 |
+ 128 |
! |
- ncol(df)
+ actionButton(ns("metadata_button"), "Show metadata")
|
- | 920 |
+ 129 |
|
- )
+ )
|
- | 921 |
+ 130 |
|
- })
+ },
|
-
- | 922 |
- |
+
+ | 131 |
+ ! |
- }
+ tags$footer(
|
-
- | 923 |
- |
+
+ | 132 |
+ ! |
-
+ class = ".small",
|
-
- | 924 |
- |
+
+ | 133 |
+ ! |
- #' Renders the table for a single dataset in the left-hand side tabset panel
+ get_footer_tags(args$footnotes)
|
- | 925 |
+ 134 |
|
- #'
+ )
|
- | 926 |
+ 135 |
|
- #' The table contains column names, column labels,
+ )
|
- | 927 |
+ 136 |
|
- #' small summary about NA values and `sparkline` (if appropriate).
+ )
|
- | 928 |
+ 137 |
|
- #'
+ }
|
- | 929 |
+ 138 |
|
- #' @param dataset_name (`character`) the name of the dataset
+
|
- | 930 |
+ 139 |
|
- #' @param parent_dataname (`character`) the name of a parent `dataname` to filter out variables from
+ # Server function for the front page module
|
- | 931 |
+ 140 |
|
- #' @inheritParams render_tabset_panel_content
+ srv_front_page <- function(id, data, tables, show_metadata) {
|
-
- | 932 |
- |
+
+ | 141 |
+ ! |
+
+ checkmate::assert_class(data, "reactive")
+ |
+
+
+ | 142 |
+ ! |
- #' @keywords internal
+ checkmate::assert_class(isolate(data()), "teal_data")
|
-
- | 933 |
- |
+
+ | 143 |
+ ! |
- render_tab_table <- function(dataset_name, parent_dataname, output, data, input, columns_names, plot_var) {
+ moduleServer(id, function(input, output, session) {
|
- | 934 |
+ 144 |
! |
- table_ui_id <- paste0("variable_browser_", dataset_name)
+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
|
- | 935 |
+ 145 |
|
|
- | 936 |
- ! |
-
- output[[table_ui_id]] <- DT::renderDataTable({
- |
-
-
- | 937 |
+ 146 |
! |
- df <- data()[[dataset_name]]
+ ns <- session$ns
|
- | 938 |
+ 147 |
|
|
- | 939 |
+ 148 |
! |
- get_vars_df <- function(input, dataset_name, parent_name, data) {
+ setBookmarkExclude("metadata_button")
|
-
- | 940 |
- ! |
+
+ | 149 |
+ |
- data_cols <- colnames(df)
+
|
- | 941 |
+ 150 |
! |
- if (isTRUE(input$show_parent_vars)) {
+ lapply(seq_along(tables), function(idx) {
|
- | 942 |
+ 151 |
! |
- data_cols
+ output[[paste0("table_", idx)]] <- renderTable(
|
- | 943 |
+ 152 |
! |
- } else if (dataset_name != parent_name && parent_name %in% names(data)) {
+ tables[[idx]],
|
- | 944 |
+ 153 |
! |
- setdiff(data_cols, colnames(data()[[parent_name]]))
+ bordered = TRUE,
|
-
- | 945 |
- |
+
+ | 154 |
+ ! |
- } else {
+ caption = names(tables)[idx],
|
- | 946 |
+ 155 |
! |
- data_cols
+ caption.placement = "top"
|
- | 947 |
+ 156 |
|
- }
+ )
|
- | 948 |
+ 157 |
|
- }
+ })
|
- | 949 |
+ 158 |
|
|
- | 950 |
+ 159 |
! |
- if (length(parent_dataname) > 0) {
+ if (show_metadata) {
|
- | 951 |
+ 160 |
! |
- df_vars <- get_vars_df(input, dataset_name, parent_dataname, data)
+ observeEvent(
|
- | 952 |
+ 161 |
! |
- df <- df[df_vars]
+ input$metadata_button, showModal(
|
-
- | 953 |
- |
+
+ | 162 |
+ ! |
- }
+ modalDialog(
|
-
- | 954 |
- |
+
+ | 163 |
+ ! |
-
+ title = "Metadata",
|
- | 955 |
+ 164 |
! |
- if (is.null(df) || ncol(df) == 0) {
+ dataTableOutput(ns("metadata_table")),
|
- | 956 |
+ 165 |
! |
- columns_names[[dataset_name]] <- character(0)
+ size = "l",
|
- | 957 |
+ 166 |
! |
- df_output <- data.frame(
+ easyClose = TRUE
|
-
- | 958 |
- ! |
+
+ | 167 |
+ |
- Type = character(0),
+ )
+ |
+
+
+ | 168 |
+ |
+
+ )
+ |
+
+
+ | 169 |
+ |
+
+ )
+ |
+
+
+ | 170 |
+ |
+
+
|
- | 959 |
+ 171 |
! |
- Variable = character(0),
+ metadata_data_frame <- reactive({
|
- | 960 |
+ 172 |
! |
- Label = character(0),
+ datanames <- teal.data::datanames(data())
|
- | 961 |
+ 173 |
! |
- Missings = character(0),
+ convert_metadata_to_dataframe(
|
- | 962 |
+ 174 |
! |
- Sparklines = character(0),
+ lapply(datanames, function(dataname) attr(data()[[dataname]], "metadata")),
|
- | 963 |
+ 175 |
! |
- stringsAsFactors = FALSE
+ datanames
|
- | 964 |
+ 176 |
|
- )
+ )
|
- | 965 |
+ 177 |
|
- } else {
+ })
|
- | 966 |
+ 178 |
|
- # extract data variable labels
+
|
- | 967 |
+ 179 |
! |
- labels <- teal.data::col_labels(df)
+ output$metadata_table <- renderDataTable({
|
-
- | 968 |
- |
+
+ | 180 |
+ ! |
-
+ validate(need(nrow(metadata_data_frame()) > 0, "The data has no associated metadata"))
|
- | 969 |
+ 181 |
! |
- columns_names[[dataset_name]] <- names(labels)
+ metadata_data_frame()
|
- | 970 |
+ 182 |
|
-
+ })
|
- | 971 |
+ 183 |
|
- # calculate number of missing values
- |
-
-
- | 972 |
- ! |
-
- missings <- vapply(
- |
-
-
- | 973 |
- ! |
-
- df,
+ }
|
-
- | 974 |
- ! |
+
+ | 184 |
+ |
- var_missings_info,
+ })
|
-
- | 975 |
- ! |
+
+ | 185 |
+ |
- FUN.VALUE = character(1),
+ }
|
-
- | 976 |
- ! |
+
+ | 186 |
+ |
- USE.NAMES = FALSE
+
|
- | 977 |
+ 187 |
|
- )
+ ## utils functions
|
- | 978 |
+ 188 |
|
|
- | 979 |
+ 189 |
|
- # get icons proper for the data types
+ get_header_tags <- function(header_text) {
|
- | 980 |
+ 190 |
! |
- icons <- vapply(df, function(x) class(x)[1L], character(1L))
+ if (length(header_text) == 0) {
+ |
+
+
+ | 191 |
+ ! |
+
+ return(list())
|
- | 981 |
+ 192 |
+ |
+
+ }
+ |
+
+
+ | 193 |
|
|
- | 982 |
+ 194 |
! |
- join_keys <- teal.data::join_keys(data())
+ get_single_header_tags <- function(header_text, p_text, header_tag = tags$h4) {
|
- | 983 |
+ 195 |
! |
- if (!is.null(join_keys)) {
+ tagList(
|
- | 984 |
+ 196 |
! |
- icons[intersect(join_keys[dataset_name, dataset_name], colnames(df))] <- "primary_key"
+ tags$div(
|
-
- | 985 |
- |
+
+ | 197 |
+ ! |
- }
+ if (!is.null(header_text) && nchar(header_text) > 0) header_tag(header_text),
|
- | 986 |
+ 198 |
! |
- icons <- variable_type_icons(icons)
+ tags$p(p_text)
|
- | 987 |
+ 199 |
|
-
+ )
|
- | 988 |
+ 200 |
|
- # generate sparklines
+ )
|
-
- | 989 |
- ! |
+
+ | 201 |
+ |
- sparklines_html <- vapply(
+ }
|
-
- | 990 |
- ! |
+
+ | 202 |
+ |
- df,
+
|
- | 991 |
+ 203 |
! |
- create_sparklines,
+ header_tags <- get_single_header_tags(names(header_text[1]), header_text[1], header_tag = tags$h3)
|
- | 992 |
+ 204 |
! |
- FUN.VALUE = character(1),
+ c(header_tags, mapply(get_single_header_tags, utils::tail(names(header_text), -1), utils::tail(header_text, -1)))
|
-
- | 993 |
- ! |
+
+ | 205 |
+ |
- USE.NAMES = FALSE
+ }
|
- | 994 |
+ 206 |
|
- )
+
|
- | 995 |
+ 207 |
|
-
+ get_table_tags <- function(tables, ns) {
|
- | 996 |
+ 208 |
! |
- df_output <- data.frame(
+ if (length(tables) == 0) {
|
- | 997 |
+ 209 |
! |
- Type = icons,
+ return(list())
|
-
- | 998 |
- ! |
+
+ | 210 |
+ |
- Variable = names(labels),
+ }
|
- | 999 |
+ 211 |
! |
- Label = labels,
+ table_tags <- c(lapply(seq_along(tables), function(idx) {
|
- | 1000 |
+ 212 |
! |
- Missings = missings,
+ list(
|
- | 1001 |
+ 213 |
! |
- Sparklines = sparklines_html,
+ tableOutput(ns(paste0("table_", idx)))
|
-
- | 1002 |
- ! |
+
+ | 214 |
+ |
- stringsAsFactors = FALSE
+ )
|
- | 1003 |
+ 215 |
|
- )
+ }))
+ |
+
+
+ | 216 |
+ ! |
+
+ return(table_tags)
|
- | 1004 |
+ 217 |
|
- }
+ }
|
- | 1005 |
+ 218 |
|
|
- | 1006 |
+ 219 |
|
- # Select row 1 as default / fallback
+ get_footer_tags <- function(footnotes) {
|
- | 1007 |
+ 220 |
! |
- selected_ix <- 1
+ if (length(footnotes) == 0) {
|
-
- | 1008 |
- |
+
+ | 221 |
+ ! |
- # Define starting page index (base-0 index of the first item on page
+ return(list())
|
- | 1009 |
+ 222 |
|
- # note: in many cases it's not the item itself
+ }
|
- | 1010 |
+ 223 |
! |
- selected_page_ix <- 0
+ bold_texts <- if (is.null(names(footnotes))) rep("", length(footnotes)) else names(footnotes)
|
-
- | 1011 |
- |
+
+ | 224 |
+ ! |
-
+ footnote_tags <- mapply(function(bold_text, value) {
|
-
- | 1012 |
- |
+
+ | 225 |
+ ! |
- # Retrieve current selected variable if any
+ list(
|
- | 1013 |
+ 226 |
! |
- isolated_variable <- isolate(plot_var$variable[[dataset_name]])
+ tags$div(
|
-
- | 1014 |
- |
+
+ | 227 |
+ ! |
-
+ tags$b(bold_text),
|
- | 1015 |
+ 228 |
! |
- if (!is.null(isolated_variable)) {
+ value,
|
- | 1016 |
+ 229 |
! |
- index <- which(columns_names[[dataset_name]] == isolated_variable)[1]
+ tags$br()
+ |
+
+
+ | 230 |
+ |
+
+ )
+ |
+
+
+ | 231 |
+ |
+
+ )
|
- | 1017 |
+ 232 |
! |
- if (!is.null(index) && !is.na(index) && length(index) > 0) selected_ix <- index
+ }, bold_text = bold_texts, value = footnotes)
|
- | 1018 |
+ 233 |
|
- }
+ }
|
- | 1019 |
+ 234 |
|
|
- | 1020 |
+ 235 |
|
- # Retrieve the index of the first item of the current page
+ # take a list of metadata, one item per dataset (raw_metadata each element from datasets$get_metadata())
|
- | 1021 |
+ 236 |
|
- # it works with varying number of entries on the page (10, 25, ...)
+ # and the corresponding datanames and output a data.frame with columns {Dataset, Name, Value}.
|
-
- | 1022 |
- ! |
+
+ | 237 |
+ |
- table_id_sel <- paste0("variable_browser_", dataset_name, "_state")
+ # which are, the Dataset the metadata came from, the metadata's name and value
|
-
- | 1023 |
- ! |
+
+ | 238 |
+ |
- dt_state <- isolate(input[[table_id_sel]])
+ convert_metadata_to_dataframe <- function(raw_metadata, datanames) {
|
-
- | 1024 |
- ! |
+
+ | 239 |
+ 4x |
- if (selected_ix != 1 && !is.null(dt_state)) {
+ output <- mapply(function(metadata, dataname) {
|
-
- | 1025 |
- ! |
+
+ | 240 |
+ 6x |
- selected_page_ix <- floor(selected_ix / dt_state$length) * dt_state$length
+ if (is.null(metadata)) {
|
-
- | 1026 |
- |
+
+ | 241 |
+ 2x |
- }
+ return(data.frame(Dataset = character(0), Name = character(0), Value = character(0)))
|
- | 1027 |
+ 242 |
|
-
- |
-
-
- | 1028 |
- ! |
-
- DT::datatable(
+ }
|
-
- | 1029 |
- ! |
+
+ | 243 |
+ 4x |
- df_output,
+ return(data.frame(
|
-
- | 1030 |
- ! |
+
+ | 244 |
+ 4x |
- escape = FALSE,
+ Dataset = dataname,
|
-
- | 1031 |
- ! |
+
+ | 245 |
+ 4x |
- rownames = FALSE,
+ Name = names(metadata),
|
-
- | 1032 |
- ! |
+
+ | 246 |
+ 4x |
- selection = list(mode = "single", target = "row", selected = selected_ix),
+ Value = unname(unlist(lapply(metadata, as.character)))
|
-
- | 1033 |
- ! |
+
+ | 247 |
+ |
- options = list(
+ ))
|
-
- | 1034 |
- ! |
+
+ | 248 |
+ 4x |
- fnDrawCallback = htmlwidgets::JS("function() { HTMLWidgets.staticRender(); }"),
+ }, raw_metadata, datanames, SIMPLIFY = FALSE)
|
-
- | 1035 |
- ! |
+
+ | 249 |
+ 4x |
- pageLength = input[[paste0(table_ui_id, "_rows")]],
+ do.call(rbind, output)
|
-
- | 1036 |
- ! |
+
+ | 250 |
+ |
- displayStart = selected_page_ix
+ }
|
+
+
+
+
+
+
- | 1037 |
+ 1 |
|
- )
+ #' `teal` module: Scatterplot
|
- | 1038 |
+ 2 |
|
- )
+ #'
|
- | 1039 |
+ 3 |
|
- })
+ #' Generates a customizable scatterplot using `ggplot2`.
|
- | 1040 |
+ 4 |
|
- }
+ #' This module allows users to select variables for the x and y axes,
|
- | 1041 |
+ 5 |
|
-
+ #' color and size encodings, faceting options, and more. It supports log transformations,
|
- | 1042 |
+ 6 |
|
- #' Creates observers updating the currently selected column
+ #' trend line additions, and dynamic adjustments of point opacity and size through UI controls.
|
- | 1043 |
+ 7 |
|
#'
|
- | 1044 |
+ 8 |
|
- #' The created observers update the column currently selected in the left-hand side
+ #' @note For more examples, please see the vignette "Using scatterplot" via
|
- | 1045 |
+ 9 |
|
- #' tabset panel.
+ #' `vignette("using-scatterplot", package = "teal.modules.general")`.
|
- | 1046 |
+ 10 |
|
#'
|
- | 1047 |
+ 11 |
|
- #' @note
+ #' @inheritParams teal::module
|
- | 1048 |
+ 12 |
|
- #' Creates an observer for each dataset (each tab in the tabset panel).
+ #' @inheritParams shared_params
|
- | 1049 |
+ 13 |
|
- #'
+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) Specifies
|
- | 1050 |
+ 14 |
|
- #' @inheritParams render_tabset_panel_content
+ #' variable names selected to plot along the x-axis by default.
|
- | 1051 |
+ 15 |
|
- #' @keywords internal
+ #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) Specifies
|
- | 1052 |
+ 16 |
|
- establish_updating_selection <- function(datanames, input, plot_var, columns_names) {
- |
-
-
- | 1053 |
- ! |
-
- lapply(datanames, function(dataset_name) {
+ #' variable names selected to plot along the y-axis by default.
|
-
- | 1054 |
- ! |
+
+ | 17 |
+ |
- table_ui_id <- paste0("variable_browser_", dataset_name)
+ #' @param color_by (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
|
-
- | 1055 |
- ! |
+
+ | 18 |
+ |
- table_id_sel <- paste0(table_ui_id, "_rows_selected")
+ #' defines the color encoding. If `NULL` then no color encoding option will be displayed.
|
-
- | 1056 |
- ! |
+
+ | 19 |
+ |
- observeEvent(input[[table_id_sel]], {
+ #' @param size_by (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
|
-
- | 1057 |
- ! |
+
+ | 20 |
+ |
- plot_var$data <- dataset_name
+ #' defines the point size encoding. If `NULL` then no size encoding option will be displayed.
|
-
- | 1058 |
- ! |
+
+ | 21 |
+ |
- plot_var$variable[[dataset_name]] <- columns_names[[dataset_name]][input[[table_id_sel]]]
+ #' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
|
- | 1059 |
+ 22 |
|
- })
+ #' specifies the variable(s) for faceting rows.
|
- | 1060 |
+ 23 |
|
- })
+ #' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
|
- | 1061 |
+ 24 |
|
- }
+ #' specifies the variable(s) for faceting columns.
|
- | 1062 |
+ 25 |
|
-
+ #' @param shape (`character`) optional, character vector with the names of the
|
- | 1063 |
+ 26 |
|
- get_bin_width <- function(x_vec, scaling_factor = 2) {
+ #' shape, e.g. `c("triangle", "square", "circle")`. It defaults to `shape_names`. This is a complete list from
|
-
- | 1064 |
- ! |
+
+ | 27 |
+ |
- x_vec <- x_vec[!is.na(x_vec)]
+ #' `vignette("ggplot2-specs", package="ggplot2")`.
|
-
- | 1065 |
- ! |
+
+ | 28 |
+ |
- qntls <- stats::quantile(x_vec, probs = c(0.1, 0.25, 0.75, 0.9), type = 2)
+ #' @param max_deg (`integer`) optional, maximum degree for the polynomial trend line. Must not be less than 1.
|
-
- | 1066 |
- ! |
+
+ | 29 |
+ |
- iqr <- qntls[3] - qntls[2]
+ #' @param table_dec (`integer`) optional, number of decimal places used to round numeric values in the table.
|
-
- | 1067 |
- ! |
+
+ | 30 |
+ |
- binwidth <- max(scaling_factor * iqr / length(x_vec) ^ (1 / 3), sqrt(qntls[4] - qntls[1])) # styler: off
+ #'
|
-
- | 1068 |
- ! |
+
+ | 31 |
+ |
- binwidth <- ifelse(binwidth == 0, 1, binwidth)
+ #' @inherit shared_params return
|
- | 1069 |
+ 32 |
|
- # to ensure at least two bins when variable span is very small
+ #'
|
-
- | 1070 |
- ! |
+
+ | 33 |
+ |
- x_span <- diff(range(x_vec))
+ #' @examplesShinylive
|
-
- | 1071 |
- ! |
+
+ | 34 |
+ |
- if (isTRUE(x_span / binwidth >= 2)) binwidth else x_span / 2
+ #' library(teal.modules.general)
|
- | 1072 |
+ 35 |
|
- }
+ #' interactive <- function() TRUE
|
- | 1073 |
+ 36 |
|
-
+ #' {{ next_example }}
|
- | 1074 |
+ 37 |
|
- #' Removes the outlier observation from an array
+ # nolint start: line_length_linter.
|
- | 1075 |
+ 38 |
|
- #'
+ #' @examplesIf require("ggpmisc", quietly = TRUE) && require("ggExtra", quietly = TRUE) && require("colourpicker", quietly = TRUE)
|
- | 1076 |
+ 39 |
|
- #' @param var (`numeric`) a numeric vector
+ # nolint end: line_length_linter.
|
- | 1077 |
+ 40 |
|
- #' @param outlier_definition (`numeric`) if `0` then no outliers are removed, otherwise
+ #' # general data example
|
- | 1078 |
+ 41 |
|
- #' outliers (those more than `outlier_definition*IQR below/above Q1/Q3`) are removed
+ #' data <- teal_data()
|
- | 1079 |
+ 42 |
|
- #' @returns (`numeric`) vector without the outlier values
+ #' data <- within(data, {
|
- | 1080 |
+ 43 |
|
- #' @keywords internal
+ #' require(nestcolor)
|
- | 1081 |
+ 44 |
|
- remove_outliers_from <- function(var, outlier_definition) {
+ #' CO2 <- CO2
|
-
- | 1082 |
- 3x |
+
+ | 45 |
+ |
- if (outlier_definition == 0) {
+ #' })
|
-
- | 1083 |
- 1x |
+
+ | 46 |
+ |
- return(var)
+ #' datanames(data) <- "CO2"
|
- | 1084 |
+ 47 |
|
- }
+ #'
|
-
- | 1085 |
- 2x |
+
+ | 48 |
+ |
- q1_q3 <- stats::quantile(var, probs = c(0.25, 0.75), type = 2, na.rm = TRUE)
+ #' app <- init(
|
-
- | 1086 |
- 2x |
+
+ | 49 |
+ |
- iqr <- q1_q3[2] - q1_q3[1]
+ #' data = data,
|
-
- | 1087 |
- 2x |
+
+ | 50 |
+ |
- var[var >= q1_q3[1] - outlier_definition * iqr & var <= q1_q3[2] + outlier_definition * iqr]
+ #' modules = modules(
|
- | 1088 |
+ 51 |
|
- }
+ #' tm_g_scatterplot(
|
- | 1089 |
+ 52 |
|
-
+ #' label = "Scatterplot Choices",
|
- | 1090 |
+ 53 |
|
-
+ #' x = data_extract_spec(
|
- | 1091 |
+ 54 |
|
- # sparklines ----
+ #' dataname = "CO2",
|
- | 1092 |
+ 55 |
|
-
+ #' select = select_spec(
|
- | 1093 |
+ 56 |
|
- #' S3 generic for `sparkline` widget HTML
+ #' label = "Select variable:",
|
- | 1094 |
+ 57 |
|
- #'
+ #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
|
- | 1095 |
+ 58 |
|
- #' Generates the `sparkline` HTML code corresponding to the input array.
+ #' selected = "conc",
|
- | 1096 |
+ 59 |
|
- #' For numeric variables creates a box plot, for character and factors - bar plot.
+ #' multiple = FALSE,
|
- | 1097 |
+ 60 |
|
- #' Produces an empty string for variables of other types.
+ #' fixed = FALSE
|
- | 1098 |
+ 61 |
|
- #'
+ #' )
|
- | 1099 |
+ 62 |
|
- #' @param arr vector of any type and length
+ #' ),
|
- | 1100 |
+ 63 |
|
- #' @param width `numeric` the width of the `sparkline` widget (pixels)
+ #' y = data_extract_spec(
|
- | 1101 |
+ 64 |
|
- #' @param bar_spacing `numeric` the spacing between the bars (in pixels)
+ #' dataname = "CO2",
|
- | 1102 |
+ 65 |
|
- #' @param bar_width `numeric` the width of the bars (in pixels)
+ #' select = select_spec(
|
- | 1103 |
+ 66 |
|
- #' @param ... `list` additional options passed to bar plots of `jquery.sparkline`;
+ #' label = "Select variable:",
|
- | 1104 |
+ 67 |
|
- #' see [`jquery.sparkline docs`](https://omnipotent.net/jquery.sparkline/#common)
+ #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
|
- | 1105 |
+ 68 |
|
- #'
+ #' selected = "uptake",
|
- | 1106 |
+ 69 |
|
- #' @return Character string containing HTML code of the `sparkline` HTML widget.
+ #' multiple = FALSE,
|
- | 1107 |
+ 70 |
|
- #' @keywords internal
+ #' fixed = FALSE
|
- | 1108 |
+ 71 |
|
- create_sparklines <- function(arr, width = 150, ...) {
+ #' )
|
-
- | 1109 |
- ! |
+
+ | 72 |
+ |
- if (all(is.null(arr))) {
+ #' ),
|
-
- | 1110 |
- ! |
+
+ | 73 |
+ |
- return("")
+ #' color_by = data_extract_spec(
|
- | 1111 |
+ 74 |
|
- }
+ #' dataname = "CO2",
|
-
- | 1112 |
- ! |
+
+ | 75 |
+ |
- UseMethod("create_sparklines")
+ #' select = select_spec(
|
- | 1113 |
+ 76 |
|
- }
+ #' label = "Select variable:",
|
- | 1114 |
+ 77 |
|
-
+ #' choices = variable_choices(
|
- | 1115 |
+ 78 |
|
- #' @rdname create_sparklines
+ #' data[["CO2"]],
|
- | 1116 |
+ 79 |
|
- #' @keywords internal
+ #' c("Plant", "Type", "Treatment", "conc", "uptake")
|
- | 1117 |
+ 80 |
|
- #' @export
+ #' ),
|
- | 1118 |
+ 81 |
|
- create_sparklines.logical <- function(arr, ...) {
+ #' selected = NULL,
|
-
- | 1119 |
- ! |
+
+ | 82 |
+ |
- create_sparklines(as.factor(arr))
+ #' multiple = FALSE,
|
- | 1120 |
+ 83 |
|
- }
+ #' fixed = FALSE
|
- | 1121 |
+ 84 |
|
-
+ #' )
|
- | 1122 |
+ 85 |
|
- #' @rdname create_sparklines
+ #' ),
|
- | 1123 |
+ 86 |
|
- #' @keywords internal
+ #' size_by = data_extract_spec(
|
- | 1124 |
+ 87 |
|
- #' @export
+ #' dataname = "CO2",
|
- | 1125 |
+ 88 |
|
- create_sparklines.numeric <- function(arr, width = 150, ...) {
+ #' select = select_spec(
|
-
- | 1126 |
- ! |
+
+ | 89 |
+ |
- if (any(is.infinite(arr))) {
+ #' label = "Select variable:",
|
-
- | 1127 |
- ! |
+
+ | 90 |
+ |
- return(as.character(tags$code("infinite values", class = "text-blue")))
+ #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")),
|
- | 1128 |
+ 91 |
|
- }
+ #' selected = "uptake",
|
-
- | 1129 |
- ! |
+
+ | 92 |
+ |
- if (length(arr) > 100000) {
+ #' multiple = FALSE,
|
-
- | 1130 |
- ! |
+
+ | 93 |
+ |
- return(as.character(tags$code("Too many rows (>100000)", class = "text-blue")))
+ #' fixed = FALSE
|
- | 1131 |
+ 94 |
|
- }
+ #' )
|
- | 1132 |
+ 95 |
|
-
+ #' ),
|
-
- | 1133 |
- ! |
+
+ | 96 |
+ |
- arr <- arr[!is.na(arr)]
+ #' row_facet = data_extract_spec(
|
-
- | 1134 |
- ! |
+
+ | 97 |
+ |
- sparkline::spk_chr(unname(arr), type = "box", width = width, ...)
+ #' dataname = "CO2",
|
- | 1135 |
+ 98 |
|
- }
+ #' select = select_spec(
|
- | 1136 |
+ 99 |
|
-
+ #' label = "Select variable:",
|
- | 1137 |
+ 100 |
|
- #' @rdname create_sparklines
+ #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
|
- | 1138 |
+ 101 |
|
- #' @keywords internal
+ #' selected = NULL,
|
- | 1139 |
+ 102 |
|
- #' @export
+ #' multiple = FALSE,
|
- | 1140 |
+ 103 |
|
- create_sparklines.character <- function(arr, ...) {
+ #' fixed = FALSE
|
-
- | 1141 |
- ! |
+
+ | 104 |
+ |
- return(create_sparklines(as.factor(arr)))
+ #' )
|
- | 1142 |
+ 105 |
|
- }
+ #' ),
|
- | 1143 |
+ 106 |
|
-
+ #' col_facet = data_extract_spec(
|
- | 1144 |
+ 107 |
|
-
+ #' dataname = "CO2",
|
- | 1145 |
+ 108 |
|
- #' @rdname create_sparklines
+ #' select = select_spec(
|
- | 1146 |
+ 109 |
|
- #' @keywords internal
+ #' label = "Select variable:",
|
- | 1147 |
+ 110 |
|
- #' @export
+ #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
|
- | 1148 |
+ 111 |
|
- create_sparklines.factor <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
+ #' selected = NULL,
|
-
- | 1149 |
- ! |
+
+ | 112 |
+ |
- decreasing_order <- TRUE
+ #' multiple = FALSE,
|
- | 1150 |
+ 113 |
|
-
+ #' fixed = FALSE
|
-
- | 1151 |
- ! |
+
+ | 114 |
+ |
- counts <- table(arr)
+ #' )
|
-
- | 1152 |
- ! |
+
+ | 115 |
+ |
- if (length(counts) >= 100) {
+ #' )
|
-
- | 1153 |
- ! |
+
+ | 116 |
+ |
- return(as.character(tags$code("> 99 levels", class = "text-blue")))
+ #' )
|
-
- | 1154 |
- ! |
+
+ | 117 |
+ |
- } else if (length(counts) == 0) {
+ #' )
|
-
- | 1155 |
- ! |
+
+ | 118 |
+ |
- return(as.character(tags$code("no levels", class = "text-blue")))
+ #' )
|
-
- | 1156 |
- ! |
+
+ | 119 |
+ |
- } else if (length(counts) == 1) {
+ #' if (interactive()) {
|
-
- | 1157 |
- ! |
+
+ | 120 |
+ |
- return(as.character(tags$code("one level", class = "text-blue")))
+ #' shinyApp(app$ui, app$server)
|
- | 1158 |
+ 121 |
|
- }
+ #' }
|
- | 1159 |
+ 122 |
|
-
+ #'
|
- | 1160 |
+ 123 |
|
- # Summarize the occurences of different levels
+ #' @examplesShinylive
|
- | 1161 |
+ 124 |
|
- # and get the maximum and minimum number of occurences
+ #' library(teal.modules.general)
|
- | 1162 |
+ 125 |
|
- # This is needed for the sparkline to correctly display the bar plots
+ #' interactive <- function() TRUE
|
- | 1163 |
+ 126 |
|
- # Otherwise they are cropped
+ #' {{ next_example }}
|
-
- | 1164 |
- ! |
+
+ | 127 |
+ |
- counts <- sort(counts, decreasing = decreasing_order, method = "radix")
+ # nolint start: line_length_linter.
|
-
- | 1165 |
- ! |
+
+ | 128 |
+ |
- max_value <- if (decreasing_order) counts[1] else counts[length[counts]]
+ #' @examplesIf require("ggpmisc", quietly = TRUE) && require("ggExtra", quietly = TRUE) && require("colourpicker", quietly = TRUE)
|
-
- | 1166 |
- ! |
+
+ | 129 |
+ |
- max_value <- unname(max_value)
+ # nolint end: line_length_linter.
|
- | 1167 |
+ 130 |
|
-
+ #' # CDISC data example
|
-
- | 1168 |
- ! |
+
+ | 131 |
+ |
- sparkline::spk_chr(
+ #' data <- teal_data()
|
-
- | 1169 |
- ! |
+
+ | 132 |
+ |
- unname(counts),
+ #' data <- within(data, {
|
-
- | 1170 |
- ! |
+
+ | 133 |
+ |
- type = "bar",
+ #' require(nestcolor)
|
-
- | 1171 |
- ! |
+
+ | 134 |
+ |
- chartRangeMin = 0,
+ #' ADSL <- rADSL
|
-
- | 1172 |
- ! |
+
+ | 135 |
+ |
- chartRangeMax = max_value,
+ #' })
|
-
- | 1173 |
- ! |
+
+ | 136 |
+ |
- width = width,
+ #' datanames(data) <- c("ADSL")
|
-
- | 1174 |
- ! |
+
+ | 137 |
+ |
- barWidth = bar_width,
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
|
-
- | 1175 |
- ! |
+
+ | 138 |
+ |
- barSpacing = bar_spacing,
+ #'
|
-
- | 1176 |
- ! |
+
+ | 139 |
+ |
- tooltipFormatter = custom_sparkline_formatter(names(counts), as.vector(counts))
+ #' app <- init(
|
- | 1177 |
+ 140 |
|
- )
+ #' data = data,
|
- | 1178 |
+ 141 |
|
- }
+ #' modules = modules(
|
- | 1179 |
+ 142 |
|
-
+ #' tm_g_scatterplot(
|
- | 1180 |
+ 143 |
|
- #' @rdname create_sparklines
+ #' label = "Scatterplot Choices",
|
- | 1181 |
+ 144 |
|
- #' @keywords internal
+ #' x = data_extract_spec(
|
- | 1182 |
+ 145 |
|
- #' @export
+ #' dataname = "ADSL",
|
- | 1183 |
+ 146 |
|
- create_sparklines.Date <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
+ #' select = select_spec(
|
-
- | 1184 |
- ! |
+
+ | 147 |
+ |
- arr_num <- as.numeric(arr)
+ #' label = "Select variable:",
|
-
- | 1185 |
- ! |
+
+ | 148 |
+ |
- arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")
+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")),
|
-
- | 1186 |
- ! |
+
+ | 149 |
+ |
- binwidth <- get_bin_width(arr_num, 1)
+ #' selected = "AGE",
|
-
- | 1187 |
- ! |
+
+ | 150 |
+ |
- bins <- floor(diff(range(arr_num)) / binwidth) + 1
+ #' multiple = FALSE,
|
-
- | 1188 |
- ! |
+
+ | 151 |
+ |
- if (all(is.na(bins))) {
+ #' fixed = FALSE
|
-
- | 1189 |
- ! |
+
+ | 152 |
+ |
- return(as.character(tags$code("only NA", class = "text-blue")))
+ #' )
|
-
- | 1190 |
- ! |
+
+ | 153 |
+ |
- } else if (bins == 1) {
+ #' ),
|
-
- | 1191 |
- ! |
+
+ | 154 |
+ |
- return(as.character(tags$code("one date", class = "text-blue")))
+ #' y = data_extract_spec(
|
- | 1192 |
+ 155 |
|
- }
+ #' dataname = "ADSL",
|
-
- | 1193 |
- ! |
+
+ | 156 |
+ |
- counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))
+ #' select = select_spec(
|
-
- | 1194 |
- ! |
+
+ | 157 |
+ |
- max_value <- max(counts)
+ #' label = "Select variable:",
|
- | 1195 |
+ 158 |
|
-
+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")),
|
-
- | 1196 |
- ! |
+
+ | 159 |
+ |
- start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))
+ #' selected = "BMRKR1",
|
-
- | 1197 |
- ! |
+
+ | 160 |
+ |
- labels_start <- as.character(as.Date(arr_num[start_bins], origin = as.Date("1970-01-01")))
+ #' multiple = FALSE,
|
-
- | 1198 |
- ! |
+
+ | 161 |
+ |
- labels <- paste("Start:", labels_start)
+ #' fixed = FALSE
|
- | 1199 |
+ 162 |
|
-
+ #' )
|
-
- | 1200 |
- ! |
+
+ | 163 |
+ |
- sparkline::spk_chr(
+ #' ),
|
-
- | 1201 |
- ! |
+
+ | 164 |
+ |
- unname(counts),
+ #' color_by = data_extract_spec(
|
-
- | 1202 |
- ! |
+
+ | 165 |
+ |
- type = "bar",
+ #' dataname = "ADSL",
|
-
- | 1203 |
- ! |
+
+ | 166 |
+ |
- chartRangeMin = 0,
+ #' select = select_spec(
|
-
- | 1204 |
- ! |
+
+ | 167 |
+ |
- chartRangeMax = max_value,
+ #' label = "Select variable:",
|
-
-
- | 1205 |
- ! |
+
+
+ | 168 |
+ |
- width = width,
+ #' choices = variable_choices(
|
-
- | 1206 |
- ! |
+
+ | 169 |
+ |
- barWidth = bar_width,
+ #' data[["ADSL"]],
|
-
- | 1207 |
- ! |
+
+ | 170 |
+ |
- barSpacing = bar_spacing,
+ #' c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1")
|
-
- | 1208 |
- ! |
+
+ | 171 |
+ |
- tooltipFormatter = custom_sparkline_formatter(labels, counts)
+ #' ),
|
- | 1209 |
+ 172 |
|
- )
+ #' selected = NULL,
|
- | 1210 |
+ 173 |
|
- }
+ #' multiple = FALSE,
|
- | 1211 |
+ 174 |
|
-
+ #' fixed = FALSE
|
- | 1212 |
+ 175 |
|
- #' @rdname create_sparklines
+ #' )
|
- | 1213 |
+ 176 |
|
- #' @keywords internal
+ #' ),
|
- | 1214 |
+ 177 |
|
- #' @export
+ #' size_by = data_extract_spec(
|
- | 1215 |
+ 178 |
|
- create_sparklines.POSIXct <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
+ #' dataname = "ADSL",
|
-
- | 1216 |
- ! |
+
+ | 179 |
+ |
- arr_num <- as.numeric(arr)
+ #' select = select_spec(
|
-
- | 1217 |
- ! |
+
+ | 180 |
+ |
- arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")
+ #' label = "Select variable:",
|
-
- | 1218 |
- ! |
+
+ | 181 |
+ |
- binwidth <- get_bin_width(arr_num, 1)
+ #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
|
-
- | 1219 |
- ! |
+
+ | 182 |
+ |
- bins <- floor(diff(range(arr_num)) / binwidth) + 1
+ #' selected = "AGE",
|
-
- | 1220 |
- ! |
+
+ | 183 |
+ |
- if (all(is.na(bins))) {
+ #' multiple = FALSE,
|
-
- | 1221 |
- ! |
+
+ | 184 |
+ |
- return(as.character(tags$code("only NA", class = "text-blue")))
+ #' fixed = FALSE
|
-
- | 1222 |
- ! |
+
+ | 185 |
+ |
- } else if (bins == 1) {
+ #' )
|
-
- | 1223 |
- ! |
+
+ | 186 |
+ |
- return(as.character(tags$code("one date-time", class = "text-blue")))
+ #' ),
|
- | 1224 |
+ 187 |
|
- }
+ #' row_facet = data_extract_spec(
|
-
- | 1225 |
- ! |
+
+ | 188 |
+ |
- counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))
+ #' dataname = "ADSL",
|
-
- | 1226 |
- ! |
+
+ | 189 |
+ |
- max_value <- max(counts)
+ #' select = select_spec(
|
- | 1227 |
+ 190 |
|
-
+ #' label = "Select variable:",
|
-
- | 1228 |
- ! |
+
+ | 191 |
+ |
- start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))
+ #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")),
|
-
- | 1229 |
- ! |
+
+ | 192 |
+ |
- labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
+ #' selected = NULL,
|
-
- | 1230 |
- ! |
+
+ | 193 |
+ |
- labels <- paste("Start:", labels_start)
+ #' multiple = FALSE,
|
- | 1231 |
+ 194 |
|
-
+ #' fixed = FALSE
|
-
- | 1232 |
- ! |
+
+ | 195 |
+ |
- sparkline::spk_chr(
+ #' )
|
-
- | 1233 |
- ! |
+
+ | 196 |
+ |
- unname(counts),
+ #' ),
|
-
- | 1234 |
- ! |
+
+ | 197 |
+ |
- type = "bar",
+ #' col_facet = data_extract_spec(
|
-
- | 1235 |
- ! |
+
+ | 198 |
+ |
- chartRangeMin = 0,
+ #' dataname = "ADSL",
|
-
- | 1236 |
- ! |
+
+ | 199 |
+ |
- chartRangeMax = max_value,
+ #' select = select_spec(
|
-
- | 1237 |
- ! |
+
+ | 200 |
+ |
- width = width,
+ #' label = "Select variable:",
|
-
- | 1238 |
- ! |
+
+ | 201 |
+ |
- barWidth = bar_width,
+ #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")),
|
-
- | 1239 |
- ! |
+
+ | 202 |
+ |
- barSpacing = bar_spacing,
+ #' selected = NULL,
|
-
- | 1240 |
- ! |
+
+ | 203 |
+ |
- tooltipFormatter = custom_sparkline_formatter(labels, counts)
+ #' multiple = FALSE,
|
- | 1241 |
+ 204 |
|
- )
+ #' fixed = FALSE
|
- | 1242 |
+ 205 |
|
- }
+ #' )
|
- | 1243 |
+ 206 |
|
-
+ #' )
|
- | 1244 |
+ 207 |
|
- #' @rdname create_sparklines
+ #' )
|
- | 1245 |
+ 208 |
|
- #' @keywords internal
+ #' )
|
- | 1246 |
+ 209 |
|
- #' @export
+ #' )
|
- | 1247 |
+ 210 |
|
- create_sparklines.POSIXlt <- function(arr, width = 150, bar_spacing = 5, bar_width = 20, ...) {
+ #' if (interactive()) {
|
-
- | 1248 |
- ! |
+
+ | 211 |
+ |
- arr_num <- as.numeric(arr)
+ #' shinyApp(app$ui, app$server)
|
-
- | 1249 |
- ! |
+
+ | 212 |
+ |
- arr_num <- sort(arr_num, decreasing = FALSE, method = "radix")
+ #' }
|
-
- | 1250 |
- ! |
+
+ | 213 |
+ |
- binwidth <- get_bin_width(arr_num, 1)
+ #'
|
-
- | 1251 |
- ! |
+
+ | 214 |
+ |
- bins <- floor(diff(range(arr_num)) / binwidth) + 1
+ #' @export
|
-
- | 1252 |
- ! |
+
+ | 215 |
+ |
- if (all(is.na(bins))) {
+ #'
|
-
- | 1253 |
- ! |
+
+ | 216 |
+ |
- return(as.character(tags$code("only NA", class = "text-blue")))
+ tm_g_scatterplot <- function(label = "Scatterplot",
|
-
- | 1254 |
- ! |
+
+ | 217 |
+ |
- } else if (bins == 1) {
+ x,
|
-
- | 1255 |
- ! |
+
+ | 218 |
+ |
- return(as.character(tags$code("one date-time", class = "text-blue")))
+ y,
|
- | 1256 |
+ 219 |
|
- }
+ color_by = NULL,
|
-
- | 1257 |
- ! |
+
+ | 220 |
+ |
- counts <- as.vector(unname(base::table(cut(arr_num, breaks = bins))))
+ size_by = NULL,
|
-
- | 1258 |
- ! |
+
+ | 221 |
+ |
- max_value <- max(counts)
+ row_facet = NULL,
|
- | 1259 |
+ 222 |
|
-
+ col_facet = NULL,
|
-
- | 1260 |
- ! |
+
+ | 223 |
+ |
- start_bins <- as.integer(seq(1, length(arr_num), length.out = bins))
+ plot_height = c(600, 200, 2000),
|
-
- | 1261 |
- ! |
+
+ | 224 |
+ |
- labels_start <- as.character(format(as.POSIXct(arr_num[start_bins], origin = as.Date("1970-01-01")), "%Y-%m-%d"))
+ plot_width = NULL,
|
-
- | 1262 |
- ! |
+
+ | 225 |
+ |
- labels <- paste("Start:", labels_start)
+ alpha = c(1, 0, 1),
|
- | 1263 |
+ 226 |
|
-
+ shape = shape_names,
|
-
- | 1264 |
- ! |
+
+ | 227 |
+ |
- sparkline::spk_chr(
+ size = c(5, 1, 15),
|
-
- | 1265 |
- ! |
+
+ | 228 |
+ |
- unname(counts),
+ max_deg = 5L,
|
-
- | 1266 |
- ! |
+
+ | 229 |
+ |
- type = "bar",
+ rotate_xaxis_labels = FALSE,
|
-
- | 1267 |
- ! |
+
+ | 230 |
+ |
- chartRangeMin = 0,
+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
-
- | 1268 |
- ! |
+
+ | 231 |
+ |
- chartRangeMax = max_value,
+ pre_output = NULL,
|
-
- | 1269 |
- ! |
+
+ | 232 |
+ |
- width = width,
+ post_output = NULL,
|
-
- | 1270 |
- ! |
+
+ | 233 |
+ |
- barWidth = bar_width,
+ table_dec = 4,
|
-
- | 1271 |
- ! |
+
+ | 234 |
+ |
- barSpacing = bar_spacing,
+ ggplot2_args = teal.widgets::ggplot2_args()) {
|
- | 1272 |
+ 235 |
! |
- tooltipFormatter = custom_sparkline_formatter(labels, counts)
+ message("Initializing tm_g_scatterplot")
|
- | 1273 |
+ 236 |
|
- )
+
|
- | 1274 |
+ 237 |
|
- }
+ # Requires Suggested packages
|
-
- | 1275 |
- |
+
+ | 238 |
+ ! |
-
+ extra_packages <- c("ggpmisc", "ggExtra", "colourpicker")
|
-
- | 1276 |
- |
+
+ | 239 |
+ ! |
- #' @rdname create_sparklines
+ missing_packages <- Filter(function(x) !requireNamespace(x, quietly = TRUE), extra_packages)
|
-
- | 1277 |
- |
+
+ | 240 |
+ ! |
- #' @keywords internal
+ if (length(missing_packages) > 0L) {
|
-
- | 1278 |
- |
+
+ | 241 |
+ ! |
- #' @export
+ stop(sprintf(
|
-
- | 1279 |
- |
+
+ | 242 |
+ ! |
- create_sparklines.default <- function(arr, width = 150, ...) {
+ "Cannot load package(s): %s.\nInstall or restart your session.",
|
- | 1280 |
+ 243 |
! |
- as.character(tags$code("unsupported variable type", class = "text-blue"))
+ toString(missing_packages)
|
- | 1281 |
+ 244 |
|
- }
+ ))
|
- | 1282 |
+ 245 |
|
-
+ }
|
- | 1283 |
+ 246 |
|
|
- | 1284 |
+ 247 |
|
- custom_sparkline_formatter <- function(labels, counts) {
+ # Normalize the parameters
|
- | 1285 |
+ 248 |
! |
- htmlwidgets::JS(
+ if (inherits(x, "data_extract_spec")) x <- list(x)
|
- | 1286 |
+ 249 |
! |
- sprintf(
+ if (inherits(y, "data_extract_spec")) y <- list(y)
|
- | 1287 |
+ 250 |
! |
- "function(sparkline, options, field) {
+ if (inherits(color_by, "data_extract_spec")) color_by <- list(color_by)
|
- | 1288 |
+ 251 |
! |
- return 'ID: ' + %s[field[0].offset] + '<br>' + 'Count: ' + %s[field[0].offset];
- |
-
-
- | 1289 |
- |
-
- }",
+ if (inherits(size_by, "data_extract_spec")) size_by <- list(size_by)
|
- | 1290 |
+ 252 |
! |
- jsonlite::toJSON(labels),
+ if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)
|
- | 1291 |
+ 253 |
! |
- jsonlite::toJSON(counts)
- |
-
-
- | 1292 |
- |
-
- )
- |
-
-
- | 1293 |
- |
-
- )
- |
-
-
- | 1294 |
- |
-
- }
+ if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)
|
-
-
-
-
-
-
-
- | 1 |
- |
+
+ | 254 |
+ ! |
- #' `teal` module: Cross-table
+ if (is.double(max_deg)) max_deg <- as.integer(max_deg)
|
- | 2 |
+ 255 |
|
- #'
+
|
- | 3 |
+ 256 |
|
- #' Generates a simple cross-table of two variables from a dataset with custom
+ # Start of assertions
|
-
- | 4 |
- |
+
+ | 257 |
+ ! |
- #' options for showing percentages and sub-totals.
+ checkmate::assert_string(label)
|
-
- | 5 |
- |
+
+ | 258 |
+ ! |
- #'
+ checkmate::assert_list(x, types = "data_extract_spec")
|
-
- | 6 |
- |
+
+ | 259 |
+ ! |
- #' @inheritParams teal::module
+ checkmate::assert_list(y, types = "data_extract_spec")
|
-
- | 7 |
- |
+
+ | 260 |
+ ! |
- #' @inheritParams shared_params
+ checkmate::assert_list(color_by, types = "data_extract_spec", null.ok = TRUE)
|
-
- | 8 |
- |
+
+ | 261 |
+ ! |
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)
+ checkmate::assert_list(size_by, types = "data_extract_spec", null.ok = TRUE)
|
- | 9 |
+ 262 |
|
- #' Object with all available choices with pre-selected option for variable X - row values.
+
|
-
- | 10 |
- |
+
+ | 263 |
+ ! |
- #' In case of `data_extract_spec` use `select_spec(..., ordered = TRUE)` if table elements should be
+ checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)
|
-
- | 11 |
- |
+
+ | 264 |
+ ! |
- #' rendered according to selection order.
+ assert_single_selection(row_facet)
|
- | 12 |
+ 265 |
|
- #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`)
+
|
-
- | 13 |
- |
+
+ | 266 |
+ ! |
- #' Object with all available choices with pre-selected option for variable Y - column values.
+ checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)
|
-
- | 14 |
- |
+
+ | 267 |
+ ! |
- #'
+ assert_single_selection(col_facet)
|
- | 15 |
+ 268 |
|
- #' `data_extract_spec` must not allow multiple selection in this case.
+
|
-
- | 16 |
- |
+
+ | 269 |
+ ! |
- #' @param show_percentage (`logical(1)`)
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
|
-
- | 17 |
- |
+
+ | 270 |
+ ! |
- #' Indicates whether to show percentages (relevant only when `x` is a `factor`).
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
|
-
- | 18 |
- |
+
+ | 271 |
+ ! |
- #' Defaults to `TRUE`.
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
|
-
- | 19 |
- |
+
+ | 272 |
+ ! |
- #' @param show_total (`logical(1)`)
+ checkmate::assert_numeric(
|
-
- | 20 |
- |
+
+ | 273 |
+ ! |
- #' Indicates whether to show total column.
+ plot_width[1],
|
-
- | 21 |
- |
+
+ | 274 |
+ ! |
- #' Defaults to `TRUE`.
+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
|
- | 22 |
+ 275 |
|
- #'
+ )
|
- | 23 |
+ 276 |
|
- #' @note For more examples, please see the vignette "Using cross table" via
+
|
-
- | 24 |
- |
+
+ | 277 |
+ ! |
- #' `vignette("using-cross-table", package = "teal.modules.general")`.
+ if (length(alpha) == 1) {
|
-
- | 25 |
- |
+
+ | 278 |
+ ! |
- #'
+ checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE)
|
- | 26 |
+ 279 |
|
- #' @inherit shared_params return
+ } else {
|
-
- | 27 |
- |
+
+ | 280 |
+ ! |
- #'
+ checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE)
|
-
- | 28 |
- |
+
+ | 281 |
+ ! |
- #' @examples
+ checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")
|
- | 29 |
+ 282 |
|
- #' # general data example
+ }
|
- | 30 |
+ 283 |
|
- #' library(teal.widgets)
+
|
-
- | 31 |
- |
+
+ | 284 |
+ ! |
- #'
+ checkmate::assert_character(shape)
|
- | 32 |
+ 285 |
|
- #' data <- teal_data()
+
|
-
- | 33 |
- |
+
+ | 286 |
+ ! |
- #' data <- within(data, {
+ if (length(size) == 1) {
|
-
- | 34 |
- |
+
+ | 287 |
+ ! |
- #' mtcars <- mtcars
+ checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE)
|
- | 35 |
+ 288 |
|
- #' for (v in c("cyl", "vs", "am", "gear")) {
+ } else {
|
-
- | 36 |
- |
+
+ | 289 |
+ ! |
- #' mtcars[[v]] <- as.factor(mtcars[[v]])
+ checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE)
|
-
- | 37 |
- |
+
+ | 290 |
+ ! |
- #' }
+ checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")
|
- | 38 |
+ 291 |
|
- #' mtcars[["primary_key"]] <- seq_len(nrow(mtcars))
+ }
|
- | 39 |
+ 292 |
|
- #' })
+
|
-
- | 40 |
- |
+
+ | 293 |
+ ! |
- #' datanames(data) <- "mtcars"
+ checkmate::assert_int(max_deg, lower = 1L)
|
-
- | 41 |
- |
+
+ | 294 |
+ ! |
- #' join_keys(data) <- join_keys(join_key("mtcars", "mtcars", "primary_key"))
+ checkmate::assert_flag(rotate_xaxis_labels)
|
-
- | 42 |
- |
+
+ | 295 |
+ ! |
- #'
+ ggtheme <- match.arg(ggtheme)
|
- | 43 |
+ 296 |
|
- #' app <- init(
+
|
-
- | 44 |
- |
+
+ | 297 |
+ ! |
- #' data = data,
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
-
- | 45 |
- |
+
+ | 298 |
+ ! |
- #' modules = modules(
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
- | 46 |
+ 299 |
|
- #' tm_t_crosstable(
+
|
-
- | 47 |
- |
+
+ | 300 |
+ ! |
- #' label = "Cross Table",
+ checkmate::assert_scalar(table_dec)
|
-
- | 48 |
- |
+
+ | 301 |
+ ! |
- #' x = data_extract_spec(
+ checkmate::assert_class(ggplot2_args, "ggplot2_args")
|
- | 49 |
+ 302 |
|
- #' dataname = "mtcars",
+ # End of assertions
|
- | 50 |
+ 303 |
|
- #' select = select_spec(
+
|
- | 51 |
+ 304 |
|
- #' label = "Select variable:",
+ # Make UI args
|
-
- | 52 |
- |
+
+ | 305 |
+ ! |
- #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
+ args <- as.list(environment())
|
- | 53 |
+ 306 |
|
- #' selected = c("cyl", "gear"),
+
|
-
- | 54 |
- |
+
+ | 307 |
+ ! |
- #' multiple = TRUE,
+ data_extract_list <- list(
|
-
- | 55 |
- |
+
+ | 308 |
+ ! |
- #' ordered = TRUE,
+ x = x,
|
-
- | 56 |
- |
+
+ | 309 |
+ ! |
- #' fixed = FALSE
+ y = y,
|
-
- | 57 |
- |
+
+ | 310 |
+ ! |
- #' )
+ color_by = color_by,
|
-
- | 58 |
- |
+
+ | 311 |
+ ! |
- #' ),
+ size_by = size_by,
|
-
- | 59 |
- |
+
+ | 312 |
+ ! |
- #' y = data_extract_spec(
+ row_facet = row_facet,
|
-
- | 60 |
- |
+
+ | 313 |
+ ! |
- #' dataname = "mtcars",
+ col_facet = col_facet
|
- | 61 |
+ 314 |
|
- #' select = select_spec(
+ )
|
- | 62 |
+ 315 |
|
- #' label = "Select variable:",
+
|
-
- | 63 |
- |
+
+ | 316 |
+ ! |
- #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")),
+ ans <- module(
|
-
- | 64 |
- |
+
+ | 317 |
+ ! |
- #' selected = "vs",
+ label = label,
|
-
- | 65 |
- |
+
+ | 318 |
+ ! |
- #' multiple = FALSE,
+ server = srv_g_scatterplot,
|
-
- | 66 |
- |
+
+ | 319 |
+ ! |
- #' fixed = FALSE
+ ui = ui_g_scatterplot,
|
-
- | 67 |
- |
+
+ | 320 |
+ ! |
- #' )
+ ui_args = args,
|
-
- | 68 |
- |
+
+ | 321 |
+ ! |
- #' ),
+ server_args = c(
|
-
- | 69 |
- |
+
+ | 322 |
+ ! |
- #' basic_table_args = basic_table_args(
+ data_extract_list,
|
-
- | 70 |
- |
+
+ | 323 |
+ ! |
- #' subtitles = "Table generated by Crosstable Module"
+ list(plot_height = plot_height, plot_width = plot_width, table_dec = table_dec, ggplot2_args = ggplot2_args)
|
- | 71 |
+ 324 |
|
- #' )
+ ),
|
-
- | 72 |
- |
+
+ | 325 |
+ ! |
- #' )
+ datanames = teal.transform::get_extract_datanames(data_extract_list)
|
- | 73 |
+ 326 |
|
- #' )
+ )
|
-
- | 74 |
- |
+
+ | 327 |
+ ! |
- #' )
+ attr(ans, "teal_bookmarkable") <- TRUE
|
-
- | 75 |
- |
+
+ | 328 |
+ ! |
- #' if (interactive()) {
+ ans
|
- | 76 |
+ 329 |
|
- #' shinyApp(app$ui, app$server)
+ }
|
- | 77 |
+ 330 |
|
- #' }
+
|
- | 78 |
+ 331 |
|
- #'
+ # UI function for the scatterplot module
|
- | 79 |
+ 332 |
|
- #' # CDISC data example
+ ui_g_scatterplot <- function(id, ...) {
|
-
- | 80 |
- |
+
+ | 333 |
+ ! |
- #' library(teal.widgets)
+ args <- list(...)
|
-
- | 81 |
- |
+
+ | 334 |
+ ! |
- #'
+ ns <- NS(id)
|
-
- | 82 |
- |
+
+ | 335 |
+ ! |
- #' data <- teal_data()
+ is_single_dataset_value <- teal.transform::is_single_dataset(
|
-
- | 83 |
- |
+
+ | 336 |
+ ! |
- #' data <- within(data, {
+ args$x, args$y, args$color_by, args$size_by, args$row_facet, args$col_facet
|
- | 84 |
+ 337 |
|
- #' ADSL <- rADSL
+ )
|
- | 85 |
+ 338 |
|
- #' })
+
|
-
- | 86 |
- |
+
+ | 339 |
+ ! |
- #' datanames(data) <- "ADSL"
+ tagList(
|
-
- | 87 |
- |
+
+ | 340 |
+ ! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
+ include_css_files("custom"),
|
-
- | 88 |
- |
+
+ | 341 |
+ ! |
- #'
+ teal.widgets::standard_layout(
|
-
- | 89 |
- |
+
+ | 342 |
+ ! |
- #' app <- init(
+ output = teal.widgets::white_small_well(
|
-
- | 90 |
- |
+
+ | 343 |
+ ! |
- #' data = data,
+ teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")),
|
-
- | 91 |
- |
+
+ | 344 |
+ ! |
- #' modules = modules(
+ tags$h1(tags$strong("Selected points:"), class = "text-center font-150p"),
|
-
- | 92 |
- |
+
+ | 345 |
+ ! |
- #' tm_t_crosstable(
+ teal.widgets::get_dt_rows(ns("data_table"), ns("data_table_rows")),
|
-
- | 93 |
- |
+
+ | 346 |
+ ! |
- #' label = "Cross Table",
+ DT::dataTableOutput(ns("data_table"), width = "100%")
|
- | 94 |
+ 347 |
|
- #' x = data_extract_spec(
+ ),
|
-
- | 95 |
- |
+
+ | 348 |
+ ! |
- #' dataname = "ADSL",
+ encoding = tags$div(
|
- | 96 |
+ 349 |
|
- #' select = select_spec(
+ ### Reporter
|
-
- | 97 |
- |
+
+ | 350 |
+ ! |
- #' label = "Select variable:",
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
- | 98 |
+ 351 |
|
- #' choices = variable_choices(data[["ADSL"]], subset = function(data) {
+ ###
|
-
- | 99 |
- |
+
+ | 352 |
+ ! |
- #' idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt"))
+ tags$label("Encodings", class = "text-primary"),
|
-
- | 100 |
- |
+
+ | 353 |
+ ! |
- #' return(names(data)[idx])
+ teal.transform::datanames_input(args[c("x", "y", "color_by", "size_by", "row_facet", "col_facet")]),
|
-
- | 101 |
- |
+
+ | 354 |
+ ! |
- #' }),
+ teal.transform::data_extract_ui(
|
-
- | 102 |
- |
+
+ | 355 |
+ ! |
- #' selected = "COUNTRY",
+ id = ns("x"),
|
-
- | 103 |
- |
+
+ | 356 |
+ ! |
- #' multiple = TRUE,
+ label = "X variable",
|
-
- | 104 |
- |
+
+ | 357 |
+ ! |
- #' ordered = TRUE,
+ data_extract_spec = args$x,
|
-
- | 105 |
- |
+
+ | 358 |
+ ! |
- #' fixed = FALSE
+ is_single_dataset = is_single_dataset_value
|
- | 106 |
+ 359 |
|
- #' )
+ ),
|
-
- | 107 |
- |
+
+ | 360 |
+ ! |
- #' ),
+ checkboxInput(ns("log_x"), "Use log transformation", value = FALSE),
|
-
- | 108 |
- |
+
+ | 361 |
+ ! |
- #' y = data_extract_spec(
+ conditionalPanel(
|
-
- | 109 |
- |
+
+ | 362 |
+ ! |
- #' dataname = "ADSL",
+ condition = paste0("input['", ns("log_x"), "'] == true"),
|
-
- | 110 |
- |
+
+ | 363 |
+ ! |
- #' select = select_spec(
+ radioButtons(
|
-
- | 111 |
- |
+
+ | 364 |
+ ! |
- #' label = "Select variable:",
+ ns("log_x_base"),
|
-
- | 112 |
- |
+
+ | 365 |
+ ! |
- #' choices = variable_choices(data[["ADSL"]], subset = function(data) {
+ label = NULL,
|
-
- | 113 |
- |
+
+ | 366 |
+ ! |
- #' idx <- vapply(data, is.factor, logical(1))
+ inline = TRUE,
|
-
- | 114 |
- |
+
+ | 367 |
+ ! |
- #' return(names(data)[idx])
+ choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
|
- | 115 |
+ 368 |
|
- #' }),
+ )
|
- | 116 |
+ 369 |
|
- #' selected = "SEX",
+ ),
|
-
- | 117 |
- |
+
+ | 370 |
+ ! |
- #' multiple = FALSE,
+ teal.transform::data_extract_ui(
|
-
- | 118 |
- |
+
+ | 371 |
+ ! |
- #' fixed = FALSE
+ id = ns("y"),
|
-
- | 119 |
- |
+
+ | 372 |
+ ! |
- #' )
+ label = "Y variable",
|
-
- | 120 |
- |
+
+ | 373 |
+ ! |
- #' ),
+ data_extract_spec = args$y,
|
-
- | 121 |
- |
+
+ | 374 |
+ ! |
- #' basic_table_args = basic_table_args(
+ is_single_dataset = is_single_dataset_value
|
- | 122 |
+ 375 |
|
- #' subtitles = "Table generated by Crosstable Module"
+ ),
|
-
- | 123 |
- |
+
+ | 376 |
+ ! |
- #' )
+ checkboxInput(ns("log_y"), "Use log transformation", value = FALSE),
|
-
- | 124 |
- |
+
+ | 377 |
+ ! |
- #' )
+ conditionalPanel(
|
-
- | 125 |
- |
+
+ | 378 |
+ ! |
- #' )
+ condition = paste0("input['", ns("log_y"), "'] == true"),
|
-
- | 126 |
- |
+
+ | 379 |
+ ! |
- #' )
+ radioButtons(
|
-
- | 127 |
- |
+
+ | 380 |
+ ! |
- #' if (interactive()) {
+ ns("log_y_base"),
|
-
- | 128 |
- |
+
+ | 381 |
+ ! |
- #' shinyApp(app$ui, app$server)
+ label = NULL,
|
-
- | 129 |
- |
+
+ | 382 |
+ ! |
- #' }
+ inline = TRUE,
|
-
- | 130 |
- |
+
+ | 383 |
+ ! |
- #'
+ choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2")
|
- | 131 |
+ 384 |
|
- #' @export
+ )
|
- | 132 |
+ 385 |
|
- #'
+ ),
|
-
- | 133 |
- |
+
+ | 386 |
+ ! |
- tm_t_crosstable <- function(label = "Cross Table",
+ if (!is.null(args$color_by)) {
|
-
- | 134 |
- |
+
+ | 387 |
+ ! |
- x,
+ teal.transform::data_extract_ui(
|
-
- | 135 |
- |
+
+ | 388 |
+ ! |
- y,
+ id = ns("color_by"),
|
-
- | 136 |
- |
+
+ | 389 |
+ ! |
- show_percentage = TRUE,
+ label = "Color by variable",
|
-
- | 137 |
- |
+
+ | 390 |
+ ! |
- show_total = TRUE,
+ data_extract_spec = args$color_by,
|
-
- | 138 |
- |
+
+ | 391 |
+ ! |
- pre_output = NULL,
+ is_single_dataset = is_single_dataset_value
|
- | 139 |
+ 392 |
|
- post_output = NULL,
+ )
|
- | 140 |
+ 393 |
|
- basic_table_args = teal.widgets::basic_table_args()) {
+ },
|
- | 141 |
+ 394 |
! |
- message("Initializing tm_t_crosstable")
+ if (!is.null(args$size_by)) {
|
-
- | 142 |
- |
+
+ | 395 |
+ ! |
-
+ teal.transform::data_extract_ui(
|
-
- | 143 |
- |
+
+ | 396 |
+ ! |
- # Requires Suggested packages
+ id = ns("size_by"),
|
- | 144 |
+ 397 |
! |
- if (!requireNamespace("rtables", quietly = TRUE)) {
+ label = "Size by variable",
|
- | 145 |
+ 398 |
! |
- stop("Cannot load rtables - please install the package or restart your session.")
+ data_extract_spec = args$size_by,
|
-
- | 146 |
- |
+
+ | 399 |
+ ! |
- }
+ is_single_dataset = is_single_dataset_value
|
- | 147 |
+ 400 |
|
-
+ )
|
- | 148 |
+ 401 |
|
- # Normalize the parameters
+ },
|
- | 149 |
+ 402 |
! |
- if (inherits(x, "data_extract_spec")) x <- list(x)
+ if (!is.null(args$row_facet)) {
|
- | 150 |
+ 403 |
! |
- if (inherits(y, "data_extract_spec")) y <- list(y)
+ teal.transform::data_extract_ui(
|
-
- | 151 |
- |
+
+ | 404 |
+ ! |
-
+ id = ns("row_facet"),
|
-
- | 152 |
- |
+
+ | 405 |
+ ! |
- # Start of assertions
+ label = "Row facetting",
|
- | 153 |
+ 406 |
! |
- checkmate::assert_string(label)
+ data_extract_spec = args$row_facet,
|
- | 154 |
+ 407 |
! |
- checkmate::assert_list(x, types = "data_extract_spec")
+ is_single_dataset = is_single_dataset_value
|
- | 155 |
+ 408 |
|
-
+ )
|
-
- | 156 |
- ! |
+
+ | 409 |
+ |
- checkmate::assert_list(y, types = "data_extract_spec")
+ },
|
- | 157 |
+ 410 |
! |
- assert_single_selection(y)
- |
-
-
- | 158 |
- |
-
-
+ if (!is.null(args$col_facet)) {
|
- | 159 |
+ 411 |
! |
- checkmate::assert_flag(show_percentage)
+ teal.transform::data_extract_ui(
|
- | 160 |
+ 412 |
! |
- checkmate::assert_flag(show_total)
+ id = ns("col_facet"),
|
- | 161 |
+ 413 |
! |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ label = "Column facetting",
|
- | 162 |
+ 414 |
! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ data_extract_spec = args$col_facet,
|
- | 163 |
+ 415 |
! |
- checkmate::assert_class(basic_table_args, classes = "basic_table_args")
+ is_single_dataset = is_single_dataset_value
|
- | 164 |
+ 416 |
|
- # End of assertions
+ )
|
- | 165 |
+ 417 |
|
-
+ },
|
-
- | 166 |
- |
+
+ | 418 |
+ ! |
- # Make UI args
+ teal.widgets::panel_group(
|
- | 167 |
+ 419 |
! |
- ui_args <- as.list(environment())
+ teal.widgets::panel_item(
|
-
- | 168 |
- |
+
+ | 420 |
+ ! |
-
+ title = "Plot settings",
|
- | 169 |
+ 421 |
! |
- server_args <- list(
+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
|
- | 170 |
+ 422 |
! |
- label = label,
+ teal.widgets::optionalSelectInput(
|
- | 171 |
+ 423 |
! |
- x = x,
+ inputId = ns("shape"),
|
- | 172 |
+ 424 |
! |
- y = y,
+ label = "Points shape:",
|
- | 173 |
+ 425 |
! |
- basic_table_args = basic_table_args
+ choices = args$shape,
|
-
- | 174 |
- |
+
+ | 426 |
+ ! |
- )
+ selected = args$shape[1],
+ |
+
+
+ | 427 |
+ ! |
+
+ multiple = FALSE
|
- | 175 |
+ 428 |
|
-
+ ),
|
- | 176 |
+ 429 |
! |
- ans <- module(
+ colourpicker::colourInput(ns("color"), "Points color:", "black"),
|
- | 177 |
+ 430 |
! |
- label = label,
+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE, step = .1),
|
- | 178 |
+ 431 |
! |
- server = srv_t_crosstable,
+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
|
- | 179 |
+ 432 |
! |
- ui = ui_t_crosstable,
+ checkboxInput(ns("add_density"), "Add marginal density", value = FALSE),
|
- | 180 |
+ 433 |
! |
- ui_args = ui_args,
+ checkboxInput(ns("rug_plot"), "Include rug plot", value = FALSE),
|
- | 181 |
+ 434 |
! |
- server_args = server_args,
+ checkboxInput(ns("show_count"), "Show N (number of observations)", value = FALSE),
|
- | 182 |
+ 435 |
! |
- datanames = teal.transform::get_extract_datanames(list(x = x, y = y))
+ shinyjs::hidden(helpText(id = ns("line_msg"), "Trendline needs numeric X and Y variables")),
|
-
- | 183 |
- |
+
+ | 436 |
+ ! |
- )
+ teal.widgets::optionalSelectInput(ns("smoothing_degree"), "Smoothing degree", seq_len(args$max_deg)),
|
- | 184 |
+ 437 |
! |
- attr(ans, "teal_bookmarkable") <- TRUE
+ shinyjs::hidden(teal.widgets::optionalSelectInput(ns("color_sub"), label = "", multiple = TRUE)),
|
- | 185 |
+ 438 |
! |
- ans
+ teal.widgets::optionalSliderInputValMinMax(ns("ci"), "Confidence", c(.95, .8, .99), ticks = FALSE),
|
-
- | 186 |
- |
+
+ | 439 |
+ ! |
- }
+ shinyjs::hidden(checkboxInput(ns("show_form"), "Show formula", value = TRUE)),
|
-
- | 187 |
- |
+
+ | 440 |
+ ! |
-
+ shinyjs::hidden(checkboxInput(ns("show_r2"), "Show adj-R Squared", value = TRUE)),
|
-
- | 188 |
- |
+
+ | 441 |
+ ! |
- # UI function for the cross-table module
+ uiOutput(ns("num_na_removed")),
|
-
- | 189 |
- |
+
+ | 442 |
+ ! |
- ui_t_crosstable <- function(id, x, y, show_percentage, show_total, pre_output, post_output, ...) {
+ tags$div(
|
- | 190 |
+ 443 |
! |
- ns <- NS(id)
+ id = ns("label_pos"),
|
- | 191 |
+ 444 |
! |
- is_single_dataset <- teal.transform::is_single_dataset(x, y)
+ tags$div(tags$strong("Stats position")),
|
-
- | 192 |
- |
+
+ | 445 |
+ ! |
-
+ tags$div(class = "inline-block w-10", helpText("Left")),
|
- | 193 |
+ 446 |
! |
- join_default_options <- c(
+ tags$div(
|
- | 194 |
+ 447 |
! |
- "Full Join" = "dplyr::full_join",
+ class = "inline-block w-70",
|
- | 195 |
+ 448 |
! |
- "Inner Join" = "dplyr::inner_join",
+ teal.widgets::optionalSliderInput(
|
- | 196 |
+ 449 |
! |
- "Left Join" = "dplyr::left_join",
+ ns("pos"),
|
- | 197 |
+ 450 |
! |
- "Right Join" = "dplyr::right_join"
+ label = NULL,
+ |
+
+
+ | 451 |
+ ! |
+
+ min = 0, max = 1, value = .99, ticks = FALSE, step = .01
|
- | 198 |
+ 452 |
|
- )
+ )
|
- | 199 |
+ 453 |
|
-
+ ),
|
- | 200 |
+ 454 |
! |
- teal.widgets::standard_layout(
+ tags$div(class = "inline-block w-10", helpText("Right"))
+ |
+
+
+ | 455 |
+ |
+
+ ),
|
- | 201 |
+ 456 |
! |
- output = teal.widgets::white_small_well(
+ teal.widgets::optionalSliderInput(
|
- | 202 |
+ 457 |
! |
- textOutput(ns("title")),
+ ns("label_size"), "Stats font size",
|
- | 203 |
+ 458 |
! |
- teal.widgets::table_with_settings_ui(ns("table"))
+ min = 3, max = 10, value = 5, ticks = FALSE, step = .1
|
- | 204 |
+ 459 |
|
- ),
+ ),
|
- | 205 |
+ 460 |
! |
- encoding = tags$div(
- |
-
-
- | 206 |
- |
-
- ### Reporter
+ if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
|
- | 207 |
+ 461 |
! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ checkboxInput(ns("free_scales"), "Free scales", value = FALSE)
|
- | 208 |
+ 462 |
|
- ###
+ },
|
- | 209 |
+ 463 |
! |
- tags$label("Encodings", class = "text-primary"),
+ selectInput(
|
- | 210 |
+ 464 |
! |
- teal.transform::datanames_input(list(x, y)),
+ inputId = ns("ggtheme"),
|
- | 211 |
+ 465 |
! |
- teal.transform::data_extract_ui(ns("x"), label = "Row values", x, is_single_dataset = is_single_dataset),
+ label = "Theme (by ggplot):",
|
- | 212 |
+ 466 |
! |
- teal.transform::data_extract_ui(ns("y"), label = "Column values", y, is_single_dataset = is_single_dataset),
+ choices = ggplot_themes,
|
- | 213 |
+ 467 |
! |
- teal.widgets::optionalSelectInput(
+ selected = args$ggtheme,
|
- | 214 |
+ 468 |
! |
- ns("join_fun"),
+ multiple = FALSE
|
-
- | 215 |
- ! |
+
+ | 469 |
+ |
- label = "Row to Column type of join",
+ )
|
-
- | 216 |
- ! |
+
+ | 470 |
+ |
- choices = join_default_options,
+ )
+ |
+
+
+ | 471 |
+ |
+
+ )
+ |
+
+
+ | 472 |
+ |
+
+ ),
|
- | 217 |
+ 473 |
! |
- selected = join_default_options[1],
+ forms = tagList(
|
- | 218 |
+ 474 |
! |
- multiple = FALSE
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
- | 219 |
+ 475 |
|
),
|
- | 220 |
+ 476 |
! |
- tags$hr(),
+ pre_output = args$pre_output,
|
- | 221 |
+ 477 |
! |
- teal.widgets::panel_group(
+ post_output = args$post_output
|
-
- | 222 |
- ! |
+
+ | 478 |
+ |
- teal.widgets::panel_item(
+ )
|
-
- | 223 |
- ! |
+
+ | 479 |
+ |
- title = "Table settings",
+ )
|
-
- | 224 |
- ! |
+
+ | 480 |
+ |
- checkboxInput(ns("show_percentage"), "Show column percentage", value = show_percentage),
+ }
|
-
- | 225 |
- ! |
+
+ | 481 |
+ |
- checkboxInput(ns("show_total"), "Show total column", value = show_total)
+
|
- | 226 |
+ 482 |
|
- )
+ # Server function for the scatterplot module
|
- | 227 |
+ 483 |
|
- )
+ srv_g_scatterplot <- function(id,
|
- | 228 |
+ 484 |
|
- ),
+ data,
|
-
- | 229 |
- ! |
+
+ | 485 |
+ |
- forms = tagList(
+ reporter,
|
-
- | 230 |
- ! |
+
+ | 486 |
+ |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ filter_panel_api,
|
- | 231 |
+ 487 |
|
- ),
+ x,
|
-
- | 232 |
- ! |
+
+ | 488 |
+ |
- pre_output = pre_output,
+ y,
+ |
+
+
+ | 489 |
+ |
+
+ color_by,
+ |
+
+
+ | 490 |
+ |
+
+ size_by,
|
-
- | 233 |
- ! |
+
+ | 491 |
+ |
- post_output = post_output
+ row_facet,
|
- | 234 |
+ 492 |
|
- )
+ col_facet,
|
- | 235 |
+ 493 |
|
- }
+ plot_height,
|
- | 236 |
+ 494 |
|
-
+ plot_width,
|
- | 237 |
+ 495 |
|
- # Server function for the cross-table module
+ table_dec,
|
- | 238 |
+ 496 |
|
- srv_t_crosstable <- function(id, data, reporter, filter_panel_api, label, x, y, basic_table_args) {
+ ggplot2_args) {
|
- | 239 |
+ 497 |
! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
|
- | 240 |
+ 498 |
! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
|
- | 241 |
+ 499 |
! |
checkmate::assert_class(data, "reactive")
|
- | 242 |
+ 500 |
! |
checkmate::assert_class(isolate(data()), "teal_data")
|
- | 243 |
+ 501 |
! |
moduleServer(id, function(input, output, session) {
|
- | 244 |
+ 502 |
! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
|
- | 245 |
+ 503 |
|
|
- | 246 |
+ 504 |
! |
- selector_list <- teal.transform::data_extract_multiple_srv(
+ data_extract <- list(
|
- | 247 |
+ 505 |
! |
- data_extract = list(x = x, y = y),
+ x = x,
|
- | 248 |
+ 506 |
! |
- datasets = data,
+ y = y,
|
- | 249 |
+ 507 |
! |
- select_validation_rule = list(
+ color_by = color_by,
|
- | 250 |
+ 508 |
! |
- x = shinyvalidate::sv_required("Please define column for row variable."),
+ size_by = size_by,
|
- | 251 |
+ 509 |
! |
- y = shinyvalidate::sv_required("Please define column for column variable.")
+ row_facet = row_facet,
|
-
- | 252 |
- |
+
+ | 510 |
+ ! |
- )
+ col_facet = col_facet
|
- | 253 |
+ 511 |
|
)
|
- | 254 |
+ 512 |
|
|
- | 255 |
+ 513 |
! |
- iv_r <- reactive({
+ rule_diff <- function(other) {
|
- | 256 |
+ 514 |
! |
- iv <- shinyvalidate::InputValidator$new()
+ function(value) {
|
- | 257 |
+ 515 |
! |
- iv$add_rule("join_fun", function(value) {
+ othervalue <- selector_list()[[other]]()[["select"]]
|
- | 258 |
+ 516 |
! |
- if (!identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
+ if (!is.null(othervalue)) {
|
- | 259 |
+ 517 |
! |
- if (!shinyvalidate::input_provided(value)) {
+ if (identical(value, othervalue)) {
|
- | 260 |
+ 518 |
! |
- "Please select a joining function."
+ "Row and column facetting variables must be different."
|
- | 261 |
+ 519 |
|
}
|
- | 262 |
+ 520 |
|
}
|
- | 263 |
+ 521 |
|
- })
- |
-
-
- | 264 |
- ! |
-
- teal.transform::compose_and_enable_validators(iv, selector_list)
+ }
|
- | 265 |
+ 522 |
|
- })
+ }
|
- | 266 |
+ 523 |
|
|
- | 267 |
+ 524 |
! |
- observeEvent(
+ selector_list <- teal.transform::data_extract_multiple_srv(
|
- | 268 |
+ 525 |
! |
- eventExpr = {
+ data_extract = data_extract,
|
- | 269 |
+ 526 |
! |
- req(!is.null(selector_list()$x()) && !is.null(selector_list()$y()))
+ datasets = data,
|
- | 270 |
+ 527 |
! |
- list(selector_list()$x(), selector_list()$y())
- |
-
-
- | 271 |
- |
-
- },
+ select_validation_rule = list(
|
- | 272 |
+ 528 |
! |
- handlerExpr = {
+ x = ~ if (length(.) != 1) "Please select exactly one x var.",
|
- | 273 |
+ 529 |
! |
- if (identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) {
+ y = ~ if (length(.) != 1) "Please select exactly one y var.",
|
- | 274 |
+ 530 |
! |
- shinyjs::hide("join_fun")
- |
-
-
- | 275 |
- |
-
- } else {
+ color_by = ~ if (length(.) > 1) "There cannot be more than 1 color variable.",
|
- | 276 |
+ 531 |
! |
- shinyjs::show("join_fun")
+ size_by = ~ if (length(.) > 1) "There cannot be more than 1 size variable.",
|
-
- | 277 |
- |
+
+ | 532 |
+ ! |
- }
+ row_facet = shinyvalidate::compose_rules(
|
-
- | 278 |
- |
+
+ | 533 |
+ ! |
- }
+ shinyvalidate::sv_optional(),
|
-
- | 279 |
- |
+
+ | 534 |
+ ! |
- )
+ rule_diff("col_facet")
|
- | 280 |
+ 535 |
|
-
+ ),
|
- | 281 |
+ 536 |
! |
- merge_function <- reactive({
+ col_facet = shinyvalidate::compose_rules(
|
- | 282 |
+ 537 |
! |
- if (is.null(input$join_fun)) {
+ shinyvalidate::sv_optional(),
|
- | 283 |
+ 538 |
! |
- "dplyr::full_join"
+ rule_diff("row_facet")
|
- | 284 |
+ 539 |
|
- } else {
- |
-
-
- | 285 |
- ! |
-
- input$join_fun
+ )
|
- | 286 |
+ 540 |
|
- }
+ )
|
- | 287 |
+ 541 |
|
- })
+ )
|
- | 288 |
+ 542 |
|
|
- | 289 |
+ 543 |
! |
- anl_merged_input <- teal.transform::merge_expression_srv(
+ iv_r <- reactive({
|
- | 290 |
+ 544 |
! |
- datasets = data,
+ iv_facet <- shinyvalidate::InputValidator$new()
|
- | 291 |
+ 545 |
! |
- selector_list = selector_list,
+ iv <- shinyvalidate::InputValidator$new()
|
- | 292 |
+ 546 |
! |
- merge_function = merge_function
+ teal.transform::compose_and_enable_validators(iv, selector_list)
|
- | 293 |
+ 547 |
|
- )
+ })
|
-
- | 294 |
- |
+
+ | 548 |
+ ! |
-
+ iv_facet <- shinyvalidate::InputValidator$new()
|
- | 295 |
+ 549 |
! |
- anl_merged_q <- reactive({
+ iv_facet$add_rule("add_density", ~ if (
|
- | 296 |
+ 550 |
! |
- req(anl_merged_input())
+ isTRUE(.) &&
+ |
+
+
+ | 551 |
+ |
+
+ (
|
- | 297 |
+ 552 |
! |
- data() %>%
+ length(selector_list()$row_facet()$select) > 0L ||
|
- | 298 |
+ 553 |
! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))
+ length(selector_list()$col_facet()$select) > 0L
|
- | 299 |
+ 554 |
|
- })
+ )
|
- | 300 |
+ 555 |
|
-
+ ) {
|
- | 301 |
+ 556 |
! |
- merged <- list(
+ "Cannot add marginal density when Row or Column facetting has been selected"
|
-
- | 302 |
- ! |
+
+ | 557 |
+ |
- anl_input_r = anl_merged_input,
+ })
|
- | 303 |
+ 558 |
! |
- anl_q_r = anl_merged_q
+ iv_facet$enable()
|
- | 304 |
+ 559 |
|
- )
+
|
-
- | 305 |
- |
+
+ | 560 |
+ ! |
-
+ anl_merged_input <- teal.transform::merge_expression_srv(
|
- | 306 |
+ 561 |
! |
- output_q <- reactive({
+ selector_list = selector_list,
|
- | 307 |
+ 562 |
! |
- teal::validate_inputs(iv_r())
+ datasets = data,
|
- | 308 |
+ 563 |
! |
- ANL <- merged$anl_q_r()[["ANL"]]
+ merge_function = "dplyr::inner_join"
|
- | 309 |
+ 564 |
|
-
+ )
|
- | 310 |
+ 565 |
|
- # As this is a summary
+
|
- | 311 |
+ 566 |
! |
- x_name <- as.vector(merged$anl_input_r()$columns_source$x)
+ anl_merged_q <- reactive({
|
- | 312 |
+ 567 |
! |
- y_name <- as.vector(merged$anl_input_r()$columns_source$y)
+ req(anl_merged_input())
|
-
- | 313 |
- |
+
+ | 568 |
+ ! |
-
+ data() %>%
|
- | 314 |
+ 569 |
! |
- teal::validate_has_data(ANL, 3)
+ teal.code::eval_code(as.expression(anl_merged_input()$expr)) %>%
|
- | 315 |
+ 570 |
! |
- teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE)
+ teal.code::eval_code(quote(ANL)) # used to display table when running show-r-code code
|
- | 316 |
+ 571 |
+ |
+
+ })
+ |
+
+
+ | 572 |
|
|
- | 317 |
+ 573 |
! |
- is_allowed_class <- function(x) is.numeric(x) || is.factor(x) || is.character(x) || is.logical(x)
+ merged <- list(
|
- | 318 |
+ 574 |
! |
- validate(need(
+ anl_input_r = anl_merged_input,
|
- | 319 |
+ 575 |
! |
- all(vapply(ANL[x_name], is_allowed_class, logical(1))),
+ anl_q_r = anl_merged_q
|
-
- | 320 |
- ! |
+
+ | 576 |
+ |
- "Selected row variable has an unsupported data type."
+ )
|
- | 321 |
+ 577 |
|
- ))
+
|
- | 322 |
+ 578 |
! |
- validate(need(
+ trend_line_is_applicable <- reactive({
|
- | 323 |
+ 579 |
! |
- is_allowed_class(ANL[[y_name]]),
+ ANL <- merged$anl_q_r()[["ANL"]]
|
- | 324 |
+ 580 |
! |
- "Selected column variable has an unsupported data type."
+ x_var <- as.vector(merged$anl_input_r()$columns_source$x)
+ |
+
+
+ | 581 |
+ ! |
+
+ y_var <- as.vector(merged$anl_input_r()$columns_source$y)
+ |
+
+
+ | 582 |
+ ! |
+
+ length(x_var) > 0 && length(y_var) > 0 && is.numeric(ANL[[x_var]]) && is.numeric(ANL[[y_var]])
|
- | 325 |
+ 583 |
|
- ))
+ })
|
- | 326 |
+ 584 |
|
|
- | 327 |
+ 585 |
! |
- show_percentage <- input$show_percentage
+ add_trend_line <- reactive({
|
- | 328 |
+ 586 |
! |
- show_total <- input$show_total
+ smoothing_degree <- as.integer(input$smoothing_degree)
+ |
+
+
+ | 587 |
+ ! |
+
+ trend_line_is_applicable() && length(smoothing_degree) > 0
|
- | 329 |
+ 588 |
|
-
+ })
|
-
- | 330 |
- ! |
+
+ | 589 |
+ |
- plot_title <- paste(
+
|
- | 331 |
+ 590 |
! |
- "Cross-Table of",
+ if (!is.null(color_by)) {
|
- | 332 |
+ 591 |
! |
- paste0(varname_w_label(x_name, ANL), collapse = ", "),
+ observeEvent(
|
- | 333 |
+ 592 |
! |
- "(rows)", "vs.",
+ eventExpr = merged$anl_input_r()$columns_source$color_by,
|
- | 334 |
+ 593 |
! |
- varname_w_label(y_name, ANL),
+ handlerExpr = {
|
- | 335 |
+ 594 |
! |
- "(columns)"
- |
-
-
- | 336 |
- |
-
- )
+ color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by)
|
-
- | 337 |
- |
+
+ | 595 |
+ ! |
-
+ if (length(color_by_var) > 0) {
|
- | 338 |
+ 596 |
! |
- labels_vec <- vapply(
+ shinyjs::hide("color")
|
-
- | 339 |
- ! |
+
+ | 597 |
+ |
- x_name,
+ } else {
|
- | 340 |
+ 598 |
! |
- varname_w_label,
+ shinyjs::show("color")
|
-
- | 341 |
- ! |
+
+ | 599 |
+ |
- character(1),
+ }
|
-
- | 342 |
- ! |
+
+ | 600 |
+ |
- ANL
+ }
|
- | 343 |
+ 601 |
|
)
|
- | 344 |
+ 602 |
+ |
+
+ }
+ |
+
+
+ | 603 |
|
|
- | 345 |
+ 604 |
! |
- teal.code::eval_code(
+ output$num_na_removed <- renderUI({
|
- | 346 |
+ 605 |
! |
- merged$anl_q_r(),
+ if (add_trend_line()) {
|
- | 347 |
+ 606 |
! |
- substitute(
+ ANL <- merged$anl_q_r()[["ANL"]]
|
- | 348 |
+ 607 |
! |
- expr = {
+ x_var <- as.vector(merged$anl_input_r()$columns_source$x)
|
- | 349 |
+ 608 |
! |
- title <- plot_title
+ y_var <- as.vector(merged$anl_input_r()$columns_source$y)
|
-
- | 350 |
- |
+
+ | 609 |
+ ! |
- },
+ if ((num_total_na <- nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)]))) > 0) {
|
- | 351 |
+ 610 |
! |
- env = list(plot_title = plot_title)
+ tags$div(paste(num_total_na, "row(s) with missing values were removed"), tags$hr())
|
- | 352 |
+ 611 |
|
- )
+ }
|
- | 353 |
+ 612 |
|
- ) %>%
+ }
|
-
- | 354 |
- ! |
+
+ | 613 |
+ |
- teal.code::eval_code(
+ })
|
-
- | 355 |
- ! |
+
+ | 614 |
+ |
- substitute(
+
|
- | 356 |
+ 615 |
! |
- expr = {
+ observeEvent(
|
- | 357 |
+ 616 |
! |
- lyt <- basic_tables %>%
+ eventExpr = merged$anl_input_r()$columns_source[c("col_facet", "row_facet")],
|
- | 358 |
+ 617 |
! |
- split_call %>% # styler: off
+ handlerExpr = {
|
- | 359 |
+ 618 |
! |
- rtables::add_colcounts() %>%
+ if (
|
- | 360 |
+ 619 |
! |
- tern::analyze_vars(
+ length(merged$anl_input_r()$columns_source$col_facet) == 0 &&
|
- | 361 |
+ 620 |
! |
- vars = x_name,
+ length(merged$anl_input_r()$columns_source$row_facet) == 0
|
-
- | 362 |
- ! |
+
+ | 621 |
+ |
- var_labels = labels_vec,
+ ) {
|
- | 363 |
+ 622 |
! |
- na.rm = FALSE,
+ shinyjs::hide("free_scales")
|
-
- | 364 |
- ! |
+
+ | 623 |
+ |
- denom = "N_col",
+ } else {
|
- | 365 |
+ 624 |
! |
- .stats = c("mean_sd", "median", "range", count_value)
+ shinyjs::show("free_scales")
|
- | 366 |
+ 625 |
|
- )
+ }
|
- | 367 |
+ 626 |
|
- },
+ }
|
-
- | 368 |
- ! |
+
+ | 627 |
+ |
- env = list(
+ )
+ |
+
+
+ | 628 |
+ |
+
+
|
- | 369 |
+ 629 |
! |
- basic_tables = teal.widgets::parse_basic_table_args(
+ output_q <- reactive({
|
- | 370 |
+ 630 |
! |
- basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args)
+ teal::validate_inputs(iv_r(), iv_facet)
|
- | 371 |
+ 631 |
|
- ),
+
|
- | 372 |
+ 632 |
! |
- split_call = if (show_total) {
+ ANL <- merged$anl_q_r()[["ANL"]]
|
-
- | 373 |
- ! |
+
+ | 633 |
+ |
- substitute(
+
|
- | 374 |
+ 634 |
! |
- expr = rtables::split_cols_by(
+ x_var <- as.vector(merged$anl_input_r()$columns_source$x)
|
- | 375 |
+ 635 |
! |
- y_name,
+ y_var <- as.vector(merged$anl_input_r()$columns_source$y)
|
- | 376 |
+ 636 |
! |
- split_fun = rtables::add_overall_level(label = "Total", first = FALSE)
+ color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by)
|
-
- | 377 |
- |
+
+ | 637 |
+ ! |
- ),
+ size_by_var <- as.vector(merged$anl_input_r()$columns_source$size_by)
|
- | 378 |
+ 638 |
! |
- env = list(y_name = y_name)
+ row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
|
-
- | 379 |
- |
+
+ | 639 |
+ ! |
- )
+ character(0)
|
- | 380 |
+ 640 |
|
- } else {
+ } else {
|
- | 381 |
+ 641 |
! |
- substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name))
+ as.vector(merged$anl_input_r()$columns_source$row_facet)
|
- | 382 |
+ 642 |
|
- },
- |
-
-
- | 383 |
- ! |
-
- x_name = x_name,
+ }
|
- | 384 |
+ 643 |
! |
- labels_vec = labels_vec,
+ col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
|
- | 385 |
+ 644 |
! |
- count_value = ifelse(show_percentage, "count_fraction", "count")
+ character(0)
|
- | 386 |
+ 645 |
|
- )
+ } else {
|
-
- | 387 |
- |
+
+ | 646 |
+ ! |
- )
+ as.vector(merged$anl_input_r()$columns_source$col_facet)
|
- | 388 |
+ 647 |
|
- ) %>%
+ }
|
- | 389 |
+ 648 |
! |
- teal.code::eval_code(
+ alpha <- input$alpha
|
- | 390 |
+ 649 |
! |
- substitute(
+ size <- input$size
|
- | 391 |
+ 650 |
! |
- expr = {
+ rotate_xaxis_labels <- input$rotate_xaxis_labels
|
- | 392 |
+ 651 |
! |
- ANL <- tern::df_explicit_na(ANL)
+ add_density <- input$add_density
|
- | 393 |
+ 652 |
! |
- tbl <- rtables::build_table(lyt = lyt, df = ANL[order(ANL[[y_name]]), ])
+ ggtheme <- input$ggtheme
|
- | 394 |
+ 653 |
! |
- tbl
+ rug_plot <- input$rug_plot
|
-
- | 395 |
- |
+
+ | 654 |
+ ! |
- },
+ color <- input$color
|
- | 396 |
+ 655 |
! |
- env = list(y_name = y_name)
+ shape <- `if`(is.null(input$shape) || identical(input$shape, ""), "circle", input$shape)
|
-
- | 397 |
- |
+
+ | 656 |
+ ! |
- )
+ smoothing_degree <- as.integer(input$smoothing_degree)
|
-
- | 398 |
- |
+
+ | 657 |
+ ! |
- )
+ ci <- input$ci
|
- | 399 |
+ 658 |
|
- })
+
|
-
- | 400 |
- |
+
+ | 659 |
+ ! |
-
+ log_x <- input$log_x
|
- | 401 |
+ 660 |
! |
- output$title <- renderText(output_q()[["title"]])
+ log_y <- input$log_y
|
- | 402 |
+ 661 |
|
|
- | 403 |
+ 662 |
! |
- table_r <- reactive({
+ validate(need(
|
- | 404 |
+ 663 |
! |
- req(iv_r()$is_valid())
+ length(row_facet_name) == 0 || inherits(ANL[[row_facet_name]], c("character", "factor", "Date", "integer")),
|
- | 405 |
+ 664 |
! |
- output_q()[["tbl"]]
- |
-
-
- | 406 |
- |
-
- })
+ "`Row facetting` variable must be of class `character`, `factor`, `Date`, or `integer`"
|
- | 407 |
+ 665 |
|
-
+ ))
|
- | 408 |
+ 666 |
! |
- teal.widgets::table_with_settings_srv(
+ validate(need(
|
- | 409 |
+ 667 |
! |
- id = "table",
+ length(col_facet_name) == 0 || inherits(ANL[[col_facet_name]], c("character", "factor", "Date", "integer")),
|
- | 410 |
+ 668 |
! |
- table_r = table_r
+ "`Column facetting` variable must be of class `character`, `factor`, `Date`, or `integer`"
|
- | 411 |
+ 669 |
|
- )
+ ))
|
- | 412 |
+ 670 |
|
|
- | 413 |
+ 671 |
! |
- teal.widgets::verbatim_popup_srv(
+ if (add_density && length(color_by_var) > 0) {
|
- | 414 |
+ 672 |
! |
- id = "rcode",
+ validate(need(
|
- | 415 |
+ 673 |
! |
- verbatim_content = reactive(teal.code::get_code(output_q())),
+ !is.numeric(ANL[[color_by_var]]),
|
- | 416 |
+ 674 |
! |
- title = "Show R Code for Cross-Table"
+ "Marginal plots cannot be produced when the points are colored by numeric variables.
|
-
- | 417 |
- |
+
+ | 675 |
+ ! |
- )
+ \n Uncheck the 'Add marginal density' checkbox to display the plot."
|
- | 418 |
+ 676 |
|
-
+ ))
+ |
+
+
+ | 677 |
+ ! |
+
+ validate(need(
|
- | 419 |
+ 678 |
|
- ### REPORTER
+ !(
|
- | 420 |
+ 679 |
! |
- if (with_reporter) {
+ inherits(ANL[[color_by_var]], "Date") ||
|
- | 421 |
+ 680 |
! |
- card_fun <- function(comment, label) {
+ inherits(ANL[[color_by_var]], "POSIXct") ||
|
- | 422 |
+ 681 |
! |
- card <- teal::report_card_template(
+ inherits(ANL[[color_by_var]], "POSIXlt")
|
-
- | 423 |
- ! |
+
+ | 682 |
+ |
- title = "Cross Table",
+ ),
|
- | 424 |
+ 683 |
! |
- label = label,
+ "Marginal plots cannot be produced when the points are colored by Date or POSIX variables.
|
- | 425 |
+ 684 |
! |
- with_filter = with_filter,
+ \n Uncheck the 'Add marginal density' checkbox to display the plot."
|
-
- | 426 |
- ! |
+
+ | 685 |
+ |
- filter_panel_api = filter_panel_api
+ ))
|
- | 427 |
+ 686 |
|
- )
+ }
|
-
- | 428 |
- ! |
+
+ | 687 |
+ |
- card$append_text("Table", "header3")
+
|
- | 429 |
+ 688 |
! |
- card$append_table(table_r())
+ teal::validate_has_data(ANL[, c(x_var, y_var)], 10, complete = TRUE, allow_inf = FALSE)
|
-
- | 430 |
- ! |
+
+ | 689 |
+ |
- if (!comment == "") {
+
|
- | 431 |
+ 690 |
! |
- card$append_text("Comment", "header3")
+ if (log_x) {
|
- | 432 |
+ 691 |
! |
- card$append_text(comment)
+ validate(
|
-
- | 433 |
- |
+
+ | 692 |
+ ! |
- }
+ need(
|
- | 434 |
+ 693 |
! |
- card$append_src(teal.code::get_code(output_q()))
+ is.numeric(ANL[[x_var]]) && all(
|
- | 435 |
+ 694 |
! |
- card
+ ANL[[x_var]] > 0 | is.na(ANL[[x_var]])
|
- | 436 |
+ 695 |
|
- }
+ ),
|
- | 437 |
+ 696 |
! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ "X variable can only be log transformed if variable is numeric and all values are positive."
|
- | 438 |
+ 697 |
|
- }
+ )
|
- | 439 |
+ 698 |
+ |
+
+ )
+ |
+
+
+ | 699 |
|
- ###
+ }
+ |
+
+
+ | 700 |
+ ! |
+
+ if (log_y) {
+ |
+
+
+ | 701 |
+ ! |
+
+ validate(
|
-
- | 440 |
- |
+
+ | 702 |
+ ! |
- })
+ need(
|
-
- | 441 |
- |
+
+ | 703 |
+ ! |
- }
+ is.numeric(ANL[[y_var]]) && all(
|
-
-
-
-
-
-
-
- | 1 |
- |
+
+ | 704 |
+ ! |
- #' `teal` module: Principal component analysis
+ ANL[[y_var]] > 0 | is.na(ANL[[y_var]])
|
- | 2 |
+ 705 |
|
- #'
+ ),
|
-
- | 3 |
- |
+
+ | 706 |
+ ! |
- #' Module conducts principal component analysis (PCA) on a given dataset and offers different
+ "Y variable can only be log transformed if variable is numeric and all values are positive."
|
- | 4 |
+ 707 |
|
- #' ways of visualizing the outcomes, including elbow plot, circle plot, biplot, and eigenvector plot.
+ )
|
- | 5 |
+ 708 |
|
- #' Additionally, it enables dynamic customization of plot aesthetics, such as opacity, size, and
+ )
|
- | 6 |
+ 709 |
|
- #' font size, through UI inputs.
+ }
|
- | 7 |
+ 710 |
|
- #'
+
|
-
- | 8 |
- |
+
+ | 711 |
+ ! |
- #' @inheritParams teal::module
+ facet_cl <- facet_ggplot_call(
|
-
- | 9 |
- |
+
+ | 712 |
+ ! |
- #' @inheritParams shared_params
+ row_facet_name,
|
-
- | 10 |
- |
+
+ | 713 |
+ ! |
- #' @param dat (`data_extract_spec` or `list` of multiple `data_extract_spec`)
+ col_facet_name,
|
-
- | 11 |
- |
+
+ | 714 |
+ ! |
- #' specifying columns used to compute PCA.
+ free_x_scales = isTRUE(input$free_scales),
|
-
- | 12 |
- |
+
+ | 715 |
+ ! |
- #' @param font_size (`numeric`) optional, specifies font size.
+ free_y_scales = isTRUE(input$free_scales)
|
- | 13 |
+ 716 |
|
- #' It controls the font size for plot titles, axis labels, and legends.
+ )
|
- | 14 |
+ 717 |
|
- #' - If vector of `length == 1` then the font sizes will have a fixed size.
+
|
-
- | 15 |
- |
+
+ | 718 |
+ ! |
- #' - while vector of `value`, `min`, and `max` allows dynamic adjustment.
+ point_sizes <- if (length(size_by_var) > 0) {
|
-
- | 16 |
- |
+
+ | 719 |
+ ! |
- #' @templateVar ggnames "Elbow plot", "Circle plot", "Biplot", "Eigenvector plot"
+ validate(need(is.numeric(ANL[[size_by_var]]), "Variable to size by must be numeric"))
|
-
- | 17 |
- |
+
+ | 720 |
+ ! |
- #' @template ggplot2_args_multi
+ substitute(
|
-
- | 18 |
- |
+
+ | 721 |
+ ! |
- #'
+ expr = size * ANL[[size_by_var]] / max(ANL[[size_by_var]], na.rm = TRUE),
|
-
- | 19 |
- |
+
+ | 722 |
+ ! |
- #' @inherit shared_params return
+ env = list(size = size, size_by_var = size_by_var)
|
- | 20 |
+ 723 |
|
- #'
+ )
|
- | 21 |
+ 724 |
|
- #' @examples
+ } else {
|
-
- | 22 |
- |
+
+ | 725 |
+ ! |
- #' library(teal.widgets)
+ size
|
- | 23 |
+ 726 |
|
- #'
+ }
|
- | 24 |
+ 727 |
|
- #' # general data example
+
|
-
- | 25 |
- |
+
+ | 728 |
+ ! |
- #' data <- teal_data()
+ plot_q <- merged$anl_q_r()
|
- | 26 |
+ 729 |
|
- #' data <- within(data, {
+
|
-
- | 27 |
- |
+
+ | 730 |
+ ! |
- #' require(nestcolor)
+ if (log_x) {
|
-
- | 28 |
- |
+
+ | 731 |
+ ! |
- #' USArrests <- USArrests
+ log_x_fn <- input$log_x_base
|
-
- | 29 |
- |
+
+ | 732 |
+ ! |
- #' })
+ plot_q <- teal.code::eval_code(
|
-
- | 30 |
- |
+
+ | 733 |
+ ! |
- #'
+ object = plot_q,
|
-
- | 31 |
- |
+
+ | 734 |
+ ! |
- #' datanames(data) <- "USArrests"
+ code = substitute(
|
-
- | 32 |
- |
+
+ | 735 |
+ ! |
- #'
+ expr = ANL[, log_x_var] <- log_x_fn(ANL[, x_var]),
|
-
- | 33 |
- |
+
+ | 736 |
+ ! |
- #' app <- init(
+ env = list(
|
-
- | 34 |
- |
+
+ | 737 |
+ ! |
- #' data = data,
+ x_var = x_var,
|
-
- | 35 |
- |
+
+ | 738 |
+ ! |
- #' modules = modules(
+ log_x_fn = as.name(log_x_fn),
|
-
- | 36 |
- |
+
+ | 739 |
+ ! |
- #' tm_a_pca(
+ log_x_var = paste0(log_x_fn, "_", x_var)
|
- | 37 |
+ 740 |
|
- #' "PCA",
+ )
|
- | 38 |
+ 741 |
|
- #' dat = data_extract_spec(
+ )
|
- | 39 |
+ 742 |
|
- #' dataname = "USArrests",
+ )
|
- | 40 |
+ 743 |
|
- #' select = select_spec(
+ }
|
- | 41 |
+ 744 |
|
- #' choices = variable_choices(
+
|
-
- | 42 |
- |
+
+ | 745 |
+ ! |
- #' data = data[["USArrests"]], c("Murder", "Assault", "UrbanPop", "Rape")
+ if (log_y) {
|
-
- | 43 |
- |
+
+ | 746 |
+ ! |
- #' ),
+ log_y_fn <- input$log_y_base
|
-
- | 44 |
- |
+
+ | 747 |
+ ! |
- #' selected = c("Murder", "Assault"),
+ plot_q <- teal.code::eval_code(
|
-
- | 45 |
- |
+
+ | 748 |
+ ! |
- #' multiple = TRUE
+ object = plot_q,
|
-
- | 46 |
- |
+
+ | 749 |
+ ! |
- #' ),
+ code = substitute(
|
-
- | 47 |
- |
+
+ | 750 |
+ ! |
- #' filter = NULL
+ expr = ANL[, log_y_var] <- log_y_fn(ANL[, y_var]),
|
-
- | 48 |
- |
+
+ | 751 |
+ ! |
- #' ),
+ env = list(
|
-
- | 49 |
- |
+
+ | 752 |
+ ! |
- #' ggplot2_args = ggplot2_args(
+ y_var = y_var,
|
-
- | 50 |
- |
+
+ | 753 |
+ ! |
- #' labs = list(subtitle = "Plot generated by PCA Module")
+ log_y_fn = as.name(log_y_fn),
|
-
- | 51 |
- |
+
+ | 754 |
+ ! |
- #' )
+ log_y_var = paste0(log_y_fn, "_", y_var)
|
- | 52 |
+ 755 |
|
- #' )
+ )
|
- | 53 |
+ 756 |
|
- #' )
+ )
|
- | 54 |
+ 757 |
|
- #' )
+ )
|
- | 55 |
+ 758 |
|
- #' if (interactive()) {
+ }
|
- | 56 |
+ 759 |
|
- #' shinyApp(app$ui, app$server)
+
|
-
- | 57 |
- |
+
+ | 760 |
+ ! |
- #' }
+ pre_pro_anl <- if (input$show_count) {
|
-
- | 58 |
- |
+
+ | 761 |
+ ! |
- #'
+ paste0(
|
-
- | 59 |
- |
+
+ | 762 |
+ ! |
- #' # CDISC data example
+ "ANL %>% dplyr::group_by(",
|
-
- | 60 |
- |
+
+ | 763 |
+ ! |
- #' data <- teal_data()
+ paste(
|
-
- | 61 |
- |
+
+ | 764 |
+ ! |
- #' data <- within(data, {
+ c(
|
-
- | 62 |
- |
+
+ | 765 |
+ ! |
- #' require(nestcolor)
+ if (length(color_by_var) > 0 && inherits(ANL[[color_by_var]], c("factor", "character"))) color_by_var,
|
-
- | 63 |
- |
+
+ | 766 |
+ ! |
- #' ADSL <- rADSL
+ row_facet_name,
|
-
- | 64 |
- |
+
+ | 767 |
+ ! |
- #' })
+ col_facet_name
|
- | 65 |
+ 768 |
|
- #' datanames(data) <- "ADSL"
+ ),
|
-
- | 66 |
- |
+
+ | 769 |
+ ! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
+ collapse = ", "
|
- | 67 |
+ 770 |
|
- #'
+ ),
|
-
- | 68 |
- |
+
+ | 771 |
+ ! |
- #' app <- init(
+ ") %>% dplyr::mutate(n = dplyr::n()) %>% dplyr::ungroup()"
|
- | 69 |
+ 772 |
|
- #' data = data,
+ )
|
- | 70 |
+ 773 |
|
- #' modules = modules(
+ } else {
|
-
- | 71 |
- |
+
+ | 774 |
+ ! |
- #' tm_a_pca(
+ "ANL"
|
- | 72 |
+ 775 |
|
- #' "PCA",
+ }
|
- | 73 |
+ 776 |
|
- #' dat = data_extract_spec(
+
|
-
- | 74 |
- |
+
+ | 777 |
+ ! |
- #' dataname = "ADSL",
+ plot_call <- substitute(expr = pre_pro_anl %>% ggplot(), env = list(pre_pro_anl = str2lang(pre_pro_anl)))
|
- | 75 |
+ 778 |
|
- #' select = select_spec(
+
|
-
- | 76 |
- |
+
+ | 779 |
+ ! |
- #' choices = variable_choices(
+ plot_call <- if (length(color_by_var) == 0) {
|
-
- | 77 |
- |
+
+ | 780 |
+ ! |
- #' data = data[["ADSL"]], c("BMRKR1", "AGE", "EOSDY")
+ substitute(
|
-
- | 78 |
- |
+
+ | 781 |
+ ! |
- #' ),
+ expr = plot_call +
|
-
- | 79 |
- |
+
+ | 782 |
+ ! |
- #' selected = c("BMRKR1", "AGE"),
+ ggplot2::aes(x = x_name, y = y_name) +
|
-
- | 80 |
- |
+
+ | 783 |
+ ! |
- #' multiple = TRUE
+ ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value, color = color_value),
|
-
- | 81 |
- |
+
+ | 784 |
+ ! |
- #' ),
+ env = list(
|
-
- | 82 |
- |
+
+ | 785 |
+ ! |
- #' filter = NULL
+ plot_call = plot_call,
|
-
- | 83 |
- |
+
+ | 786 |
+ ! |
- #' ),
+ x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var),
|
-
- | 84 |
- |
+
+ | 787 |
+ ! |
- #' ggplot2_args = ggplot2_args(
+ y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var),
|
-
- | 85 |
- |
+
+ | 788 |
+ ! |
- #' labs = list(subtitle = "Plot generated by PCA Module")
+ alpha_value = alpha,
|
-
- | 86 |
- |
+
+ | 789 |
+ ! |
- #' )
+ point_sizes = point_sizes,
|
-
- | 87 |
- |
+
+ | 790 |
+ ! |
- #' )
+ shape_value = shape,
|
-
- | 88 |
- |
+
+ | 791 |
+ ! |
- #' )
+ color_value = color
|
- | 89 |
+ 792 |
|
- #' )
+ )
|
- | 90 |
+ 793 |
|
- #' if (interactive()) {
+ )
|
- | 91 |
+ 794 |
|
- #' shinyApp(app$ui, app$server)
+ } else {
|
-
- | 92 |
- |
+
+ | 795 |
+ ! |
- #' }
+ substitute(
|
-
- | 93 |
- |
+
+ | 796 |
+ ! |
- #'
+ expr = plot_call +
|
-
- | 94 |
- |
+
+ | 797 |
+ ! |
- #' @export
+ ggplot2::aes(x = x_name, y = y_name, color = color_by_var_name) +
|
-
- | 95 |
- |
+
+ | 798 |
+ ! |
- #'
+ ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value),
|
-
- | 96 |
- |
+
+ | 799 |
+ ! |
- tm_a_pca <- function(label = "Principal Component Analysis",
+ env = list(
|
-
- | 97 |
- |
+
+ | 800 |
+ ! |
- dat,
+ plot_call = plot_call,
|
-
- | 98 |
- |
+
+ | 801 |
+ ! |
- plot_height = c(600, 200, 2000),
+ x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var),
|
-
- | 99 |
- |
+
+ | 802 |
+ ! |
- plot_width = NULL,
+ y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var),
|
-
- | 100 |
- |
+
+ | 803 |
+ ! |
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ color_by_var_name = as.name(color_by_var),
|
-
- | 101 |
- |
+
+ | 804 |
+ ! |
- ggplot2_args = teal.widgets::ggplot2_args(),
+ alpha_value = alpha,
|
-
- | 102 |
- |
+
+ | 805 |
+ ! |
- rotate_xaxis_labels = FALSE,
+ point_sizes = point_sizes,
|
-
- | 103 |
- |
+
+ | 806 |
+ ! |
- font_size = c(12, 8, 20),
+ shape_value = shape
|
- | 104 |
+ 807 |
|
- alpha = c(1, 0, 1),
+ )
|
- | 105 |
+ 808 |
|
- size = c(2, 1, 8),
+ )
|
- | 106 |
+ 809 |
|
- pre_output = NULL,
+ }
|
- | 107 |
+ 810 |
|
- post_output = NULL) {
+
|
- | 108 |
+ 811 |
! |
- message("Initializing tm_a_pca")
+ if (rug_plot) plot_call <- substitute(expr = plot_call + geom_rug(), env = list(plot_call = plot_call))
|
- | 109 |
+ 812 |
|
|
-
- | 110 |
- |
+
+ | 813 |
+ ! |
- # Normalize the parameters
+ plot_label_generator <- function(rhs_formula = quote(y ~ 1),
|
- | 111 |
+ 814 |
! |
- if (inherits(dat, "data_extract_spec")) dat <- list(dat)
+ show_form = input$show_form,
|
- | 112 |
+ 815 |
! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)
+ show_r2 = input$show_r2,
|
-
- | 113 |
- |
+
+ | 816 |
+ ! |
-
+ show_count = input$show_count,
|
-
- | 114 |
- |
+
+ | 817 |
+ ! |
- # Start of assertions
+ pos = input$pos,
|
- | 115 |
+ 818 |
! |
- checkmate::assert_string(label)
+ label_size = input$label_size) {
|
- | 116 |
+ 819 |
! |
- checkmate::assert_list(dat, types = "data_extract_spec")
+ stopifnot(sum(show_form, show_r2, show_count) >= 1)
|
-
- | 117 |
- |
+
+ | 820 |
+ ! |
-
+ aes_label <- paste0(
|
- | 118 |
+ 821 |
! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
+ "aes(",
|
- | 119 |
+ 822 |
! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
+ if (show_count) "n = n, ",
|
- | 120 |
+ 823 |
! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
+ "label = ",
|
- | 121 |
+ 824 |
! |
- checkmate::assert_numeric(
+ if (sum(show_form, show_r2, show_count) > 1) "paste(",
|
- | 122 |
+ 825 |
! |
- plot_width[1],
+ paste(
|
- | 123 |
+ 826 |
! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
+ c(
|
-
- | 124 |
- |
+
+ | 827 |
+ ! |
- )
+ if (show_form) "stat(eq.label)",
|
-
- | 125 |
- |
+
+ | 828 |
+ ! |
-
+ if (show_r2) "stat(adj.rr.label)",
|
- | 126 |
+ 829 |
! |
- ggtheme <- match.arg(ggtheme)
+ if (show_count) "paste('N ~`=`~', n)"
|
- | 127 |
+ 830 |
|
-
+ ),
|
- | 128 |
+ 831 |
! |
- plot_choices <- c("Elbow plot", "Circle plot", "Biplot", "Eigenvector plot")
+ collapse = ", "
|
-
- | 129 |
- ! |
+
+ | 832 |
+ |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")
+ ),
|
- | 130 |
+ 833 |
! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ if (sum(show_form, show_r2, show_count) > 1) ", sep = '*\", \"*'))" else ")"
|
- | 131 |
+ 834 |
|
-
+ )
|
- | 132 |
+ 835 |
! |
- checkmate::assert_flag(rotate_xaxis_labels)
- |
-
-
- | 133 |
- |
-
-
+ label_geom <- substitute(
|
- | 134 |
+ 836 |
! |
- if (length(font_size) == 1) {
+ expr = ggpmisc::stat_poly_eq(
|
- | 135 |
+ 837 |
! |
- checkmate::assert_numeric(font_size, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20)
+ mapping = aes_label,
|
-
- | 136 |
- |
+
+ | 838 |
+ ! |
- } else {
+ formula = rhs_formula,
|
- | 137 |
+ 839 |
! |
- checkmate::assert_numeric(font_size, len = 3, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20)
+ parse = TRUE,
|
- | 138 |
+ 840 |
! |
- checkmate::assert_numeric(font_size[1], lower = font_size[2], upper = font_size[3], .var.name = "font_size")
+ label.x = pos,
|
-
- | 139 |
- |
+
+ | 841 |
+ ! |
- }
+ size = label_size
|
- | 140 |
+ 842 |
|
-
+ ),
|
- | 141 |
+ 843 |
! |
- if (length(alpha) == 1) {
+ env = list(
|
- | 142 |
+ 844 |
! |
- checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1)
+ rhs_formula = rhs_formula,
|
-
- | 143 |
- |
+
+ | 845 |
+ ! |
- } else {
+ pos = pos,
|
- | 144 |
+ 846 |
! |
- checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1)
+ aes_label = str2lang(aes_label),
|
- | 145 |
+ 847 |
! |
- checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")
+ label_size = label_size
|
- | 146 |
+ 848 |
|
- }
+ )
|
- | 147 |
+ 849 |
|
-
+ )
|
- | 148 |
+ 850 |
! |
- if (length(size) == 1) {
+ substitute(
|
- | 149 |
+ 851 |
! |
- checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8)
+ expr = plot_call + label_geom,
|
-
- | 150 |
- |
+
+ | 852 |
+ ! |
- } else {
+ env = list(
|
- | 151 |
+ 853 |
! |
- checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8)
+ plot_call = plot_call,
|
- | 152 |
+ 854 |
! |
- checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")
+ label_geom = label_geom
|
- | 153 |
+ 855 |
|
- }
+ )
|
- | 154 |
+ 856 |
|
-
- |
-
-
- | 155 |
- ! |
-
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
- |
-
-
- | 156 |
- ! |
-
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ )
|
- | 157 |
+ 857 |
|
- # End of assertions
+ }
|
- | 158 |
+ 858 |
|
|
-
- | 159 |
- |
+
+ | 859 |
+ ! |
- # Make UI args
+ if (trend_line_is_applicable()) {
|
- | 160 |
+ 860 |
! |
- args <- as.list(environment())
+ shinyjs::hide("line_msg")
|
-
- | 161 |
- |
+
+ | 861 |
+ ! |
-
+ shinyjs::show("smoothing_degree")
|
- | 162 |
+ 862 |
! |
- data_extract_list <- list(dat = dat)
+ if (!add_trend_line()) {
|
-
- | 163 |
- |
+
+ | 863 |
+ ! |
+
+ shinyjs::hide("ci")
+ |
+
+
+ | 864 |
+ ! |
-
+ shinyjs::hide("color_sub")
|
- | 164 |
+ 865 |
! |
- ans <- module(
+ shinyjs::hide("show_form")
|
- | 165 |
+ 866 |
! |
- label = label,
+ shinyjs::hide("show_r2")
|
- | 166 |
+ 867 |
! |
- server = srv_a_pca,
+ if (input$show_count) {
|
- | 167 |
+ 868 |
! |
- ui = ui_a_pca,
+ plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE)
|
- | 168 |
+ 869 |
! |
- ui_args = args,
+ shinyjs::show("label_pos")
|
- | 169 |
+ 870 |
! |
- server_args = c(
+ shinyjs::show("label_size")
|
-
- | 170 |
- ! |
+
+ | 871 |
+ |
- data_extract_list,
+ } else {
|
- | 171 |
+ 872 |
! |
- list(
+ shinyjs::hide("label_pos")
|
- | 172 |
+ 873 |
! |
- plot_height = plot_height,
+ shinyjs::hide("label_size")
+ |
+
+
+ | 874 |
+ |
+
+ }
+ |
+
+
+ | 875 |
+ |
+
+ } else {
|
- | 173 |
+ 876 |
! |
- plot_width = plot_width,
+ shinyjs::show("ci")
|
- | 174 |
+ 877 |
! |
- ggplot2_args = ggplot2_args
+ shinyjs::show("show_form")
|
-
- | 175 |
- |
+
+ | 878 |
+ ! |
- )
+ shinyjs::show("show_r2")
|
-
- | 176 |
- |
+
+ | 879 |
+ ! |
- ),
+ if (nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)])) > 0) {
|
- | 177 |
+ 880 |
! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)
+ plot_q <- teal.code::eval_code(
|
-
- | 178 |
- |
+
+ | 881 |
+ ! |
- )
+ plot_q,
|
- | 179 |
+ 882 |
! |
- attr(ans, "teal_bookmarkable") <- FALSE
+ substitute(
|
- | 180 |
+ 883 |
! |
- ans
+ expr = ANL <- dplyr::filter(ANL, !is.na(x_var) & !is.na(y_var)),
|
-
- | 181 |
- |
+
+ | 884 |
+ ! |
- }
+ env = list(x_var = as.name(x_var), y_var = as.name(y_var))
|
- | 182 |
+ 885 |
|
-
+ )
|
- | 183 |
+ 886 |
|
- # UI function for the PCA module
+ )
|
- | 184 |
+ 887 |
|
- ui_a_pca <- function(id, ...) {
+ }
|
- | 185 |
+ 888 |
! |
- ns <- NS(id)
+ rhs_formula <- substitute(
|
- | 186 |
+ 889 |
! |
- args <- list(...)
+ expr = y ~ poly(x, smoothing_degree, raw = TRUE),
|
- | 187 |
+ 890 |
! |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$dat)
+ env = list(smoothing_degree = smoothing_degree)
|
- | 188 |
+ 891 |
|
-
- |
-
-
- | 189 |
- ! |
-
- color_selector <- args$dat
+ )
|
- | 190 |
+ 892 |
! |
- for (i in seq_along(color_selector)) {
+ if (input$show_form || input$show_r2 || input$show_count) {
|
- | 191 |
+ 893 |
! |
- color_selector[[i]]$select$multiple <- FALSE
+ plot_call <- plot_label_generator(rhs_formula = rhs_formula)
|
- | 192 |
+ 894 |
! |
- color_selector[[i]]$select$always_selected <- NULL
+ shinyjs::show("label_pos")
|
- | 193 |
+ 895 |
! |
- color_selector[[i]]$select$selected <- NULL
+ shinyjs::show("label_size")
|
- | 194 |
+ 896 |
|
- }
+ } else {
|
-
- | 195 |
- |
+
+ | 897 |
+ ! |
-
+ shinyjs::hide("label_pos")
|
- | 196 |
+ 898 |
! |
- tagList(
+ shinyjs::hide("label_size")
|
-
- | 197 |
- ! |
+
+ | 899 |
+ |
- include_css_files("custom"),
+ }
|
- | 198 |
+ 900 |
! |
- teal.widgets::standard_layout(
+ plot_call <- substitute(
|
- | 199 |
+ 901 |
! |
- output = teal.widgets::white_small_well(
+ expr = plot_call + ggplot2::geom_smooth(formula = rhs_formula, se = TRUE, level = ci, method = "lm"),
|
- | 200 |
+ 902 |
! |
- uiOutput(ns("all_plots"))
+ env = list(plot_call = plot_call, rhs_formula = rhs_formula, ci = ci)
|
- | 201 |
+ 903 |
|
- ),
+ )
|
-
- | 202 |
- ! |
+
+ | 904 |
+ |
- encoding = tags$div(
+ }
|
- | 203 |
+ 905 |
|
- ### Reporter
+ } else {
|
- | 204 |
+ 906 |
! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ shinyjs::hide("smoothing_degree")
|
-
- | 205 |
- |
+
+ | 907 |
+ ! |
- ###
+ shinyjs::hide("ci")
|
- | 206 |
+ 908 |
! |
- tags$label("Encodings", class = "text-primary"),
+ shinyjs::hide("color_sub")
|
- | 207 |
+ 909 |
! |
- teal.transform::datanames_input(args["dat"]),
+ shinyjs::hide("show_form")
|
- | 208 |
+ 910 |
! |
- teal.transform::data_extract_ui(
+ shinyjs::hide("show_r2")
|
- | 209 |
+ 911 |
! |
- id = ns("dat"),
+ if (input$show_count) {
|
- | 210 |
+ 912 |
! |
- label = "Data selection",
+ plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE)
|
- | 211 |
+ 913 |
! |
- data_extract_spec = args$dat,
+ shinyjs::show("label_pos")
|
- | 212 |
+ 914 |
! |
- is_single_dataset = is_single_dataset_value
+ shinyjs::show("label_size")
|
- | 213 |
+ 915 |
|
- ),
+ } else {
|
- | 214 |
+ 916 |
! |
- teal.widgets::panel_group(
+ shinyjs::hide("label_pos")
|
- | 215 |
+ 917 |
! |
- teal.widgets::panel_item(
+ shinyjs::hide("label_size")
|
-
- | 216 |
- ! |
+
+ | 918 |
+ |
- title = "Display",
+ }
|
- | 217 |
+ 919 |
! |
- collapsed = FALSE,
+ shinyjs::show("line_msg")
|
-
- | 218 |
- ! |
+
+ | 920 |
+ |
- checkboxGroupInput(
+ }
|
-
- | 219 |
- ! |
+
+ | 921 |
+ |
- ns("tables_display"),
+
|
- | 220 |
+ 922 |
! |
- "Tables display",
+ if (!is.null(facet_cl)) {
|
- | 221 |
+ 923 |
! |
- choices = c("PC importance" = "importance", "Eigenvectors" = "eigenvector"),
+ plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))
|
-
- | 222 |
- ! |
+
+ | 924 |
+ |
- selected = c("importance", "eigenvector")
+ }
|
- | 223 |
+ 925 |
|
- ),
+
|
- | 224 |
+ 926 |
! |
- radioButtons(
+ y_label <- varname_w_label(
|
- | 225 |
+ 927 |
! |
- ns("plot_type"),
+ y_var,
|
- | 226 |
+ 928 |
! |
- label = "Plot type",
+ ANL,
|
- | 227 |
+ 929 |
! |
- choices = args$plot_choices,
+ prefix = if (log_y) paste(log_y_fn, "(") else NULL,
|
- | 228 |
+ 930 |
! |
- selected = args$plot_choices[1]
- |
-
-
- | 229 |
- |
-
- )
+ suffix = if (log_y) ")" else NULL
|
- | 230 |
+ 931 |
|
- ),
- |
-
-
- | 231 |
- ! |
-
- teal.widgets::panel_item(
+ )
|
- | 232 |
+ 932 |
! |
- title = "Pre-processing",
+ x_label <- varname_w_label(
|
- | 233 |
+ 933 |
! |
- radioButtons(
+ x_var,
|
- | 234 |
+ 934 |
! |
- ns("standardization"), "Standardization",
+ ANL,
|
- | 235 |
+ 935 |
! |
- choices = c("None" = "none", "Center" = "center", "Center & Scale" = "center_scale"),
+ prefix = if (log_x) paste(log_x_fn, "(") else NULL,
|
- | 236 |
+ 936 |
! |
- selected = "center_scale"
+ suffix = if (log_x) ")" else NULL
|
- | 237 |
+ 937 |
|
- ),
+ )
|
-
- | 238 |
- ! |
+
+ | 938 |
+ |
- radioButtons(
+
|
- | 239 |
+ 939 |
! |
- ns("na_action"), "NA action",
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(
|
- | 240 |
+ 940 |
! |
- choices = c("None" = "none", "Drop" = "drop"),
+ labs = list(y = y_label, x = x_label),
|
- | 241 |
+ 941 |
! |
- selected = "none"
+ theme = list(legend.position = "bottom")
|
- | 242 |
+ 942 |
|
- )
+ )
|
- | 243 |
+ 943 |
|
- ),
+
|
- | 244 |
+ 944 |
! |
- teal.widgets::panel_item(
+ if (rotate_xaxis_labels) {
|
- | 245 |
+ 945 |
! |
- title = "Selected plot specific settings",
+ dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1))
|
-
- | 246 |
- ! |
+
+ | 946 |
+ |
- collapsed = FALSE,
+ }
|
-
- | 247 |
- ! |
+
+ | 947 |
+ |
- uiOutput(ns("plot_settings")),
+
|
- | 248 |
+ 948 |
! |
- conditionalPanel(
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
|
- | 249 |
+ 949 |
! |
- condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")),
+ user_plot = ggplot2_args,
|
- | 250 |
+ 950 |
! |
- list(
+ module_plot = dev_ggplot2_args
|
-
- | 251 |
- ! |
+
+ | 951 |
+ |
- teal.transform::data_extract_ui(
+ )
|
-
- | 252 |
- ! |
+
+ | 952 |
+ |
- id = ns("response"),
+
|
- | 253 |
+ 953 |
! |
- label = "Color by",
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = ggtheme)
|
-
- | 254 |
- ! |
+
+ | 954 |
+ |
- data_extract_spec = color_selector,
+
+ |
+
+
+ | 955 |
+ |
+
+
|
- | 255 |
+ 956 |
! |
- is_single_dataset = is_single_dataset_value
+ if (add_density) {
|
-
- | 256 |
- |
+
+ | 957 |
+ ! |
- ),
+ plot_call <- substitute(
|
- | 257 |
+ 958 |
! |
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
+ expr = ggExtra::ggMarginal(
|
- | 258 |
+ 959 |
! |
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE)
+ plot_call + labs + ggthemes + themes,
|
-
- | 259 |
- |
+
+ | 960 |
+ ! |
- )
+ type = "density",
|
-
- | 260 |
- |
+
+ | 961 |
+ ! |
- )
+ groupColour = group_colour
|
- | 261 |
+ 962 |
|
),
|
- | 262 |
+ 963 |
! |
- teal.widgets::panel_item(
+ env = list(
|
- | 263 |
+ 964 |
! |
- title = "Plot settings",
+ plot_call = plot_call,
|
- | 264 |
+ 965 |
! |
- collapsed = TRUE,
+ group_colour = if (length(color_by_var) > 0) TRUE else FALSE,
|
- | 265 |
+ 966 |
! |
- conditionalPanel(
+ labs = parsed_ggplot2_args$labs,
|
- | 266 |
+ 967 |
! |
- condition = sprintf(
+ ggthemes = parsed_ggplot2_args$ggtheme,
|
- | 267 |
+ 968 |
! |
- "input['%s'] == 'Elbow plot' || input['%s'] == 'Eigenvector plot'",
+ themes = parsed_ggplot2_args$theme
|
-
- | 268 |
- ! |
+
+ | 969 |
+ |
- ns("plot_type"),
+ )
|
-
- | 269 |
- ! |
+
+ | 970 |
+ |
- ns("plot_type")
+ )
|
- | 270 |
+ 971 |
|
- ),
+ } else {
|
- | 271 |
+ 972 |
! |
- list(checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels))
+ plot_call <- substitute(
|
-
- | 272 |
- |
+
+ | 973 |
+ ! |
- ),
+ expr = plot_call +
|
- | 273 |
+ 974 |
! |
- selectInput(
+ labs +
|
- | 274 |
+ 975 |
! |
- inputId = ns("ggtheme"),
+ ggthemes +
|
- | 275 |
+ 976 |
! |
- label = "Theme (by ggplot):",
+ themes,
|
- | 276 |
+ 977 |
! |
- choices = ggplot_themes,
+ env = list(
|
- | 277 |
+ 978 |
! |
- selected = args$ggtheme,
+ plot_call = plot_call,
|
- | 278 |
+ 979 |
! |
- multiple = FALSE
+ labs = parsed_ggplot2_args$labs,
|
-
- | 279 |
- |
+
+ | 980 |
+ ! |
- ),
+ ggthemes = parsed_ggplot2_args$ggtheme,
|
- | 280 |
+ 981 |
! |
- teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", args$font_size, ticks = FALSE)
+ themes = parsed_ggplot2_args$theme
|
- | 281 |
+ 982 |
|
)
|
- | 282 |
+ 983 |
|
)
|
- | 283 |
+ 984 |
|
- ),
+ }
|
-
- | 284 |
- ! |
+
+ | 985 |
+ |
- forms = tagList(
+
|
- | 285 |
+ 986 |
! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ plot_call <- substitute(expr = p <- plot_call, env = list(plot_call = plot_call))
|
- | 286 |
+ 987 |
|
- ),
+
|
- | 287 |
+ 988 |
! |
- pre_output = args$pre_output,
+ teal.code::eval_code(plot_q, plot_call) %>%
|
- | 288 |
+ 989 |
! |
- post_output = args$post_output
+ teal.code::eval_code(quote(print(p)))
|
- | 289 |
+ 990 |
|
- )
+ })
|
- | 290 |
+ 991 |
|
- )
+
|
-
- | 291 |
- |
+
+ | 992 |
+ ! |
- }
+ plot_r <- reactive(output_q()[["p"]])
|
- | 292 |
+ 993 |
|
|
- | 293 |
- |
-
- # Server function for the PCA module
- |
-
-
- | 294 |
+ 994 |
|
- srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, plot_width, ggplot2_args) {
+ # Insert the plot into a plot_with_settings module from teal.widgets
|
- | 295 |
+ 995 |
! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
+ pws <- teal.widgets::plot_with_settings_srv(
|
- | 296 |
+ 996 |
! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
+ id = "scatter_plot",
|
- | 297 |
+ 997 |
! |
- checkmate::assert_class(data, "reactive")
+ plot_r = plot_r,
|
- | 298 |
+ 998 |
! |
- checkmate::assert_class(isolate(data()), "teal_data")
+ height = plot_height,
|
- | 299 |
+ 999 |
! |
- moduleServer(id, function(input, output, session) {
+ width = plot_width,
|
- | 300 |
+ 1000 |
! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
+ brushing = TRUE
|
- | 301 |
+ 1001 |
|
-
- |
-
-
- | 302 |
- ! |
-
- response <- dat
+ )
|
- | 303 |
+ 1002 |
|
|
- | 304 |
+ 1003 |
! |
- for (i in seq_along(response)) {
+ output$data_table <- DT::renderDataTable({
|
- | 305 |
+ 1004 |
! |
- response[[i]]$select$multiple <- FALSE
+ plot_brush <- pws$brush()
|
-
- | 306 |
- ! |
+
+ | 1005 |
+ |
- response[[i]]$select$always_selected <- NULL
+
|
- | 307 |
+ 1006 |
! |
- response[[i]]$select$selected <- NULL
+ if (!is.null(plot_brush)) {
|
- | 308 |
+ 1007 |
! |
- all_cols <- teal.data::col_labels(isolate(data())[[response[[i]]$dataname]])
+ validate(need(!input$add_density, "Brushing feature is currently not supported when plot has marginal density"))
|
-
- | 309 |
- ! |
+
+ | 1008 |
+ |
- ignore_cols <- unlist(teal.data::join_keys(isolate(data()))[[response[[i]]$dataname]])
+ }
|
-
- | 310 |
- ! |
+
+ | 1009 |
+ |
- color_cols <- all_cols[!names(all_cols) %in% ignore_cols]
+
|
- | 311 |
+ 1010 |
! |
- response[[i]]$select$choices <- teal.transform::choices_labeled(names(color_cols), color_cols)
- |
-
-
- | 312 |
- |
-
- }
+ merged_data <- isolate(teal.code::dev_suppress(output_q()[["ANL"]]))
|
- | 313 |
+ 1011 |
|
|
- | 314 |
+ 1012 |
! |
- selector_list <- teal.transform::data_extract_multiple_srv(
+ brushed_df <- teal.widgets::clean_brushedPoints(merged_data, plot_brush)
|
- | 315 |
+ 1013 |
! |
- data_extract = list(dat = dat, response = response),
+ numeric_cols <- names(brushed_df)[
|
- | 316 |
+ 1014 |
! |
- datasets = data,
+ vapply(brushed_df, function(x) is.numeric(x) && !is.integer(x), FUN.VALUE = logical(1))
|
-
- | 317 |
- ! |
+
+ | 1015 |
+ |
- select_validation_rule = list(
+ ]
+ |
+
+
+ | 1016 |
+ |
+
+
|
- | 318 |
+ 1017 |
! |
- dat = ~ if (length(.) < 2L) "Please select more than 1 variable to perform PCA.",
+ if (length(numeric_cols) > 0) {
|
- | 319 |
+ 1018 |
! |
- response = shinyvalidate::compose_rules(
+ DT::formatRound(
|
- | 320 |
+ 1019 |
! |
- shinyvalidate::sv_optional(),
+ DT::datatable(brushed_df,
|
- | 321 |
+ 1020 |
! |
- ~ if (isTRUE(is.element(., selector_list()$dat()$select))) {
+ rownames = FALSE,
|
- | 322 |
+ 1021 |
! |
- "Response must not have been used for PCA."
+ options = list(scrollX = TRUE, pageLength = input$data_table_rows)
|
- | 323 |
+ 1022 |
|
- }
+ ),
|
-
- | 324 |
- |
+
+ | 1023 |
+ ! |
- )
+ numeric_cols,
|
-
- | 325 |
- |
+
+ | 1024 |
+ ! |
- )
+ table_dec
|
- | 326 |
+ 1025 |
|
- )
+ )
|
- | 327 |
+ 1026 |
|
-
- |
-
-
- | 328 |
- ! |
-
- iv_r <- reactive({
+ } else {
|
- | 329 |
+ 1027 |
! |
- iv <- shinyvalidate::InputValidator$new()
+ DT::datatable(brushed_df, rownames = FALSE, options = list(scrollX = TRUE, pageLength = input$data_table_rows))
|
-
- | 330 |
- ! |
+
+ | 1028 |
+ |
- teal.transform::compose_and_enable_validators(iv, selector_list)
+ }
|
- | 331 |
+ 1029 |
|
})
|
- | 332 |
+ 1030 |
|
|
- | 333 |
+ 1031 |
! |
- iv_extra <- shinyvalidate::InputValidator$new()
+ teal.widgets::verbatim_popup_srv(
|
- | 334 |
+ 1032 |
! |
- iv_extra$add_rule("x_axis", function(value) {
+ id = "rcode",
|
- | 335 |
+ 1033 |
! |
- if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
+ verbatim_content = reactive(teal.code::get_code(output_q())),
|
- | 336 |
+ 1034 |
! |
- if (!shinyvalidate::input_provided(value)) {
+ title = "R Code for scatterplot"
|
-
- | 337 |
- ! |
+
+ | 1035 |
+ |
- "Need X axis"
+ )
|
- | 338 |
+ 1036 |
|
- }
+
|
- | 339 |
+ 1037 |
|
- }
+ ### REPORTER
|
-
- | 340 |
- |
+
+ | 1038 |
+ ! |
- })
+ if (with_reporter) {
|
- | 341 |
+ 1039 |
! |
- iv_extra$add_rule("y_axis", function(value) {
+ card_fun <- function(comment, label) {
|
- | 342 |
+ 1040 |
! |
- if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
+ card <- teal::report_card_template(
|
- | 343 |
+ 1041 |
! |
- if (!shinyvalidate::input_provided(value)) {
+ title = "Scatter Plot",
|
- | 344 |
+ 1042 |
! |
- "Need Y axis"
+ label = label,
|
-
- | 345 |
- |
+
+ | 1043 |
+ ! |
- }
+ with_filter = with_filter,
|
-
- | 346 |
- |
+
+ | 1044 |
+ ! |
- }
+ filter_panel_api = filter_panel_api
|
- | 347 |
+ 1045 |
|
- })
+ )
|
- | 348 |
+ 1046 |
! |
- rule_dupl <- function(...) {
+ card$append_text("Plot", "header3")
|
- | 349 |
+ 1047 |
! |
- if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
+ card$append_plot(plot_r(), dim = pws$dim())
|
- | 350 |
+ 1048 |
! |
- if (isTRUE(input$x_axis == input$y_axis)) {
+ if (!comment == "") {
|
- | 351 |
+ 1049 |
! |
- "Please choose different X and Y axes."
- |
-
-
- | 352 |
- |
-
- }
+ card$append_text("Comment", "header3")
|
-
- | 353 |
- |
+
+ | 1050 |
+ ! |
- }
+ card$append_text(comment)
|
- | 354 |
+ 1051 |
|
- }
+ }
|
- | 355 |
+ 1052 |
! |
- iv_extra$add_rule("x_axis", rule_dupl)
+ card$append_src(teal.code::get_code(output_q()))
|
- | 356 |
+ 1053 |
! |
- iv_extra$add_rule("y_axis", rule_dupl)
+ card
|
-
- | 357 |
- ! |
+
+ | 1054 |
+ |
- iv_extra$add_rule("variables", function(value) {
+ }
|
- | 358 |
+ 1055 |
! |
- if (identical(input$plot_type, "Circle plot")) {
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
-
- | 359 |
- ! |
+
+ | 1056 |
+ |
- if (!shinyvalidate::input_provided(value)) {
+ }
|
-
- | 360 |
- ! |
+
+ | 1057 |
+ |
- "Need Original Coordinates"
+ ###
|
- | 361 |
+ 1058 |
|
- }
+ })
|
- | 362 |
+ 1059 |
|
- }
+ }
|
+
+
+
+
+
+
- | 363 |
+ 1 |
|
- })
+ #' `teal` module: Univariate and bivariate visualizations
|
-
- | 364 |
- ! |
+
+ | 2 |
+ |
- iv_extra$add_rule("pc", function(value) {
+ #'
|
-
- | 365 |
- ! |
+
+ | 3 |
+ |
- if (identical(input$plot_type, "Eigenvector plot")) {
+ #' Module enables the creation of univariate and bivariate plots,
|
-
- | 366 |
- ! |
+
+ | 4 |
+ |
- if (!shinyvalidate::input_provided(value)) {
+ #' facilitating the exploration of data distributions and relationships between two variables.
|
-
- | 367 |
- ! |
+
+ | 5 |
+ |
- "Need PC"
+ #'
|
- | 368 |
+ 6 |
|
- }
+ #' This is a general module to visualize 1 & 2 dimensional data.
|
- | 369 |
+ 7 |
|
- }
+ #'
|
- | 370 |
+ 8 |
|
- })
+ #' @note
|
-
- | 371 |
- ! |
+
+ | 9 |
+ |
- iv_extra$enable()
+ #' For more examples, please see the vignette "Using bivariate plot" via
|
- | 372 |
+ 10 |
|
-
+ #' `vignette("using-bivariate-plot", package = "teal.modules.general")`.
|
-
- | 373 |
- ! |
+
+ | 11 |
+ |
- anl_merged_input <- teal.transform::merge_expression_srv(
+ #'
|
-
- | 374 |
- ! |
+
+ | 12 |
+ |
- selector_list = selector_list,
+ #' @inheritParams teal::module
|
-
- | 375 |
- ! |
+
+ | 13 |
+ |
- datasets = data
+ #' @inheritParams shared_params
|
- | 376 |
+ 14 |
|
- )
+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)
|
- | 377 |
+ 15 |
|
-
+ #' Variable names selected to plot along the x-axis by default.
|
-
- | 378 |
- ! |
+
+ | 16 |
+ |
- anl_merged_q <- reactive({
+ #' Can be numeric, factor or character.
|
-
- | 379 |
- ! |
+
+ | 17 |
+ |
- req(anl_merged_input())
+ #' No empty selections are allowed.
|
-
- | 380 |
- ! |
+
+ | 18 |
+ |
- data() %>%
+ #' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`)
|
-
- | 381 |
- ! |
+
+ | 19 |
+ |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))
+ #' Variable names selected to plot along the y-axis by default.
|
- | 382 |
+ 20 |
|
- })
+ #' Can be numeric, factor or character.
|
- | 383 |
+ 21 |
|
-
+ #' @param use_density (`logical`) optional, indicates whether to plot density (`TRUE`) or frequency (`FALSE`).
|
-
- | 384 |
- ! |
+
+ | 22 |
+ |
- merged <- list(
+ #' Defaults to frequency (`FALSE`).
|
-
- | 385 |
- ! |
+
+ | 23 |
+ |
- anl_input_r = anl_merged_input,
+ #' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
|
-
- | 386 |
- ! |
+
+ | 24 |
+ |
- anl_q_r = anl_merged_q
+ #' specification of the data variable(s) to use for faceting rows.
|
- | 387 |
+ 25 |
|
- )
+ #' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
|
- | 388 |
+ 26 |
|
-
+ #' specification of the data variable(s) to use for faceting columns.
|
-
- | 389 |
- ! |
+
+ | 27 |
+ |
- validation <- reactive({
+ #' @param facet (`logical`) optional, specifies whether the facet encodings `ui` elements are toggled
|
-
- | 390 |
- ! |
+
+ | 28 |
+ |
- req(merged$anl_q_r())
+ #' on and shown to the user by default. Defaults to `TRUE` if either `row_facet` or `column_facet`
|
- | 391 |
+ 29 |
|
- # inputs
+ #' are supplied.
|
-
- | 392 |
- ! |
+
+ | 30 |
+ |
- keep_cols <- as.character(merged$anl_input_r()$columns_source$dat)
+ #' @param color_settings (`logical`) Whether coloring, filling and size should be applied
|
-
- | 393 |
- ! |
+
+ | 31 |
+ |
- na_action <- input$na_action
+ #' and `UI` tool offered to the user.
|
-
- | 394 |
- ! |
+
+ | 32 |
+ |
- standardization <- input$standardization
+ #' @param color (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
|
-
- | 395 |
- ! |
+
+ | 33 |
+ |
- center <- standardization %in% c("center", "center_scale")
+ #' specification of the data variable(s) selected for the outline color inside the coloring settings.
|
-
- | 396 |
- ! |
+
+ | 34 |
+ |
- scale <- standardization == "center_scale"
+ #' It will be applied when `color_settings` is set to `TRUE`.
|
-
- | 397 |
- ! |
+
+ | 35 |
+ |
- ANL <- merged$anl_q_r()[["ANL"]]
+ #' @param fill (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
|
- | 398 |
+ 36 |
|
-
+ #' specification of the data variable(s) selected for the fill color inside the coloring settings.
|
-
- | 399 |
- ! |
+
+ | 37 |
+ |
- teal::validate_has_data(ANL, 10)
+ #' It will be applied when `color_settings` is set to `TRUE`.
|
-
- | 400 |
- ! |
+
+ | 38 |
+ |
- validate(need(
+ #' @param size (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional,
|
-
- | 401 |
- ! |
+
+ | 39 |
+ |
- na_action != "none" | !anyNA(ANL[keep_cols]),
+ #' specification of the data variable(s) selected for the size of `geom_point` plots inside the coloring settings.
|
-
- | 402 |
- ! |
+
+ | 40 |
+ |
- paste(
+ #' It will be applied when `color_settings` is set to `TRUE`.
|
-
- | 403 |
- ! |
+
+ | 41 |
+ |
- "There are NAs in the dataset. Please deal with them in preprocessing",
+ #' @param free_x_scales (`logical`) optional, whether X scaling shall be changeable.
|
-
- | 404 |
- ! |
+
+ | 42 |
+ |
- "or select \"Drop\" in the NA actions inside the encodings panel (left)."
+ #' Does not allow scaling to be changed by default (`FALSE`).
|
- | 405 |
+ 43 |
|
- )
+ #' @param free_y_scales (`logical`) optional, whether Y scaling shall be changeable.
|
- | 406 |
+ 44 |
|
- ))
+ #' Does not allow scaling to be changed by default (`FALSE`).
|
-
- | 407 |
- ! |
+
+ | 45 |
+ |
- if (scale) {
+ #' @param swap_axes (`logical`) optional, whether to swap X and Y axes. Defaults to `FALSE`.
|
-
- | 408 |
- ! |
+
+ | 46 |
+ |
- not_single <- vapply(ANL[keep_cols], function(column) length(unique(column)) != 1, FUN.VALUE = logical(1))
+ #'
|
- | 409 |
+ 47 |
|
-
+ #' @inherit shared_params return
|
-
- | 410 |
- ! |
+
+ | 48 |
+ |
- msg <- paste0(
+ #'
|
-
- | 411 |
- ! |
+
+ | 49 |
+ |
- "You have selected `Center & Scale` under `Standardization` in the `Pre-processing` panel, ",
+ #' @examplesShinylive
|
-
- | 412 |
- ! |
+
+ | 50 |
+ |
- "but one or more of your columns has/have a variance value of zero, indicating all values are identical"
+ #' library(teal.modules.general)
|
- | 413 |
+ 51 |
|
- )
+ #' interactive <- function() TRUE
|
-
- | 414 |
- ! |
+
+ | 52 |
+ |
- validate(need(all(not_single), msg))
+ #' {{ next_example }}
|
- | 415 |
+ 53 |
|
- }
+ #' @examples
|
- | 416 |
+ 54 |
|
- })
+ #' # general data example
|
- | 417 |
+ 55 |
|
-
+ #' data <- teal_data()
|
- | 418 |
+ 56 |
|
- # computation ----
+ #' data <- within(data, {
|
-
- | 419 |
- ! |
+
+ | 57 |
+ |
- computation <- reactive({
+ #' require(nestcolor)
|
-
- | 420 |
- ! |
+
+ | 58 |
+ |
- validation()
+ #' CO2 <- data.frame(CO2)
|
- | 421 |
+ 59 |
|
-
+ #' })
|
- | 422 |
+ 60 |
|
- # inputs
+ #' datanames(data) <- c("CO2")
|
-
- | 423 |
- ! |
+
+ | 61 |
+ |
- keep_cols <- as.character(merged$anl_input_r()$columns_source$dat)
+ #'
|
-
- | 424 |
- ! |
+
+ | 62 |
+ |
- na_action <- input$na_action
+ #' app <- init(
|
-
- | 425 |
- ! |
+
+ | 63 |
+ |
- standardization <- input$standardization
+ #' data = data,
|
-
- | 426 |
- ! |
+
+ | 64 |
+ |
- center <- standardization %in% c("center", "center_scale")
+ #' modules = tm_g_bivariate(
|
-
- | 427 |
- ! |
+
+ | 65 |
+ |
- scale <- standardization == "center_scale"
+ #' x = data_extract_spec(
|
-
- | 428 |
- ! |
+
+ | 66 |
+ |
- ANL <- merged$anl_q_r()[["ANL"]]
+ #' dataname = "CO2",
|
- | 429 |
+ 67 |
|
-
+ #' select = select_spec(
|
-
- | 430 |
- ! |
+
+ | 68 |
+ |
- qenv <- teal.code::eval_code(
+ #' label = "Select variable:",
|
-
- | 431 |
- ! |
+
+ | 69 |
+ |
- merged$anl_q_r(),
+ #' choices = variable_choices(data[["CO2"]]),
|
-
- | 432 |
- ! |
+
+ | 70 |
+ |
- substitute(
+ #' selected = "conc",
|
-
- | 433 |
- ! |
+
+ | 71 |
+ |
- expr = keep_columns <- keep_cols,
+ #' fixed = FALSE
|
-
- | 434 |
- ! |
+
+ | 72 |
+ |
- env = list(keep_cols = keep_cols)
+ #' )
|
- | 435 |
+ 73 |
|
- )
+ #' ),
|
- | 436 |
+ 74 |
|
- )
+ #' y = data_extract_spec(
|
- | 437 |
+ 75 |
|
-
+ #' dataname = "CO2",
|
-
- | 438 |
- ! |
+
+ | 76 |
+ |
- if (na_action == "drop") {
+ #' select = select_spec(
|
-
- | 439 |
- ! |
+
+ | 77 |
+ |
- qenv <- teal.code::eval_code(
+ #' label = "Select variable:",
|
-
- | 440 |
- ! |
+
+ | 78 |
+ |
- qenv,
+ #' choices = variable_choices(data[["CO2"]]),
|
-
- | 441 |
- ! |
+
+ | 79 |
+ |
- quote(ANL <- tidyr::drop_na(ANL, keep_columns))
+ #' selected = "uptake",
|
- | 442 |
+ 80 |
|
- )
+ #' multiple = FALSE,
|
- | 443 |
+ 81 |
|
- }
+ #' fixed = FALSE
|
- | 444 |
+ 82 |
|
-
+ #' )
|
-
- | 445 |
- ! |
+
+ | 83 |
+ |
- qenv <- teal.code::eval_code(
+ #' ),
|
-
- | 446 |
- ! |
+
+ | 84 |
+ |
- qenv,
+ #' row_facet = data_extract_spec(
|
-
- | 447 |
- ! |
+
+ | 85 |
+ |
- substitute(
+ #' dataname = "CO2",
|
-
- | 448 |
- ! |
+
+ | 86 |
+ |
- expr = pca <- summary(stats::prcomp(ANL[keep_columns], center = center, scale. = scale, retx = TRUE)),
+ #' select = select_spec(
|
-
- | 449 |
- ! |
+
+ | 87 |
+ |
- env = list(center = center, scale = scale)
+ #' label = "Select variable:",
|
- | 450 |
+ 88 |
|
- )
+ #' choices = variable_choices(data[["CO2"]]),
|
- | 451 |
+ 89 |
|
- )
+ #' selected = "Type",
|
- | 452 |
+ 90 |
|
-
+ #' fixed = FALSE
|
-
- | 453 |
- ! |
+
+ | 91 |
+ |
- qenv <- teal.code::eval_code(
+ #' )
|
-
- | 454 |
- ! |
+
+ | 92 |
+ |
- qenv,
+ #' ),
|
-
- | 455 |
- ! |
+
+ | 93 |
+ |
- quote({
+ #' col_facet = data_extract_spec(
|
-
- | 456 |
- ! |
+
+ | 94 |
+ |
- tbl_importance <- dplyr::as_tibble(pca$importance, rownames = "Metric")
+ #' dataname = "CO2",
|
-
- | 457 |
- ! |
+
+ | 95 |
+ |
- tbl_importance
+ #' select = select_spec(
|
- | 458 |
+ 96 |
|
- })
+ #' label = "Select variable:",
|
- | 459 |
+ 97 |
|
- )
+ #' choices = variable_choices(data[["CO2"]]),
|
- | 460 |
+ 98 |
|
-
+ #' selected = "Treatment",
|
-
- | 461 |
- ! |
+
+ | 99 |
+ |
- teal.code::eval_code(
+ #' fixed = FALSE
|
-
- | 462 |
- ! |
+
+ | 100 |
+ |
- qenv,
+ #' )
|
-
- | 463 |
- ! |
+
+ | 101 |
+ |
- quote({
+ #' )
|
-
- | 464 |
- ! |
+
+ | 102 |
+ |
- tbl_eigenvector <- dplyr::as_tibble(pca$rotation, rownames = "Variable")
+ #' )
|
-
- | 465 |
- ! |
+
+ | 103 |
+ |
- tbl_eigenvector
+ #' )
|
- | 466 |
+ 104 |
|
- })
+ #' if (interactive()) {
|
- | 467 |
+ 105 |
|
- )
+ #' shinyApp(app$ui, app$server)
|
- | 468 |
+ 106 |
|
- })
+ #' }
|
- | 469 |
+ 107 |
|
-
+ #'
|
- | 470 |
+ 108 |
|
- # plot args ----
+ #' @examplesShinylive
|
-
- | 471 |
- ! |
+
+ | 109 |
+ |
- output$plot_settings <- renderUI({
+ #' library(teal.modules.general)
|
- | 472 |
+ 110 |
|
- # reactivity triggers
+ #' interactive <- function() TRUE
|
-
- | 473 |
- ! |
+
+ | 111 |
+ |
- req(iv_r()$is_valid())
+ #' {{ next_example }}
|
-
- | 474 |
- ! |
+
+ | 112 |
+ |
- req(computation())
+ #' @examples
|
-
- | 475 |
- ! |
+
+ | 113 |
+ |
- qenv <- computation()
+ #' # CDISC data example
|
- | 476 |
+ 114 |
|
-
+ #' data <- teal_data()
|
-
- | 477 |
- ! |
+
+ | 115 |
+ |
- ns <- session$ns
+ #' data <- within(data, {
|
- | 478 |
+ 116 |
|
-
+ #' require(nestcolor)
|
-
- | 479 |
- ! |
+
+ | 117 |
+ |
- pca <- qenv[["pca"]]
+ #' ADSL <- rADSL
|
-
- | 480 |
- ! |
+
+ | 118 |
+ |
- chcs_pcs <- colnames(pca$rotation)
+ #' })
|
-
- | 481 |
- ! |
+
+ | 119 |
+ |
- chcs_vars <- qenv[["keep_columns"]]
+ #' datanames(data) <- c("ADSL")
|
- | 482 |
+ 120 |
|
-
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
|
-
- | 483 |
- ! |
+
+ | 121 |
+ |
- tagList(
+ #'
|
-
- | 484 |
- ! |
+
+ | 122 |
+ |
- conditionalPanel(
+ #' app <- init(
|
-
- | 485 |
- ! |
+
+ | 123 |
+ |
- condition = sprintf(
+ #' data = data,
|
-
- | 486 |
- ! |
+
+ | 124 |
+ |
- "input['%s'] == 'Biplot' || input['%s'] == 'Circle plot'",
+ #' modules = tm_g_bivariate(
|
-
- | 487 |
- ! |
+
+ | 125 |
+ |
- ns("plot_type"), ns("plot_type")
+ #' x = data_extract_spec(
|
- | 488 |
+ 126 |
|
- ),
+ #' dataname = "ADSL",
|
-
- | 489 |
- ! |
+
+ | 127 |
+ |
- list(
+ #' select = select_spec(
|
-
- | 490 |
- ! |
+
+ | 128 |
+ |
- teal.widgets::optionalSelectInput(ns("x_axis"), "X axis", choices = chcs_pcs, selected = chcs_pcs[1]),
+ #' label = "Select variable:",
|
-
- | 491 |
- ! |
+
+ | 129 |
+ |
- teal.widgets::optionalSelectInput(ns("y_axis"), "Y axis", choices = chcs_pcs, selected = chcs_pcs[2]),
+ #' choices = variable_choices(data[["ADSL"]]),
|
-
- | 492 |
- ! |
+
+ | 130 |
+ |
- teal.widgets::optionalSelectInput(
+ #' selected = "AGE",
|
-
- | 493 |
- ! |
+
+ | 131 |
+ |
- ns("variables"), "Original coordinates",
+ #' fixed = FALSE
|
-
- | 494 |
- ! |
+
+ | 132 |
+ |
- choices = chcs_vars, selected = chcs_vars,
+ #' )
|
-
- | 495 |
- ! |
+
+ | 133 |
+ |
- multiple = TRUE
+ #' ),
|
- | 496 |
+ 134 |
|
- )
+ #' y = data_extract_spec(
|
- | 497 |
+ 135 |
|
- )
+ #' dataname = "ADSL",
|
- | 498 |
+ 136 |
|
- ),
+ #' select = select_spec(
|
-
- | 499 |
- ! |
+
+ | 137 |
+ |
- conditionalPanel(
+ #' label = "Select variable:",
|
-
- | 500 |
- ! |
+
+ | 138 |
+ |
- condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")),
+ #' choices = variable_choices(data[["ADSL"]]),
|
-
- | 501 |
- ! |
+
+ | 139 |
+ |
- helpText("No plot specific settings available.")
+ #' selected = "SEX",
|
- | 502 |
+ 140 |
|
- ),
+ #' multiple = FALSE,
|
-
- | 503 |
- ! |
+
+ | 141 |
+ |
- conditionalPanel(
+ #' fixed = FALSE
|
-
- | 504 |
- ! |
+
+ | 142 |
+ |
- condition = paste0("input['", ns("plot_type"), "'] == 'Eigenvector plot'"),
+ #' )
|
-
- | 505 |
- ! |
+
+ | 143 |
+ |
- teal.widgets::optionalSelectInput(ns("pc"), "PC", choices = chcs_pcs, selected = chcs_pcs[1])
+ #' ),
|
- | 506 |
+ 144 |
|
- )
+ #' row_facet = data_extract_spec(
|
- | 507 |
+ 145 |
|
- )
+ #' dataname = "ADSL",
|
- | 508 |
+ 146 |
|
- })
+ #' select = select_spec(
|
- | 509 |
+ 147 |
|
-
+ #' label = "Select variable:",
|
- | 510 |
+ 148 |
|
- # plot elbow ----
+ #' choices = variable_choices(data[["ADSL"]]),
|
-
- | 511 |
- ! |
+
+ | 149 |
+ |
- plot_elbow <- function(base_q) {
+ #' selected = "ARM",
|
-
- | 512 |
- ! |
+
+ | 150 |
+ |
- ggtheme <- input$ggtheme
+ #' fixed = FALSE
|
-
- | 513 |
- ! |
+
+ | 151 |
+ |
- rotate_xaxis_labels <- input$rotate_xaxis_labels
+ #' )
|
-
- | 514 |
- ! |
+
+ | 152 |
+ |
- font_size <- input$font_size
+ #' ),
|
- | 515 |
+ 153 |
|
-
+ #' col_facet = data_extract_spec(
|
-
- | 516 |
- ! |
+
+ | 154 |
+ |
- angle_value <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)
+ #' dataname = "ADSL",
|
-
- | 517 |
- ! |
+
+ | 155 |
+ |
- hjust_value <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)
+ #' select = select_spec(
|
- | 518 |
+ 156 |
|
-
+ #' label = "Select variable:",
|
-
- | 519 |
- ! |
+
+ | 157 |
+ |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(
+ #' choices = variable_choices(data[["ADSL"]]),
|
-
- | 520 |
- ! |
+
+ | 158 |
+ |
- labs = list(x = "Principal component", y = "Proportion of variance explained", color = "", fill = "Legend"),
+ #' selected = "COUNTRY",
|
-
- | 521 |
- ! |
+
+ | 159 |
+ |
- theme = list(
+ #' fixed = FALSE
|
-
- | 522 |
- ! |
+
+ | 160 |
+ |
- legend.position = "right",
+ #' )
|
-
- | 523 |
- ! |
+
+ | 161 |
+ |
- legend.spacing.y = quote(grid::unit(-5, "pt")),
+ #' )
|
-
- | 524 |
- ! |
+
+ | 162 |
+ |
- legend.title = quote(element_text(vjust = 25)),
+ #' )
|
-
- | 525 |
- ! |
+
+ | 163 |
+ |
- axis.text.x = substitute(
+ #' )
|
-
- | 526 |
- ! |
+
+ | 164 |
+ |
- element_text(angle = angle_value, hjust = hjust_value),
+ #' if (interactive()) {
|
-
- | 527 |
- ! |
+
+ | 165 |
+ |
- list(angle_value = angle_value, hjust_value = hjust_value)
+ #' shinyApp(app$ui, app$server)
|
- | 528 |
+ 166 |
|
- ),
+ #' }
|
-
- | 529 |
- ! |
+
+ | 167 |
+ |
- text = substitute(element_text(size = font_size), list(font_size = font_size))
+ #'
|
- | 530 |
+ 168 |
|
- )
+ #' @export
|
- | 531 |
+ 169 |
|
- )
+ #'
|
- | 532 |
+ 170 |
|
-
+ tm_g_bivariate <- function(label = "Bivariate Plots",
|
-
- | 533 |
- ! |
+
+ | 171 |
+ |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
+ x,
|
-
- | 534 |
- ! |
+
+ | 172 |
+ |
- teal.widgets::resolve_ggplot2_args(
+ y,
|
-
- | 535 |
- ! |
+
+ | 173 |
+ |
- user_plot = ggplot2_args[["Elbow plot"]],
+ row_facet = NULL,
|
-
- | 536 |
- ! |
+
+ | 174 |
+ |
- user_default = ggplot2_args$default,
+ col_facet = NULL,
|
-
- | 537 |
- ! |
+
+ | 175 |
+ |
- module_plot = dev_ggplot2_args
+ facet = !is.null(row_facet) || !is.null(col_facet),
|
- | 538 |
+ 176 |
|
- ),
+ color = NULL,
|
-
- | 539 |
- ! |
+
+ | 177 |
+ |
- ggtheme = ggtheme
+ fill = NULL,
|
- | 540 |
+ 178 |
|
- )
+ size = NULL,
|
- | 541 |
+ 179 |
|
-
+ use_density = FALSE,
|
-
- | 542 |
- ! |
+
+ | 180 |
+ |
- teal.code::eval_code(
+ color_settings = FALSE,
|
-
- | 543 |
- ! |
+
+ | 181 |
+ |
- base_q,
+ free_x_scales = FALSE,
|
-
- | 544 |
- ! |
+
+ | 182 |
+ |
- substitute(
+ free_y_scales = FALSE,
|
-
- | 545 |
- ! |
+
+ | 183 |
+ |
- expr = {
+ plot_height = c(600, 200, 2000),
|
-
- | 546 |
- ! |
+
+ | 184 |
+ |
- elb_dat <- pca$importance[c("Proportion of Variance", "Cumulative Proportion"), ] %>%
+ plot_width = NULL,
|
-
- | 547 |
- ! |
+
+ | 185 |
+ |
- dplyr::as_tibble(rownames = "metric") %>%
+ rotate_xaxis_labels = FALSE,
|
-
- | 548 |
- ! |
+
+ | 186 |
+ |
- tidyr::gather("component", "value", -metric) %>%
+ swap_axes = FALSE,
|
-
- | 549 |
- ! |
+
+ | 187 |
+ |
- dplyr::mutate(
+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
-
- | 550 |
- ! |
+
+ | 188 |
+ |
- component = factor(component, levels = unique(stringr::str_sort(component, numeric = TRUE)))
+ ggplot2_args = teal.widgets::ggplot2_args(),
|
- | 551 |
+ 189 |
|
- )
+ pre_output = NULL,
|
- | 552 |
+ 190 |
|
-
+ post_output = NULL) {
|
-
- | 553 |
- ! |
+
+ | 191 |
+ 18x |
- cols <- c(getOption("ggplot2.discrete.colour"), c("lightblue", "darkred", "black"))[1:3]
+ message("Initializing tm_g_bivariate")
|
-
- | 554 |
- ! |
+
+ | 192 |
+ |
- g <- ggplot(mapping = aes_string(x = "component", y = "value")) +
+
|
-
- | 555 |
- ! |
+
+ | 193 |
+ |
- geom_bar(
+ # Normalize the parameters
|
-
- | 556 |
- ! |
+
+ | 194 |
+ 14x |
- aes(fill = "Single variance"),
+ if (inherits(x, "data_extract_spec")) x <- list(x)
|
-
- | 557 |
- ! |
+
+ | 195 |
+ 13x |
- data = dplyr::filter(elb_dat, metric == "Proportion of Variance"),
+ if (inherits(y, "data_extract_spec")) y <- list(y)
|
-
- | 558 |
- ! |
+
+ | 196 |
+ 1x |
- color = "black",
+ if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)
|
-
- | 559 |
- ! |
+
+ | 197 |
+ 1x |
- stat = "identity"
+ if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)
|
-
- | 560 |
- |
+
+ | 198 |
+ 1x |
- ) +
+ if (inherits(color, "data_extract_spec")) color <- list(color)
|
-
- | 561 |
- ! |
+
+ | 199 |
+ 1x |
- geom_point(
+ if (inherits(fill, "data_extract_spec")) fill <- list(fill)
|
-
- | 562 |
- ! |
+
+ | 200 |
+ 1x |
- aes(color = "Cumulative variance"),
+ if (inherits(size, "data_extract_spec")) size <- list(size)
|
-
- | 563 |
- ! |
+
+ | 201 |
+ |
- data = dplyr::filter(elb_dat, metric == "Cumulative Proportion")
+
|
- | 564 |
+ 202 |
|
- ) +
+ # Start of assertions
|
-
- | 565 |
- ! |
+
+ | 203 |
+ 18x |
- geom_line(
+ checkmate::assert_string(label)
|
-
- | 566 |
- ! |
+
+ | 204 |
+ |
- aes(group = 1, color = "Cumulative variance"),
+
|
-
- | 567 |
- ! |
+
+ | 205 |
+ 18x |
- data = dplyr::filter(elb_dat, metric == "Cumulative Proportion")
+ checkmate::assert_list(x, types = "data_extract_spec")
+ |
+
+
+ | 206 |
+ 18x |
+
+ assert_single_selection(x)
|
- | 568 |
+ 207 |
|
- ) +
+
|
-
- | 569 |
- ! |
+
+ | 208 |
+ 16x |
- labs +
+ checkmate::assert_list(y, types = "data_extract_spec")
|
-
- | 570 |
- ! |
+
+ | 209 |
+ 16x |
- scale_color_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[3])) +
+ assert_single_selection(y)
|
-
- | 571 |
- ! |
+
+ | 210 |
+ |
- scale_fill_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[1])) +
+
|
-
- | 572 |
- ! |
+
+ | 211 |
+ 14x |
- ggthemes +
+ checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)
|
-
- | 573 |
- ! |
+
+ | 212 |
+ 14x |
- themes
+ assert_single_selection(row_facet)
|
- | 574 |
+ 213 |
|
|
-
- | 575 |
- ! |
+
+ | 214 |
+ 14x |
- print(g)
+ checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)
+ |
+
+
+ | 215 |
+ 14x |
+
+ assert_single_selection(col_facet)
|
- | 576 |
+ 216 |
|
- },
+
|
-
- | 577 |
- ! |
+
+ | 217 |
+ 14x |
- env = list(
+ checkmate::assert_flag(facet)
|
-
- | 578 |
- ! |
+
+ | 218 |
+ |
- ggthemes = parsed_ggplot2_args$ggtheme,
+
|
-
- | 579 |
- ! |
+
+ | 219 |
+ 14x |
- labs = parsed_ggplot2_args$labs,
+ checkmate::assert_list(color, types = "data_extract_spec", null.ok = TRUE)
|
-
- | 580 |
- ! |
+
+ | 220 |
+ 14x |
- themes = parsed_ggplot2_args$theme
+ assert_single_selection(color)
|
- | 581 |
+ 221 |
|
- )
+
|
-
- | 582 |
- |
+
+ | 222 |
+ 14x |
- )
+ checkmate::assert_list(fill, types = "data_extract_spec", null.ok = TRUE)
|
-
- | 583 |
- |
+
+ | 223 |
+ 14x |
- )
+ assert_single_selection(fill)
|
- | 584 |
+ 224 |
|
- }
+
|
-
- | 585 |
- |
+
+ | 225 |
+ 14x |
-
+ checkmate::assert_list(size, types = "data_extract_spec", null.ok = TRUE)
+ |
+
+
+ | 226 |
+ 14x |
+
+ assert_single_selection(size)
|
- | 586 |
+ 227 |
|
- # plot circle ----
+
|
-
- | 587 |
- ! |
+
+ | 228 |
+ 14x |
- plot_circle <- function(base_q) {
+ checkmate::assert_flag(use_density)
|
-
- | 588 |
- ! |
+
+ | 229 |
+ |
- x_axis <- input$x_axis
+
|
-
- | 589 |
- ! |
+
+ | 230 |
+ |
- y_axis <- input$y_axis
+ # Determines color, fill & size if they are not explicitly set
|
-
- | 590 |
- ! |
+
+ | 231 |
+ 14x |
- variables <- input$variables
+ checkmate::assert_flag(color_settings)
|
-
- | 591 |
- ! |
+
+ | 232 |
+ 14x |
- ggtheme <- input$ggtheme
+ if (color_settings) {
|
-
- | 592 |
- |
+
+ | 233 |
+ 2x |
-
+ if (is.null(color)) {
|
-
- | 593 |
- ! |
+
+ | 234 |
+ 2x |
- rotate_xaxis_labels <- input$rotate_xaxis_labels
+ color <- x
|
-
- | 594 |
- ! |
+
+ | 235 |
+ 2x |
- font_size <- input$font_size
+ color[[1]]$select <- teal.transform::select_spec(choices = color[[1]]$select$choices, selected = NULL)
|
- | 595 |
+ 236 |
|
-
+ }
|
-
- | 596 |
- ! |
+
+ | 237 |
+ 2x |
- angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)
+ if (is.null(fill)) {
|
-
- | 597 |
- ! |
+
+ | 238 |
+ 2x |
- hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)
+ fill <- x
+ |
+
+
+ | 239 |
+ 2x |
+
+ fill[[1]]$select <- teal.transform::select_spec(choices = fill[[1]]$select$choices, selected = NULL)
|
- | 598 |
+ 240 |
|
-
+ }
|
-
- | 599 |
- ! |
+
+ | 241 |
+ 2x |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(
+ if (is.null(size)) {
|
-
- | 600 |
- ! |
+
+ | 242 |
+ 2x |
- theme = list(
+ size <- x
|
-
- | 601 |
- ! |
+
+ | 243 |
+ 2x |
- text = substitute(element_text(size = font_size), list(font_size = font_size)),
+ size[[1]]$select <- teal.transform::select_spec(choices = size[[1]]$select$choices, selected = NULL)
|
-
- | 602 |
- ! |
+
+ | 244 |
+ |
- axis.text.x = substitute(
+ }
|
-
- | 603 |
- ! |
+
+ | 245 |
+ |
- element_text(angle = angle_val, hjust = hjust_val),
+ } else {
|
-
- | 604 |
- ! |
+
+ | 246 |
+ 12x |
- list(angle_val = angle, hjust_val = hjust)
+ if (!is.null(c(color, fill, size))) {
|
-
- | 605 |
- |
+
+ | 247 |
+ 3x |
- )
+ stop("'color_settings' argument needs to be set to TRUE if 'color', 'fill', and/or 'size' is/are supplied.")
|
- | 606 |
+ 248 |
|
- )
+ }
|
- | 607 |
+ 249 |
|
- )
+ }
|
- | 608 |
+ 250 |
|
|
-
- | 609 |
- ! |
+
+ | 251 |
+ 11x |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
+ checkmate::assert_flag(free_x_scales)
|
-
- | 610 |
- ! |
+
+ | 252 |
+ 11x |
- user_plot = ggplot2_args[["Circle plot"]],
+ checkmate::assert_flag(free_y_scales)
|
-
- | 611 |
- ! |
+
+ | 253 |
+ |
- user_default = ggplot2_args$default,
+
|
-
- | 612 |
- ! |
+
+ | 254 |
+ 11x |
- module_plot = dev_ggplot2_args
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
|
-
- | 613 |
- |
+
+ | 255 |
+ 10x |
- )
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
|
-
- | 614 |
- |
+
+ | 256 |
+ 8x |
-
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
|
-
- | 615 |
- ! |
+
+ | 257 |
+ 7x |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
+ checkmate::assert_numeric(
|
-
- | 616 |
- ! |
+
+ | 258 |
+ 7x |
- all_ggplot2_args,
+ plot_width[1],
|
-
- | 617 |
- ! |
+
+ | 259 |
+ 7x |
- ggtheme = ggtheme
+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
|
- | 618 |
+ 260 |
|
- )
+ )
|
- | 619 |
+ 261 |
|
|
-
- | 620 |
- ! |
-
- teal.code::eval_code(
- |
-
-
- | 621 |
- ! |
-
- base_q,
- |
-
-
- | 622 |
- ! |
+
+ | 262 |
+ 5x |
- substitute(
+ checkmate::assert_flag(rotate_xaxis_labels)
|
-
- | 623 |
- ! |
+
+ | 263 |
+ 5x |
- expr = {
+ checkmate::assert_flag(swap_axes)
|
-
- | 624 |
- ! |
+
+ | 264 |
+ |
- pca_rot <- pca$rotation[, c(x_axis, y_axis)] %>%
+
|
-
- | 625 |
- ! |
+
+ | 265 |
+ 5x |
- dplyr::as_tibble(rownames = "label") %>%
+ ggtheme <- match.arg(ggtheme)
|
-
- | 626 |
- ! |
+
+ | 266 |
+ 5x |
- dplyr::filter(label %in% variables)
+ checkmate::assert_class(ggplot2_args, "ggplot2_args")
|
- | 627 |
+ 267 |
|
|
-
- | 628 |
- ! |
-
- circle_data <- data.frame(
- |
-
-
- | 629 |
- ! |
+
+ | 268 |
+ 5x |
- x = cos(seq(0, 2 * pi, length.out = 100)),
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
-
- | 630 |
- ! |
+
+ | 269 |
+ 5x |
- y = sin(seq(0, 2 * pi, length.out = 100))
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
- | 631 |
+ 270 |
|
- )
+ # End of assertions
|
- | 632 |
+ 271 |
|
|
-
- | 633 |
- ! |
+
+ | 272 |
+ |
- g <- ggplot(pca_rot) +
+ # Make UI args
|
-
- | 634 |
- ! |
+
+ | 273 |
+ 5x |
- geom_point(aes_string(x = x_axis, y = y_axis)) +
+ args <- as.list(environment())
|
-
- | 635 |
- ! |
+
+ | 274 |
+ |
- geom_label(
+
|
-
- | 636 |
- ! |
+
+ | 275 |
+ 5x |
- aes_string(x = x_axis, y = y_axis, label = "label"),
+ data_extract_list <- list(
|
-
- | 637 |
- ! |
+
+ | 276 |
+ 5x |
- nudge_x = 0.1, nudge_y = 0.05,
+ x = x,
|
-
- | 638 |
- ! |
+
+ | 277 |
+ 5x |
- fontface = "bold"
+ y = y,
|
-
- | 639 |
- |
+
+ | 278 |
+ 5x |
- ) +
+ row_facet = row_facet,
|
-
- | 640 |
- ! |
+
+ | 279 |
+ 5x |
- geom_path(aes(x, y, group = 1), data = circle_data) +
+ col_facet = col_facet,
|
-
- | 641 |
- ! |
+
+ | 280 |
+ 5x |
- geom_point(aes(x = x, y = y), data = data.frame(x = 0, y = 0), shape = "x", size = 5) +
+ color_settings = color_settings,
|
-
- | 642 |
- ! |
+
+ | 281 |
+ 5x |
- labs +
+ color = color,
|
-
- | 643 |
- ! |
+
+ | 282 |
+ 5x |
- ggthemes +
+ fill = fill,
|
-
- | 644 |
- ! |
+
+ | 283 |
+ 5x |
- themes
+ size = size
|
-
- | 645 |
- ! |
+
+ | 284 |
+ |
- print(g)
+ )
|
- | 646 |
+ 285 |
|
- },
+
|
-
- | 647 |
- ! |
+
+ | 286 |
+ 5x |
- env = list(
+ ans <- module(
|
-
- | 648 |
- ! |
+
+ | 287 |
+ 5x |
- x_axis = x_axis,
+ label = label,
|
-
- | 649 |
- ! |
+
+ | 288 |
+ 5x |
- y_axis = y_axis,
+ server = srv_g_bivariate,
|
-
- | 650 |
- ! |
+
+ | 289 |
+ 5x |
- variables = variables,
+ ui = ui_g_bivariate,
|
-
- | 651 |
- ! |
+
+ | 290 |
+ 5x |
- ggthemes = parsed_ggplot2_args$ggtheme,
+ ui_args = args,
|
-
- | 652 |
- ! |
+
+ | 291 |
+ 5x |
- labs = `if`(is.null(parsed_ggplot2_args$labs), quote(labs()), parsed_ggplot2_args$labs),
+ server_args = c(
|
-
- | 653 |
- ! |
+
+ | 292 |
+ 5x |
- themes = parsed_ggplot2_args$theme
+ data_extract_list,
+ |
+
+
+ | 293 |
+ 5x |
+
+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)
|
- | 654 |
+ 294 |
|
- )
+ ),
+ |
+
+
+ | 295 |
+ 5x |
+
+ datanames = teal.transform::get_extract_datanames(data_extract_list)
|
- | 655 |
+ 296 |
|
- )
+ )
+ |
+
+
+ | 297 |
+ 5x |
+
+ attr(ans, "teal_bookmarkable") <- TRUE
+ |
+
+
+ | 298 |
+ 5x |
+
+ ans
|
- | 656 |
+ 299 |
|
- )
+ }
|
- | 657 |
+ 300 |
|
- }
+
|
- | 658 |
+ 301 |
|
-
+ # UI function for the bivariate module
|
- | 659 |
+ 302 |
|
- # plot biplot ----
+ ui_g_bivariate <- function(id, ...) {
|
- | 660 |
+ 303 |
+ ! |
+
+ args <- list(...)
+ |
+
+
+ | 304 |
! |
- plot_biplot <- function(base_q) {
+ is_single_dataset_value <- teal.transform::is_single_dataset(
|
- | 661 |
+ 305 |
! |
- qenv <- base_q
+ args$x, args$y, args$row_facet, args$col_facet, args$color, args$fill, args$size
|
- | 662 |
+ 306 |
|
-
- |
-
-
- | 663 |
- ! |
-
- ANL <- qenv[["ANL"]]
+ )
|
- | 664 |
+ 307 |
|
|
- | 665 |
+ 308 |
! |
- resp_col <- as.character(merged$anl_input_r()$columns_source$response)
+ ns <- NS(id)
|
- | 666 |
+ 309 |
! |
- dat_cols <- as.character(merged$anl_input_r()$columns_source$dat)
+ teal.widgets::standard_layout(
|
- | 667 |
+ 310 |
! |
- x_axis <- input$x_axis
+ output = teal.widgets::white_small_well(
|
- | 668 |
+ 311 |
! |
- y_axis <- input$y_axis
+ tags$div(teal.widgets::plot_with_settings_ui(id = ns("myplot")))
|
-
- | 669 |
- ! |
+
+ | 312 |
+ |
- variables <- input$variables
+ ),
|
- | 670 |
+ 313 |
! |
- pca <- qenv[["pca"]]
+ encoding = tags$div(
|
- | 671 |
+ 314 |
|
-
+ ### Reporter
|
- | 672 |
+ 315 |
! |
- ggtheme <- input$ggtheme
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
- | 673 |
+ 316 |
|
-
+ ###
|
- | 674 |
+ 317 |
! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels
+ tags$label("Encodings", class = "text-primary"),
|
- | 675 |
+ 318 |
! |
- alpha <- input$alpha
+ teal.transform::datanames_input(args[c("x", "y", "row_facet", "col_facet", "color", "fill", "size")]),
|
- | 676 |
+ 319 |
! |
- size <- input$size
+ teal.transform::data_extract_ui(
|
- | 677 |
+ 320 |
! |
- font_size <- input$font_size
+ id = ns("x"),
|
-
- | 678 |
- |
+
+ | 321 |
+ ! |
-
+ label = "X variable",
|
- | 679 |
+ 322 |
! |
- qenv <- teal.code::eval_code(
+ data_extract_spec = args$x,
|
- | 680 |
+ 323 |
! |
- qenv,
+ is_single_dataset = is_single_dataset_value
|
-
- | 681 |
- ! |
+
+ | 324 |
+ |
- substitute(
+ ),
|
- | 682 |
+ 325 |
! |
- expr = pca_rot <- dplyr::as_tibble(pca$x[, c(x_axis, y_axis)]),
+ teal.transform::data_extract_ui(
|
- | 683 |
+ 326 |
! |
- env = list(x_axis = x_axis, y_axis = y_axis)
+ id = ns("y"),
|
-
- | 684 |
- |
+
+ | 327 |
+ ! |
- )
+ label = "Y variable",
|
-
- | 685 |
- |
+
+ | 328 |
+ ! |
- )
+ data_extract_spec = args$y,
|
-
- | 686 |
- |
+
+ | 329 |
+ ! |
-
+ is_single_dataset = is_single_dataset_value
|
- | 687 |
+ 330 |
|
- # rot_vars = data frame that displays arrows in the plot, need to be scaled to data
+ ),
|
- | 688 |
+ 331 |
! |
- if (!is.null(input$variables)) {
+ conditionalPanel(
|
- | 689 |
+ 332 |
! |
- qenv <- teal.code::eval_code(
+ condition =
|
- | 690 |
+ 333 |
! |
- qenv,
+ "$(\"button[data-id*='-x-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ||
|
- | 691 |
+ 334 |
! |
- substitute(
+ $(\"button[data-id*='-y-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ",
|
- | 692 |
+ 335 |
! |
- expr = {
+ shinyWidgets::radioGroupButtons(
|
- | 693 |
+ 336 |
! |
- r <- sqrt(qchisq(0.69, df = 2)) * prod(colMeans(pca_rot ^ 2)) ^ (1 / 4) # styler: off
+ inputId = ns("use_density"),
|
- | 694 |
+ 337 |
! |
- v_scale <- rowSums(pca$rotation ^ 2) # styler: off
+ label = NULL,
|
-
- | 695 |
- |
+
+ | 338 |
+ ! |
-
+ choices = c("frequency", "density"),
|
- | 696 |
+ 339 |
! |
- rot_vars <- pca$rotation[, c(x_axis, y_axis)] %>%
+ selected = ifelse(args$use_density, "density", "frequency"),
|
- | 697 |
+ 340 |
! |
- dplyr::as_tibble(rownames = "label") %>%
+ justified = TRUE
|
-
- | 698 |
- ! |
+
+ | 341 |
+ |
- dplyr::mutate_at(vars(c(x_axis, y_axis)), function(x) r * x / sqrt(max(v_scale)))
+ )
|
- | 699 |
+ 342 |
|
- },
+ ),
|
- | 700 |
+ 343 |
! |
- env = list(x_axis = x_axis, y_axis = y_axis)
+ if (!is.null(args$row_facet) || !is.null(args$col_facet)) {
|
-
- | 701 |
- |
+
+ | 344 |
+ ! |
- )
+ tags$div(
|
-
- | 702 |
- |
+
+ | 345 |
+ ! |
- ) %>%
+ class = "data-extract-box",
|
- | 703 |
+ 346 |
! |
- teal.code::eval_code(
+ tags$label("Facetting"),
|
- | 704 |
+ 347 |
! |
- if (is.logical(pca$center) && !pca$center) {
+ shinyWidgets::switchInput(inputId = ns("facetting"), value = args$facet, size = "mini"),
|
- | 705 |
+ 348 |
! |
- substitute(
+ conditionalPanel(
|
- | 706 |
+ 349 |
! |
- expr = {
+ condition = paste0("input['", ns("facetting"), "']"),
|
- | 707 |
+ 350 |
! |
- rot_vars <- rot_vars %>%
+ tags$div(
|
- | 708 |
+ 351 |
! |
- tibble::column_to_rownames("label") %>%
+ if (!is.null(args$row_facet)) {
|
- | 709 |
+ 352 |
! |
- sweep(1, apply(ANL[keep_columns], 2, mean, na.rm = TRUE)) %>%
+ teal.transform::data_extract_ui(
|
- | 710 |
+ 353 |
! |
- tibble::rownames_to_column("label") %>%
+ id = ns("row_facet"),
|
- | 711 |
+ 354 |
! |
- dplyr::mutate(
+ label = "Row facetting variable",
|
- | 712 |
+ 355 |
! |
- xstart = mean(pca$x[, x_axis], na.rm = TRUE),
+ data_extract_spec = args$row_facet,
|
- | 713 |
+ 356 |
! |
- ystart = mean(pca$x[, y_axis], na.rm = TRUE)
+ is_single_dataset = is_single_dataset_value
|
- | 714 |
+ 357 |
|
- )
+ )
|
- | 715 |
+ 358 |
|
- },
+ },
|
- | 716 |
+ 359 |
! |
- env = list(x_axis = x_axis, y_axis = y_axis)
+ if (!is.null(args$col_facet)) {
|
-
- | 717 |
- |
+
+ | 360 |
+ ! |
- )
+ teal.transform::data_extract_ui(
|
-
- | 718 |
- |
+
+ | 361 |
+ ! |
- } else {
+ id = ns("col_facet"),
|
- | 719 |
+ 362 |
! |
- quote(rot_vars <- rot_vars %>% dplyr::mutate(xstart = 0, ystart = 0))
+ label = "Column facetting variable",
|
-
- | 720 |
- |
+
+ | 363 |
+ ! |
- }
+ data_extract_spec = args$col_facet,
|
-
- | 721 |
- |
+
+ | 364 |
+ ! |
- ) %>%
+ is_single_dataset = is_single_dataset_value
|
-
- | 722 |
- ! |
+
+ | 365 |
+ |
- teal.code::eval_code(
+ )
|
-
- | 723 |
- ! |
+
+ | 366 |
+ |
- substitute(
+ },
|
- | 724 |
+ 367 |
! |
- expr = rot_vars <- rot_vars %>% dplyr::filter(label %in% variables),
+ checkboxInput(ns("free_x_scales"), "free x scales", value = args$free_x_scales),
|
- | 725 |
+ 368 |
! |
- env = list(variables = variables)
+ checkboxInput(ns("free_y_scales"), "free y scales", value = args$free_y_scales)
|
- | 726 |
+ 369 |
|
)
|
- | 727 |
+ 370 |
|
)
|
- | 728 |
+ 371 |
|
- }
+ )
|
- | 729 |
+ 372 |
|
-
+ },
|
- | 730 |
+ 373 |
! |
- pca_plot_biplot_expr <- list(quote(ggplot()))
+ if (args$color_settings) {
|
- | 731 |
+ 374 |
|
-
+ # Put a grey border around the coloring settings
|
- | 732 |
+ 375 |
! |
- if (length(resp_col) == 0) {
+ tags$div(
|
- | 733 |
+ 376 |
! |
- pca_plot_biplot_expr <- c(
+ class = "data-extract-box",
|
- | 734 |
+ 377 |
! |
- pca_plot_biplot_expr,
+ tags$label("Color settings"),
|
- | 735 |
+ 378 |
! |
- substitute(
+ shinyWidgets::switchInput(inputId = ns("coloring"), value = TRUE, size = "mini"),
|
- | 736 |
+ 379 |
! |
- geom_point(aes_string(x = x_axis, y = y_axis), data = pca_rot, alpha = alpha, size = size),
+ conditionalPanel(
|
- | 737 |
+ 380 |
! |
- list(x_axis = input$x_axis, y_axis = input$y_axis, alpha = input$alpha, size = input$size)
+ condition = paste0("input['", ns("coloring"), "']"),
|
-
- | 738 |
- |
+
+ | 381 |
+ ! |
- )
+ tags$div(
|
-
- | 739 |
- |
+
+ | 382 |
+ ! |
- )
+ teal.transform::data_extract_ui(
|
- | 740 |
+ 383 |
! |
- dev_labs <- list()
+ id = ns("color"),
|
-
- | 741 |
- |
+
+ | 384 |
+ ! |
- } else {
+ label = "Outline color by variable",
|
- | 742 |
+ 385 |
! |
- rp_keys <- setdiff(colnames(ANL), as.character(unlist(merged$anl_input_r()$columns_source)))
+ data_extract_spec = args$color,
+ |
+
+
+ | 386 |
+ ! |
+
+ is_single_dataset = is_single_dataset_value
|
- | 743 |
+ 387 |
|
-
+ ),
|
- | 744 |
+ 388 |
! |
- response <- ANL[[resp_col]]
+ teal.transform::data_extract_ui(
|
-
- | 745 |
- |
+
+ | 389 |
+ ! |
-
+ id = ns("fill"),
|
- | 746 |
+ 390 |
! |
- aes_biplot <- substitute(
+ label = "Fill color by variable",
|
- | 747 |
+ 391 |
! |
- aes_string(x = x_axis, y = y_axis, color = "response"),
+ data_extract_spec = args$fill,
|
- | 748 |
+ 392 |
! |
- env = list(x_axis = x_axis, y_axis = y_axis)
+ is_single_dataset = is_single_dataset_value
|
- | 749 |
+ 393 |
|
- )
+ ),
|
-
- | 750 |
- |
+
+ | 394 |
+ ! |
-
+ tags$div(
|
- | 751 |
+ 395 |
! |
- qenv <- teal.code::eval_code(
+ id = ns("size_settings"),
|
- | 752 |
+ 396 |
! |
- qenv,
+ teal.transform::data_extract_ui(
|
- | 753 |
+ 397 |
! |
- substitute(response <- ANL[[resp_col]], env = list(resp_col = resp_col))
+ id = ns("size"),
+ |
+
+
+ | 398 |
+ ! |
+
+ label = "Size of points by variable (only if x and y are numeric)",
+ |
+
+
+ | 399 |
+ ! |
+
+ data_extract_spec = args$size,
+ |
+
+
+ | 400 |
+ ! |
+
+ is_single_dataset = is_single_dataset_value
|
- | 754 |
+ 401 |
|
- )
+ )
|
- | 755 |
+ 402 |
|
-
+ )
|
-
- | 756 |
- ! |
+
+ | 403 |
+ |
- dev_labs <- list(color = varname_w_label(resp_col, ANL))
+ )
+ |
+
+
+ | 404 |
+ |
+
+ )
+ |
+
+
+ | 405 |
+ |
+
+ )
|
- | 757 |
+ 406 |
|
-
+ },
|
- | 758 |
+ 407 |
! |
- scales_biplot <-
+ teal.widgets::panel_group(
|
- | 759 |
+ 408 |
! |
- if (
+ teal.widgets::panel_item(
|
- | 760 |
+ 409 |
! |
- is.character(response) ||
+ title = "Plot settings",
|
- | 761 |
+ 410 |
! |
- is.factor(response) ||
+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
|
- | 762 |
+ 411 |
! |
- (is.numeric(response) && length(unique(response)) <= 6)
+ checkboxInput(ns("swap_axes"), "Swap axes", value = args$swap_axes),
|
-
- | 763 |
- |
+
+ | 412 |
+ ! |
- ) {
+ selectInput(
|
- | 764 |
+ 413 |
! |
- qenv <- teal.code::eval_code(
+ inputId = ns("ggtheme"),
|
- | 765 |
+ 414 |
! |
- qenv,
+ label = "Theme (by ggplot):",
|
- | 766 |
+ 415 |
! |
- quote(pca_rot$response <- as.factor(response))
+ choices = ggplot_themes,
|
-
- | 767 |
- |
+
+ | 416 |
+ ! |
- )
+ selected = args$ggtheme,
|
- | 768 |
+ 417 |
! |
- quote(scale_color_brewer(palette = "Dark2"))
+ multiple = FALSE
|
-
- | 769 |
- ! |
+
+ | 418 |
+ |
- } else if (inherits(response, "Date")) {
+ ),
|
- | 770 |
+ 419 |
! |
- qenv <- teal.code::eval_code(
+ sliderInput(
|
- | 771 |
+ 420 |
! |
- qenv,
+ ns("alpha"), "Opacity Scatterplot:",
|
- | 772 |
+ 421 |
! |
- quote(pca_rot$response <- numeric(response))
+ min = 0, max = 1,
|
-
- | 773 |
- |
+
+ | 422 |
+ ! |
- )
+ step = .05, value = .5, ticks = FALSE
|
- | 774 |
+ 423 |
|
-
+ ),
|
- | 775 |
+ 424 |
! |
- quote(
+ sliderInput(
|
- | 776 |
+ 425 |
! |
- scale_color_gradient(
+ ns("fixed_size"), "Scatterplot point size:",
|
- | 777 |
+ 426 |
! |
- low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],
+ min = 1, max = 8,
|
- | 778 |
+ 427 |
! |
- high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1],
+ step = 1, value = 2, ticks = FALSE
+ |
+
+
+ | 428 |
+ |
+
+ ),
|
- | 779 |
+ 429 |
! |
- labels = function(x) as.Date(x, origin = "1970-01-01")
+ checkboxInput(ns("add_lines"), "Add lines"),
|
- | 780 |
+ 430 |
|
- )
+ )
|
- | 781 |
+ 431 |
|
- )
+ )
|
- | 782 |
+ 432 |
|
- } else {
- |
-
-
- | 783 |
- ! |
-
- qenv <- teal.code::eval_code(
+ ),
|
- | 784 |
+ 433 |
! |
- qenv,
+ forms = tagList(
|
- | 785 |
+ 434 |
! |
- quote(pca_rot$response <- response)
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
- | 786 |
+ 435 |
|
- )
+ ),
|
- | 787 |
+ 436 |
! |
- quote(scale_color_gradient(
+ pre_output = args$pre_output,
|
- | 788 |
+ 437 |
! |
- low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],
+ post_output = args$post_output
|
-
- | 789 |
- ! |
+
+ | 438 |
+ |
- high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
+ )
|
- | 790 |
+ 439 |
|
- ))
+ }
|
- | 791 |
+ 440 |
|
- }
+
|
- | 792 |
+ 441 |
|
-
+ # Server function for the bivariate module
|
-
- | 793 |
- ! |
+
+ | 442 |
+ |
- pca_plot_biplot_expr <- c(
+ srv_g_bivariate <- function(id,
|
-
- | 794 |
- ! |
+
+ | 443 |
+ |
- pca_plot_biplot_expr,
+ data,
|
-
- | 795 |
- ! |
+
+ | 444 |
+ |
- substitute(
+ reporter,
|
-
- | 796 |
- ! |
+
+ | 445 |
+ |
- geom_point(aes_biplot, data = pca_rot, alpha = alpha, size = size),
+ filter_panel_api,
|
-
- | 797 |
- ! |
+
+ | 446 |
+ |
- env = list(aes_biplot = aes_biplot, alpha = alpha, size = size)
+ x,
|
- | 798 |
+ 447 |
|
- ),
+ y,
|
-
- | 799 |
- ! |
+
+ | 448 |
+ |
- scales_biplot
+ row_facet,
|
- | 800 |
+ 449 |
|
- )
+ col_facet,
|
- | 801 |
+ 450 |
|
- }
+ color_settings = FALSE,
|
- | 802 |
+ 451 |
|
-
+ color,
|
-
- | 803 |
- ! |
+
+ | 452 |
+ |
- if (!is.null(input$variables)) {
+ fill,
|
-
- | 804 |
- ! |
+
+ | 453 |
+ |
- pca_plot_biplot_expr <- c(
+ size,
|
-
- | 805 |
- ! |
+
+ | 454 |
+ |
- pca_plot_biplot_expr,
+ plot_height,
|
-
- | 806 |
- ! |
+
+ | 455 |
+ |
- substitute(
+ plot_width,
|
-
- | 807 |
- ! |
+
+ | 456 |
+ |
- geom_segment(
+ ggplot2_args) {
|
- | 808 |
+ 457 |
! |
- aes_string(x = "xstart", y = "ystart", xend = x_axis, yend = y_axis),
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
|
- | 809 |
+ 458 |
! |
- data = rot_vars,
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
|
- | 810 |
+ 459 |
! |
- lineend = "round", linejoin = "round",
+ checkmate::assert_class(data, "reactive")
|
- | 811 |
+ 460 |
! |
- arrow = grid::arrow(length = grid::unit(0.5, "cm"))
+ checkmate::assert_class(isolate(data()), "teal_data")
|
-
- | 812 |
- |
+
+ | 461 |
+ ! |
- ),
+ moduleServer(id, function(input, output, session) {
|
- | 813 |
+ 462 |
! |
- env = list(x_axis = x_axis, y_axis = y_axis)
+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
|
- | 814 |
+ 463 |
|
- ),
+
|
- | 815 |
+ 464 |
! |
- substitute(
+ ns <- session$ns
|
-
- | 816 |
- ! |
+
+ | 465 |
+ |
- geom_label(
+
|
- | 817 |
+ 466 |
! |
- aes_string(
+ data_extract <- list(
|
- | 818 |
+ 467 |
! |
- x = x_axis,
+ x = x, y = y, row_facet = row_facet, col_facet = col_facet,
|
- | 819 |
+ 468 |
! |
- y = y_axis,
+ color = color, fill = fill, size = size
|
-
- | 820 |
- ! |
+
+ | 469 |
+ |
- label = "label"
+ )
|
- | 821 |
+ 470 |
|
- ),
+
|
- | 822 |
+ 471 |
! |
- data = rot_vars,
+ rule_var <- function(other) {
|
- | 823 |
+ 472 |
! |
- nudge_y = 0.1,
+ function(value) {
|
- | 824 |
+ 473 |
! |
- fontface = "bold"
- |
-
-
- | 825 |
- |
-
- ),
+ othervalue <- selector_list()[[other]]()$select
|
- | 826 |
+ 474 |
! |
- env = list(x_axis = x_axis, y_axis = y_axis)
- |
-
-
- | 827 |
- |
-
- ),
+ if (length(value) == 0L && length(othervalue) == 0L) {
|
- | 828 |
+ 475 |
! |
- quote(geom_point(aes(x = xstart, y = ystart), data = rot_vars, shape = "x", size = 5))
+ "Please select at least one of x-variable or y-variable"
|
- | 829 |
+ 476 |
|
- )
+ }
|
- | 830 |
+ 477 |
|
}
|
- | 831 |
- |
-
-
- |
-
-
- | 832 |
- ! |
-
- angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)
- |
-
-
- | 833 |
- ! |
-
- hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)
- |
-
-
- | 834 |
+ 478 |
|
-
+ }
|
- | 835 |
+ 479 |
! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(
+ rule_diff <- function(other) {
|
- | 836 |
+ 480 |
! |
- labs = dev_labs,
+ function(value) {
|
- | 837 |
+ 481 |
! |
- theme = list(
+ othervalue <- selector_list()[[other]]()[["select"]]
|
- | 838 |
+ 482 |
! |
- text = substitute(element_text(size = font_size), list(font_size = font_size)),
+ if (!is.null(othervalue)) {
|
- | 839 |
+ 483 |
! |
- axis.text.x = substitute(
+ if (identical(value, othervalue)) {
|
- | 840 |
+ 484 |
! |
- element_text(angle = angle_val, hjust = hjust_val),
+ "Row and column facetting variables must be different."
|
-
- | 841 |
- ! |
+
+ | 485 |
+ |
- list(angle_val = angle, hjust_val = hjust)
+ }
|
- | 842 |
+ 486 |
|
- )
+ }
|
- | 843 |
+ 487 |
|
- )
+ }
|
- | 844 |
+ 488 |
|
- )
+ }
|
- | 845 |
+ 489 |
|
|
- | 846 |
+ 490 |
! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
+ selector_list <- teal.transform::data_extract_multiple_srv(
|
- | 847 |
+ 491 |
! |
- user_plot = ggplot2_args[["Biplot"]],
+ data_extract = data_extract,
|
- | 848 |
+ 492 |
! |
- user_default = ggplot2_args$default,
+ datasets = data,
|
- | 849 |
+ 493 |
! |
- module_plot = dev_ggplot2_args
+ select_validation_rule = list(
|
-
- | 850 |
- |
+
+ | 494 |
+ ! |
- )
+ x = rule_var("y"),
|
-
- | 851 |
- |
+
+ | 495 |
+ ! |
-
+ y = rule_var("x"),
|
- | 852 |
+ 496 |
! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
+ row_facet = shinyvalidate::compose_rules(
|
- | 853 |
+ 497 |
! |
- all_ggplot2_args,
+ shinyvalidate::sv_optional(),
|
- | 854 |
+ 498 |
! |
- ggtheme = ggtheme
+ rule_diff("col_facet")
|
- | 855 |
+ 499 |
|
- )
+ ),
|
-
- | 856 |
- |
+
+ | 500 |
+ ! |
-
+ col_facet = shinyvalidate::compose_rules(
|
- | 857 |
+ 501 |
! |
- pca_plot_biplot_expr <- c(
+ shinyvalidate::sv_optional(),
|
- | 858 |
+ 502 |
! |
- pca_plot_biplot_expr,
+ rule_diff("row_facet")
|
-
- | 859 |
- ! |
+
+ | 503 |
+ |
- parsed_ggplot2_args
+ )
|
- | 860 |
+ 504 |
|
)
|
- | 861 |
+ 505 |
+ |
+
+ )
+ |
+
+
+ | 506 |
|
|
- | 862 |
+ 507 |
! |
- teal.code::eval_code(
+ iv_r <- reactive({
|
- | 863 |
+ 508 |
! |
- qenv,
+ iv_facet <- shinyvalidate::InputValidator$new()
|
- | 864 |
+ 509 |
! |
- substitute(
+ iv_child <- teal.transform::compose_and_enable_validators(iv_facet, selector_list,
|
- | 865 |
+ 510 |
! |
- expr = {
+ validator_names = c("row_facet", "col_facet")
|
-
- | 866 |
- ! |
+
+ | 511 |
+ |
- g <- plot_call
+ )
|
- | 867 |
+ 512 |
! |
- print(g)
+ iv_child$condition(~ isTRUE(input$facetting))
|
- | 868 |
+ 513 |
|
- },
+
|
- | 869 |
+ 514 |
! |
- env = list(
+ iv <- shinyvalidate::InputValidator$new()
|
- | 870 |
+ 515 |
! |
- plot_call = Reduce(function(x, y) call("+", x, y), pca_plot_biplot_expr)
- |
-
-
- | 871 |
- |
-
- )
- |
-
-
- | 872 |
- |
-
- )
+ iv$add_validator(iv_child)
|
-
- | 873 |
- |
+
+ | 516 |
+ ! |
- )
+ teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = c("x", "y"))
|
- | 874 |
+ 517 |
|
- }
+ })
|
- | 875 |
+ 518 |
|
|
-
- | 876 |
- |
+
+ | 519 |
+ ! |
- # plot pc_var ----
+ anl_merged_input <- teal.transform::merge_expression_srv(
|
- | 877 |
+ 520 |
! |
- plot_pc_var <- function(base_q) {
+ selector_list = selector_list,
|
- | 878 |
+ 521 |
! |
- pc <- input$pc
+ datasets = data
|
-
- | 879 |
- ! |
+
+ | 522 |
+ |
- ggtheme <- input$ggtheme
+ )
|
- | 880 |
+ 523 |
|
|
- | 881 |
+ 524 |
! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels
+ anl_merged_q <- reactive({
|
- | 882 |
+ 525 |
! |
- font_size <- input$font_size
+ req(anl_merged_input())
|
-
- | 883 |
- |
+
+ | 526 |
+ ! |
-
+ data() %>%
|
- | 884 |
+ 527 |
! |
- angle <- ifelse(rotate_xaxis_labels, 45, 0)
+ teal.code::eval_code(as.expression(anl_merged_input()$expr))
|
-
- | 885 |
- ! |
+
+ | 528 |
+ |
- hjust <- ifelse(rotate_xaxis_labels, 1, 0.5)
+ })
|
- | 886 |
+ 529 |
|
|
- | 887 |
+ 530 |
! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(
+ merged <- list(
|
- | 888 |
+ 531 |
! |
- theme = list(
+ anl_input_r = anl_merged_input,
|
- | 889 |
+ 532 |
! |
- text = substitute(element_text(size = font_size), list(font_size = font_size)),
+ anl_q_r = anl_merged_q
|
-
- | 890 |
- ! |
+
+ | 533 |
+ |
- axis.text.x = substitute(
+ )
+ |
+
+
+ | 534 |
+ |
+
+
|
- | 891 |
+ 535 |
! |
- element_text(angle = angle_val, hjust = hjust_val),
+ output_q <- reactive({
|
- | 892 |
+ 536 |
! |
- list(angle_val = angle, hjust_val = hjust)
+ teal::validate_inputs(iv_r())
|
- | 893 |
+ 537 |
|
- )
+
|
-
- | 894 |
- |
+
+ | 538 |
+ ! |
- )
+ ANL <- merged$anl_q_r()[["ANL"]]
|
-
- | 895 |
- |
+
+ | 539 |
+ ! |
- )
+ teal::validate_has_data(ANL, 3)
|
- | 896 |
+ 540 |
|
|
- | 897 |
+ 541 |
! |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
+ x_col_vec <- as.vector(merged$anl_input_r()$columns_source$x)
|
- | 898 |
+ 542 |
! |
- user_plot = ggplot2_args[["Eigenvector plot"]],
+ x_name <- `if`(is.null(x_col_vec), character(0), x_col_vec)
|
- | 899 |
+ 543 |
! |
- user_default = ggplot2_args$default,
+ y_col_vec <- as.vector(merged$anl_input_r()$columns_source$y)
|
- | 900 |
+ 544 |
! |
- module_plot = dev_ggplot2_args
- |
-
-
- | 901 |
- |
-
- )
+ y_name <- `if`(is.null(y_col_vec), character(0), y_col_vec)
|
- | 902 |
+ 545 |
|
|
- | 903 |
+ 546 |
! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
+ row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet)
|
- | 904 |
+ 547 |
! |
- all_ggplot2_args,
+ col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet)
|
- | 905 |
+ 548 |
! |
- ggtheme = ggtheme
+ color_name <- if ("color" %in% names(merged$anl_input_r()$columns_source)) {
|
-
- | 906 |
- |
+
+ | 549 |
+ ! |
- )
+ as.vector(merged$anl_input_r()$columns_source$color)
|
- | 907 |
+ 550 |
|
-
+ } else {
|
- | 908 |
+ 551 |
! |
- ggplot_exprs <- c(
+ character(0)
|
-
- | 909 |
- ! |
+
+ | 552 |
+ |
- list(
+ }
|
- | 910 |
+ 553 |
! |
- quote(ggplot(pca_rot)),
+ fill_name <- if ("fill" %in% names(merged$anl_input_r()$columns_source)) {
|
- | 911 |
+ 554 |
! |
- substitute(
+ as.vector(merged$anl_input_r()$columns_source$fill)
|
-
- | 912 |
- ! |
+
+ | 555 |
+ |
- geom_bar(
+ } else {
|
- | 913 |
+ 556 |
! |
- aes_string(x = "Variable", y = pc),
+ character(0)
|
-
- | 914 |
- ! |
+
+ | 557 |
+ |
- stat = "identity",
+ }
|
- | 915 |
+ 558 |
! |
- color = "black",
+ size_name <- if ("size" %in% names(merged$anl_input_r()$columns_source)) {
|
- | 916 |
+ 559 |
! |
- fill = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
+ as.vector(merged$anl_input_r()$columns_source$size)
|
- | 917 |
+ 560 |
|
- ),
+ } else {
|
- | 918 |
+ 561 |
! |
- env = list(pc = pc)
+ character(0)
|
- | 919 |
+ 562 |
|
- ),
+ }
|
-
- | 920 |
- ! |
+
+ | 563 |
+ |
- substitute(
+
|
- | 921 |
+ 564 |
! |
- geom_text(
+ use_density <- input$use_density == "density"
|
- | 922 |
+ 565 |
! |
- aes(
+ free_x_scales <- input$free_x_scales
|
- | 923 |
+ 566 |
! |
- x = Variable,
+ free_y_scales <- input$free_y_scales
|
- | 924 |
+ 567 |
! |
- y = pc_name,
+ ggtheme <- input$ggtheme
|
- | 925 |
+ 568 |
! |
- label = round(pc_name, 3),
+ rotate_xaxis_labels <- input$rotate_xaxis_labels
|
- | 926 |
+ 569 |
! |
- vjust = ifelse(pc_name > 0, -0.5, 1.3)
- |
-
-
- | 927 |
- |
-
- )
+ swap_axes <- input$swap_axes
|
- | 928 |
+ 570 |
|
- ),
+
|
- | 929 |
+ 571 |
! |
- env = list(pc_name = as.name(pc))
+ is_scatterplot <- all(vapply(ANL[c(x_name, y_name)], is.numeric, logical(1))) &&
|
-
- | 930 |
- |
+
+ | 572 |
+ ! |
- )
+ length(x_name) > 0 && length(y_name) > 0
|
- | 931 |
+ 573 |
|
- ),
+
|
- | 932 |
+ 574 |
! |
- parsed_ggplot2_args$labs,
+ if (is_scatterplot) {
|
- | 933 |
+ 575 |
! |
- parsed_ggplot2_args$ggtheme,
+ shinyjs::show("alpha")
|
- | 934 |
+ 576 |
! |
- parsed_ggplot2_args$theme
+ alpha <- input$alpha
|
-
- | 935 |
- |
+
+ | 577 |
+ ! |
- )
+ shinyjs::show("add_lines")
|
- | 936 |
+ 578 |
|
|
- | 937 |
+ 579 |
! |
- teal.code::eval_code(
+ if (color_settings && input$coloring) {
|
- | 938 |
+ 580 |
! |
- base_q,
+ shinyjs::hide("fixed_size")
|
- | 939 |
+ 581 |
! |
- substitute(
+ shinyjs::show("size_settings")
|
- | 940 |
+ 582 |
! |
- expr = {
+ size <- NULL
+ |
+
+
+ | 583 |
+ |
+
+ } else {
|
- | 941 |
+ 584 |
! |
- pca_rot <- pca$rotation[, pc, drop = FALSE] %>%
+ shinyjs::show("fixed_size")
|
- | 942 |
+ 585 |
! |
- dplyr::as_tibble(rownames = "Variable")
+ size <- input$fixed_size
|
- | 943 |
+ 586 |
|
-
+ }
+ |
+
+
+ | 587 |
+ |
+
+ } else {
|
- | 944 |
+ 588 |
! |
- g <- plot_call
+ shinyjs::hide("add_lines")
|
-
- | 945 |
- |
+
+ | 589 |
+ ! |
-
+ updateCheckboxInput(session, "add_lines", value = restoreInput(ns("add_lines"), FALSE))
|
- | 946 |
+ 590 |
! |
- print(g)
+ shinyjs::hide("alpha")
|
-
- | 947 |
- |
+
+ | 591 |
+ ! |
- },
+ shinyjs::hide("fixed_size")
|
- | 948 |
+ 592 |
! |
- env = list(
+ shinyjs::hide("size_settings")
|
- | 949 |
+ 593 |
! |
- pc = pc,
+ alpha <- 1
|
- | 950 |
+ 594 |
! |
- plot_call = Reduce(function(x, y) call("+", x, y), ggplot_exprs)
+ size <- NULL
|
- | 951 |
+ 595 |
|
- )
+ }
|
- | 952 |
+ 596 |
|
- )
+
|
-
- | 953 |
- |
+
+ | 597 |
+ ! |
- )
+ teal::validate_has_data(ANL[, c(x_name, y_name), drop = FALSE], 3, complete = TRUE, allow_inf = FALSE)
|
- | 954 |
+ 598 |
|
- }
+
+ |
+
+
+ | 599 |
+ ! |
+
+ cl <- bivariate_plot_call(
+ |
+
+
+ | 600 |
+ ! |
+
+ data_name = "ANL",
|
-
- | 955 |
- |
+
+ | 601 |
+ ! |
-
+ x = x_name,
|
-
- | 956 |
- |
+
+ | 602 |
+ ! |
- # plot final ----
+ y = y_name,
|
- | 957 |
+ 603 |
! |
- output_q <- reactive({
+ x_class = ifelse(!identical(x_name, character(0)), class(ANL[[x_name]]), "NULL"),
|
- | 958 |
+ 604 |
! |
- req(computation())
+ y_class = ifelse(!identical(y_name, character(0)), class(ANL[[y_name]]), "NULL"),
|
- | 959 |
+ 605 |
! |
- teal::validate_inputs(iv_r())
+ x_label = varname_w_label(x_name, ANL),
|
- | 960 |
+ 606 |
! |
- teal::validate_inputs(iv_extra, header = "Plot settings are required")
+ y_label = varname_w_label(y_name, ANL),
|
-
- | 961 |
- |
+
+ | 607 |
+ ! |
-
+ freq = !use_density,
|
- | 962 |
+ 608 |
! |
- switch(input$plot_type,
+ theme = ggtheme,
|
- | 963 |
+ 609 |
! |
- "Elbow plot" = plot_elbow(computation()),
+ rotate_xaxis_labels = rotate_xaxis_labels,
|
- | 964 |
+ 610 |
! |
- "Circle plot" = plot_circle(computation()),
+ swap_axes = swap_axes,
|
- | 965 |
+ 611 |
! |
- "Biplot" = plot_biplot(computation()),
+ alpha = alpha,
|
- | 966 |
+ 612 |
! |
- "Eigenvector plot" = plot_pc_var(computation()),
+ size = size,
|
- | 967 |
+ 613 |
! |
- stop("Unknown plot")
+ ggplot2_args = ggplot2_args
|
- | 968 |
+ 614 |
|
)
|
- | 969 |
+ 615 |
|
- })
+
+ |
+
+
+ | 616 |
+ ! |
+
+ facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name)))
|
- | 970 |
+ 617 |
|
|
- | 971 |
+ 618 |
! |
- plot_r <- reactive({
+ if (facetting) {
|
- | 972 |
+ 619 |
! |
- output_q()[["g"]]
- |
-
-
- | 973 |
- |
-
- })
+ facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name, free_x_scales, free_y_scales)
|
- | 974 |
+ 620 |
|
|
- | 975 |
+ 621 |
! |
- pws <- teal.widgets::plot_with_settings_srv(
+ if (!is.null(facet_cl)) {
|
- | 976 |
+ 622 |
! |
- id = "pca_plot",
+ cl <- call("+", cl, facet_cl)
|
-
- | 977 |
- ! |
+
+ | 623 |
+ |
- plot_r = plot_r,
+ }
|
-
- | 978 |
- ! |
+
+ | 624 |
+ |
- height = plot_height,
+ }
|
-
- | 979 |
- ! |
+
+ | 625 |
+ |
- width = plot_width,
+
|
- | 980 |
+ 626 |
! |
- graph_align = "center"
+ if (input$add_lines) {
|
-
- | 981 |
- |
+
+ | 627 |
+ ! |
- )
+ cl <- call("+", cl, quote(geom_line(size = 1)))
|
- | 982 |
+ 628 |
|
-
+ }
|
- | 983 |
+ 629 |
|
- # tables ----
+
|
- | 984 |
+ 630 |
! |
- output$tbl_importance <- renderTable(
+ coloring_cl <- NULL
|
- | 985 |
+ 631 |
! |
- expr = {
+ if (color_settings) {
|
- | 986 |
+ 632 |
! |
- req("importance" %in% input$tables_display, computation())
+ if (input$coloring) {
|
- | 987 |
+ 633 |
! |
- computation()[["tbl_importance"]]
+ coloring_cl <- coloring_ggplot_call(
|
-
- | 988 |
- |
+
+ | 634 |
+ ! |
- },
+ colour = color_name,
|
- | 989 |
+ 635 |
! |
- bordered = TRUE,
+ fill = fill_name,
|
- | 990 |
+ 636 |
! |
- align = "c",
+ size = size_name,
|
- | 991 |
+ 637 |
! |
- digits = 3
+ is_point = any(grepl("geom_point", cl %>% deparse()))
|
- | 992 |
+ 638 |
|
- )
+ )
|
-
- | 993 |
- |
+
+ | 639 |
+ ! |
-
+ legend_lbls <- substitute(
|
- | 994 |
+ 640 |
! |
- output$tbl_importance_ui <- renderUI({
+ expr = labs(color = color_name, fill = fill_name, size = size_name),
|
- | 995 |
+ 641 |
! |
- req("importance" %in% input$tables_display)
+ env = list(
|
- | 996 |
+ 642 |
! |
- tags$div(
+ color_name = varname_w_label(color_name, ANL),
|
- | 997 |
+ 643 |
! |
- align = "center",
+ fill_name = varname_w_label(fill_name, ANL),
|
- | 998 |
+ 644 |
! |
- tags$h4("Principal components importance"),
+ size_name = varname_w_label(size_name, ANL)
+ |
+
+
+ | 645 |
+ |
+
+ )
+ |
+
+
+ | 646 |
+ |
+
+ )
+ |
+
+
+ | 647 |
+ |
+
+ }
|
- | 999 |
+ 648 |
! |
- tableOutput(session$ns("tbl_importance")),
+ if (!is.null(coloring_cl)) {
|
- | 1000 |
+ 649 |
! |
- tags$hr()
+ cl <- call("+", call("+", cl, coloring_cl), legend_lbls)
|
- | 1001 |
+ 650 |
|
- )
+ }
|
- | 1002 |
+ 651 |
|
- })
+ }
|
- | 1003 |
+ 652 |
|
|
-
- | 1004 |
- ! |
+
+ | 653 |
+ |
- output$tbl_eigenvector <- renderTable(
+ # Add labels to facets
|
- | 1005 |
+ 654 |
! |
- expr = {
+ nulled_row_facet_name <- varname_w_label(row_facet_name, ANL)
|
- | 1006 |
+ 655 |
! |
- req("eigenvector" %in% input$tables_display, req(computation()))
+ nulled_col_facet_name <- varname_w_label(col_facet_name, ANL)
|
- | 1007 |
+ 656 |
! |
- computation()[["tbl_eigenvector"]]
+ without_facet <- (is.null(nulled_row_facet_name) && is.null(nulled_col_facet_name)) || !facetting
|
- | 1008 |
+ 657 |
|
- },
+
|
- | 1009 |
+ 658 |
! |
- bordered = TRUE,
+ print_call <- if (without_facet) {
|
- | 1010 |
+ 659 |
! |
- align = "c",
+ quote(print(p))
+ |
+
+
+ | 660 |
+ |
+
+ } else {
|
- | 1011 |
+ 661 |
! |
- digits = 3
+ substitute(
+ |
+
+
+ | 662 |
+ ! |
+
+ expr = {
|
- | 1012 |
+ 663 |
|
- )
+ # Add facetting labels
|
- | 1013 |
+ 664 |
|
-
+ # optional: grid.newpage() # nolint: commented_code.
+ |
+
+
+ | 665 |
+ |
+
+ # Prefixed with teal.modules.general as its usage will appear in "Show R code"
|
- | 1014 |
+ 666 |
! |
- output$tbl_eigenvector_ui <- renderUI({
+ p <- teal.modules.general::add_facet_labels(
|
- | 1015 |
+ 667 |
! |
- req("eigenvector" %in% input$tables_display)
+ p,
|
- | 1016 |
+ 668 |
! |
- tags$div(
+ xfacet_label = nulled_col_facet_name,
|
- | 1017 |
+ 669 |
! |
- align = "center",
+ yfacet_label = nulled_row_facet_name
+ |
+
+
+ | 670 |
+ |
+
+ )
|
- | 1018 |
+ 671 |
! |
- tags$h4("Eigenvectors"),
+ grid::grid.newpage()
|
- | 1019 |
+ 672 |
! |
- tableOutput(session$ns("tbl_eigenvector")),
+ grid::grid.draw(p)
+ |
+
+
+ | 673 |
+ |
+
+ },
|
- | 1020 |
+ 674 |
! |
- tags$hr()
+ env = list(nulled_col_facet_name = nulled_col_facet_name, nulled_row_facet_name = nulled_row_facet_name)
|
- | 1021 |
+ 675 |
|
- )
+ )
|
- | 1022 |
+ 676 |
|
- })
+ }
|
- | 1023 |
+ 677 |
|
|
- | 1024 |
+ 678 |
! |
- output$all_plots <- renderUI({
+ teal.code::eval_code(merged$anl_q_r(), substitute(expr = p <- cl, env = list(cl = cl))) %>%
|
- | 1025 |
+ 679 |
! |
- teal::validate_inputs(iv_r())
+ teal.code::eval_code(print_call)
|
-
- | 1026 |
- ! |
+
+ | 680 |
+ |
- teal::validate_inputs(iv_extra, header = "Plot settings are required")
+ })
|
- | 1027 |
+ 681 |
|
|
- | 1028 |
+ 682 |
! |
- validation()
+ plot_r <- reactive({
|
- | 1029 |
+ 683 |
! |
- tags$div(
+ output_q()[["p"]]
+ |
+
+
+ | 684 |
+ |
+
+ })
+ |
+
+
+ | 685 |
+ |
+
+
|
- | 1030 |
+ 686 |
! |
- class = "overflow-scroll",
+ pws <- teal.widgets::plot_with_settings_srv(
|
- | 1031 |
+ 687 |
! |
- uiOutput(session$ns("tbl_importance_ui")),
+ id = "myplot",
|
- | 1032 |
+ 688 |
! |
- uiOutput(session$ns("tbl_eigenvector_ui")),
+ plot_r = plot_r,
|
- | 1033 |
+ 689 |
! |
- teal.widgets::plot_with_settings_ui(id = session$ns("pca_plot"))
+ height = plot_height,
|
-
- | 1034 |
- |
+
+ | 690 |
+ ! |
- )
+ width = plot_width
|
- | 1035 |
+ 691 |
|
- })
+ )
|
- | 1036 |
+ 692 |
|
|
- | 1037 |
+ 693 |
! |
teal.widgets::verbatim_popup_srv(
|
- | 1038 |
+ 694 |
! |
id = "rcode",
|
- | 1039 |
+ 695 |
! |
verbatim_content = reactive(teal.code::get_code(output_q())),
|
- | 1040 |
+ 696 |
! |
- title = "R Code for PCA"
+ title = "Bivariate Plot"
|
- | 1041 |
+ 697 |
|
)
|
- | 1042 |
+ 698 |
|
|
- | 1043 |
+ 699 |
|
### REPORTER
|
- | 1044 |
+ 700 |
! |
if (with_reporter) {
|
- | 1045 |
+ 701 |
! |
card_fun <- function(comment, label) {
|
- | 1046 |
+ 702 |
! |
card <- teal::report_card_template(
|
- | 1047 |
+ 703 |
! |
- title = "Principal Component Analysis Plot",
+ title = "Bivariate Plot",
|
- | 1048 |
+ 704 |
! |
label = label,
|
- | 1049 |
+ 705 |
! |
with_filter = with_filter,
|
- | 1050 |
+ 706 |
! |
filter_panel_api = filter_panel_api
|
- | 1051 |
+ 707 |
|
)
|
- | 1052 |
- ! |
-
- card$append_text("Principal Components Table", "header3")
- |
-
-
- | 1053 |
- ! |
-
- card$append_table(computation()[["tbl_importance"]])
- |
-
-
- | 1054 |
- ! |
-
- card$append_text("Eigenvectors Table", "header3")
- |
-
-
- | 1055 |
- ! |
-
- card$append_table(computation()[["tbl_eigenvector"]])
- |
-
-
- | 1056 |
+ 708 |
! |
card$append_text("Plot", "header3")
|
- | 1057 |
+ 709 |
! |
card$append_plot(plot_r(), dim = pws$dim())
|
- | 1058 |
+ 710 |
! |
if (!comment == "") {
|
- | 1059 |
+ 711 |
! |
card$append_text("Comment", "header3")
|
- | 1060 |
+ 712 |
! |
card$append_text(comment)
|
- | 1061 |
+ 713 |
|
}
|
- | 1062 |
+ 714 |
! |
card$append_src(teal.code::get_code(output_q()))
|
- | 1063 |
+ 715 |
! |
card
|
- | 1064 |
+ 716 |
|
}
|
- | 1065 |
+ 717 |
! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
- | 1066 |
+ 718 |
|
}
|
- | 1067 |
+ 719 |
|
###
|
- | 1068 |
+ 720 |
|
})
|
- | 1069 |
+ 721 |
|
}
|
-
-
-
-
-
-
- | 1 |
+ 722 |
|
- #' `teal` module: Data table viewer
+
|
- | 2 |
+ 723 |
|
- #'
+ # Get Substituted ggplot call
|
- | 3 |
+ 724 |
|
- #' Module provides a dynamic and interactive way to view `data.frame`s in a `teal` application.
+ bivariate_plot_call <- function(data_name,
|
- | 4 |
+ 725 |
|
- #' It uses the `DT` package to display data tables in a paginated, searchable, and sortable format,
+ x = character(0),
|
- | 5 |
+ 726 |
|
- #' which helps to enhance data exploration and analysis.
+ y = character(0),
|
- | 6 |
+ 727 |
|
- #'
+ x_class = "NULL",
|
- | 7 |
+ 728 |
|
- #' The `DT` package has an option `DT.TOJSON_ARGS` to show `Inf` and `NA` in data tables.
+ y_class = "NULL",
|
- | 8 |
+ 729 |
|
- #' Configure the `DT.TOJSON_ARGS` option via
+ x_label = NULL,
|
- | 9 |
+ 730 |
|
- #' `options(DT.TOJSON_ARGS = list(na = "string"))` before running the module.
+ y_label = NULL,
|
- | 10 |
+ 731 |
|
- #' Note though that sorting of numeric columns with `NA`/`Inf` will be lexicographic not numerical.
+ freq = TRUE,
|
- | 11 |
+ 732 |
|
- #'
+ theme = "gray",
|
- | 12 |
+ 733 |
|
- #' @inheritParams teal::module
+ rotate_xaxis_labels = FALSE,
|
- | 13 |
+ 734 |
|
- #' @inheritParams shared_params
+ swap_axes = FALSE,
|
- | 14 |
+ 735 |
|
- #' @param variables_selected (`named list`) Character vectors of the variables (i.e. columns)
+ alpha = double(0),
|
- | 15 |
+ 736 |
|
- #' which should be initially shown for each dataset.
+ size = 2,
|
- | 16 |
+ 737 |
|
- #' Names of list elements should correspond to the names of the datasets available in the app.
+ ggplot2_args = teal.widgets::ggplot2_args()) {
|
-
- | 17 |
- |
+
+ | 738 |
+ ! |
- #' If no entry is specified for a dataset, the first six variables from that
+ supported_types <- c("NULL", "numeric", "integer", "factor", "character", "logical", "ordered")
|
-
- | 18 |
- |
+
+ | 739 |
+ ! |
- #' dataset will initially be shown.
+ validate(need(x_class %in% supported_types, paste0("Data type '", x_class, "' is not supported.")))
|
-
- | 19 |
- |
+
+ | 740 |
+ ! |
- #' @param datasets_selected (`character`) A vector of datasets which should be
+ validate(need(y_class %in% supported_types, paste0("Data type '", y_class, "' is not supported.")))
|
- | 20 |
+ 741 |
|
- #' shown and in what order. Names in the vector have to correspond with datasets names.
+
|
- | 21 |
+ 742 |
|
- #' If vector of `length == 0` (default) then all datasets are shown.
+
|
-
- | 22 |
- |
+
+ | 743 |
+ ! |
- #' Note: Only datasets of the `data.frame` class are compatible.
+ if (identical(x, character(0))) {
|
-
- | 23 |
- |
+
+ | 744 |
+ ! |
- #' @param dt_args (`named list`) Additional arguments to be passed to [DT::datatable()]
+ x <- x_label <- "-"
|
- | 24 |
+ 745 |
|
- #' (must not include `data` or `options`).
+ } else {
|
-
- | 25 |
- |
+
+ | 746 |
+ ! |
- #' @param dt_options (`named list`) The `options` argument to `DT::datatable`. By default
+ x <- if (is.call(x)) x else as.name(x)
|
- | 26 |
+ 747 |
|
- #' `list(searching = FALSE, pageLength = 30, lengthMenu = c(5, 15, 30, 100), scrollX = TRUE)`
+ }
|
-
- | 27 |
- |
+
+ | 748 |
+ ! |
- #' @param server_rendering (`logical`) should the data table be rendered server side
+ if (identical(y, character(0))) {
|
-
- | 28 |
- |
+
+ | 749 |
+ ! |
- #' (see `server` argument of [DT::renderDataTable()])
+ y <- y_label <- "-"
|
- | 29 |
+ 750 |
|
- #'
+ } else {
|
-
- | 30 |
- |
+
+ | 751 |
+ ! |
- #' @inherit shared_params return
+ y <- if (is.call(y)) y else as.name(y)
|
- | 31 |
+ 752 |
|
- #'
+ }
|
- | 32 |
+ 753 |
|
- #' @examples
+
|
-
- | 33 |
- |
+
+ | 754 |
+ ! |
- #' # general data example
+ cl <- bivariate_ggplot_call(
|
-
- | 34 |
- |
+
+ | 755 |
+ ! |
- #' data <- teal_data()
+ x_class = x_class,
|
-
- | 35 |
- |
+
+ | 756 |
+ ! |
- #' data <- within(data, {
+ y_class = y_class,
|
-
- | 36 |
- |
+
+ | 757 |
+ ! |
- #' require(nestcolor)
+ freq = freq,
|
-
- | 37 |
- |
+
+ | 758 |
+ ! |
- #' iris <- iris
+ theme = theme,
|
-
- | 38 |
- |
+
+ | 759 |
+ ! |
- #' })
+ rotate_xaxis_labels = rotate_xaxis_labels,
|
-
- | 39 |
- |
+
+ | 760 |
+ ! |
- #' datanames(data) <- c("iris")
+ swap_axes = swap_axes,
|
-
- | 40 |
- |
+
+ | 761 |
+ ! |
- #'
+ alpha = alpha,
+ |
+
+
+ | 762 |
+ ! |
+
+ size = size,
+ |
+
+
+ | 763 |
+ ! |
+
+ ggplot2_args = ggplot2_args,
+ |
+
+
+ | 764 |
+ ! |
+
+ x = x,
+ |
+
+
+ | 765 |
+ ! |
+
+ y = y,
+ |
+
+
+ | 766 |
+ ! |
+
+ xlab = x_label,
+ |
+
+
+ | 767 |
+ ! |
+
+ ylab = y_label,
+ |
+
+
+ | 768 |
+ ! |
+
+ data_name = data_name
|
- | 41 |
+ 769 |
|
- #' app <- init(
+ )
|
- | 42 |
+ 770 |
|
- #' data = data,
+ }
|
- | 43 |
+ 771 |
|
- #' modules = modules(
+
|
- | 44 |
+ 772 |
|
- #' tm_data_table(
+ # Create ggplot part of plot call
|
- | 45 |
+ 773 |
|
- #' variables_selected = list(
+ # Due to the type of the x and y variable the plot type is chosen
|
- | 46 |
+ 774 |
|
- #' iris = c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width", "Species")
+ bivariate_ggplot_call <- function(x_class,
|
- | 47 |
+ 775 |
|
- #' ),
+ y_class,
|
- | 48 |
+ 776 |
|
- #' dt_args = list(caption = "IRIS Table Caption")
+ freq = TRUE,
|
- | 49 |
+ 777 |
|
- #' )
+ theme = "gray",
|
- | 50 |
+ 778 |
|
- #' )
+ rotate_xaxis_labels = FALSE,
|
- | 51 |
+ 779 |
|
- #' )
+ swap_axes = FALSE,
|
- | 52 |
+ 780 |
|
- #' if (interactive()) {
+ size = double(0),
|
- | 53 |
+ 781 |
|
- #' shinyApp(app$ui, app$server)
+ alpha = double(0),
|
- | 54 |
+ 782 |
|
- #' }
+ x = NULL,
|
- | 55 |
+ 783 |
|
- #'
+ y = NULL,
|
- | 56 |
+ 784 |
|
- #' # CDISC data example
+ xlab = "-",
|
- | 57 |
+ 785 |
|
- #' data <- teal_data()
+ ylab = "-",
|
- | 58 |
+ 786 |
|
- #' data <- within(data, {
+ data_name = "ANL",
|
- | 59 |
+ 787 |
|
- #' require(nestcolor)
+ ggplot2_args = teal.widgets::ggplot2_args()) {
+ |
+
+
+ | 788 |
+ 42x |
+
+ x_class <- switch(x_class,
+ |
+
+
+ | 789 |
+ 42x |
+
+ "character" = ,
+ |
+
+
+ | 790 |
+ 42x |
+
+ "ordered" = ,
+ |
+
+
+ | 791 |
+ 42x |
+
+ "logical" = ,
+ |
+
+
+ | 792 |
+ 42x |
+
+ "factor" = "factor",
+ |
+
+
+ | 793 |
+ 42x |
+
+ "integer" = ,
+ |
+
+
+ | 794 |
+ 42x |
+
+ "numeric" = "numeric",
+ |
+
+
+ | 795 |
+ 42x |
+
+ "NULL" = "NULL",
+ |
+
+
+ | 796 |
+ 42x |
+
+ stop("unsupported x_class: ", x_class)
|
- | 60 |
+ 797 |
|
- #' ADSL <- rADSL
+ )
+ |
+
+
+ | 798 |
+ 42x |
+
+ y_class <- switch(y_class,
+ |
+
+
+ | 799 |
+ 42x |
+
+ "character" = ,
+ |
+
+
+ | 800 |
+ 42x |
+
+ "ordered" = ,
+ |
+
+
+ | 801 |
+ 42x |
+
+ "logical" = ,
+ |
+
+
+ | 802 |
+ 42x |
+
+ "factor" = "factor",
+ |
+
+
+ | 803 |
+ 42x |
+
+ "integer" = ,
+ |
+
+
+ | 804 |
+ 42x |
+
+ "numeric" = "numeric",
+ |
+
+
+ | 805 |
+ 42x |
+
+ "NULL" = "NULL",
+ |
+
+
+ | 806 |
+ 42x |
+
+ stop("unsupported y_class: ", y_class)
|
- | 61 |
+ 807 |
|
- #' })
+ )
|
- | 62 |
+ 808 |
|
- #' datanames(data) <- "ADSL"
+
|
-
- | 63 |
- |
+
+ | 809 |
+ 42x |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
+ if (all(c(x_class, y_class) == "NULL")) {
|
-
- | 64 |
- |
+
+ | 810 |
+ ! |
- #'
+ stop("either x or y is required")
|
- | 65 |
+ 811 |
|
- #' app <- init(
+ }
|
- | 66 |
+ 812 |
|
- #' data = data,
+
|
-
- | 67 |
- |
+
+ | 813 |
+ 42x |
- #' modules = modules(
+ reduce_plot_call <- function(...) {
|
-
- | 68 |
- |
+
+ | 814 |
+ 104x |
- #' tm_data_table(
+ args <- Filter(Negate(is.null), list(...))
|
-
- | 69 |
- |
+
+ | 815 |
+ 104x |
- #' variables_selected = list(ADSL = c("STUDYID", "USUBJID", "SUBJID", "SITEID", "AGE", "SEX")),
+ Reduce(function(x, y) call("+", x, y), args)
|
- | 70 |
+ 816 |
|
- #' dt_args = list(caption = "ADSL Table Caption")
+ }
|
- | 71 |
+ 817 |
|
- #' )
+
|
-
- | 72 |
- |
+
+ | 818 |
+ 42x |
- #' )
+ plot_call <- substitute(ggplot(data_name), env = list(data_name = as.name(data_name)))
|
- | 73 |
+ 819 |
|
- #' )
+
|
- | 74 |
+ 820 |
|
- #' if (interactive()) {
+ # Single data plots
|
-
- | 75 |
- |
+
+ | 821 |
+ 42x |
- #' shinyApp(app$ui, app$server)
+ if (x_class == "numeric" && y_class == "NULL") {
|
-
- | 76 |
- |
+
+ | 822 |
+ 6x |
- #' }
+ plot_call <- reduce_plot_call(plot_call, substitute(aes(x = xval), env = list(xval = x)))
|
- | 77 |
+ 823 |
|
- #'
+
|
-
- | 78 |
- |
+
+ | 824 |
+ 6x |
- #' @export
+ if (freq) {
|
-
- | 79 |
- |
+
+ | 825 |
+ 4x |
- #'
+ plot_call <- reduce_plot_call(
|
-
- | 80 |
- |
+
+ | 826 |
+ 4x |
- tm_data_table <- function(label = "Data Table",
+ plot_call,
|
-
- | 81 |
- |
+
+ | 827 |
+ 4x |
- variables_selected = list(),
+ quote(geom_histogram(bins = 30)),
|
-
- | 82 |
- |
+
+ | 828 |
+ 4x |
- datasets_selected = character(0),
+ quote(ylab("Frequency"))
|
- | 83 |
+ 829 |
|
- dt_args = list(),
+ )
|
- | 84 |
+ 830 |
|
- dt_options = list(
+ } else {
|
-
- | 85 |
- |
+
+ | 831 |
+ 2x |
- searching = FALSE,
+ plot_call <- reduce_plot_call(
|
-
- | 86 |
- |
+
+ | 832 |
+ 2x |
- pageLength = 30,
+ plot_call,
|
-
- | 87 |
- |
+
+ | 833 |
+ 2x |
- lengthMenu = c(5, 15, 30, 100),
+ quote(geom_histogram(bins = 30, aes(y = after_stat(density)))),
|
-
- | 88 |
- |
+
+ | 834 |
+ 2x |
- scrollX = TRUE
+ quote(geom_density(aes(y = after_stat(density)))),
|
-
- | 89 |
- |
+
+ | 835 |
+ 2x |
- ),
+ quote(ylab("Density"))
|
- | 90 |
+ 836 |
|
- server_rendering = FALSE,
+ )
|
- | 91 |
+ 837 |
|
- pre_output = NULL,
+ }
|
-
- | 92 |
- |
+
+ | 838 |
+ 36x |
- post_output = NULL) {
+ } else if (x_class == "NULL" && y_class == "numeric") {
|
-
- | 93 |
- ! |
+
+ | 839 |
+ 6x |
- message("Initializing tm_data_table")
+ plot_call <- reduce_plot_call(plot_call, substitute(aes(x = yval), env = list(yval = y)))
|
- | 94 |
+ 840 |
|
|
-
- | 95 |
- |
+
+ | 841 |
+ 6x |
- # Start of assertions
+ if (freq) {
|
-
- | 96 |
- ! |
+
+ | 842 |
+ 4x |
- checkmate::assert_string(label)
+ plot_call <- reduce_plot_call(
|
-
- | 97 |
- |
+
+ | 843 |
+ 4x |
-
+ plot_call,
|
-
- | 98 |
- ! |
+
+ | 844 |
+ 4x |
- checkmate::assert_list(variables_selected, min.len = 0, types = "character", names = "named")
+ quote(geom_histogram(bins = 30)),
|
-
- | 99 |
- ! |
+
+ | 845 |
+ 4x |
- if (length(variables_selected) > 0) {
+ quote(ylab("Frequency"))
|
-
- | 100 |
- ! |
+
+ | 846 |
+ |
- lapply(seq_along(variables_selected), function(i) {
+ )
|
-
- | 101 |
- ! |
+
+ | 847 |
+ |
- checkmate::assert_character(variables_selected[[i]], min.chars = 1, min.len = 1)
+ } else {
|
-
- | 102 |
- ! |
+
+ | 848 |
+ 2x |
- if (!is.null(names(variables_selected[[i]]))) {
+ plot_call <- reduce_plot_call(
|
-
- | 103 |
- ! |
+
+ | 849 |
+ 2x |
- checkmate::assert_names(names(variables_selected[[i]]))
+ plot_call,
|
-
- | 104 |
- |
+
+ | 850 |
+ 2x |
- }
+ quote(geom_histogram(bins = 30, aes(y = after_stat(density)))),
|
-
- | 105 |
- |
+
+ | 851 |
+ 2x |
- })
+ quote(geom_density(aes(y = after_stat(density)))),
|
-
- | 106 |
- |
+
+ | 852 |
+ 2x |
- }
+ quote(ylab("Density"))
|
- | 107 |
+ 853 |
|
-
- |
-
-
- | 108 |
- ! |
-
- checkmate::assert_character(datasets_selected, min.len = 0, min.chars = 1)
+ )
|
-
- | 109 |
- ! |
+
+ | 854 |
+ |
- checkmate::assert(
+ }
|
-
- | 110 |
- ! |
+
+ | 855 |
+ 30x |
- checkmate::check_list(dt_args, len = 0),
+ } else if (x_class == "factor" && y_class == "NULL") {
|
-
- | 111 |
- ! |
+
+ | 856 |
+ 4x |
- checkmate::check_subset(names(dt_args), choices = names(formals(DT::datatable)))
+ plot_call <- reduce_plot_call(plot_call, substitute(aes(x = xval), env = list(xval = x)))
|
- | 112 |
+ 857 |
|
- )
+
|
-
- | 113 |
- ! |
+
+ | 858 |
+ 4x |
- checkmate::assert_list(dt_options, names = "named")
+ if (freq) {
|
-
- | 114 |
- ! |
+
+ | 859 |
+ 2x |
- checkmate::assert_flag(server_rendering)
+ plot_call <- reduce_plot_call(
|
-
- | 115 |
- ! |
+
+ | 860 |
+ 2x |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ plot_call,
|
-
- | 116 |
- ! |
+
+ | 861 |
+ 2x |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ quote(geom_bar()),
|
-
- | 117 |
- |
+
+ | 862 |
+ 2x |
- # End of assertions
+ quote(ylab("Frequency"))
|
- | 118 |
+ 863 |
|
-
+ )
|
-
- | 119 |
- ! |
+
+ | 864 |
+ |
- ans <- module(
+ } else {
|
-
- | 120 |
- ! |
+
+ | 865 |
+ 2x |
- label,
+ plot_call <- reduce_plot_call(
|
-
- | 121 |
- ! |
+
+ | 866 |
+ 2x |
- server = srv_page_data_table,
+ plot_call,
|
-
- | 122 |
- ! |
+
+ | 867 |
+ 2x |
- ui = ui_page_data_table,
+ quote(geom_bar(aes(y = after_stat(prop), group = 1))),
|
-
- | 123 |
- ! |
+
+ | 868 |
+ 2x |
- datanames = if (length(datasets_selected) == 0) "all" else datasets_selected,
+ quote(ylab("Fraction"))
|
-
- | 124 |
- ! |
+
+ | 869 |
+ |
- server_args = list(
+ )
|
-
- | 125 |
- ! |
+
+ | 870 |
+ |
- variables_selected = variables_selected,
+ }
|
-
- | 126 |
- ! |
+
+ | 871 |
+ 26x |
- datasets_selected = datasets_selected,
+ } else if (x_class == "NULL" && y_class == "factor") {
|
-
- | 127 |
- ! |
+
+ | 872 |
+ 4x |
- dt_args = dt_args,
+ plot_call <- reduce_plot_call(plot_call, substitute(aes(x = yval), env = list(yval = y)))
|
-
- | 128 |
- ! |
+
+ | 873 |
+ |
- dt_options = dt_options,
+
|
-
- | 129 |
- ! |
+
+ | 874 |
+ 4x |
- server_rendering = server_rendering
+ if (freq) {
|
-
- | 130 |
- |
+
+ | 875 |
+ 2x |
- ),
+ plot_call <- reduce_plot_call(
|
-
- | 131 |
- ! |
+
+ | 876 |
+ 2x |
- ui_args = list(
+ plot_call,
|
-
- | 132 |
- ! |
+
+ | 877 |
+ 2x |
- pre_output = pre_output,
+ quote(geom_bar()),
|
-
- | 133 |
- ! |
+
+ | 878 |
+ 2x |
- post_output = post_output
+ quote(ylab("Frequency"))
|
- | 134 |
+ 879 |
|
- )
+ )
|
- | 135 |
+ 880 |
|
- )
+ } else {
|
-
- | 136 |
- ! |
+
+ | 881 |
+ 2x |
- attr(ans, "teal_bookmarkable") <- TRUE
+ plot_call <- reduce_plot_call(
|
-
- | 137 |
- ! |
+
+ | 882 |
+ 2x |
- ans
+ plot_call,
|
-
- | 138 |
- |
+
+ | 883 |
+ 2x |
- }
+ quote(geom_bar(aes(y = after_stat(prop), group = 1))),
|
-
- | 139 |
- |
+
+ | 884 |
+ 2x |
-
+ quote(ylab("Fraction"))
|
- | 140 |
+ 885 |
|
- # UI page module
+ )
|
- | 141 |
+ 886 |
|
- ui_page_data_table <- function(id,
+ }
|
- | 142 |
+ 887 |
|
- pre_output = NULL,
+ # Numeric Plots
|
-
- | 143 |
- |
+
+ | 888 |
+ 22x |
- post_output = NULL) {
+ } else if (x_class == "numeric" && y_class == "numeric") {
|
-
- | 144 |
- ! |
+
+ | 889 |
+ 2x |
- ns <- NS(id)
+ plot_call <- reduce_plot_call(
|
-
- | 145 |
- |
+
+ | 890 |
+ 2x |
-
+ plot_call,
|
-
- | 146 |
- ! |
+
+ | 891 |
+ 2x |
- tagList(
+ substitute(aes(x = xval, y = yval), env = list(xval = x, yval = y)),
|
-
- | 147 |
- ! |
+
+ | 892 |
+ |
- include_css_files("custom"),
+ # pch = 21 for consistent coloring behaviour b/w all geoms (outline and fill properties)
|
-
- | 148 |
- ! |
+
+ | 893 |
+ 2x |
- teal.widgets::standard_layout(
+ `if`(
|
-
- | 149 |
- ! |
+
+ | 894 |
+ 2x |
- output = teal.widgets::white_small_well(
+ !is.null(size),
|
-
- | 150 |
- ! |
+
+ | 895 |
+ 2x |
- fluidRow(
+ substitute(
|
-
- | 151 |
- ! |
+
+ | 896 |
+ 2x |
- column(
+ geom_point(alpha = alphaval, size = sizeval, pch = 21),
|
-
- | 152 |
- ! |
+
+ | 897 |
+ 2x |
- width = 12,
+ env = list(alphaval = alpha, sizeval = size)
|
-
- | 153 |
- ! |
+
+ | 898 |
+ |
- checkboxInput(
+ ),
|
-
- | 154 |
- ! |
+
+ | 899 |
+ 2x |
- ns("if_distinct"),
+ substitute(
|
-
- | 155 |
- ! |
+
+ | 900 |
+ 2x |
- "Show only distinct rows:",
+ geom_point(alpha = alphaval, pch = 21),
|
-
- | 156 |
- ! |
+
+ | 901 |
+ 2x |
- value = FALSE
+ env = list(alphaval = alpha)
|
- | 157 |
+ 902 |
|
- )
+ )
|
- | 158 |
+ 903 |
|
- )
+ )
|
- | 159 |
+ 904 |
|
- ),
+ )
|
-
- | 160 |
- ! |
+
+ | 905 |
+ 20x |
- fluidRow(
+ } else if ((x_class == "numeric" && y_class == "factor") || (x_class == "factor" && y_class == "numeric")) {
|
-
- | 161 |
- ! |
+
+ | 906 |
+ 6x |
- class = "mb-8",
+ plot_call <- reduce_plot_call(
|
-
- | 162 |
- ! |
+
+ | 907 |
+ 6x |
- column(
+ plot_call,
|
-
- | 163 |
- ! |
+
+ | 908 |
+ 6x |
- width = 12,
+ substitute(aes(x = xval, y = yval), env = list(xval = x, yval = y)),
|
-
- | 164 |
- ! |
+
+ | 909 |
+ 6x |
- uiOutput(ns("dataset_table"))
+ quote(geom_boxplot())
|
- | 165 |
+ 910 |
|
- )
+ )
|
- | 166 |
+ 911 |
|
- )
+ # Factor and character plots
|
-
- | 167 |
- |
+
+ | 912 |
+ 14x |
- ),
+ } else if (x_class == "factor" && y_class == "factor") {
|
-
- | 168 |
- ! |
+
+ | 913 |
+ 14x |
- pre_output = pre_output,
+ plot_call <- reduce_plot_call(
|
-
- | 169 |
- ! |
+
+ | 914 |
+ 14x |
- post_output = post_output
+ plot_call,
|
-
- | 170 |
- |
+
+ | 915 |
+ 14x |
- )
+ substitute(
|
-
- | 171 |
- |
+
+ | 916 |
+ 14x |
- )
+ ggmosaic::geom_mosaic(aes(x = ggmosaic::product(xval), fill = yval), na.rm = TRUE),
|
-
- | 172 |
- |
+
+ | 917 |
+ 14x |
- }
+ env = list(xval = x, yval = y)
|
- | 173 |
+ 918 |
|
-
+ )
|
- | 174 |
+ 919 |
|
- # Server page module
+ )
|
- | 175 |
+ 920 |
|
- srv_page_data_table <- function(id,
+ } else {
|
-
- | 176 |
- |
+
+ | 921 |
+ ! |
- data,
+ stop("x y type combination not allowed")
|
- | 177 |
+ 922 |
|
- datasets_selected,
+ }
|
- | 178 |
+ 923 |
|
- variables_selected,
+
|
-
- | 179 |
- |
+
+ | 924 |
+ 42x |
- dt_args,
+ labs_base <- if (x_class == "NULL") {
|
-
- | 180 |
- |
+
+ | 925 |
+ 10x |
- dt_options,
+ list(x = substitute(ylab, list(ylab = ylab)))
|
-
- | 181 |
- |
+
+ | 926 |
+ 42x |
- server_rendering) {
+ } else if (y_class == "NULL") {
|
-
- | 182 |
- ! |
+
+ | 927 |
+ 10x |
- checkmate::assert_class(data, "reactive")
+ list(x = substitute(xlab, list(xlab = xlab)))
|
-
- | 183 |
- ! |
+
+ | 928 |
+ |
- checkmate::assert_class(isolate(data()), "teal_data")
+ } else {
|
-
- | 184 |
- ! |
+
+ | 929 |
+ 22x |
- moduleServer(id, function(input, output, session) {
+ list(
|
-
- | 185 |
- ! |
+
+ | 930 |
+ 22x |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
+ x = substitute(xlab, list(xlab = xlab)),
|
-
- | 186 |
- |
+
+ | 931 |
+ 22x |
-
+ y = substitute(ylab, list(ylab = ylab))
|
-
- | 187 |
- ! |
+
+ | 932 |
+ |
- if_filtered <- reactive(as.logical(input$if_filtered))
+ )
|
-
- | 188 |
- ! |
+
+ | 933 |
+ |
- if_distinct <- reactive(as.logical(input$if_distinct))
+ }
|
- | 189 |
+ 934 |
|
|
-
- | 190 |
- ! |
-
- datanames <- isolate(teal.data::datanames(data()))
- |
-
-
- | 191 |
- ! |
-
- datanames <- Filter(function(name) {
- |
-
-
- | 192 |
- ! |
-
- is.data.frame(isolate(data())[[name]])
- |
-
-
- | 193 |
- ! |
+
+ | 935 |
+ 42x |
- }, datanames)
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(labs = labs_base)
|
- | 194 |
+ 936 |
|
|
-
- | 195 |
- ! |
-
- if (!identical(datasets_selected, character(0))) {
- |
-
-
- | 196 |
- ! |
+
+ | 937 |
+ 42x |
- checkmate::assert_subset(datasets_selected, datanames)
+ if (rotate_xaxis_labels) {
|
- | 197 |
+ 938 |
! |
- datanames <- datasets_selected
+ dev_ggplot2_args$theme <- list(axis.text.x = quote(element_text(angle = 45, hjust = 1)))
|
- | 198 |
+ 939 |
|
- }
+ }
|
- | 199 |
+ 940 |
|
|
-
- | 200 |
- ! |
-
- output$dataset_table <- renderUI({
- |
-
-
- | 201 |
- ! |
-
- do.call(
- |
-
-
- | 202 |
- ! |
+
+ | 941 |
+ 42x |
- tabsetPanel,
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
|
-
- | 203 |
- ! |
+
+ | 942 |
+ 42x |
- c(
+ user_plot = ggplot2_args,
|
-
- | 204 |
- ! |
+
+ | 943 |
+ 42x |
- list(id = session$ns("dataname_tab")),
+ module_plot = dev_ggplot2_args
|
-
- | 205 |
- ! |
+
+ | 944 |
+ |
- lapply(
+ )
|
-
- | 206 |
- ! |
+
+ | 945 |
+ |
- datanames,
+
|
-
- | 207 |
- ! |
+
+ | 946 |
+ 42x |
- function(x) {
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = theme)
|
-
- | 208 |
- ! |
+
+ | 947 |
+ |
- dataset <- isolate(data()[[x]])
+
|
-
- | 209 |
- ! |
+
+ | 948 |
+ 42x |
- choices <- names(dataset)
+ plot_call <- reduce_plot_call(
|
-
- | 210 |
- ! |
+
+ | 949 |
+ 42x |
- labels <- vapply(
+ plot_call,
|
-
- | 211 |
- ! |
+
+ | 950 |
+ 42x |
- dataset,
+ parsed_ggplot2_args$labs,
|
-
- | 212 |
- ! |
+
+ | 951 |
+ 42x |
- function(x) ifelse(is.null(attr(x, "label")), "", attr(x, "label")),
+ parsed_ggplot2_args$ggtheme,
|
-
- | 213 |
- ! |
+
+ | 952 |
+ 42x |
- character(1)
+ parsed_ggplot2_args$theme
|
- | 214 |
+ 953 |
|
- )
- |
-
-
- | 215 |
- ! |
-
- names(choices) <- ifelse(
+ )
|
-
- | 216 |
- ! |
+
+ | 954 |
+ |
- is.na(labels) | labels == "",
+
|
-
- | 217 |
- ! |
+
+ | 955 |
+ 42x |
- choices,
+ if (swap_axes) {
|
- | 218 |
+ 956 |
! |
- paste(choices, labels, sep = ": ")
+ plot_call <- reduce_plot_call(plot_call, quote(coord_flip()))
|
- | 219 |
+ 957 |
|
- )
+ }
|
-
- | 220 |
- ! |
+
+ | 958 |
+ |
- variables_selected <- if (!is.null(variables_selected[[x]])) {
+
|
-
- | 221 |
- ! |
+
+ | 959 |
+ 42x |
- variables_selected[[x]]
+ plot_call
|
- | 222 |
+ 960 |
|
- } else {
+ }
|
-
- | 223 |
- ! |
+
+ | 961 |
+ |
- utils::head(choices)
+
|
- | 224 |
+ 962 |
|
- }
+ # Create facet call
|
-
- | 225 |
- ! |
+
+ | 963 |
+ |
- tabPanel(
+ facet_ggplot_call <- function(row_facet = character(0),
|
-
- | 226 |
- ! |
+
+ | 964 |
+ |
- title = x,
+ col_facet = character(0),
|
-
- | 227 |
- ! |
+
+ | 965 |
+ |
- column(
+ free_x_scales = FALSE,
|
-
- | 228 |
- ! |
+
+ | 966 |
+ |
- width = 12,
+ free_y_scales = FALSE) {
|
- | 229 |
+ 967 |
! |
- div(
+ scales <- if (free_x_scales && free_y_scales) {
|
- | 230 |
+ 968 |
! |
- class = "mt-4",
+ "free"
|
- | 231 |
+ 969 |
! |
- ui_data_table(
+ } else if (free_x_scales) {
|
- | 232 |
+ 970 |
! |
- id = session$ns(x),
+ "free_x"
|
- | 233 |
+ 971 |
! |
- choices = choices,
+ } else if (free_y_scales) {
|
- | 234 |
+ 972 |
! |
- selected = variables_selected
- |
-
-
- | 235 |
- |
-
- )
- |
-
-
- | 236 |
- |
-
- )
- |
-
-
- | 237 |
- |
-
- )
- |
-
-
- | 238 |
- |
-
- )
- |
-
-
- | 239 |
- |
-
- }
- |
-
-
- | 240 |
- |
-
- )
+ "free_y"
|
- | 241 |
+ 973 |
|
- )
+ } else {
|
-
- | 242 |
- |
+
+ | 974 |
+ ! |
- )
+ "fixed"
|
- | 243 |
+ 975 |
|
- })
+ }
|
- | 244 |
+ 976 |
|
|
- | 245 |
+ 977 |
! |
- lapply(
+ if (identical(row_facet, character(0)) && identical(col_facet, character(0))) {
|
- | 246 |
+ 978 |
! |
- datanames,
+ NULL
|
- | 247 |
+ 979 |
! |
- function(x) {
+ } else if (!identical(row_facet, character(0)) && !identical(col_facet, character(0))) {
|
- | 248 |
+ 980 |
! |
- srv_data_table(
+ call(
|
- | 249 |
+ 981 |
! |
- id = x,
+ "facet_grid",
|
- | 250 |
+ 982 |
! |
- data = data,
+ rows = call_fun_dots("vars", row_facet),
|
- | 251 |
+ 983 |
! |
- dataname = x,
+ cols = call_fun_dots("vars", col_facet),
|
- | 252 |
+ 984 |
! |
- if_filtered = if_filtered,
+ scales = scales
+ |
+
+
+ | 985 |
+ |
+
+ )
|
- | 253 |
+ 986 |
! |
- if_distinct = if_distinct,
+ } else if (identical(row_facet, character(0)) && !identical(col_facet, character(0))) {
|
- | 254 |
+ 987 |
! |
- dt_args = dt_args,
+ call("facet_grid", cols = call_fun_dots("vars", col_facet), scales = scales)
|
- | 255 |
+ 988 |
! |
- dt_options = dt_options,
+ } else if (!identical(row_facet, character(0)) && identical(col_facet, character(0))) {
|
- | 256 |
+ 989 |
! |
- server_rendering = server_rendering
+ call("facet_grid", rows = call_fun_dots("vars", row_facet), scales = scales)
|
- | 257 |
+ 990 |
|
- )
+ }
|
- | 258 |
+ 991 |
|
- }
+ }
|
- | 259 |
+ 992 |
|
- )
+
|
- | 260 |
+ 993 |
|
- })
+ coloring_ggplot_call <- function(colour,
|
- | 261 |
+ 994 |
|
- }
+ fill,
|
- | 262 |
+ 995 |
|
-
+ size,
|
- | 263 |
+ 996 |
|
- # UI function for the data_table module
+ is_point = FALSE) {
|
- | 264 |
+ 997 |
|
- ui_data_table <- function(id,
+ if (
|
-
- | 265 |
- |
+
+ | 998 |
+ 15x |
- choices,
+ !identical(colour, character(0)) &&
|
-
- | 266 |
- |
+
+ | 999 |
+ 15x |
- selected) {
+ !identical(fill, character(0)) &&
|
-
- | 267 |
- ! |
+
+ | 1000 |
+ 15x |
- ns <- NS(id)
+ is_point &&
|
-
- | 268 |
- |
+
+ | 1001 |
+ 15x |
-
+ !identical(size, character(0))
|
-
- | 269 |
- ! |
+
+ | 1002 |
+ |
- if (!is.null(selected)) {
+ ) {
|
-
- | 270 |
- ! |
+
+ | 1003 |
+ 1x |
- all_choices <- choices
+ substitute(
|
-
- | 271 |
- ! |
+
+ | 1004 |
+ 1x |
- choices <- c(selected, setdiff(choices, selected))
+ expr = aes(colour = colour_name, fill = fill_name, size = size_name),
|
-
- | 272 |
- ! |
+
+ | 1005 |
+ 1x |
- names(choices) <- names(all_choices)[match(choices, all_choices)]
+ env = list(colour_name = as.name(colour), fill_name = as.name(fill), size_name = as.name(size))
|
- | 273 |
+ 1006 |
|
- }
+ )
|
- | 274 |
+ 1007 |
|
-
+ } else if (
|
-
- | 275 |
- ! |
+
+ | 1008 |
+ 14x |
- tagList(
+ identical(colour, character(0)) &&
|
-
- | 276 |
- ! |
+
+ | 1009 |
+ 14x |
- teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")),
+ !identical(fill, character(0)) &&
|
-
- | 277 |
- ! |
+
+ | 1010 |
+ 14x |
- fluidRow(
+ is_point &&
|
-
- | 278 |
- ! |
+
+ | 1011 |
+ 14x |
- teal.widgets::optionalSelectInput(
+ identical(size, character(0))
|
-
- | 279 |
- ! |
+
+ | 1012 |
+ |
- ns("variables"),
+ ) {
|
-
- | 280 |
- ! |
+
+ | 1013 |
+ 1x |
- "Select variables:",
+ substitute(expr = aes(fill = fill_name), env = list(fill_name = as.name(fill)))
|
-
- | 281 |
- ! |
+
+ | 1014 |
+ |
- choices = choices,
+ } else if (
|
-
- | 282 |
- ! |
+
+ | 1015 |
+ 13x |
- selected = selected,
+ !identical(colour, character(0)) &&
|
-
- | 283 |
- ! |
+
+ | 1016 |
+ 13x |
- multiple = TRUE,
+ !identical(fill, character(0)) &&
|
-
- | 284 |
- ! |
+
+ | 1017 |
+ 13x |
- width = "100%"
+ (!is_point || identical(size, character(0)))
|
- | 285 |
+ 1018 |
|
- )
+ ) {
|
-
- | 286 |
- |
+
+ | 1019 |
+ 3x |
- ),
+ substitute(
|
-
- | 287 |
- ! |
+
+ | 1020 |
+ 3x |
- fluidRow(
+ expr = aes(colour = colour_name, fill = fill_name),
|
-
- | 288 |
- ! |
+
+ | 1021 |
+ 3x |
- DT::dataTableOutput(ns("data_table"), width = "100%")
+ env = list(colour_name = as.name(colour), fill_name = as.name(fill))
|
- | 289 |
+ 1022 |
|
)
|
- | 290 |
+ 1023 |
|
- )
+ } else if (
|
-
- | 291 |
- |
+
+ | 1024 |
+ 10x |
- }
+ !identical(colour, character(0)) &&
|
-
- | 292 |
- |
+
+ | 1025 |
+ 10x |
-
+ identical(fill, character(0)) &&
+ |
+
+
+ | 1026 |
+ 10x |
+
+ (!is_point || identical(size, character(0)))
|
- | 293 |
+ 1027 |
|
- # Server function for the data_table module
+ ) {
|
-
- | 294 |
- |
+
+ | 1028 |
+ 1x |
- srv_data_table <- function(id,
+ substitute(expr = aes(colour = colour_name), env = list(colour_name = as.name(colour)))
|
- | 295 |
+ 1029 |
|
- data,
+ } else if (
|
-
- | 296 |
- |
+
+ | 1030 |
+ 9x |
- dataname,
+ identical(colour, character(0)) &&
|
-
- | 297 |
- |
+
+ | 1031 |
+ 9x |
- if_filtered,
+ !identical(fill, character(0)) &&
|
-
- | 298 |
- |
+
+ | 1032 |
+ 9x |
- if_distinct,
+ (!is_point || identical(size, character(0)))
|
- | 299 |
+ 1033 |
|
- dt_args,
+ ) {
|
-
- | 300 |
- |
+
+ | 1034 |
+ 2x |
- dt_options,
+ substitute(expr = aes(fill = fill_name), env = list(fill_name = as.name(fill)))
|
- | 301 |
+ 1035 |
|
- server_rendering) {
- |
-
-
- | 302 |
- ! |
-
- moduleServer(id, function(input, output, session) {
+ } else if (
|
-
- | 303 |
- ! |
+
+ | 1036 |
+ 7x |
- iv <- shinyvalidate::InputValidator$new()
+ identical(colour, character(0)) &&
|
-
- | 304 |
- ! |
+
+ | 1037 |
+ 7x |
- iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names"))
+ identical(fill, character(0)) &&
|
-
- | 305 |
- ! |
+
+ | 1038 |
+ 7x |
- iv$add_rule("variables", shinyvalidate::sv_in_set(
+ is_point &&
|
-
- | 306 |
- ! |
+
+ | 1039 |
+ 7x |
- set = names(isolate(data())[[dataname]]), message_fmt = "Not all selected variables exist in the data"
+ !identical(size, character(0))
|
- | 307 |
+ 1040 |
|
- ))
+ ) {
|
-
- | 308 |
- ! |
+
+ | 1041 |
+ 1x |
- iv$enable()
+ substitute(expr = aes(size = size_name), env = list(size_name = as.name(size)))
|
- | 309 |
+ 1042 |
|
-
- |
-
-
- | 310 |
- ! |
-
- output$data_table <- DT::renderDataTable(server = server_rendering, {
+ } else if (
|
-
- | 311 |
- ! |
+
+ | 1043 |
+ 6x |
- teal::validate_inputs(iv)
+ !identical(colour, character(0)) &&
|
-
- | 312 |
- |
+
+ | 1044 |
+ 6x |
-
+ identical(fill, character(0)) &&
|
-
- | 313 |
- ! |
+
+ | 1045 |
+ 6x |
- df <- data()[[dataname]]
+ is_point &&
|
-
- | 314 |
- ! |
+
+ | 1046 |
+ 6x |
- variables <- input$variables
+ !identical(size, character(0))
|
- | 315 |
+ 1047 |
|
-
+ ) {
|
-
- | 316 |
- ! |
+
+ | 1048 |
+ 1x |
- teal::validate_has_data(df, min_nrow = 1L, msg = paste("data", dataname, "is empty"))
+ substitute(
|
-
- | 317 |
- |
+
+ | 1049 |
+ 1x |
-
+ expr = aes(colour = colour_name, size = size_name),
|
-
- | 318 |
- ! |
+
+ | 1050 |
+ 1x |
- dataframe_selected <- if (if_distinct()) {
+ env = list(colour_name = as.name(colour), size_name = as.name(size))
|
-
- | 319 |
- ! |
+
+ | 1051 |
+ |
- dplyr::count(df, dplyr::across(dplyr::all_of(variables)))
+ )
|
- | 320 |
+ 1052 |
|
- } else {
+ } else if (
|
-
- | 321 |
- ! |
+
+ | 1053 |
+ 5x |
- df[variables]
+ identical(colour, character(0)) &&
|
-
- | 322 |
- |
+
+ | 1054 |
+ 5x |
- }
+ !identical(fill, character(0)) &&
|
-
- | 323 |
- |
+
+ | 1055 |
+ 5x |
-
+ is_point &&
|
-
- | 324 |
- ! |
+
+ | 1056 |
+ 5x |
- dt_args$options <- dt_options
+ !identical(size, character(0))
|
-
- | 325 |
- ! |
+
+ | 1057 |
+ |
- if (!is.null(input$dt_rows)) {
+ ) {
|
-
- | 326 |
- ! |
+
+ | 1058 |
+ 1x |
- dt_args$options$pageLength <- input$dt_rows
+ substitute(
|
-
- | 327 |
- |
+
+ | 1059 |
+ 1x |
- }
+ expr = aes(colour = colour_name, fill = fill_name, size = size_name),
|
-
- | 328 |
- ! |
+
+ | 1060 |
+ 1x |
- dt_args$data <- dataframe_selected
+ env = list(colour_name = as.name(fill), fill_name = as.name(fill), size_name = as.name(size))
|
- | 329 |
+ 1061 |
|
-
+ )
|
-
- | 330 |
- ! |
+
+ | 1062 |
+ |
- do.call(DT::datatable, dt_args)
+ } else {
|
-
- | 331 |
- |
+
+ | 1063 |
+ 4x |
- })
+ NULL
|
- | 332 |
+ 1064 |
|
- })
+ }
|
- | 333 |
+ 1065 |
|
}
@@ -64145,119 +64508,119 @@ teal.modules.general coverage - 3.44%
| 20 |
|
- #' @examples
+ #' @examplesShinylive
|
| 21 |
|
- #' library(teal.widgets)
+ #' library(teal.modules.general)
|
| 22 |
|
- #'
+ #' interactive <- function() TRUE
|
| 23 |
|
- #' # module specification used in apps below
+ #' {{ next_example }}
|
| 24 |
|
- #' tm_missing_data_module <- tm_missing_data(
+ #' @examplesIf require("gridExtra", quietly = TRUE) && require("rlang", quietly = TRUE)
|
| 25 |
|
- #' ggplot2_args = list(
+ #' # general example data
|
| 26 |
|
- #' "Combinations Hist" = ggplot2_args(
+ #' data <- teal_data()
|
| 27 |
|
- #' labs = list(subtitle = "Plot produced by Missing Data Module", caption = NULL)
+ #' data <- within(data, {
|
| 28 |
|
- #' ),
+ #' require(nestcolor)
|
| 29 |
|
- #' "Combinations Main" = ggplot2_args(labs = list(title = NULL))
+ #'
|
| 30 |
|
- #' )
+ #' add_nas <- function(x) {
|
| 31 |
|
- #' )
+ #' x[sample(seq_along(x), floor(length(x) * runif(1, .05, .17)))] <- NA
|
| 32 |
|
- #'
+ #' x
|
| 33 |
|
- #' # general example data
+ #' }
|
| 34 |
|
- #' data <- teal_data()
+ #'
|
| 35 |
|
- #' data <- within(data, {
+ #' iris <- iris
|
| 36 |
|
- #' require(nestcolor)
+ #' mtcars <- mtcars
|
@@ -64271,8964 +64634,8971 @@ teal.modules.general coverage - 3.44%
38 |
|
- #' add_nas <- function(x) {
+ #' iris[] <- lapply(iris, add_nas)
|
| 39 |
|
- #' x[sample(seq_along(x), floor(length(x) * runif(1, .05, .17)))] <- NA
+ #' mtcars[] <- lapply(mtcars, add_nas)
|
| 40 |
|
- #' x
+ #' mtcars[["cyl"]] <- as.factor(mtcars[["cyl"]])
|
| 41 |
|
- #' }
+ #' mtcars[["gear"]] <- as.factor(mtcars[["gear"]])
|
| 42 |
|
- #'
+ #' })
|
| 43 |
|
- #' iris <- iris
+ #' datanames(data) <- c("iris", "mtcars")
|
| 44 |
|
- #' mtcars <- mtcars
+ #'
|
| 45 |
|
- #'
+ #' app <- init(
|
| 46 |
|
- #' iris[] <- lapply(iris, add_nas)
+ #' data = data,
|
| 47 |
|
- #' mtcars[] <- lapply(mtcars, add_nas)
+ #' modules = modules(
|
| 48 |
|
- #' mtcars[["cyl"]] <- as.factor(mtcars[["cyl"]])
+ #' tm_missing_data()
|
| 49 |
|
- #' mtcars[["gear"]] <- as.factor(mtcars[["gear"]])
+ #' )
|
| 50 |
|
- #' })
+ #' )
|
| 51 |
|
- #' datanames(data) <- c("iris", "mtcars")
+ #' if (interactive()) {
|
| 52 |
|
- #'
+ #' shinyApp(app$ui, app$server)
|
| 53 |
|
- #' app <- init(
+ #' }
|
| 54 |
|
- #' data = data,
+ #'
|
| 55 |
|
- #' modules = modules(tm_missing_data_module)
+ #' @examplesShinylive
|
| 56 |
|
- #' )
+ #' library(teal.modules.general)
|
| 57 |
|
- #' if (interactive()) {
+ #' interactive <- function() TRUE
|
| 58 |
|
- #' shinyApp(app$ui, app$server)
+ #' {{ next_example }}
|
| 59 |
|
- #' }
+ #' @examplesIf require("gridExtra", quietly = TRUE) && require("rlang", quietly = TRUE)
|
| 60 |
|
- #'
+ #' # CDISC example data
|
| 61 |
|
- #' # CDISC example data
+ #' data <- teal_data()
|
| 62 |
|
- #' data <- teal_data()
+ #' data <- within(data, {
|
| 63 |
|
- #' data <- within(data, {
+ #' require(nestcolor)
|
| 64 |
|
- #' require(nestcolor)
+ #' ADSL <- rADSL
|
| 65 |
|
- #' ADSL <- rADSL
+ #' ADRS <- rADRS
|
| 66 |
|
- #' ADRS <- rADRS
+ #' })
|
| 67 |
|
- #' })
+ #' datanames(data) <- c("ADSL", "ADRS")
|
| 68 |
|
- #' datanames(data) <- c("ADSL", "ADRS")
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
|
| 69 |
|
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
+ #'
|
| 70 |
|
- #'
+ #' app <- init(
|
| 71 |
|
- #' app <- init(
+ #' data = data,
|
| 72 |
|
- #' data = data,
+ #' modules = modules(
|
| 73 |
|
- #' modules = modules(tm_missing_data_module)
+ #' tm_missing_data()
|
| 74 |
|
- #' )
+ #' )
|
| 75 |
|
- #' if (interactive()) {
+ #' )
|
| 76 |
|
- #' shinyApp(app$ui, app$server)
+ #' if (interactive()) {
|
| 77 |
|
- #' }
+ #' shinyApp(app$ui, app$server)
|
| 78 |
|
- #'
+ #' }
|
| 79 |
|
- #' @export
+ #'
|
| 80 |
|
- #'
+ #' @export
|
| 81 |
|
- tm_missing_data <- function(label = "Missing data",
+ #'
|
| 82 |
|
- plot_height = c(600, 400, 5000),
+ tm_missing_data <- function(label = "Missing data",
|
| 83 |
|
- plot_width = NULL,
+ plot_height = c(600, 400, 5000),
|
| 84 |
|
- parent_dataname = "ADSL",
+ plot_width = NULL,
|
| 85 |
|
- ggtheme = c("classic", "gray", "bw", "linedraw", "light", "dark", "minimal", "void"),
+ parent_dataname = "ADSL",
|
| 86 |
|
- ggplot2_args = list(
+ ggtheme = c("classic", "gray", "bw", "linedraw", "light", "dark", "minimal", "void"),
|
| 87 |
|
- "Combinations Hist" = teal.widgets::ggplot2_args(labs = list(caption = NULL)),
+ ggplot2_args = list(
|
| 88 |
|
- "Combinations Main" = teal.widgets::ggplot2_args(labs = list(title = NULL))
+ "Combinations Hist" = teal.widgets::ggplot2_args(labs = list(caption = NULL)),
|
| 89 |
|
- ),
+ "Combinations Main" = teal.widgets::ggplot2_args(labs = list(title = NULL))
|
| 90 |
|
- pre_output = NULL,
+ ),
|
| 91 |
|
+
+ pre_output = NULL,
+ |
+
+
+ | 92 |
+ |
post_output = NULL) {
|
- | 92 |
+ 93 |
! |
message("Initializing tm_missing_data")
|
- | 93 |
+ 94 |
|
|
- | 94 |
+ 95 |
|
# Requires Suggested packages
|
- | 95 |
+ 96 |
! |
if (!requireNamespace("gridExtra", quietly = TRUE)) {
|
- | 96 |
+ 97 |
! |
stop("Cannot load gridExtra - please install the package or restart your session.")
|
- | 97 |
+ 98 |
|
}
|
- | 98 |
+ 99 |
! |
if (!requireNamespace("rlang", quietly = TRUE)) {
|
- | 99 |
+ 100 |
! |
stop("Cannot load rlang - please install the package or restart your session.")
|
- | 100 |
+ 101 |
|
}
|
- | 101 |
+ 102 |
|
|
- | 102 |
+ 103 |
|
# Normalize the parameters
|
- | 103 |
+ 104 |
! |
if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)
|
- | 104 |
+ 105 |
|
|
- | 105 |
+ 106 |
|
# Start of assertions
|
- | 106 |
+ 107 |
! |
checkmate::assert_string(label)
|
- | 107 |
+ 108 |
|
|
- | 108 |
+ 109 |
! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
|
- | 109 |
+ 110 |
! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
|
- | 110 |
+ 111 |
! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
|
- | 111 |
+ 112 |
! |
checkmate::assert_numeric(
|
- | 112 |
+ 113 |
! |
plot_width[1],
|
- | 113 |
+ 114 |
! |
lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
|
- | 114 |
+ 115 |
|
)
|
- | 115 |
+ 116 |
|
|
- | 116 |
+ 117 |
! |
checkmate::assert_character(parent_dataname, min.len = 0, max.len = 1)
|
- | 117 |
+ 118 |
! |
ggtheme <- match.arg(ggtheme)
|
- | 118 |
+ 119 |
|
|
- | 119 |
+ 120 |
! |
plot_choices <- c("Summary Obs", "Summary Patients", "Combinations Main", "Combinations Hist", "By Subject")
|
- | 120 |
+ 121 |
! |
checkmate::assert_list(ggplot2_args, types = "ggplot2_args")
|
- | 121 |
+ 122 |
! |
checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
- | 122 |
+ 123 |
|
|
- | 123 |
+ 124 |
! |
checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
- | 124 |
+ 125 |
! |
checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
- | 125 |
+ 126 |
|
# End of assertions
|
- | 126 |
+ 127 |
|
|
- | 127 |
+ 128 |
! |
ans <- module(
|
- | 128 |
+ 129 |
! |
label,
|
- | 129 |
+ 130 |
! |
server = srv_page_missing_data,
|
- | 130 |
+ 131 |
! |
server_args = list(
|
- | 131 |
+ 132 |
! |
parent_dataname = parent_dataname, plot_height = plot_height,
|
- | 132 |
+ 133 |
! |
plot_width = plot_width, ggplot2_args = ggplot2_args, ggtheme = ggtheme
|
- | 133 |
+ 134 |
|
),
|
- | 134 |
+ 135 |
! |
ui = ui_page_missing_data,
|
- | 135 |
+ 136 |
! |
datanames = "all",
|
- | 136 |
+ 137 |
! |
ui_args = list(pre_output = pre_output, post_output = post_output)
|
- | 137 |
+ 138 |
|
)
|
- | 138 |
+ 139 |
! |
attr(ans, "teal_bookmarkable") <- TRUE
|
- | 139 |
+ 140 |
! |
ans
|
- | 140 |
+ 141 |
|
}
|
- | 141 |
+ 142 |
|
|
- | 142 |
+ 143 |
|
# UI function for the missing data module (all datasets)
|
- | 143 |
+ 144 |
|
ui_page_missing_data <- function(id, pre_output = NULL, post_output = NULL) {
|
- | 144 |
+ 145 |
! |
ns <- NS(id)
|
- | 145 |
+ 146 |
! |
tagList(
|
- | 146 |
+ 147 |
! |
include_css_files("custom"),
|
- | 147 |
+ 148 |
! |
teal.widgets::standard_layout(
|
- | 148 |
+ 149 |
! |
output = teal.widgets::white_small_well(
|
- | 149 |
+ 150 |
! |
tags$div(
|
- | 150 |
+ 151 |
! |
class = "flex",
|
- | 151 |
+ 152 |
! |
column(
|
- | 152 |
+ 153 |
! |
width = 12,
|
- | 153 |
+ 154 |
! |
uiOutput(ns("dataset_tabs"))
|
- | 154 |
+ 155 |
|
)
|
- | 155 |
+ 156 |
|
)
|
- | 156 |
+ 157 |
|
),
|
- | 157 |
+ 158 |
! |
encoding = tags$div(
|
- | 158 |
+ 159 |
! |
uiOutput(ns("dataset_encodings"))
|
- | 159 |
+ 160 |
|
),
|
- | 160 |
+ 161 |
! |
uiOutput(ns("dataset_reporter")),
|
- | 161 |
+ 162 |
! |
pre_output = pre_output,
|
- | 162 |
+ 163 |
! |
post_output = post_output
|
- | 163 |
+ 164 |
|
)
|
- | 164 |
+ 165 |
|
)
|
- | 165 |
+ 166 |
|
}
|
- | 166 |
+ 167 |
|
|
- | 167 |
+ 168 |
|
# Server function for the missing data module (all datasets)
|
- | 168 |
+ 169 |
|
srv_page_missing_data <- function(id, data, reporter, filter_panel_api, parent_dataname,
|
- | 169 |
+ 170 |
|
plot_height, plot_width, ggplot2_args, ggtheme) {
|
- | 170 |
+ 171 |
! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
|
- | 171 |
+ 172 |
! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
|
- | 172 |
+ 173 |
! |
moduleServer(id, function(input, output, session) {
|
- | 173 |
+ 174 |
! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
|
- | 174 |
+ 175 |
|
|
- | 175 |
+ 176 |
! |
datanames <- isolate(teal.data::datanames(data()))
|
- | 176 |
+ 177 |
! |
datanames <- Filter(function(name) {
|
- | 177 |
+ 178 |
! |
is.data.frame(isolate(data())[[name]])
|
- | 178 |
+ 179 |
! |
}, datanames)
|
- | 179 |
+ 180 |
! |
if_subject_plot <- length(parent_dataname) > 0 && parent_dataname %in% datanames
|
- | 180 |
+ 181 |
|
|
- | 181 |
+ 182 |
! |
ns <- session$ns
|
- | 182 |
+ 183 |
|
|
- | 183 |
+ 184 |
! |
output$dataset_tabs <- renderUI({
|
- | 184 |
+ 185 |
! |
do.call(
|
- | 185 |
+ 186 |
! |
tabsetPanel,
|
- | 186 |
+ 187 |
! |
c(
|
- | 187 |
+ 188 |
! |
id = ns("dataname_tab"),
|
- | 188 |
+ 189 |
! |
lapply(
|
- | 189 |
+ 190 |
! |
datanames,
|
- | 190 |
+ 191 |
! |
function(x) {
|
- | 191 |
+ 192 |
! |
tabPanel(
|
- | 192 |
+ 193 |
! |
title = x,
|
- | 193 |
+ 194 |
! |
column(
|
- | 194 |
+ 195 |
! |
width = 12,
|
- | 195 |
+ 196 |
! |
tags$div(
|
- | 196 |
+ 197 |
! |
class = "mt-4",
|
- | 197 |
+ 198 |
! |
ui_missing_data(id = ns(x), by_subject_plot = if_subject_plot)
|
- | 198 |
+ 199 |
|
)
|
- | 199 |
+ 200 |
|
)
|
- | 200 |
+ 201 |
|
)
|
- | 201 |
+ 202 |
|
}
|
- | 202 |
+ 203 |
|
)
|
- | 203 |
+ 204 |
|
)
|
- | 204 |
+ 205 |
|
)
|
- | 205 |
+ 206 |
|
})
|
- | 206 |
+ 207 |
|
|
- | 207 |
+ 208 |
! |
output$dataset_encodings <- renderUI({
|
- | 208 |
+ 209 |
! |
tagList(
|
- | 209 |
+ 210 |
! |
lapply(
|
- | 210 |
+ 211 |
! |
datanames,
|
- | 211 |
+ 212 |
! |
function(x) {
|
- | 212 |
+ 213 |
! |
conditionalPanel(
|
- | 213 |
+ 214 |
! |
is_tab_active_js(ns("dataname_tab"), x),
|
- | 214 |
+ 215 |
! |
encoding_missing_data(
|
- | 215 |
+ 216 |
! |
id = ns(x),
|
- | 216 |
+ 217 |
! |
summary_per_patient = if_subject_plot,
|
- | 217 |
+ 218 |
! |
ggtheme = ggtheme,
|
- | 218 |
+ 219 |
! |
datanames = datanames
|
- | 219 |
+ 220 |
|
)
|
- | 220 |
+ 221 |
|
)
|
- | 221 |
+ 222 |
|
}
|
- | 222 |
+ 223 |
|
)
|
- | 223 |
+ 224 |
|
)
|
- | 224 |
+ 225 |
|
})
|
- | 225 |
+ 226 |
|
|
- | 226 |
+ 227 |
! |
output$dataset_reporter <- renderUI({
|
- | 227 |
+ 228 |
! |
lapply(datanames, function(x) {
|
- | 228 |
+ 229 |
! |
dataname_ns <- NS(ns(x))
|
- | 229 |
+ 230 |
|
|
- | 230 |
+ 231 |
! |
conditionalPanel(
|
- | 231 |
+ 232 |
! |
is_tab_active_js(ns("dataname_tab"), x),
|
- | 232 |
+ 233 |
! |
tagList(
|
- | 233 |
+ 234 |
! |
teal.widgets::verbatim_popup_ui(dataname_ns("rcode"), "Show R code")
|
- | 234 |
+ 235 |
|
)
|
- | 235 |
+ 236 |
|
)
|
- | 236 |
+ 237 |
|
})
|
- | 237 |
+ 238 |
|
})
|
- | 238 |
+ 239 |
|
|
- | 239 |
+ 240 |
! |
lapply(
|
- | 240 |
+ 241 |
! |
datanames,
|
- | 241 |
+ 242 |
! |
function(x) {
|
- | 242 |
+ 243 |
! |
srv_missing_data(
|
- | 243 |
+ 244 |
! |
id = x,
|
- | 244 |
+ 245 |
! |
data = data,
|
- | 245 |
+ 246 |
! |
reporter = if (with_reporter) reporter,
|
- | 246 |
+ 247 |
! |
filter_panel_api = if (with_filter) filter_panel_api,
|
- | 247 |
+ 248 |
! |
dataname = x,
|
- | 248 |
+ 249 |
! |
parent_dataname = parent_dataname,
|
- | 249 |
+ 250 |
! |
plot_height = plot_height,
|
- | 250 |
+ 251 |
! |
plot_width = plot_width,
|
- | 251 |
+ 252 |
! |
ggplot2_args = ggplot2_args
|
- | 252 |
+ 253 |
|
)
|
- | 253 |
+ 254 |
|
}
|
- | 254 |
+ 255 |
|
)
|
- | 255 |
+ 256 |
|
})
|
- | 256 |
+ 257 |
|
}
|
- | 257 |
+ 258 |
|
|
- | 258 |
+ 259 |
|
# UI function for the missing data module (single dataset)
|
- | 259 |
+ 260 |
|
ui_missing_data <- function(id, by_subject_plot = FALSE) {
|
- | 260 |
+ 261 |
! |
ns <- NS(id)
|
- | 261 |
+ 262 |
|
|
- | 262 |
+ 263 |
! |
tab_list <- list(
|
- | 263 |
+ 264 |
! |
tabPanel(
|
- | 264 |
+ 265 |
! |
"Summary",
|
- | 265 |
+ 266 |
! |
teal.widgets::plot_with_settings_ui(id = ns("summary_plot")),
|
- | 266 |
+ 267 |
! |
helpText(
|
- | 267 |
+ 268 |
! |
tags$p(paste(
|
- | 268 |
+ 269 |
! |
'The "Summary" graph shows the number of missing values per variable (both absolute and percentage),',
|
- | 269 |
+ 270 |
! |
"sorted by magnitude."
|
- | 270 |
+ 271 |
|
)),
|
- | 271 |
+ 272 |
! |
tags$p(
|
- | 272 |
+ 273 |
! |
'The "summary per patients" graph is showing how many subjects have at least one missing observation',
|
- | 273 |
+ 274 |
! |
"for each variable. It will be most useful for panel datasets."
|
- | 274 |
+ 275 |
|
)
|
- | 275 |
+ 276 |
|
)
|
- | 276 |
+ 277 |
|
),
|
- | 277 |
+ 278 |
! |
tabPanel(
|
- | 278 |
+ 279 |
! |
"Combinations",
|
- | 279 |
+ 280 |
! |
teal.widgets::plot_with_settings_ui(id = ns("combination_plot")),
|
- | 280 |
+ 281 |
! |
helpText(
|
- | 281 |
+ 282 |
! |
tags$p(paste(
|
- | 282 |
+ 283 |
! |
'The "Combinations" graph is used to explore the relationship between the missing data within',
|
- | 283 |
+ 284 |
! |
"different columns of the dataset.",
|
- | 284 |
+ 285 |
! |
"It shows the different patterns of missingness in the rows of the data.",
|
- | 285 |
+ 286 |
! |
'For example, suppose that 70 rows of the data have exactly columns "A" and "B" missing.',
|
- | 286 |
+ 287 |
! |
"In this case there would be a bar of height 70 in the top graph and",
|
- | 287 |
+ 288 |
! |
'the column below this in the second graph would have rows "A" and "B" cells shaded red.'
|
- | 288 |
+ 289 |
|
)),
|
- | 289 |
+ 290 |
! |
tags$p(paste(
|
- | 290 |
+ 291 |
! |
"Due to the large number of missing data patterns possible, only those with a large set of observations",
|
- | 291 |
+ 292 |
! |
'are shown in the graph and the "Combination cut-off" slider can be used to adjust the number shown.'
|
- | 292 |
+ 293 |
|
))
|
- | 293 |
+ 294 |
|
)
|
- | 294 |
+ 295 |
|
),
|
- | 295 |
+ 296 |
! |
tabPanel(
|
- | 296 |
+ 297 |
! |
"By Variable Levels",
|
- | 297 |
+ 298 |
! |
teal.widgets::get_dt_rows(ns("levels_table"), ns("levels_table_rows")),
|
- | 298 |
+ 299 |
! |
DT::dataTableOutput(ns("levels_table"))
|
- | 299 |
+ 300 |
|
)
|
- | 300 |
+ 301 |
|
)
|
- | 301 |
+ 302 |
! |
if (isTRUE(by_subject_plot)) {
|
- | 302 |
+ 303 |
! |
tab_list <- append(
|
- | 303 |
+ 304 |
! |
tab_list,
|
- | 304 |
+ 305 |
! |
list(tabPanel(
|
- | 305 |
+ 306 |
! |
"Grouped by Subject",
|
- | 306 |
+ 307 |
! |
teal.widgets::plot_with_settings_ui(id = ns("by_subject_plot")),
|
- | 307 |
+ 308 |
! |
helpText(
|
- | 308 |
+ 309 |
! |
tags$p(paste(
|
- | 309 |
+ 310 |
! |
"This graph shows the missingness with respect to subjects rather than individual rows of the",
|
- | 310 |
+ 311 |
! |
"dataset. Each row represents one dataset variable and each column a single subject. Only subjects",
|
- | 311 |
+ 312 |
! |
"with at least one record in this dataset are shown. For a given subject, if they have any missing",
|
- | 312 |
+ 313 |
! |
"values of a specific variable then the appropriate cell in the graph is marked as missing."
|
- | 313 |
+ 314 |
|
))
|
- | 314 |
+ 315 |
|
)
|
- | 315 |
+ 316 |
|
))
|
- | 316 |
+ 317 |
|
)
|
- | 317 |
+ 318 |
|
}
|
- | 318 |
+ 319 |
|
|
- | 319 |
+ 320 |
! |
do.call(
|
- | 320 |
+ 321 |
! |
tabsetPanel,
|
- | 321 |
+ 322 |
! |
c(
|
- | 322 |
+ 323 |
! |
id = ns("summary_type"),
|
- | 323 |
+ 324 |
! |
tab_list
|
- | 324 |
+ 325 |
|
)
|
- | 325 |
+ 326 |
|
)
|
- | 326 |
+ 327 |
|
}
|
- | 327 |
+ 328 |
|
|
- | 328 |
+ 329 |
|
# UI encoding for the missing data module (all datasets)
|
- | 329 |
+ 330 |
|
encoding_missing_data <- function(id, summary_per_patient = FALSE, ggtheme, datanames) {
|
- | 330 |
+ 331 |
! |
ns <- NS(id)
|
- | 331 |
+ 332 |
|
|
- | 332 |
+ 333 |
! |
tagList(
|
- | 333 |
+ 334 |
|
### Reporter
|
- | 334 |
+ 335 |
! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
- | 335 |
+ 336 |
|
###
|
- | 336 |
+ 337 |
! |
tags$label("Encodings", class = "text-primary"),
|
- | 337 |
+ 338 |
! |
helpText(
|
- | 338 |
+ 339 |
! |
paste0("Dataset", `if`(length(datanames) > 1, "s", ""), ":"),
|
- | 339 |
+ 340 |
! |
tags$code(paste(datanames, collapse = ", "))
|
- | 340 |
+ 341 |
|
),
|
- | 341 |
+ 342 |
! |
uiOutput(ns("variables")),
|
- | 342 |
+ 343 |
! |
actionButton(
|
- | 343 |
+ 344 |
! |
ns("filter_na"),
|
- | 344 |
+ 345 |
! |
tags$span("Select only vars with missings", class = "whitespace-normal"),
|
- | 345 |
+ 346 |
! |
width = "100%",
|
- | 346 |
+ 347 |
! |
class = "mb-4"
|
- | 347 |
+ 348 |
|
),
|
- | 348 |
+ 349 |
! |
conditionalPanel(
|
- | 349 |
+ 350 |
! |
is_tab_active_js(ns("summary_type"), "Summary"),
|
- | 350 |
+ 351 |
! |
checkboxInput(
|
- | 351 |
+ 352 |
! |
ns("any_na"),
|
- | 352 |
+ 353 |
! |
tags$div(
|
- | 353 |
+ 354 |
! |
class = "teal-tooltip",
|
- | 354 |
+ 355 |
! |
tagList(
|
- | 355 |
+ 356 |
! |
"Add **anyna** variable",
|
- | 356 |
+ 357 |
! |
icon("circle-info"),
|
- | 357 |
+ 358 |
! |
tags$span(
|
- | 358 |
+ 359 |
! |
class = "tooltiptext",
|
- | 359 |
+ 360 |
! |
"Describes the number of observations with at least one missing value in any variable."
|
- | 360 |
+ 361 |
|
)
|
- | 361 |
+ 362 |
|
)
|
- | 362 |
+ 363 |
|
),
|
- | 363 |
+ 364 |
! |
value = FALSE
|
- | 364 |
+ 365 |
|
),
|
- | 365 |
+ 366 |
! |
if (summary_per_patient) {
|
- | 366 |
+ 367 |
! |
checkboxInput(
|
- | 367 |
+ 368 |
! |
ns("if_patients_plot"),
|
- | 368 |
+ 369 |
! |
tags$div(
|
- | 369 |
+ 370 |
! |
class = "teal-tooltip",
|
- | 370 |
+ 371 |
! |
tagList(
|
- | 371 |
+ 372 |
! |
"Add summary per patients",
|
- | 372 |
+ 373 |
! |
icon("circle-info"),
|
- | 373 |
+ 374 |
! |
tags$span(
|
- | 374 |
+ 375 |
! |
class = "tooltiptext",
|
- | 375 |
+ 376 |
! |
paste(
|
- | 376 |
+ 377 |
! |
"Displays the number of missing values per observation,",
|
- | 377 |
+ 378 |
! |
"where the x-axis is sorted by observation appearance in the table."
|
- | 378 |
+ 379 |
|
)
|
- | 379 |
+ 380 |
|
)
|
- | 380 |
+ 381 |
|
)
|
- | 381 |
+ 382 |
|
),
|
- | 382 |
+ 383 |
! |
value = FALSE
|
- | 383 |
+ 384 |
|
)
|
- | 384 |
+ 385 |
|
}
|
- | 385 |
+ 386 |
|
),
|
- | 386 |
+ 387 |
! |
conditionalPanel(
|
- | 387 |
+ 388 |
! |
is_tab_active_js(ns("summary_type"), "Combinations"),
|
- | 388 |
+ 389 |
! |
uiOutput(ns("cutoff"))
|
- | 389 |
+ 390 |
|
),
|
- | 390 |
+ 391 |
! |
conditionalPanel(
|
- | 391 |
+ 392 |
! |
is_tab_active_js(ns("summary_type"), "By Variable Levels"),
|
- | 392 |
+ 393 |
! |
tagList(
|
- | 393 |
+ 394 |
! |
uiOutput(ns("group_by_var_ui")),
|
- | 394 |
+ 395 |
! |
uiOutput(ns("group_by_vals_ui")),
|
- | 395 |
+ 396 |
! |
radioButtons(
|
- | 396 |
+ 397 |
! |
ns("count_type"),
|
- | 397 |
+ 398 |
! |
label = "Display missing as",
|
- | 398 |
+ 399 |
! |
choices = c("counts", "proportions"),
|
- | 399 |
+ 400 |
! |
selected = "counts",
|
- | 400 |
+ 401 |
! |
inline = TRUE
|
- | 401 |
+ 402 |
|
)
|
- | 402 |
+ 403 |
|
)
|
- | 403 |
+ 404 |
|
),
|
- | 404 |
+ 405 |
! |
teal.widgets::panel_item(
|
- | 405 |
+ 406 |
! |
title = "Plot settings",
|
- | 406 |
+ 407 |
! |
selectInput(
|
- | 407 |
+ 408 |
! |
inputId = ns("ggtheme"),
|
- | 408 |
+ 409 |
! |
label = "Theme (by ggplot):",
|
- | 409 |
+ 410 |
! |
choices = ggplot_themes,
|
- | 410 |
+ 411 |
! |
selected = ggtheme,
|
- | 411 |
+ 412 |
! |
multiple = FALSE
|
- | 412 |
+ 413 |
|
)
|
- | 413 |
+ 414 |
|
)
|
- | 414 |
+ 415 |
|
)
|
- | 415 |
+ 416 |
|
}
|
- | 416 |
+ 417 |
|
|
- | 417 |
+ 418 |
|
# Server function for the missing data (single dataset)
|
- | 418 |
+ 419 |
|
srv_missing_data <- function(id, data, reporter, filter_panel_api, dataname, parent_dataname,
|
- | 419 |
+ 420 |
|
plot_height, plot_width, ggplot2_args) {
|
- | 420 |
+ 421 |
! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
|
- | 421 |
+ 422 |
! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
|
- | 422 |
+ 423 |
! |
checkmate::assert_class(data, "reactive")
|
- | 423 |
+ 424 |
! |
checkmate::assert_class(isolate(data()), "teal_data")
|
- | 424 |
+ 425 |
! |
moduleServer(id, function(input, output, session) {
|
- | 425 |
+ 426 |
! |
ns <- session$ns
|
- | 426 |
+ 427 |
|
|
- | 427 |
+ 428 |
! |
prev_group_by_var <- reactiveVal("")
|
- | 428 |
+ 429 |
! |
data_r <- reactive(data()[[dataname]])
|
- | 429 |
+ 430 |
! |
data_keys <- reactive(unlist(teal.data::join_keys(data())[[dataname]]))
|
- | 430 |
+ 431 |
|
|
- | 431 |
+ 432 |
! |
iv_r <- reactive({
|
- | 432 |
+ 433 |
! |
iv <- shinyvalidate::InputValidator$new()
|
- | 433 |
+ 434 |
! |
iv$add_rule(
|
- | 434 |
+ 435 |
! |
"variables_select",
|
- | 435 |
+ 436 |
! |
shinyvalidate::sv_required("At least one reference variable needs to be selected.")
|
- | 436 |
+ 437 |
|
)
|
- | 437 |
+ 438 |
! |
iv$add_rule(
|
- | 438 |
+ 439 |
! |
"variables_select",
|
- | 439 |
+ 440 |
! |
~ if (length(setdiff((.), data_keys())) < 1) "Please also select non-key columns."
|
- | 440 |
+ 441 |
|
)
|
- | 441 |
+ 442 |
! |
iv_summary_table <- shinyvalidate::InputValidator$new()
|
- | 442 |
+ 443 |
! |
iv_summary_table$condition(~ isTRUE(input$summary_type == "By Variable Levels"))
|
- | 443 |
+ 444 |
! |
iv_summary_table$add_rule("count_type", shinyvalidate::sv_required("Please select type of counts"))
|
- | 444 |
+ 445 |
! |
iv_summary_table$add_rule(
|
- | 445 |
+ 446 |
! |
"group_by_vals",
|
- | 446 |
+ 447 |
! |
shinyvalidate::sv_required("Please select both group-by variable and values")
|
- | 447 |
+ 448 |
|
)
|
- | 448 |
+ 449 |
! |
iv_summary_table$add_rule(
|
- | 449 |
+ 450 |
! |
"group_by_var",
|
- | 450 |
+ 451 |
! |
~ if (length(.) > 0 && length(input$variables_select) == 1 && (.) == input$variables_select) {
|
- | 451 |
+ 452 |
! |
"If only one reference variable is selected it must not be the grouping variable."
|
- | 452 |
+ 453 |
|
}
|
- | 453 |
+ 454 |
|
)
|
- | 454 |
+ 455 |
! |
iv_summary_table$add_rule(
|
- | 455 |
+ 456 |
! |
"variables_select",
|
- | 456 |
+ 457 |
! |
~ if (length(input$group_by_var) > 0 && length(.) == 1 && (.) == input$group_by_var) {
|
- | 457 |
+ 458 |
! |
"If only one reference variable is selected it must not be the grouping variable."
|
- | 458 |
+ 459 |
|
}
|
- | 459 |
+ 460 |
|
)
|
- | 460 |
+ 461 |
! |
iv$add_validator(iv_summary_table)
|
- | 461 |
+ 462 |
! |
iv$enable()
|
- | 462 |
+ 463 |
! |
iv
|
- | 463 |
+ 464 |
|
})
|
- | 464 |
+ 465 |
|
|
- | 465 |
+ 466 |
|
|
- | 466 |
+ 467 |
! |
data_parent_keys <- reactive({
|
- | 467 |
+ 468 |
! |
if (length(parent_dataname) > 0 && parent_dataname %in% teal.data::datanames(data())) {
|
- | 468 |
+ 469 |
! |
keys <- teal.data::join_keys(data())[[dataname]]
|
- | 469 |
+ 470 |
! |
if (parent_dataname %in% names(keys)) {
|
- | 470 |
+ 471 |
! |
keys[[parent_dataname]]
|
- | 471 |
+ 472 |
|
} else {
|
- | 472 |
+ 473 |
! |
keys[[dataname]]
|
- | 473 |
+ 474 |
|
}
|
- | 474 |
+ 475 |
|
} else {
|
- | 475 |
+ 476 |
! |
NULL
|
- | 476 |
+ 477 |
|
}
|
- | 477 |
+ 478 |
|
})
|
- | 478 |
+ 479 |
|
|
- | 479 |
+ 480 |
! |
common_code_q <- reactive({
|
- | 480 |
+ 481 |
! |
teal::validate_inputs(iv_r())
|
- | 481 |
+ 482 |
|
|
- | 482 |
+ 483 |
! |
group_var <- input$group_by_var
|
- | 483 |
+ 484 |
! |
anl <- data_r()
|
- | 484 |
+ 485 |
|
|
- | 485 |
+ 486 |
! |
qenv <- if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {
|
- | 486 |
+ 487 |
! |
teal.code::eval_code(
|
- | 487 |
+ 488 |
! |
data(),
|
- | 488 |
+ 489 |
! |
substitute(
|
- | 489 |
+ 490 |
! |
expr = ANL <- anl_name[, selected_vars, drop = FALSE],
|
- | 490 |
+ 491 |
! |
env = list(anl_name = as.name(dataname), selected_vars = selected_vars())
|
- | 491 |
+ 492 |
|
)
|
- | 492 |
+ 493 |
|
)
|
- | 493 |
+ 494 |
|
} else {
|
- | 494 |
+ 495 |
! |
teal.code::eval_code(
|
- | 495 |
+ 496 |
! |
data(),
|
- | 496 |
+ 497 |
! |
substitute(expr = ANL <- anl_name, env = list(anl_name = as.name(dataname)))
|
- | 497 |
+ 498 |
|
)
|
- | 498 |
+ 499 |
|
}
|
- | 499 |
+ 500 |
|
|
- | 500 |
+ 501 |
! |
if (input$summary_type == "By Variable Levels" && !is.null(group_var) && !(group_var %in% selected_vars())) {
|
- | 501 |
+ 502 |
! |
qenv <- teal.code::eval_code(
|
- | 502 |
+ 503 |
! |
qenv,
|
- | 503 |
+ 504 |
! |
substitute(
|
- | 504 |
+ 505 |
! |
expr = ANL[[group_var]] <- anl_name[[group_var]],
|
- | 505 |
+ 506 |
! |
env = list(group_var = group_var, anl_name = as.name(dataname))
|
- | 506 |
+ 507 |
|
)
|
- | 507 |
+ 508 |
|
)
|
- | 508 |
+ 509 |
|
}
|
- | 509 |
+ 510 |
|
|
- | 510 |
+ 511 |
! |
new_col_name <- "**anyna**"
|
- | 511 |
+ 512 |
|
|
- | 512 |
+ 513 |
! |
qenv <- teal.code::eval_code(
|
- | 513 |
+ 514 |
! |
qenv,
|
- | 514 |
+ 515 |
! |
substitute(
|
- | 515 |
+ 516 |
! |
expr =
|
- | 516 |
+ 517 |
! |
create_cols_labels <- function(cols, just_label = FALSE) {
|
- | 517 |
+ 518 |
! |
column_labels <- column_labels_value
|
- | 518 |
+ 519 |
! |
column_labels[is.na(column_labels) | length(column_labels) == 0] <- ""
|
- | 519 |
+ 520 |
! |
if (just_label) {
|
- | 520 |
+ 521 |
! |
labels <- column_labels[cols]
|
- | 521 |
+ 522 |
|
} else {
|
- | 522 |
+ 523 |
! |
labels <- ifelse(cols == new_col_name | cols == "", cols, paste0(column_labels[cols], " [", cols, "]"))
|
- | 523 |
+ 524 |
|
}
|
- | 524 |
+ 525 |
! |
labels
|
- | 525 |
+ 526 |
|
},
|
- | 526 |
+ 527 |
! |
env = list(
|
- | 527 |
+ 528 |
! |
new_col_name = new_col_name,
|
- | 528 |
+ 529 |
! |
column_labels_value = c(teal.data::col_labels(data_r())[selected_vars()],
|
- | 529 |
+ 530 |
! |
new_col_name = new_col_name
|
- | 530 |
+ 531 |
|
)
|
- | 531 |
+ 532 |
|
)
|
- | 532 |
+ 533 |
|
)
|
- | 533 |
+ 534 |
|
)
|
- | 534 |
+ 535 |
! |
qenv
|
- | 535 |
+ 536 |
|
})
|
- | 536 |
+ 537 |
|
|
- | 537 |
+ 538 |
! |
selected_vars <- reactive({
|
- | 538 |
+ 539 |
! |
req(input$variables_select)
|
- | 539 |
+ 540 |
! |
keys <- data_keys()
|
- | 540 |
+ 541 |
! |
vars <- unique(c(keys, input$variables_select))
|
- | 541 |
+ 542 |
! |
vars
|
- | 542 |
+ 543 |
|
})
|
- | 543 |
+ 544 |
|
|
- | 544 |
+ 545 |
! |
vars_summary <- reactive({
|
- | 545 |
+ 546 |
! |
na_count <- data_r() %>%
|
- | 546 |
+ 547 |
! |
sapply(function(x) mean(is.na(x)), USE.NAMES = TRUE) %>%
|
- | 547 |
+ 548 |
! |
sort(decreasing = TRUE)
|
- | 548 |
+ 549 |
|
|
- | 549 |
+ 550 |
! |
tibble::tibble(
|
- | 550 |
+ 551 |
! |
key = names(na_count),
|
- | 551 |
+ 552 |
! |
value = unname(na_count),
|
- | 552 |
+ 553 |
! |
label = cut(na_count, breaks = seq(from = 0, to = 1, by = 0.1), include.lowest = TRUE)
|
- | 553 |
+ 554 |
|
)
|
- | 554 |
+ 555 |
|
})
|
- | 555 |
+ 556 |
|
|
- | 556 |
+ 557 |
! |
output$variables <- renderUI({
|
- | 557 |
+ 558 |
! |
choices <- split(x = vars_summary()$key, f = vars_summary()$label, drop = TRUE) %>% rev()
|
- | 558 |
+ 559 |
! |
selected <- choices <- unname(unlist(choices))
|
- | 559 |
+ 560 |
|
|
- | 560 |
+ 561 |
! |
teal.widgets::optionalSelectInput(
|
- | 561 |
+ 562 |
! |
ns("variables_select"),
|
- | 562 |
+ 563 |
! |
label = "Select variables",
|
- | 563 |
+ 564 |
! |
label_help = HTML(paste0("Dataset: ", tags$code(dataname))),
|
- | 564 |
+ 565 |
! |
choices = teal.transform::variable_choices(data_r(), choices),
|
- | 565 |
+ 566 |
! |
selected = selected,
|
- | 566 |
+ 567 |
! |
multiple = TRUE
|
- | 567 |
+ 568 |
|
)
|
- | 568 |
+ 569 |
|
})
|
- | 569 |
+ 570 |
|
|
- | 570 |
+ 571 |
! |
observeEvent(input$filter_na, {
|
- | 571 |
+ 572 |
! |
choices <- vars_summary() %>%
|
- | 572 |
+ 573 |
! |
dplyr::select(!!as.name("key")) %>%
|
- | 573 |
+ 574 |
! |
getElement(name = 1)
|
- | 574 |
+ 575 |
|
|
- | 575 |
+ 576 |
! |
selected <- vars_summary() %>%
|
- | 576 |
+ 577 |
! |
dplyr::filter(!!as.name("value") > 0) %>%
|
- | 577 |
+ 578 |
! |
dplyr::select(!!as.name("key")) %>%
|
- | 578 |
+ 579 |
! |
getElement(name = 1)
|
- | 579 |
+ 580 |
|
|
- | 580 |
+ 581 |
! |
teal.widgets::updateOptionalSelectInput(
|
- | 581 |
+ 582 |
! |
session = session,
|
- | 582 |
+ 583 |
! |
inputId = "variables_select",
|
- | 583 |
+ 584 |
! |
choices = teal.transform::variable_choices(data_r()),
|
- | 584 |
+ 585 |
! |
selected = restoreInput(ns("variables_select"), selected)
|
- | 585 |
+ 586 |
|
)
|
- | 586 |
+ 587 |
|
})
|
- | 587 |
+ 588 |
|
|
- | 588 |
+ 589 |
! |
output$group_by_var_ui <- renderUI({
|
- | 589 |
+ 590 |
! |
all_choices <- teal.transform::variable_choices(data_r())
|
- | 590 |
+ 591 |
! |
cat_choices <- all_choices[!sapply(data_r(), function(x) is.numeric(x) || inherits(x, "POSIXct"))]
|
- | 591 |
+ 592 |
! |
validate(
|
- | 592 |
+ 593 |
! |
need(cat_choices, "Dataset does not have any non-numeric or non-datetime variables to use to group data with")
|
- | 593 |
+ 594 |
|
)
|
- | 594 |
+ 595 |
! |
teal.widgets::optionalSelectInput(
|
- | 595 |
+ 596 |
! |
ns("group_by_var"),
|
- | 596 |
+ 597 |
! |
label = "Group by variable",
|
- | 597 |
+ 598 |
! |
choices = cat_choices,
|
- | 598 |
+ 599 |
! |
selected = `if`(
|
- | 599 |
+ 600 |
! |
is.null(isolate(input$group_by_var)),
|
- | 600 |
+ 601 |
! |
cat_choices[1],
|
- | 601 |
+ 602 |
! |
isolate(input$group_by_var)
|
- | 602 |
+ 603 |
|
),
|
- | 603 |
+ 604 |
! |
multiple = FALSE,
|
- | 604 |
+ 605 |
! |
label_help = paste0("Dataset: ", dataname)
|
- | 605 |
+ 606 |
|
)
|
- | 606 |
+ 607 |
|
})
|
- | 607 |
+ 608 |
|
|
- | 608 |
+ 609 |
! |
output$group_by_vals_ui <- renderUI({
|
- | 609 |
+ 610 |
! |
req(input$group_by_var)
|
- | 610 |
+ 611 |
|
|
- | 611 |
+ 612 |
! |
choices <- teal.transform::value_choices(data_r(), input$group_by_var, input$group_by_var)
|
- | 612 |
+ 613 |
! |
prev_choices <- isolate(input$group_by_vals)
|
- | 613 |
+ 614 |
|
|
- | 614 |
+ 615 |
|
# determine selected value based on filtered data
|
- | 615 |
+ 616 |
|
# display those previously selected values that are still available
|
- | 616 |
+ 617 |
! |
selected <- if (!is.null(prev_choices) && any(prev_choices %in% choices)) {
|
- | 617 |
+ 618 |
! |
prev_choices[match(choices[choices %in% prev_choices], prev_choices)]
|
- | 618 |
+ 619 |
! |
} else if (
|
- | 619 |
+ 620 |
! |
!is.null(prev_choices) &&
|
- | 620 |
+ 621 |
! |
!any(prev_choices %in% choices) &&
|
- | 621 |
+ 622 |
! |
isolate(prev_group_by_var()) == input$group_by_var
|
- | 622 |
+ 623 |
|
) {
|
- | 623 |
+ 624 |
|
# if not any previously selected value is available and the grouping variable is the same,
|
- | 624 |
+ 625 |
|
# then display NULL
|
- | 625 |
+ 626 |
! |
NULL
|
- | 626 |
+ 627 |
|
} else {
|
- | 627 |
+ 628 |
|
# if new grouping variable (i.e. not any previously selected value is available),
|
- | 628 |
+ 629 |
|
# then display all choices
|
- | 629 |
+ 630 |
! |
choices
|
- | 630 |
+ 631 |
|
}
|
- | 631 |
+ 632 |
|
|
- | 632 |
+ 633 |
! |
prev_group_by_var(input$group_by_var) # set current group_by_var
|
- | 633 |
+ 634 |
! |
validate(need(length(choices) < 100, "Please select group-by variable with fewer than 100 unique values"))
|
- | 634 |
+ 635 |
|
|
- | 635 |
+ 636 |
! |
teal.widgets::optionalSelectInput(
|
- | 636 |
+ 637 |
! |
ns("group_by_vals"),
|
- | 637 |
+ 638 |
! |
label = "Filter levels",
|
- | 638 |
+ 639 |
! |
choices = choices,
|
- | 639 |
+ 640 |
! |
selected = selected,
|
- | 640 |
+ 641 |
! |
multiple = TRUE,
|
- | 641 |
+ 642 |
! |
label_help = paste0("Dataset: ", dataname)
|
- | 642 |
+ 643 |
|
)
|
- | 643 |
+ 644 |
|
})
|
- | 644 |
+ 645 |
|
|
- | 645 |
+ 646 |
! |
summary_plot_q <- reactive({
|
- | 646 |
+ 647 |
! |
req(input$summary_type == "Summary") # needed to trigger show r code update on tab change
|
- | 647 |
+ 648 |
! |
teal::validate_has_data(data_r(), 1)
|
- | 648 |
+ 649 |
|
|
- | 649 |
+ 650 |
! |
qenv <- common_code_q()
|
- | 650 |
+ 651 |
|
|
- | 651 |
+ 652 |
! |
if (input$any_na) {
|
- | 652 |
+ 653 |
! |
new_col_name <- "**anyna**"
|
- | 653 |
+ 654 |
! |
qenv <- teal.code::eval_code(
|
- | 654 |
+ 655 |
! |
qenv,
|
- | 655 |
+ 656 |
! |
substitute(
|
- | 656 |
+ 657 |
! |
expr = ANL[[new_col_name]] <- ifelse(rowSums(is.na(ANL)) > 0, NA, FALSE),
|
- | 657 |
+ 658 |
! |
env = list(new_col_name = new_col_name)
|
- | 658 |
+ 659 |
|
)
|
- | 659 |
+ 660 |
|
)
|
- | 660 |
+ 661 |
|
}
|
- | 661 |
+ 662 |
|
|
- | 662 |
+ 663 |
! |
qenv <- teal.code::eval_code(
|
- | 663 |
+ 664 |
! |
qenv,
|
- | 664 |
+ 665 |
! |
substitute(
|
- | 665 |
+ 666 |
! |
expr = analysis_vars <- setdiff(colnames(ANL), data_keys),
|
- | 666 |
+ 667 |
! |
env = list(data_keys = data_keys())
|
- | 667 |
+ 668 |
|
)
|
- | 668 |
+ 669 |
|
) %>%
|
- | 669 |
+ 670 |
! |
teal.code::eval_code(
|
- | 670 |
+ 671 |
! |
substitute(
|
- | 671 |
+ 672 |
! |
expr = summary_plot_obs <- data_frame_call[, analysis_vars] %>%
|
- | 672 |
+ 673 |
! |
dplyr::summarise_all(list(function(x) sum(is.na(x)))) %>%
|
- | 673 |
+ 674 |
! |
tidyr::pivot_longer(dplyr::everything(), names_to = "col", values_to = "n_na") %>%
|
- | 674 |
+ 675 |
! |
dplyr::mutate(n_not_na = nrow(ANL) - n_na) %>%
|
- | 675 |
+ 676 |
! |
tidyr::pivot_longer(-col, names_to = "isna", values_to = "n") %>%
|
- | 676 |
+ 677 |
! |
dplyr::mutate(isna = isna == "n_na", n_pct = n / nrow(ANL) * 100),
|
- | 677 |
+ 678 |
! |
env = list(data_frame_call = if (!inherits(data_r(), "tbl_df")) {
|
- | 678 |
+ 679 |
! |
quote(tibble::as_tibble(ANL))
|
- | 679 |
+ 680 |
|
} else {
|
- | 680 |
+ 681 |
! |
quote(ANL)
|
- | 681 |
+ 682 |
|
})
|
- | 682 |
+ 683 |
|
)
|
- | 683 |
+ 684 |
|
) %>%
|
- | 684 |
+ 685 |
|
# x axis ordering according to number of missing values and alphabet
|
- | 685 |
+ 686 |
! |
teal.code::eval_code(
|
- | 686 |
+ 687 |
! |
quote(
|
- | 687 |
+ 688 |
! |
expr = x_levels <- dplyr::filter(summary_plot_obs, isna) %>%
|
- | 688 |
+ 689 |
! |
dplyr::arrange(n_pct, dplyr::desc(col)) %>%
|
- | 689 |
+ 690 |
! |
dplyr::pull(col) %>%
|
- | 690 |
+ 691 |
! |
create_cols_labels()
|
- | 691 |
+ 692 |
|
)
|
- | 692 |
+ 693 |
|
)
|
- | 693 |
+ 694 |
|
|
- | 694 |
+ 695 |
|
# always set "**anyna**" level as the last one
|
- | 695 |
+ 696 |
! |
if (isolate(input$any_na)) {
|
- | 696 |
+ 697 |
! |
qenv <- teal.code::eval_code(
|
- | 697 |
+ 698 |
! |
qenv,
|
- | 698 |
+ 699 |
! |
quote(x_levels <- c(setdiff(x_levels, "**anyna**"), "**anyna**"))
|
- | 699 |
+ 700 |
|
)
|
- | 700 |
+ 701 |
|
}
|
- | 701 |
+ 702 |
|
|
- | 702 |
+ 703 |
! |
dev_ggplot2_args <- teal.widgets::ggplot2_args(
|
- | 703 |
+ 704 |
! |
labs = list(x = "Variable", y = "Missing observations"),
|
- | 704 |
+ 705 |
! |
theme = list(legend.position = "bottom", axis.text.x = quote(element_text(angle = 45, hjust = 1)))
|
- | 705 |
+ 706 |
|
)
|
- | 706 |
+ 707 |
|
|
- | 707 |
+ 708 |
! |
all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
|
- | 708 |
+ 709 |
! |
user_plot = ggplot2_args[["Summary Obs"]],
|
- | 709 |
+ 710 |
! |
user_default = ggplot2_args$default,
|
- | 710 |
+ 711 |
! |
module_plot = dev_ggplot2_args
|
- | 711 |
+ 712 |
|
)
|
- | 712 |
+ 713 |
|
|
- | 713 |
+ 714 |
! |
parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
|
- | 714 |
+ 715 |
! |
all_ggplot2_args,
|
- | 715 |
+ 716 |
! |
ggtheme = input$ggtheme
|
- | 716 |
+ 717 |
|
)
|
- | 717 |
+ 718 |
|
|
- | 718 |
+ 719 |
! |
qenv <- teal.code::eval_code(
|
- | 719 |
+ 720 |
! |
qenv,
|
- | 720 |
+ 721 |
! |
substitute(
|
- | 721 |
+ 722 |
! |
p1 <- summary_plot_obs %>%
|
- | 722 |
+ 723 |
! |
ggplot() +
|
- | 723 |
+ 724 |
! |
aes(
|
- | 724 |
+ 725 |
! |
x = factor(create_cols_labels(col), levels = x_levels),
|
- | 725 |
+ 726 |
! |
y = n_pct,
|
- | 726 |
+ 727 |
! |
fill = isna
|
- | 727 |
+ 728 |
|
) +
|
- | 728 |
+ 729 |
! |
geom_bar(position = "fill", stat = "identity") +
|
- | 729 |
+ 730 |
! |
scale_fill_manual(
|
- | 730 |
+ 731 |
! |
name = "",
|
- | 731 |
+ 732 |
! |
values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
|
- | 732 |
+ 733 |
! |
labels = c("Present", "Missing")
|
- | 733 |
+ 734 |
|
) +
|
- | 734 |
+ 735 |
! |
scale_y_continuous(
|
- | 735 |
+ 736 |
! |
labels = scales::percent_format(),
|
- | 736 |
+ 737 |
! |
breaks = seq(0, 1, by = 0.1),
|
- | 737 |
+ 738 |
! |
expand = c(0, 0)
|
- | 738 |
+ 739 |
|
) +
|
- | 739 |
+ 740 |
! |
geom_text(
|
- | 740 |
+ 741 |
! |
aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),
|
- | 741 |
+ 742 |
! |
hjust = 1,
|
- | 742 |
+ 743 |
! |
color = "black"
|
- | 743 |
+ 744 |
|
) +
|
- | 744 |
+ 745 |
! |
labs +
|
- | 745 |
+ 746 |
! |
ggthemes +
|
- | 746 |
+ 747 |
! |
themes +
|
- | 747 |
+ 748 |
! |
coord_flip(),
|
- | 748 |
+ 749 |
! |
env = list(
|
- | 749 |
+ 750 |
! |
labs = parsed_ggplot2_args$labs,
|
- | 750 |
+ 751 |
! |
themes = parsed_ggplot2_args$theme,
|
- | 751 |
+ 752 |
! |
ggthemes = parsed_ggplot2_args$ggtheme
|
- | 752 |
+ 753 |
|
)
|
- | 753 |
+ 754 |
|
)
|
- | 754 |
+ 755 |
|
)
|
- | 755 |
+ 756 |
|
|
- | 756 |
+ 757 |
! |
if (isTRUE(input$if_patients_plot)) {
|
- | 757 |
+ 758 |
! |
qenv <- teal.code::eval_code(
|
- | 758 |
+ 759 |
! |
qenv,
|
- | 759 |
+ 760 |
! |
substitute(
|
- | 760 |
+ 761 |
! |
expr = parent_keys <- keys,
|
- | 761 |
+ 762 |
! |
env = list(keys = data_parent_keys())
|
- | 762 |
+ 763 |
|
)
|
- | 763 |
+ 764 |
|
) %>%
|
- | 764 |
+ 765 |
! |
teal.code::eval_code(quote(ndistinct_subjects <- dplyr::n_distinct(ANL[, parent_keys]))) %>%
|
- | 765 |
+ 766 |
! |
teal.code::eval_code(
|
- | 766 |
+ 767 |
! |
quote(
|
- | 767 |
+ 768 |
! |
summary_plot_patients <- ANL[, c(parent_keys, analysis_vars)] %>%
|
- | 768 |
+ 769 |
! |
dplyr::group_by_at(parent_keys) %>%
|
- | 769 |
+ 770 |
! |
dplyr::summarise_all(anyNA) %>%
|
- | 770 |
+ 771 |
! |
tidyr::pivot_longer(cols = !dplyr::all_of(parent_keys), names_to = "col", values_to = "anyna") %>%
|
- | 771 |
+ 772 |
! |
dplyr::group_by_at(c("col")) %>%
|
- | 772 |
+ 773 |
! |
dplyr::summarise(count_na = sum(anyna)) %>%
|
- | 773 |
+ 774 |
! |
dplyr::mutate(count_not_na = ndistinct_subjects - count_na) %>%
|
- | 774 |
+ 775 |
! |
tidyr::pivot_longer(-c(col), names_to = "isna", values_to = "n") %>%
|
- | 775 |
+ 776 |
! |
dplyr::mutate(isna = isna == "count_na", n_pct = n / ndistinct_subjects * 100) %>%
|
- | 776 |
+ 777 |
! |
dplyr::arrange_at(c("isna", "n"), .funs = dplyr::desc)
|
- | 777 |
+ 778 |
|
)
|
- | 778 |
+ 779 |
|
)
|
- | 779 |
+ 780 |
|
|
- | 780 |
+ 781 |
! |
dev_ggplot2_args <- teal.widgets::ggplot2_args(
|
- | 781 |
+ 782 |
! |
labs = list(x = "", y = "Missing patients"),
|
- | 782 |
+ 783 |
! |
theme = list(
|
- | 783 |
+ 784 |
! |
legend.position = "bottom",
|
- | 784 |
+ 785 |
! |
axis.text.x = quote(element_text(angle = 45, hjust = 1)),
|
- | 785 |
+ 786 |
! |
axis.text.y = quote(element_blank())
|
- | 786 |
+ 787 |
|
)
|
- | 787 |
+ 788 |
|
)
|
- | 788 |
+ 789 |
|
|
- | 789 |
+ 790 |
! |
all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
|
- | 790 |
+ 791 |
! |
user_plot = ggplot2_args[["Summary Patients"]],
|
- | 791 |
+ 792 |
! |
user_default = ggplot2_args$default,
|
- | 792 |
+ 793 |
! |
module_plot = dev_ggplot2_args
|
- | 793 |
+ 794 |
|
)
|
- | 794 |
+ 795 |
|
|
- | 795 |
+ 796 |
! |
parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
|
- | 796 |
+ 797 |
! |
all_ggplot2_args,
|
- | 797 |
+ 798 |
! |
ggtheme = input$ggtheme
|
- | 798 |
+ 799 |
|
)
|
- | 799 |
+ 800 |
|
|
- | 800 |
+ 801 |
! |
qenv <- teal.code::eval_code(
|
- | 801 |
+ 802 |
! |
qenv,
|
- | 802 |
+ 803 |
! |
substitute(
|
- | 803 |
+ 804 |
! |
p2 <- summary_plot_patients %>%
|
- | 804 |
+ 805 |
! |
ggplot() +
|
- | 805 |
+ 806 |
! |
aes_(
|
- | 806 |
+ 807 |
! |
x = ~ factor(create_cols_labels(col), levels = x_levels),
|
- | 807 |
+ 808 |
! |
y = ~n_pct,
|
- | 808 |
+ 809 |
! |
fill = ~isna
|
- | 809 |
+ 810 |
|
) +
|
- | 810 |
+ 811 |
! |
geom_bar(alpha = 1, stat = "identity", position = "fill") +
|
- | 811 |
+ 812 |
! |
scale_y_continuous(
|
- | 812 |
+ 813 |
! |
labels = scales::percent_format(),
|
- | 813 |
+ 814 |
! |
breaks = seq(0, 1, by = 0.1),
|
- | 814 |
+ 815 |
! |
expand = c(0, 0)
|
- | 815 |
+ 816 |
|
) +
|
- | 816 |
+ 817 |
! |
scale_fill_manual(
|
- | 817 |
+ 818 |
! |
name = "",
|
- | 818 |
+ 819 |
! |
values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
|
- | 819 |
+ 820 |
! |
labels = c("Present", "Missing")
|
- | 820 |
+ 821 |
|
) +
|
- | 821 |
+ 822 |
! |
geom_text(
|
- | 822 |
+ 823 |
! |
aes(label = ifelse(isna == TRUE, sprintf("%d [%.02f%%]", n, n_pct), ""), y = 1),
|
- | 823 |
+ 824 |
! |
hjust = 1,
|
- | 824 |
+ 825 |
! |
color = "black"
|
- | 825 |
+ 826 |
|
) +
|
- | 826 |
+ 827 |
! |
labs +
|
- | 827 |
+ 828 |
! |
ggthemes +
|
- | 828 |
+ 829 |
! |
themes +
|
- | 829 |
+ 830 |
! |
coord_flip(),
|
- | 830 |
+ 831 |
! |
env = list(
|
- | 831 |
+ 832 |
! |
labs = parsed_ggplot2_args$labs,
|
- | 832 |
+ 833 |
! |
themes = parsed_ggplot2_args$theme,
|
- | 833 |
+ 834 |
! |
ggthemes = parsed_ggplot2_args$ggtheme
|
- | 834 |
+ 835 |
|
)
|
- | 835 |
+ 836 |
|
)
|
- | 836 |
+ 837 |
|
) %>%
|
- | 837 |
+ 838 |
! |
teal.code::eval_code(
|
- | 838 |
+ 839 |
! |
quote({
|
- | 839 |
+ 840 |
! |
g1 <- ggplotGrob(p1)
|
- | 840 |
+ 841 |
! |
g2 <- ggplotGrob(p2)
|
- | 841 |
+ 842 |
! |
g <- gridExtra::gtable_cbind(g1, g2, size = "first")
|
- | 842 |
+ 843 |
! |
g$heights <- grid::unit.pmax(g1$heights, g2$heights)
|
- | 843 |
+ 844 |
! |
grid::grid.newpage()
|
- | 844 |
+ 845 |
|
})
|
- | 845 |
+ 846 |
|
)
|
- | 846 |
+ 847 |
|
} else {
|
- | 847 |
+ 848 |
! |
qenv <- teal.code::eval_code(
|
- | 848 |
+ 849 |
! |
qenv,
|
- | 849 |
+ 850 |
! |
quote({
|
- | 850 |
+ 851 |
! |
g <- ggplotGrob(p1)
|
- | 851 |
+ 852 |
! |
grid::grid.newpage()
|
- | 852 |
+ 853 |
|
})
|
- | 853 |
+ 854 |
|
)
|
- | 854 |
+ 855 |
|
}
|
- | 855 |
+ 856 |
|
|
- | 856 |
+ 857 |
! |
teal.code::eval_code(
|
- | 857 |
+ 858 |
! |
qenv,
|
- | 858 |
+ 859 |
! |
quote(grid::grid.draw(g))
|
- | 859 |
+ 860 |
|
)
|
- | 860 |
+ 861 |
|
})
|
- | 861 |
+ 862 |
|
|
- | 862 |
+ 863 |
! |
summary_plot_r <- reactive(summary_plot_q()[["g"]])
|
- | 863 |
+ 864 |
|
|
- | 864 |
+ 865 |
! |
combination_cutoff_q <- reactive({
|
- | 865 |
+ 866 |
! |
req(common_code_q())
|
- | 866 |
+ 867 |
! |
teal.code::eval_code(
|
- | 867 |
+ 868 |
! |
common_code_q(),
|
- | 868 |
+ 869 |
! |
quote(
|
- | 869 |
+ 870 |
! |
combination_cutoff <- ANL %>%
|
- | 870 |
+ 871 |
! |
dplyr::mutate_all(is.na) %>%
|
- | 871 |
+ 872 |
! |
dplyr::group_by_all() %>%
|
- | 872 |
+ 873 |
! |
dplyr::tally() %>%
|
- | 873 |
+ 874 |
! |
dplyr::ungroup()
|
- | 874 |
+ 875 |
|
)
|
- | 875 |
+ 876 |
|
)
|
- | 876 |
+ 877 |
|
})
|
- | 877 |
+ 878 |
|
|
- | 878 |
+ 879 |
! |
output$cutoff <- renderUI({
|
- | 879 |
+ 880 |
! |
x <- combination_cutoff_q()[["combination_cutoff"]]$n
|
- | 880 |
+ 881 |
|
|
- | 881 |
+ 882 |
|
# select 10-th from the top
|
- | 882 |
+ 883 |
! |
n <- length(x)
|
- | 883 |
+ 884 |
! |
idx <- max(1, n - 10)
|
- | 884 |
+ 885 |
! |
prev_value <- isolate(input$combination_cutoff)
|
- | 885 |
+ 886 |
! |
value <- `if`(
|
- | 886 |
+ 887 |
! |
is.null(prev_value) || prev_value > max(x) || prev_value < min(x),
|
- | 887 |
+ 888 |
! |
sort(x, partial = idx)[idx], prev_value
|
- | 888 |
+ 889 |
|
)
|
- | 889 |
+ 890 |
|
|
- | 890 |
+ 891 |
! |
teal.widgets::optionalSliderInputValMinMax(
|
- | 891 |
+ 892 |
! |
ns("combination_cutoff"),
|
- | 892 |
+ 893 |
! |
"Combination cut-off",
|
- | 893 |
+ 894 |
! |
c(value, range(x))
|
- | 894 |
+ 895 |
|
)
|
- | 895 |
+ 896 |
|
})
|
- | 896 |
+ 897 |
|
|
- | 897 |
+ 898 |
! |
combination_plot_q <- reactive({
|
- | 898 |
+ 899 |
! |
req(input$summary_type == "Combinations", input$combination_cutoff, combination_cutoff_q())
|
- | 899 |
+ 900 |
! |
teal::validate_has_data(data_r(), 1)
|
- | 900 |
+ 901 |
|
|
- | 901 |
+ 902 |
! |
qenv <- teal.code::eval_code(
|
- | 902 |
+ 903 |
! |
combination_cutoff_q(),
|
- | 903 |
+ 904 |
! |
substitute(
|
- | 904 |
+ 905 |
! |
expr = data_combination_plot_cutoff <- combination_cutoff %>%
|
- | 905 |
+ 906 |
! |
dplyr::filter(n >= combination_cutoff_value) %>%
|
- | 906 |
+ 907 |
! |
dplyr::mutate(id = rank(-n, ties.method = "first")) %>%
|
- | 907 |
+ 908 |
! |
tidyr::pivot_longer(-c(n, id), names_to = "key", values_to = "value") %>%
|
- | 908 |
+ 909 |
! |
dplyr::arrange(n),
|
- | 909 |
+ 910 |
! |
env = list(combination_cutoff_value = input$combination_cutoff)
|
- | 910 |
+ 911 |
|
)
|
- | 911 |
+ 912 |
|
)
|
- | 912 |
+ 913 |
|
|
- | 913 |
+ 914 |
|
# find keys in dataset not selected in the UI and remove them from dataset
|
- | 914 |
+ 915 |
! |
keys_not_selected <- setdiff(data_keys(), input$variables_select)
|
- | 915 |
+ 916 |
! |
if (length(keys_not_selected) > 0) {
|
- | 916 |
+ 917 |
! |
qenv <- teal.code::eval_code(
|
- | 917 |
+ 918 |
! |
qenv,
|
- | 918 |
+ 919 |
! |
substitute(
|
- | 919 |
+ 920 |
! |
expr = data_combination_plot_cutoff <- data_combination_plot_cutoff %>%
|
- | 920 |
+ 921 |
! |
dplyr::filter(!key %in% keys_not_selected),
|
- | 921 |
+ 922 |
! |
env = list(keys_not_selected = keys_not_selected)
|
- | 922 |
+ 923 |
|
)
|
- | 923 |
+ 924 |
|
)
|
- | 924 |
+ 925 |
|
}
|
- | 925 |
+ 926 |
|
|
- | 926 |
+ 927 |
! |
qenv <- teal.code::eval_code(
|
- | 927 |
+ 928 |
! |
qenv,
|
- | 928 |
+ 929 |
! |
quote(
|
- | 929 |
+ 930 |
! |
labels <- data_combination_plot_cutoff %>%
|
- | 930 |
+ 931 |
! |
dplyr::filter(key == key[[1]]) %>%
|
- | 931 |
+ 932 |
! |
getElement(name = 1)
|
- | 932 |
+ 933 |
|
)
|
- | 933 |
+ 934 |
|
)
|
- | 934 |
+ 935 |
|
|
- | 935 |
+ 936 |
! |
dev_ggplot2_args1 <- teal.widgets::ggplot2_args(
|
- | 936 |
+ 937 |
! |
labs = list(x = "", y = ""),
|
- | 937 |
+ 938 |
! |
theme = list(
|
- | 938 |
+ 939 |
! |
legend.position = "bottom",
|
- | 939 |
+ 940 |
! |
axis.text.x = quote(element_blank())
|
- | 940 |
+ 941 |
|
)
|
- | 941 |
+ 942 |
|
)
|
- | 942 |
+ 943 |
|
|
- | 943 |
+ 944 |
! |
all_ggplot2_args1 <- teal.widgets::resolve_ggplot2_args(
|
- | 944 |
+ 945 |
! |
user_plot = ggplot2_args[["Combinations Hist"]],
|
- | 945 |
+ 946 |
! |
user_default = ggplot2_args$default,
|
- | 946 |
+ 947 |
! |
module_plot = dev_ggplot2_args1
|
- | 947 |
+ 948 |
|
)
|
- | 948 |
+ 949 |
|
|
- | 949 |
+ 950 |
! |
parsed_ggplot2_args1 <- teal.widgets::parse_ggplot2_args(
|
- | 950 |
+ 951 |
! |
all_ggplot2_args1,
|
- | 951 |
+ 952 |
! |
ggtheme = "void"
|
- | 952 |
+ 953 |
|
)
|
- | 953 |
+ 954 |
|
|
- | 954 |
+ 955 |
! |
dev_ggplot2_args2 <- teal.widgets::ggplot2_args(
|
- | 955 |
+ 956 |
! |
labs = list(x = "", y = ""),
|
- | 956 |
+ 957 |
! |
theme = list(
|
- | 957 |
+ 958 |
! |
legend.position = "bottom",
|
- | 958 |
+ 959 |
! |
axis.text.x = quote(element_blank()),
|
- | 959 |
+ 960 |
! |
axis.ticks = quote(element_blank()),
|
- | 960 |
+ 961 |
! |
panel.grid.major = quote(element_blank())
|
- | 961 |
+ 962 |
|
)
|
- | 962 |
+ 963 |
|
)
|
- | 963 |
+ 964 |
|
|
- | 964 |
+ 965 |
! |
all_ggplot2_args2 <- teal.widgets::resolve_ggplot2_args(
|
- | 965 |
+ 966 |
! |
user_plot = ggplot2_args[["Combinations Main"]],
|
- | 966 |
+ 967 |
! |
user_default = ggplot2_args$default,
|
- | 967 |
+ 968 |
! |
module_plot = dev_ggplot2_args2
|
- | 968 |
+ 969 |
|
)
|
- | 969 |
+ 970 |
|
|
- | 970 |
+ 971 |
! |
parsed_ggplot2_args2 <- teal.widgets::parse_ggplot2_args(
|
- | 971 |
+ 972 |
! |
all_ggplot2_args2,
|
- | 972 |
+ 973 |
! |
ggtheme = input$ggtheme
|
- | 973 |
+ 974 |
|
)
|
- | 974 |
+ 975 |
|
|
- | 975 |
+ 976 |
! |
teal.code::eval_code(
|
- | 976 |
+ 977 |
! |
qenv,
|
- | 977 |
+ 978 |
! |
substitute(
|
- | 978 |
+ 979 |
! |
expr = {
|
- | 979 |
+ 980 |
! |
p1 <- data_combination_plot_cutoff %>%
|
- | 980 |
+ 981 |
! |
dplyr::select(id, n) %>%
|
- | 981 |
+ 982 |
! |
dplyr::distinct() %>%
|
- | 982 |
+ 983 |
! |
ggplot(aes(x = id, y = n)) +
|
- | 983 |
+ 984 |
! |
geom_bar(stat = "identity", fill = c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]) +
|
- | 984 |
+ 985 |
! |
geom_text(
|
- | 985 |
+ 986 |
! |
aes(label = n),
|
- | 986 |
+ 987 |
! |
position = position_dodge(width = 0.9),
|
- | 987 |
+ 988 |
! |
vjust = -0.25
|
- | 988 |
+ 989 |
|
) +
|
- | 989 |
+ 990 |
! |
ylim(c(0, max(data_combination_plot_cutoff$n) * 1.5)) +
|
- | 990 |
+ 991 |
! |
labs1 +
|
- | 991 |
+ 992 |
! |
ggthemes1 +
|
- | 992 |
+ 993 |
! |
themes1
|
- | 993 |
+ 994 |
|
|
- | 994 |
+ 995 |
! |
graph_number_rows <- length(unique(data_combination_plot_cutoff$id))
|
- | 995 |
+ 996 |
! |
graph_number_cols <- nrow(data_combination_plot_cutoff) / graph_number_rows
|
- | 996 |
+ 997 |
|
|
- | 997 |
+ 998 |
! |
p2 <- data_combination_plot_cutoff %>% ggplot() +
|
- | 998 |
+ 999 |
! |
aes(x = create_cols_labels(key), y = id - 0.5, fill = value) +
|
- | 999 |
+ 1000 |
! |
geom_tile(alpha = 0.85, height = 0.95) +
|
- | 1000 |
+ 1001 |
! |
scale_fill_manual(
|
- | 1001 |
+ 1002 |
! |
name = "",
|
- | 1002 |
+ 1003 |
! |
values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
|
- | 1003 |
+ 1004 |
! |
labels = c("Present", "Missing")
|
- | 1004 |
+ 1005 |
|
) +
|
- | 1005 |
+ 1006 |
! |
geom_hline(yintercept = seq_len(1 + graph_number_rows) - 1) +
|
- | 1006 |
+ 1007 |
! |
geom_vline(xintercept = seq_len(1 + graph_number_cols) - 0.5, linetype = "dotted") +
|
- | 1007 |
+ 1008 |
! |
coord_flip() +
|
- | 1008 |
+ 1009 |
! |
labs2 +
|
- | 1009 |
+ 1010 |
! |
ggthemes2 +
|
- | 1010 |
+ 1011 |
! |
themes2
|
- | 1011 |
+ 1012 |
|
|
- | 1012 |
+ 1013 |
! |
g1 <- ggplotGrob(p1)
|
- | 1013 |
+ 1014 |
! |
g2 <- ggplotGrob(p2)
|
- | 1014 |
+ 1015 |
|
|
- | 1015 |
+ 1016 |
! |
g <- gridExtra::gtable_rbind(g1, g2, size = "last")
|
- | 1016 |
+ 1017 |
! |
g$heights[7] <- grid::unit(0.2, "null") # rescale to get the bar chart smaller
|
- | 1017 |
+ 1018 |
! |
grid::grid.newpage()
|
- | 1018 |
+ 1019 |
! |
grid::grid.draw(g)
|
- | 1019 |
+ 1020 |
|
},
|
- | 1020 |
+ 1021 |
! |
env = list(
|
- | 1021 |
+ 1022 |
! |
labs1 = parsed_ggplot2_args1$labs,
|
- | 1022 |
+ 1023 |
! |
themes1 = parsed_ggplot2_args1$theme,
|
- | 1023 |
+ 1024 |
! |
ggthemes1 = parsed_ggplot2_args1$ggtheme,
|
- | 1024 |
+ 1025 |
! |
labs2 = parsed_ggplot2_args2$labs,
|
- | 1025 |
+ 1026 |
! |
themes2 = parsed_ggplot2_args2$theme,
|
- | 1026 |
+ 1027 |
! |
ggthemes2 = parsed_ggplot2_args2$ggtheme
|
- | 1027 |
+ 1028 |
|
)
|
- | 1028 |
+ 1029 |
|
)
|
- | 1029 |
+ 1030 |
|
)
|
- | 1030 |
+ 1031 |
|
})
|
- | 1031 |
+ 1032 |
|
|
- | 1032 |
+ 1033 |
! |
combination_plot_r <- reactive(combination_plot_q()[["g"]])
|
- | 1033 |
+ 1034 |
|
|
- | 1034 |
+ 1035 |
! |
summary_table_q <- reactive({
|
- | 1035 |
+ 1036 |
! |
req(
|
- | 1036 |
+ 1037 |
! |
input$summary_type == "By Variable Levels", # needed to trigger show r code update on tab change
|
- | 1037 |
+ 1038 |
! |
common_code_q()
|
- | 1038 |
+ 1039 |
|
)
|
- | 1039 |
+ 1040 |
! |
teal::validate_has_data(data_r(), 1)
|
- | 1040 |
+ 1041 |
|
|
- | 1041 |
+ 1042 |
|
# extract the ANL dataset for use in further validation
|
- | 1042 |
+ 1043 |
! |
anl <- common_code_q()[["ANL"]]
|
- | 1043 |
+ 1044 |
|
|
- | 1044 |
+ 1045 |
! |
group_var <- input$group_by_var
|
- | 1045 |
+ 1046 |
! |
validate(
|
- | 1046 |
+ 1047 |
! |
need(
|
- | 1047 |
+ 1048 |
! |
is.null(group_var) ||
|
- | 1048 |
+ 1049 |
! |
length(unique(anl[[group_var]])) < 100,
|
- | 1049 |
+ 1050 |
! |
"Please select group-by variable with fewer than 100 unique values"
|
- | 1050 |
+ 1051 |
|
)
|
- | 1051 |
+ 1052 |
|
)
|
- | 1052 |
+ 1053 |
|
|
- | 1053 |
+ 1054 |
! |
group_vals <- input$group_by_vals
|
- | 1054 |
+ 1055 |
! |
variables_select <- input$variables_select
|
- | 1055 |
+ 1056 |
! |
vars <- unique(variables_select, group_var)
|
- | 1056 |
+ 1057 |
! |
count_type <- input$count_type
|
- | 1057 |
+ 1058 |
|
|
- | 1058 |
+ 1059 |
! |
if (!is.null(selected_vars()) && length(selected_vars()) != ncol(anl)) {
|
- | 1059 |
+ 1060 |
! |
variables <- selected_vars()
|
- | 1060 |
+ 1061 |
|
} else {
|
- | 1061 |
+ 1062 |
! |
variables <- colnames(anl)
|
- | 1062 |
+ 1063 |
|
}
|
- | 1063 |
+ 1064 |
|
|
- | 1064 |
+ 1065 |
! |
summ_fn <- if (input$count_type == "counts") {
|
- | 1065 |
+ 1066 |
! |
function(x) sum(is.na(x))
|
- | 1066 |
+ 1067 |
|
} else {
|
- | 1067 |
+ 1068 |
! |
function(x) round(sum(is.na(x)) / length(x), 4)
|
- | 1068 |
+ 1069 |
|
}
|
- | 1069 |
+ 1070 |
|
|
- | 1070 |
+ 1071 |
! |
qenv <- common_code_q()
|
- | 1071 |
+ 1072 |
|
|
- | 1072 |
+ 1073 |
! |
if (!is.null(group_var)) {
|
- | 1073 |
+ 1074 |
! |
qenv <- teal.code::eval_code(
|
- | 1074 |
+ 1075 |
! |
qenv,
|
- | 1075 |
+ 1076 |
! |
substitute(
|
- | 1076 |
+ 1077 |
! |
expr = {
|
- | 1077 |
+ 1078 |
! |
summary_data <- ANL %>%
|
- | 1078 |
+ 1079 |
! |
dplyr::mutate(group_var_name := forcats::fct_na_value_to_level(as.factor(group_var_name), "NA")) %>%
|
- | 1079 |
+ 1080 |
! |
dplyr::group_by_at(group_var) %>%
|
- | 1080 |
+ 1081 |
! |
dplyr::filter(group_var_name %in% group_vals)
|
- | 1081 |
+ 1082 |
|
|
- | 1082 |
+ 1083 |
! |
count_data <- dplyr::summarise(summary_data, n = dplyr::n())
|
- | 1083 |
+ 1084 |
|
|
- | 1084 |
+ 1085 |
! |
summary_data <- dplyr::summarise_all(summary_data, summ_fn) %>%
|
- | 1085 |
+ 1086 |
! |
dplyr::mutate(group_var_name := paste0(group_var, ":", group_var_name, "(N=", count_data$n, ")")) %>%
|
- | 1086 |
+ 1087 |
! |
tidyr::pivot_longer(!dplyr::all_of(group_var), names_to = "Variable", values_to = "out") %>%
|
- | 1087 |
+ 1088 |
! |
tidyr::pivot_wider(names_from = group_var, values_from = "out") %>%
|
- | 1088 |
+ 1089 |
! |
dplyr::mutate(`Variable label` = create_cols_labels(Variable, just_label = TRUE), .after = Variable)
|
- | 1089 |
+ 1090 |
|
},
|
- | 1090 |
+ 1091 |
! |
env = list(
|
- | 1091 |
+ 1092 |
! |
group_var = group_var, group_var_name = as.name(group_var), group_vals = group_vals, summ_fn = summ_fn
|
- | 1092 |
+ 1093 |
|
)
|
- | 1093 |
+ 1094 |
|
)
|
- | 1094 |
+ 1095 |
|
)
|
- | 1095 |
+ 1096 |
|
} else {
|
- | 1096 |
+ 1097 |
! |
qenv <- teal.code::eval_code(
|
- | 1097 |
+ 1098 |
! |
qenv,
|
- | 1098 |
+ 1099 |
! |
substitute(
|
- | 1099 |
+ 1100 |
! |
expr = summary_data <- ANL %>%
|
- | 1100 |
+ 1101 |
! |
dplyr::summarise_all(summ_fn) %>%
|
- | 1101 |
+ 1102 |
! |
tidyr::pivot_longer(dplyr::everything(),
|
- | 1102 |
+ 1103 |
! |
names_to = "Variable",
|
- | 1103 |
+ 1104 |
! |
values_to = paste0("Missing (N=", nrow(ANL), ")")
|
- | 1104 |
+ 1105 |
|
) %>%
|
- | 1105 |
+ 1106 |
! |
dplyr::mutate(`Variable label` = create_cols_labels(Variable), .after = Variable),
|
- | 1106 |
+ 1107 |
! |
env = list(summ_fn = summ_fn)
|
- | 1107 |
+ 1108 |
|
)
|
- | 1108 |
+ 1109 |
|
)
|
- | 1109 |
+ 1110 |
|
}
|
- | 1110 |
+ 1111 |
|
|
- | 1111 |
+ 1112 |
! |
teal.code::eval_code(qenv, quote(summary_data))
|
- | 1112 |
+ 1113 |
|
})
|
- | 1113 |
+ 1114 |
|
|
- | 1114 |
+ 1115 |
! |
summary_table_r <- reactive(summary_table_q()[["summary_data"]])
|
- | 1115 |
+ 1116 |
|
|
- | 1116 |
+ 1117 |
! |
by_subject_plot_q <- reactive({
|
- | 1117 |
+ 1118 |
|
# needed to trigger show r code update on tab change
|
- | 1118 |
+ 1119 |
! |
req(input$summary_type == "Grouped by Subject", common_code_q())
|
- | 1119 |
+ 1120 |
|
|
- | 1120 |
+ 1121 |
! |
teal::validate_has_data(data_r(), 1)
|
- | 1121 |
+ 1122 |
|
|
- | 1122 |
+ 1123 |
! |
dev_ggplot2_args <- teal.widgets::ggplot2_args(
|
- | 1123 |
+ 1124 |
! |
labs = list(x = "", y = ""),
|
- | 1124 |
+ 1125 |
! |
theme = list(legend.position = "bottom", axis.text.x = quote(element_blank()))
|
- | 1125 |
+ 1126 |
|
)
|
- | 1126 |
+ 1127 |
|
|
- | 1127 |
+ 1128 |
! |
all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
|
- | 1128 |
+ 1129 |
! |
user_plot = ggplot2_args[["By Subject"]],
|
- | 1129 |
+ 1130 |
! |
user_default = ggplot2_args$default,
|
- | 1130 |
+ 1131 |
! |
module_plot = dev_ggplot2_args
|
- | 1131 |
+ 1132 |
|
)
|
- | 1132 |
+ 1133 |
|
|
- | 1133 |
+ 1134 |
! |
parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
|
- | 1134 |
+ 1135 |
! |
all_ggplot2_args,
|
- | 1135 |
+ 1136 |
! |
ggtheme = input$ggtheme
|
- | 1136 |
+ 1137 |
|
)
|
- | 1137 |
+ 1138 |
|
|
- | 1138 |
+ 1139 |
! |
teal.code::eval_code(
|
- | 1139 |
+ 1140 |
! |
common_code_q(),
|
- | 1140 |
+ 1141 |
! |
substitute(
|
- | 1141 |
+ 1142 |
! |
expr = parent_keys <- keys,
|
- | 1142 |
+ 1143 |
! |
env = list(keys = data_parent_keys())
|
- | 1143 |
+ 1144 |
|
)
|
- | 1144 |
+ 1145 |
|
) %>%
|
- | 1145 |
+ 1146 |
! |
teal.code::eval_code(
|
- | 1146 |
+ 1147 |
! |
substitute(
|
- | 1147 |
+ 1148 |
! |
expr = analysis_vars <- setdiff(colnames(ANL), data_keys),
|
- | 1148 |
+ 1149 |
! |
env = list(data_keys = data_keys())
|
- | 1149 |
+ 1150 |
|
)
|
- | 1150 |
+ 1151 |
|
) %>%
|
- | 1151 |
+ 1152 |
! |
teal.code::eval_code(
|
- | 1152 |
+ 1153 |
! |
quote({
|
- | 1153 |
+ 1154 |
! |
summary_plot_patients <- ANL[, c(parent_keys, analysis_vars)] %>%
|
- | 1154 |
+ 1155 |
! |
dplyr::group_by_at(parent_keys) %>%
|
- | 1155 |
+ 1156 |
! |
dplyr::mutate(id = dplyr::cur_group_id()) %>%
|
- | 1156 |
+ 1157 |
! |
dplyr::ungroup() %>%
|
- | 1157 |
+ 1158 |
! |
dplyr::group_by_at(c(parent_keys, "id")) %>%
|
- | 1158 |
+ 1159 |
! |
dplyr::summarise_all(anyNA) %>%
|
- | 1159 |
+ 1160 |
! |
dplyr::ungroup()
|
- | 1160 |
+ 1161 |
|
|
- | 1161 |
+ 1162 |
|
# order subjects by decreasing number of missing and then by
|
- | 1162 |
+ 1163 |
|
# missingness pattern (defined using sha1)
|
- | 1163 |
+ 1164 |
! |
order_subjects <- summary_plot_patients %>%
|
- | 1164 |
+ 1165 |
! |
dplyr::select(-"id", -dplyr::all_of(parent_keys)) %>%
|
- | 1165 |
+ 1166 |
! |
dplyr::transmute(
|
- | 1166 |
+ 1167 |
! |
id = dplyr::row_number(),
|
- | 1167 |
+ 1168 |
! |
number_NA = apply(., 1, sum),
|
- | 1168 |
+ 1169 |
! |
sha = apply(., 1, rlang::hash)
|
- | 1169 |
+ 1170 |
|
) %>%
|
- | 1170 |
+ 1171 |
! |
dplyr::arrange(dplyr::desc(number_NA), sha) %>%
|
- | 1171 |
+ 1172 |
! |
getElement(name = "id")
|
- | 1172 |
+ 1173 |
|
|
- | 1173 |
+ 1174 |
|
# order columns by decreasing percent of missing values
|
- | 1174 |
+ 1175 |
! |
ordered_columns <- summary_plot_patients %>%
|
- | 1175 |
+ 1176 |
! |
dplyr::select(-"id", -dplyr::all_of(parent_keys)) %>%
|
- | 1176 |
+ 1177 |
! |
dplyr::summarise(
|
- | 1177 |
+ 1178 |
! |
column = create_cols_labels(colnames(.)),
|
- | 1178 |
+ 1179 |
! |
na_count = apply(., MARGIN = 2, FUN = sum),
|
- | 1179 |
+ 1180 |
! |
na_percent = na_count / nrow(.) * 100
|
- | 1180 |
+ 1181 |
|
) %>%
|
- | 1181 |
+ 1182 |
! |
dplyr::arrange(na_percent, dplyr::desc(column))
|
- | 1182 |
+ 1183 |
|
|
- | 1183 |
+ 1184 |
! |
summary_plot_patients <- summary_plot_patients %>%
|
- | 1184 |
+ 1185 |
! |
tidyr::gather("col", "isna", -"id", -dplyr::all_of(parent_keys)) %>%
|
- | 1185 |
+ 1186 |
! |
dplyr::mutate(col = create_cols_labels(col))
|
- | 1186 |
+ 1187 |
|
})
|
- | 1187 |
+ 1188 |
|
) %>%
|
- | 1188 |
+ 1189 |
! |
teal.code::eval_code(
|
- | 1189 |
+ 1190 |
! |
substitute(
|
- | 1190 |
+ 1191 |
! |
expr = {
|
- | 1191 |
+ 1192 |
! |
g <- ggplot(summary_plot_patients, aes(
|
- | 1192 |
+ 1193 |
! |
x = factor(id, levels = order_subjects),
|
- | 1193 |
+ 1194 |
! |
y = factor(col, levels = ordered_columns[["column"]]),
|
- | 1194 |
+ 1195 |
! |
fill = isna
|
- | 1195 |
+ 1196 |
|
)) +
|
- | 1196 |
+ 1197 |
! |
geom_raster() +
|
- | 1197 |
+ 1198 |
! |
annotate(
|
- | 1198 |
+ 1199 |
! |
"text",
|
- | 1199 |
+ 1200 |
! |
x = length(order_subjects),
|
- | 1200 |
+ 1201 |
! |
y = seq_len(nrow(ordered_columns)),
|
- | 1201 |
+ 1202 |
! |
hjust = 1,
|
- | 1202 |
+ 1203 |
! |
label = sprintf("%d [%.02f%%]", ordered_columns[["na_count"]], ordered_columns[["na_percent"]])
|
- | 1203 |
+ 1204 |
|
) +
|
- | 1204 |
+ 1205 |
! |
scale_fill_manual(
|
- | 1205 |
+ 1206 |
! |
name = "",
|
- | 1206 |
+ 1207 |
! |
values = c("grey90", c(getOption("ggplot2.discrete.colour")[2], "#ff2951ff")[1]),
|
- | 1207 |
+ 1208 |
! |
labels = c("Present", "Missing (at least one)")
|
- | 1208 |
+ 1209 |
|
) +
|
- | 1209 |
+ 1210 |
! |
labs +
|
- | 1210 |
+ 1211 |
! |
ggthemes +
|
- | 1211 |
+ 1212 |
! |
themes
|
- | 1212 |
+ 1213 |
! |
print(g)
|
- | 1213 |
+ 1214 |
|
},
|
- | 1214 |
+ 1215 |
! |
env = list(
|
- | 1215 |
+ 1216 |
! |
labs = parsed_ggplot2_args$labs,
|
- | 1216 |
+ 1217 |
! |
themes = parsed_ggplot2_args$theme,
|
- | 1217 |
+ 1218 |
! |
ggthemes = parsed_ggplot2_args$ggtheme
|
- | 1218 |
+ 1219 |
|
)
|
- | 1219 |
+ 1220 |
|
)
|
- | 1220 |
+ 1221 |
|
)
|
- | 1221 |
+ 1222 |
|
})
|
- | 1222 |
+ 1223 |
|
|
- | 1223 |
+ 1224 |
! |
by_subject_plot_r <- reactive(by_subject_plot_q()[["g"]])
|
- | 1224 |
+ 1225 |
|
|
- | 1225 |
+ 1226 |
! |
output$levels_table <- DT::renderDataTable(
|
- | 1226 |
+ 1227 |
! |
expr = {
|
- | 1227 |
+ 1228 |
! |
if (length(input$variables_select) == 0) {
|
- | 1228 |
+ 1229 |
|
# so that zeroRecords message gets printed
|
- | 1229 |
+ 1230 |
|
# using tibble as it supports weird column names, such as " "
|
- | 1230 |
+ 1231 |
! |
tibble::tibble(` ` = logical(0))
|
- | 1231 |
+ 1232 |
|
} else {
|
- | 1232 |
+ 1233 |
! |
summary_table_r()
|
- | 1233 |
+ 1234 |
|
}
|
- | 1234 |
+ 1235 |
|
},
|
- | 1235 |
+ 1236 |
! |
options = list(language = list(zeroRecords = "No variable selected"), pageLength = input$levels_table_rows)
|
- | 1236 |
+ 1237 |
|
)
|
- | 1237 |
+ 1238 |
|
|
- | 1238 |
+ 1239 |
! |
pws1 <- teal.widgets::plot_with_settings_srv(
|
- | 1239 |
+ 1240 |
! |
id = "summary_plot",
|
- | 1240 |
+ 1241 |
! |
plot_r = summary_plot_r,
|
- | 1241 |
+ 1242 |
! |
height = plot_height,
|
- | 1242 |
+ 1243 |
! |
width = plot_width
|
- | 1243 |
+ 1244 |
|
)
|
- | 1244 |
+ 1245 |
|
|
- | 1245 |
+ 1246 |
! |
pws2 <- teal.widgets::plot_with_settings_srv(
|
- | 1246 |
+ 1247 |
! |
id = "combination_plot",
|
- | 1247 |
+ 1248 |
! |
plot_r = combination_plot_r,
|
- | 1248 |
+ 1249 |
! |
height = plot_height,
|
- | 1249 |
+ 1250 |
! |
width = plot_width
|
- | 1250 |
+ 1251 |
|
)
|
- | 1251 |
+ 1252 |
|
|
- | 1252 |
+ 1253 |
! |
pws3 <- teal.widgets::plot_with_settings_srv(
|
- | 1253 |
+ 1254 |
! |
id = "by_subject_plot",
|
- | 1254 |
+ 1255 |
! |
plot_r = by_subject_plot_r,
|
- | 1255 |
+ 1256 |
! |
height = plot_height,
|
- | 1256 |
+ 1257 |
! |
width = plot_width
|
- | 1257 |
+ 1258 |
|
)
|
- | 1258 |
+ 1259 |
|
|
- | 1259 |
+ 1260 |
! |
final_q <- reactive({
|
- | 1260 |
+ 1261 |
! |
req(input$summary_type)
|
- | 1261 |
+ 1262 |
! |
sum_type <- input$summary_type
|
- | 1262 |
+ 1263 |
! |
if (sum_type == "Summary") {
|
- | 1263 |
+ 1264 |
! |
summary_plot_q()
|
- | 1264 |
+ 1265 |
! |
} else if (sum_type == "Combinations") {
|
- | 1265 |
+ 1266 |
! |
combination_plot_q()
|
- | 1266 |
+ 1267 |
! |
} else if (sum_type == "By Variable Levels") {
|
- | 1267 |
+ 1268 |
! |
summary_table_q()
|
- | 1268 |
+ 1269 |
! |
} else if (sum_type == "Grouped by Subject") {
|
- | 1269 |
+ 1270 |
! |
by_subject_plot_q()
|
- | 1270 |
+ 1271 |
|
}
|
- | 1271 |
+ 1272 |
|
})
|
- | 1272 |
+ 1273 |
|
|
- | 1273 |
+ 1274 |
! |
teal.widgets::verbatim_popup_srv(
|
- | 1274 |
+ 1275 |
! |
id = "rcode",
|
- | 1275 |
+ 1276 |
! |
verbatim_content = reactive(teal.code::get_code(final_q())),
|
- | 1276 |
+ 1277 |
! |
title = "Show R Code for Missing Data"
|
- | 1277 |
+ 1278 |
|
)
|
- | 1278 |
+ 1279 |
|
|
- | 1279 |
+ 1280 |
|
### REPORTER
|
- | 1280 |
+ 1281 |
! |
if (with_reporter) {
|
- | 1281 |
+ 1282 |
! |
card_fun <- function(comment, label) {
|
- | 1282 |
+ 1283 |
! |
card <- teal::TealReportCard$new()
|
- | 1283 |
+ 1284 |
! |
sum_type <- input$summary_type
|
- | 1284 |
+ 1285 |
! |
title <- if (sum_type == "By Variable Levels") paste0(sum_type, " Table") else paste0(sum_type, " Plot")
|
- | 1285 |
+ 1286 |
! |
title_dataname <- paste(title, dataname, sep = " - ")
|
- | 1286 |
+ 1287 |
! |
label <- if (label == "") {
|
- | 1287 |
+ 1288 |
! |
paste("Missing Data", sum_type, dataname, sep = " - ")
|
- | 1288 |
+ 1289 |
|
} else {
|
- | 1289 |
+ 1290 |
! |
label
|
- | 1290 |
+ 1291 |
|
}
|
- | 1291 |
+ 1292 |
! |
card$set_name(label)
|
- | 1292 |
+ 1293 |
! |
card$append_text(title_dataname, "header2")
|
- | 1293 |
+ 1294 |
! |
if (with_filter) card$append_fs(filter_panel_api$get_filter_state())
|
- | 1294 |
+ 1295 |
! |
if (sum_type == "Summary") {
|
- | 1295 |
+ 1296 |
! |
card$append_text("Plot", "header3")
|
- | 1296 |
+ 1297 |
! |
card$append_plot(summary_plot_r(), dim = pws1$dim())
|
- | 1297 |
+ 1298 |
! |
} else if (sum_type == "Combinations") {
|
- | 1298 |
+ 1299 |
! |
card$append_text("Plot", "header3")
|
- | 1299 |
+ 1300 |
! |
card$append_plot(combination_plot_r(), dim = pws2$dim())
|
- | 1300 |
+ 1301 |
! |
} else if (sum_type == "By Variable Levels") {
|
- | 1301 |
+ 1302 |
! |
card$append_text("Table", "header3")
|
- | 1302 |
+ 1303 |
! |
card$append_table(summary_table_r[["summary_data"]])
|
- | 1303 |
+ 1304 |
! |
} else if (sum_type == "Grouped by Subject") {
|
- | 1304 |
+ 1305 |
! |
card$append_text("Plot", "header3")
|
- | 1305 |
+ 1306 |
! |
card$append_plot(by_subject_plot_r(), dim = pws3$dim())
|
- | 1306 |
+ 1307 |
|
}
|
- | 1307 |
+ 1308 |
! |
if (!comment == "") {
|
- | 1308 |
+ 1309 |
! |
card$append_text("Comment", "header3")
|
- | 1309 |
+ 1310 |
! |
card$append_text(comment)
|
- | 1310 |
+ 1311 |
|
}
|
- | 1311 |
+ 1312 |
! |
card$append_src(teal.code::get_code(final_q()))
|
- | 1312 |
+ 1313 |
! |
card
|
- | 1313 |
+ 1314 |
|
}
|
- | 1314 |
+ 1315 |
! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
- | 1315 |
+ 1316 |
|
}
|
- | 1316 |
+ 1317 |
|
###
|
- | 1317 |
+ 1318 |
|
})
|
- | 1318 |
+ 1319 |
|
}
@@ -73237,14 +73607,14 @@ teal.modules.general coverage - 3.44%
|
-
+
| 1 |
|
- #' `teal` module: Response plot
+ #' Shared parameters documentation
|
@@ -73258,294 +73628,294 @@ teal.modules.general coverage - 3.44%
3 |
|
- #' Generates a response plot for a given `response` and `x` variables.
+ #' Defines common arguments shared across multiple functions in the package
|
| 4 |
|
- #' This module allows users customize and add annotations to the plot depending
+ #' to avoid repetition by using `inheritParams`.
|
| 5 |
|
- #' on the module's arguments.
+ #'
|
| 6 |
|
- #' It supports showing the counts grouped by other variable facets (by row / column),
+ #' @param plot_height (`numeric`) optional, specifies the plot height as a three-element vector of
|
| 7 |
|
- #' swapping the coordinates, show count annotations and displaying the response plot
+ #' `value`, `min`, and `max` intended for use with a slider UI element.
|
| 8 |
|
- #' as frequency or density.
+ #' @param plot_width (`numeric`) optional, specifies the plot width as a three-element vector of
|
| 9 |
|
- #'
+ #' `value`, `min`, and `max` for a slider encoding the plot width.
|
| 10 |
|
- #' @inheritParams teal::module
+ #' @param rotate_xaxis_labels (`logical`) optional, whether to rotate plot X axis labels. Does not
|
| 11 |
|
- #' @inheritParams shared_params
+ #' rotate by default (`FALSE`).
|
| 12 |
|
- #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`)
+ #' @param ggtheme (`character`) optional, `ggplot2` theme to be used by default. Defaults to `"gray"`.
|
| 13 |
|
- #' Which variable to use as the response.
+ #' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()]
|
| 14 |
|
- #' You can define one fixed column by setting `fixed = TRUE` inside the `select_spec`.
+ #' with settings for the module plot.
|
| 15 |
|
- #'
+ #' The argument is merged with options variable `teal.ggplot2_args` and default module setup.
|
| 16 |
|
- #' The `data_extract_spec` must not allow multiple selection in this case.
+ #'
|
| 17 |
|
- #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)
+ #' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`
|
| 18 |
|
- #' Specifies which variable to use on the X-axis of the response plot.
+ #' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()]
|
| 19 |
|
- #' Allow the user to select multiple columns from the `data` allowed in teal.
+ #' with settings for the module table.
|
| 20 |
|
- #'
+ #' The argument is merged with options variable `teal.basic_table_args` and default module setup.
|
| 21 |
|
- #' The `data_extract_spec` must not allow multiple selection in this case.
+ #'
|
| 22 |
|
- #' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`)
+ #' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")`
|
| 23 |
|
- #' optional specification of the data variable(s) to use for faceting rows.
+ #' @param pre_output (`shiny.tag`) optional, text or UI element to be displayed before the module's output,
|
| 24 |
|
- #' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`)
+ #' providing context or a title.
|
| 25 |
|
- #' optional specification of the data variable(s) to use for faceting columns.
+ #' with text placed before the output to put the output into context. For example a title.
|
| 26 |
|
- #' @param coord_flip (`logical(1)`)
+ #' @param post_output (`shiny.tag`) optional, text or UI element to be displayed after the module's output,
|
| 27 |
|
- #' Indicates whether to flip coordinates between `x` and `response`.
+ #' adding context or further instructions. Elements like `shiny::helpText()` are useful.
|
| 28 |
|
- #' The default value is `FALSE` and it will show the `x` variable on the x-axis
+ #'
|
| 29 |
|
- #' and the `response` variable on the y-axis.
+ #' @param alpha (`integer(1)` or `integer(3)`) optional, specifies point opacity.
|
| 30 |
|
- #' @param count_labels (`logical(1)`)
+ #' - When the length of `alpha` is one: the plot points will have a fixed opacity.
|
| 31 |
|
- #' Indicates whether to show count labels.
+ #' - When the length of `alpha` is three: the plot points opacity are dynamically adjusted based on
|
| 32 |
|
- #' Defaults to `TRUE`.
+ #' vector of `value`, `min`, and `max`.
|
| 33 |
|
- #' @param freq (`logical(1)`)
+ #' @param size (`integer(1)` or `integer(3)`) optional, specifies point size.
|
| 34 |
|
- #' Indicates whether to display frequency (`TRUE`) or density (`FALSE`).
+ #' - When the length of `size` is one: the plot point sizes will have a fixed size.
|
| 35 |
|
- #' Defaults to density (`FALSE`).
+ #' - When the length of `size` is three: the plot points size are dynamically adjusted based on
|
| 36 |
|
- #'
+ #' vector of `value`, `min`, and `max`.
|
| 37 |
|
- #' @inherit shared_params return
+ #'
|
| 38 |
|
- #'
+ #' @return Object of class `teal_module` to be used in `teal` applications.
|
| 39 |
|
- #' @note For more examples, please see the vignette "Using response plot" via
+ #'
|
| 40 |
|
- #' `vignette("using-response-plot", package = "teal.modules.general")`.
+ #' @name shared_params
|
| 41 |
|
- #'
+ #' @keywords internal
|
| 42 |
|
- #' @examples
+ NULL
|
| 43 |
|
- #' # general data example
+
|
| 44 |
|
- #' library(teal.widgets)
+ #' Add labels for facets to a `ggplot2` object
|
@@ -73559,644 +73929,644 @@ teal.modules.general coverage - 3.44%
46 |
|
- #' data <- teal_data()
+ #' Enhances a `ggplot2` plot by adding labels that describe
|
| 47 |
|
- #' data <- within(data, {
+ #' the faceting variables along the x and y axes.
|
| 48 |
|
- #' require(nestcolor)
+ #'
|
| 49 |
|
- #' mtcars <- mtcars
+ #' @param p (`ggplot2`) object to which facet labels will be added.
|
| 50 |
|
- #' for (v in c("cyl", "vs", "am", "gear")) {
+ #' @param xfacet_label (`character`) Label for the facet along the x-axis.
|
| 51 |
|
- #' mtcars[[v]] <- as.factor(mtcars[[v]])
+ #' If `NULL`, no label is added. If a vector, labels are joined with " & ".
|
| 52 |
|
- #' }
+ #' @param yfacet_label (`character`) Label for the facet along the y-axis.
|
| 53 |
|
- #' })
+ #' Similar behavior to `xfacet_label`.
|
| 54 |
|
- #' datanames(data) <- "mtcars"
+ #'
|
| 55 |
|
- #'
+ #' @return Returns `grid` or `grob` object (to be drawn with `grid.draw`)
|
| 56 |
|
- #' app <- init(
+ #'
|
| 57 |
|
- #' data = data,
+ #' @examples
|
| 58 |
|
- #' modules = modules(
+ #' library(ggplot2)
|
| 59 |
|
- #' tm_g_response(
+ #' library(grid)
|
| 60 |
|
- #' label = "Response Plots",
+ #'
|
| 61 |
|
- #' response = data_extract_spec(
+ #' p <- ggplot(mtcars) +
|
| 62 |
|
- #' dataname = "mtcars",
+ #' aes(x = mpg, y = disp) +
|
| 63 |
|
- #' select = select_spec(
+ #' geom_point() +
|
| 64 |
|
- #' label = "Select variable:",
+ #' facet_grid(gear ~ cyl)
|
| 65 |
|
- #' choices = variable_choices(data[["mtcars"]], c("cyl", "gear")),
+ #'
|
| 66 |
|
- #' selected = "cyl",
+ #' xfacet_label <- "cylinders"
|
| 67 |
|
- #' multiple = FALSE,
+ #' yfacet_label <- "gear"
|
| 68 |
|
- #' fixed = FALSE
+ #' res <- add_facet_labels(p, xfacet_label, yfacet_label)
|
| 69 |
|
- #' )
+ #' grid.newpage()
|
| 70 |
|
- #' ),
+ #' grid.draw(res)
|
| 71 |
|
- #' x = data_extract_spec(
+ #'
|
| 72 |
|
- #' dataname = "mtcars",
+ #' grid.newpage()
|
| 73 |
|
- #' select = select_spec(
+ #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label))
|
| 74 |
|
- #' label = "Select variable:",
+ #' grid.newpage()
|
| 75 |
|
- #' choices = variable_choices(data[["mtcars"]], c("vs", "am")),
+ #' grid.draw(add_facet_labels(p, xfacet_label, yfacet_label = NULL))
|
| 76 |
|
- #' selected = "vs",
+ #' grid.newpage()
|
| 77 |
|
- #' multiple = FALSE,
+ #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label = NULL))
|
| 78 |
|
- #' fixed = FALSE
+ #'
|
| 79 |
|
- #' )
+ #' @export
|
| 80 |
|
- #' ),
+ #'
|
| 81 |
|
- #' ggplot2_args = ggplot2_args(
+ add_facet_labels <- function(p, xfacet_label = NULL, yfacet_label = NULL) {
|
-
+
| 82 |
- |
+ ! |
- #' labs = list(subtitle = "Plot generated by Response Module")
+ checkmate::assert_class(p, classes = "ggplot")
|
-
+
| 83 |
- |
+ ! |
- #' )
+ checkmate::assert_character(xfacet_label, null.ok = TRUE, min.len = 1)
|
-
+
| 84 |
- |
+ ! |
- #' )
+ checkmate::assert_character(yfacet_label, null.ok = TRUE, min.len = 1)
|
-
+
| 85 |
- |
+ ! |
- #' )
+ if (is.null(xfacet_label) && is.null(yfacet_label)) {
|
-
+
| 86 |
- |
+ ! |
- #' )
+ return(ggplotGrob(p))
|
| 87 |
|
- #' if (interactive()) {
+ }
|
-
+
| 88 |
- |
+ ! |
- #' shinyApp(app$ui, app$server)
+ grid::grid.grabExpr({
|
-
+
| 89 |
- |
+ ! |
- #' }
+ g <- ggplotGrob(p)
|
| 90 |
|
- #'
+
|
| 91 |
|
- #' # CDISC data example
+ # we are going to replace these, so we make sure they have nothing in them
|
-
+
| 92 |
- |
+ ! |
- #' library(teal.widgets)
+ checkmate::assert_class(g$grobs[[grep("xlab-t", g$layout$name, fixed = TRUE)]], "zeroGrob")
|
-
+
| 93 |
- |
+ ! |
- #'
+ checkmate::assert_class(g$grobs[[grep("ylab-r", g$layout$name, fixed = TRUE)]], "zeroGrob")
|
| 94 |
|
- #' data <- teal_data()
+
|
-
+
| 95 |
- |
+ ! |
- #' data <- within(data, {
+ xaxis_label_grob <- g$grobs[[grep("xlab-b", g$layout$name, fixed = TRUE)]]
|
-
+
| 96 |
- |
+ ! |
- #' require(nestcolor)
+ xaxis_label_grob$children[[1]]$label <- paste(xfacet_label, collapse = " & ")
|
-
+
| 97 |
- |
+ ! |
- #' ADSL <- rADSL
+ yaxis_label_grob <- g$grobs[[grep("ylab-l", g$layout$name, fixed = TRUE)]]
|
-
+
| 98 |
- |
+ ! |
- #' })
+ yaxis_label_grob$children[[1]]$label <- paste(yfacet_label, collapse = " & ")
|
-
+
| 99 |
- |
+ ! |
- #' datanames(data) <- c("ADSL")
+ yaxis_label_grob$children[[1]]$rot <- 270
|
| 100 |
|
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
+
|
-
+
| 101 |
- |
+ ! |
- #'
+ top_height <- if (is.null(xfacet_label)) 0 else grid::unit(2, "line")
|
-
+
| 102 |
- |
+ ! |
- #' app <- init(
+ right_width <- if (is.null(yfacet_label)) 0 else grid::unit(2, "line")
|
| 103 |
|
- #' data = data,
+
|
-
+
| 104 |
- |
+ ! |
- #' modules = modules(
+ grid::grid.newpage()
|
-
+
| 105 |
- |
+ ! |
- #' tm_g_response(
+ grid::pushViewport(grid::plotViewport(margins = c(0, 0, top_height, right_width), name = "ggplot"))
|
-
+
| 106 |
- |
+ ! |
- #' label = "Response Plots",
+ grid::grid.draw(g)
|
-
+
| 107 |
- |
+ ! |
- #' response = data_extract_spec(
+ grid::upViewport(1)
|
| 108 |
|
- #' dataname = "ADSL",
+
|
| 109 |
|
- #' select = select_spec(
+ # draw x facet
|
-
+
| 110 |
- |
+ ! |
- #' label = "Select variable:",
+ if (!is.null(xfacet_label)) {
|
-
+
| 111 |
- |
+ ! |
- #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "COUNTRY")),
+ grid::pushViewport(grid::viewport(
|
-
+
| 112 |
- |
+ ! |
- #' selected = "BMRKR2",
+ x = 0, y = grid::unit(1, "npc") - top_height, width = grid::unit(1, "npc"),
|
-
+
| 113 |
- |
+ ! |
- #' multiple = FALSE,
+ height = top_height, just = c("left", "bottom"), name = "topxaxis"
|
| 114 |
|
- #' fixed = FALSE
+ ))
|
-
+
| 115 |
- |
+ ! |
- #' )
+ grid::grid.draw(xaxis_label_grob)
|
-
+
| 116 |
- |
+ ! |
- #' ),
+ grid::upViewport(1)
|
| 117 |
|
- #' x = data_extract_spec(
+ }
|
| 118 |
|
- #' dataname = "ADSL",
+
|
| 119 |
|
- #' select = select_spec(
+ # draw y facet
|
-
+
| 120 |
- |
+ ! |
- #' label = "Select variable:",
+ if (!is.null(yfacet_label)) {
|
-
+
| 121 |
- |
+ ! |
- #' choices = variable_choices(data[["ADSL"]], c("SEX", "RACE")),
+ grid::pushViewport(grid::viewport(
|
-
+
| 122 |
- |
+ ! |
- #' selected = "RACE",
+ x = grid::unit(1, "npc") - grid::unit(as.numeric(right_width) / 2, "line"), y = 0, width = right_width,
|
-
+
| 123 |
- |
+ ! |
- #' multiple = FALSE,
+ height = grid::unit(1, "npc"), just = c("left", "bottom"), name = "rightyaxis"
|
| 124 |
|
- #' fixed = FALSE
+ ))
|
-
+
| 125 |
- |
+ ! |
- #' )
+ grid::grid.draw(yaxis_label_grob)
|
-
+
| 126 |
- |
+ ! |
- #' ),
+ grid::upViewport(1)
|
| 127 |
|
- #' ggplot2_args = ggplot2_args(
+ }
|
| 128 |
|
- #' labs = list(subtitle = "Plot generated by Response Module")
+ })
|
| 129 |
|
- #' )
+ }
|
| 130 |
|
- #' )
+
|
| 131 |
|
- #' )
+ #' Call a function with a character vector for the `...` argument
|
| 132 |
|
- #' )
+ #'
|
| 133 |
|
- #' if (interactive()) {
+ #' @param fun (`character`) Name of a function where the `...` argument shall be replaced by values from `str_args`.
|
| 134 |
|
- #' shinyApp(app$ui, app$server)
+ #' @param str_args (`character`) A character vector that the function shall be executed with
|
| 135 |
|
- #' }
+ #'
|
| 136 |
|
- #'
+ #' @return
|
| 137 |
|
- #' @export
+ #' Value of call to `fun` with arguments specified in `str_args`.
|
@@ -74210,245 +74580,245 @@ teal.modules.general coverage - 3.44%
139 |
|
- tm_g_response <- function(label = "Response Plot",
+ #' @keywords internal
|
| 140 |
|
- response,
+ call_fun_dots <- function(fun, str_args) {
|
-
+
| 141 |
- |
+ ! |
- x,
+ do.call("call", c(list(fun), lapply(str_args, as.name)), quote = TRUE)
|
| 142 |
|
- row_facet = NULL,
+ }
|
| 143 |
|
- col_facet = NULL,
+
|
| 144 |
|
- coord_flip = FALSE,
+ #' Generate a string for a variable including its label
|
| 145 |
|
- count_labels = TRUE,
+ #'
|
| 146 |
|
- rotate_xaxis_labels = FALSE,
+ #' @param var_names (`character`) Name of variable to extract labels from.
|
| 147 |
|
- freq = FALSE,
+ #' @param dataset (`dataset`) Name of analysis dataset.
|
| 148 |
|
- plot_height = c(600, 400, 5000),
+ #' @param prefix,suffix (`character`) String to paste to the beginning/end of the variable name with label.
|
| 149 |
|
- plot_width = NULL,
+ #' @param wrap_width (`numeric`) Number of characters to wrap original label to. Defaults to 80.
|
| 150 |
|
- ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
+ #'
|
| 151 |
|
- ggplot2_args = teal.widgets::ggplot2_args(),
+ #' @return (`character`) String with variable name and label.
|
| 152 |
|
- pre_output = NULL,
+ #'
|
| 153 |
|
- post_output = NULL) {
+ #' @keywords internal
|
-
+
| 154 |
- ! |
+ |
- message("Initializing tm_g_response")
+ #'
|
| 155 |
|
-
+ varname_w_label <- function(var_names,
|
| 156 |
|
- # Normalize the parameters
+ dataset,
|
-
+
| 157 |
- ! |
+ |
- if (inherits(response, "data_extract_spec")) response <- list(response)
+ wrap_width = 80,
|
-
+
| 158 |
- ! |
+ |
- if (inherits(x, "data_extract_spec")) x <- list(x)
+ prefix = NULL,
|
-
+
| 159 |
- ! |
+ |
- if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)
+ suffix = NULL) {
|
| 160 |
! |
- if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)
+ add_label <- function(var_names) {
|
-
+
| 161 |
- |
+ ! |
-
+ label <- vapply(
|
-
+
| 162 |
- |
+ ! |
- # Start of assertions
+ dataset[var_names], function(x) {
|
| 163 |
! |
- checkmate::assert_string(label)
+ attr_label <- attr(x, "label")
|
-
+
| 164 |
- |
+ ! |
-
+ `if`(is.null(attr_label), "", attr_label)
|
-
+
| 165 |
- ! |
+ |
- checkmate::assert_list(response, types = "data_extract_spec")
+ },
|
| 166 |
! |
- if (!all(vapply(response, function(x) !("" %in% x$select$choices), logical(1)))) {
+ character(1)
|
-
+
| 167 |
- ! |
+ |
- stop("'response' should not allow empty values")
+ )
|
| 168 |
|
- }
+
|
| 169 |
! |
- assert_single_selection(response)
+ if (length(label) == 1 && !is.na(label) && !identical(label, "")) {
|
-
+
| 170 |
- |
+ ! |
-
+ paste0(prefix, label, " [", var_names, "]", suffix)
|
-
+
| 171 |
- ! |
+ |
- checkmate::assert_list(x, types = "data_extract_spec")
+ } else {
|
| 172 |
! |
- if (!all(vapply(x, function(x) !("" %in% x$select$choices), logical(1)))) {
+ var_names
|
-
+
| 173 |
- ! |
+ |
- stop("'x' should not allow empty values")
+ }
|
@@ -74458,137 +74828,137 @@ teal.modules.general coverage - 3.44%
}
-
+
| 175 |
- ! |
+ |
- assert_single_selection(x)
+
|
-
+
| 176 |
- |
+ ! |
-
+ if (length(var_names) < 1) {
|
| 177 |
! |
- checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)
+ NULL
|
| 178 |
! |
- checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)
+ } else if (length(var_names) == 1) {
|
| 179 |
! |
- checkmate::assert_flag(coord_flip)
+ stringr::str_wrap(add_label(var_names), width = wrap_width)
|
| 180 |
! |
- checkmate::assert_flag(count_labels)
+ } else if (length(var_names) > 1) {
|
| 181 |
! |
- checkmate::assert_flag(rotate_xaxis_labels)
+ stringr::str_wrap(vapply(var_names, add_label, character(1)), width = wrap_width)
|
-
+
| 182 |
- ! |
+ |
- checkmate::assert_flag(freq)
+ }
|
| 183 |
|
-
+ }
|
-
+
| 184 |
- ! |
+ |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
+
|
-
+
| 185 |
- ! |
+ |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
+ # see vignette("ggplot2-specs", package="ggplot2")
|
-
+
| 186 |
- ! |
+ |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
+ shape_names <- c(
|
-
+
| 187 |
- ! |
+ |
- checkmate::assert_numeric(
+ "circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",
|
-
+
| 188 |
- ! |
+ |
- plot_width[1],
+ "square", paste("square", c("open", "filled", "cross", "plus", "triangle")),
|
-
+
| 189 |
- ! |
+ |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
+ "diamond", paste("diamond", c("open", "filled", "plus")),
|
| 190 |
|
- )
+ "triangle", paste("triangle", c("open", "filled", "square")),
|
| 191 |
|
-
+ paste("triangle down", c("open", "filled")),
|
-
+
| 192 |
- ! |
+ |
- ggtheme <- match.arg(ggtheme)
+ "plus", "cross", "asterisk"
|
-
+
| 193 |
- ! |
+ |
- checkmate::assert_class(ggplot2_args, "ggplot2_args")
+ )
|
@@ -74598,6545 +74968,6460 @@ teal.modules.general coverage - 3.44%
-
+
| 195 |
- ! |
+ |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ #' Get icons to represent variable types in dataset
|
-
+
| 196 |
- ! |
+ |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ #'
|
| 197 |
|
- # End of assertions
+ #' @param var_type (`character`) of R internal types (classes).
|
| 198 |
|
-
+ #' @return (`character`) vector of HTML icons corresponding to data type in each column.
|
| 199 |
|
- # Make UI args
+ #' @keywords internal
|
-
+
| 200 |
- ! |
+ |
- args <- as.list(environment())
+ variable_type_icons <- function(var_type) {
|
-
+
| 201 |
- |
+ ! |
-
+ checkmate::assert_character(var_type, any.missing = FALSE)
|
-
+
| 202 |
- ! |
+ |
- data_extract_list <- list(
+
|
| 203 |
! |
- response = response,
+ class_to_icon <- list(
|
| 204 |
! |
- x = x,
+ numeric = "arrow-up-1-9",
|
| 205 |
! |
- row_facet = row_facet,
+ integer = "arrow-up-1-9",
|
| 206 |
! |
- col_facet = col_facet
+ logical = "pause",
|
-
+
| 207 |
- |
+ ! |
- )
+ Date = "calendar",
|
-
+
| 208 |
- |
+ ! |
-
+ POSIXct = "calendar",
|
| 209 |
! |
- ans <- module(
+ POSIXlt = "calendar",
|
| 210 |
! |
- label = label,
+ factor = "chart-bar",
|
| 211 |
! |
- server = srv_g_response,
+ character = "keyboard",
|
| 212 |
! |
- ui = ui_g_response,
+ primary_key = "key",
|
| 213 |
! |
- ui_args = args,
+ unknown = "circle-question"
|
-
+
| 214 |
- ! |
+ |
- server_args = c(
+ )
|
| 215 |
! |
- data_extract_list,
+ class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome")))
|
-
+
| 216 |
- ! |
+ |
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)
+
|
-
+
| 217 |
- |
+ ! |
- ),
+ unname(vapply(
|
| 218 |
! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)
+ var_type,
|
-
+
| 219 |
- |
+ ! |
- )
+ FUN.VALUE = character(1),
|
| 220 |
! |
- attr(ans, "teal_bookmarkable") <- TRUE
+ FUN = function(class) {
|
| 221 |
! |
- ans
+ if (class == "") {
|
-
+
| 222 |
- |
+ ! |
- }
+ class
|
-
+
| 223 |
- |
+ ! |
-
+ } else if (is.null(class_to_icon[[class]])) {
|
-
+
| 224 |
- |
+ ! |
- # UI function for the response module
+ class_to_icon[["unknown"]]
|
| 225 |
|
- ui_g_response <- function(id, ...) {
+ } else {
|
| 226 |
! |
- ns <- NS(id)
+ class_to_icon[[class]]
|
-
+
| 227 |
- ! |
+ |
- args <- list(...)
+ }
|
-
+
| 228 |
- ! |
+ |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$response, args$x, args$row_facet, args$col_facet)
+ }
|
| 229 |
|
-
+ ))
|
-
+
| 230 |
- ! |
+ |
- teal.widgets::standard_layout(
+ }
|
-
+
| 231 |
- ! |
+ |
- output = teal.widgets::white_small_well(
+
|
-
+
| 232 |
- ! |
+ |
- teal.widgets::plot_with_settings_ui(id = ns("myplot"))
+ #' Include `CSS` files from `/inst/css/` package directory to application header
|
| 233 |
|
- ),
+ #'
|
-
+
| 234 |
- ! |
+ |
- encoding = tags$div(
+ #' `system.file` should not be used to access files in other packages, it does
|
| 235 |
|
- ### Reporter
+ #' not work with `devtools`. Therefore, we redefine this method in each package
|
-
+
| 236 |
- ! |
+ |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ #' as needed. Thus, we do not export this method
|
| 237 |
|
- ###
+ #'
|
-
+
| 238 |
- ! |
+ |
- tags$label("Encodings", class = "text-primary"),
+ #' @param pattern (`character`) optional, regular expression to match the file names to be included.
|
-
+
| 239 |
- ! |
+ |
- teal.transform::datanames_input(args[c("response", "x", "row_facet", "col_facet")]),
+ #'
|
-
+
| 240 |
- ! |
+ |
- teal.transform::data_extract_ui(
+ #' @return HTML code that includes `CSS` files.
|
-
+
| 241 |
- ! |
+ |
- id = ns("response"),
+ #' @keywords internal
|
-
+
| 242 |
- ! |
+ |
- label = "Response variable",
+ #'
|
-
+
| 243 |
- ! |
+ |
- data_extract_spec = args$response,
+ include_css_files <- function(pattern = "*") {
|
| 244 |
! |
- is_single_dataset = is_single_dataset_value
+ css_files <- list.files(
|
-
+
| 245 |
- |
+ ! |
- ),
+ system.file("css", package = "teal.modules.general", mustWork = TRUE),
|
| 246 |
! |
- teal.transform::data_extract_ui(
+ pattern = pattern, full.names = TRUE
|
-
+
| 247 |
- ! |
+ |
- id = ns("x"),
+ )
|
| 248 |
! |
- label = "X variable",
+ if (length(css_files) == 0) {
|
| 249 |
! |
- data_extract_spec = args$x,
+ return(NULL)
|
-
+
| 250 |
- ! |
+ |
- is_single_dataset = is_single_dataset_value
+ }
|
-
+
| 251 |
- |
+ ! |
- ),
+ singleton(tags$head(lapply(css_files, includeCSS)))
|
-
+
| 252 |
- ! |
+ |
- if (!is.null(args$row_facet)) {
+ }
|
-
+
| 253 |
- ! |
+ |
- teal.transform::data_extract_ui(
+
|
-
+
| 254 |
- ! |
+ |
- id = ns("row_facet"),
+ #' JavaScript condition to check if a specific tab is active
|
-
+
| 255 |
- ! |
+ |
- label = "Row facetting",
+ #'
|
-
+
| 256 |
- ! |
+ |
- data_extract_spec = args$row_facet,
+ #' @param id (`character(1)`) the id of the tab panel with tabs.
|
-
+
| 257 |
- ! |
+ |
- is_single_dataset = is_single_dataset_value
+ #' @param name (`character(1)`) the name of the tab.
|
| 258 |
|
- )
+ #' @return JavaScript expression to be used in `shiny::conditionalPanel()` to determine
|
| 259 |
|
- },
+ #' if the specified tab is active.
|
-
+
| 260 |
- ! |
+ |
- if (!is.null(args$col_facet)) {
+ #' @keywords internal
|
-
+
| 261 |
- ! |
+ |
- teal.transform::data_extract_ui(
+ #'
|
-
+
| 262 |
- ! |
+ |
- id = ns("col_facet"),
+ is_tab_active_js <- function(id, name) {
|
-
+
| 263 |
- ! |
+ |
- label = "Column facetting",
+ # supporting the bs3 and higher version at the same time
|
| 264 |
! |
- data_extract_spec = args$col_facet,
+ sprintf(
|
| 265 |
! |
- is_single_dataset = is_single_dataset_value
+ "$(\"#%1$s > li.active\").text().trim() == '%2$s' || $(\"#%1$s > li a.active\").text().trim() == '%2$s'",
|
-
+
| 266 |
- |
+ ! |
- )
+ id, name
|
| 267 |
|
- },
+ )
|
-
+
| 268 |
- ! |
+ |
- shinyWidgets::radioGroupButtons(
+ }
|
-
+
| 269 |
- ! |
+ |
- inputId = ns("freq"),
+
|
-
+
| 270 |
- ! |
+ |
- label = NULL,
+ #' Assert single selection on `data_extract_spec` object
|
-
+
| 271 |
- ! |
+ |
- choices = c("frequency", "density"),
+ #' Helper to reduce code in assertions
|
-
+
| 272 |
- ! |
+ |
- selected = ifelse(args$freq, "frequency", "density"),
+ #' @noRd
|
-
+
| 273 |
- ! |
+ |
- justified = TRUE
+ #'
|
| 274 |
|
- ),
+ assert_single_selection <- function(x,
|
-
+
| 275 |
- ! |
+ |
- teal.widgets::panel_group(
+ .var.name = checkmate::vname(x)) { # nolint: object_name.
|
-
+
| 276 |
- ! |
+ 104x |
- teal.widgets::panel_item(
+ if (any(vapply(x, function(.x) .x$select$multiple, logical(1)))) {
|
-
+
| 277 |
- ! |
+ 4x |
- title = "Plot settings",
+ stop("'", .var.name, "' should not allow multiple selection")
|
-
+
| 278 |
- ! |
+ |
- checkboxInput(ns("count_labels"), "Add count labels", value = args$count_labels),
+ }
|
-
+
| 279 |
- ! |
+ 100x |
- checkboxInput(ns("coord_flip"), "Swap axes", value = args$coord_flip),
+ invisible(TRUE)
|
-
+
| 280 |
- ! |
-
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
- |
-
-
- | 281 |
- ! |
-
- selectInput(
- |
-
-
- | 282 |
- ! |
-
- inputId = ns("ggtheme"),
- |
-
-
- | 283 |
- ! |
-
- label = "Theme (by ggplot):",
- |
-
-
- | 284 |
- ! |
-
- choices = ggplot_themes,
- |
-
-
- | 285 |
- ! |
-
- selected = args$ggtheme,
- |
-
-
- | 286 |
- ! |
+ |
- multiple = FALSE
+ }
|
+
+
+
+
+
+
- | 287 |
+ 1 |
|
- )
+ #' `teal` module: Response plot
|
- | 288 |
+ 2 |
|
- )
+ #'
|
- | 289 |
+ 3 |
|
- )
+ #' Generates a response plot for a given `response` and `x` variables.
|
- | 290 |
+ 4 |
|
- ),
- |
-
-
- | 291 |
- ! |
-
- forms = tagList(
- |
-
-
- | 292 |
- ! |
-
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ #' This module allows users customize and add annotations to the plot depending
|
- | 293 |
+ 5 |
|
- ),
- |
-
-
- | 294 |
- ! |
-
- pre_output = args$pre_output,
- |
-
-
- | 295 |
- ! |
-
- post_output = args$post_output
+ #' on the module's arguments.
|
- | 296 |
+ 6 |
|
- )
+ #' It supports showing the counts grouped by other variable facets (by row / column),
|
- | 297 |
+ 7 |
|
- }
+ #' swapping the coordinates, show count annotations and displaying the response plot
|
- | 298 |
+ 8 |
|
-
+ #' as frequency or density.
|
- | 299 |
+ 9 |
|
- # Server function for the response module
+ #'
|
- | 300 |
+ 10 |
|
- srv_g_response <- function(id,
+ #' @inheritParams teal::module
|
- | 301 |
+ 11 |
|
- data,
+ #' @inheritParams shared_params
|
- | 302 |
+ 12 |
|
- reporter,
+ #' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`)
|
- | 303 |
+ 13 |
|
- filter_panel_api,
+ #' Which variable to use as the response.
|
- | 304 |
+ 14 |
|
- response,
+ #' You can define one fixed column by setting `fixed = TRUE` inside the `select_spec`.
|
- | 305 |
+ 15 |
|
- x,
+ #'
|
- | 306 |
+ 16 |
|
- row_facet,
+ #' The `data_extract_spec` must not allow multiple selection in this case.
|
- | 307 |
+ 17 |
|
- col_facet,
+ #' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`)
|
- | 308 |
+ 18 |
|
- plot_height,
+ #' Specifies which variable to use on the X-axis of the response plot.
|
- | 309 |
+ 19 |
|
- plot_width,
+ #' Allow the user to select multiple columns from the `data` allowed in teal.
|
- | 310 |
+ 20 |
|
- ggplot2_args) {
- |
-
-
- | 311 |
- ! |
-
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
- |
-
-
- | 312 |
- ! |
-
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
- |
-
-
- | 313 |
- ! |
-
- checkmate::assert_class(data, "reactive")
- |
-
-
- | 314 |
- ! |
-
- checkmate::assert_class(isolate(data()), "teal_data")
- |
-
-
- | 315 |
- ! |
-
- moduleServer(id, function(input, output, session) {
+ #'
|
-
- | 316 |
- ! |
+
+ | 21 |
+ |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
+ #' The `data_extract_spec` must not allow multiple selection in this case.
|
- | 317 |
+ 22 |
|
-
+ #' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`)
|
-
- | 318 |
- ! |
+
+ | 23 |
+ |
- data_extract <- list(response = response, x = x, row_facet = row_facet, col_facet = col_facet)
+ #' optional specification of the data variable(s) to use for faceting rows.
|
- | 319 |
+ 24 |
|
-
+ #' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`)
|
-
- | 320 |
- ! |
+
+ | 25 |
+ |
- rule_diff <- function(other) {
+ #' optional specification of the data variable(s) to use for faceting columns.
|
-
- | 321 |
- ! |
+
+ | 26 |
+ |
- function(value) {
+ #' @param coord_flip (`logical(1)`)
|
-
- | 322 |
- ! |
+
+ | 27 |
+ |
- if (other %in% names(selector_list())) {
+ #' Indicates whether to flip coordinates between `x` and `response`.
|
-
- | 323 |
- ! |
+
+ | 28 |
+ |
- othervalue <- selector_list()[[other]]()[["select"]]
+ #' The default value is `FALSE` and it will show the `x` variable on the x-axis
|
-
- | 324 |
- ! |
+
+ | 29 |
+ |
- if (!is.null(othervalue)) {
+ #' and the `response` variable on the y-axis.
|
-
- | 325 |
- ! |
+
+ | 30 |
+ |
- if (identical(value, othervalue)) {
+ #' @param count_labels (`logical(1)`)
|
-
- | 326 |
- ! |
+
+ | 31 |
+ |
- "Row and column facetting variables must be different."
+ #' Indicates whether to show count labels.
|
- | 327 |
+ 32 |
|
- }
+ #' Defaults to `TRUE`.
|
- | 328 |
+ 33 |
|
- }
+ #' @param freq (`logical(1)`)
|
- | 329 |
+ 34 |
|
- }
+ #' Indicates whether to display frequency (`TRUE`) or density (`FALSE`).
|
- | 330 |
+ 35 |
|
- }
+ #' Defaults to density (`FALSE`).
|
- | 331 |
+ 36 |
|
- }
+ #'
|
- | 332 |
+ 37 |
|
-
+ #' @inherit shared_params return
|
-
- | 333 |
- ! |
+
+ | 38 |
+ |
- selector_list <- teal.transform::data_extract_multiple_srv(
+ #'
|
-
- | 334 |
- ! |
+
+ | 39 |
+ |
- data_extract = data_extract,
+ #' @note For more examples, please see the vignette "Using response plot" via
|
-
- | 335 |
- ! |
+
+ | 40 |
+ |
- datasets = data,
+ #' `vignette("using-response-plot", package = "teal.modules.general")`.
|
-
- | 336 |
- ! |
+
+ | 41 |
+ |
- select_validation_rule = list(
+ #'
|
-
- | 337 |
- ! |
+
+ | 42 |
+ |
- response = shinyvalidate::sv_required("Please define a column for the response variable"),
+ #' @examplesShinylive
|
-
- | 338 |
- ! |
+
+ | 43 |
+ |
- x = shinyvalidate::sv_required("Please define a column for X variable"),
+ #' library(teal.modules.general)
|
-
- | 339 |
- ! |
+
+ | 44 |
+ |
- row_facet = shinyvalidate::compose_rules(
+ #' interactive <- function() TRUE
|
-
- | 340 |
- ! |
+
+ | 45 |
+ |
- shinyvalidate::sv_optional(),
+ #' {{ next_example }}
|
-
- | 341 |
- ! |
+
+ | 46 |
+ |
- ~ if (length(.) > 1) "There must be 1 or no row facetting variable.",
+ #' @examples
|
-
- | 342 |
- ! |
+
+ | 47 |
+ |
- rule_diff("col_facet")
+ #' # general data example
|
- | 343 |
+ 48 |
|
- ),
+ #' data <- teal_data()
|
-
- | 344 |
- ! |
+
+ | 49 |
+ |
- col_facet = shinyvalidate::compose_rules(
+ #' data <- within(data, {
|
-
- | 345 |
- ! |
+
+ | 50 |
+ |
- shinyvalidate::sv_optional(),
+ #' require(nestcolor)
|
-
- | 346 |
- ! |
+
+ | 51 |
+ |
- ~ if (length(.) > 1) "There must be 1 or no column facetting variable.",
+ #' mtcars <- mtcars
|
-
- | 347 |
- ! |
+
+ | 52 |
+ |
- rule_diff("row_facet")
+ #' for (v in c("cyl", "vs", "am", "gear")) {
|
- | 348 |
+ 53 |
|
- )
+ #' mtcars[[v]] <- as.factor(mtcars[[v]])
|
- | 349 |
+ 54 |
|
- )
+ #' }
|
- | 350 |
+ 55 |
|
- )
+ #' })
|
- | 351 |
+ 56 |
|
-
+ #' datanames(data) <- "mtcars"
|
-
- | 352 |
- ! |
+
+ | 57 |
+ |
- iv_r <- reactive({
+ #'
|
-
- | 353 |
- ! |
+
+ | 58 |
+ |
- iv <- shinyvalidate::InputValidator$new()
+ #' app <- init(
|
-
- | 354 |
- ! |
+
+ | 59 |
+ |
- iv$add_rule("ggtheme", shinyvalidate::sv_required("Please select a theme"))
+ #' data = data,
|
-
- | 355 |
- ! |
+
+ | 60 |
+ |
- teal.transform::compose_and_enable_validators(iv, selector_list)
+ #' modules = modules(
|
- | 356 |
+ 61 |
|
- })
+ #' tm_g_response(
|
- | 357 |
+ 62 |
|
-
+ #' label = "Response Plots",
|
-
- | 358 |
- ! |
+
+ | 63 |
+ |
- anl_merged_input <- teal.transform::merge_expression_srv(
+ #' response = data_extract_spec(
|
-
- | 359 |
- ! |
+
+ | 64 |
+ |
- selector_list = selector_list,
+ #' dataname = "mtcars",
|
-
- | 360 |
- ! |
+
+ | 65 |
+ |
- datasets = data
+ #' select = select_spec(
|
- | 361 |
+ 66 |
|
- )
+ #' label = "Select variable:",
|
- | 362 |
+ 67 |
|
-
+ #' choices = variable_choices(data[["mtcars"]], c("cyl", "gear")),
|
-
- | 363 |
- ! |
+
+ | 68 |
+ |
- anl_merged_q <- reactive({
+ #' selected = "cyl",
|
-
- | 364 |
- ! |
+
+ | 69 |
+ |
- req(anl_merged_input())
+ #' multiple = FALSE,
|
-
- | 365 |
- ! |
+
+ | 70 |
+ |
- data() %>%
+ #' fixed = FALSE
|
-
- | 366 |
- ! |
+
+ | 71 |
+ |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))
+ #' )
|
- | 367 |
+ 72 |
|
- })
+ #' ),
|
- | 368 |
+ 73 |
|
-
+ #' x = data_extract_spec(
|
-
- | 369 |
- ! |
+
+ | 74 |
+ |
- merged <- list(
+ #' dataname = "mtcars",
|
-
- | 370 |
- ! |
+
+ | 75 |
+ |
- anl_input_r = anl_merged_input,
+ #' select = select_spec(
|
-
- | 371 |
- ! |
+
+ | 76 |
+ |
- anl_q_r = anl_merged_q
+ #' label = "Select variable:",
|
- | 372 |
+ 77 |
|
- )
+ #' choices = variable_choices(data[["mtcars"]], c("vs", "am")),
|
- | 373 |
+ 78 |
|
-
+ #' selected = "vs",
|
-
- | 374 |
- ! |
+
+ | 79 |
+ |
- output_q <- reactive({
+ #' multiple = FALSE,
|
-
- | 375 |
- ! |
+
+ | 80 |
+ |
- teal::validate_inputs(iv_r())
+ #' fixed = FALSE
|
- | 376 |
+ 81 |
|
-
+ #' )
|
-
- | 377 |
- ! |
+
+ | 82 |
+ |
- qenv <- merged$anl_q_r()
+ #' )
|
-
- | 378 |
- ! |
+
+ | 83 |
+ |
- ANL <- qenv[["ANL"]]
+ #' )
|
-
- | 379 |
- ! |
+
+ | 84 |
+ |
- resp_var <- as.vector(merged$anl_input_r()$columns_source$response)
+ #' )
|
-
- | 380 |
- ! |
+
+ | 85 |
+ |
- x <- as.vector(merged$anl_input_r()$columns_source$x)
+ #' )
|
- | 381 |
+ 86 |
|
-
+ #' if (interactive()) {
|
-
- | 382 |
- ! |
+
+ | 87 |
+ |
- validate(need(is.factor(ANL[[resp_var]]), "Please select a factor variable as the response."))
+ #' shinyApp(app$ui, app$server)
|
-
- | 383 |
- ! |
+
+ | 88 |
+ |
- validate(need(is.factor(ANL[[x]]), "Please select a factor variable as the X-Variable."))
+ #' }
|
-
- | 384 |
- ! |
+
+ | 89 |
+ |
- teal::validate_has_data(ANL, 10)
+ #'
|
-
- | 385 |
- ! |
+
+ | 90 |
+ |
- teal::validate_has_data(ANL[, c(resp_var, x)], 10, complete = TRUE, allow_inf = FALSE)
+ #' @examplesShinylive
|
- | 386 |
+ 91 |
|
-
+ #' library(teal.modules.general)
|
-
- | 387 |
- ! |
+
+ | 92 |
+ |
- row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
+ #' interactive <- function() TRUE
|
-
- | 388 |
- ! |
+
+ | 93 |
+ |
- character(0)
+ #' {{ next_example }}
|
- | 389 |
+ 94 |
|
- } else {
+ #' @examples
|
-
- | 390 |
- ! |
+
+ | 95 |
+ |
- as.vector(merged$anl_input_r()$columns_source$row_facet)
+ #' # CDISC data example
|
- | 391 |
+ 96 |
|
- }
+ #' data <- teal_data()
|
-
- | 392 |
- ! |
+
+ | 97 |
+ |
- col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
+ #' data <- within(data, {
|
-
- | 393 |
- ! |
+
+ | 98 |
+ |
- character(0)
+ #' require(nestcolor)
|
- | 394 |
+ 99 |
|
- } else {
+ #' ADSL <- rADSL
|
-
- | 395 |
- ! |
+
+ | 100 |
+ |
- as.vector(merged$anl_input_r()$columns_source$col_facet)
+ #' })
|
- | 396 |
+ 101 |
|
- }
+ #' datanames(data) <- c("ADSL")
|
- | 397 |
+ 102 |
|
-
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
|
-
- | 398 |
- ! |
+
+ | 103 |
+ |
- freq <- input$freq == "frequency"
+ #'
|
-
- | 399 |
- ! |
+
+ | 104 |
+ |
- swap_axes <- input$coord_flip
+ #' app <- init(
|
-
- | 400 |
- ! |
+
+ | 105 |
+ |
- counts <- input$count_labels
+ #' data = data,
|
-
- | 401 |
- ! |
+
+ | 106 |
+ |
- rotate_xaxis_labels <- input$rotate_xaxis_labels
+ #' modules = modules(
|
-
- | 402 |
- ! |
+
+ | 107 |
+ |
- ggtheme <- input$ggtheme
+ #' tm_g_response(
|
- | 403 |
+ 108 |
|
-
+ #' label = "Response Plots",
|
-
- | 404 |
- ! |
+
+ | 109 |
+ |
- arg_position <- if (freq) "stack" else "fill"
+ #' response = data_extract_spec(
|
- | 405 |
+ 110 |
|
-
+ #' dataname = "ADSL",
|
-
- | 406 |
- ! |
+
+ | 111 |
+ |
- rowf <- if (length(row_facet_name) != 0) as.name(row_facet_name)
+ #' select = select_spec(
|
-
- | 407 |
- ! |
+
+ | 112 |
+ |
- colf <- if (length(col_facet_name) != 0) as.name(col_facet_name)
+ #' label = "Select variable:",
|
-
- | 408 |
- ! |
+
+ | 113 |
+ |
- resp_cl <- as.name(resp_var)
+ #' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "COUNTRY")),
|
-
- | 409 |
- ! |
+
+ | 114 |
+ |
- x_cl <- as.name(x)
+ #' selected = "BMRKR2",
|
- | 410 |
+ 115 |
|
-
+ #' multiple = FALSE,
|
-
- | 411 |
- ! |
+
+ | 116 |
+ |
- if (swap_axes) {
+ #' fixed = FALSE
|
-
- | 412 |
- ! |
+
+ | 117 |
+ |
- qenv <- teal.code::eval_code(
+ #' )
|
-
- | 413 |
- ! |
+
+ | 118 |
+ |
- qenv,
+ #' ),
|
-
- | 414 |
- ! |
+
+ | 119 |
+ |
- substitute(
+ #' x = data_extract_spec(
|
-
- | 415 |
- ! |
+
+ | 120 |
+ |
- expr = ANL[[x]] <- with(ANL, forcats::fct_rev(x_cl)),
+ #' dataname = "ADSL",
|
-
- | 416 |
- ! |
+
+ | 121 |
+ |
- env = list(x = x, x_cl = x_cl)
+ #' select = select_spec(
|
- | 417 |
+ 122 |
|
- )
+ #' label = "Select variable:",
|
- | 418 |
+ 123 |
|
- )
+ #' choices = variable_choices(data[["ADSL"]], c("SEX", "RACE")),
|
- | 419 |
+ 124 |
|
- }
+ #' selected = "RACE",
|
- | 420 |
+ 125 |
|
-
+ #' multiple = FALSE,
|
-
- | 421 |
- ! |
+
+ | 126 |
+ |
- qenv <- teal.code::eval_code(
+ #' fixed = FALSE
|
-
- | 422 |
- ! |
+
+ | 127 |
+ |
- qenv,
+ #' )
|
-
- | 423 |
- ! |
+
+ | 128 |
+ |
- substitute(
+ #' )
|
-
- | 424 |
- ! |
+
+ | 129 |
+ |
- expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]),
+ #' )
|
-
- | 425 |
- ! |
+
+ | 130 |
+ |
- env = list(resp_var = resp_var)
+ #' )
|
- | 426 |
+ 131 |
|
- )
+ #' )
|
- | 427 |
+ 132 |
|
- ) %>%
+ #' if (interactive()) {
|
- | 428 |
+ 133 |
|
- # rowf and colf will be a NULL if not set by a user
+ #' shinyApp(app$ui, app$server)
|
-
- | 429 |
- ! |
+
+ | 134 |
+ |
- teal.code::eval_code(
+ #' }
|
-
- | 430 |
- ! |
+
+ | 135 |
+ |
- substitute(
+ #'
|
-
- | 431 |
- ! |
+
+ | 136 |
+ |
- expr = ANL2 <- ANL %>%
+ #' @export
|
-
- | 432 |
- ! |
+
+ | 137 |
+ |
- dplyr::group_by_at(dplyr::vars(x_cl, resp_cl, rowf, colf)) %>%
+ #'
|
-
- | 433 |
- ! |
+
+ | 138 |
+ |
- dplyr::summarise(ns = dplyr::n()) %>%
+ tm_g_response <- function(label = "Response Plot",
|
-
- | 434 |
- ! |
+
+ | 139 |
+ |
- dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%
+ response,
|
-
- | 435 |
- ! |
+
+ | 140 |
+ |
- dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)),
+ x,
|
-
- | 436 |
- ! |
+
+ | 141 |
+ |
- env = list(x_cl = x_cl, resp_cl = resp_cl, rowf = rowf, colf = colf)
+ row_facet = NULL,
|
- | 437 |
+ 142 |
|
- )
+ col_facet = NULL,
|
- | 438 |
+ 143 |
|
- ) %>%
+ coord_flip = FALSE,
|
-
- | 439 |
- ! |
+
+ | 144 |
+ |
- teal.code::eval_code(
+ count_labels = TRUE,
|
-
- | 440 |
- ! |
+
+ | 145 |
+ |
- substitute(
+ rotate_xaxis_labels = FALSE,
|
-
- | 441 |
- ! |
+
+ | 146 |
+ |
- expr = ANL3 <- ANL %>%
+ freq = FALSE,
|
-
- | 442 |
- ! |
+
+ | 147 |
+ |
- dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%
+ plot_height = c(600, 400, 5000),
|
-
- | 443 |
- ! |
+
+ | 148 |
+ |
- dplyr::summarise(ns = dplyr::n()),
+ plot_width = NULL,
|
-
- | 444 |
- ! |
+
+ | 149 |
+ |
- env = list(x_cl = x_cl, rowf = rowf, colf = colf)
+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
- | 445 |
+ 150 |
|
- )
+ ggplot2_args = teal.widgets::ggplot2_args(),
|
- | 446 |
+ 151 |
|
- )
+ pre_output = NULL,
|
- | 447 |
+ 152 |
|
-
+ post_output = NULL) {
|
- | 448 |
+ 153 |
! |
- plot_call <- substitute(
+ message("Initializing tm_g_response")
|
-
- | 449 |
- ! |
+
+ | 154 |
+ |
- expr = ggplot(ANL2, aes(x = x_cl, y = ns)) +
+
|
-
- | 450 |
- ! |
+
+ | 155 |
+ |
- geom_bar(aes(fill = resp_cl), stat = "identity", position = arg_position),
+ # Normalize the parameters
|
- | 451 |
+ 156 |
! |
- env = list(
+ if (inherits(response, "data_extract_spec")) response <- list(response)
|
- | 452 |
+ 157 |
! |
- x_cl = x_cl,
+ if (inherits(x, "data_extract_spec")) x <- list(x)
|
- | 453 |
+ 158 |
! |
- resp_cl = resp_cl,
+ if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet)
|
- | 454 |
+ 159 |
! |
- arg_position = arg_position
+ if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet)
|
- | 455 |
+ 160 |
|
- )
+
|
- | 456 |
+ 161 |
|
- )
+ # Start of assertions
|
-
- | 457 |
- |
+
+ | 162 |
+ ! |
-
+ checkmate::assert_string(label)
|
-
- | 458 |
- ! |
+
+ | 163 |
+ |
- if (!freq) {
+
|
- | 459 |
+ 164 |
! |
- plot_call <- substitute(
+ checkmate::assert_list(response, types = "data_extract_spec")
|
- | 460 |
+ 165 |
! |
- plot_call + expand_limits(y = c(0, 1.1)),
+ if (!all(vapply(response, function(x) !("" %in% x$select$choices), logical(1)))) {
|
- | 461 |
+ 166 |
! |
- env = list(plot_call = plot_call)
+ stop("'response' should not allow empty values")
|
- | 462 |
+ 167 |
|
- )
+ }
|
-
- | 463 |
- |
+
+ | 168 |
+ ! |
- }
+ assert_single_selection(response)
|
- | 464 |
+ 169 |
|
|
- | 465 |
- ! |
-
- if (counts) {
- |
-
-
- | 466 |
+ 170 |
! |
- plot_call <- substitute(
+ checkmate::assert_list(x, types = "data_extract_spec")
|
- | 467 |
+ 171 |
! |
- expr = plot_call +
+ if (!all(vapply(x, function(x) !("" %in% x$select$choices), logical(1)))) {
|
- | 468 |
+ 172 |
! |
- geom_text(
+ stop("'x' should not allow empty values")
|
-
- | 469 |
- ! |
+
+ | 173 |
+ |
- data = ANL2,
+ }
|
- | 470 |
+ 174 |
! |
- aes(label = ns, x = x_cl, y = ns, group = resp_cl),
+ assert_single_selection(x)
|
-
- | 471 |
- ! |
+
+ | 175 |
+ |
- col = "white",
+
|
- | 472 |
+ 176 |
! |
- vjust = "middle",
+ checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE)
|
- | 473 |
+ 177 |
! |
- hjust = "middle",
+ checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE)
|
- | 474 |
+ 178 |
! |
- position = position_anl2_value
- |
-
-
- | 475 |
- |
-
- ) +
+ checkmate::assert_flag(coord_flip)
|
- | 476 |
+ 179 |
! |
- geom_text(
+ checkmate::assert_flag(count_labels)
|
- | 477 |
+ 180 |
! |
- data = ANL3, aes(label = ns, x = x_cl, y = anl3_y),
+ checkmate::assert_flag(rotate_xaxis_labels)
|
- | 478 |
+ 181 |
! |
- hjust = hjust_value,
+ checkmate::assert_flag(freq)
|
-
- | 479 |
- ! |
+
+ | 182 |
+ |
- vjust = vjust_value,
+
|
- | 480 |
+ 183 |
! |
- position = position_anl3_value
- |
-
-
- | 481 |
- |
-
- ),
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
|
- | 482 |
+ 184 |
! |
- env = list(
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
|
- | 483 |
+ 185 |
! |
- plot_call = plot_call,
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
|
- | 484 |
+ 186 |
! |
- x_cl = x_cl,
+ checkmate::assert_numeric(
|
- | 485 |
+ 187 |
! |
- resp_cl = resp_cl,
+ plot_width[1],
|
- | 486 |
+ 188 |
! |
- hjust_value = if (swap_axes) "left" else "middle",
+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
|
-
- | 487 |
- ! |
+
+ | 189 |
+ |
- vjust_value = if (swap_axes) "middle" else -1,
+ )
|
-
- | 488 |
- ! |
+
+ | 190 |
+ |
- position_anl2_value = if (!freq) quote(position_fill(0.5)) else quote(position_stack(0.5)), # nolint: line_length.
+
|
- | 489 |
+ 191 |
! |
- anl3_y = if (!freq) 1.1 else as.name("ns"),
+ ggtheme <- match.arg(ggtheme)
|
- | 490 |
+ 192 |
! |
- position_anl3_value = if (!freq) "fill" else "stack"
+ checkmate::assert_class(ggplot2_args, "ggplot2_args")
|
- | 491 |
+ 193 |
|
- )
+
|
-
- | 492 |
- |
+
+ | 194 |
+ ! |
- )
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ |
+
+
+ | 195 |
+ ! |
+
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
- | 493 |
+ 196 |
|
- }
+ # End of assertions
|
- | 494 |
+ 197 |
|
|
-
- | 495 |
- ! |
+
+ | 198 |
+ |
- if (swap_axes) {
+ # Make UI args
|
- | 496 |
+ 199 |
! |
- plot_call <- substitute(plot_call + coord_flip(), env = list(plot_call = plot_call))
+ args <- as.list(environment())
|
- | 497 |
+ 200 |
|
- }
+
|
-
- | 498 |
- |
+
+ | 201 |
+ ! |
-
+ data_extract_list <- list(
|
- | 499 |
+ 202 |
! |
- facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name)
+ response = response,
|
-
- | 500 |
- |
+
+ | 203 |
+ ! |
-
+ x = x,
|
- | 501 |
+ 204 |
! |
- if (!is.null(facet_cl)) {
+ row_facet = row_facet,
|
- | 502 |
+ 205 |
! |
- plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))
+ col_facet = col_facet
|
- | 503 |
+ 206 |
|
- }
+ )
|
- | 504 |
+ 207 |
|
|
- | 505 |
+ 208 |
! |
- dev_ggplot2_args <- teal.widgets::ggplot2_args(
+ ans <- module(
|
- | 506 |
+ 209 |
! |
- labs = list(
+ label = label,
|
- | 507 |
+ 210 |
! |
- x = varname_w_label(x, ANL),
+ server = srv_g_response,
|
- | 508 |
+ 211 |
! |
- y = varname_w_label(resp_var, ANL, prefix = "Proportion of "),
+ ui = ui_g_response,
|
- | 509 |
+ 212 |
! |
- fill = varname_w_label(resp_var, ANL)
+ ui_args = args,
|
-
- | 510 |
- |
+
+ | 213 |
+ ! |
- ),
+ server_args = c(
|
- | 511 |
+ 214 |
! |
- theme = list(legend.position = "bottom")
+ data_extract_list,
+ |
+
+
+ | 215 |
+ ! |
+
+ list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)
|
- | 512 |
+ 216 |
|
- )
+ ),
+ |
+
+
+ | 217 |
+ ! |
+
+ datanames = teal.transform::get_extract_datanames(data_extract_list)
|
- | 513 |
+ 218 |
|
-
+ )
|
- | 514 |
+ 219 |
! |
- if (rotate_xaxis_labels) {
+ attr(ans, "teal_bookmarkable") <- TRUE
|
- | 515 |
+ 220 |
! |
- dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1))
+ ans
|
- | 516 |
+ 221 |
|
- }
+ }
|
- | 517 |
+ 222 |
|
|
-
- | 518 |
- ! |
+
+ | 223 |
+ |
- all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
+ # UI function for the response module
+ |
+
+
+ | 224 |
+ |
+
+ ui_g_response <- function(id, ...) {
|
- | 519 |
+ 225 |
! |
- user_plot = ggplot2_args,
+ ns <- NS(id)
|
- | 520 |
+ 226 |
! |
- module_plot = dev_ggplot2_args
+ args <- list(...)
|
-
- | 521 |
- |
+
+ | 227 |
+ ! |
- )
+ is_single_dataset_value <- teal.transform::is_single_dataset(args$response, args$x, args$row_facet, args$col_facet)
|
- | 522 |
+ 228 |
|
|
- | 523 |
+ 229 |
! |
- parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
+ teal.widgets::standard_layout(
|
- | 524 |
+ 230 |
! |
- all_ggplot2_args,
+ output = teal.widgets::white_small_well(
|
- | 525 |
+ 231 |
! |
- ggtheme = ggtheme
+ teal.widgets::plot_with_settings_ui(id = ns("myplot"))
|
- | 526 |
+ 232 |
|
- )
+ ),
+ |
+
+
+ | 233 |
+ ! |
+
+ encoding = tags$div(
|
- | 527 |
+ 234 |
|
-
+ ### Reporter
|
- | 528 |
+ 235 |
! |
- plot_call <- substitute(expr = {
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ |
+
+
+ | 236 |
+ |
+
+ ###
|
- | 529 |
+ 237 |
! |
- p <- plot_call + labs + ggthemes + themes
+ tags$label("Encodings", class = "text-primary"),
|
- | 530 |
+ 238 |
! |
- print(p)
+ teal.transform::datanames_input(args[c("response", "x", "row_facet", "col_facet")]),
|
- | 531 |
+ 239 |
! |
- }, env = list(
+ teal.transform::data_extract_ui(
|
- | 532 |
+ 240 |
! |
- plot_call = plot_call,
+ id = ns("response"),
|
- | 533 |
+ 241 |
! |
- labs = parsed_ggplot2_args$labs,
+ label = "Response variable",
|
- | 534 |
+ 242 |
! |
- themes = parsed_ggplot2_args$theme,
+ data_extract_spec = args$response,
|
- | 535 |
+ 243 |
! |
- ggthemes = parsed_ggplot2_args$ggtheme
+ is_single_dataset = is_single_dataset_value
|
- | 536 |
+ 244 |
|
- ))
+ ),
|
-
- | 537 |
- |
+
+ | 245 |
+ ! |
-
+ teal.transform::data_extract_ui(
|
- | 538 |
+ 246 |
! |
- teal.code::eval_code(qenv, plot_call)
+ id = ns("x"),
|
-
- | 539 |
- |
+
+ | 247 |
+ ! |
- })
+ label = "X variable",
|
-
- | 540 |
- |
+
+ | 248 |
+ ! |
-
+ data_extract_spec = args$x,
|
- | 541 |
+ 249 |
! |
- plot_r <- reactive(output_q()[["p"]])
+ is_single_dataset = is_single_dataset_value
|
- | 542 |
+ 250 |
|
-
+ ),
|
-
- | 543 |
- |
+
+ | 251 |
+ ! |
- # Insert the plot into a plot_with_settings module from teal.widgets
+ if (!is.null(args$row_facet)) {
|
- | 544 |
+ 252 |
! |
- pws <- teal.widgets::plot_with_settings_srv(
+ teal.transform::data_extract_ui(
|
- | 545 |
+ 253 |
! |
- id = "myplot",
+ id = ns("row_facet"),
|
- | 546 |
+ 254 |
! |
- plot_r = plot_r,
+ label = "Row facetting",
|
- | 547 |
+ 255 |
! |
- height = plot_height,
+ data_extract_spec = args$row_facet,
|
- | 548 |
+ 256 |
! |
- width = plot_width
+ is_single_dataset = is_single_dataset_value
|
- | 549 |
+ 257 |
|
- )
+ )
|
- | 550 |
+ 258 |
|
-
+ },
|
- | 551 |
+ 259 |
! |
- teal.widgets::verbatim_popup_srv(
+ if (!is.null(args$col_facet)) {
|
- | 552 |
+ 260 |
! |
- id = "rcode",
+ teal.transform::data_extract_ui(
|
- | 553 |
+ 261 |
! |
- verbatim_content = reactive(teal.code::get_code(output_q())),
+ id = ns("col_facet"),
|
- | 554 |
+ 262 |
! |
- title = "Show R Code for Response"
+ label = "Column facetting",
|
-
- | 555 |
- |
+
+ | 263 |
+ ! |
- )
+ data_extract_spec = args$col_facet,
+ |
+
+
+ | 264 |
+ ! |
+
+ is_single_dataset = is_single_dataset_value
|
- | 556 |
+ 265 |
|
-
+ )
|
- | 557 |
+ 266 |
|
- ### REPORTER
+ },
|
- | 558 |
+ 267 |
! |
- if (with_reporter) {
+ shinyWidgets::radioGroupButtons(
|
- | 559 |
+ 268 |
! |
- card_fun <- function(comment, label) {
+ inputId = ns("freq"),
|
- | 560 |
+ 269 |
! |
- card <- teal::report_card_template(
+ label = NULL,
|
- | 561 |
+ 270 |
! |
- title = "Response Plot",
+ choices = c("frequency", "density"),
|
- | 562 |
+ 271 |
! |
- label = label,
+ selected = ifelse(args$freq, "frequency", "density"),
|
- | 563 |
+ 272 |
! |
- with_filter = with_filter,
+ justified = TRUE
+ |
+
+
+ | 273 |
+ |
+
+ ),
|
- | 564 |
+ 274 |
! |
- filter_panel_api = filter_panel_api
+ teal.widgets::panel_group(
|
-
- | 565 |
- |
+
+ | 275 |
+ ! |
- )
+ teal.widgets::panel_item(
|
- | 566 |
+ 276 |
! |
- card$append_text("Plot", "header3")
+ title = "Plot settings",
|
- | 567 |
+ 277 |
! |
- card$append_plot(plot_r(), dim = pws$dim())
+ checkboxInput(ns("count_labels"), "Add count labels", value = args$count_labels),
|
- | 568 |
+ 278 |
! |
- if (!comment == "") {
+ checkboxInput(ns("coord_flip"), "Swap axes", value = args$coord_flip),
|
- | 569 |
+ 279 |
! |
- card$append_text("Comment", "header3")
+ checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels),
|
- | 570 |
+ 280 |
! |
- card$append_text(comment)
+ selectInput(
|
-
- | 571 |
- |
+
+ | 281 |
+ ! |
- }
+ inputId = ns("ggtheme"),
|
- | 572 |
+ 282 |
! |
- card$append_src(teal.code::get_code(output_q()))
+ label = "Theme (by ggplot):",
|
- | 573 |
+ 283 |
! |
- card
+ choices = ggplot_themes,
|
-
- | 574 |
- |
+
+ | 284 |
+ ! |
- }
+ selected = args$ggtheme,
|
- | 575 |
+ 285 |
! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ multiple = FALSE
|
- | 576 |
+ 286 |
|
- }
+ )
|
- | 577 |
+ 287 |
|
- ###
+ )
|
- | 578 |
+ 288 |
|
- })
+ )
|
- | 579 |
+ 289 |
|
- }
+ ),
|
-
-
-
-
-
-
-
- | 1 |
- |
+
+ | 290 |
+ ! |
- #' `teal` module: Scatterplot matrix
+ forms = tagList(
|
-
- | 2 |
- |
+
+ | 291 |
+ ! |
- #'
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
- | 3 |
+ 292 |
|
- #' Generates a scatterplot matrix from selected `variables` from datasets.
+ ),
+ |
+
+
+ | 293 |
+ ! |
+
+ pre_output = args$pre_output,
+ |
+
+
+ | 294 |
+ ! |
+
+ post_output = args$post_output
|
- | 4 |
+ 295 |
|
- #' Each plot within the matrix represents the relationship between two variables,
+ )
|
- | 5 |
+ 296 |
|
- #' providing the overview of correlations and distributions across selected data.
+ }
|
- | 6 |
+ 297 |
|
- #'
+
|
- | 7 |
+ 298 |
|
- #' @note For more examples, please see the vignette "Using scatterplot matrix" via
+ # Server function for the response module
|
- | 8 |
+ 299 |
|
- #' `vignette("using-scatterplot-matrix", package = "teal.modules.general")`.
+ srv_g_response <- function(id,
|
- | 9 |
+ 300 |
|
- #'
+ data,
|
- | 10 |
+ 301 |
|
- #' @inheritParams teal::module
+ reporter,
|
- | 11 |
+ 302 |
|
- #' @inheritParams tm_g_scatterplot
+ filter_panel_api,
|
- | 12 |
+ 303 |
|
- #' @inheritParams shared_params
+ response,
|
- | 13 |
+ 304 |
|
- #'
+ x,
|
- | 14 |
+ 305 |
|
- #' @param variables (`data_extract_spec` or `list` of multiple `data_extract_spec`)
+ row_facet,
|
- | 15 |
+ 306 |
|
- #' Specifies plotting variables from an incoming dataset with filtering and selecting. In case of
+ col_facet,
|
- | 16 |
+ 307 |
|
- #' `data_extract_spec` use `select_spec(..., ordered = TRUE)` if plot elements should be
+ plot_height,
|
- | 17 |
+ 308 |
|
- #' rendered according to selection order.
+ plot_width,
|
- | 18 |
+ 309 |
|
- #'
+ ggplot2_args) {
|
-
- | 19 |
- |
+
+ | 310 |
+ ! |
- #' @inherit shared_params return
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
|
-
- | 20 |
- |
+
+ | 311 |
+ ! |
- #'
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
|
-
- | 21 |
- |
+
+ | 312 |
+ ! |
- #' @examples
+ checkmate::assert_class(data, "reactive")
|
-
- | 22 |
- |
+
+ | 313 |
+ ! |
- #' # general data example
+ checkmate::assert_class(isolate(data()), "teal_data")
|
-
- | 23 |
- |
+
+ | 314 |
+ ! |
- #' data <- teal_data()
+ moduleServer(id, function(input, output, session) {
|
-
- | 24 |
- |
+
+ | 315 |
+ ! |
- #' data <- within(data, {
+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
|
- | 25 |
+ 316 |
|
- #' countries <- data.frame(
+
|
-
- | 26 |
- |
+
+ | 317 |
+ ! |
- #' id = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
+ data_extract <- list(response = response, x = x, row_facet = row_facet, col_facet = col_facet)
|
- | 27 |
+ 318 |
|
- #' government = factor(
+
|
-
- | 28 |
- |
+
+ | 319 |
+ ! |
- #' c(2, 2, 2, 1, 2, 2, 1, 1, 1, 2),
+ rule_diff <- function(other) {
|
-
- | 29 |
- |
+
+ | 320 |
+ ! |
- #' labels = c("Monarchy", "Republic")
+ function(value) {
|
-
- | 30 |
- |
+
+ | 321 |
+ ! |
- #' ),
+ if (other %in% names(selector_list())) {
|
-
- | 31 |
- |
+
+ | 322 |
+ ! |
- #' language_family = factor(
+ othervalue <- selector_list()[[other]]()[["select"]]
|
-
- | 32 |
- |
+
+ | 323 |
+ ! |
- #' c(1, 3, 3, 3, 3, 2, 1, 1, 3, 1),
+ if (!is.null(othervalue)) {
|
-
- | 33 |
- |
+
+ | 324 |
+ ! |
- #' labels = c("Germanic", "Hellenic", "Romance")
+ if (identical(value, othervalue)) {
|
-
- | 34 |
- |
+
+ | 325 |
+ ! |
- #' ),
+ "Row and column facetting variables must be different."
|
- | 35 |
+ 326 |
|
- #' population = c(83, 67, 60, 47, 10, 11, 17, 11, 0.6, 9),
+ }
|
- | 36 |
+ 327 |
|
- #' area = c(357, 551, 301, 505, 92, 132, 41, 30, 2.6, 83),
+ }
|
- | 37 |
+ 328 |
|
- #' gdp = c(3.4, 2.7, 2.1, 1.4, 0.3, 0.2, 0.7, 0.5, 0.1, 0.4),
+ }
|
- | 38 |
+ 329 |
|
- #' debt = c(2.1, 2.3, 2.4, 2.6, 2.3, 2.4, 2.3, 2.4, 2.3, 2.4)
+ }
|
- | 39 |
+ 330 |
|
- #' )
+ }
|
- | 40 |
+ 331 |
|
- #' sales <- data.frame(
+
|
-
- | 41 |
- |
+
+ | 332 |
+ ! |
- #' id = 1:50,
+ selector_list <- teal.transform::data_extract_multiple_srv(
|
-
- | 42 |
- |
+
+ | 333 |
+ ! |
- #' country_id = sample(
+ data_extract = data_extract,
|
-
- | 43 |
- |
+
+ | 334 |
+ ! |
- #' c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
+ datasets = data,
|
-
- | 44 |
- |
+
+ | 335 |
+ ! |
- #' size = 50,
+ select_validation_rule = list(
|
-
- | 45 |
- |
+
+ | 336 |
+ ! |
- #' replace = TRUE
+ response = shinyvalidate::sv_required("Please define a column for the response variable"),
|
-
- | 46 |
- |
+
+ | 337 |
+ ! |
- #' ),
+ x = shinyvalidate::sv_required("Please define a column for X variable"),
|
-
- | 47 |
- |
+
+ | 338 |
+ ! |
- #' year = sort(sample(2010:2020, 50, replace = TRUE)),
+ row_facet = shinyvalidate::compose_rules(
|
-
- | 48 |
- |
+
+ | 339 |
+ ! |
- #' venue = sample(c("small", "medium", "large", "online"), 50, replace = TRUE),
+ shinyvalidate::sv_optional(),
|
-
- | 49 |
- |
+
+ | 340 |
+ ! |
- #' cancelled = sample(c(TRUE, FALSE), 50, replace = TRUE),
+ ~ if (length(.) > 1) "There must be 1 or no row facetting variable.",
|
-
- | 50 |
- |
+
+ | 341 |
+ ! |
- #' quantity = rnorm(50, 100, 20),
+ rule_diff("col_facet")
|
- | 51 |
+ 342 |
|
- #' costs = rnorm(50, 80, 20),
+ ),
|
-
- | 52 |
- |
+
+ | 343 |
+ ! |
- #' profit = rnorm(50, 20, 10)
+ col_facet = shinyvalidate::compose_rules(
|
-
- | 53 |
- |
+
+ | 344 |
+ ! |
- #' )
+ shinyvalidate::sv_optional(),
|
-
- | 54 |
- |
+
+ | 345 |
+ ! |
- #' })
+ ~ if (length(.) > 1) "There must be 1 or no column facetting variable.",
|
-
- | 55 |
- |
+
+ | 346 |
+ ! |
- #' datanames(data) <- c("countries", "sales")
+ rule_diff("row_facet")
|
- | 56 |
+ 347 |
|
- #' join_keys(data) <- join_keys(
+ )
|
- | 57 |
+ 348 |
|
- #' join_key("countries", "countries", "id"),
+ )
|
- | 58 |
+ 349 |
|
- #' join_key("sales", "sales", "id"),
+ )
|
- | 59 |
+ 350 |
|
- #' join_key("countries", "sales", c("id" = "country_id"))
+
|
-
- | 60 |
- |
+
+ | 351 |
+ ! |
- #' )
+ iv_r <- reactive({
|
-
- | 61 |
- |
+
+ | 352 |
+ ! |
- #'
+ iv <- shinyvalidate::InputValidator$new()
|
-
- | 62 |
- |
+
+ | 353 |
+ ! |
- #' app <- init(
+ iv$add_rule("ggtheme", shinyvalidate::sv_required("Please select a theme"))
|
-
- | 63 |
- |
+
+ | 354 |
+ ! |
- #' data = data,
+ teal.transform::compose_and_enable_validators(iv, selector_list)
|
- | 64 |
+ 355 |
|
- #' modules = modules(
+ })
|
- | 65 |
+ 356 |
|
- #' tm_g_scatterplotmatrix(
+
|
-
- | 66 |
- |
+
+ | 357 |
+ ! |
- #' label = "Scatterplot matrix",
+ anl_merged_input <- teal.transform::merge_expression_srv(
|
-
- | 67 |
- |
+
+ | 358 |
+ ! |
- #' variables = list(
+ selector_list = selector_list,
|
-
- | 68 |
- |
+
+ | 359 |
+ ! |
- #' data_extract_spec(
+ datasets = data
|
- | 69 |
+ 360 |
|
- #' dataname = "countries",
+ )
|
- | 70 |
+ 361 |
|
- #' select = select_spec(
+
|
-
- | 71 |
- |
+
+ | 362 |
+ ! |
- #' label = "Select variables:",
+ anl_merged_q <- reactive({
|
-
- | 72 |
- |
+
+ | 363 |
+ ! |
- #' choices = variable_choices(data[["countries"]]),
+ req(anl_merged_input())
|
-
- | 73 |
- |
+
+ | 364 |
+ ! |
- #' selected = c("area", "gdp", "debt"),
+ data() %>%
|
-
- | 74 |
- |
+
+ | 365 |
+ ! |
- #' multiple = TRUE,
+ teal.code::eval_code(as.expression(anl_merged_input()$expr))
|
- | 75 |
+ 366 |
|
- #' ordered = TRUE,
+ })
|
- | 76 |
+ 367 |
|
- #' fixed = FALSE
+
|
-
- | 77 |
- |
+
+ | 368 |
+ ! |
- #' )
+ merged <- list(
|
-
- | 78 |
- |
+
+ | 369 |
+ ! |
- #' ),
+ anl_input_r = anl_merged_input,
|
-
- | 79 |
- |
+
+ | 370 |
+ ! |
- #' data_extract_spec(
+ anl_q_r = anl_merged_q
|
- | 80 |
+ 371 |
|
- #' dataname = "sales",
+ )
|
- | 81 |
+ 372 |
|
- #' filter = filter_spec(
+
|
-
- | 82 |
- |
+
+ | 373 |
+ ! |
- #' label = "Select variable:",
+ output_q <- reactive({
|
-
- | 83 |
- |
+
+ | 374 |
+ ! |
- #' vars = "country_id",
+ teal::validate_inputs(iv_r())
|
- | 84 |
+ 375 |
|
- #' choices = value_choices(data[["sales"]], "country_id"),
+
|
-
- | 85 |
- |
+
+ | 376 |
+ ! |
+
+ qenv <- merged$anl_q_r()
+ |
+
+
+ | 377 |
+ ! |
- #' selected = c("DE", "FR", "IT", "ES", "PT", "GR", "NL", "BE", "LU", "AT"),
+ ANL <- qenv[["ANL"]]
|
-
- | 86 |
- |
+
+ | 378 |
+ ! |
- #' multiple = TRUE
+ resp_var <- as.vector(merged$anl_input_r()$columns_source$response)
|
-
- | 87 |
- |
+
+ | 379 |
+ ! |
- #' ),
+ x <- as.vector(merged$anl_input_r()$columns_source$x)
|
- | 88 |
+ 380 |
|
- #' select = select_spec(
+
|
-
- | 89 |
- |
+
+ | 381 |
+ ! |
- #' label = "Select variables:",
+ validate(need(is.factor(ANL[[resp_var]]), "Please select a factor variable as the response."))
|
-
- | 90 |
- |
+
+ | 382 |
+ ! |
- #' choices = variable_choices(data[["sales"]], c("quantity", "costs", "profit")),
+ validate(need(is.factor(ANL[[x]]), "Please select a factor variable as the X-Variable."))
|
-
- | 91 |
- |
+
+ | 383 |
+ ! |
- #' selected = c("quantity", "costs", "profit"),
+ teal::validate_has_data(ANL, 10)
|
-
- | 92 |
- |
+
+ | 384 |
+ ! |
- #' multiple = TRUE,
+ teal::validate_has_data(ANL[, c(resp_var, x)], 10, complete = TRUE, allow_inf = FALSE)
|
- | 93 |
+ 385 |
|
- #' ordered = TRUE,
+
|
-
- | 94 |
- |
+
+ | 386 |
+ ! |
- #' fixed = FALSE
+ row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) {
|
-
- | 95 |
- |
+
+ | 387 |
+ ! |
- #' )
+ character(0)
|
- | 96 |
+ 388 |
|
- #' )
+ } else {
|
-
- | 97 |
- |
+
+ | 389 |
+ ! |
- #' )
+ as.vector(merged$anl_input_r()$columns_source$row_facet)
|
- | 98 |
+ 390 |
|
- #' )
+ }
|
-
- | 99 |
- |
+
+ | 391 |
+ ! |
- #' )
+ col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) {
|
-
- | 100 |
- |
+
+ | 392 |
+ ! |
- #' )
+ character(0)
|
- | 101 |
+ 393 |
|
- #' if (interactive()) {
+ } else {
|
-
- | 102 |
- |
+
+ | 394 |
+ ! |
- #' shinyApp(app$ui, app$server)
+ as.vector(merged$anl_input_r()$columns_source$col_facet)
|
- | 103 |
+ 395 |
|
- #' }
+ }
|
- | 104 |
+ 396 |
|
- #'
+
|
-
- | 105 |
- |
+
+ | 397 |
+ ! |
- #' # CDISC data example
+ freq <- input$freq == "frequency"
|
-
- | 106 |
- |
+
+ | 398 |
+ ! |
- #' data <- teal_data()
+ swap_axes <- input$coord_flip
|
-
- | 107 |
- |
+
+ | 399 |
+ ! |
- #' data <- within(data, {
+ counts <- input$count_labels
|
-
- | 108 |
- |
+
+ | 400 |
+ ! |
- #' ADSL <- rADSL
+ rotate_xaxis_labels <- input$rotate_xaxis_labels
|
-
- | 109 |
- |
+
+ | 401 |
+ ! |
- #' ADRS <- rADRS
+ ggtheme <- input$ggtheme
|
- | 110 |
+ 402 |
|
- #' })
+
|
-
- | 111 |
- |
+
+ | 403 |
+ ! |
- #' datanames(data) <- c("ADSL", "ADRS")
+ arg_position <- if (freq) "stack" else "fill"
|
- | 112 |
+ 404 |
|
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
+
|
-
- | 113 |
- |
+
+ | 405 |
+ ! |
- #'
+ rowf <- if (length(row_facet_name) != 0) as.name(row_facet_name)
|
-
- | 114 |
- |
+
+ | 406 |
+ ! |
- #' app <- init(
+ colf <- if (length(col_facet_name) != 0) as.name(col_facet_name)
|
-
- | 115 |
- |
+
+ | 407 |
+ ! |
- #' data = data,
+ resp_cl <- as.name(resp_var)
|
-
- | 116 |
- |
+
+ | 408 |
+ ! |
- #' modules = modules(
+ x_cl <- as.name(x)
|
- | 117 |
+ 409 |
|
- #' tm_g_scatterplotmatrix(
+
|
-
- | 118 |
- |
+
+ | 410 |
+ ! |
- #' label = "Scatterplot matrix",
+ if (swap_axes) {
|
-
- | 119 |
- |
+
+ | 411 |
+ ! |
- #' variables = list(
+ qenv <- teal.code::eval_code(
|
-
- | 120 |
- |
+
+ | 412 |
+ ! |
- #' data_extract_spec(
+ qenv,
|
-
- | 121 |
- |
+
+ | 413 |
+ ! |
- #' dataname = "ADSL",
+ substitute(
|
-
- | 122 |
- |
+
+ | 414 |
+ ! |
- #' select = select_spec(
+ expr = ANL[[x]] <- with(ANL, forcats::fct_rev(x_cl)),
|
-
- | 123 |
- |
+
+ | 415 |
+ ! |
- #' label = "Select variables:",
+ env = list(x = x, x_cl = x_cl)
|
- | 124 |
+ 416 |
|
- #' choices = variable_choices(data[["ADSL"]]),
+ )
|
- | 125 |
+ 417 |
|
- #' selected = c("AGE", "RACE", "SEX"),
+ )
|
- | 126 |
+ 418 |
|
- #' multiple = TRUE,
+ }
|
- | 127 |
+ 419 |
|
- #' ordered = TRUE,
+
|
-
- | 128 |
- |
+
+ | 420 |
+ ! |
- #' fixed = FALSE
+ qenv <- teal.code::eval_code(
|
-
- | 129 |
- |
+
+ | 421 |
+ ! |
- #' )
+ qenv,
|
-
- | 130 |
- |
+
+ | 422 |
+ ! |
- #' ),
+ substitute(
|
-
- | 131 |
- |
+
+ | 423 |
+ ! |
- #' data_extract_spec(
+ expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]),
|
-
- | 132 |
- |
+
+ | 424 |
+ ! |
- #' dataname = "ADRS",
+ env = list(resp_var = resp_var)
|
- | 133 |
+ 425 |
|
- #' filter = filter_spec(
+ )
|
- | 134 |
+ 426 |
|
- #' label = "Select endpoints:",
+ ) %>%
|
- | 135 |
+ 427 |
|
- #' vars = c("PARAMCD", "AVISIT"),
+ # rowf and colf will be a NULL if not set by a user
|
-
- | 136 |
- |
+
+ | 428 |
+ ! |
- #' choices = value_choices(data[["ADRS"]], c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")),
+ teal.code::eval_code(
|
-
- | 137 |
- |
+
+ | 429 |
+ ! |
- #' selected = "INVET - END OF INDUCTION",
+ substitute(
|
-
- | 138 |
- |
+
+ | 430 |
+ ! |
- #' multiple = TRUE
+ expr = ANL2 <- ANL %>%
|
-
- | 139 |
- |
+
+ | 431 |
+ ! |
- #' ),
+ dplyr::group_by_at(dplyr::vars(x_cl, resp_cl, rowf, colf)) %>%
|
-
- | 140 |
- |
+
+ | 432 |
+ ! |
- #' select = select_spec(
+ dplyr::summarise(ns = dplyr::n()) %>%
|
-
- | 141 |
- |
+
+ | 433 |
+ ! |
- #' label = "Select variables:",
+ dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%
|
-
- | 142 |
- |
+
+ | 434 |
+ ! |
- #' choices = variable_choices(data[["ADRS"]]),
+ dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)),
|
-
- | 143 |
- |
+
+ | 435 |
+ ! |
- #' selected = c("AGE", "AVAL", "ADY"),
+ env = list(x_cl = x_cl, resp_cl = resp_cl, rowf = rowf, colf = colf)
|
- | 144 |
+ 436 |
|
- #' multiple = TRUE,
+ )
|
- | 145 |
+ 437 |
|
- #' ordered = TRUE,
+ ) %>%
|
-
- | 146 |
- |
+
+ | 438 |
+ ! |
- #' fixed = FALSE
+ teal.code::eval_code(
|
-
- | 147 |
- |
+
+ | 439 |
+ ! |
- #' )
+ substitute(
|
-
- | 148 |
- |
+
+ | 440 |
+ ! |
- #' )
+ expr = ANL3 <- ANL %>%
|
-
- | 149 |
- |
+
+ | 441 |
+ ! |
- #' )
+ dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>%
|
-
- | 150 |
- |
+
+ | 442 |
+ ! |
- #' )
+ dplyr::summarise(ns = dplyr::n()),
|
-
- | 151 |
- |
+
+ | 443 |
+ ! |
- #' )
+ env = list(x_cl = x_cl, rowf = rowf, colf = colf)
|
- | 152 |
+ 444 |
|
- #' )
+ )
|
- | 153 |
+ 445 |
|
- #' if (interactive()) {
+ )
|
- | 154 |
+ 446 |
|
- #' shinyApp(app$ui, app$server)
+
|
-
- | 155 |
- |
+
+ | 447 |
+ ! |
- #' }
+ plot_call <- substitute(
|
-
- | 156 |
- |
+
+ | 448 |
+ ! |
- #'
+ expr = ggplot(ANL2, aes(x = x_cl, y = ns)) +
|
-
- | 157 |
- |
+
+ | 449 |
+ ! |
- #' @export
+ geom_bar(aes(fill = resp_cl), stat = "identity", position = arg_position),
|
-
- | 158 |
- |
+
+ | 450 |
+ ! |
- #'
+ env = list(
|
-
- | 159 |
- |
+
+ | 451 |
+ ! |
- tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix",
+ x_cl = x_cl,
|
-
- | 160 |
- |
+
+ | 452 |
+ ! |
- variables,
+ resp_cl = resp_cl,
|
-
- | 161 |
- |
+
+ | 453 |
+ ! |
- plot_height = c(600, 200, 2000),
+ arg_position = arg_position
|
- | 162 |
+ 454 |
|
- plot_width = NULL,
+ )
|
- | 163 |
+ 455 |
|
- pre_output = NULL,
+ )
|
- | 164 |
+ 456 |
|
- post_output = NULL) {
+
|
- | 165 |
+ 457 |
! |
- message("Initializing tm_g_scatterplotmatrix")
- |
-
-
- | 166 |
- |
-
-
+ if (!freq) {
|
-
- | 167 |
- |
+
+ | 458 |
+ ! |
- # Requires Suggested packages
+ plot_call <- substitute(
|
- | 168 |
+ 459 |
! |
- if (!requireNamespace("lattice", quietly = TRUE)) {
+ plot_call + expand_limits(y = c(0, 1.1)),
|
- | 169 |
+ 460 |
! |
- stop("Cannot load lattice - please install the package or restart your session.")
+ env = list(plot_call = plot_call)
|
- | 170 |
+ 461 |
|
- }
+ )
|
- | 171 |
+ 462 |
|
-
+ }
|
- | 172 |
+ 463 |
|
- # Normalize the parameters
+
|
- | 173 |
+ 464 |
! |
- if (inherits(variables, "data_extract_spec")) variables <- list(variables)
- |
-
-
- | 174 |
- |
-
-
- |
-
-
- | 175 |
- |
-
- # Start of assertions
+ if (counts) {
|
- | 176 |
+ 465 |
! |
- checkmate::assert_string(label)
+ plot_call <- substitute(
|
- | 177 |
+ 466 |
! |
- checkmate::assert_list(variables, types = "data_extract_spec")
- |
-
-
- | 178 |
- |
-
-
+ expr = plot_call +
|
- | 179 |
+ 467 |
! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
+ geom_text(
|
- | 180 |
+ 468 |
! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
+ data = ANL2,
|
- | 181 |
+ 469 |
! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
+ aes(label = ns, x = x_cl, y = ns, group = resp_cl),
|
- | 182 |
+ 470 |
! |
- checkmate::assert_numeric(
+ col = "white",
|
- | 183 |
+ 471 |
! |
- plot_width[1],
+ vjust = "middle",
|
- | 184 |
+ 472 |
! |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
+ hjust = "middle",
|
-
- | 185 |
- |
+
+ | 473 |
+ ! |
- )
+ position = position_anl2_value
|
- | 186 |
+ 474 |
|
-
+ ) +
|
- | 187 |
+ 475 |
! |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ geom_text(
|
- | 188 |
+ 476 |
! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
- |
-
-
- | 189 |
- |
-
- # End of assertions
+ data = ANL3, aes(label = ns, x = x_cl, y = anl3_y),
|
-
- | 190 |
- |
+
+ | 477 |
+ ! |
-
+ hjust = hjust_value,
|
-
- | 191 |
- |
+
+ | 478 |
+ ! |
- # Make UI args
+ vjust = vjust_value,
|
- | 192 |
+ 479 |
! |
- args <- as.list(environment())
+ position = position_anl3_value
|
- | 193 |
+ 480 |
|
-
+ ),
|
- | 194 |
+ 481 |
! |
- ans <- module(
+ env = list(
|
- | 195 |
+ 482 |
! |
- label = label,
+ plot_call = plot_call,
|
- | 196 |
+ 483 |
! |
- server = srv_g_scatterplotmatrix,
+ x_cl = x_cl,
|
- | 197 |
+ 484 |
! |
- ui = ui_g_scatterplotmatrix,
+ resp_cl = resp_cl,
|
- | 198 |
+ 485 |
! |
- ui_args = args,
+ hjust_value = if (swap_axes) "left" else "middle",
|
- | 199 |
+ 486 |
! |
- server_args = list(variables = variables, plot_height = plot_height, plot_width = plot_width),
+ vjust_value = if (swap_axes) "middle" else -1,
|
- | 200 |
+ 487 |
! |
- datanames = teal.transform::get_extract_datanames(variables)
- |
-
-
- | 201 |
- |
-
- )
+ position_anl2_value = if (!freq) quote(position_fill(0.5)) else quote(position_stack(0.5)), # nolint: line_length.
|
- | 202 |
+ 488 |
! |
- attr(ans, "teal_bookmarkable") <- TRUE
+ anl3_y = if (!freq) 1.1 else as.name("ns"),
|
- | 203 |
+ 489 |
! |
- ans
+ position_anl3_value = if (!freq) "fill" else "stack"
|
- | 204 |
+ 490 |
|
- }
+ )
|
- | 205 |
+ 491 |
|
-
+ )
|
- | 206 |
+ 492 |
|
- # UI function for the scatterplot matrix module
+ }
|
- | 207 |
+ 493 |
|
- ui_g_scatterplotmatrix <- function(id, ...) {
+
|
- | 208 |
+ 494 |
! |
- args <- list(...)
+ if (swap_axes) {
|
- | 209 |
+ 495 |
! |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$variables)
+ plot_call <- substitute(plot_call + coord_flip(), env = list(plot_call = plot_call))
|
-
- | 210 |
- ! |
+
+ | 496 |
+ |
- ns <- NS(id)
+ }
|
-
- | 211 |
- ! |
+
+ | 497 |
+ |
- teal.widgets::standard_layout(
+
|
- | 212 |
+ 498 |
! |
- output = teal.widgets::white_small_well(
+ facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name)
|
-
- | 213 |
- ! |
+
+ | 499 |
+ |
- textOutput(ns("message")),
+
|
- | 214 |
+ 500 |
! |
- tags$br(),
+ if (!is.null(facet_cl)) {
|
- | 215 |
+ 501 |
! |
- teal.widgets::plot_with_settings_ui(id = ns("myplot"))
+ plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl))
|
- | 216 |
+ 502 |
|
- ),
- |
-
-
- | 217 |
- ! |
-
- encoding = tags$div(
+ }
|
- | 218 |
+ 503 |
|
- ### Reporter
+
|
- | 219 |
+ 504 |
! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
- |
-
-
- | 220 |
- |
-
- ###
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(
|
- | 221 |
+ 505 |
! |
- tags$label("Encodings", class = "text-primary"),
+ labs = list(
|
- | 222 |
+ 506 |
! |
- teal.transform::datanames_input(args$variables),
+ x = varname_w_label(x, ANL),
|
- | 223 |
+ 507 |
! |
- teal.transform::data_extract_ui(
+ y = varname_w_label(resp_var, ANL, prefix = "Proportion of "),
|
- | 224 |
+ 508 |
! |
- id = ns("variables"),
+ fill = varname_w_label(resp_var, ANL)
|
-
- | 225 |
- ! |
+
+ | 509 |
+ |
- label = "Variables",
+ ),
|
- | 226 |
+ 510 |
! |
- data_extract_spec = args$variables,
+ theme = list(legend.position = "bottom")
|
-
- | 227 |
- ! |
+
+ | 511 |
+ |
- is_single_dataset = is_single_dataset_value
+ )
|
- | 228 |
+ 512 |
|
- ),
+
|
- | 229 |
+ 513 |
! |
- tags$hr(),
+ if (rotate_xaxis_labels) {
|
- | 230 |
+ 514 |
! |
- teal.widgets::panel_group(
+ dev_ggplot2_args$theme[["axis.text.x"]] <- quote(element_text(angle = 45, hjust = 1))
|
-
- | 231 |
- ! |
+
+ | 515 |
+ |
- teal.widgets::panel_item(
+ }
|
-
- | 232 |
- ! |
+
+ | 516 |
+ |
- title = "Plot settings",
+
|
- | 233 |
+ 517 |
! |
- sliderInput(
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
|
- | 234 |
+ 518 |
! |
- ns("alpha"), "Opacity:",
+ user_plot = ggplot2_args,
|
- | 235 |
+ 519 |
! |
- min = 0, max = 1,
+ module_plot = dev_ggplot2_args
|
-
- | 236 |
- ! |
+
+ | 520 |
+ |
- step = .05, value = .5, ticks = FALSE
+ )
|
- | 237 |
+ 521 |
|
- ),
+
|
- | 238 |
+ 522 |
! |
- sliderInput(
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
|
- | 239 |
+ 523 |
! |
- ns("cex"), "Points size:",
+ all_ggplot2_args,
|
- | 240 |
+ 524 |
! |
- min = 0.2, max = 3,
+ ggtheme = ggtheme
|
-
- | 241 |
- ! |
+
+ | 525 |
+ |
- step = .05, value = .65, ticks = FALSE
+ )
|
- | 242 |
+ 526 |
|
- ),
+
|
- | 243 |
+ 527 |
! |
- checkboxInput(ns("cor"), "Add Correlation", value = FALSE),
+ plot_call <- substitute(expr = {
|
- | 244 |
+ 528 |
! |
- radioButtons(
+ p <- plot_call + labs + ggthemes + themes
|
- | 245 |
+ 529 |
! |
- ns("cor_method"), "Select Correlation Method",
+ print(p)
|
- | 246 |
+ 530 |
! |
- choiceNames = c("Pearson", "Kendall", "Spearman"),
+ }, env = list(
|
- | 247 |
+ 531 |
! |
- choiceValues = c("pearson", "kendall", "spearman"),
+ plot_call = plot_call,
|
- | 248 |
+ 532 |
! |
- inline = TRUE
- |
-
-
- | 249 |
- |
-
- ),
+ labs = parsed_ggplot2_args$labs,
|
- | 250 |
+ 533 |
! |
- checkboxInput(ns("cor_na_omit"), "Omit Missing Values", value = TRUE)
+ themes = parsed_ggplot2_args$theme,
|
-
- | 251 |
- |
+
+ | 534 |
+ ! |
- )
+ ggthemes = parsed_ggplot2_args$ggtheme
|
- | 252 |
+ 535 |
|
- )
+ ))
|
- | 253 |
+ 536 |
|
- ),
- |
-
-
- | 254 |
- ! |
-
- forms = tagList(
+
|
- | 255 |
+ 537 |
! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ teal.code::eval_code(qenv, plot_call)
|
- | 256 |
+ 538 |
|
- ),
- |
-
-
- | 257 |
- ! |
-
- pre_output = args$pre_output,
- |
-
-
- | 258 |
- ! |
-
- post_output = args$post_output
+ })
|
- | 259 |
+ 539 |
|
- )
+
|
-
- | 260 |
- |
+
+ | 540 |
+ ! |
- }
+ plot_r <- reactive(output_q()[["p"]])
|
- | 261 |
+ 541 |
|
|
- | 262 |
- |
-
- # Server function for the scatterplot matrix module
- |
-
-
- | 263 |
+ 542 |
|
- srv_g_scatterplotmatrix <- function(id, data, reporter, filter_panel_api, variables, plot_height, plot_width) {
+ # Insert the plot into a plot_with_settings module from teal.widgets
|
- | 264 |
+ 543 |
! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
+ pws <- teal.widgets::plot_with_settings_srv(
|
- | 265 |
+ 544 |
! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
+ id = "myplot",
|
- | 266 |
+ 545 |
! |
- checkmate::assert_class(data, "reactive")
+ plot_r = plot_r,
|
- | 267 |
+ 546 |
! |
- checkmate::assert_class(isolate(data()), "teal_data")
+ height = plot_height,
|
- | 268 |
+ 547 |
! |
- moduleServer(id, function(input, output, session) {
+ width = plot_width
|
-
- | 269 |
- ! |
+
+ | 548 |
+ |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
+ )
|
- | 270 |
+ 549 |
|
|
- | 271 |
+ 550 |
! |
- selector_list <- teal.transform::data_extract_multiple_srv(
+ teal.widgets::verbatim_popup_srv(
|
- | 272 |
+ 551 |
! |
- data_extract = list(variables = variables),
+ id = "rcode",
|
- | 273 |
+ 552 |
! |
- datasets = data,
+ verbatim_content = reactive(teal.code::get_code(output_q())),
|
- | 274 |
+ 553 |
! |
- select_validation_rule = list(
+ title = "Show R Code for Response"
|
-
- | 275 |
- ! |
+
+ | 554 |
+ |
- variables = ~ if (length(.) <= 1) "Please select at least 2 columns."
+ )
|
- | 276 |
+ 555 |
|
- )
+
|
- | 277 |
+ 556 |
|
- )
+ ### REPORTER
|
-
- | 278 |
- |
+
+ | 557 |
+ ! |
-
+ if (with_reporter) {
|
- | 279 |
+ 558 |
! |
- iv_r <- reactive({
+ card_fun <- function(comment, label) {
|
- | 280 |
+ 559 |
! |
- iv <- shinyvalidate::InputValidator$new()
+ card <- teal::report_card_template(
|
- | 281 |
+ 560 |
! |
- teal.transform::compose_and_enable_validators(iv, selector_list)
+ title = "Response Plot",
|
-
- | 282 |
- |
+
+ | 561 |
+ ! |
- })
+ label = label,
+ |
+
+
+ | 562 |
+ ! |
+
+ with_filter = with_filter,
+ |
+
+
+ | 563 |
+ ! |
+
+ filter_panel_api = filter_panel_api
|
- | 283 |
+ 564 |
|
-
+ )
|
- | 284 |
+ 565 |
! |
- anl_merged_input <- teal.transform::merge_expression_srv(
+ card$append_text("Plot", "header3")
|
- | 285 |
+ 566 |
! |
- datasets = data,
+ card$append_plot(plot_r(), dim = pws$dim())
|
- | 286 |
+ 567 |
! |
- selector_list = selector_list
+ if (!comment == "") {
|
-
- | 287 |
- |
+
+ | 568 |
+ ! |
- )
+ card$append_text("Comment", "header3")
+ |
+
+
+ | 569 |
+ ! |
+
+ card$append_text(comment)
|
- | 288 |
+ 570 |
|
-
+ }
|
- | 289 |
+ 571 |
! |
- anl_merged_q <- reactive({
+ card$append_src(teal.code::get_code(output_q()))
|
- | 290 |
+ 572 |
! |
- req(anl_merged_input())
+ card
|
-
- | 291 |
- ! |
+
+ | 573 |
+ |
- data() %>%
+ }
|
- | 292 |
+ 574 |
! |
- teal.code::eval_code(as.expression(anl_merged_input()$expr))
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
- | 293 |
+ 575 |
|
- })
+ }
|
- | 294 |
+ 576 |
|
-
+ ###
|
-
- | 295 |
- ! |
+
+ | 577 |
+ |
- merged <- list(
+ })
|
-
- | 296 |
- ! |
+
+ | 578 |
+ |
- anl_input_r = anl_merged_input,
+ }
|
-
- | 297 |
- ! |
+
+
+
+
+
+
+
+ | 1 |
+ |
- anl_q_r = anl_merged_q
+ #' `teal` module: File viewer
|
- | 298 |
+ 2 |
|
- )
+ #'
|
- | 299 |
+ 3 |
|
-
+ #' The file viewer module provides a tool to view static files.
|
- | 300 |
+ 4 |
|
- # plot
+ #' Supported formats include text formats, `PDF`, `PNG` `APNG`,
|
-
- | 301 |
- ! |
+
+ | 5 |
+ |
- output_q <- reactive({
+ #' `JPEG` `SVG`, `WEBP`, `GIF` and `BMP`.
|
-
- | 302 |
- ! |
+
+ | 6 |
+ |
- teal::validate_inputs(iv_r())
+ #'
|
- | 303 |
+ 7 |
|
-
+ #' @inheritParams teal::module
|
-
- | 304 |
- ! |
+
+ | 8 |
+ |
- qenv <- merged$anl_q_r()
+ #' @inheritParams shared_params
|
-
- | 305 |
- ! |
+
+ | 9 |
+ |
- ANL <- qenv[["ANL"]]
+ #' @param input_path (`list`) of the input paths, optional. Each element can be:
|
- | 306 |
+ 10 |
|
-
+ #'
|
-
- | 307 |
- ! |
+
+ | 11 |
+ |
- cols_names <- merged$anl_input_r()$columns_source$variables
+ #' Paths can be specified as absolute paths or relative to the running directory of the application.
|
-
- | 308 |
- ! |
+
+ | 12 |
+ |
- alpha <- input$alpha
+ #' Default to the current working directory if not supplied.
|
-
- | 309 |
- ! |
+
+ | 13 |
+ |
- cex <- input$cex
+ #'
|
-
- | 310 |
- ! |
+
+ | 14 |
+ |
- add_cor <- input$cor
+ #' @inherit shared_params return
|
-
- | 311 |
- ! |
+
+ | 15 |
+ |
- cor_method <- input$cor_method
+ #'
|
-
- | 312 |
- ! |
+
+ | 16 |
+ |
- cor_na_omit <- input$cor_na_omit
+ #' @examplesShinylive
|
- | 313 |
+ 17 |
|
-
+ #' library(teal.modules.general)
|
-
- | 314 |
- ! |
+
+ | 18 |
+ |
- cor_na_action <- if (isTruthy(cor_na_omit)) {
+ #' interactive <- function() TRUE
|
-
- | 315 |
- ! |
+
+ | 19 |
+ |
- "na.omit"
+ #' {{ next_example }}
|
- | 316 |
+ 20 |
|
- } else {
+ #' @examples
|
-
- | 317 |
- ! |
+
+ | 21 |
+ |
- "na.fail"
+ #' data <- teal_data()
|
- | 318 |
+ 22 |
|
- }
+ #' data <- within(data, {
|
- | 319 |
+ 23 |
|
-
+ #' data <- data.frame(1)
|
-
- | 320 |
- ! |
+
+ | 24 |
+ |
- teal::validate_has_data(ANL, 10)
+ #' })
|
-
- | 321 |
- ! |
+
+ | 25 |
+ |
- teal::validate_has_data(ANL[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE)
+ #' datanames(data) <- c("data")
|
- | 322 |
+ 26 |
|
-
+ #'
|
- | 323 |
+ 27 |
|
- # get labels and proper variable names
+ #' app <- init(
|
-
- | 324 |
- ! |
+
+ | 28 |
+ |
- varnames <- varname_w_label(cols_names, ANL, wrap_width = 20)
+ #' data = data,
|
- | 325 |
+ 29 |
|
-
+ #' modules = modules(
|
- | 326 |
+ 30 |
|
- # check character columns. If any, then those are converted to factors
+ #' tm_file_viewer(
|
-
- | 327 |
- ! |
+
+ | 31 |
+ |
- check_char <- vapply(ANL[, cols_names], is.character, logical(1))
+ #' input_path = list(
|
-
- | 328 |
- ! |
+
+ | 32 |
+ |
- if (any(check_char)) {
+ #' folder = system.file("sample_files", package = "teal.modules.general"),
|
-
- | 329 |
- ! |
+
+ | 33 |
+ |
- qenv <- teal.code::eval_code(
+ #' png = system.file("sample_files/sample_file.png", package = "teal.modules.general"),
|
-
- | 330 |
- ! |
+
+ | 34 |
+ |
- qenv,
+ #' txt = system.file("sample_files/sample_file.txt", package = "teal.modules.general"),
|
-
- | 331 |
- ! |
+
+ | 35 |
+ |
- substitute(
+ #' url = "https://fda.gov/files/drugs/published/Portable-Document-Format-Specifications.pdf"
|
-
- | 332 |
- ! |
+
+ | 36 |
+ |
- expr = ANL <- ANL[, cols_names] %>%
+ #' )
|
-
- | 333 |
- ! |
+
+ | 37 |
+ |
- dplyr::mutate_if(is.character, as.factor) %>%
+ #' )
|
-
- | 334 |
- ! |
+
+ | 38 |
+ |
- droplevels(),
+ #' )
|
-
- | 335 |
- ! |
+
+ | 39 |
+ |
- env = list(cols_names = cols_names)
+ #' )
|
- | 336 |
+ 40 |
|
- )
+ #' if (interactive()) {
|
- | 337 |
+ 41 |
|
- )
+ #' shinyApp(app$ui, app$server)
|
- | 338 |
+ 42 |
|
- } else {
+ #' }
|
-
- | 339 |
- ! |
+
+ | 43 |
+ |
- qenv <- teal.code::eval_code(
+ #'
|
-
- | 340 |
- ! |
+
+ | 44 |
+ |
- qenv,
+ #' @export
|
-
- | 341 |
- ! |
+
+ | 45 |
+ |
- substitute(
+ #'
|
-
- | 342 |
- ! |
+
+ | 46 |
+ |
- expr = ANL <- ANL[, cols_names] %>%
+ tm_file_viewer <- function(label = "File Viewer Module",
|
-
- | 343 |
- ! |
+
+ | 47 |
+ |
- droplevels(),
+ input_path = list("Current Working Directory" = ".")) {
|
- | 344 |
+ 48 |
! |
- env = list(cols_names = cols_names)
+ message("Initializing tm_file_viewer")
|
- | 345 |
+ 49 |
|
- )
+
|
- | 346 |
+ 50 |
|
- )
+ # Normalize the parameters
|
-
- | 347 |
- |
+
+ | 51 |
+ ! |
- }
+ if (length(label) == 0 || identical(label, "")) label <- " "
|
-
- | 348 |
- |
+
+ | 52 |
+ ! |
-
+ if (length(input_path) == 0 || identical(input_path, "")) input_path <- list()
|
- | 349 |
+ 53 |
|
|
- | 350 |
+ 54 |
|
- # create plot
+ # Start of assertions
|
- | 351 |
+ 55 |
! |
- if (add_cor) {
+ checkmate::assert_string(label)
+ |
+
+
+ | 56 |
+ |
+
+
|
- | 352 |
+ 57 |
! |
- shinyjs::show("cor_method")
+ checkmate::assert(
|
- | 353 |
+ 58 |
! |
- shinyjs::show("cor_use")
+ checkmate::check_list(input_path, types = "character", min.len = 0),
|
- | 354 |
+ 59 |
! |
- shinyjs::show("cor_na_omit")
+ checkmate::check_character(input_path, min.len = 1)
|
- | 355 |
+ 60 |
|
-
+ )
|
- | 356 |
+ 61 |
! |
- qenv <- teal.code::eval_code(
+ if (length(input_path) > 0) {
|
- | 357 |
+ 62 |
! |
- qenv,
+ valid_url <- function(url_input, timeout = 2) {
|
- | 358 |
+ 63 |
! |
- substitute(
+ con <- try(url(url_input), silent = TRUE)
|
- | 359 |
+ 64 |
! |
- expr = {
+ check <- suppressWarnings(try(open.connection(con, open = "rt", timeout = timeout), silent = TRUE)[1])
|
- | 360 |
+ 65 |
! |
- g <- lattice::splom(
+ try(close.connection(con), silent = TRUE)
|
- | 361 |
+ 66 |
! |
- ANL,
+ is.null(check)
|
-
- | 362 |
- ! |
+
+ | 67 |
+ |
- varnames = varnames_value,
+ }
|
- | 363 |
+ 68 |
! |
- panel = function(x, y, ...) {
+ idx <- vapply(input_path, function(x) file.exists(x) || valid_url(x), logical(1))
|
-
- | 364 |
- ! |
+
+ | 69 |
+ |
- lattice::panel.splom(x = x, y = y, ...)
+
|
- | 365 |
+ 70 |
! |
- cpl <- lattice::current.panel.limits()
+ if (!all(idx)) {
|
- | 366 |
+ 71 |
! |
- lattice::panel.text(
+ warning(
|
- | 367 |
+ 72 |
! |
- mean(cpl$xlim),
+ paste0(
|
- | 368 |
+ 73 |
! |
- mean(cpl$ylim),
+ "Non-existent file or url path. Please provide valid paths for:\n",
|
- | 369 |
+ 74 |
! |
- get_scatterplotmatrix_stats(
+ paste0(input_path[!idx], collapse = "\n")
|
-
- | 370 |
- ! |
+
+ | 75 |
+ |
- x,
+ )
|
-
- | 371 |
- ! |
+
+ | 76 |
+ |
- y,
+ )
|
-
- | 372 |
- ! |
+
+ | 77 |
+ |
- .f = stats::cor.test,
+ }
|
- | 373 |
+ 78 |
! |
- .f_args = list(method = cor_method, na.action = cor_na_action)
+ input_path <- input_path[idx]
|
- | 374 |
+ 79 |
|
- ),
+ } else {
|
- | 375 |
+ 80 |
! |
- alpha = 0.6,
+ warning(
|
- | 376 |
+ 81 |
! |
- fontsize = 18,
+ "No file or url paths were provided."
|
-
- | 377 |
- ! |
+
+ | 82 |
+ |
- fontface = "bold"
+ )
|
- | 378 |
+ 83 |
|
- )
+ }
|
- | 379 |
+ 84 |
|
- },
+ # End of assertions
|
-
- | 380 |
- ! |
+
+ | 85 |
+ |
- pch = 16,
+
|
-
- | 381 |
- ! |
+
+ | 86 |
+ |
- alpha = alpha_value,
+ # Make UI args
|
- | 382 |
+ 87 |
! |
- cex = cex_value
+ args <- as.list(environment())
|
- | 383 |
+ 88 |
|
- )
+
|
- | 384 |
+ 89 |
! |
- print(g)
+ ans <- module(
|
-
- | 385 |
- |
+
+ | 90 |
+ ! |
- },
+ label = label,
|
- | 386 |
+ 91 |
! |
- env = list(
+ server = srv_viewer,
|
- | 387 |
+ 92 |
! |
- varnames_value = varnames,
+ server_args = list(input_path = input_path),
|
- | 388 |
+ 93 |
! |
- cor_method = cor_method,
+ ui = ui_viewer,
|
- | 389 |
+ 94 |
! |
- cor_na_action = cor_na_action,
+ ui_args = args,
|
- | 390 |
+ 95 |
! |
- alpha_value = alpha,
+ datanames = NULL
+ |
+
+
+ | 96 |
+ |
+
+ )
|
- | 391 |
+ 97 |
! |
- cex_value = cex
+ attr(ans, "teal_bookmarkable") <- FALSE
+ |
+
+
+ | 98 |
+ ! |
+
+ ans
|
- | 392 |
+ 99 |
|
- )
+ }
|
- | 393 |
+ 100 |
|
- )
+
|
- | 394 |
+ 101 |
|
- )
+ # UI function for the file viewer module
|
- | 395 |
+ 102 |
|
- } else {
+ ui_viewer <- function(id, ...) {
|
- | 396 |
+ 103 |
! |
- shinyjs::hide("cor_method")
+ args <- list(...)
|
- | 397 |
+ 104 |
! |
- shinyjs::hide("cor_use")
+ ns <- NS(id)
+ |
+
+
+ | 105 |
+ |
+
+
|
- | 398 |
+ 106 |
! |
- shinyjs::hide("cor_na_omit")
+ tagList(
|
- | 399 |
+ 107 |
! |
- qenv <- teal.code::eval_code(
+ include_css_files("custom"),
|
- | 400 |
+ 108 |
! |
- qenv,
+ teal.widgets::standard_layout(
|
- | 401 |
+ 109 |
! |
- substitute(
+ output = tags$div(
|
- | 402 |
+ 110 |
! |
- expr = {
+ uiOutput(ns("output"))
+ |
+
+
+ | 111 |
+ |
+
+ ),
|
- | 403 |
+ 112 |
! |
- g <- lattice::splom(ANL, varnames = varnames_value, pch = 16, alpha = alpha_value, cex = cex_value)
+ encoding = tags$div(
|
- | 404 |
+ 113 |
! |
- g
+ class = "file_viewer_encoding",
|
-
- | 405 |
- |
+
+ | 114 |
+ ! |
- },
+ tags$label("Encodings", class = "text-primary"),
|
- | 406 |
+ 115 |
! |
- env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex)
+ shinyTree::shinyTree(
|
-
- | 407 |
- |
+
+ | 116 |
+ ! |
- )
+ ns("tree"),
|
-
- | 408 |
- |
+
+ | 117 |
+ ! |
- )
+ dragAndDrop = FALSE,
|
-
- | 409 |
- |
+
+ | 118 |
+ ! |
- }
+ sort = FALSE,
|
- | 410 |
+ 119 |
! |
- qenv
+ wholerow = TRUE,
+ |
+
+
+ | 120 |
+ ! |
+
+ theme = "proton",
+ |
+
+
+ | 121 |
+ ! |
+
+ multiple = FALSE
|
- | 411 |
+ 122 |
|
- })
+ )
|
- | 412 |
+ 123 |
|
-
+ )
|
-
- | 413 |
- ! |
+
+ | 124 |
+ |
- plot_r <- reactive(output_q()[["g"]])
+ )
|
- | 414 |
+ 125 |
|
-
+ )
|
- | 415 |
+ 126 |
|
- # Insert the plot into a plot_with_settings module
+ }
|
-
- | 416 |
- ! |
+
+ | 127 |
+ |
- pws <- teal.widgets::plot_with_settings_srv(
+
|
-
- | 417 |
- ! |
+
+ | 128 |
+ |
- id = "myplot",
+ # Server function for the file viewer module
|
-
- | 418 |
- ! |
+
+ | 129 |
+ |
- plot_r = plot_r,
+ srv_viewer <- function(id, input_path) {
|
- | 419 |
+ 130 |
! |
- height = plot_height,
+ moduleServer(id, function(input, output, session) {
|
- | 420 |
+ 131 |
! |
- width = plot_width
- |
-
-
- | 421 |
- |
-
- )
+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
|
- | 422 |
+ 132 |
|
|
-
- | 423 |
- |
-
- # show a message if conversion to factors took place
- |
-
- | 424 |
+ 133 |
! |
- output$message <- renderText({
+ temp_dir <- tempfile()
|
- | 425 |
+ 134 |
! |
- req(iv_r()$is_valid())
+ if (!dir.exists(temp_dir)) {
|
- | 426 |
+ 135 |
! |
- req(selector_list()$variables())
+ dir.create(temp_dir, recursive = TRUE)
|
-
- | 427 |
- ! |
+
+ | 136 |
+ |
- ANL <- merged$anl_q_r()[["ANL"]]
+ }
|
- | 428 |
+ 137 |
! |
- cols_names <- unique(unname(do.call(c, merged$anl_input_r()$columns_source)))
+ addResourcePath(basename(temp_dir), temp_dir)
|
-
- | 429 |
- ! |
+
+ | 138 |
+ |
- check_char <- vapply(ANL[, cols_names], is.character, logical(1))
+
|
- | 430 |
+ 139 |
! |
- if (any(check_char)) {
+ test_path_text <- function(selected_path, type) {
|
- | 431 |
+ 140 |
! |
- is_single <- sum(check_char) == 1
+ out <- tryCatch(
|
- | 432 |
+ 141 |
! |
- paste(
+ expr = {
|
- | 433 |
+ 142 |
! |
- "Character",
+ if (type != "url") {
|
- | 434 |
+ 143 |
! |
- ifelse(is_single, "variable", "variables"),
+ selected_path <- normalizePath(selected_path, winslash = "/")
|
-
- | 435 |
- ! |
+
+ | 144 |
+ |
- paste0("(", paste(cols_names[check_char], collapse = ", "), ")"),
+ }
|
- | 436 |
+ 145 |
! |
- ifelse(is_single, "was", "were"),
+ readLines(con = selected_path)
|
-
- | 437 |
- ! |
+
+ | 146 |
+ |
- "converted to",
+ },
|
- | 438 |
+ 147 |
! |
- ifelse(is_single, "factor.", "factors.")
+ error = function(cond) FALSE,
|
-
- | 439 |
- |
+
+ | 148 |
+ ! |
- )
+ warning = function(cond) {
|
-
- | 440 |
- |
+
+ | 149 |
+ ! |
- } else {
+ `if`(grepl("^incomplete final line found on", cond[[1]]), suppressWarnings(eval(cond[[2]])), FALSE)
|
- | 441 |
+ 150 |
|
- ""
+ }
|
- | 442 |
+ 151 |
|
- }
+ )
|
- | 443 |
+ 152 |
|
- })
+ }
|
- | 444 |
+ 153 |
|
|
- | 445 |
+ 154 |
! |
- teal.widgets::verbatim_popup_srv(
+ handle_connection_type <- function(selected_path) {
|
- | 446 |
+ 155 |
! |
- id = "rcode",
+ file_extension <- tools::file_ext(selected_path)
|
- | 447 |
+ 156 |
! |
- verbatim_content = reactive(teal.code::get_code(output_q())),
+ file_class <- suppressWarnings(file(selected_path))
|
- | 448 |
+ 157 |
! |
- title = "Show R Code for Scatterplotmatrix"
+ close(file_class)
|
- | 449 |
+ 158 |
|
- )
+
|
-
- | 450 |
- |
+
+ | 159 |
+ ! |
-
+ output_text <- test_path_text(selected_path, type = class(file_class)[1])
|
- | 451 |
+ 160 |
|
- ### REPORTER
+
|
- | 452 |
+ 161 |
! |
- if (with_reporter) {
+ if (class(file_class)[1] == "url") {
|
- | 453 |
+ 162 |
! |
- card_fun <- function(comment, label) {
+ list(selected_path = selected_path, output_text = output_text)
|
-
- | 454 |
- ! |
+
+ | 163 |
+ |
- card <- teal::report_card_template(
+ } else {
|
- | 455 |
+ 164 |
! |
- title = "Scatter Plot Matrix",
+ file.copy(normalizePath(selected_path, winslash = "/"), temp_dir)
|
- | 456 |
+ 165 |
! |
- label = label,
+ selected_path <- file.path(basename(temp_dir), basename(selected_path))
|
- | 457 |
+ 166 |
! |
- with_filter = with_filter,
+ list(selected_path = selected_path, output_text = output_text)
|
-
- | 458 |
- ! |
+
+ | 167 |
+ |
- filter_panel_api = filter_panel_api
+ }
|
- | 459 |
+ 168 |
|
- )
+ }
|
-
- | 460 |
- ! |
+
+ | 169 |
+ |
- card$append_text("Plot", "header3")
+
|
- | 461 |
+ 170 |
! |
- card$append_plot(plot_r(), dim = pws$dim())
+ display_file <- function(selected_path) {
|
- | 462 |
+ 171 |
! |
- if (!comment == "") {
+ con_type <- handle_connection_type(selected_path)
|
- | 463 |
+ 172 |
! |
- card$append_text("Comment", "header3")
+ file_extension <- tools::file_ext(selected_path)
|
- | 464 |
+ 173 |
! |
- card$append_text(comment)
- |
-
-
- | 465 |
- |
-
- }
+ if (file_extension %in% c("png", "apng", "jpg", "jpeg", "svg", "gif", "webp", "bmp")) {
|
- | 466 |
+ 174 |
! |
- card$append_src(teal.code::get_code(output_q()))
+ tags$img(src = con_type$selected_path, alt = "file does not exist")
|
- | 467 |
+ 175 |
! |
- card
+ } else if (file_extension == "pdf") {
|
-
- | 468 |
- |
+
+ | 176 |
+ ! |
- }
+ tags$embed(
|
- | 469 |
+ 177 |
! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ class = "embed_pdf",
|
-
- | 470 |
- |
+
+ | 178 |
+ ! |
- }
+ src = con_type$selected_path
|
- | 471 |
+ 179 |
|
- ###
+ )
|
-
- | 472 |
- |
+
+ | 180 |
+ ! |
- })
+ } else if (!isFALSE(con_type$output_text[1])) {
|
-
- | 473 |
- |
+
+ | 181 |
+ ! |
- }
+ tags$pre(paste0(con_type$output_text, collapse = "\n"))
|
- | 474 |
+ 182 |
|
-
+ } else {
|
-
- | 475 |
- |
+
+ | 183 |
+ ! |
- #' Get stats for x-y pairs in scatterplot matrix
+ tags$p("Please select a supported format.")
|
- | 476 |
+ 184 |
|
- #'
+ }
|
- | 477 |
+ 185 |
|
- #' Uses [stats::cor.test()] per default for all numerical input variables and converts results
+ }
|
- | 478 |
+ 186 |
|
- #' to character vector.
+
|
-
- | 479 |
- |
+
+ | 187 |
+ ! |
- #' Could be extended if different stats for different variable types are needed.
+ tree_list <- function(file_or_dir) {
|
-
- | 480 |
- |
+
+ | 188 |
+ ! |
- #' Meant to be called from [lattice::panel.text()].
+ nested_list <- lapply(file_or_dir, function(path) {
|
-
- | 481 |
- |
+
+ | 189 |
+ ! |
- #'
+ file_class <- suppressWarnings(file(path))
|
-
- | 482 |
- |
+
+ | 190 |
+ ! |
- #' Presently we need to use a formula input for `stats::cor.test` because
+ close(file_class)
|
-
- | 483 |
- |
+
+ | 191 |
+ ! |
- #' `na.fail` only gets evaluated when a formula is passed (see below).
+ if (class(file_class)[[1]] != "url") {
|
-
- | 484 |
- |
+
+ | 192 |
+ ! |
- #' ```
+ isdir <- file.info(path)$isdir
|
-
- | 485 |
- |
+
+ | 193 |
+ ! |
- #' x = c(1,3,5,7,NA)
+ if (!isdir) {
|
-
- | 486 |
- |
+
+ | 194 |
+ ! |
- #' y = c(3,6,7,8,1)
+ structure(path, ancestry = path, sticon = "file")
|
- | 487 |
+ 195 |
|
- #' stats::cor.test(x, y, na.action = "na.fail")
+ } else {
|
-
- | 488 |
- |
+
+ | 196 |
+ ! |
- #' stats::cor.test(~ x + y, na.action = "na.fail")
+ files <- list.files(path, full.names = TRUE, include.dirs = TRUE)
|
-
- | 489 |
- |
+
+ | 197 |
+ ! |
- #' ```
+ out <- lapply(files, function(x) tree_list(x))
|
-
- | 490 |
- |
+
+ | 198 |
+ ! |
- #'
+ out <- unlist(out, recursive = FALSE)
|
-
- | 491 |
- |
+
+ | 199 |
+ ! |
- #' @param x,y (`numeric`) vectors of data values. `x` and `y` must have the same length.
+ if (length(files) > 0) names(out) <- basename(files)
|
-
- | 492 |
- |
+
+ | 200 |
+ ! |
- #' @param .f (`function`) function that accepts x and y as formula input `~ x + y`.
+ out
|
- | 493 |
+ 201 |
|
- #' Default `stats::cor.test`.
+ }
|
- | 494 |
+ 202 |
|
- #' @param .f_args (`list`) of arguments to be passed to `.f`.
+ } else {
|
-
- | 495 |
- |
+
+ | 203 |
+ ! |
- #' @param round_stat (`integer(1)`) optional, number of decimal places to use when rounding the estimate.
+ structure(path, ancestry = path, sticon = "file")
|
- | 496 |
+ 204 |
|
- #' @param round_pval (`integer(1)`) optional, number of decimal places to use when rounding the p-value.
+ }
|
- | 497 |
+ 205 |
|
- #'
+ })
|
- | 498 |
+ 206 |
|
- #' @return Character with stats. For [stats::cor.test()] correlation coefficient and p-value.
+
|
-
- | 499 |
- |
+
+ | 207 |
+ ! |
- #'
+ missing_labels <- if (is.null(names(nested_list))) seq_along(nested_list) else which(names(nested_list) == "")
|
-
- | 500 |
- |
+
+ | 208 |
+ ! |
- #' @examples
+ names(nested_list)[missing_labels] <- file_or_dir[missing_labels]
|
-
- | 501 |
- |
+
+ | 209 |
+ ! |
- #' set.seed(1)
+ nested_list
|
- | 502 |
+ 210 |
|
- #' x <- runif(25, 0, 1)
+ }
|
- | 503 |
+ 211 |
|
- #' y <- runif(25, 0, 1)
+
|
-
- | 504 |
- |
+
+ | 212 |
+ ! |
- #' x[c(3, 10, 18)] <- NA
+ output$tree <- shinyTree::renderTree({
|
-
- | 505 |
- |
+
+ | 213 |
+ ! |
- #'
+ if (length(input_path) > 0) {
|
-
- | 506 |
- |
+
+ | 214 |
+ ! |
- #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson"))
+ tree_list(input_path)
|
- | 507 |
+ 215 |
|
- #' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(
+ } else {
|
-
- | 508 |
- |
+
+ | 216 |
+ ! |
- #' method = "pearson",
+ list("Empty Path" = NULL)
|
- | 509 |
+ 217 |
|
- #' na.action = na.fail
+ }
|
- | 510 |
+ 218 |
|
- #' ))
+ })
|
- | 511 |
+ 219 |
|
- #'
+
|
-
- | 512 |
- |
+
+ | 220 |
+ ! |
- #' @export
+ output$output <- renderUI({
|
-
- | 513 |
- |
+
+ | 221 |
+ ! |
- #'
+ validate(
|
-
- | 514 |
- |
+
+ | 222 |
+ ! |
- get_scatterplotmatrix_stats <- function(x, y,
+ need(
|
-
- | 515 |
- |
+
+ | 223 |
+ ! |
- .f = stats::cor.test,
+ length(shinyTree::get_selected(input$tree)) > 0,
|
-
- | 516 |
- |
+
+ | 224 |
+ ! |
- .f_args = list(),
+ "Please select a file."
|
- | 517 |
+ 225 |
|
- round_stat = 2,
+ )
|
- | 518 |
+ 226 |
|
- round_pval = 4) {
- |
-
-
- | 519 |
- 6x |
-
- if (is.numeric(x) && is.numeric(y)) {
- |
-
-
- | 520 |
- 3x |
-
- stat <- tryCatch(do.call(.f, c(list(~ x + y), .f_args)), error = function(e) NA)
+ )
|
- | 521 |
+ 227 |
|
|
-
- | 522 |
- 3x |
+
+ | 228 |
+ ! |
- if (anyNA(stat)) {
+ obj <- shinyTree::get_selected(input$tree, format = "names")[[1]]
|
-
- | 523 |
- 1x |
+
+ | 229 |
+ ! |
- return("NA")
+ repo <- attr(obj, "ancestry")
|
-
- | 524 |
- 2x |
+
+ | 230 |
+ ! |
- } else if (all(c("estimate", "p.value") %in% names(stat))) {
+ repo_collapsed <- if (length(repo) > 1) paste0(repo, collapse = "/") else repo
|
-
- | 525 |
- 2x |
+
+ | 231 |
+ ! |
- return(paste(
+ is_not_named <- file.exists(file.path(c(repo_collapsed, obj[1])))[1]
|
-
- | 526 |
- 2x |
+
+ | 232 |
+ |
- c(
+
|
-
- | 527 |
- 2x |
+
+ | 233 |
+ ! |
- paste0(names(stat$estimate), ":", round(stat$estimate, round_stat)),
+ if (is_not_named) {
|
-
- | 528 |
- 2x |
+
+ | 234 |
+ ! |
- paste0("P:", round(stat$p.value, round_pval))
+ selected_path <- do.call("file.path", as.list(c(repo, obj[1])))
|
- | 529 |
+ 235 |
|
- ),
+ } else {
|
-
- | 530 |
- 2x |
+
+ | 236 |
+ ! |
- collapse = "\n"
+ if (length(repo) == 0) {
|
-
- | 531 |
- |
+
+ | 237 |
+ ! |
- ))
+ selected_path <- do.call("file.path", as.list(attr(input$tree[[obj[1]]], "ancestry")))
|
- | 532 |
+ 238 |
|
- } else {
+ } else {
|
- | 533 |
+ 239 |
! |
- stop("function not supported")
+ selected_path <- do.call("file.path", as.list(attr(input$tree[[repo]][[obj[1]]], "ancestry")))
|
- | 534 |
+ 240 |
|
- }
+ }
|
- | 535 |
+ 241 |
|
- } else {
+ }
|
-
- | 536 |
- 3x |
+
+ | 242 |
+ |
- if ("method" %in% names(.f_args)) {
+
|
-
- | 537 |
- 3x |
+
+ | 243 |
+ ! |
- if (.f_args$method == "pearson") {
+ validate(
|
-
- | 538 |
- 1x |
+
+ | 244 |
+ ! |
- return("cor:-")
+ need(
|
-
- | 539 |
- |
+
+ | 245 |
+ ! |
- }
+ !isTRUE(file.info(selected_path)$isdir) && length(selected_path) > 0,
|
-
- | 540 |
- 2x |
+
+ | 246 |
+ ! |
- if (.f_args$method == "kendall") {
+ "Please select a single file."
|
-
- | 541 |
- 1x |
+
+ | 247 |
+ |
- return("tau:-")
+ )
|
- | 542 |
+ 248 |
|
- }
+ )
|
-
- | 543 |
- 1x |
+
+ | 249 |
+ ! |
- if (.f_args$method == "spearman") {
+ display_file(selected_path)
|
-
- | 544 |
- 1x |
+
+ | 250 |
+ |
- return("rho:-")
+ })
|
- | 545 |
+ 251 |
|
- }
+
|
-
- | 546 |
- |
+
+ | 252 |
+ ! |
- }
+ onStop(function() {
|
- | 547 |
+ 253 |
! |
- return("-")
+ removeResourcePath(basename(temp_dir))
+ |
+
+
+ | 254 |
+ ! |
+
+ unlink(temp_dir)
|
- | 548 |
+ 255 |
|
- }
+ })
|
- | 549 |
+ 256 |
+ |
+
+ })
+ |
+
+
+ | 257 |
|
}
@@ -81145,14 +81430,14 @@ teal.modules.general coverage - 3.44%
|
-
+
| 1 |
|
- #' Shared parameters documentation
+ #' `teal` module: Principal component analysis
|
@@ -81166,476 +81451,476 @@ teal.modules.general coverage - 3.44%
3 |
|
- #' Defines common arguments shared across multiple functions in the package
+ #' Module conducts principal component analysis (PCA) on a given dataset and offers different
|
| 4 |
|
- #' to avoid repetition by using `inheritParams`.
+ #' ways of visualizing the outcomes, including elbow plot, circle plot, biplot, and eigenvector plot.
|
| 5 |
|
- #'
+ #' Additionally, it enables dynamic customization of plot aesthetics, such as opacity, size, and
|
| 6 |
|
- #' @param plot_height (`numeric`) optional, specifies the plot height as a three-element vector of
+ #' font size, through UI inputs.
|
| 7 |
|
- #' `value`, `min`, and `max` intended for use with a slider UI element.
+ #'
|
| 8 |
|
- #' @param plot_width (`numeric`) optional, specifies the plot width as a three-element vector of
+ #' @inheritParams teal::module
|
| 9 |
|
- #' `value`, `min`, and `max` for a slider encoding the plot width.
+ #' @inheritParams shared_params
|
| 10 |
|
- #' @param rotate_xaxis_labels (`logical`) optional, whether to rotate plot X axis labels. Does not
+ #' @param dat (`data_extract_spec` or `list` of multiple `data_extract_spec`)
|
| 11 |
|
- #' rotate by default (`FALSE`).
+ #' specifying columns used to compute PCA.
|
| 12 |
|
- #' @param ggtheme (`character`) optional, `ggplot2` theme to be used by default. Defaults to `"gray"`.
+ #' @param font_size (`numeric`) optional, specifies font size.
|
| 13 |
|
- #' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()]
+ #' It controls the font size for plot titles, axis labels, and legends.
|
| 14 |
|
- #' with settings for the module plot.
+ #' - If vector of `length == 1` then the font sizes will have a fixed size.
|
| 15 |
|
- #' The argument is merged with options variable `teal.ggplot2_args` and default module setup.
+ #' - while vector of `value`, `min`, and `max` allows dynamic adjustment.
|
| 16 |
|
- #'
+ #' @templateVar ggnames "Elbow plot", "Circle plot", "Biplot", "Eigenvector plot"
|
| 17 |
|
- #' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`
+ #' @template ggplot2_args_multi
|
| 18 |
|
- #' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()]
+ #'
|
| 19 |
|
- #' with settings for the module table.
+ #' @inherit shared_params return
|
| 20 |
|
- #' The argument is merged with options variable `teal.basic_table_args` and default module setup.
+ #'
|
| 21 |
|
- #'
+ #' @examplesShinylive
|
| 22 |
|
- #' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")`
+ #' library(teal.modules.general)
|
| 23 |
|
- #' @param pre_output (`shiny.tag`) optional, text or UI element to be displayed before the module's output,
+ #' interactive <- function() TRUE
|
| 24 |
|
- #' providing context or a title.
+ #' {{ next_example }}
|
| 25 |
|
- #' with text placed before the output to put the output into context. For example a title.
+ #' @examples
|
| 26 |
|
- #' @param post_output (`shiny.tag`) optional, text or UI element to be displayed after the module's output,
+ #' # general data example
|
| 27 |
|
- #' adding context or further instructions. Elements like `shiny::helpText()` are useful.
+ #' data <- teal_data()
|
| 28 |
|
- #'
+ #' data <- within(data, {
|
| 29 |
|
- #' @param alpha (`integer(1)` or `integer(3)`) optional, specifies point opacity.
+ #' require(nestcolor)
|
| 30 |
|
- #' - When the length of `alpha` is one: the plot points will have a fixed opacity.
+ #' USArrests <- USArrests
|
| 31 |
|
- #' - When the length of `alpha` is three: the plot points opacity are dynamically adjusted based on
+ #' })
|
| 32 |
|
- #' vector of `value`, `min`, and `max`.
+ #'
|
| 33 |
|
- #' @param size (`integer(1)` or `integer(3)`) optional, specifies point size.
+ #' datanames(data) <- "USArrests"
|
| 34 |
|
- #' - When the length of `size` is one: the plot point sizes will have a fixed size.
+ #'
|
| 35 |
|
- #' - When the length of `size` is three: the plot points size are dynamically adjusted based on
+ #' app <- init(
|
| 36 |
|
- #' vector of `value`, `min`, and `max`.
+ #' data = data,
|
| 37 |
|
- #'
+ #' modules = modules(
|
| 38 |
|
- #' @return Object of class `teal_module` to be used in `teal` applications.
+ #' tm_a_pca(
|
| 39 |
|
- #'
+ #' "PCA",
|
| 40 |
|
- #' @name shared_params
+ #' dat = data_extract_spec(
|
| 41 |
|
- #' @keywords internal
+ #' dataname = "USArrests",
|
| 42 |
|
- NULL
+ #' select = select_spec(
|
| 43 |
|
-
+ #' choices = variable_choices(
|
| 44 |
|
- #' Add labels for facets to a `ggplot2` object
+ #' data = data[["USArrests"]], c("Murder", "Assault", "UrbanPop", "Rape")
|
| 45 |
|
- #'
+ #' ),
|
| 46 |
|
- #' Enhances a `ggplot2` plot by adding labels that describe
+ #' selected = c("Murder", "Assault"),
|
| 47 |
|
- #' the faceting variables along the x and y axes.
+ #' multiple = TRUE
|
| 48 |
|
- #'
+ #' ),
|
| 49 |
|
- #' @param p (`ggplot2`) object to which facet labels will be added.
+ #' filter = NULL
|
| 50 |
|
- #' @param xfacet_label (`character`) Label for the facet along the x-axis.
+ #' )
|
| 51 |
|
- #' If `NULL`, no label is added. If a vector, labels are joined with " & ".
+ #' )
|
| 52 |
|
- #' @param yfacet_label (`character`) Label for the facet along the y-axis.
+ #' )
|
| 53 |
|
- #' Similar behavior to `xfacet_label`.
+ #' )
|
| 54 |
|
- #'
+ #' if (interactive()) {
|
| 55 |
|
- #' @return Returns `grid` or `grob` object (to be drawn with `grid.draw`)
+ #' shinyApp(app$ui, app$server)
|
| 56 |
|
- #'
+ #' }
|
| 57 |
|
- #' @examples
+ #'
|
| 58 |
|
- #' library(ggplot2)
+ #' @examplesShinylive
|
| 59 |
|
- #' library(grid)
+ #' library(teal.modules.general)
|
| 60 |
|
- #'
+ #' interactive <- function() TRUE
|
| 61 |
|
- #' p <- ggplot(mtcars) +
+ #' {{ next_example }}
|
| 62 |
|
- #' aes(x = mpg, y = disp) +
+ #' @examples
|
| 63 |
|
- #' geom_point() +
+ #' # CDISC data example
|
| 64 |
|
- #' facet_grid(gear ~ cyl)
+ #' data <- teal_data()
|
| 65 |
|
- #'
+ #' data <- within(data, {
|
| 66 |
|
- #' xfacet_label <- "cylinders"
+ #' require(nestcolor)
|
| 67 |
|
- #' yfacet_label <- "gear"
+ #' ADSL <- rADSL
|
| 68 |
|
- #' res <- add_facet_labels(p, xfacet_label, yfacet_label)
+ #' })
|
| 69 |
|
- #' grid.newpage()
+ #' datanames(data) <- "ADSL"
|
| 70 |
|
- #' grid.draw(res)
+ #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
|
@@ -81649,322 +81934,322 @@ teal.modules.general coverage - 3.44%
72 |
|
- #' grid.newpage()
+ #' app <- init(
|
| 73 |
|
- #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label))
+ #' data = data,
|
| 74 |
|
- #' grid.newpage()
+ #' modules = modules(
|
| 75 |
|
- #' grid.draw(add_facet_labels(p, xfacet_label, yfacet_label = NULL))
+ #' tm_a_pca(
|
| 76 |
|
- #' grid.newpage()
+ #' "PCA",
|
| 77 |
|
- #' grid.draw(add_facet_labels(p, xfacet_label = NULL, yfacet_label = NULL))
+ #' dat = data_extract_spec(
|
| 78 |
|
- #'
+ #' dataname = "ADSL",
|
| 79 |
|
- #' @export
+ #' select = select_spec(
|
| 80 |
|
- #'
+ #' choices = variable_choices(
|
| 81 |
|
- add_facet_labels <- function(p, xfacet_label = NULL, yfacet_label = NULL) {
+ #' data = data[["ADSL"]], c("BMRKR1", "AGE", "EOSDY")
|
-
+
| 82 |
- ! |
+ |
- checkmate::assert_class(p, classes = "ggplot")
+ #' ),
|
-
+
| 83 |
- ! |
+ |
- checkmate::assert_character(xfacet_label, null.ok = TRUE, min.len = 1)
+ #' selected = c("BMRKR1", "AGE"),
|
-
+
| 84 |
- ! |
+ |
- checkmate::assert_character(yfacet_label, null.ok = TRUE, min.len = 1)
+ #' multiple = TRUE
|
-
+
| 85 |
- ! |
+ |
- if (is.null(xfacet_label) && is.null(yfacet_label)) {
+ #' ),
|
-
+
| 86 |
- ! |
+ |
- return(ggplotGrob(p))
+ #' filter = NULL
|
| 87 |
|
- }
+ #' )
|
-
+
| 88 |
- ! |
+ |
- grid::grid.grabExpr({
+ #' )
|
-
+
| 89 |
- ! |
+ |
- g <- ggplotGrob(p)
+ #' )
|
| 90 |
|
-
+ #' )
|
| 91 |
|
- # we are going to replace these, so we make sure they have nothing in them
+ #' if (interactive()) {
|
-
+
| 92 |
- ! |
+ |
- checkmate::assert_class(g$grobs[[grep("xlab-t", g$layout$name, fixed = TRUE)]], "zeroGrob")
+ #' shinyApp(app$ui, app$server)
|
-
+
| 93 |
- ! |
+ |
- checkmate::assert_class(g$grobs[[grep("ylab-r", g$layout$name, fixed = TRUE)]], "zeroGrob")
+ #' }
|
| 94 |
|
-
+ #'
|
-
+
| 95 |
- ! |
+ |
- xaxis_label_grob <- g$grobs[[grep("xlab-b", g$layout$name, fixed = TRUE)]]
+ #' @export
|
-
+
| 96 |
- ! |
+ |
- xaxis_label_grob$children[[1]]$label <- paste(xfacet_label, collapse = " & ")
+ #'
|
-
+
| 97 |
- ! |
+ |
- yaxis_label_grob <- g$grobs[[grep("ylab-l", g$layout$name, fixed = TRUE)]]
+ tm_a_pca <- function(label = "Principal Component Analysis",
|
-
+
| 98 |
- ! |
+ |
- yaxis_label_grob$children[[1]]$label <- paste(yfacet_label, collapse = " & ")
+ dat,
|
-
+
| 99 |
- ! |
+ |
- yaxis_label_grob$children[[1]]$rot <- 270
+ plot_height = c(600, 200, 2000),
|
| 100 |
|
-
+ plot_width = NULL,
|
-
+
| 101 |
- ! |
+ |
- top_height <- if (is.null(xfacet_label)) 0 else grid::unit(2, "line")
+ ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"),
|
-
+
| 102 |
- ! |
+ |
- right_width <- if (is.null(yfacet_label)) 0 else grid::unit(2, "line")
+ ggplot2_args = teal.widgets::ggplot2_args(),
|
| 103 |
|
-
+ rotate_xaxis_labels = FALSE,
|
-
+
| 104 |
- ! |
+ |
- grid::grid.newpage()
+ font_size = c(12, 8, 20),
|
-
+
| 105 |
- ! |
+ |
- grid::pushViewport(grid::plotViewport(margins = c(0, 0, top_height, right_width), name = "ggplot"))
+ alpha = c(1, 0, 1),
|
-
+
| 106 |
- ! |
+ |
- grid::grid.draw(g)
+ size = c(2, 1, 8),
|
-
+
| 107 |
- ! |
+ |
- grid::upViewport(1)
+ pre_output = NULL,
|
| 108 |
|
-
+ post_output = NULL) {
|
-
+
| 109 |
- |
+ ! |
- # draw x facet
+ message("Initializing tm_a_pca")
|
-
+
| 110 |
- ! |
+ |
- if (!is.null(xfacet_label)) {
+
|
-
+
| 111 |
- ! |
+ |
- grid::pushViewport(grid::viewport(
+ # Normalize the parameters
|
| 112 |
! |
- x = 0, y = grid::unit(1, "npc") - top_height, width = grid::unit(1, "npc"),
+ if (inherits(dat, "data_extract_spec")) dat <- list(dat)
|
| 113 |
! |
- height = top_height, just = c("left", "bottom"), name = "topxaxis"
+ if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)
|
| 114 |
|
- ))
+
|
-
+
| 115 |
- ! |
+ |
- grid::grid.draw(xaxis_label_grob)
+ # Start of assertions
|
| 116 |
! |
- grid::upViewport(1)
+ checkmate::assert_string(label)
|
-
+
| 117 |
- |
+ ! |
- }
+ checkmate::assert_list(dat, types = "data_extract_spec")
|
@@ -81974,6707 +82259,6737 @@ teal.modules.general coverage - 3.44%
-
+
| 119 |
- |
+ ! |
- # draw y facet
+ checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
|
| 120 |
! |
- if (!is.null(yfacet_label)) {
+ checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
|
| 121 |
! |
- grid::pushViewport(grid::viewport(
+ checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
|
| 122 |
! |
- x = grid::unit(1, "npc") - grid::unit(as.numeric(right_width) / 2, "line"), y = 0, width = right_width,
+ checkmate::assert_numeric(
|
| 123 |
! |
- height = grid::unit(1, "npc"), just = c("left", "bottom"), name = "rightyaxis"
+ plot_width[1],
|
-
+
| 124 |
- |
+ ! |
- ))
+ lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
|
-
+
| 125 |
- ! |
+ |
- grid::grid.draw(yaxis_label_grob)
+ )
|
-
+
| 126 |
- ! |
+ |
- grid::upViewport(1)
+
|
-
+
| 127 |
- |
+ ! |
- }
+ ggtheme <- match.arg(ggtheme)
|
| 128 |
|
- })
+
|
-
+
| 129 |
- |
+ ! |
- }
+ plot_choices <- c("Elbow plot", "Circle plot", "Biplot", "Eigenvector plot")
|
-
+
| 130 |
- |
+ ! |
-
+ checkmate::assert_list(ggplot2_args, types = "ggplot2_args")
|
-
+
| 131 |
- |
+ ! |
- #' Call a function with a character vector for the `...` argument
+ checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
| 132 |
|
- #'
+
|
-
+
| 133 |
- |
+ ! |
- #' @param fun (`character`) Name of a function where the `...` argument shall be replaced by values from `str_args`.
+ checkmate::assert_flag(rotate_xaxis_labels)
|
| 134 |
|
- #' @param str_args (`character`) A character vector that the function shall be executed with
+
|
-
+
| 135 |
- |
+ ! |
- #'
+ if (length(font_size) == 1) {
|
-
+
| 136 |
- |
+ ! |
- #' @return
+ checkmate::assert_numeric(font_size, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20)
|
| 137 |
|
- #' Value of call to `fun` with arguments specified in `str_args`.
+ } else {
|
-
+
| 138 |
- |
+ ! |
- #'
+ checkmate::assert_numeric(font_size, len = 3, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20)
|
-
+
| 139 |
- |
+ ! |
- #' @keywords internal
+ checkmate::assert_numeric(font_size[1], lower = font_size[2], upper = font_size[3], .var.name = "font_size")
|
| 140 |
|
- call_fun_dots <- function(fun, str_args) {
+ }
|
-
+
| 141 |
- ! |
+ |
- do.call("call", c(list(fun), lapply(str_args, as.name)), quote = TRUE)
+
|
-
+
| 142 |
- |
+ ! |
- }
+ if (length(alpha) == 1) {
|
-
+
| 143 |
- |
+ ! |
-
+ checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1)
|
| 144 |
|
- #' Generate a string for a variable including its label
+ } else {
|
-
+
| 145 |
- |
+ ! |
- #'
+ checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1)
|
-
+
| 146 |
- |
+ ! |
- #' @param var_names (`character`) Name of variable to extract labels from.
+ checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha")
|
| 147 |
|
- #' @param dataset (`dataset`) Name of analysis dataset.
+ }
|
| 148 |
|
- #' @param prefix,suffix (`character`) String to paste to the beginning/end of the variable name with label.
+
|
-
+
| 149 |
- |
+ ! |
- #' @param wrap_width (`numeric`) Number of characters to wrap original label to. Defaults to 80.
+ if (length(size) == 1) {
|
-
+
| 150 |
- |
+ ! |
- #'
+ checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8)
|
| 151 |
|
- #' @return (`character`) String with variable name and label.
+ } else {
|
-
+
| 152 |
- |
+ ! |
- #'
+ checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8)
|
-
+
| 153 |
- |
+ ! |
- #' @keywords internal
+ checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size")
|
| 154 |
|
- #'
+ }
|
| 155 |
|
- varname_w_label <- function(var_names,
+
|
-
+
| 156 |
- |
+ ! |
- dataset,
+ checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
-
+
| 157 |
- |
+ ! |
- wrap_width = 80,
+ checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
|
| 158 |
|
- prefix = NULL,
+ # End of assertions
|
| 159 |
|
- suffix = NULL) {
+
|
-
+
| 160 |
- ! |
+ |
- add_label <- function(var_names) {
+ # Make UI args
|
| 161 |
! |
- label <- vapply(
+ args <- as.list(environment())
|
-
+
| 162 |
- ! |
+ |
- dataset[var_names], function(x) {
+
|
| 163 |
! |
- attr_label <- attr(x, "label")
+ data_extract_list <- list(dat = dat)
|
-
+
| 164 |
- ! |
+ |
- `if`(is.null(attr_label), "", attr_label)
+
|
-
+
| 165 |
- |
+ ! |
- },
+ ans <- module(
|
| 166 |
! |
- character(1)
+ label = label,
|
-
+
| 167 |
- |
+ ! |
- )
+ server = srv_a_pca,
|
-
+
| 168 |
- |
+ ! |
-
+ ui = ui_a_pca,
|
| 169 |
! |
- if (length(label) == 1 && !is.na(label) && !identical(label, "")) {
+ ui_args = args,
|
| 170 |
! |
- paste0(prefix, label, " [", var_names, "]", suffix)
+ server_args = c(
|
-
+
| 171 |
- |
+ ! |
- } else {
+ data_extract_list,
|
| 172 |
! |
- var_names
+ list(
|
-
+
| 173 |
- |
+ ! |
- }
+ plot_height = plot_height,
|
-
+
| 174 |
- |
+ ! |
- }
+ plot_width = plot_width,
|
-
+
| 175 |
- |
+ ! |
-
+ ggplot2_args = ggplot2_args
|
-
+
| 176 |
- ! |
+ |
- if (length(var_names) < 1) {
+ )
|
-
+
| 177 |
- ! |
+ |
- NULL
+ ),
|
| 178 |
! |
- } else if (length(var_names) == 1) {
+ datanames = teal.transform::get_extract_datanames(data_extract_list)
|
-
+
| 179 |
- ! |
+ |
- stringr::str_wrap(add_label(var_names), width = wrap_width)
+ )
|
| 180 |
! |
- } else if (length(var_names) > 1) {
+ attr(ans, "teal_bookmarkable") <- FALSE
|
| 181 |
! |
- stringr::str_wrap(vapply(var_names, add_label, character(1)), width = wrap_width)
+ ans
|
| 182 |
|
- }
+ }
|
| 183 |
|
- }
+
|
| 184 |
|
-
+ # UI function for the PCA module
|
| 185 |
|
- # see vignette("ggplot2-specs", package="ggplot2")
+ ui_a_pca <- function(id, ...) {
|
-
+
| 186 |
- |
+ ! |
- shape_names <- c(
+ ns <- NS(id)
|
-
+
| 187 |
- |
+ ! |
- "circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet",
+ args <- list(...)
|
-
+
| 188 |
- |
+ ! |
- "square", paste("square", c("open", "filled", "cross", "plus", "triangle")),
+ is_single_dataset_value <- teal.transform::is_single_dataset(args$dat)
|
| 189 |
|
- "diamond", paste("diamond", c("open", "filled", "plus")),
+
|
-
+
| 190 |
- |
+ ! |
- "triangle", paste("triangle", c("open", "filled", "square")),
+ color_selector <- args$dat
|
-
+
| 191 |
- |
+ ! |
- paste("triangle down", c("open", "filled")),
+ for (i in seq_along(color_selector)) {
|
-
+
| 192 |
- |
+ ! |
- "plus", "cross", "asterisk"
+ color_selector[[i]]$select$multiple <- FALSE
|
-
+
| 193 |
- |
+ ! |
- )
+ color_selector[[i]]$select$always_selected <- NULL
|
-
+
| 194 |
- |
+ ! |
-
+ color_selector[[i]]$select$selected <- NULL
|
| 195 |
|
- #' Get icons to represent variable types in dataset
+ }
|
| 196 |
|
- #'
+
|
-
+
| 197 |
- |
+ ! |
- #' @param var_type (`character`) of R internal types (classes).
+ tagList(
|
-
+
| 198 |
- |
+ ! |
- #' @return (`character`) vector of HTML icons corresponding to data type in each column.
+ include_css_files("custom"),
|
-
+
| 199 |
- |
+ ! |
- #' @keywords internal
+ teal.widgets::standard_layout(
|
-
+
| 200 |
- |
+ ! |
- variable_type_icons <- function(var_type) {
+ output = teal.widgets::white_small_well(
|
| 201 |
! |
- checkmate::assert_character(var_type, any.missing = FALSE)
+ uiOutput(ns("all_plots"))
|
| 202 |
|
-
+ ),
|
| 203 |
! |
- class_to_icon <- list(
+ encoding = tags$div(
|
-
+
| 204 |
- ! |
+ |
- numeric = "arrow-up-1-9",
+ ### Reporter
|
| 205 |
! |
- integer = "arrow-up-1-9",
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
-
+
| 206 |
- ! |
+ |
- logical = "pause",
+ ###
|
| 207 |
! |
- Date = "calendar",
+ tags$label("Encodings", class = "text-primary"),
|
| 208 |
! |
- POSIXct = "calendar",
+ teal.transform::datanames_input(args["dat"]),
|
| 209 |
! |
- POSIXlt = "calendar",
+ teal.transform::data_extract_ui(
|
| 210 |
! |
- factor = "chart-bar",
+ id = ns("dat"),
|
| 211 |
! |
- character = "keyboard",
+ label = "Data selection",
|
| 212 |
! |
- primary_key = "key",
+ data_extract_spec = args$dat,
|
| 213 |
! |
- unknown = "circle-question"
+ is_single_dataset = is_single_dataset_value
|
| 214 |
|
- )
+ ),
|
| 215 |
! |
- class_to_icon <- lapply(class_to_icon, function(icon_name) toString(icon(icon_name, lib = "font-awesome")))
+ teal.widgets::panel_group(
|
-
+
| 216 |
- |
+ ! |
-
+ teal.widgets::panel_item(
|
| 217 |
! |
- unname(vapply(
+ title = "Display",
|
| 218 |
! |
- var_type,
+ collapsed = FALSE,
|
| 219 |
! |
- FUN.VALUE = character(1),
+ checkboxGroupInput(
|
| 220 |
! |
- FUN = function(class) {
+ ns("tables_display"),
|
| 221 |
! |
- if (class == "") {
+ "Tables display",
|
| 222 |
! |
- class
+ choices = c("PC importance" = "importance", "Eigenvectors" = "eigenvector"),
|
| 223 |
! |
- } else if (is.null(class_to_icon[[class]])) {
+ selected = c("importance", "eigenvector")
|
-
+
| 224 |
- ! |
+ |
- class_to_icon[["unknown"]]
+ ),
|
-
+
| 225 |
- |
+ ! |
- } else {
+ radioButtons(
|
| 226 |
! |
- class_to_icon[[class]]
+ ns("plot_type"),
|
-
+
| 227 |
- |
+ ! |
- }
+ label = "Plot type",
|
-
+
| 228 |
- |
+ ! |
- }
+ choices = args$plot_choices,
|
-
+
| 229 |
- |
+ ! |
- ))
+ selected = args$plot_choices[1]
|
| 230 |
|
- }
+ )
|
| 231 |
|
-
+ ),
|
-
+
| 232 |
- |
+ ! |
- #' Include `CSS` files from `/inst/css/` package directory to application header
+ teal.widgets::panel_item(
|
-
+
| 233 |
- |
+ ! |
- #'
+ title = "Pre-processing",
|
-
+
| 234 |
- |
+ ! |
- #' `system.file` should not be used to access files in other packages, it does
+ radioButtons(
|
-
+
| 235 |
- |
+ ! |
- #' not work with `devtools`. Therefore, we redefine this method in each package
+ ns("standardization"), "Standardization",
|
-
+
| 236 |
- |
+ ! |
- #' as needed. Thus, we do not export this method
+ choices = c("None" = "none", "Center" = "center", "Center & Scale" = "center_scale"),
|
-
+
| 237 |
- |
+ ! |
- #'
+ selected = "center_scale"
|
| 238 |
|
- #' @param pattern (`character`) optional, regular expression to match the file names to be included.
+ ),
|
-
+
| 239 |
- |
+ ! |
- #'
+ radioButtons(
|
-
+
| 240 |
- |
+ ! |
- #' @return HTML code that includes `CSS` files.
+ ns("na_action"), "NA action",
|
-
+
| 241 |
- |
+ ! |
- #' @keywords internal
+ choices = c("None" = "none", "Drop" = "drop"),
|
-
+
| 242 |
- |
+ ! |
- #'
+ selected = "none"
|
| 243 |
|
- include_css_files <- function(pattern = "*") {
+ )
|
-
+
| 244 |
- ! |
+ |
- css_files <- list.files(
+ ),
|
| 245 |
! |
- system.file("css", package = "teal.modules.general", mustWork = TRUE),
+ teal.widgets::panel_item(
|
| 246 |
! |
- pattern = pattern, full.names = TRUE
+ title = "Selected plot specific settings",
|
-
+
| 247 |
- |
+ ! |
- )
+ collapsed = FALSE,
|
| 248 |
! |
- if (length(css_files) == 0) {
+ uiOutput(ns("plot_settings")),
|
| 249 |
! |
- return(NULL)
+ conditionalPanel(
|
-
+
| 250 |
- |
+ ! |
- }
+ condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")),
|
| 251 |
! |
- singleton(tags$head(lapply(css_files, includeCSS)))
+ list(
|
-
+
| 252 |
- |
+ ! |
- }
+ teal.transform::data_extract_ui(
|
-
+
| 253 |
- |
+ ! |
-
+ id = ns("response"),
|
-
+
| 254 |
- |
+ ! |
- #' JavaScript condition to check if a specific tab is active
+ label = "Color by",
|
-
+
| 255 |
- |
+ ! |
- #'
+ data_extract_spec = color_selector,
|
-
+
| 256 |
- |
+ ! |
- #' @param id (`character(1)`) the id of the tab panel with tabs.
+ is_single_dataset = is_single_dataset_value
|
| 257 |
|
- #' @param name (`character(1)`) the name of the tab.
+ ),
|
-
+
| 258 |
- |
+ ! |
- #' @return JavaScript expression to be used in `shiny::conditionalPanel()` to determine
+ teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE),
|
-
+
| 259 |
- |
+ ! |
- #' if the specified tab is active.
+ teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE)
|
| 260 |
|
- #' @keywords internal
+ )
|
| 261 |
|
- #'
+ )
|
| 262 |
|
- is_tab_active_js <- function(id, name) {
+ ),
|
-
+
| 263 |
- |
+ ! |
- # supporting the bs3 and higher version at the same time
+ teal.widgets::panel_item(
|
| 264 |
! |
- sprintf(
+ title = "Plot settings",
|
| 265 |
! |
- "$(\"#%1$s > li.active\").text().trim() == '%2$s' || $(\"#%1$s > li a.active\").text().trim() == '%2$s'",
+ collapsed = TRUE,
|
| 266 |
! |
- id, name
+ conditionalPanel(
|
-
+
| 267 |
- |
+ ! |
- )
+ condition = sprintf(
|
-
+
| 268 |
- |
+ ! |
- }
+ "input['%s'] == 'Elbow plot' || input['%s'] == 'Eigenvector plot'",
|
-
+
| 269 |
- |
+ ! |
-
+ ns("plot_type"),
|
-
+
| 270 |
- |
+ ! |
- #' Assert single selection on `data_extract_spec` object
+ ns("plot_type")
|
| 271 |
|
- #' Helper to reduce code in assertions
+ ),
|
-
+
| 272 |
- |
+ ! |
- #' @noRd
+ list(checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels))
|
| 273 |
|
- #'
+ ),
|
-
+
| 274 |
- |
+ ! |
- assert_single_selection <- function(x,
+ selectInput(
|
-
+
| 275 |
- |
+ ! |
- .var.name = checkmate::vname(x)) { # nolint: object_name.
+ inputId = ns("ggtheme"),
|
-
+
| 276 |
- 104x |
+ ! |
- if (any(vapply(x, function(.x) .x$select$multiple, logical(1)))) {
+ label = "Theme (by ggplot):",
|
-
+
| 277 |
- 4x |
+ ! |
- stop("'", .var.name, "' should not allow multiple selection")
+ choices = ggplot_themes,
|
-
+
| 278 |
- |
+ ! |
- }
+ selected = args$ggtheme,
|
-
+
| 279 |
- 100x |
+ ! |
- invisible(TRUE)
+ multiple = FALSE
|
| 280 |
|
- }
+ ),
|
-
-
-
-
-
-
-
- | 1 |
- |
+
+ | 281 |
+ ! |
- #' `teal` module: Stack plots of variables and show association with reference variable
+ teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", args$font_size, ticks = FALSE)
|
- | 2 |
+ 282 |
|
- #'
+ )
|
- | 3 |
+ 283 |
|
- #' Module provides functionality for visualizing the distribution of variables and
+ )
|
- | 4 |
+ 284 |
|
- #' their association with a reference variable.
+ ),
|
-
- | 5 |
- |
+
+ | 285 |
+ ! |
- #' It supports configuring the appearance of the plots, including themes and whether to show associations.
+ forms = tagList(
|
-
- | 6 |
- |
+
+ | 286 |
+ ! |
- #'
+ teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
- | 7 |
+ 287 |
|
- #'
+ ),
|
-
- | 8 |
- |
+
+ | 288 |
+ ! |
- #' @note For more examples, please see the vignette "Using association plot" via
+ pre_output = args$pre_output,
|
-
- | 9 |
- |
+
+ | 289 |
+ ! |
- #' `vignette("using-association-plot", package = "teal.modules.general")`.
+ post_output = args$post_output
|
- | 10 |
+ 290 |
|
- #'
+ )
|
- | 11 |
+ 291 |
|
- #' @inheritParams teal::module
+ )
|
- | 12 |
+ 292 |
|
- #' @inheritParams shared_params
+ }
|
- | 13 |
+ 293 |
|
- #' @param ref (`data_extract_spec` or `list` of multiple `data_extract_spec`)
+
|
- | 14 |
+ 294 |
|
- #' Reference variable, must accepts a `data_extract_spec` with `select_spec(multiple = FALSE)`
+ # Server function for the PCA module
|
- | 15 |
+ 295 |
|
- #' to ensure single selection option.
+ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, plot_width, ggplot2_args) {
|
-
- | 16 |
- |
+
+ | 296 |
+ ! |
- #' @param vars (`data_extract_spec` or `list` of multiple `data_extract_spec`)
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
|
-
- | 17 |
- |
+
+ | 297 |
+ ! |
- #' Variables to be associated with the reference variable.
+ with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
|
-
- | 18 |
- |
+
+ | 298 |
+ ! |
- #' @param show_association (`logical`) optional, whether show association of `vars`
+ checkmate::assert_class(data, "reactive")
|
-
- | 19 |
- |
+
+ | 299 |
+ ! |
- #' with reference variable. Defaults to `TRUE`.
+ checkmate::assert_class(isolate(data()), "teal_data")
|
-
- | 20 |
- |
+
+ | 300 |
+ ! |
- #' @param distribution_theme,association_theme (`character`) optional, `ggplot2` themes to be used by default.
+ moduleServer(id, function(input, output, session) {
|
-
- | 21 |
- |
+
+ | 301 |
+ ! |
- #' Default to `"gray"`.
+ teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
|
- | 22 |
+ 302 |
|
- #'
+
|
-
- | 23 |
- |
+
+ | 303 |
+ ! |
- #' @templateVar ggnames "Bivariate1", "Bivariate2"
+ response <- dat
|
- | 24 |
+ 304 |
|
- #' @template ggplot2_args_multi
+
|
-
- | 25 |
- |
+
+ | 305 |
+ ! |
- #'
+ for (i in seq_along(response)) {
|
-
- | 26 |
- |
+
+ | 306 |
+ ! |
- #' @inherit shared_params return
+ response[[i]]$select$multiple <- FALSE
|
-
- | 27 |
- |
+
+ | 307 |
+ ! |
- #'
+ response[[i]]$select$always_selected <- NULL
|
-
- | 28 |
- |
+
+ | 308 |
+ ! |
- #' @examples
+ response[[i]]$select$selected <- NULL
|
-
- | 29 |
- |
+
+ | 309 |
+ ! |
- #' library(teal.widgets)
+ all_cols <- teal.data::col_labels(isolate(data())[[response[[i]]$dataname]])
|
-
- | 30 |
- |
+
+ | 310 |
+ ! |
- #'
+ ignore_cols <- unlist(teal.data::join_keys(isolate(data()))[[response[[i]]$dataname]])
|
-
- | 31 |
- |
+
+ | 311 |
+ ! |
- #' # general data example
+ color_cols <- all_cols[!names(all_cols) %in% ignore_cols]
|
-
- | 32 |
- |
+
+ | 312 |
+ ! |
- #' data <- teal_data()
+ response[[i]]$select$choices <- teal.transform::choices_labeled(names(color_cols), color_cols)
|
- | 33 |
+ 313 |
|
- #' data <- within(data, {
+ }
|
- | 34 |
+ 314 |
|
- #' require(nestcolor)
+
|
-
- | 35 |
- |
+
+ | 315 |
+ ! |
- #' CO2 <- CO2
+ selector_list <- teal.transform::data_extract_multiple_srv(
|
-
- | 36 |
- |
+
+ | 316 |
+ ! |
- #' factors <- names(Filter(isTRUE, vapply(CO2, is.factor, logical(1L))))
+ data_extract = list(dat = dat, response = response),
|
-
- | 37 |
- |
+
+ | 317 |
+ ! |
- #' CO2[factors] <- lapply(CO2[factors], as.character)
+ datasets = data,
|
-
- | 38 |
- |
+
+ | 318 |
+ ! |
- #' })
+ select_validation_rule = list(
|
-
- | 39 |
- |
+
+ | 319 |
+ ! |
- #' datanames(data) <- c("CO2")
+ dat = ~ if (length(.) < 2L) "Please select more than 1 variable to perform PCA.",
|
-
- | 40 |
- |
+
+ | 320 |
+ ! |
- #'
+ response = shinyvalidate::compose_rules(
|
-
- | 41 |
- |
+
+ | 321 |
+ ! |
- #' app <- init(
+ shinyvalidate::sv_optional(),
|
-
- | 42 |
- |
+
+ | 322 |
+ ! |
- #' data = data,
+ ~ if (isTRUE(is.element(., selector_list()$dat()$select))) {
|
-
- | 43 |
- |
+
+ | 323 |
+ ! |
- #' modules = modules(
+ "Response must not have been used for PCA."
|
- | 44 |
+ 324 |
|
- #' tm_g_association(
+ }
|
- | 45 |
+ 325 |
|
- #' ref = data_extract_spec(
+ )
|
- | 46 |
+ 326 |
|
- #' dataname = "CO2",
+ )
|
- | 47 |
+ 327 |
|
- #' select = select_spec(
+ )
|
- | 48 |
+ 328 |
|
- #' label = "Select variable:",
+
+ |
+
+
+ | 329 |
+ ! |
+
+ iv_r <- reactive({
+ |
+
+
+ | 330 |
+ ! |
+
+ iv <- shinyvalidate::InputValidator$new()
+ |
+
+
+ | 331 |
+ ! |
+
+ teal.transform::compose_and_enable_validators(iv, selector_list)
|
- | 49 |
+ 332 |
|
- #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
+ })
|
- | 50 |
+ 333 |
|
- #' selected = "Plant",
+
+ |
+
+
+ | 334 |
+ ! |
+
+ iv_extra <- shinyvalidate::InputValidator$new()
+ |
+
+
+ | 335 |
+ ! |
+
+ iv_extra$add_rule("x_axis", function(value) {
+ |
+
+
+ | 336 |
+ ! |
+
+ if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
|
-
- | 51 |
- |
+
+ | 337 |
+ ! |
- #' fixed = FALSE
+ if (!shinyvalidate::input_provided(value)) {
|
-
- | 52 |
- |
+
+ | 338 |
+ ! |
- #' )
+ "Need X axis"
|
- | 53 |
+ 339 |
|
- #' ),
+ }
|
- | 54 |
+ 340 |
|
- #' vars = data_extract_spec(
+ }
|
- | 55 |
+ 341 |
|
- #' dataname = "CO2",
+ })
|
-
- | 56 |
- |
+
+ | 342 |
+ ! |
- #' select = select_spec(
+ iv_extra$add_rule("y_axis", function(value) {
|
-
- | 57 |
- |
+
+ | 343 |
+ ! |
- #' label = "Select variables:",
+ if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
|
-
- | 58 |
- |
+
+ | 344 |
+ ! |
- #' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")),
+ if (!shinyvalidate::input_provided(value)) {
|
-
- | 59 |
- |
+
+ | 345 |
+ ! |
- #' selected = "Treatment",
+ "Need Y axis"
|
- | 60 |
+ 346 |
|
- #' multiple = TRUE,
+ }
|
- | 61 |
+ 347 |
|
- #' fixed = FALSE
+ }
|
- | 62 |
+ 348 |
|
- #' )
+ })
|
-
- | 63 |
- |
+
+ | 349 |
+ ! |
- #' ),
+ rule_dupl <- function(...) {
|
-
- | 64 |
- |
+
+ | 350 |
+ ! |
- #' ggplot2_args = ggplot2_args(
+ if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) {
|
-
- | 65 |
- |
+
+ | 351 |
+ ! |
- #' labs = list(subtitle = "Plot generated by Association Module")
+ if (isTRUE(input$x_axis == input$y_axis)) {
|
-
- | 66 |
- |
+
+ | 352 |
+ ! |
- #' )
+ "Please choose different X and Y axes."
|
- | 67 |
+ 353 |
|
- #' )
+ }
|
- | 68 |
+ 354 |
|
- #' )
+ }
|
- | 69 |
+ 355 |
|
- #' )
+ }
|
-
- | 70 |
- |
+
+ | 356 |
+ ! |
- #' if (interactive()) {
+ iv_extra$add_rule("x_axis", rule_dupl)
|
-
- | 71 |
- |
+
+ | 357 |
+ ! |
- #' shinyApp(app$ui, app$server)
+ iv_extra$add_rule("y_axis", rule_dupl)
|
-
- | 72 |
- |
+
+ | 358 |
+ ! |
- #' }
+ iv_extra$add_rule("variables", function(value) {
|
-
- | 73 |
- |
+
+ | 359 |
+ ! |
- #'
+ if (identical(input$plot_type, "Circle plot")) {
|
-
- | 74 |
- |
+
+ | 360 |
+ ! |
- #' # CDISC data example
+ if (!shinyvalidate::input_provided(value)) {
|
-
- | 75 |
- |
+
+ | 361 |
+ ! |
- #' data <- teal_data()
+ "Need Original Coordinates"
|
- | 76 |
+ 362 |
|
- #' data <- within(data, {
+ }
|
- | 77 |
+ 363 |
|
- #' require(nestcolor)
+ }
|
- | 78 |
+ 364 |
|
- #' ADSL <- rADSL
+ })
|
-
- | 79 |
- |
+
+ | 365 |
+ ! |
- #' })
+ iv_extra$add_rule("pc", function(value) {
|
-
- | 80 |
- |
+
+ | 366 |
+ ! |
- #' datanames(data) <- "ADSL"
+ if (identical(input$plot_type, "Eigenvector plot")) {
|
-
- | 81 |
- |
+
+ | 367 |
+ ! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
+ if (!shinyvalidate::input_provided(value)) {
|
-
- | 82 |
- |
+
+ | 368 |
+ ! |
- #'
+ "Need PC"
|
- | 83 |
+ 369 |
|
- #' app <- init(
+ }
|
- | 84 |
+ 370 |
|
- #' data = data,
+ }
|
- | 85 |
+ 371 |
|
- #' modules = modules(
+ })
|
-
- | 86 |
- |
+
+ | 372 |
+ ! |
- #' tm_g_association(
+ iv_extra$enable()
|
- | 87 |
+ 373 |
|
- #' ref = data_extract_spec(
+
|
-
- | 88 |
- |
+
+ | 374 |
+ ! |
- #' dataname = "ADSL",
+ anl_merged_input <- teal.transform::merge_expression_srv(
|
-
- | 89 |
- |
+
+ | 375 |
+ ! |
- #' select = select_spec(
+ selector_list = selector_list,
|
-
- | 90 |
- |
+
+ | 376 |
+ ! |
- #' label = "Select variable:",
+ datasets = data
|
- | 91 |
+ 377 |
|
- #' choices = variable_choices(
+ )
|
- | 92 |
+ 378 |
|
- #' data[["ADSL"]],
+
|
-
- | 93 |
- |
+
+ | 379 |
+ ! |
- #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
+ anl_merged_q <- reactive({
|
-
- | 94 |
- |
+
+ | 380 |
+ ! |
- #' ),
+ req(anl_merged_input())
|
-
- | 95 |
- |
+
+ | 381 |
+ ! |
- #' selected = "RACE",
+ data() %>%
|
-
- | 96 |
- |
+
+ | 382 |
+ ! |
- #' fixed = FALSE
+ teal.code::eval_code(as.expression(anl_merged_input()$expr))
|
- | 97 |
+ 383 |
|
- #' )
+ })
|
- | 98 |
+ 384 |
|
- #' ),
+
|
-
- | 99 |
- |
+
+ | 385 |
+ ! |
- #' vars = data_extract_spec(
+ merged <- list(
|
-
- | 100 |
- |
+
+ | 386 |
+ ! |
- #' dataname = "ADSL",
+ anl_input_r = anl_merged_input,
|
-
- | 101 |
- |
+
+ | 387 |
+ ! |
- #' select = select_spec(
+ anl_q_r = anl_merged_q
|
- | 102 |
+ 388 |
|
- #' label = "Select variables:",
+ )
|
- | 103 |
+ 389 |
|
- #' choices = variable_choices(
+
|
-
- | 104 |
- |
+
+ | 390 |
+ ! |
- #' data[["ADSL"]],
+ validation <- reactive({
|
-
- | 105 |
- |
+
+ | 391 |
+ ! |
- #' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
+ req(merged$anl_q_r())
|
- | 106 |
+ 392 |
|
- #' ),
+ # inputs
|
-
- | 107 |
- |
+
+ | 393 |
+ ! |
- #' selected = "BMRKR2",
+ keep_cols <- as.character(merged$anl_input_r()$columns_source$dat)
|
-
- | 108 |
- |
+
+ | 394 |
+ ! |
- #' multiple = TRUE,
+ na_action <- input$na_action
|
-
- | 109 |
- |
+
+ | 395 |
+ ! |
- #' fixed = FALSE
+ standardization <- input$standardization
|
-
- | 110 |
- |
+
+ | 396 |
+ ! |
- #' )
+ center <- standardization %in% c("center", "center_scale")
|
-
- | 111 |
- |
+
+ | 397 |
+ ! |
- #' ),
+ scale <- standardization == "center_scale"
|
-
- | 112 |
- |
+
+ | 398 |
+ ! |
- #' ggplot2_args = ggplot2_args(
+ ANL <- merged$anl_q_r()[["ANL"]]
|
- | 113 |
+ 399 |
|
- #' labs = list(subtitle = "Plot generated by Association Module")
+
|
-
- | 114 |
- |
+
+ | 400 |
+ ! |
- #' )
+ teal::validate_has_data(ANL, 10)
|
-
- | 115 |
- |
+
+ | 401 |
+ ! |
- #' )
+ validate(need(
|
-
- | 116 |
- |
+
+ | 402 |
+ ! |
- #' )
+ na_action != "none" | !anyNA(ANL[keep_cols]),
|
-
- | 117 |
- |
+
+ | 403 |
+ ! |
- #' )
+ paste(
|
-
- | 118 |
- |
+
+ | 404 |
+ ! |
- #' if (interactive()) {
+ "There are NAs in the dataset. Please deal with them in preprocessing",
|
-
- | 119 |
- |
+
+ | 405 |
+ ! |
- #' shinyApp(app$ui, app$server)
+ "or select \"Drop\" in the NA actions inside the encodings panel (left)."
|
- | 120 |
+ 406 |
|
- #' }
+ )
|
- | 121 |
+ 407 |
|
- #'
+ ))
|
-
- | 122 |
- |
+
+ | 408 |
+ ! |
- #' @export
+ if (scale) {
|
-
- | 123 |
- |
+
+ | 409 |
+ ! |
- #'
+ not_single <- vapply(ANL[keep_cols], function(column) length(unique(column)) != 1, FUN.VALUE = logical(1))
|
- | 124 |
+ 410 |
|
- tm_g_association <- function(label = "Association",
+
|
-
- | 125 |
- |
+
+ | 411 |
+ ! |
- ref,
+ msg <- paste0(
|
-
- | 126 |
- |
+
+ | 412 |
+ ! |
- vars,
+ "You have selected `Center & Scale` under `Standardization` in the `Pre-processing` panel, ",
|
-
- | 127 |
- |
+
+ | 413 |
+ ! |
- show_association = TRUE,
+ "but one or more of your columns has/have a variance value of zero, indicating all values are identical"
|
- | 128 |
+ 414 |
|
- plot_height = c(600, 400, 5000),
+ )
|
-
-
- | 129 |
- |
+
+
+ | 415 |
+ ! |
- plot_width = NULL,
+ validate(need(all(not_single), msg))
|
- | 130 |
+ 416 |
|
- distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
+ }
|
- | 131 |
+ 417 |
|
- association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length.
+ })
|
- | 132 |
+ 418 |
|
- pre_output = NULL,
+
|
- | 133 |
+ 419 |
|
- post_output = NULL,
+ # computation ----
|
-
- | 134 |
- |
+
+ | 420 |
+ ! |
- ggplot2_args = teal.widgets::ggplot2_args()) {
+ computation <- reactive({
|
- | 135 |
+ 421 |
! |
- message("Initializing tm_g_association")
+ validation()
|
- | 136 |
+ 422 |
|
|
- | 137 |
+ 423 |
|
- # Normalize the parameters
+ # inputs
|
- | 138 |
+ 424 |
! |
- if (inherits(ref, "data_extract_spec")) ref <- list(ref)
+ keep_cols <- as.character(merged$anl_input_r()$columns_source$dat)
|
- | 139 |
+ 425 |
! |
- if (inherits(vars, "data_extract_spec")) vars <- list(vars)
+ na_action <- input$na_action
|
- | 140 |
+ 426 |
! |
- if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args)
+ standardization <- input$standardization
|
-
- | 141 |
- |
+
+ | 427 |
+ ! |
-
+ center <- standardization %in% c("center", "center_scale")
|
-
- | 142 |
- |
+
+ | 428 |
+ ! |
- # Start of assertions
+ scale <- standardization == "center_scale"
|
- | 143 |
+ 429 |
! |
- checkmate::assert_string(label)
+ ANL <- merged$anl_q_r()[["ANL"]]
|
- | 144 |
+ 430 |
|
|
- | 145 |
+ 431 |
! |
- checkmate::assert_list(ref, types = "data_extract_spec")
+ qenv <- teal.code::eval_code(
|
- | 146 |
+ 432 |
! |
- if (!all(vapply(ref, function(x) !x$select$multiple, logical(1)))) {
+ merged$anl_q_r(),
|
- | 147 |
+ 433 |
! |
- stop("'ref' should not allow multiple selection")
+ substitute(
+ |
+
+
+ | 434 |
+ ! |
+
+ expr = keep_columns <- keep_cols,
+ |
+
+
+ | 435 |
+ ! |
+
+ env = list(keep_cols = keep_cols)
|
- | 148 |
+ 436 |
|
- }
+ )
|
- | 149 |
+ 437 |
+ |
+
+ )
+ |
+
+
+ | 438 |
|
|
- | 150 |
+ 439 |
! |
- checkmate::assert_list(vars, types = "data_extract_spec")
+ if (na_action == "drop") {
|
- | 151 |
+ 440 |
! |
- checkmate::assert_flag(show_association)
+ qenv <- teal.code::eval_code(
+ |
+
+
+ | 441 |
+ ! |
+
+ qenv,
+ |
+
+
+ | 442 |
+ ! |
+
+ quote(ANL <- tidyr::drop_na(ANL, keep_columns))
|
- | 152 |
+ 443 |
+ |
+
+ )
+ |
+
+
+ | 444 |
+ |
+
+ }
+ |
+
+
+ | 445 |
|
|
- | 153 |
+ 446 |
! |
- checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE)
+ qenv <- teal.code::eval_code(
|
- | 154 |
+ 447 |
! |
- checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height")
+ qenv,
|
- | 155 |
+ 448 |
! |
- checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE)
+ substitute(
|
- | 156 |
+ 449 |
! |
- checkmate::assert_numeric(
+ expr = pca <- summary(stats::prcomp(ANL[keep_columns], center = center, scale. = scale, retx = TRUE)),
|
- | 157 |
+ 450 |
! |
- plot_width[1],
+ env = list(center = center, scale = scale)
|
-
- | 158 |
- ! |
+
+ | 451 |
+ |
- lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width"
+ )
|
- | 159 |
+ 452 |
|
- )
+ )
|
- | 160 |
+ 453 |
|
|
- | 161 |
+ 454 |
! |
- distribution_theme <- match.arg(distribution_theme)
+ qenv <- teal.code::eval_code(
|
- | 162 |
+ 455 |
! |
- association_theme <- match.arg(association_theme)
+ qenv,
|
-
- | 163 |
- |
+
+ | 456 |
+ ! |
-
+ quote({
|
- | 164 |
+ 457 |
! |
- checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ tbl_importance <- dplyr::as_tibble(pca$importance, rownames = "Metric")
|
- | 165 |
+ 458 |
! |
- checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
+ tbl_importance
|
- | 166 |
+ 459 |
+ |
+
+ })
+ |
+
+
+ | 460 |
+ |
+
+ )
+ |
+
+
+ | 461 |
|
|
- | 167 |
+ 462 |
! |
- plot_choices <- c("Bivariate1", "Bivariate2")
+ teal.code::eval_code(
|
- | 168 |
+ 463 |
! |
- checkmate::assert_list(ggplot2_args, types = "ggplot2_args")
+ qenv,
|
- | 169 |
+ 464 |
! |
- checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
+ quote({
+ |
+
+
+ | 465 |
+ ! |
+
+ tbl_eigenvector <- dplyr::as_tibble(pca$rotation, rownames = "Variable")
+ |
+
+
+ | 466 |
+ ! |
+
+ tbl_eigenvector
|
- | 170 |
+ 467 |
|
- # End of assertions
+ })
|
- | 171 |
+ 468 |
+ |
+
+ )
+ |
+
+
+ | 469 |
+ |
+
+ })
+ |
+
+
+ | 470 |
|
|
- | 172 |
+ 471 |
|
- # Make UI args
+ # plot args ----
|
- | 173 |
+ 472 |
! |
- args <- as.list(environment())
+ output$plot_settings <- renderUI({
|
- | 174 |
+ 473 |
|
-
+ # reactivity triggers
|
- | 175 |
+ 474 |
! |
- data_extract_list <- list(
+ req(iv_r()$is_valid())
|
- | 176 |
+ 475 |
! |
- ref = ref,
+ req(computation())
|
- | 177 |
+ 476 |
! |
- vars = vars
+ qenv <- computation()
|
- | 178 |
+ 477 |
|
- )
+
+ |
+
+
+ | 478 |
+ ! |
+
+ ns <- session$ns
|
- | 179 |
+ 479 |
|
|
- | 180 |
+ 480 |
! |
- ans <- module(
+ pca <- qenv[["pca"]]
|
- | 181 |
+ 481 |
! |
- label = label,
+ chcs_pcs <- colnames(pca$rotation)
|
- | 182 |
+ 482 |
! |
- server = srv_tm_g_association,
+ chcs_vars <- qenv[["keep_columns"]]
+ |
+
+
+ | 483 |
+ |
+
+
|
- | 183 |
+ 484 |
! |
- ui = ui_tm_g_association,
+ tagList(
|
- | 184 |
+ 485 |
! |
- ui_args = args,
+ conditionalPanel(
|
- | 185 |
+ 486 |
! |
- server_args = c(
+ condition = sprintf(
|
- | 186 |
+ 487 |
! |
- data_extract_list,
+ "input['%s'] == 'Biplot' || input['%s'] == 'Circle plot'",
|
- | 187 |
+ 488 |
! |
- list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args)
+ ns("plot_type"), ns("plot_type")
|
- | 188 |
+ 489 |
|
- ),
+ ),
|
- | 189 |
+ 490 |
! |
- datanames = teal.transform::get_extract_datanames(data_extract_list)
+ list(
|
-
- | 190 |
- |
+
+ | 491 |
+ ! |
- )
+ teal.widgets::optionalSelectInput(ns("x_axis"), "X axis", choices = chcs_pcs, selected = chcs_pcs[1]),
|
- | 191 |
+ 492 |
! |
- attr(ans, "teal_bookmarkable") <- TRUE
+ teal.widgets::optionalSelectInput(ns("y_axis"), "Y axis", choices = chcs_pcs, selected = chcs_pcs[2]),
|
- | 192 |
+ 493 |
! |
- ans
+ teal.widgets::optionalSelectInput(
|
-
- | 193 |
- |
+
+ | 494 |
+ ! |
- }
+ ns("variables"), "Original coordinates",
+ |
+
+
+ | 495 |
+ ! |
+
+ choices = chcs_vars, selected = chcs_vars,
+ |
+
+
+ | 496 |
+ ! |
+
+ multiple = TRUE
|
- | 194 |
+ 497 |
|
-
+ )
|
- | 195 |
+ 498 |
|
- # UI function for the association module
+ )
|
- | 196 |
+ 499 |
|
- ui_tm_g_association <- function(id, ...) {
+ ),
|
- | 197 |
+ 500 |
! |
- ns <- NS(id)
+ conditionalPanel(
|
- | 198 |
+ 501 |
! |
- args <- list(...)
+ condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")),
|
- | 199 |
+ 502 |
! |
- is_single_dataset_value <- teal.transform::is_single_dataset(args$ref, args$vars)
+ helpText("No plot specific settings available.")
|
- | 200 |
+ 503 |
|
-
+ ),
|
- | 201 |
+ 504 |
! |
- teal.widgets::standard_layout(
+ conditionalPanel(
|
- | 202 |
+ 505 |
! |
- output = teal.widgets::white_small_well(
+ condition = paste0("input['", ns("plot_type"), "'] == 'Eigenvector plot'"),
|
- | 203 |
+ 506 |
! |
- textOutput(ns("title")),
+ teal.widgets::optionalSelectInput(ns("pc"), "PC", choices = chcs_pcs, selected = chcs_pcs[1])
|
-
- | 204 |
- ! |
+
+ | 507 |
+ |
- tags$br(),
+ )
|
-
- | 205 |
- ! |
+
+ | 508 |
+ |
- teal.widgets::plot_with_settings_ui(id = ns("myplot"))
+ )
|
- | 206 |
+ 509 |
|
- ),
+ })
|
-
- | 207 |
- ! |
+
+ | 510 |
+ |
- encoding = tags$div(
+
|
- | 208 |
+ 511 |
|
- ### Reporter
+ # plot elbow ----
|
- | 209 |
+ 512 |
! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ plot_elbow <- function(base_q) {
+ |
+
+
+ | 513 |
+ ! |
+
+ ggtheme <- input$ggtheme
+ |
+
+
+ | 514 |
+ ! |
+
+ rotate_xaxis_labels <- input$rotate_xaxis_labels
+ |
+
+
+ | 515 |
+ ! |
+
+ font_size <- input$font_size
|
- | 210 |
+ 516 |
|
- ###
+
|
- | 211 |
+ 517 |
! |
- tags$label("Encodings", class = "text-primary"),
+ angle_value <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)
+ |
+
+
+ | 518 |
+ ! |
+
+ hjust_value <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)
+ |
+
+
+ | 519 |
+ |
+
+
|
- | 212 |
+ 520 |
! |
- teal.transform::datanames_input(args[c("ref", "vars")]),
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(
|
- | 213 |
+ 521 |
! |
- teal.transform::data_extract_ui(
+ labs = list(x = "Principal component", y = "Proportion of variance explained", color = "", fill = "Legend"),
|
- | 214 |
+ 522 |
! |
- id = ns("ref"),
+ theme = list(
|
- | 215 |
+ 523 |
! |
- label = "Reference variable",
+ legend.position = "right",
|
- | 216 |
+ 524 |
! |
- data_extract_spec = args$ref,
+ legend.spacing.y = quote(grid::unit(-5, "pt")),
|
- | 217 |
+ 525 |
! |
- is_single_dataset = is_single_dataset_value
+ legend.title = quote(element_text(vjust = 25)),
|
-
- | 218 |
- |
+
+ | 526 |
+ ! |
- ),
+ axis.text.x = substitute(
|
- | 219 |
+ 527 |
! |
- teal.transform::data_extract_ui(
+ element_text(angle = angle_value, hjust = hjust_value),
|
- | 220 |
+ 528 |
! |
- id = ns("vars"),
+ list(angle_value = angle_value, hjust_value = hjust_value)
|
-
- | 221 |
- ! |
+
+ | 529 |
+ |
- label = "Associated variables",
+ ),
|
- | 222 |
+ 530 |
! |
- data_extract_spec = args$vars,
+ text = substitute(element_text(size = font_size), list(font_size = font_size))
|
-
- | 223 |
- ! |
+
+ | 531 |
+ |
- is_single_dataset = is_single_dataset_value
+ )
|
- | 224 |
+ 532 |
|
- ),
+ )
|
-
- | 225 |
- ! |
+
+ | 533 |
+ |
- checkboxInput(
+
|
- | 226 |
+ 534 |
! |
- ns("association"),
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
|
- | 227 |
+ 535 |
! |
- "Association with reference variable",
+ teal.widgets::resolve_ggplot2_args(
|
- | 228 |
+ 536 |
! |
- value = args$show_association
+ user_plot = ggplot2_args[["Elbow plot"]],
|
-
- | 229 |
- |
+
+ | 537 |
+ ! |
- ),
+ user_default = ggplot2_args$default,
|
- | 230 |
+ 538 |
! |
- checkboxInput(
+ module_plot = dev_ggplot2_args
|
-
- | 231 |
- ! |
+
+ | 539 |
+ |
- ns("show_dist"),
+ ),
|
- | 232 |
+ 540 |
! |
- "Scaled frequencies",
+ ggtheme = ggtheme
|
-
- | 233 |
- ! |
+
+ | 541 |
+ |
- value = FALSE
+ )
|
- | 234 |
+ 542 |
|
- ),
+
|
- | 235 |
+ 543 |
! |
- checkboxInput(
+ teal.code::eval_code(
|
- | 236 |
+ 544 |
! |
- ns("log_transformation"),
+ base_q,
|
- | 237 |
+ 545 |
! |
- "Log transformed",
+ substitute(
|
- | 238 |
+ 546 |
! |
- value = FALSE
+ expr = {
|
-
- | 239 |
- |
+
+ | 547 |
+ ! |
- ),
+ elb_dat <- pca$importance[c("Proportion of Variance", "Cumulative Proportion"), ] %>%
|
- | 240 |
+ 548 |
! |
- teal.widgets::panel_group(
+ dplyr::as_tibble(rownames = "metric") %>%
|
- | 241 |
+ 549 |
! |
- teal.widgets::panel_item(
+ tidyr::gather("component", "value", -metric) %>%
|
- | 242 |
+ 550 |
! |
- title = "Plot settings",
+ dplyr::mutate(
|
- | 243 |
+ 551 |
! |
- teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Scatterplot opacity:", c(0.5, 0, 1), ticks = FALSE),
+ component = factor(component, levels = unique(stringr::str_sort(component, numeric = TRUE)))
|
-
- | 244 |
- ! |
+
+ | 552 |
+ |
- teal.widgets::optionalSliderInputValMinMax(ns("size"), "Scatterplot points size:", c(2, 1, 8), ticks = FALSE),
+ )
|
-
- | 245 |
- ! |
+
+ | 553 |
+ |
- checkboxInput(ns("swap_axes"), "Swap axes", value = FALSE),
+
|
- | 246 |
+ 554 |
! |
- checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = FALSE),
+ cols <- c(getOption("ggplot2.discrete.colour"), c("lightblue", "darkred", "black"))[1:3]
|
- | 247 |
+ 555 |
! |
- selectInput(
+ g <- ggplot(mapping = aes_string(x = "component", y = "value")) +
|
- | 248 |
+ 556 |
! |
- inputId = ns("distribution_theme"),
+ geom_bar(
|
- | 249 |
+ 557 |
! |
- label = "Distribution theme (by ggplot):",
+ aes(fill = "Single variance"),
|
- | 250 |
+ 558 |
! |
- choices = ggplot_themes,
+ data = dplyr::filter(elb_dat, metric == "Proportion of Variance"),
|
- | 251 |
+ 559 |
! |
- selected = args$distribution_theme,
+ color = "black",
|
- | 252 |
+ 560 |
! |
- multiple = FALSE
+ stat = "identity"
|
- | 253 |
+ 561 |
|
- ),
+ ) +
|
- | 254 |
+ 562 |
! |
- selectInput(
+ geom_point(
|
- | 255 |
+ 563 |
! |
- inputId = ns("association_theme"),
+ aes(color = "Cumulative variance"),
|
- | 256 |
+ 564 |
! |
- label = "Association theme (by ggplot):",
+ data = dplyr::filter(elb_dat, metric == "Cumulative Proportion")
|
-
- | 257 |
- ! |
+
+ | 565 |
+ |
- choices = ggplot_themes,
+ ) +
|
- | 258 |
+ 566 |
! |
- selected = args$association_theme,
+ geom_line(
|
- | 259 |
+ 567 |
! |
- multiple = FALSE
- |
-
-
- | 260 |
- |
-
- )
- |
-
-
- | 261 |
- |
-
- )
+ aes(group = 1, color = "Cumulative variance"),
|
-
- | 262 |
- |
+
+ | 568 |
+ ! |
- )
+ data = dplyr::filter(elb_dat, metric == "Cumulative Proportion")
|
- | 263 |
+ 569 |
|
- ),
+ ) +
|
- | 264 |
+ 570 |
! |
- forms = tagList(
+ labs +
|
- | 265 |
+ 571 |
! |
- teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
+ scale_color_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[3])) +
|
-
- | 266 |
- |
+
+ | 572 |
+ ! |
- ),
+ scale_fill_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[1])) +
|
- | 267 |
+ 573 |
! |
- pre_output = args$pre_output,
+ ggthemes +
|
- | 268 |
+ 574 |
! |
- post_output = args$post_output
+ themes
|
- | 269 |
+ 575 |
|
- )
+
|
-
- | 270 |
- |
+
+ | 576 |
+ ! |
- }
+ print(g)
|
- | 271 |
+ 577 |
|
-
+ },
|
-
- | 272 |
- |
+
+ | 578 |
+ ! |
- # Server function for the association module
+ env = list(
|
-
- | 273 |
- |
+
+ | 579 |
+ ! |
- srv_tm_g_association <- function(id,
+ ggthemes = parsed_ggplot2_args$ggtheme,
|
-
- | 274 |
- |
+
+ | 580 |
+ ! |
- data,
+ labs = parsed_ggplot2_args$labs,
|
-
- | 275 |
- |
+
+ | 581 |
+ ! |
- reporter,
+ themes = parsed_ggplot2_args$theme
|
- | 276 |
+ 582 |
|
- filter_panel_api,
+ )
|
- | 277 |
+ 583 |
|
- ref,
+ )
|
- | 278 |
+ 584 |
|
- vars,
+ )
|
- | 279 |
+ 585 |
|
- plot_height,
+ }
|
- | 280 |
+ 586 |
|
- plot_width,
+
|
- | 281 |
+ 587 |
|
- ggplot2_args) {
- |
-
-
- | 282 |
- ! |
-
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
+ # plot circle ----
|
- | 283 |
+ 588 |
! |
- with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
+ plot_circle <- function(base_q) {
|
- | 284 |
+ 589 |
! |
- checkmate::assert_class(data, "reactive")
+ x_axis <- input$x_axis
|
- | 285 |
+ 590 |
! |
- checkmate::assert_class(isolate(data()), "teal_data")
- |
-
-
- | 286 |
- |
-
-
+ y_axis <- input$y_axis
|
- | 287 |
+ 591 |
! |
- moduleServer(id, function(input, output, session) {
+ variables <- input$variables
|
- | 288 |
+ 592 |
! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
+ ggtheme <- input$ggtheme
|
- | 289 |
+ 593 |
|
|
- | 290 |
+ 594 |
! |
- selector_list <- teal.transform::data_extract_multiple_srv(
+ rotate_xaxis_labels <- input$rotate_xaxis_labels
|
- | 291 |
+ 595 |
! |
- data_extract = list(ref = ref, vars = vars),
+ font_size <- input$font_size
|
-
- | 292 |
- ! |
+
+ | 596 |
+ |
- datasets = data,
+
|
- | 293 |
+ 597 |
! |
- select_validation_rule = list(
+ angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)
|
- | 294 |
+ 598 |
! |
- ref = shinyvalidate::compose_rules(
+ hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)
|
-
- | 295 |
- ! |
+
+ | 599 |
+ |
- shinyvalidate::sv_required("A reference variable needs to be selected."),
+
|
- | 296 |
+ 600 |
! |
- ~ if ((.) %in% selector_list()$vars()$select) {
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(
|
- | 297 |
+ 601 |
! |
- "Associated variables and reference variable cannot overlap"
- |
-
-
- | 298 |
- |
-
- }
- |
-
-
- | 299 |
- |
-
- ),
+ theme = list(
|
- | 300 |
+ 602 |
! |
- vars = shinyvalidate::compose_rules(
+ text = substitute(element_text(size = font_size), list(font_size = font_size)),
|
- | 301 |
+ 603 |
! |
- shinyvalidate::sv_required("An associated variable needs to be selected."),
+ axis.text.x = substitute(
|
- | 302 |
+ 604 |
! |
- ~ if (length(selector_list()$ref()$select) != 0 && selector_list()$ref()$select %in% (.)) {
+ element_text(angle = angle_val, hjust = hjust_val),
|
- | 303 |
+ 605 |
! |
- "Associated variables and reference variable cannot overlap"
- |
-
-
- | 304 |
- |
-
- }
- |
-
-
- | 305 |
- |
-
- )
- |
-
-
- | 306 |
- |
-
- )
+ list(angle_val = angle, hjust_val = hjust)
|
- | 307 |
+ 606 |
|
- )
+ )
|
- | 308 |
- |
-
-
- |
-
-
- | 309 |
- ! |
-
- iv_r <- reactive({
- |
-
-
- | 310 |
- ! |
-
- iv <- shinyvalidate::InputValidator$new()
- |
-
-
- | 311 |
- ! |
+ 607 |
+ |
- teal.transform::compose_and_enable_validators(iv, selector_list)
+ )
|
- | 312 |
+ 608 |
|
- })
+ )
|
- | 313 |
+ 609 |
|
|
- | 314 |
+ 610 |
! |
- anl_merged_input <- teal.transform::merge_expression_srv(
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
|
- | 315 |
+ 611 |
! |
- datasets = data,
+ user_plot = ggplot2_args[["Circle plot"]],
|
- | 316 |
+ 612 |
! |
- selector_list = selector_list
+ user_default = ggplot2_args$default,
+ |
+
+
+ | 613 |
+ ! |
+
+ module_plot = dev_ggplot2_args
|
- | 317 |
+ 614 |
|
- )
+ )
|
- | 318 |
+ 615 |
|
|
- | 319 |
+ 616 |
! |
- anl_merged_q <- reactive({
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
|
- | 320 |
+ 617 |
! |
- req(anl_merged_input())
+ all_ggplot2_args,
|
- | 321 |
+ 618 |
! |
- data() %>% teal.code::eval_code(as.expression(anl_merged_input()$expr))
+ ggtheme = ggtheme
|
- | 322 |
+ 619 |
|
- })
+ )
|
- | 323 |
+ 620 |
|
|
- | 324 |
+ 621 |
! |
- merged <- list(
+ teal.code::eval_code(
|
- | 325 |
+ 622 |
! |
- anl_input_r = anl_merged_input,
+ base_q,
|
- | 326 |
+ 623 |
! |
- anl_q_r = anl_merged_q
+ substitute(
|
-
- | 327 |
- |
+
+ | 624 |
+ ! |
- )
+ expr = {
|
-
- | 328 |
- |
+
+ | 625 |
+ ! |
-
+ pca_rot <- pca$rotation[, c(x_axis, y_axis)] %>%
|
- | 329 |
+ 626 |
! |
- output_q <- reactive({
+ dplyr::as_tibble(rownames = "label") %>%
|
- | 330 |
+ 627 |
! |
- teal::validate_inputs(iv_r())
+ dplyr::filter(label %in% variables)
|
- | 331 |
+ 628 |
|
|
- | 332 |
+ 629 |
! |
- ANL <- merged$anl_q_r()[["ANL"]]
+ circle_data <- data.frame(
|
- | 333 |
+ 630 |
! |
- teal::validate_has_data(ANL, 3)
- |
-
-
- | 334 |
- |
-
-
+ x = cos(seq(0, 2 * pi, length.out = 100)),
|
- | 335 |
+ 631 |
! |
- vars_names <- merged$anl_input_r()$columns_source$vars
+ y = sin(seq(0, 2 * pi, length.out = 100))
|
- | 336 |
+ 632 |
|
-
- |
-
-
- | 337 |
- ! |
-
- ref_name <- as.vector(merged$anl_input_r()$columns_source$ref)
+ )
|
-
- | 338 |
- ! |
+
+ | 633 |
+ |
- association <- input$association
+
|
- | 339 |
+ 634 |
! |
- show_dist <- input$show_dist
+ g <- ggplot(pca_rot) +
|
- | 340 |
+ 635 |
! |
- log_transformation <- input$log_transformation
+ geom_point(aes_string(x = x_axis, y = y_axis)) +
|
- | 341 |
+ 636 |
! |
- rotate_xaxis_labels <- input$rotate_xaxis_labels
+ geom_label(
|
- | 342 |
+ 637 |
! |
- swap_axes <- input$swap_axes
+ aes_string(x = x_axis, y = y_axis, label = "label"),
|
- | 343 |
+ 638 |
! |
- distribution_theme <- input$distribution_theme
+ nudge_x = 0.1, nudge_y = 0.05,
|
- | 344 |
+ 639 |
! |
- association_theme <- input$association_theme
+ fontface = "bold"
|
- | 345 |
+ 640 |
|
-
+ ) +
|
- | 346 |
+ 641 |
! |
- is_scatterplot <- is.numeric(ANL[[ref_name]]) && any(vapply(ANL[vars_names], is.numeric, logical(1)))
+ geom_path(aes(x, y, group = 1), data = circle_data) +
|
- | 347 |
+ 642 |
! |
- if (is_scatterplot) {
+ geom_point(aes(x = x, y = y), data = data.frame(x = 0, y = 0), shape = "x", size = 5) +
|
- | 348 |
+ 643 |
! |
- shinyjs::show("alpha")
+ labs +
|
- | 349 |
+ 644 |
! |
- shinyjs::show("size")
+ ggthemes +
|
- | 350 |
+ 645 |
! |
- alpha <- input$alpha
+ themes
|
- | 351 |
+ 646 |
! |
- size <- input$size
+ print(g)
|
- | 352 |
+ 647 |
|
- } else {
+ },
|
- | 353 |
+ 648 |
! |
- shinyjs::hide("alpha")
+ env = list(
|
- | 354 |
+ 649 |
! |
- shinyjs::hide("size")
+ x_axis = x_axis,
|
- | 355 |
+ 650 |
! |
- alpha <- 0.5
+ y_axis = y_axis,
|
- | 356 |
+ 651 |
! |
- size <- 2
+ variables = variables,
|
-
- | 357 |
- |
+
+ | 652 |
+ ! |
- }
+ ggthemes = parsed_ggplot2_args$ggtheme,
|
-
- | 358 |
- |
+
+ | 653 |
+ ! |
-
+ labs = `if`(is.null(parsed_ggplot2_args$labs), quote(labs()), parsed_ggplot2_args$labs),
|
- | 359 |
+ 654 |
! |
- teal::validate_has_data(ANL[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE)
+ themes = parsed_ggplot2_args$theme
|
- | 360 |
+ 655 |
|
-
+ )
|
- | 361 |
+ 656 |
|
- # reference
+ )
|
-
- | 362 |
- ! |
+
+ | 657 |
+ |
- ref_class <- class(ANL[[ref_name]])[1]
+ )
|
-
- | 363 |
- ! |
+
+ | 658 |
+ |
- if (is.numeric(ANL[[ref_name]]) && log_transformation) {
+ }
|
- | 364 |
+ 659 |
|
- # works for both integers and doubles
+
+ |
+
+
+ | 660 |
+ |
+
+ # plot biplot ----
|
- | 365 |
+ 661 |
! |
- ref_cl_name <- call("log", as.name(ref_name))
+ plot_biplot <- function(base_q) {
|
- | 366 |
+ 662 |
! |
- ref_cl_lbl <- varname_w_label(ref_name, ANL, prefix = "Log of ")
+ qenv <- base_q
|
- | 367 |
+ 663 |
|
- } else {
+
|
-
- | 368 |
- |
+
+ | 664 |
+ ! |
- # silently ignore when non-numeric even if `log` is selected because some
+ ANL <- qenv[["ANL"]]
|
- | 369 |
+ 665 |
|
- # variables may be numeric and others not
+
|
- | 370 |
+ 666 |
! |
- ref_cl_name <- as.name(ref_name)
+ resp_col <- as.character(merged$anl_input_r()$columns_source$response)
|
- | 371 |
+ 667 |
! |
- ref_cl_lbl <- varname_w_label(ref_name, ANL)
- |
-
-
- | 372 |
- |
-
- }
- |
-
-
- | 373 |
- |
-
-
+ dat_cols <- as.character(merged$anl_input_r()$columns_source$dat)
|
- | 374 |
+ 668 |
! |
- user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
+ x_axis <- input$x_axis
|
- | 375 |
+ 669 |
! |
- user_plot = ggplot2_args[["Bivariate1"]],
+ y_axis <- input$y_axis
|
- | 376 |
+ 670 |
! |
- user_default = ggplot2_args$default
+ variables <- input$variables
|
-
- | 377 |
- |
+
+ | 671 |
+ ! |
- )
+ pca <- qenv[["pca"]]
|
- | 378 |
+ 672 |
|
|
- | 379 |
+ 673 |
! |
- ref_call <- bivariate_plot_call(
+ ggtheme <- input$ggtheme
|
-
- | 380 |
- ! |
+
+ | 674 |
+ |
- data_name = "ANL",
+
|
- | 381 |
+ 675 |
! |
- x = ref_cl_name,
+ rotate_xaxis_labels <- input$rotate_xaxis_labels
|
- | 382 |
+ 676 |
! |
- x_class = ref_class,
+ alpha <- input$alpha
|
- | 383 |
+ 677 |
! |
- x_label = ref_cl_lbl,
+ size <- input$size
|
- | 384 |
+ 678 |
! |
- freq = !show_dist,
+ font_size <- input$font_size
|
-
- | 385 |
- ! |
+
+ | 679 |
+ |
- theme = distribution_theme,
+
|
- | 386 |
+ 680 |
! |
- rotate_xaxis_labels = rotate_xaxis_labels,
+ qenv <- teal.code::eval_code(
|
- | 387 |
+ 681 |
! |
- swap_axes = FALSE,
+ qenv,
|
- | 388 |
+ 682 |
! |
- size = size,
+ substitute(
|
- | 389 |
+ 683 |
! |
- alpha = alpha,
+ expr = pca_rot <- dplyr::as_tibble(pca$x[, c(x_axis, y_axis)]),
|
- | 390 |
+ 684 |
! |
- ggplot2_args = user_ggplot2_args
+ env = list(x_axis = x_axis, y_axis = y_axis)
|
- | 391 |
+ 685 |
|
- )
+ )
|
- | 392 |
+ 686 |
|
-
+ )
|
- | 393 |
+ 687 |
|
- # association
- |
-
-
- | 394 |
- ! |
-
- ref_class_cov <- ifelse(association, ref_class, "NULL")
+
|
- | 395 |
+ 688 |
|
-
+ # rot_vars = data frame that displays arrows in the plot, need to be scaled to data
|
- | 396 |
+ 689 |
! |
- print_call <- quote(print(p))
- |
-
-
- | 397 |
- |
-
-
+ if (!is.null(input$variables)) {
|
- | 398 |
+ 690 |
! |
- var_calls <- lapply(vars_names, function(var_i) {
+ qenv <- teal.code::eval_code(
|
- | 399 |
+ 691 |
! |
- var_class <- class(ANL[[var_i]])[1]
+ qenv,
|
- | 400 |
+ 692 |
! |
- if (is.numeric(ANL[[var_i]]) && log_transformation) {
- |
-
-
- | 401 |
- |
-
- # works for both integers and doubles
+ substitute(
|
- | 402 |
+ 693 |
! |
- var_cl_name <- call("log", as.name(var_i))
+ expr = {
|
- | 403 |
+ 694 |
! |
- var_cl_lbl <- varname_w_label(var_i, ANL, prefix = "Log of ")
- |
-
-
- | 404 |
- |
-
- } else {
+ r <- sqrt(qchisq(0.69, df = 2)) * prod(colMeans(pca_rot ^ 2)) ^ (1 / 4) # styler: off
|
-
- | 405 |
- |
+
+ | 695 |
+ ! |
- # silently ignore when non-numeric even if `log` is selected because some
+ v_scale <- rowSums(pca$rotation ^ 2) # styler: off
|
- | 406 |
+ 696 |
|
- # variables may be numeric and others not
+
|
- | 407 |
+ 697 |
! |
- var_cl_name <- as.name(var_i)
+ rot_vars <- pca$rotation[, c(x_axis, y_axis)] %>%
|
- | 408 |
+ 698 |
! |
- var_cl_lbl <- varname_w_label(var_i, ANL)
- |
-
-
- | 409 |
- |
-
- }
- |
-
-
- | 410 |
- |
-
-
+ dplyr::as_tibble(rownames = "label") %>%
|
- | 411 |
+ 699 |
! |
- user_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
+ dplyr::mutate_at(vars(c(x_axis, y_axis)), function(x) r * x / sqrt(max(v_scale)))
|
-
- | 412 |
- ! |
+
+ | 700 |
+ |
- user_plot = ggplot2_args[["Bivariate2"]],
+ },
|
- | 413 |
+ 701 |
! |
- user_default = ggplot2_args$default
+ env = list(x_axis = x_axis, y_axis = y_axis)
|
- | 414 |
+ 702 |
|
- )
+ )
|
- | 415 |
+ 703 |
|
-
- |
-
-
- | 416 |
- ! |
-
- bivariate_plot_call(
+ ) %>%
|
- | 417 |
+ 704 |
! |
- data_name = "ANL",
+ teal.code::eval_code(
|
- | 418 |
+ 705 |
! |
- x = ref_cl_name,
+ if (is.logical(pca$center) && !pca$center) {
|
- | 419 |
+ 706 |
! |
- y = var_cl_name,
+ substitute(
|
- | 420 |
+ 707 |
! |
- x_class = ref_class_cov,
+ expr = {
|
- | 421 |
+ 708 |
! |
- y_class = var_class,
+ rot_vars <- rot_vars %>%
|
- | 422 |
+ 709 |
! |
- x_label = ref_cl_lbl,
+ tibble::column_to_rownames("label") %>%
|
- | 423 |
+ 710 |
! |
- y_label = var_cl_lbl,
+ sweep(1, apply(ANL[keep_columns], 2, mean, na.rm = TRUE)) %>%
|
- | 424 |
+ 711 |
! |
- theme = association_theme,
+ tibble::rownames_to_column("label") %>%
|
- | 425 |
+ 712 |
! |
- freq = !show_dist,
+ dplyr::mutate(
|
- | 426 |
+ 713 |
! |
- rotate_xaxis_labels = rotate_xaxis_labels,
+ xstart = mean(pca$x[, x_axis], na.rm = TRUE),
|
- | 427 |
+ 714 |
! |
- swap_axes = swap_axes,
+ ystart = mean(pca$x[, y_axis], na.rm = TRUE)
|
-
- | 428 |
- ! |
+
+ | 715 |
+ |
- alpha = alpha,
+ )
|
-
- | 429 |
- ! |
+
+ | 716 |
+ |
- size = size,
+ },
|
- | 430 |
+ 717 |
! |
- ggplot2_args = user_ggplot2_args
+ env = list(x_axis = x_axis, y_axis = y_axis)
|
- | 431 |
+ 718 |
|
- )
+ )
|
- | 432 |
+ 719 |
|
- })
+ } else {
+ |
+
+
+ | 720 |
+ ! |
+
+ quote(rot_vars <- rot_vars %>% dplyr::mutate(xstart = 0, ystart = 0))
|
- | 433 |
+ 721 |
|
-
+ }
|
- | 434 |
+ 722 |
|
- # helper function to format variable name
+ ) %>%
|
- | 435 |
+ 723 |
! |
- format_varnames <- function(x) {
+ teal.code::eval_code(
|
- | 436 |
+ 724 |
! |
- if (is.numeric(ANL[[x]]) && log_transformation) {
+ substitute(
|
- | 437 |
+ 725 |
! |
- varname_w_label(x, ANL, prefix = "Log of ")
+ expr = rot_vars <- rot_vars %>% dplyr::filter(label %in% variables),
+ |
+
+
+ | 726 |
+ ! |
+
+ env = list(variables = variables)
|
- | 438 |
+ 727 |
|
- } else {
+ )
|
-
- | 439 |
- ! |
+
+ | 728 |
+ |
- varname_w_label(x, ANL)
+ )
|
- | 440 |
+ 729 |
|
- }
+ }
|
- | 441 |
+ 730 |
|
- }
+
|
- | 442 |
+ 731 |
! |
- new_title <-
+ pca_plot_biplot_expr <- list(quote(ggplot()))
|
-
- | 443 |
- ! |
+
+ | 732 |
+ |
- if (association) {
+
|
- | 444 |
+ 733 |
! |
- switch(as.character(length(vars_names)),
+ if (length(resp_col) == 0) {
|
- | 445 |
+ 734 |
! |
- "0" = sprintf("Value distribution for %s", ref_cl_lbl),
+ pca_plot_biplot_expr <- c(
|
- | 446 |
+ 735 |
! |
- "1" = sprintf(
+ pca_plot_biplot_expr,
|
- | 447 |
+ 736 |
! |
- "Association between %s and %s",
+ substitute(
|
- | 448 |
+ 737 |
! |
- ref_cl_lbl,
+ geom_point(aes_string(x = x_axis, y = y_axis), data = pca_rot, alpha = alpha, size = size),
|
- | 449 |
+ 738 |
! |
- format_varnames(vars_names)
+ list(x_axis = input$x_axis, y_axis = input$y_axis, alpha = input$alpha, size = input$size)
|
- | 450 |
+ 739 |
|
- ),
+ )
|
-
- | 451 |
- ! |
+
+ | 740 |
+ |
- sprintf(
+ )
|
- | 452 |
+ 741 |
! |
- "Associations between %s and: %s",
+ dev_labs <- list()
|
-
- | 453 |
- ! |
+
+ | 742 |
+ |
- ref_cl_lbl,
+ } else {
|
- | 454 |
+ 743 |
! |
- paste(lapply(vars_names, format_varnames), collapse = ", ")
+ rp_keys <- setdiff(colnames(ANL), as.character(unlist(merged$anl_input_r()$columns_source)))
|
- | 455 |
+ 744 |
|
- )
+
|
-
- | 456 |
- |
+
+ | 745 |
+ ! |
- )
+ response <- ANL[[resp_col]]
|
- | 457 |
+ 746 |
|
- } else {
+
|
- | 458 |
+ 747 |
! |
- switch(as.character(length(vars_names)),
+ aes_biplot <- substitute(
|
- | 459 |
+ 748 |
! |
- "0" = sprintf("Value distribution for %s", ref_cl_lbl),
+ aes_string(x = x_axis, y = y_axis, color = "response"),
|
- | 460 |
+ 749 |
! |
- sprintf(
+ env = list(x_axis = x_axis, y_axis = y_axis)
+ |
+
+
+ | 750 |
+ |
+
+ )
+ |
+
+
+ | 751 |
+ |
+
+
|
- | 461 |
+ 752 |
! |
- "Value distributions for %s and %s",
+ qenv <- teal.code::eval_code(
|
- | 462 |
+ 753 |
! |
- ref_cl_lbl,
+ qenv,
|
- | 463 |
+ 754 |
! |
- paste(lapply(vars_names, format_varnames), collapse = ", ")
+ substitute(response <- ANL[[resp_col]], env = list(resp_col = resp_col))
|
- | 464 |
+ 755 |
|
- )
+ )
|
- | 465 |
+ 756 |
|
- )
+
|
-
- | 466 |
- |
+
+ | 757 |
+ ! |
- }
+ dev_labs <- list(color = varname_w_label(resp_col, ANL))
|
- | 467 |
+ 758 |
|
|
- | 468 |
+ 759 |
! |
- teal.code::eval_code(
+ scales_biplot <-
|
- | 469 |
+ 760 |
! |
- merged$anl_q_r(),
+ if (
|
- | 470 |
+ 761 |
! |
- substitute(
+ is.character(response) ||
|
- | 471 |
+ 762 |
! |
- expr = title <- new_title,
+ is.factor(response) ||
|
- | 472 |
+ 763 |
! |
- env = list(new_title = new_title)
+ (is.numeric(response) && length(unique(response)) <= 6)
|
- | 473 |
+ 764 |
|
- )
+ ) {
|
-
- | 474 |
- |
+
+ | 765 |
+ ! |
- ) %>%
+ qenv <- teal.code::eval_code(
|
- | 475 |
+ 766 |
! |
- teal.code::eval_code(
+ qenv,
|
- | 476 |
+ 767 |
! |
- substitute(
+ quote(pca_rot$response <- as.factor(response))
+ |
+
+
+ | 768 |
+ |
+
+ )
|
- | 477 |
+ 769 |
! |
- expr = {
+ quote(scale_color_brewer(palette = "Dark2"))
|
- | 478 |
+ 770 |
! |
- plots <- plot_calls
+ } else if (inherits(response, "Date")) {
|
- | 479 |
+ 771 |
! |
- p <- tern::stack_grobs(grobs = lapply(plots, ggplotGrob))
+ qenv <- teal.code::eval_code(
|
- | 480 |
+ 772 |
! |
- grid::grid.newpage()
+ qenv,
|
- | 481 |
+ 773 |
! |
- grid::grid.draw(p)
+ quote(pca_rot$response <- numeric(response))
|
- | 482 |
+ 774 |
|
- },
+ )
+ |
+
+
+ | 775 |
+ |
+
+
|
- | 483 |
+ 776 |
! |
- env = list(
+ quote(
|
- | 484 |
+ 777 |
! |
- plot_calls = do.call(
+ scale_color_gradient(
|
- | 485 |
+ 778 |
! |
- "call",
+ low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],
|
- | 486 |
+ 779 |
! |
- c(list("list", ref_call), var_calls),
+ high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1],
|
- | 487 |
+ 780 |
! |
- quote = TRUE
+ labels = function(x) as.Date(x, origin = "1970-01-01")
|
- | 488 |
+ 781 |
|
)
|
- | 489 |
+ 782 |
|
)
|
- | 490 |
- |
-
- )
- |
-
-
- | 491 |
- |
-
- )
- |
-
-
- | 492 |
- |
-
- })
- |
-
-
- | 493 |
+ 783 |
|
-
+ } else {
|
- | 494 |
+ 784 |
! |
- plot_r <- reactive({
+ qenv <- teal.code::eval_code(
|
- | 495 |
+ 785 |
! |
- req(iv_r()$is_valid())
+ qenv,
|
- | 496 |
+ 786 |
! |
- output_q()[["p"]]
- |
-
-
- | 497 |
- |
-
- })
+ quote(pca_rot$response <- response)
|
- | 498 |
+ 787 |
|
-
- |
-
-
- | 499 |
- ! |
-
- pws <- teal.widgets::plot_with_settings_srv(
+ )
|
- | 500 |
+ 788 |
! |
- id = "myplot",
+ quote(scale_color_gradient(
|
- | 501 |
+ 789 |
! |
- plot_r = plot_r,
+ low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1],
|
- | 502 |
+ 790 |
! |
- height = plot_height,
+ high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
|
-
- | 503 |
- ! |
+
+ | 791 |
+ |
- width = plot_width
+ ))
|
- | 504 |
+ 792 |
|
- )
+ }
|
- | 505 |
+ 793 |
|
|
- | 506 |
+ 794 |
! |
- output$title <- renderText({
+ pca_plot_biplot_expr <- c(
|
- | 507 |
+ 795 |
! |
- teal.code::dev_suppress(output_q()[["title"]])
- |
-
-
- | 508 |
- |
-
- })
+ pca_plot_biplot_expr,
|
-
- | 509 |
- |
+
+ | 796 |
+ ! |
-
+ substitute(
|
- | 510 |
+ 797 |
! |
- teal.widgets::verbatim_popup_srv(
+ geom_point(aes_biplot, data = pca_rot, alpha = alpha, size = size),
|
- | 511 |
+ 798 |
! |
- id = "rcode",
+ env = list(aes_biplot = aes_biplot, alpha = alpha, size = size)
|
-
- | 512 |
- ! |
+
+ | 799 |
+ |
- verbatim_content = reactive(teal.code::get_code(output_q())),
+ ),
|
- | 513 |
+ 800 |
! |
- title = "Association Plot"
+ scales_biplot
|
- | 514 |
+ 801 |
|
- )
+ )
|
- | 515 |
+ 802 |
|
-
+ }
|
- | 516 |
+ 803 |
|
- ### REPORTER
+
+ |
+
+
+ | 804 |
+ ! |
+
+ if (!is.null(input$variables)) {
+ |
+
+
+ | 805 |
+ ! |
+
+ pca_plot_biplot_expr <- c(
|
- | 517 |
+ 806 |
! |
- if (with_reporter) {
+ pca_plot_biplot_expr,
|
- | 518 |
+ 807 |
! |
- card_fun <- function(comment, label) {
+ substitute(
|
- | 519 |
+ 808 |
! |
- card <- teal::report_card_template(
+ geom_segment(
|
- | 520 |
+ 809 |
! |
- title = "Association Plot",
+ aes_string(x = "xstart", y = "ystart", xend = x_axis, yend = y_axis),
|
- | 521 |
+ 810 |
! |
- label = label,
+ data = rot_vars,
|
- | 522 |
+ 811 |
! |
- with_filter = with_filter,
+ lineend = "round", linejoin = "round",
|
- | 523 |
+ 812 |
! |
- filter_panel_api = filter_panel_api
+ arrow = grid::arrow(length = grid::unit(0.5, "cm"))
|
- | 524 |
+ 813 |
|
- )
+ ),
|
- | 525 |
+ 814 |
! |
- card$append_text("Plot", "header3")
+ env = list(x_axis = x_axis, y_axis = y_axis)
|
-
- | 526 |
- ! |
+
+ | 815 |
+ |
- card$append_plot(plot_r(), dim = pws$dim())
+ ),
|
- | 527 |
+ 816 |
! |
- if (!comment == "") {
+ substitute(
|
- | 528 |
+ 817 |
! |
- card$append_text("Comment", "header3")
+ geom_label(
|
- | 529 |
+ 818 |
! |
- card$append_text(comment)
+ aes_string(
|
-
- | 530 |
- |
+
+ | 819 |
+ ! |
- }
+ x = x_axis,
|
- | 531 |
+ 820 |
! |
- card$append_src(teal.code::get_code(output_q()))
+ y = y_axis,
|
- | 532 |
+ 821 |
! |
- card
+ label = "label"
|
- | 533 |
+ 822 |
|
- }
+ ),
|
- | 534 |
+ 823 |
! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ data = rot_vars,
|
-
- | 535 |
- |
+
+ | 824 |
+ ! |
- }
+ nudge_y = 0.1,
|
-
- | 536 |
- |
+
+ | 825 |
+ ! |
- ###
+ fontface = "bold"
|
- | 537 |
+ 826 |
|
- })
+ ),
|
-
- | 538 |
- |
+
+ | 827 |
+ ! |
- }
+ env = list(x_axis = x_axis, y_axis = y_axis)
|
-
-
-
-
-
-
- | 1 |
+ 828 |
|
- .onLoad <- function(libname, pkgname) {
+ ),
|
- | 2 |
+ 829 |
! |
- teal.logger::register_logger(namespace = "teal.modules.general")
+ quote(geom_point(aes(x = xstart, y = ystart), data = rot_vars, shape = "x", size = 5))
|
-
- | 3 |
- ! |
+
+ | 830 |
+ |
- teal.logger::register_handlers("teal.modules.general")
+ )
|
- | 4 |
+ 831 |
|
- }
+ }
|
- | 5 |
+ 832 |
|
|
-
- | 6 |
- |
+
+ | 833 |
+ ! |
- ### global variables
+ angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0)
|
-
- | 7 |
- |
+
+ | 834 |
+ ! |
- ggplot_themes <- c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void")
+ hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5)
|
- | 8 |
+ 835 |
|
|
-
- | 9 |
- |
+
+ | 836 |
+ ! |
- interactive <- NULL
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(
|
-
-
-
-
-
-
-
- | 1 |
- |
+
+ | 837 |
+ ! |
- #' `teal` module: Front page
+ labs = dev_labs,
|
-
- | 2 |
- |
+
+ | 838 |
+ ! |
- #'
+ theme = list(
|
-
- | 3 |
- |
+
+ | 839 |
+ ! |
- #' Creates a simple front page for `teal` applications, displaying
+ text = substitute(element_text(size = font_size), list(font_size = font_size)),
|
-
- | 4 |
- |
+
+ | 840 |
+ ! |
- #' introductory text, tables, additional `html` or `shiny` tags, and footnotes.
+ axis.text.x = substitute(
|
-
- | 5 |
- |
+
+ | 841 |
+ ! |
- #'
+ element_text(angle = angle_val, hjust = hjust_val),
|
-
- | 6 |
- |
+
+ | 842 |
+ ! |
- #' @inheritParams teal::module
+ list(angle_val = angle, hjust_val = hjust)
|
- | 7 |
+ 843 |
|
- #' @param header_text (`character` vector) text to be shown at the top of the module, for each
+ )
|
- | 8 |
+ 844 |
|
- #' element, if named the name is shown first in bold as a header followed by the value. The first
+ )
|
- | 9 |
+ 845 |
|
- #' element's header is displayed larger than the others.
+ )
|
- | 10 |
+ 846 |
|
- #' @param tables (`named list` of `data.frame`s) tables to be shown in the module.
+
|
-
- | 11 |
- |
+
+ | 847 |
+ ! |
- #' @param additional_tags (`shiny.tag.list` or `html`) additional `shiny` tags or `html` to be included after the table,
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
|
-
- | 12 |
- |
+
+ | 848 |
+ ! |
- #' for example to include an image, `tagList(tags$img(src = "image.png"))` or to include further `html`,
+ user_plot = ggplot2_args[["Biplot"]],
|
-
- | 13 |
- |
+
+ | 849 |
+ ! |
- #' `HTML("html text here")`.
+ user_default = ggplot2_args$default,
|
-
- | 14 |
- |
+
+ | 850 |
+ ! |
- #' @param footnotes (`character` vector) of text to be shown at the bottom of the module, for each
+ module_plot = dev_ggplot2_args
|
- | 15 |
+ 851 |
|
- #' element, if named the name is shown first in bold, followed by the value.
+ )
|
- | 16 |
+ 852 |
|
- #' @param show_metadata (`logical`) indicating whether the metadata of the datasets be available on the module.
+
|
-
- | 17 |
- |
+
+ | 853 |
+ ! |
- #'
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
|
-
- | 18 |
- |
+
+ | 854 |
+ ! |
- #' @inherit shared_params return
+ all_ggplot2_args,
|
-
- | 19 |
- |
+
+ | 855 |
+ ! |
- #'
+ ggtheme = ggtheme
|
- | 20 |
+ 856 |
|
- #' @examples
+ )
|
- | 21 |
+ 857 |
|
- #' data <- teal_data()
+
|
-
- | 22 |
- |
+
+ | 858 |
+ ! |
- #' data <- within(data, {
+ pca_plot_biplot_expr <- c(
|
-
- | 23 |
- |
+
+ | 859 |
+ ! |
- #' require(nestcolor)
+ pca_plot_biplot_expr,
|
-
- | 24 |
- |
+
+ | 860 |
+ ! |
- #' ADSL <- rADSL
+ parsed_ggplot2_args
|
- | 25 |
+ 861 |
|
- #' attr(ADSL, "metadata") <- list("Author" = "NEST team", "data_source" = "synthetic data")
+ )
|
- | 26 |
+ 862 |
|
- #' })
+
|
-
- | 27 |
- |
+
+ | 863 |
+ ! |
- #' datanames(data) <- "ADSL"
+ teal.code::eval_code(
|
-
- | 28 |
- |
+
+ | 864 |
+ ! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames(data)]
+ qenv,
|
-
- | 29 |
- |
+
+ | 865 |
+ ! |
- #'
+ substitute(
|
-
- | 30 |
- |
+
+ | 866 |
+ ! |
- #' table_1 <- data.frame(Info = c("A", "B"), Text = c("A", "B"))
+ expr = {
|
-
- | 31 |
- |
+
+ | 867 |
+ ! |
- #' table_2 <- data.frame(`Column 1` = c("C", "D"), `Column 2` = c(5.5, 6.6), `Column 3` = c("A", "B"))
+ g <- plot_call
|
-
- | 32 |
- |
+
+ | 868 |
+ ! |
- #' table_3 <- data.frame(Info = c("E", "F"), Text = c("G", "H"))
+ print(g)
|
- | 33 |
+ 869 |
|
- #'
+ },
|
-
- | 34 |
- |
+
+ | 870 |
+ ! |
- #' table_input <- list(
+ env = list(
|
-
- | 35 |
- |
+
+ | 871 |
+ ! |
- #' "Table 1" = table_1,
+ plot_call = Reduce(function(x, y) call("+", x, y), pca_plot_biplot_expr)
|
- | 36 |
+ 872 |
|
- #' "Table 2" = table_2,
+ )
|
- | 37 |
+ 873 |
|
- #' "Table 3" = table_3
+ )
|
- | 38 |
+ 874 |
|
- #' )
+ )
|
- | 39 |
+ 875 |
|
- #'
+ }
|
- | 40 |
+ 876 |
|
- #' app <- init(
+
|
- | 41 |
+ 877 |
|
- #' data = data,
+ # plot pc_var ----
|
-
- | 42 |
- |
+
+ | 878 |
+ ! |
- #' modules = modules(
+ plot_pc_var <- function(base_q) {
|
-
- | 43 |
- |
+
+ | 879 |
+ ! |
- #' tm_front_page(
+ pc <- input$pc
|
-
- | 44 |
- |
+
+ | 880 |
+ ! |
- #' header_text = c(
+ ggtheme <- input$ggtheme
|
- | 45 |
+ 881 |
|
- #' "Important information" = "It can go here.",
+
|
-
- | 46 |
- |
+
+ | 882 |
+ ! |
- #' "Other information" = "Can go here."
+ rotate_xaxis_labels <- input$rotate_xaxis_labels
|
-
- | 47 |
- |
+
+ | 883 |
+ ! |
- #' ),
+ font_size <- input$font_size
|
- | 48 |
+ 884 |
|
- #' tables = table_input,
+
|
-
- | 49 |
- |
+
+ | 885 |
+ ! |
- #' additional_tags = HTML("Additional HTML or shiny tags go here <br>"),
+ angle <- ifelse(rotate_xaxis_labels, 45, 0)
|
-
- | 50 |
- |
+
+ | 886 |
+ ! |
- #' footnotes = c("X" = "is the first footnote", "Y is the second footnote"),
+ hjust <- ifelse(rotate_xaxis_labels, 1, 0.5)
|
- | 51 |
+ 887 |
|
- #' show_metadata = TRUE
+
|
-
- | 52 |
- |
+
+ | 888 |
+ ! |
- #' )
- |
-
-
- | 53 |
- |
+ dev_ggplot2_args <- teal.widgets::ggplot2_args(
+
+
+
+ | 889 |
+ ! |
- #' ),
+ theme = list(
|
-
- | 54 |
- |
+
+ | 890 |
+ ! |
- #' header = tags$h1("Sample Application"),
+ text = substitute(element_text(size = font_size), list(font_size = font_size)),
|
-
- | 55 |
- |
+
+ | 891 |
+ ! |
- #' footer = tags$p("Application footer"),
+ axis.text.x = substitute(
|
-
- | 56 |
- |
+
+ | 892 |
+ ! |
- #' )
+ element_text(angle = angle_val, hjust = hjust_val),
|
-
- | 57 |
- |
+
+ | 893 |
+ ! |
- #'
+ list(angle_val = angle, hjust_val = hjust)
|
- | 58 |
+ 894 |
|
- #' if (interactive()) {
+ )
|
- | 59 |
+ 895 |
|
- #' shinyApp(app$ui, app$server)
+ )
|
- | 60 |
+ 896 |
|
- #' }
+ )
|
- | 61 |
+ 897 |
|
- #'
+
|
-
- | 62 |
- |
+
+ | 898 |
+ ! |
- #' @export
+ all_ggplot2_args <- teal.widgets::resolve_ggplot2_args(
|
-
- | 63 |
- |
+
+ | 899 |
+ ! |
- #'
+ user_plot = ggplot2_args[["Eigenvector plot"]],
|
-
- | 64 |
- |
+
+ | 900 |
+ ! |
- tm_front_page <- function(label = "Front page",
+ user_default = ggplot2_args$default,
|
-
- | 65 |
- |
+
+ | 901 |
+ ! |
- header_text = character(0),
+ module_plot = dev_ggplot2_args
|
- | 66 |
+ 902 |
|
- tables = list(),
+ )
|
- | 67 |
+ 903 |
|
- additional_tags = tagList(),
+
|
-
- | 68 |
- |
+
+ | 904 |
+ ! |
- footnotes = character(0),
+ parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(
|
-
- | 69 |
- |
+
+ | 905 |
+ ! |
- show_metadata = FALSE) {
+ all_ggplot2_args,
|
- | 70 |
+ 906 |
! |
- message("Initializing tm_front_page")
+ ggtheme = ggtheme
|
- | 71 |
+ 907 |
|
-
+ )
|
- | 72 |
+ 908 |
|
- # Start of assertions
+
|
- | 73 |
+ 909 |
! |
- checkmate::assert_string(label)
+ ggplot_exprs <- c(
|
- | 74 |
+ 910 |
! |
- checkmate::assert_character(header_text, min.len = 0, any.missing = FALSE)
+ list(
|
- | 75 |
+ 911 |
! |
- checkmate::assert_list(tables, types = "data.frame", names = "named", any.missing = FALSE)
+ quote(ggplot(pca_rot)),
|
- | 76 |
+ 912 |
! |
- checkmate::assert_multi_class(additional_tags, classes = c("shiny.tag.list", "html"))
+ substitute(
|
- | 77 |
+ 913 |
! |
- checkmate::assert_character(footnotes, min.len = 0, any.missing = FALSE)
+ geom_bar(
|
- | 78 |
+ 914 |
! |
- checkmate::assert_flag(show_metadata)
+ aes_string(x = "Variable", y = pc),
|
-
- | 79 |
- |
+
+ | 915 |
+ ! |
- # End of assertions
+ stat = "identity",
|
-
- | 80 |
- |
+
+ | 916 |
+ ! |
-
+ color = "black",
+ |
+
+
+ | 917 |
+ ! |
+
+ fill = c(getOption("ggplot2.discrete.colour"), "lightblue")[1]
|
- | 81 |
+ 918 |
|
- # Make UI args
+ ),
|
- | 82 |
+ 919 |
! |
- args <- as.list(environment())
+ env = list(pc = pc)
|
- | 83 |
+ 920 |
|
-
+ ),
|
- | 84 |
+ 921 |
! |
- ans <- module(
+ substitute(
|
- | 85 |
+ 922 |
! |
- label = label,
+ geom_text(
|
- | 86 |
+ 923 |
! |
- server = srv_front_page,
+ aes(
|
- | 87 |
+ 924 |
! |
- ui = ui_front_page,
+ x = Variable,
|
- | 88 |
+ 925 |
! |
- ui_args = args,
+ y = pc_name,
|
- | 89 |
+ 926 |
! |
- server_args = list(tables = tables, show_metadata = show_metadata),
+ label = round(pc_name, 3),
|
- | 90 |
+ 927 |
! |
- datanames = if (show_metadata) "all" else NULL
+ vjust = ifelse(pc_name > 0, -0.5, 1.3)
|
- | 91 |
+ 928 |
|
- )
+ )
|
-
- | 92 |
- ! |
+
+ | 929 |
+ |
- attr(ans, "teal_bookmarkable") <- TRUE
+ ),
|
- | 93 |
+ 930 |
! |
- ans
+ env = list(pc_name = as.name(pc))
|
- | 94 |
+ 931 |
|
- }
+ )
|
- | 95 |
+ 932 |
|
-
+ ),
|
-
- | 96 |
- |
+
+ | 933 |
+ ! |
- # UI function for the front page module
+ parsed_ggplot2_args$labs,
|
-
- | 97 |
- |
+
+ | 934 |
+ ! |
- ui_front_page <- function(id, ...) {
+ parsed_ggplot2_args$ggtheme,
|
- | 98 |
+ 935 |
! |
- args <- list(...)
+ parsed_ggplot2_args$theme
|
-
- | 99 |
- ! |
+
+ | 936 |
+ |
- ns <- NS(id)
+ )
|
- | 100 |
+ 937 |
|
|
- | 101 |
+ 938 |
! |
- tagList(
+ teal.code::eval_code(
|
- | 102 |
+ 939 |
! |
- include_css_files("custom"),
+ base_q,
|
- | 103 |
+ 940 |
! |
- tags$div(
+ substitute(
|
- | 104 |
+ 941 |
! |
- id = "front_page_content",
+ expr = {
|
- | 105 |
+ 942 |
! |
- class = "ml-8",
+ pca_rot <- pca$rotation[, pc, drop = FALSE] %>%
|
- | 106 |
+ 943 |
! |
- tags$div(
+ dplyr::as_tibble(rownames = "Variable")
|
-
- | 107 |
- ! |
+
+ | 944 |
+ |
- id = "front_page_headers",
+
|
- | 108 |
+ 945 |
! |
- get_header_tags(args$header_text)
+ g <- plot_call
|
- | 109 |
+ 946 |
|
- ),
+
|
- | 110 |
+ 947 |
! |
- tags$div(
+ print(g)
+ |
+
+
+ | 948 |
+ |
+
+ },
|
- | 111 |
+ 949 |
! |
- id = "front_page_tables",
+ env = list(
|
- | 112 |
+ 950 |
! |
- class = "ml-4",
+ pc = pc,
|
- | 113 |
+ 951 |
! |
- get_table_tags(args$tables, ns)
+ plot_call = Reduce(function(x, y) call("+", x, y), ggplot_exprs)
|
- | 114 |
+ 952 |
|
- ),
+ )
|
-
- | 115 |
- ! |
+
+ | 953 |
+ |
- tags$div(
+ )
|
-
- | 116 |
- ! |
+
+ | 954 |
+ |
- id = "front_page_custom_html",
+ )
|
-
- | 117 |
- ! |
+
+ | 955 |
+ |
- class = "my-4",
+ }
|
-
- | 118 |
- ! |
+
+ | 956 |
+ |
- args$additional_tags
+
|
- | 119 |
+ 957 |
|
- ),
+ # plot final ----
|
- | 120 |
+ 958 |
! |
- if (args$show_metadata) {
+ output_q <- reactive({
|
- | 121 |
+ 959 |
! |
- tags$div(
+ req(computation())
|
- | 122 |
+ 960 |
! |
- id = "front_page_metabutton",
+ teal::validate_inputs(iv_r())
|
- | 123 |
+ 961 |
! |
- class = "m-4",
+ teal::validate_inputs(iv_extra, header = "Plot settings are required")
+ |
+
+
+ | 962 |
+ |
+
+
|
- | 124 |
+ 963 |
! |
- actionButton(ns("metadata_button"), "Show metadata")
+ switch(input$plot_type,
|
-
- | 125 |
- |
+
+ | 964 |
+ ! |
- )
+ "Elbow plot" = plot_elbow(computation()),
|
-
- | 126 |
- |
+
+ | 965 |
+ ! |
- },
+ "Circle plot" = plot_circle(computation()),
|
- | 127 |
+ 966 |
! |
- tags$footer(
+ "Biplot" = plot_biplot(computation()),
|
- | 128 |
+ 967 |
! |
- class = ".small",
+ "Eigenvector plot" = plot_pc_var(computation()),
|
- | 129 |
+ 968 |
! |
- get_footer_tags(args$footnotes)
+ stop("Unknown plot")
|
- | 130 |
+ 969 |
|
)
|
- | 131 |
+ 970 |
|
- )
+ })
|
- | 132 |
+ 971 |
|
- )
+
|
-
- | 133 |
- |
+
+ | 972 |
+ ! |
- }
+ plot_r <- reactive({
|
-
- | 134 |
- |
+
+ | 973 |
+ ! |
-
+ output_q()[["g"]]
|
- | 135 |
+ 974 |
|
- # Server function for the front page module
+ })
|
- | 136 |
+ 975 |
|
- srv_front_page <- function(id, data, tables, show_metadata) {
+
|
- | 137 |
+ 976 |
! |
- checkmate::assert_class(data, "reactive")
+ pws <- teal.widgets::plot_with_settings_srv(
|
- | 138 |
+ 977 |
! |
- checkmate::assert_class(isolate(data()), "teal_data")
+ id = "pca_plot",
|
- | 139 |
+ 978 |
! |
- moduleServer(id, function(input, output, session) {
+ plot_r = plot_r,
|
- | 140 |
+ 979 |
! |
- teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general")
+ height = plot_height,
|
-
- | 141 |
- |
+
+ | 980 |
+ ! |
-
+ width = plot_width,
|
- | 142 |
+ 981 |
! |
- ns <- session$ns
+ graph_align = "center"
|
- | 143 |
+ 982 |
|
-
+ )
|
-
- | 144 |
- ! |
+
+ | 983 |
+ |
- setBookmarkExclude("metadata_button")
+
|
- | 145 |
+ 984 |
|
-
+ # tables ----
|
- | 146 |
+ 985 |
! |
- lapply(seq_along(tables), function(idx) {
+ output$tbl_importance <- renderTable(
|
- | 147 |
+ 986 |
! |
- output[[paste0("table_", idx)]] <- renderTable(
+ expr = {
|
- | 148 |
+ 987 |
! |
- tables[[idx]],
+ req("importance" %in% input$tables_display, computation())
|
- | 149 |
+ 988 |
! |
- bordered = TRUE,
+ computation()[["tbl_importance"]]
+ |
+
+
+ | 989 |
+ |
+
+ },
|
- | 150 |
+ 990 |
! |
- caption = names(tables)[idx],
+ bordered = TRUE,
|
- | 151 |
+ 991 |
! |
- caption.placement = "top"
+ align = "c",
|
-
- | 152 |
- |
+
+ | 992 |
+ ! |
- )
+ digits = 3
|
- | 153 |
+ 993 |
|
- })
+ )
|
- | 154 |
+ 994 |
|
|
- | 155 |
- ! |
-
- if (show_metadata) {
- |
-
-
- | 156 |
+ 995 |
! |
- observeEvent(
+ output$tbl_importance_ui <- renderUI({
|
- | 157 |
+ 996 |
! |
- input$metadata_button, showModal(
+ req("importance" %in% input$tables_display)
|
- | 158 |
+ 997 |
! |
- modalDialog(
+ tags$div(
|
- | 159 |
+ 998 |
! |
- title = "Metadata",
+ align = "center",
|
- | 160 |
+ 999 |
! |
- dataTableOutput(ns("metadata_table")),
+ tags$h4("Principal components importance"),
|
- | 161 |
+ 1000 |
! |
- size = "l",
+ tableOutput(session$ns("tbl_importance")),
|
- | 162 |
+ 1001 |
! |
- easyClose = TRUE
+ tags$hr()
|
- | 163 |
+ 1002 |
|
- )
+ )
|
- | 164 |
+ 1003 |
|
- )
+ })
|
- | 165 |
+ 1004 |
|
- )
+
|
-
- | 166 |
- |
+
+ | 1005 |
+ ! |
-
+ output$tbl_eigenvector <- renderTable(
|
- | 167 |
+ 1006 |
! |
- metadata_data_frame <- reactive({
+ expr = {
|
- | 168 |
+ 1007 |
! |
- datanames <- teal.data::datanames(data())
+ req("eigenvector" %in% input$tables_display, req(computation()))
|
- | 169 |
+ 1008 |
! |
- convert_metadata_to_dataframe(
+ computation()[["tbl_eigenvector"]]
+ |
+
+
+ | 1009 |
+ |
+
+ },
|
- | 170 |
+ 1010 |
! |
- lapply(datanames, function(dataname) attr(data()[[dataname]], "metadata")),
+ bordered = TRUE,
|
- | 171 |
+ 1011 |
! |
- datanames
+ align = "c",
|
-
- | 172 |
- |
+
+ | 1012 |
+ ! |
- )
+ digits = 3
|
- | 173 |
+ 1013 |
|
- })
+ )
|
- | 174 |
+ 1014 |
|
|
- | 175 |
+ 1015 |
! |
- output$metadata_table <- renderDataTable({
+ output$tbl_eigenvector_ui <- renderUI({
|
- | 176 |
+ 1016 |
! |
- validate(need(nrow(metadata_data_frame()) > 0, "The data has no associated metadata"))
+ req("eigenvector" %in% input$tables_display)
|
- | 177 |
+ 1017 |
! |
- metadata_data_frame()
+ tags$div(
|
-
- | 178 |
- |
+
+ | 1018 |
+ ! |
- })
+ align = "center",
|
-
- | 179 |
- |
+
+ | 1019 |
+ ! |
- }
+ tags$h4("Eigenvectors"),
|
-
- | 180 |
- |
+
+ | 1020 |
+ ! |
- })
+ tableOutput(session$ns("tbl_eigenvector")),
|
-
- | 181 |
- |
+
+ | 1021 |
+ ! |
- }
+ tags$hr()
|
- | 182 |
+ 1022 |
|
-
+ )
|
- | 183 |
+ 1023 |
|
- ## utils functions
+ })
|
- | 184 |
+ 1024 |
|
|
-
- | 185 |
- |
+
+ | 1025 |
+ ! |
- get_header_tags <- function(header_text) {
+ output$all_plots <- renderUI({
|
- | 186 |
+ 1026 |
! |
- if (length(header_text) == 0) {
+ teal::validate_inputs(iv_r())
|
- | 187 |
+ 1027 |
! |
- return(list())
+ teal::validate_inputs(iv_extra, header = "Plot settings are required")
|
- | 188 |
+ 1028 |
|
- }
+
|
-
- | 189 |
- |
+
+ | 1029 |
+ ! |
-
+ validation()
|
- | 190 |
+ 1030 |
! |
- get_single_header_tags <- function(header_text, p_text, header_tag = tags$h4) {
+ tags$div(
|
- | 191 |
+ 1031 |
! |
- tagList(
+ class = "overflow-scroll",
|
- | 192 |
+ 1032 |
! |
- tags$div(
+ uiOutput(session$ns("tbl_importance_ui")),
|
- | 193 |
+ 1033 |
! |
- if (!is.null(header_text) && nchar(header_text) > 0) header_tag(header_text),
+ uiOutput(session$ns("tbl_eigenvector_ui")),
|
- | 194 |
+ 1034 |
! |
- tags$p(p_text)
+ teal.widgets::plot_with_settings_ui(id = session$ns("pca_plot"))
|
- | 195 |
+ 1035 |
|
)
|
- | 196 |
+ 1036 |
|
- )
+ })
|
- | 197 |
+ 1037 |
|
- }
+
|
-
- | 198 |
- |
+
+ | 1038 |
+ ! |
-
+ teal.widgets::verbatim_popup_srv(
|
- | 199 |
+ 1039 |
! |
- header_tags <- get_single_header_tags(names(header_text[1]), header_text[1], header_tag = tags$h3)
+ id = "rcode",
|
- | 200 |
+ 1040 |
! |
- c(header_tags, mapply(get_single_header_tags, utils::tail(names(header_text), -1), utils::tail(header_text, -1)))
+ verbatim_content = reactive(teal.code::get_code(output_q())),
+ |
+
+
+ | 1041 |
+ ! |
+
+ title = "R Code for PCA"
|
- | 201 |
+ 1042 |
|
- }
+ )
|
- | 202 |
+ 1043 |
|
|
- | 203 |
+ 1044 |
|
- get_table_tags <- function(tables, ns) {
+ ### REPORTER
|
- | 204 |
+ 1045 |
! |
- if (length(tables) == 0) {
+ if (with_reporter) {
|
- | 205 |
+ 1046 |
! |
- return(list())
- |
-
-
- | 206 |
- |
-
- }
+ card_fun <- function(comment, label) {
|
- | 207 |
+ 1047 |
! |
- table_tags <- c(lapply(seq_along(tables), function(idx) {
+ card <- teal::report_card_template(
|
- | 208 |
+ 1048 |
! |
- list(
+ title = "Principal Component Analysis Plot",
|
- | 209 |
+ 1049 |
! |
- tableOutput(ns(paste0("table_", idx)))
- |
-
-
- | 210 |
- |
-
- )
- |
-
-
- | 211 |
- |
-
- }))
+ label = label,
|
- | 212 |
+ 1050 |
! |
- return(table_tags)
- |
-
-
- | 213 |
- |
-
- }
+ with_filter = with_filter,
|
-
- | 214 |
- |
+
+ | 1051 |
+ ! |
-
+ filter_panel_api = filter_panel_api
|
- | 215 |
+ 1052 |
|
- get_footer_tags <- function(footnotes) {
+ )
|
- | 216 |
+ 1053 |
! |
- if (length(footnotes) == 0) {
+ card$append_text("Principal Components Table", "header3")
|
- | 217 |
+ 1054 |
! |
- return(list())
- |
-
-
- | 218 |
- |
-
- }
+ card$append_table(computation()[["tbl_importance"]])
|
- | 219 |
+ 1055 |
! |
- bold_texts <- if (is.null(names(footnotes))) rep("", length(footnotes)) else names(footnotes)
+ card$append_text("Eigenvectors Table", "header3")
|
- | 220 |
+ 1056 |
! |
- footnote_tags <- mapply(function(bold_text, value) {
+ card$append_table(computation()[["tbl_eigenvector"]])
|
- | 221 |
+ 1057 |
! |
- list(
+ card$append_text("Plot", "header3")
|
- | 222 |
+ 1058 |
! |
- tags$div(
+ card$append_plot(plot_r(), dim = pws$dim())
|
- | 223 |
+ 1059 |
! |
- tags$b(bold_text),
+ if (!comment == "") {
|
- | 224 |
+ 1060 |
! |
- value,
+ card$append_text("Comment", "header3")
|
- | 225 |
+ 1061 |
! |
- tags$br()
+ card$append_text(comment)
|
- | 226 |
+ 1062 |
|
- )
+ }
|
-
- | 227 |
- |
+
+ | 1063 |
+ ! |
- )
+ card$append_src(teal.code::get_code(output_q()))
|
- | 228 |
+ 1064 |
! |
- }, bold_text = bold_texts, value = footnotes)
+ card
|
- | 229 |
+ 1065 |
|
- }
+ }
|
-
- | 230 |
- |
+
+ | 1066 |
+ ! |
-
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
- | 231 |
+ 1067 |
|
- # take a list of metadata, one item per dataset (raw_metadata each element from datasets$get_metadata())
+ }
|
- | 232 |
+ 1068 |
|
- # and the corresponding datanames and output a data.frame with columns {Dataset, Name, Value}.
+ ###
|
- | 233 |
+ 1069 |
|
- # which are, the Dataset the metadata came from, the metadata's name and value
+ })
|
- | 234 |
+ 1070 |
|
- convert_metadata_to_dataframe <- function(raw_metadata, datanames) {
- |
-
-
- | 235 |
- 4x |
-
- output <- mapply(function(metadata, dataname) {
- |
-
-
- | 236 |
- 6x |
-
- if (is.null(metadata)) {
- |
-
-
- | 237 |
- 2x |
-
- return(data.frame(Dataset = character(0), Name = character(0), Value = character(0)))
+ }
|
+
+
+
+
+
+
- | 238 |
+ 1 |
|
- }
+ .onLoad <- function(libname, pkgname) {
|
-
- | 239 |
- 4x |
+
+ | 2 |
+ ! |
- return(data.frame(
+ teal.logger::register_logger(namespace = "teal.modules.general")
|
-
- | 240 |
- 4x |
+
+ | 3 |
+ ! |
- Dataset = dataname,
+ teal.logger::register_handlers("teal.modules.general")
|
-
- | 241 |
- 4x |
+
+ | 4 |
+ |
- Name = names(metadata),
+ }
|
-
- | 242 |
- 4x |
+
+ | 5 |
+ |
- Value = unname(unlist(lapply(metadata, as.character)))
+
|
- | 243 |
+ 6 |
|
- ))
+ ### global variables
|
-
- | 244 |
- 4x |
+
+ | 7 |
+ |
- }, raw_metadata, datanames, SIMPLIFY = FALSE)
+ ggplot_themes <- c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void")
|
-
- | 245 |
- 4x |
+
+ | 8 |
+ |
- do.call(rbind, output)
+
|
- | 246 |
+ 9 |
|
- }
+ interactive <- NULL
|
|