├── .dockerignore ├── .gitignore ├── CHANGELOG.md ├── DESCRIPTION ├── Dockerfile ├── LICENSE ├── README.md ├── Shiny-GEM.Rproj ├── app.R ├── data └── rds │ ├── border.RDS │ ├── college.RDS │ ├── ign.RDS │ └── starbucks.RDS ├── install-requirements.R ├── server ├── helpers.R └── server.R └── ui ├── body.R ├── body ├── group_options.R ├── grouped_dataset.R ├── load_and_transform.R ├── plot_options.R ├── plots.R ├── selected_dataset.R └── source_dataset.R ├── date_formats.R ├── header.R └── sidebar.R /.dockerignore: -------------------------------------------------------------------------------- 1 | node_modules 2 | npm-debug.log 3 | Dockerfile* 4 | docker-compose* 5 | .dockerignore 6 | .git 7 | .gitignore 8 | .env 9 | */bin 10 | */obj 11 | README.md 12 | LICENSE 13 | .vscode -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | rsconnect 3 | csv/ -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | CHANGELOG: 2 | ``` 3 | 2019-04-28 - restructured content and Dockerized. 4 | 2018-02-05 - initial release 5 | ``` 6 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Title: Shiny GEM 2 | Author: Donald Mellenbruch 3 | DisplayMode: Normal 4 | Type: Shiny -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM r-base:3.5.2 2 | 3 | # system libraries of general use 4 | RUN apt-get update && apt-get install -y \ 5 | libcurl4-gnutls-dev \ 6 | libcairo2-dev \ 7 | libxt-dev \ 8 | libssl-dev \ 9 | libssh2-1-dev \ 10 | libxml2-dev 11 | 12 | COPY . /app 13 | RUN Rscript /app/install-requirements.R 14 | 15 | EXPOSE 3838 16 | 17 | CMD ["R", "-e", "shiny::runApp('/app', port=3838, host = '0.0.0.0')"] 18 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2010-2018 Donald Mellenbruch 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21 | THE SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | # Shiny GEM 3 | 4 | Shiny GEM is a data analysis app written in R Shiny. 5 | 6 | - [Documentation](#documentation) 7 | - [Ways to Run](#ways-to-run) 8 | - [ShinyApps.io](#shinyappsio) 9 | - [Docker](#docker) 10 | - [From Source](#from-source) 11 | - [ShinyStudio](#shinystudio) 12 | 13 | 14 | ## Documentation 15 | 16 | https://www.donaldmellenbruch.com/doc/shinygem 17 | 18 | > Simplified documentation is on the agenda. 19 | 20 | ## Ways to Run 21 | 22 | Shiny GEM is available on ShinyApps.io, DockerHub, GitHub, and from within ShinyStudio. Take your pick! 23 | 24 | ### ShinyApps.io 25 | 26 | The easiest way to demo the app is from [ShinyApps.io](https://dmellenbruch.shinyapps.io/Shiny_GEM/). 27 | 28 | https://dmellenbruch.shinyapps.io/Shiny_GEM/ 29 | 30 | For increased performance and security, consider another method below. 31 | 32 | ### Docker 33 | 34 | * Download image from DockerHub: 35 | 36 | ```bash 37 | docker pull dm3ll3n/shiny-gem 38 | ``` 39 | 40 | * Run locally in a background container: 41 | 42 | ```bash 43 | docker run -d --restart unless-stopped -p 127.0.0.1:3838:3838 dm3ll3n/shiny-gem 44 | ``` 45 | 46 | Shiny GEM will now be available in a browser at `http://localhost:3838`. 47 | 48 | ### From Source 49 | 50 | Clone the source code, install dependencies, and launch locally. 51 | 52 | ```bash 53 | git clone https://github.com/dm3ll3n/Shiny-GEM.git 54 | 55 | cd Shiny-GEM 56 | 57 | Rscript "install-requirements.R" 58 | 59 | R -e "shiny::runApp(host='127.0.0.1', port=3838)" 60 | ``` 61 | 62 | Shiny GEM will now be available in a browser at `http://localhost:3838`. 63 | 64 | ### ShinyStudio 65 | 66 | Shiny GEM is included as an example app in the [ShinyStudio](https://github.com/dm3ll3n/ShinyStudio) Docker stack. First, follow the [setup instructions](https://github.com/dm3ll3n/ShinyStudio#how-to-get-it) for ShinyStudio. Afterward: 67 | 68 | * Navigate to ShinyStudio at `http://localhost:8080`. 69 | * Open RStudio. 70 | * Use RStudio's file browser to open `shiny-examples/Shiny-GEM/app.R`. 71 | * Run the app within RStudio. 72 | 73 | Optionally, copy the directory `shiny-examples/Shiny-GEM` to `__ShinyStudio__/_apps` in order to serve Shiny GEM from the "Apps & Reports" page. 74 | -------------------------------------------------------------------------------- /Shiny-GEM.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | -------------------------------------------------------------------------------- /app.R: -------------------------------------------------------------------------------- 1 | # 2 | # This is the user-interface definition of a Shiny web application. You can 3 | # run the application by clicking 'Run App' above. 4 | # 5 | # Find out more about building applications with Shiny here: 6 | # 7 | # http://shiny.rstudio.com/ 8 | # 9 | 10 | library(shiny) 11 | library(shinydashboard) 12 | library(shinycssloaders) 13 | library(DT) 14 | library(rlang) 15 | library(data.table) 16 | library(readxl) 17 | library(readr) 18 | library(magrittr) 19 | library(ggplot2) 20 | library(scales) 21 | library(ggthemes) 22 | library(ggiraph) 23 | library(grid) 24 | library(gridExtra) 25 | library(GGally) 26 | library(lubridate) 27 | library(anytime) 28 | 29 | source('ui/date_formats.R', local = TRUE) 30 | 31 | options(spinner.type = 6, spinner.color = '#3c8dbc') 32 | 33 | theme_pattern <- 34 | '^theme\\_(?!get|update|void|set|linedraw|replace|wsj|map|solid|fivethirtyeight)' 35 | 36 | ui <- dashboardPage( 37 | header = source('ui/header.R', local = TRUE)$value, 38 | sidebar = source('ui/sidebar.R', local = TRUE)$value, 39 | body = source('ui/body.R', local = TRUE)$value, 40 | skin = 'blue' 41 | ) 42 | 43 | 44 | server <- source('server/server.R', local=TRUE)$value 45 | 46 | shinyApp(ui, server) 47 | -------------------------------------------------------------------------------- /data/rds/border.RDS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fresh2dev/shinyGEM/0eb6162d16254bafe18b83ac414785b135d57eca/data/rds/border.RDS -------------------------------------------------------------------------------- /data/rds/college.RDS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fresh2dev/shinyGEM/0eb6162d16254bafe18b83ac414785b135d57eca/data/rds/college.RDS -------------------------------------------------------------------------------- /data/rds/ign.RDS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fresh2dev/shinyGEM/0eb6162d16254bafe18b83ac414785b135d57eca/data/rds/ign.RDS -------------------------------------------------------------------------------- /data/rds/starbucks.RDS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fresh2dev/shinyGEM/0eb6162d16254bafe18b83ac414785b135d57eca/data/rds/starbucks.RDS -------------------------------------------------------------------------------- /install-requirements.R: -------------------------------------------------------------------------------- 1 | # https://stackoverflow.com/a/4090208 2 | 3 | list.of.packages <- c('shiny', 4 | 'shinydashboard', 5 | 'shinycssloaders', 6 | 'DT', 7 | 'rlang', 8 | 'data.table', 9 | 'readxl', 10 | 'readr', 11 | 'magrittr', 12 | 'scales', 13 | 'ggplot2', 14 | 'ggthemes', 15 | 'ggrepel', 16 | 'gridExtra', 17 | 'GGally', 18 | 'lubridate', 19 | 'anytime', 20 | 'devtools', 21 | 'ggiraph') 22 | 23 | new.packages <- list.of.packages[!(list.of.packages %in% installed.packages()[,"Package"])] 24 | 25 | if (length(new.packages) > 0) { 26 | install.packages(new.packages) 27 | } 28 | 29 | 30 | -------------------------------------------------------------------------------- /server/helpers.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | coalesce <- function(input, ifnull) { 4 | if (is.null(input)) { 5 | return(ifnull) 6 | } else { 7 | return(input) 8 | } 9 | } 10 | 11 | stringsAsFactors <- function (dt) { 12 | na_cols <- dt[, sapply(.SD, anyNA)] 13 | for (c in colnames(dt)[na_cols]) { 14 | if (is.POSIXct(dt[[c]])) { 15 | dt[is.na(get(c)), (c) := as.POSIXct('0001-01-01 00:00:00', tz = 'UTC')] 16 | } else if (is.Date(dt[[c]])) { 17 | dt[is.na(get(c)), (c) := as.Date('0001-01-01')] 18 | } else { 19 | if (!is.character(dt[[c]])) { 20 | dt[, (c) := as.character(get(c))] 21 | } 22 | dt[is.na(get(c)), (c) := 'NULL'] 23 | } 24 | } 25 | 26 | dt <- dt[, lapply(.SD, function(x) { 27 | if (is.logical(x)) { 28 | factor(x) 29 | } else { 30 | new_x <- if (!is.factor(x)) { 31 | x 32 | } else { 33 | as.character(x) 34 | } 35 | 36 | if (!is.character(new_x)) { 37 | new_x 38 | } else if (all(grepl(new_x, pattern = '^\\d+$'))) { 39 | as.numeric(new_x) 40 | } else if (all(grepl(new_x, pattern = '^\\d+.*%.*$'))) { 41 | as.numeric(sub( 42 | new_x, 43 | pattern = '%', 44 | replacement = '', 45 | fixed = T 46 | )) / 100 47 | } else { 48 | factor(gsub( 49 | new_x, 50 | pattern = "'", 51 | replacement = "`", 52 | fixed = T 53 | )) 54 | } 55 | } 56 | })] 57 | 58 | return(dt) 59 | } 60 | 61 | 62 | # https://rdrr.io/cran/kimisc/src/R/cut.R 63 | cut_format <- 64 | function(x, 65 | breaks, 66 | include.lowest = FALSE, 67 | right = TRUE, 68 | ordered_result = FALSE, 69 | ..., 70 | format_fun = format, 71 | sep = ", ", 72 | paren = c(')', '[', '(', ']')) { 73 | if (length(breaks) < 2L) { 74 | stop("Please specify breaks as a numeric vector of length >= 2", 75 | call. = FALSE) 76 | } 77 | 78 | if (right) { 79 | ob <- c(include.lowest, rep(FALSE, length(breaks) - 2L)) 80 | cb <- rep(TRUE, length(breaks) - 1L) 81 | } else { 82 | ob <- rep(TRUE, length(breaks) - 1L) 83 | cb <- c(rep(FALSE, length(breaks) - 2L), include.lowest) 84 | } 85 | 86 | ob <- ifelse(ob, paren[[2L]], paren[[1L]]) 87 | cb <- ifelse(cb, paren[[4L]], paren[[3L]]) 88 | 89 | formatted_breaks <- format_fun(breaks) 90 | labels <- 91 | paste0(ob, 92 | head(formatted_breaks,-1L), 93 | sep, 94 | tail(formatted_breaks,-1L), 95 | cb) 96 | cut.default( 97 | x = x, 98 | breaks = breaks, 99 | labels = labels, 100 | include.lowest = include.lowest, 101 | right = right, 102 | ordered_result = ordered_result, 103 | ... 104 | ) 105 | } 106 | 107 | # https://stackoverflow.com/a/8197703 108 | gg_color_hue <- function(n) { 109 | hues = seq(15, 375, length = n + 1) 110 | hcl(h = hues, l = 65, c = 100)[1:n] 111 | } 112 | -------------------------------------------------------------------------------- /server/server.R: -------------------------------------------------------------------------------- 1 | 2 | source('server/helpers.R', local=TRUE) 3 | 4 | function(input, output, session) { 5 | 6 | my <- reactiveValues(dataset_original=NULL, dataset=NULL, dataset_grouped=NULL, theme=NULL) 7 | 8 | c <- reactiveValues(date=NULL, group=NULL, feature=NULL, value=NULL) 9 | 10 | plot_title_dbnce <- reactive({ input$title }) %>% debounce(millis=3000) 11 | plot_subtitle_dbnce <- reactive({ input$subtitle }) %>% debounce(millis=3000) 12 | plot_caption_dbnce <- reactive({ input$caption }) %>% debounce(millis=3000) 13 | plot_xlab_dbnce <- reactive({ input$xlab }) %>% debounce(millis=3000) 14 | plot_ylab_dbnce <- reactive({ input$ylab }) %>% debounce(millis=3000) 15 | plot_height_dbnce <- reactive({ input$plotHeight }) %>% debounce(millis=3000) 16 | plot_width_dbnce <- reactive({ input$plotWidth }) %>% debounce(millis=3000) 17 | decimal_precision_dbnce <- reactive({ input$decimalPrecision }) %>% debounce(millis=3000) 18 | n_x_breaks_dbnce <- reactive({ input$n_x_breaks }) %>% debounce(millis=3000) 19 | n_y_breaks_dbnce <- reactive({ input$n_y_breaks }) %>% debounce(millis=3000) 20 | hist_bins_dbnce <- reactive({ input$bins }) %>% debounce(millis=3000) 21 | 22 | observe({ 23 | 24 | req(input$presetDataset) 25 | 26 | # print('Entered origin block') 27 | 28 | dataset <- NULL 29 | if (input$presetDataset == 'Game Ratings') { 30 | dataset <- readRDS('./data/rds/ign.RDS') 31 | } else if (input$presetDataset == 'Border Patrol Apprehensions') { 32 | dataset <- readRDS('./data/rds/border.RDS') 33 | } else if (input$presetDataset == 'College Scorecards') { 34 | dataset <- readRDS('./data/rds/college.RDS') %>% stringsAsFactors() 35 | } else if (input$presetDataset == 'Starbucks Nutrition') { 36 | dataset <- readRDS('./data/rds/starbucks.RDS') 37 | } 38 | 39 | my$dataset_original <- dataset 40 | # my$dataset <- dataset 41 | 42 | updateTextInput(session, 'title', value=input$presetDataset) 43 | }) 44 | 45 | observe(priority = 10, { 46 | req(my$dataset_original) 47 | 48 | # also fire when 'startOver', 'original_as_source' is clicked. 49 | input$startOver 50 | input$original_as_source 51 | 52 | dataset <- copy(my$dataset_original) 53 | 54 | isolate({ 55 | 56 | dataset[, '#id' := 1:.N] 57 | n_col <- ncol(dataset) 58 | setcolorder(dataset, neworder=c(n_col, 1:(n_col-1))) 59 | setkeyv(dataset, cols = '#id') 60 | 61 | for (col in c('date', 'group', 'feature', 'value')) { 62 | if (!is.null(c[[col]]) && !(c[[col]] %in% colnames(dataset))) { 63 | c[[col]] <- NULL 64 | } 65 | } 66 | 67 | my$dataset <- dataset 68 | }) 69 | }) 70 | 71 | observeEvent(input$userFile, { 72 | 73 | file_ext <- toupper(regmatches(input$userFile$name, regexpr(input$userFile$name, pattern='\\.(.+)$'))) 74 | 75 | ext_i <- match(file_ext, c('.CSV', '.XLS', '.XLSX', '.RDS')) 76 | 77 | if (!is.na(ext_i)) { 78 | if (ext_i > 3) { 79 | my$dataset_original <- readRDS(input$userFile$datapath) %>% as.data.table() # %>% stringsAsFactors() 80 | } else { 81 | read_FUN <- if (ext_i == 1) { read_csv } else { read_excel } 82 | 83 | my$dataset_original <- suppressWarnings(read_FUN(input$userFile$datapath, col_names = TRUE, 84 | trim_ws = FALSE, guess_max = 1000, na=c('', '-', 'NA', 'NULL'))) %>% 85 | as.data.table() %>% stringsAsFactors() 86 | 87 | } 88 | } 89 | 90 | updateTextInput(session, 'title', 91 | value=tools::toTitleCase(sub(tolower(input$userFile$name), pattern = tolower(file_ext), replacement='', fixed=T))) 92 | }) 93 | 94 | observeEvent(input$meltData, { 95 | 96 | # print('Entered melt block') 97 | 98 | if (length(input$userFileIdCols) > 0) { 99 | 100 | var_name <- 'feature' 101 | if (nchar(input$meltedKeyName) > 0) { var_name <- input$meltedKeyName } 102 | 103 | value_name <- 'value' 104 | if (nchar(input$meltedValueName) > 0) { value_name <- input$meltedValueName } 105 | 106 | dataset <- my$dataset 107 | 108 | id_vars <- input$userFileIdCols 109 | 110 | num_cols_TF <- sapply(dataset, is.numeric) 111 | num_cols <- colnames(dataset)[num_cols_TF] %>% .[!(. %in% id_vars)] 112 | char_cols <- colnames(dataset) %>% .[!(. %in% id_vars) & !(. %in% num_cols)] 113 | 114 | count_char_cols <- FALSE 115 | 116 | if (length(char_cols) > 0) { count_char_cols <- TRUE } 117 | 118 | if (count_char_cols && length(num_cols) > 0 && 119 | nrow(dataset[, id_vars, with=F] %>% unique()) < nrow(dataset)) { 120 | output$sourceDatasetMessage <- renderText({ 121 | 'Non-distinct ID columns specified; summed numeric values.' 122 | }) 123 | } else { 124 | output$sourceDatasetMessage <- renderText({''}) 125 | } 126 | 127 | if (count_char_cols) { 128 | dataset <- dataset[, c(list('# group obs.' = .N), lapply(.SD, function(x) { 129 | if (is.numeric(x)) { sum(x) } else { uniqueN(x) } 130 | })), by=id_vars] 131 | 132 | setnames(dataset, old=char_cols, new=paste('#', char_cols)) 133 | if (length(num_cols) > 0) { 134 | setnames(dataset, old=num_cols, new=paste('Total', num_cols)) 135 | } 136 | 137 | my$dataset <- dataset 138 | } else { 139 | updateSelectizeInput(session, 'userFileIdCols', selected=NA) 140 | updateTextInput(session, inputId = 'meltedKeyName', value = NA) 141 | updateTextInput(session, inputId = 'meltedValueName', value = NA) 142 | 143 | dataset <- melt(dataset, 144 | id.vars = c('#id', id_vars), 145 | variable.name = var_name, 146 | value.name = value_name, 147 | verbose = FALSE) 148 | 149 | dataset[, '#id' := 1:.N] 150 | 151 | for (col in c('date', 'group', 'feature', 'value')) { 152 | if (!is.null(c[[col]]) && !(c[[col]] %in% colnames(dataset))) { 153 | c[[col]] <- NULL 154 | } 155 | } 156 | 157 | my$dataset <- dataset 158 | } 159 | } 160 | }) 161 | 162 | observeEvent(input$combineCols, { 163 | 164 | req(input$columnsToCombine) 165 | 166 | # print('Entered combine block') 167 | 168 | dataset <- copy(my$dataset) 169 | 170 | to_combine <- input$columnsToCombine 171 | col_name <- input$combinedColName 172 | 173 | if (nchar(col_name) > 0) { 174 | new_col_names <- strsplit(col_name, split=',\\s*')[[1]] 175 | 176 | if (length(new_col_names) == length(to_combine)) { 177 | ren_cols <- duplicated(new_col_names) 178 | new_col_names[ren_cols] <- paste0(new_col_names[ren_cols], '.1') 179 | ren_cols <- new_col_names %in% colnames(dataset) 180 | new_col_names[ren_cols] <- paste0(new_col_names[ren_cols], '.1') 181 | setnames(dataset, old=input$columnsToCombine, new=new_col_names) 182 | } else { 183 | if (col_name %in% colnames(dataset)) { col_name <- paste0(col_name, '.1') } 184 | 185 | sep_char <- '' 186 | if (nchar(input$sepChar) > 0) { 187 | sep_char <- input$sepChar 188 | } 189 | 190 | dataset[[col_name]] <- dataset[, do.call(paste, c(.SD, sep=sep_char)), .SDcols=c(to_combine)] 191 | } 192 | 193 | updateSelectizeInput(session, 'columnsToCombine', selected=NA) 194 | updateTextInput(session, 'combinedColName', value = NA) 195 | updateTextInput(session, 'sepChar', value = NA) 196 | } 197 | 198 | if (!input$keepCombinedCols) { 199 | dataset[, c(input$columnsToCombine) := NULL] 200 | } 201 | 202 | for (col in c('date', 'group', 'feature', 'value')) { 203 | if (!is.null(c[[col]]) && !(c[[col]] %in% colnames(dataset))) { 204 | c[[col]] <- NULL 205 | } 206 | } 207 | 208 | my$dataset <- dataset %>% stringsAsFactors() 209 | }) 210 | 211 | observeEvent(input$separateCols, { 212 | req(input$columnToSplit) 213 | 214 | dataset <- my$dataset 215 | 216 | split_regex <- input$splitChar 217 | if (nchar(split_regex) == 0) { 218 | split_regex <- '[[:punct:]]+|[[:space:]]+' 219 | } 220 | 221 | split_cells <- strsplit(as.character(dataset[[input$columnToSplit]]), split=split_regex) 222 | 223 | if (length(split_cells) > 0) { 224 | n_cols <- max(sapply(split_cells, length)) 225 | col_names <- NULL # paste0('V', 1:n_cols) 226 | for (a in LETTERS) { 227 | col_names <- paste0(a, 1:n_cols) 228 | if (!any(col_names %in% colnames(dataset))) { 229 | break 230 | } 231 | } 232 | dataset <- copy(my$dataset) 233 | dataset[, c(col_names) := transpose(split_cells)] 234 | if (!input$keepSplitCols) { dataset[, c(input$columnToSplit) := NULL] } 235 | 236 | for (col in c('date', 'group', 'feature', 'value')) { 237 | if (!is.null(c[[col]]) && !(c[[col]] %in% colnames(dataset))) { 238 | c[[col]] <- NULL 239 | } 240 | } 241 | 242 | my$dataset <- dataset %>% stringsAsFactors() 243 | 244 | updateSelectizeInput(session, 'columnToSplit', selected=NA) 245 | updateTextInput(session, 'splitChar', value = NA) 246 | } 247 | }) 248 | 249 | cols <- reactiveValues(date=NULL, group=NULL, feature=NULL, value=NULL) 250 | 251 | observe(priority=100, { c$date <- input$date }) 252 | observe(priority=100, { c$group <- input$group }) 253 | observe(priority=100, { c$feature <- input$feature }) 254 | observe(priority=100, { c$value <- input$value }) 255 | 256 | observe(priority=50, { 257 | if (coalesce(input$date, '') != coalesce(c$date, '')) { 258 | updateSelectizeInput(session, 'date', selected = coalesce(c$date, NA)) 259 | } 260 | }) 261 | observe(priority=50, { 262 | if (coalesce(input$group, '') != coalesce(c$group, '')) { 263 | updateSelectizeInput(session, 'group', selected = coalesce(c$group, NA)) 264 | } 265 | }) 266 | observe(priority=50, { 267 | if (coalesce(input$feature, '') != coalesce(c$feature, '')) { 268 | updateSelectizeInput(session, 'feature', selected = coalesce(c$feature, NA)) 269 | } 270 | }) 271 | observe(priority=50, { 272 | if (coalesce(input$value, '') != coalesce(c$value, '')) { 273 | updateSelectizeInput(session, 'value', selected = coalesce(c$value, NA)) 274 | } 275 | }) 276 | 277 | observe({ 278 | req(my$dataset, input$dataset_rows_all) 279 | 280 | dataset <- NULL 281 | 282 | if (length(c(c$date, c$group, c$feature, c$value)) > 0) { 283 | # if (length(c(c$date, c$group, c$feature, c$value)) > 0) { 284 | if (between(length(input$dataset_rows_all), 0, nrow(my$dataset), incbounds = F)) { 285 | dataset <- my$dataset[input$dataset_rows_all, ] 286 | } else { 287 | dataset <- my$dataset 288 | } 289 | } 290 | 291 | my$dataset_filtered <- dataset 292 | }) 293 | 294 | setComboBox <- function(session, column, col_names, col_pattern) { 295 | if (is.null(c[[column]]) || !(c[[column]] %in% col_names)) { 296 | best_guess <- NA 297 | 298 | if (length(col_pattern) > 0) { best_guess <- col_names %>% .[grepl(tolower(.), pattern=col_pattern)] %>% head(1) } 299 | 300 | if (length(best_guess) > 0) { 301 | cols[[column]] <- best_guess 302 | updateSelectizeInput(session, column, choices = col_names, selected=best_guess) 303 | } 304 | else { 305 | cols[[column]] <- NULL 306 | updateSelectizeInput(session, column, choices = col_names, selected=NA) 307 | } 308 | } 309 | } 310 | 311 | observe({ 312 | req(is.null(c$date)) 313 | 314 | c$date 315 | 316 | updateSelectizeInput(session, 'dateFormat', selected = NA) 317 | updateSelectizeInput(session, 'dateTransform', selected = NA) 318 | }) 319 | 320 | observe(priority = 2, { 321 | req(my$dataset) 322 | 323 | # print('Populating column lists') 324 | 325 | col_names <- colnames(my$dataset) %>% .[. != '#id'] 326 | 327 | isolate({ 328 | updateSelectizeInput(session, 'userFileIdCols', choices = col_names, selected=input$userFileIdCols) 329 | updateSelectizeInput(session, 'columnsToCombine', choices = col_names, selected=input$columnsToCombine) 330 | updateSelectizeInput(session, 'columnToSplit', choices = col_names, selected=input$columnToSplit) 331 | 332 | setComboBox(session, 'date', col_names, col_pattern='year|stamp') 333 | 334 | if (is.null(cols$date)) { 335 | updateSelectizeInput(session, 'dateFormat', selected = NA) 336 | updateSelectizeInput(session, 'dateTransform', selected = NA) 337 | } 338 | 339 | setComboBox(session, 'group', col_names, col_pattern='group') 340 | 341 | setComboBox(session, 'feature', col_names, col_pattern='feature') 342 | 343 | num_col_names <- col_names[my$dataset[, lapply(.SD, class), .SDcols=col_names][1] %in% c('numeric', 'integer', 'double')] 344 | 345 | setComboBox(session, 'value', num_col_names, col_pattern='value') 346 | }) 347 | }) 348 | 349 | observe(priority = 1, { 350 | req(my$dataset, c$date) 351 | 352 | # print('Guessing date format.') 353 | 354 | dates <- as.character(my$dataset[[c$date]][1:100]) 355 | 356 | # http://gamon.webfactional.com/regexnumericrangegenerator/ 357 | patterns <- c('Year'='^\\d{3,4}$', 358 | 'Month'='^0*([1-9]|1[0-2])$', 359 | 'Day'='^0*([0-9]|[12][0-9]|3[01])$', 360 | 'Day of Year'='^0*([1-9]|[1-8][0-9]|9[0-9]|[12][0-9]{2}|3[0-5][0-9]|36[0-6])$', 361 | 'ymd_hms'='^\\d{4}.*\\d{1,2}.*\\d{1,2}\\s.+$', 362 | 'ymd'='^\\d{4}.*\\d{1,2}.*\\d{1,2}', 363 | 'mdy_hms'='^\\d{1,2}.*\\d{1,2}.*\\d{4}\\s.+$', 364 | 'mdy'='^\\d{1,2}.*\\d{1,2}.*\\d{4}', 365 | 'Year-Month'='^\\d{4}.*\\d{1,2}$', 366 | 'Hour:Minute'='^\\d{1,2}:\\d{2}$', 367 | 'Hour:Minute:Second'='^\\d{,2}:\\d{2}:\\d{2}$') 368 | 369 | format_match <- NULL # ' - Guess - ' 370 | 371 | for (f in names(patterns)) { 372 | if (all(grepl(dates, pattern=patterns[f]))) { 373 | format_match <- f 374 | break 375 | } 376 | } 377 | 378 | if (!is.null(format_match) && (is.null(isolate(input$dateFormat)) || isolate(input$dateFormat) != format_match)) { 379 | updateSelectizeInput(session, 'dateFormat', selected = format_match) 380 | 381 | if (is.null(isolate(input$dateTransform)) || isolate(input$dateTransform) != format_match) { 382 | updateSelectizeInput(session, 'dateTransform', selected = format_match) 383 | } 384 | } 385 | }) 386 | 387 | observe({ 388 | req(my$dataset_grouped()) 389 | 390 | if (is.null(c$value)) { 391 | updateRadioButtons(session, 'plotValues', selected = '# observations') 392 | } else { 393 | updateRadioButtons(session, 'plotValues', selected = 'values') 394 | } 395 | }) 396 | 397 | decimalPrecision <- reactive({ 398 | if (is.na(decimal_precision_dbnce())) { 399 | return(2L) 400 | } 401 | return(as.integer(decimal_precision_dbnce())) 402 | }) 403 | 404 | my$dataset_dates_parsed <- reactive({ 405 | 406 | req(my$dataset_filtered, 407 | # any(!is.null(c(cols$date, cols$group, cols$feature, cols$value))), 408 | length(c(c$date, input$dateFormat)) %in% c(0, 2)) 409 | 410 | # print('Entered dates_parsed block') 411 | 412 | dataset <- copy(my$dataset_filtered) 413 | 414 | date_col <- c$date 415 | 416 | if (is.null(date_col) || is.null(input$dateFormat)) { 417 | date_col <- NULL 418 | } else { 419 | if (input$dateFormat == ' - Guess - ') { 420 | dataset[, c(date_col) := anytime(dataset[[date_col]])] 421 | } else { 422 | date_format_str <- NULL 423 | date_format_str <- sapply(date_format_list, extract, input$dateFormat) %>% .[!is.na(.)] 424 | dataset[, c(date_col) := parse_date_time(dataset[[date_col]], orders = date_format_str)] 425 | } 426 | 427 | if (anyNA(dataset[[date_col]])) { 428 | dataset[, c(date_col) := NULL] 429 | date_col <- NULL 430 | } 431 | } 432 | 433 | # print('Entered date_filtered block') 434 | 435 | if (!is.null(date_col)) { 436 | if (sum(!is.na(input$dateRange)) == 2) { 437 | dataset <- dataset[between(get(isolate(date_col)), ymd(input$dateRange[1]), ymd(input$dateRange[2]), incbounds = T), ] 438 | } else if (!is.na(input$dateRange[1])) { 439 | dataset <- dataset[get(isolate(date_col)) >= ymd(input$dateRange[1]), ] 440 | } else if (!is.na(input$dateRange[2])) { 441 | dataset <- dataset[get(isolate(date_col)) <= ymd(input$dateRange[2]), ] 442 | } 443 | 444 | # print('Entered days_of_week block') 445 | 446 | if (between(length(input$daysOfWeek), 0, 7, incbounds = F)) { 447 | dataset <- dataset[weekdays(get(date_col)) %in% input$daysOfWeek,] 448 | } 449 | } 450 | 451 | # print('Entered dates_transformed block') 452 | 453 | if (!is.null(date_col) && !is.null(input$dateTransform)) { 454 | date_trans_str <- sapply(date_trans_list, extract, input$dateTransform) %>% .[!is.na(.)] 455 | 456 | if (grepl(date_trans_str, pattern = '%', fixed = TRUE)) { 457 | dataset[, c(date_col) := format(dataset[[date_col]], date_trans_str)] 458 | if (all(grepl(dataset[[date_col]], pattern='^\\d+$'))) { 459 | dataset[, c(date_col) := factor(as.integer(dataset[[date_col]]), ordered = TRUE)] # for week of year 460 | } 461 | } else { 462 | date_trans_FUN <- match.fun(date_trans_str) 463 | if (input$dateTransform =='Year-Quarter') { 464 | dataset[, c(date_col) := factor(date_trans_FUN(dataset[[date_col]], with_year=TRUE), ordered=TRUE)] 465 | } else if (is.null(as.list(args(date_trans_FUN))[['label']])) { 466 | dataset[, c(date_col) := factor(date_trans_FUN(dataset[[date_col]]), ordered=TRUE)] 467 | } else { 468 | dataset[, c(date_col) := factor(date_trans_FUN(dataset[[date_col]], label = TRUE), ordered=TRUE)] 469 | } 470 | } 471 | 472 | if (grepl(names(date_trans_str), pattern='Parts', fixed=T)) { 473 | setnames(dataset, old=date_col, new=input$dateTransform) 474 | date_col <- input$dateTransform 475 | } 476 | } 477 | 478 | cols$date <- date_col 479 | 480 | return(dataset) 481 | }) 482 | 483 | total_n <- reactiveValues(groups=0, features=0) 484 | 485 | my$dataset_grouped <- reactive({ 486 | req(my$dataset_dates_parsed()) 487 | 488 | # print('Entered dataset_grouped block') 489 | 490 | dataset <- copy(my$dataset_dates_parsed()) 491 | 492 | group_col <- c$group 493 | feature_col <- c$feature 494 | value_col <- c$value 495 | 496 | isolate({ 497 | date_col <- cols$date 498 | 499 | if (!is.null(date_col)) { 500 | if (!is.null(group_col) && group_col == c$date) { group_col <- date_col } 501 | if (!is.null(feature_col) && feature_col == c$date) { feature_col <- date_col } 502 | } 503 | }) 504 | 505 | id_col <- if (any(!is.null(c(date_col, group_col, feature_col, value_col)))) { '#id' } else { NULL} 506 | 507 | # print('Entered agg_within block') 508 | 509 | grouping <- c(date_col, group_col, feature_col) 510 | 511 | if (is.null(value_col)) { 512 | dataset <- dataset[, .('value'=NA, '# observations'=.N), by = grouping] 513 | id_col <- NULL 514 | } else { 515 | if (!is.numeric(dataset[[value_col]])) { 516 | dataset[, c(value_col) := as.numeric(gsub(get(value_col), pattern = ',', replacement = '', fixed=T))] 517 | } 518 | 519 | if (is.null(input$aggWithinFUN)) { 520 | grouping <- c(id_col, grouping, value_col) 521 | 522 | dataset <- dataset[, grouping, with=FALSE] 523 | setnames(dataset, old=value_col, new='value') 524 | 525 | dataset[, '# observations' := 1] 526 | } else { 527 | 528 | aggWithinFUN <- match.fun(input$aggWithinFUN) 529 | 530 | dataset <- dataset[, .('value'=aggWithinFUN(get(value_col), na.rm = T), 531 | '# observations'=.N), by = grouping] 532 | 533 | id_col <- NULL 534 | } 535 | } 536 | 537 | if (!is.null(value_col) && sum(dataset[['# observations']]) > nrow(dataset)) { 538 | value_col <- paste(input$aggWithinFUN, value_col, sep = ' ') 539 | } 540 | 541 | # print('Entered agg_between block') 542 | 543 | if (!is.null(value_col)) { 544 | setnames(dataset, 'value', value_col) 545 | } else { 546 | dataset[, value := NULL] 547 | } 548 | 549 | # print('Entered rounded_values_filtered block') 550 | 551 | if (!is.null(value_col)) { 552 | dataset[, c(value_col) := round(dataset[[value_col]], decimalPrecision())] 553 | } 554 | 555 | if (!is.null(value_col)) { 556 | value_col <- value_col 557 | } else if ('# observations' %in% colnames(dataset)) { 558 | value_col <- '# observations' 559 | } 560 | 561 | if (!is.null(group_col)) { 562 | if (!is.factor(dataset[[group_col]])) { # must be int, dbl, or num. 563 | dataset[, c(group_col) := factor(dataset[[group_col]], ordered = T)] 564 | } else { 565 | group_totals <- dataset[, sum(abs(get(value_col)), na.rm=T), by=c(group_col)] 566 | setorder(group_totals, -V1) 567 | dataset[, c(group_col) := factor(dataset[[group_col]], levels = group_totals[[group_col]])] 568 | } 569 | } 570 | 571 | if (!is.null(feature_col)) { 572 | if (!is.factor(dataset[[feature_col]])) { # must be int, dbl, or num. 573 | dataset[, c(feature_col) := factor(dataset[[feature_col]], ordered = T)] 574 | } else { 575 | feature_totals <- dataset[, sum(abs(get(value_col)), na.rm=T), by=c(feature_col)] 576 | setorder(feature_totals, -V1) 577 | dataset[, c(feature_col) := factor(dataset[[feature_col]], levels = feature_totals[[feature_col]])] 578 | } 579 | } 580 | 581 | # print('Entered topN block') 582 | 583 | if (is.null(group_col)) { 584 | total_n$groups <- 0L 585 | } else { 586 | n_groups <- length(levels(dataset[[group_col]])) 587 | total_n$groups <- n_groups 588 | max_groups <- 50L 589 | if (!between(n_groups, 0L, max_groups, incbounds = T)) { 590 | dataset <- dataset[get(group_col) %in% (levels(dataset[[group_col]])[1:max_groups]),] 591 | } 592 | } 593 | 594 | if (is.null(feature_col)) { 595 | total_n$features <- 0L 596 | } else { 597 | n_features <- length(levels(dataset[[feature_col]])) 598 | total_n$features <- n_features 599 | max_features <- 100L 600 | if (!between(n_features, 0L, max_features, incbounds = T)) { 601 | dataset <- dataset[get(feature_col) %in% (levels(dataset[[feature_col]])[1:max_features]),] 602 | } 603 | } 604 | 605 | setorderv(dataset, cols=c(id_col, date_col, group_col, feature_col), order = 1) 606 | 607 | cols$id <- id_col 608 | cols$date <- date_col 609 | cols$group <- group_col 610 | cols$feature <- feature_col 611 | cols$value <- value_col 612 | 613 | return(dataset) 614 | }) 615 | 616 | output$dataset <- DT::renderDataTable(server=TRUE, options = list(pageLength = 5, lengthMenu = c(3, 5, 10, 15), select=FALSE), 617 | filter='top', { my$dataset }) 618 | 619 | output$dataset_grouped <- DT::renderDataTable(server=TRUE, # options = list(pageLength = 18, lengthChange=FALSE, select=FALSE), 620 | options = list(pageLength = 5, lengthMenu = c(3, 5, 10, 15), select=FALSE), 621 | filter='top', { 622 | my$dataset_grouped() 623 | }) 624 | 625 | coalesce <- function(text, ifnull) { 626 | if (!is.null(text)) { 627 | return(text) 628 | } 629 | 630 | return(ifnull) 631 | } 632 | 633 | observeEvent(c(input$tabContainer, my$dataset_p), priority = 1, { 634 | # clear selections when plot tab changes. 635 | session$sendCustomMessage(type = 'counts_plot_set', message = character(0)) 636 | session$sendCustomMessage(type = 'distribution_plot_set', message = character(0)) 637 | session$sendCustomMessage(type = 'trends_plot_set', message = character(0)) 638 | session$sendCustomMessage(type = 'pairs_plot_set', message = character(0)) 639 | }) 640 | 641 | my$dataset_selected <- reactive({ 642 | 643 | if (all(is.null(c(input$count_plot_selected, 644 | input$trends_plot_selected, 645 | input$distribution_plot_selected, 646 | input$pairs_plot_selected)))) { 647 | return(NULL) 648 | } else { 649 | 650 | selected_list <- NULL 651 | col_names <- NULL 652 | dataset <- NULL 653 | 654 | # id_col <- coalesce(cols$id, 'V1') 655 | date_col <- coalesce(cols$date, 'V1') 656 | group_col <- coalesce(pcols$group, 'V2') 657 | feature_col <- coalesce(pcols$feature, 'V3') 658 | 659 | if (!is.null(input$pairs_plot_selected)) { 660 | selected_list <- input$pairs_plot_selected 661 | 662 | dataset <- my$dataset_wide() 663 | 664 | col_names <- colnames(dataset) %>% .[!(. %in% c(input$featureX, input$featureY))] 665 | } else { 666 | 667 | col_names <- c(date_col, group_col, feature_col) 668 | 669 | if (!is.null(input$count_plot_selected)) { 670 | selected_list <- input$count_plot_selected 671 | } else if (!is.null(input$trends_plot_selected)) { 672 | selected_list <- input$trends_plot_selected 673 | } else if (!is.null(input$distribution_plot_selected)) { 674 | selected_list <- input$distribution_plot_selected 675 | } 676 | 677 | dataset <- my$dataset_dates_parsed() 678 | } 679 | 680 | dt_selected <- as.data.table(tstrsplit(selected_list, '|', fixed=T)) 681 | 682 | if (ncol(dt_selected) == 1) { 683 | setnames(dt_selected, '#id') 684 | join_cols <- '#id' 685 | } else { 686 | setnames(dt_selected, col_names) 687 | 688 | join_cols <- dt_selected[, !sapply(.SD, function(x) { all(x=='') || anyNA(x) })] 689 | 690 | dt_selected <- dt_selected[, (join_cols), with=F] 691 | 692 | join_cols <- colnames(dt_selected) %>% .[. %in% colnames(dataset)] 693 | 694 | dt_selected <- dt_selected[, (join_cols), with=F] 695 | } 696 | 697 | if (length(join_cols) == 0) { 698 | return(dataset) 699 | } 700 | else { 701 | isolate ({ 702 | # ensure selected date is same format as dataset date. 703 | if (!is.null(cols$date) && cols$date %in% join_cols && is.character(dataset[[cols$date]])) { 704 | date_trans_str <- sapply(date_trans_list, extract, input$dateTransform) %>% .[!is.na(.)] 705 | dt_selected[, c(cols$date) := format(as_datetime(get(cols$date)), date_trans_str)] 706 | # dataset <- copy(dataset) 707 | # dataset[, c(date_col) := as.character(parse_date_time(get(date_col), orders = date_trans_str))] 708 | } 709 | }) 710 | 711 | col_types <- dataset[, lapply(.SD, class), .SDcols=join_cols][1] 712 | 713 | lapply(1:length(join_cols), function(i) { 714 | this_col <- join_cols[[i]] 715 | is_fun <- match.fun(paste0('is.', col_types[[i]])) 716 | if (!is_fun(dt_selected[[this_col]])) { 717 | as_fun <- match.fun(paste0('as.', col_types[[i]])) 718 | dt_selected[, c(this_col) := as_fun(get(this_col))] 719 | } 720 | invisible(NULL) 721 | }) 722 | 723 | return(merge(dataset, dt_selected, by=join_cols)) 724 | } 725 | } 726 | }) 727 | 728 | output$dataset_selected <- DT::renderDataTable(server=TRUE, filter='top', 729 | options = list(pageLength = 15, lengthMenu = c(3, 5, 10, 15), select=FALSE), 730 | { my$dataset_selected() }) 731 | 732 | observeEvent(input$selected_as_source, { 733 | req(my$dataset_selected()) 734 | 735 | selected_ids <- my$dataset_selected()[['#id']] 736 | 737 | isolate({ 738 | my$dataset <- my$dataset[my$dataset[['#id']] %in% selected_ids] 739 | }) 740 | }) 741 | 742 | n <- reactiveValues(dates=0, groups=0, features=0, x_breaks=30L, y_breaks=10L) 743 | 744 | # columns specific to plots. 745 | pcols <- reactiveValues(group=NULL, feature=NULL, value=NULL) 746 | 747 | observe(priority = 1, { 748 | req(my$dataset_grouped()) 749 | 750 | # print('Getting plot dataset.') 751 | 752 | dataset <- NULL 753 | 754 | if (between(length(input$dataset_grouped_rows_all), 0, nrow(my$dataset_grouped()), incbounds = F)) { 755 | dataset <- my$dataset_grouped()[input$dataset_grouped_rows_all, ] 756 | } else { 757 | dataset <- my$dataset_grouped() 758 | } 759 | 760 | # drop levels. 761 | my$dataset_p <- dataset[, lapply(.SD, function(x) { if (is.factor(x)) { factor(x) } else { x } })] 762 | }) 763 | 764 | 765 | observe({ 766 | req(my$dataset_p) 767 | 768 | dataset <- my$dataset_p 769 | 770 | group_col <- isolate(cols$group) 771 | feature_col <- isolate(cols$feature) 772 | value_col <- cols$value 773 | if (is.null(value_col) || input$plotValues == '# observations') { 774 | value_col <- '# observations' 775 | } 776 | 777 | swap <- params$swap 778 | 779 | isolate({ 780 | if (swap) { 781 | if (coalesce(pcols$group, '') != coalesce(feature_col, '')) { 782 | pcols$group <- feature_col 783 | } 784 | if (coalesce(pcols$feature, '') != coalesce(group_col, '')) { 785 | pcols$feature <- group_col 786 | } 787 | } else { 788 | if (coalesce(pcols$group, '') != coalesce(group_col, '')) { 789 | pcols$group <- group_col 790 | } 791 | if (coalesce(pcols$feature, '') != coalesce(feature_col, '')) { 792 | pcols$feature <- feature_col 793 | } 794 | } 795 | 796 | pcols$value <- value_col 797 | 798 | n$dates <- if (is.null(cols$date)) { 0L } else { length(unique(dataset[[cols$date]])) } 799 | n$groups <- if (is.null(pcols$group)) { 0L } else { length(levels(dataset[[pcols$group]])) } 800 | n$features <- if (is.null(pcols$feature)) { 0L } else { length(levels(dataset[[pcols$feature]])) } 801 | }) 802 | }) 803 | 804 | 805 | params <- reactiveValues(swap=FALSE, facetFeatures=FALSE, rotate=FALSE, fixLimsX=FALSE, fixLimsY=FALSE) 806 | 807 | observe({ 808 | for (param in names(isolate(reactiveValuesToList(params)))) { 809 | params[[param]] <- param %in% input$plotParams 810 | } 811 | }) 812 | 813 | observeEvent(params$rotate, { 814 | fix_y <- params$fixLimsX 815 | fix_x <- params$fixLimsY 816 | if (fix_x != fix_y) { 817 | selected <- input$plotParams 818 | 819 | if (!fix_x) { selected <- selected[selected != 'fixLimsX'] } 820 | else { selected <- c(selected, 'fixLimsX') } 821 | 822 | if (!fix_y) { selected <- selected[selected != 'fixLimsY'] } 823 | else { selected <- c(selected, 'fixLimsY') } 824 | 825 | updateCheckboxGroupInput(session, 'plotParams', selected = selected) 826 | } 827 | }) 828 | 829 | toName <- function(text, envir = parent.frame()) { 830 | if (is.null(text)) { 831 | return('') 832 | } 833 | return(eval(sym(text), envir = envir)) 834 | } 835 | 836 | plot <- reactiveValues(counts=NULL, trends=NULL, dist=NULL) 837 | plot_final <- reactiveValues(counts=NULL, trends=NULL, dist=NULL) 838 | 839 | output$groupCountText <- renderText({ 840 | return(paste0(n$groups, ' of ', total_n$groups, ' groups shown.')) 841 | }) 842 | 843 | output$featureCountText <- renderText({ 844 | return(paste0(n$features, ' of ', total_n$features, ' features shown.')) 845 | }) 846 | 847 | n$x_breaks <- reactive({ 848 | n <- 30L 849 | if (!is.na(n_x_breaks_dbnce()) && as.integer(n_x_breaks_dbnce()) > 0) { 850 | n <- as.integer(n_x_breaks_dbnce()) 851 | } 852 | return(n) 853 | }) 854 | 855 | n$y_breaks <- reactive({ 856 | n <- 10L 857 | if (!is.na(n_y_breaks_dbnce()) && as.integer(n_y_breaks_dbnce()) > 0) { 858 | n <- as.integer(n_y_breaks_dbnce()) 859 | } 860 | return(n) 861 | }) 862 | 863 | output$countPlotMessage <- renderText({ 864 | req(my$dataset_p) 865 | 866 | if (n$groups > 50) { 867 | return('Max of 50 groups exceeded.') 868 | } else if (n$features > 100) { 869 | return('Max of 100 features exceeeded.') 870 | } else if (n$dates > 1) { 871 | return('Summed out date column.') 872 | } 873 | }) 874 | 875 | 876 | plot$counts <- reactive({ 877 | req(my$dataset_p) 878 | 879 | # print('Entered counts_plot block') 880 | 881 | dataset <- copy(my$dataset_p) 882 | 883 | group_col <- pcols$group 884 | feature_col <- pcols$feature 885 | value_col <- pcols$value 886 | 887 | geom <- input$countGeom 888 | values_as <- input$countValuesAs 889 | rotate <- params$rotate 890 | 891 | isolate({ 892 | id_col <- cols$id 893 | date_col <- cols$date 894 | 895 | if (nrow(dataset) > 1 && !is.null(value_col) && all(is.null(c(date_col, group_col, feature_col)))) { 896 | # do this to prevent several unnecessary layers plotted atop one another 897 | dataset <- dataset[, .(value=sum(get(value_col))), by=NULL] 898 | value_col <- paste0('Sum of ', value_col) 899 | setnames(dataset, old='value', new=value_col) 900 | id_col <- NULL 901 | } 902 | 903 | if (n$dates > 1 || (is.null(input$aggWithinFUN) && sum(dataset[['# observations']], na.rm=T) == nrow(dataset))) { 904 | # contains non-distinct columns; sum them if no agg-within function is specified. 905 | grouping <- c(group_col, feature_col) 906 | dataset <- dataset[, .('value'=sum(get(value_col), na.rm = T), 907 | '# observations'=sum(get('# observations'))), by = grouping] 908 | value_col <- paste0('Sum of ', value_col) 909 | setnames(dataset, old='value', new=value_col) 910 | y_lab <- value_col 911 | date_col <- NULL 912 | id_col <- NULL 913 | } 914 | 915 | y_format <- scales::comma 916 | y_lab <- value_col 917 | x_lab <- NULL 918 | 919 | if (values_as == '% of Grand Total') { 920 | dataset[, c(value_col) := list(get(value_col)/sum(get(value_col)))] 921 | y_lab <- paste(y_lab, paste0('(', values_as, ')')) 922 | y_format <- scales::percent 923 | } else if (values_as == '% of Group Total' || geom == 'Pie') { 924 | if (is.null(group_col)) { 925 | dataset[, c(value_col) := list(get(value_col)/sum(get(value_col)))] 926 | } else { 927 | dataset[, c(value_col) := as.numeric(get(value_col))] 928 | dataset[, c(value_col) := list(get(value_col)/sum(get(value_col))), by=c(group_col)] 929 | } 930 | y_lab <- paste(y_lab, '(% of Group Total)') 931 | y_format <- scales::percent 932 | } 933 | 934 | no_legend <- FALSE 935 | 936 | if (geom == 'Bars') { 937 | p <- ggplot(dataset, aes(x=toName(feature_col), y=toName(value_col), 938 | group=toName(feature_col), fill=toName(feature_col), color=toName(feature_col), 939 | tooltip=paste(paste0('y = ',y_format(toName(value_col))), 940 | paste0('n = ',comma(toName('# observations'))), 941 | sep='\n'), 942 | data_id=paste0(paste(toName(date_col), toName(group_col), toName(feature_col), sep='|'), '|'))) + 943 | geom_bar_interactive(stat='identity', position=position_dodge(width=1), na.rm = T) 944 | # geom_bar(stat='identity', position=position_dodge(width=1), na.rm = T) 945 | 946 | no_legend <- TRUE 947 | 948 | if (rotate) { 949 | p <- p + scale_x_discrete(limits = factor(rev(levels(dataset[[feature_col]])))) 950 | } 951 | } else { 952 | x_text <- NULL # feature_col 953 | if (is.null(x_text)) { x_text <- '' } 954 | # Bars stacked 955 | p <- ggplot(dataset, aes(x=x_text, y=toName(value_col), 956 | group=toName(feature_col), fill=toName(feature_col), color=toName(feature_col), 957 | tooltip=paste(paste0('y = ',y_format(toName(value_col))), 958 | paste0('n = ',comma(toName('# observations'))), 959 | sep='\n'), 960 | data_id=paste0(paste(toName(date_col), toName(group_col), toName(feature_col), sep='|'), '|'))) + 961 | geom_bar_interactive(stat='identity', width=1, position=position_stack(reverse=T), na.rm = T) 962 | # geom_bar(stat='identity', width=1, position=position_stack(reverse=T), na.rm = T) 963 | 964 | if (geom == 'Pie') { 965 | p <- p + coord_polar('y', start=0) 966 | } 967 | } 968 | }) 969 | 970 | return(facet_features(p, x_lab=x_lab, y_lab=y_lab, x_format=NULL, y_format=y_format, no_legend = no_legend)) 971 | }) 972 | 973 | plot_final$counts <- reactive({ 974 | req(my$dataset_p, 975 | n$groups <= 50, n$features <= 100) 976 | 977 | return(postProcessPlot(plot$counts())) 978 | }) 979 | 980 | observeEvent(input$reactivity, { 981 | if (input$reactivity==TRUE) { 982 | output$count_plot <- renderggiraph({ plot_final$counts() %>% asGGiraph() }) 983 | } else { 984 | output$count_plot <- renderggiraph({ 985 | input$submit # fire on 'submit' 986 | isolate({ plot_final$counts() %>% asGGiraph() }) 987 | }) 988 | } 989 | }) 990 | 991 | output$trendPlotMessage <- renderText({ 992 | if (is.null(cols$date)) { 993 | return('Specify a date column.') 994 | } else if (n$groups > 50) { 995 | return('Max of 50 groups exceeded.') 996 | } else if (n$features > 100) { 997 | return('Max of 100 features exceeeded.') 998 | } else { 999 | return('') 1000 | } 1001 | }) 1002 | 1003 | plot$trends <- reactive({ 1004 | 1005 | # print('Entered trends_plot block') 1006 | 1007 | dataset <- copy(my$dataset_p) 1008 | 1009 | group_col <- pcols$group 1010 | feature_col <- pcols$feature 1011 | value_col <- pcols$value 1012 | 1013 | values_as <- input$trendValuesAs 1014 | 1015 | geom <- input$trendGeom 1016 | 1017 | isolate({ 1018 | id_col <- cols$id 1019 | date_col <- cols$date 1020 | 1021 | if (nrow(dataset) > 1 && !is.null(value_col) && all(is.null(c(date_col, group_col, feature_col)))) { 1022 | # do this to prevent several unnecessary layers plotted atop one another 1023 | dataset <- dataset[, .(value=round(mean(get(value_col)), isolate(decimalPrecision()))), by=NULL] 1024 | value_col <- paste0('mean ', value_col) 1025 | setnames(dataset, old='value', new=value_col) 1026 | id_col <- NULL 1027 | } 1028 | 1029 | p <- NULL 1030 | x_lab <- date_col 1031 | y_lab <- value_col 1032 | y_format <- scales::comma 1033 | x_format <- NULL 1034 | 1035 | if (values_as == '% of Grand Total') { 1036 | dataset[, c(value_col) := list(get(value_col)/sum(get(value_col)))] 1037 | y_lab <- paste(y_lab, paste0('(', values_as, ')')) 1038 | y_format <- scales::percent 1039 | } else if (values_as == '% of Group Total') { 1040 | if (is.null(group_col)) { 1041 | dataset[, c(value_col) := list(get(value_col)/sum(get(value_col)))] 1042 | } else { 1043 | dataset[, c(value_col) := as.numeric(get(value_col))] 1044 | dataset[, c(value_col) := list(get(value_col)/sum(get(value_col))), by=c(group_col)] 1045 | } 1046 | y_lab <- paste(y_lab, paste0('(', values_as, ')')) 1047 | y_format <- scales::percent 1048 | } 1049 | 1050 | x_format <- NULL 1051 | 1052 | if (is.factor(dataset[[date_col]]) && all(grepl(dataset[[date_col]], pattern='^\\d+$'))) { 1053 | dataset[, c(date_col) := as.integer(as.character(get(date_col)))] 1054 | x_format <- waiver() # leave x-axis text as-is. 1055 | } 1056 | 1057 | p <- ggplot(dataset, aes(x=toName(date_col), y=toName(value_col), 1058 | group=toName(feature_col), fill=toName(feature_col), color=toName(feature_col), 1059 | tooltip=paste(toName(feature_col), 1060 | paste(date_col, toName(date_col), sep=': '), 1061 | paste0('y = ', y_format(toName(value_col))), 1062 | paste0('n = ', comma(toName('# observations'))), 1063 | sep='\n'), 1064 | data_id=paste0(paste(toName(date_col), toName(group_col), toName(feature_col), sep='|'), '|'))) 1065 | 1066 | non_distinct_rows <- (is.null(input$aggWithinFUN) && sum(dataset[['# observations']], na.rm=T) == nrow(dataset)) 1067 | 1068 | if (non_distinct_rows) { 1069 | 1070 | if (geom == 'Lines') { 1071 | p <- p <- ggplot(dataset, aes(x=toName(date_col), y=toName(value_col), 1072 | group=toName(feature_col), fill=toName(feature_col), color=toName(feature_col), 1073 | tooltip=paste(toName(feature_col), 1074 | paste(date_col, toName(date_col), sep=': '), 1075 | paste0('y = ', y_format(toName(value_col))), 1076 | paste0('n = ', comma(toName('# observations'))), 1077 | sep='\n'), 1078 | data_id=toName(id_col))) + 1079 | geom_smooth(stat='smooth', method = 'loess', se = F, na.rm = T) + 1080 | geom_point_interactive(size=2, alpha=0.5) 1081 | } else { 1082 | id_col <- NULL 1083 | 1084 | grouping <- c(date_col, group_col, feature_col) 1085 | dataset <- dataset[, .('value'=sum(get(value_col), na.rm = T), 1086 | '# observations'=sum(get('# observations'))), 1087 | by = grouping] 1088 | 1089 | value_col <- paste0('Sum of ', value_col) 1090 | setnames(dataset, old='value', new=value_col) 1091 | y_lab <- value_col 1092 | 1093 | p <- ggplot(dataset, aes(x=toName(date_col), y=toName(value_col), 1094 | group=toName(feature_col), fill=toName(feature_col), color=toName(feature_col), 1095 | tooltip=paste(toName(feature_col), 1096 | paste(date_col, toName(date_col), sep=': '), 1097 | paste0('y = ', y_format(toName(value_col))), 1098 | paste0('n = ', comma(toName('# observations'))), 1099 | sep='\n'), 1100 | data_id=paste0(paste(toName(date_col), toName(group_col), toName(feature_col), sep='|'), '|'))) 1101 | } 1102 | } 1103 | 1104 | if (!non_distinct_rows && geom == 'Lines') { 1105 | p <- p + geom_line(size=1, na.rm = T) + geom_point_interactive(size=2, alpha=1, na.rm = T) 1106 | } else if (geom == 'Bars') { 1107 | p <- p + geom_bar_interactive(stat = 'identity', width=1, color='gray', size=0.5, position = position_stack(reverse = TRUE), na.rm = T) 1108 | } 1109 | 1110 | if (!is.integer(dataset[[date_col]])) { 1111 | n_dateSplits <- min(n$dates, n$x_breaks()) 1112 | n_dateLabels <- n_dateSplits # min(n$dates, n_dateLabels, n$x_breaks()) 1113 | 1114 | if (is.factor(dataset[[date_col]])) { 1115 | 1116 | i_splits <- round(seq(from=1, to=length(levels(dataset[[date_col]])), length.out = n_dateSplits)) 1117 | date_limits <- levels(dataset[[date_col]]) 1118 | date_labels <- date_limits 1119 | date_labels[!(date_labels %in% date_labels[i_splits])] <- '' 1120 | 1121 | if (params$rotate) { date_limits <- rev(date_limits) } 1122 | 1123 | p <- p + scale_x_discrete(name=date_col, limits = date_limits, labels = date_labels) 1124 | 1125 | date_labels <- date_labels[date_labels != ''] 1126 | 1127 | } else { 1128 | date_trans_str <- NULL 1129 | 1130 | if (is.character(dataset[[date_col]])) { 1131 | date_trans_str <- sapply(date_trans_list, extract, input$dateTransform) %>% .[!is.na(.)] 1132 | dataset[, c(date_col) := parse_date_time(get(date_col), orders = date_trans_str)] 1133 | } 1134 | 1135 | date_labels <- pretty_dates(dataset[[date_col]], n=n_dateSplits) 1136 | 1137 | scale_x <- scale_x_datetime 1138 | 1139 | if (is.Date(dataset[[date_col]])) { 1140 | scale_x <- scale_x_date 1141 | date_labels <- as_date(date_labels) 1142 | } 1143 | 1144 | if (params$rotate) { 1145 | date_labels <- rev(date_labels) 1146 | } 1147 | 1148 | if (is.null(date_trans_str)) { 1149 | p <- p + scale_x(breaks = date_labels, expand=c(0.01, 0)) 1150 | } else { 1151 | p <- p + scale_x(breaks = date_labels, date_labels=date_trans_str, expand=c(0.01, 0)) 1152 | } 1153 | } 1154 | } 1155 | }) 1156 | 1157 | return(facet_features(p, x_lab=x_lab, y_lab=y_lab, x_format=x_format, y_format=y_format)) 1158 | }) 1159 | 1160 | plot_final$trends <- reactive({ 1161 | req(my$dataset_p, cols$date, n$groups <= 50, n$features <= 100) 1162 | 1163 | return(postProcessPlot(plot$trends())) 1164 | }) 1165 | 1166 | observeEvent(input$reactivity, { 1167 | if (input$reactivity==TRUE) { 1168 | output$trends_plot <- renderggiraph({ plot_final$trends() %>% asGGiraph() }) 1169 | } else { 1170 | output$trends_plot <- renderggiraph({ 1171 | input$submit # fire on 'submit' 1172 | isolate({ plot_final$trends() %>% asGGiraph() }) 1173 | }) 1174 | } 1175 | }) 1176 | 1177 | output$distPlotMessage <- renderText({ 1178 | if (n$groups > 50) { 1179 | return('Max of 50 groups exceeded.') 1180 | } else if (n$features > 100) { 1181 | return('Max of 100 features exceeeded.') 1182 | } else if (!is.null(input$aggWithinFUN)) { 1183 | return('Consider removing within-groups aggregation.') 1184 | } else { 1185 | return('') 1186 | } 1187 | }) 1188 | 1189 | plot$dist <- reactive({ 1190 | 1191 | # print('Entered dist_plot block') 1192 | 1193 | dataset <- copy(my$dataset_p) 1194 | 1195 | group_col <- pcols$group 1196 | feature_col <- pcols$feature 1197 | value_col <- pcols$value 1198 | 1199 | geom <- input$distGeom 1200 | show_rug <- input$showRug 1201 | 1202 | n_bins <- as.integer(hist_bins_dbnce()) 1203 | values_as <- input$histValuesAs 1204 | 1205 | x_breaks <- n$x_breaks() 1206 | 1207 | rotate <- params$rotate 1208 | 1209 | isolate({ 1210 | 1211 | id_col <- cols$id 1212 | date_col <- NULL 1213 | 1214 | # if (params$showLabels) { 1215 | # grouping <- c(group_col, feature_col) 1216 | # dataset[, ':=' (Mean = round(weighted.mean(get(value_col), w=get('# observations')), digits = decimalPrecision()), 1217 | # SD = round(sd(get(value_col)), digits=decimalPrecision())), 1218 | # by=grouping][, c('id', 'AbsErr') := list(1:.N, abs(get(value_col)-Mean))] 1219 | # 1220 | # min_ids <- dataset[, .SD[which.min(AbsErr)], by=grouping, .SDcols='id']$id 1221 | # 1222 | # dataset[min_ids,]$Label <- paste0('atop(', paste0("mu=='", comma(dataset[min_ids,]$Mean), "', sigma=='", comma(dataset[min_ids,]$SD)), "')") 1223 | # 1224 | # dataset[, c('id', 'Mean', 'SD', 'AbsErr') := NULL] 1225 | # } 1226 | 1227 | p <- NULL 1228 | x_lab <- value_col 1229 | y_lab <- NULL 1230 | 1231 | y_format <- scales::comma 1232 | x_format <- scales::comma 1233 | 1234 | if (geom == 'Histogram') { 1235 | 1236 | if (is.na(n_bins) || n_bins < 2) { n_bins <- 30 } 1237 | 1238 | grouping <- c(group_col, feature_col) 1239 | 1240 | val_range <- range(dataset[[value_col]]) 1241 | if (length(unique(val_range)) > 1) { 1242 | dataset <- dataset[, .(value_bins = cut_format(get(value_col), format_fun = x_format, sep = ' ~ ', 1243 | breaks=unique(round(seq(from=val_range[1], to=val_range[2], length.out=n_bins), digits=decimalPrecision())), # Inf), 1244 | right=FALSE, include.lowest = T, ordered_result = T, dig.lab=10)), by=grouping] 1245 | } else { 1246 | dataset[, value_bins := factor(comma(val_range[1]))] 1247 | } 1248 | 1249 | dataset <- dataset[, .(n = .N), by=c(grouping, 'value_bins')] 1250 | 1251 | id_col <- NULL 1252 | y_lab <- 'Binned Frequency' 1253 | x_format <- NULL 1254 | 1255 | if (values_as == '% of Grand Total') { 1256 | dataset[, n := n/sum(n)] 1257 | y_lab <- paste(y_lab, paste0('(', values_as, ')')) 1258 | y_format <- scales::percent 1259 | } else if (values_as == '% of Group Total') { 1260 | if (is.null(group_col)) { 1261 | dataset[, n := n/sum(n)] 1262 | } else { 1263 | dataset[, n := as.numeric(n)] 1264 | dataset[, n := n/sum(n), by=c(group_col)] 1265 | } 1266 | y_lab <- paste(y_lab, '(% of Group Total)') 1267 | y_format <- scales::percent 1268 | } 1269 | 1270 | p <- ggplot(dataset, aes(x=value_bins, y=n, 1271 | group=toName(feature_col), fill=toName(feature_col), color=toName(feature_col), 1272 | tooltip=paste(toName(feature_col), 1273 | paste0('y = ', y_format(n)), 1274 | paste0('x = ', value_bins), 1275 | sep='\n'), 1276 | data_id=paste0(paste(toName(date_col), toName(group_col), toName(feature_col), sep='|'), '|'))) + 1277 | geom_bar_interactive(stat = 'identity', width=1, position = position_stack(reverse=T), color='gray', size=0.5, na.rm = T) 1278 | 1279 | x_limits <- levels(dataset[['value_bins']]) 1280 | i_splits <- round(seq(from=1, to=length(x_limits), length.out = x_breaks)) 1281 | 1282 | x_labels <- x_limits 1283 | x_labels[!(x_labels %in% x_labels[i_splits])] <- '' 1284 | 1285 | p <- p + scale_x_discrete(limits = x_limits, labels = x_labels) 1286 | 1287 | } else { 1288 | 1289 | x_lab <- NULL 1290 | y_lab <- value_col 1291 | x_format <- NULL 1292 | 1293 | # TODO 1294 | # q1 <- quantile(dataset[[value_col]], probs = 0.25) 1295 | # q3 <- quantile(dataset[[value_col]], probs = 0.75) 1296 | # iqr <- IQR(dataset[[value_col]], na.rm = T) 1297 | 1298 | grouping <- c(group_col, feature_col) 1299 | 1300 | dt_quantiles <- dataset[, .(q1 = quantile(get(value_col), probs = 0.25, na.rm = T), 1301 | q3 = quantile(get(value_col), probs = 0.75, na.rm = T), 1302 | iqr = IQR(get(value_col), na.rm=T)), by=grouping] 1303 | 1304 | dt_bounds <- dt_quantiles[, .(lower = q1 - 1.5*iqr, 1305 | upper = q3 + 1.5*iqr), by=grouping] 1306 | 1307 | dt_outliers <- NULL 1308 | 1309 | if (!is.null(grouping)) { 1310 | dt_outliers <- merge(dataset, dt_bounds, by=grouping)[!between(get(value_col), lower, upper),] 1311 | } else { 1312 | dt_outliers <- dataset[!between(get(value_col), dt_bounds$lower, dt_bounds$upper),] 1313 | } 1314 | 1315 | p <- ggplot(dataset, aes(x=toName(feature_col), y=toName(value_col), 1316 | group=toName(feature_col), color=toName(feature_col), fill=toName(feature_col))) + 1317 | geom_boxplot_interactive(aes(tooltip=paste(toName(feature_col), 1318 | toName(value_col), 1319 | sep='\n'), 1320 | data_id=paste0(paste(toName(date_col), toName(group_col), toName(feature_col), sep='|'), '|')), 1321 | fill=NA, size=1, outlier.shape=NA, na.rm = T, show.legend = F) # position = position_dodge(1), 1322 | 1323 | if (nrow(dt_outliers) > 0) { 1324 | p <- p + geom_point_interactive(data=dt_outliers, 1325 | aes(color=toName(feature_col), fill=toName(feature_col), 1326 | tooltip=paste0('y = ', comma(toName(value_col))), 1327 | data_id=toName('#id')), 1328 | size=2, alpha=1, position = position_jitter(height=0, width=0.375), show.legend = F) 1329 | } 1330 | 1331 | if (rotate) { 1332 | p <- p + scale_x_discrete(limits = rev(levels(dataset[[feature_col]]))) 1333 | } 1334 | } 1335 | 1336 | if (show_rug) { 1337 | if ((input$distGeom == 'Histogram' && !params$rotate) || 1338 | (input$distGeom != 'Histogram' && params$rotate)) { 1339 | p <- p + geom_rug(sides='b', size=0.25, # aes(y=0), 1340 | position = position_jitter(height=0), alpha=0.25, show.legend = F, na.rm = T) 1341 | } else { 1342 | p <- p + geom_rug(sides='l', size=0.25, # aes(x=0), 1343 | position = position_jitter(width=0), alpha=0.25, show.legend = F, na.rm = T) 1344 | } 1345 | } 1346 | }) 1347 | 1348 | return(facet_features(p, x_lab=x_lab, y_lab=y_lab, x_format=x_format, y_format=y_format)) 1349 | 1350 | }) 1351 | 1352 | plot_final$dist <- reactive({ 1353 | req(my$dataset_p, 1354 | n$groups <= 50, n$features <= 100) 1355 | 1356 | return(postProcessPlot(plot$dist())) 1357 | }) 1358 | 1359 | observeEvent(input$reactivity, { 1360 | if (input$reactivity==TRUE) { 1361 | output$distribution_plot <- renderggiraph({ plot_final$dist() %>% asGGiraph() }) 1362 | } else { 1363 | output$distribution_plot <- renderggiraph({ 1364 | input$submit # fire on 'submit' 1365 | isolate({ plot_final$dist() %>% asGGiraph() }) 1366 | }) 1367 | } 1368 | }) 1369 | 1370 | my$dataset_wide <- reactive({ 1371 | 1372 | req(my$dataset_dates_parsed(), 1373 | input$featureX, input$featureY) 1374 | 1375 | # print('Getting wide dataset.') 1376 | 1377 | if (n$features <= 1) { 1378 | return(my$dataset_dates_parsed()) 1379 | } else { 1380 | 1381 | dataset <- my$dataset_dates_parsed() 1382 | 1383 | feature_col <- cols$feature 1384 | value_col <- isolate(c$value) 1385 | 1386 | id_cols <- paste(colnames(dataset) %>% .[!(. %in% c(feature_col, value_col)) & !grepl(., pattern='^#')], 1387 | collapse = '+') 1388 | 1389 | if (length(id_cols) == 0 || id_cols == '') { id_cols <- '.' } 1390 | else { id_cols <- sub(id_cols, pattern='(.+\\s.+)', replacement='`\\1`') } 1391 | 1392 | f <- paste(id_cols, feature_col, sep='~') 1393 | 1394 | return(dataset[get(feature_col) %in% c(input$featureX, input$featureY), ] %>% 1395 | dcast(formula = f, value.var=value_col, fun.aggregate=mean)) #, fill=NA)) 1396 | } 1397 | }) 1398 | 1399 | output$pairsPlotMessage <- renderText({ 1400 | if (n$features > 1 && is.null(c$value)) { 1401 | 'Select a value column.' 1402 | } else if (is.null(input$featureX) || is.null(input$featureY)) { 1403 | 'Specify the X and Y axes.' 1404 | } else { # if (is.null(input$aggWithinFUN) || n$features == nrow(my$dataset_p)) { 1405 | 'Using source dataset.' 1406 | } 1407 | }) 1408 | 1409 | observe({ 1410 | req(my$dataset_p) #, pcols$feature) 1411 | 1412 | all_features <- NULL 1413 | 1414 | if (between(n$features, 1, 100)) { 1415 | all_features <- levels(my$dataset_p[[pcols$feature]]) 1416 | } else { 1417 | col_names <- colnames(my$dataset_dates_parsed()) %>% .[. != '#id'] 1418 | all_features <- col_names[my$dataset_dates_parsed()[, lapply(.SD, class), .SDcols=col_names][1] %in% c('numeric', 'integer', 'double')] 1419 | } 1420 | 1421 | if (length(all_features) > 100) { 1422 | all_features <- all_features[1:100] 1423 | } 1424 | 1425 | updateSelectizeInput(session, 'featureX', choices = all_features) 1426 | updateSelectizeInput(session, 'featureY', choices = all_features) 1427 | }) 1428 | 1429 | plot$pairs <- reactive({ 1430 | req(my$dataset_wide(), input$featureX, input$featureY) 1431 | 1432 | # print('Entered pairs_plot block.') 1433 | 1434 | col_names <- colnames(my$dataset_wide()) 1435 | 1436 | group_col <- cols$group 1437 | 1438 | isolate({ 1439 | feature_x <- input$featureX 1440 | feature_y <- input$featureY 1441 | 1442 | if ('#id' %in% col_names) { 1443 | id_expr <- paste0("toName('#id')") 1444 | } else { 1445 | col_names <- col_names[!(col_names %in% c('#id', feature_x, feature_y))] 1446 | id_expr <- paste0('paste0(paste(', paste(col_names, collapse = ', '), ', sep="|"), "|")') 1447 | } 1448 | 1449 | p <- ggplot(my$dataset_wide(), aes(x=toName(feature_x), y=toName(feature_y), 1450 | group=toName(group_col), color=toName(group_col), fill=toName(group_col), 1451 | tooltip=paste(paste0('x = ',comma(toName(feature_x))), 1452 | paste0('y = ',comma(toName(feature_y))), 1453 | sep='\n'), 1454 | data_id = eval(parse(text=id_expr)))) + 1455 | geom_point_interactive(size=2, alpha=0.5) + 1456 | geom_smooth(method='lm', se=F, color='gray20', linetype='dashed') 1457 | 1458 | }) 1459 | 1460 | return(facet_features(p, x_lab=feature_x, y_lab=feature_y, 1461 | x_format=scales::comma, y_format = scales::comma, no_legend = TRUE)) 1462 | }) 1463 | 1464 | plot_final$pairs <- reactive({ 1465 | req(my$dataset_wide(), n$groups <= 50, plot$pairs()) 1466 | 1467 | return(postProcessPlot(plot$pairs(), n_colors = isolate(n$groups))) 1468 | }) 1469 | 1470 | observeEvent(input$reactivity, { 1471 | if (input$reactivity==TRUE) { 1472 | output$pairs_plot <- renderggiraph({ plot_final$pairs() %>% asGGiraph() }) 1473 | } else { 1474 | output$pairs_plot <- renderggiraph({ 1475 | input$submit # fire on 'submit' 1476 | isolate({ plot_final$pairs() %>% asGGiraph() }) 1477 | }) 1478 | } 1479 | }) 1480 | 1481 | my$theme <- reactive({ 1482 | # print('Entered theme block.') 1483 | 1484 | angle_x <- as.integer(input$angleX) 1485 | 1486 | t <- theme(axis.text.x = element_text(size=rel(1.5)), 1487 | axis.text.y = element_text(size=rel(1.5)), 1488 | legend.title = element_blank(), 1489 | legend.position = input$legendPos, 1490 | legend.justification = 'top', 1491 | legend.box.background = element_rect(color='gray30'), 1492 | legend.text = element_text(size=rel(1.25)), 1493 | strip.background = element_rect(color = 'gray30'), 1494 | strip.text = element_text(size=rel(1.25)), 1495 | # panel.background = element_rect(color='gray30'), 1496 | panel.border = element_rect(color='gray30', fill=NA), 1497 | axis.title.y = element_text(size=rel(1.25), face='bold'), 1498 | axis.title.x = element_text(size=rel(1.25), face='bold'), 1499 | plot.title = element_text(size=rel(2.0), hjust=0.5, face='bold'), 1500 | plot.subtitle = element_text(size=rel(1.5), hjust=0.5), 1501 | plot.caption = element_text(size=rel(1.5), face = 'italic'), 1502 | plot.background = element_rect(color=NA) 1503 | ) 1504 | 1505 | if (angle_x > 0) { 1506 | if (angle_x == 90) { 1507 | t <- t + theme(axis.text.x = element_text(size=rel(1.5), hjust=1, vjust=0.35, angle=angle_x)) 1508 | } else { 1509 | t <- t + theme(axis.text.x = element_text(size=rel(1.5), hjust=1, angle=angle_x)) 1510 | } 1511 | } 1512 | 1513 | if (params$rotate) { 1514 | t <- t + theme(panel.grid.major.y = element_blank(), 1515 | panel.grid.minor.y = element_blank()) 1516 | } else { 1517 | t <- t + theme(panel.grid.major.x = element_blank(), 1518 | panel.grid.minor.x = element_blank()) 1519 | } 1520 | 1521 | return(t) 1522 | }) 1523 | 1524 | facet_features <- function(p, x_lab=NULL, y_lab=NULL, no_legend = FALSE, 1525 | x_format=scales::comma, y_format=scales::comma) { 1526 | 1527 | # print('Entered facet_features function.') 1528 | 1529 | if (nchar(plot_xlab_dbnce()) > 0) { 1530 | if (grepl(plot_xlab_dbnce(), pattern='^\\s+$')) { 1531 | x_lab <- NULL 1532 | } else { 1533 | x_lab <- plot_xlab_dbnce() 1534 | } 1535 | } 1536 | 1537 | if (nchar(plot_ylab_dbnce()) > 0) { 1538 | if (grepl(plot_ylab_dbnce(), pattern='^\\s+$')) { 1539 | y_lab <- NULL 1540 | } else { 1541 | y_lab <- plot_ylab_dbnce() 1542 | } 1543 | } 1544 | 1545 | if (params$rotate) { 1546 | p <- p + coord_flip() 1547 | } 1548 | 1549 | n_x_breaks <- n$x_breaks() 1550 | n_y_breaks <- n$y_breaks() 1551 | 1552 | if (!is.null(x_format)) { 1553 | 1554 | 1555 | scale_x_args <- list(name=x_lab, labels=x_format, breaks=scales::pretty_breaks(n=n_x_breaks), expand=c(0.01, 0)) 1556 | 1557 | if (params$fixLimsX && isolate(n$groups) <= 1 && !identical(x_format, waiver())) { 1558 | # waiver is only used when leaving numeric part of date as-is. 1559 | scale_x_args <- c(scale_x_args, list(limits=c(0, NA))) 1560 | } 1561 | 1562 | p <- p + do.call(scale_x_continuous, scale_x_args) 1563 | 1564 | } else { # if (!missing(x_lab)) { 1565 | p <- p + labs(x=x_lab) 1566 | } 1567 | 1568 | is_polar_coords <- as.logical((class(p$coordinates)[1] == 'CoordPolar')) 1569 | 1570 | if (!is.null(y_format)) { 1571 | 1572 | xpand <- if (is_polar_coords) { c(0, 0) } else { c(0.025, 0) } 1573 | 1574 | scale_y_args <- list(name=y_lab, labels = y_format, breaks=scales::pretty_breaks(n=n_y_breaks), expand=xpand) 1575 | 1576 | if (params$fixLimsY && n$groups <= 1) { 1577 | scale_y_args <- c(scale_y_args, list(limits=c(0, NA))) 1578 | } 1579 | 1580 | p <- p + do.call(scale_y_continuous, scale_y_args) 1581 | 1582 | } else { # if (!missing(y_lab)) { 1583 | p <- p + labs(y=y_lab) 1584 | } 1585 | 1586 | facet_scales <- 'fixed' 1587 | 1588 | if (!is_polar_coords) { 1589 | if (!params$fixLimsY && !params$fixLimsX) { 1590 | facet_scales <- 'free' 1591 | } else if (!params$fixLimsX) { 1592 | facet_scales <- 'free_x' 1593 | } else if (!params$fixLimsY) { 1594 | facet_scales <- 'free_y' 1595 | } else { 1596 | facet_scales <- 'fixed' 1597 | } 1598 | } 1599 | 1600 | if (params$facetFeatures) { 1601 | isolate({ 1602 | p <- p + facet_grid(toName(pcols$feature)~toName(pcols$group), scales = facet_scales) + guides(color=F, fill=F) 1603 | }) 1604 | } else { 1605 | legend_pos <- input$legendPos 1606 | isolate({ 1607 | if (n$groups > 0) { 1608 | p <- p + facet_wrap(~toName(pcols$group), scales = facet_scales, nrow=3) 1609 | } 1610 | if (n$features == 0 || no_legend == TRUE) { 1611 | p <- p + guides(color=F, fill=F) 1612 | } else { 1613 | legend_params <- NULL 1614 | if (legend_pos == 'bottom') { 1615 | legend_params <- guide_legend(title=NULL, direction='horizontal', nrow=1, byrow=T) 1616 | } else { # input$legendPos == 'top' 1617 | legend_params <- guide_legend(title=NULL, direction='vertical', ncol=1, byrow=F) 1618 | } 1619 | p <- p + guides(color=legend_params, fill=legend_params) 1620 | } 1621 | }) 1622 | } 1623 | 1624 | return(p) 1625 | } 1626 | 1627 | postProcessPlot <- function (p, myTheme=my$theme, baseTheme=theme_bw, n_colors = NULL, 1628 | title=NULL, subtitle=NULL, caption=NULL) { #xlab=NULL, ylab=NULL) { 1629 | 1630 | # print('Entered post_process block') 1631 | 1632 | if (missing(n_colors)) { 1633 | n_colors <- max(1, isolate(n$features)) 1634 | } else { 1635 | n_colors <- max(1, n_colors) 1636 | } 1637 | 1638 | color_pal <- NULL 1639 | 1640 | if (is.null(input$plotColors)) { 1641 | # https://stackoverflow.com/a/8197703 1642 | color_pal <- gg_color_hue(n_colors) 1643 | } else if (input$plotColors %in% colors(distinct=T)) { 1644 | # RColorBrewer uses cap-letters 1645 | # color_pal <- RColorBrewer::brewer.pal(n_colors, name=input$plotColors)[1:n_colors] 1646 | color_pal <- gradient_n_pal(c(input$plotColors, 'gray90'))(seq(0, 1, length.out = n_colors)) 1647 | } else { 1648 | color_pal <- match.fun(paste0(input$plotColors, '_pal'))()(n_colors)[1:n_colors] 1649 | 1650 | color_pal[is.na(color_pal)] <- '#808080' 1651 | } 1652 | 1653 | p <- p + scale_color_manual(values=color_pal) + scale_fill_manual(values=color_pal) 1654 | 1655 | if (missing(title)) { 1656 | title <- if (!is.null(p$labels$title)) { p$labels$title } else { plot_title_dbnce() } 1657 | } 1658 | if (missing(subtitle)) { 1659 | subtitle <- if (!is.null(p$labels$subtitle)) { p$labels$subtitle } else { plot_subtitle_dbnce() } 1660 | } 1661 | # xlab <- NULL 1662 | if (missing(caption)) { 1663 | caption <- if (!is.null(p$labels$caption)) { p$labels$caption } else { plot_caption_dbnce() } 1664 | } 1665 | 1666 | if (missing(baseTheme) && !is.null(input$plotTheme)) { 1667 | baseTheme <- match.fun(paste0('theme_', input$plotTheme)) 1668 | } 1669 | 1670 | p <- p + baseTheme() + my$theme() + 1671 | labs(title=bquote(underline(.(title))), 1672 | subtitle=subtitle, 1673 | caption=caption) 1674 | } 1675 | 1676 | plot$height <- reactive({ 1677 | if (!between(plot_height_dbnce(), 3, 120)) { 10L } else { as.integer(plot_height_dbnce()) } 1678 | }) 1679 | 1680 | plot$width <- reactive({ 1681 | if (!between(plot_width_dbnce(), 3, 120)) { 16L } else { as.integer(plot_width_dbnce()) } 1682 | }) 1683 | 1684 | asGGiraph <- function(p) { 1685 | return(ggiraph(code = print(p), selection_type = 'multiple', zoom_max = 5, width = 1, 1686 | height_svg = plot$height(), width_svg = plot$width(), 1687 | hover_css = "cursor:pointer;stroke:red;stroke-opacity:1;stroke-width:2;stroke-dasharray:10,10", 1688 | selected_css = "stroke:red;stroke-opacity:1;stroke-width:1.5;stroke-dasharray:10,10")) 1689 | } 1690 | 1691 | output$download_dist_plot <- downloadHandler( 1692 | filename = function() { paste('distribution.png', sep='') }, 1693 | content = function(file) { 1694 | ggsave(file, plot = plot_final$dist(), device = "png", 1695 | height = plot$height(), width = plot$width(), units = 'in') 1696 | } 1697 | ) 1698 | 1699 | output$download_trend_plot <- downloadHandler( 1700 | filename = function() { paste('trends.png', sep='') }, 1701 | content = function(file) { 1702 | ggsave(file, plot = plot_final$trends(), device = "png", 1703 | height = plot$height(), width = plot$width(), units = 'in') 1704 | } 1705 | ) 1706 | 1707 | output$download_count_plot <- downloadHandler( 1708 | filename = function() { paste('composition.png', sep='') }, 1709 | content = function(file) { 1710 | ggsave(file, plot = plot_final$counts(), device = "png", 1711 | height = plot$height(), width = plot$width(), units = 'in') 1712 | } 1713 | ) 1714 | 1715 | output$download_pairs_plot <- downloadHandler( 1716 | filename = function() { paste('feature-comparison.png', sep='') }, 1717 | content = function(file) { 1718 | ggsave(file, plot = plot_final$pairs(), device = "png", 1719 | height = plot$height(), width = plot$width(), units = 'in') 1720 | } 1721 | ) 1722 | 1723 | # https://yihui.shinyapps.io/DT-info/ 1724 | output$download = downloadHandler('data.csv', content = function(file) { 1725 | req(my$dataset, input$dataset_rows_all) 1726 | 1727 | fwrite(my$dataset[input$dataset_rows_all,], file) 1728 | }) 1729 | 1730 | output$download_final = downloadHandler('data-filtered.csv', content = function(file) { 1731 | req(my$dataset_grouped(), input$dataset_grouped_rows_all) 1732 | 1733 | fwrite(my$dataset_grouped()[input$dataset_grouped_rows_all,], file) 1734 | }) 1735 | 1736 | output$download_selected = downloadHandler('data-selected.csv', content = function(file) { 1737 | req(my$dataset_selected()) 1738 | 1739 | fwrite(my$dataset_selected(), file) 1740 | }) 1741 | 1742 | outputOptions(output, 'dataset', suspendWhenHidden=FALSE, priority=3) 1743 | outputOptions(output, 'dataset_grouped', suspendWhenHidden=FALSE, priority=2) 1744 | outputOptions(output, 'dataset_selected', suspendWhenHidden=FALSE, priority=1) 1745 | } 1746 | -------------------------------------------------------------------------------- /ui/body.R: -------------------------------------------------------------------------------- 1 | dashboardBody( 2 | # https://stackoverflow.com/a/36471739 3 | tags$style(type = "text/css", "div.nav-tabs-custom {height: 110vh !important;}"), 4 | tags$style(type = "text/css", "#count_plot {height: calc(110vh - 150px) !important;}"), 5 | tags$style(type = "text/css", "#trends_plot {height: calc(110vh - 150px) !important;}"), 6 | tags$style( 7 | type = "text/css", 8 | "#distribution_plot {height: calc(110vh - 150px) !important;}" 9 | ), 10 | tags$style(type = "text/css", "#pairs_plot {height: calc(110vh - 150px) !important;}"), 11 | tags$style(type = "text/css", ".box {border: 2px solid #3c8dbc !important;}"), 12 | tags$style( 13 | type = "text/css", 14 | "hr.blackline { margin-top: 0px; border-top: 2px solid #808080 !important;}" 15 | ), 16 | # https://stackoverflow.com/a/40098855 17 | tags$head(tags$style( 18 | HTML(".shiny-split-layout > div {overflow: visible;}") 19 | )), 20 | tags$head( 21 | tags$style(type = "text/css", "text {font-family: Segoe UI,sans-serif}") 22 | ), 23 | 24 | # https://stackoverflow.com/a/32244289 25 | tags$style( 26 | " 27 | .nav-tabs { 28 | background-color: #3c8dbc; 29 | } 30 | 31 | .nav-tabs-custom .nav-tabs li.active:hover a, .nav-tabs-custom .nav-tabs li.active a { 32 | background-color: transparent; 33 | color: #FFF; 34 | border-color: transparent; 35 | border-left-color: #FFF; 36 | border-right-color: #FFF; 37 | } 38 | 39 | .nav-tabs-custom .nav-tabs li.active { 40 | border-top-color: #FFF; 41 | color: #FFF; 42 | }"), 43 | 44 | tabItems( 45 | tabItem( 46 | tabName = 'load_dataset', 47 | 48 | source('ui/body/load_and_transform.R', local = TRUE)$value, 49 | 50 | hr(class = 'blackline'), 51 | 52 | source('ui/body/source_dataset.R', local = TRUE)$value, 53 | 54 | hr(class = 'blackline'), 55 | 56 | source('ui/body/group_options.R', local = TRUE)$value, 57 | 58 | hr(class = 'blackline'), 59 | 60 | source('ui/body/grouped_dataset.R', local = TRUE)$value, 61 | 62 | hr(class = 'blackline'), 63 | 64 | source('ui/body/plot_options.R', local = TRUE)$value, 65 | 66 | hr(class = 'blackline'), 67 | 68 | source('ui/body/plots.R', local = TRUE)$value, 69 | 70 | hr(class = 'blackline'), 71 | 72 | source('ui/body/selected_dataset.R', local = TRUE)$value 73 | ) 74 | ) 75 | ) 76 | -------------------------------------------------------------------------------- /ui/body/group_options.R: -------------------------------------------------------------------------------- 1 | fluidRow( 2 | width = '100%', 3 | box( 4 | width = 12, 5 | collapsible = TRUE, 6 | title = 'Grouping', 7 | solidHeader = TRUE, 8 | status = 'primary', 9 | box( 10 | width = 12, 11 | # background = 'light-blue', 12 | shiny::splitLayout( 13 | selectizeInput( 14 | 'date', 15 | 'Date Column:', 16 | choices = NULL, 17 | multiple = TRUE, 18 | options = list(maxItems = 1) 19 | ), 20 | 21 | selectizeInput( 22 | 'dateFormat', 23 | 'Date Format:', 24 | choices = lapply(date_format_list, names), 25 | selected = ' * Guess * ', 26 | multiple = TRUE, 27 | options = list(maxItems = 1) 28 | ), 29 | 30 | dateRangeInput( 31 | 'dateRange', 32 | 'Date Range:', 33 | format = 'mm/dd/yyyy', 34 | startview = 'month', 35 | separator = 'to', 36 | start = NA, 37 | end = NA 38 | ), 39 | 40 | selectizeInput( 41 | 'dateTransform', 42 | 'Date Transformation:', 43 | choices = lapply(date_trans_list, names), 44 | selected = NA, 45 | multiple = TRUE, 46 | options = list(maxItems = 1) 47 | ) 48 | ), 49 | conditionalPanel( 50 | 'input.date', 51 | checkboxGroupInput( 52 | 'daysOfWeek', 53 | 'Included Days of Week:', 54 | inline = TRUE, 55 | choices = wday(1:7, label = T, abbr = F), 56 | selected = wday(1:7, label = T, abbr = F) 57 | ) 58 | ) 59 | ), 60 | 61 | box( 62 | width = 3, 63 | # background = 'light-blue', 64 | selectizeInput( 65 | 'group', 66 | 'Group Column (facet by):', 67 | choices = NULL, 68 | multiple = TRUE, 69 | options = list(maxItems = 1) 70 | ) 71 | ), 72 | 73 | box( 74 | width = 3, 75 | # background = 'light-blue', 76 | selectizeInput( 77 | 'feature', 78 | 'Feature Column (color by):', 79 | choices = NULL, 80 | multiple = TRUE, 81 | options = list(maxItems = 1) 82 | ) 83 | ), 84 | 85 | box( 86 | width = 6, 87 | shiny::splitLayout( 88 | selectizeInput( 89 | 'value', 90 | 'Value Column:', 91 | choices = NULL, 92 | multiple = TRUE, 93 | options = list(maxItems = 1) 94 | ), 95 | selectizeInput( 96 | 'aggWithinFUN', 97 | 'Within-Groups Aggregation:', 98 | choices = c('sum', 'mean', 'median', 'min', 'max'), 99 | selected = NA, 100 | multiple = TRUE, 101 | options = list(maxItems = 1) 102 | ), 103 | numericInput( 104 | 'decimalPrecision', 105 | 'Rounding Precision:', 106 | min = -10, 107 | max = 10, 108 | value = 2, 109 | step = 1 110 | ) 111 | ) 112 | ) 113 | ) 114 | ) 115 | -------------------------------------------------------------------------------- /ui/body/grouped_dataset.R: -------------------------------------------------------------------------------- 1 | fluidRow( 2 | box( 3 | width = 12, 4 | title = 'Grouped Dataset', 5 | solidHeader = TRUE, 6 | collapsible = FALSE, 7 | status = 'primary', 8 | shiny::splitLayout( 9 | downloadButton('download_final', label = 'Download'), 10 | verbatimTextOutput('groupCountText', placeholder = T), 11 | verbatimTextOutput('featureCountText', placeholder = T) 12 | ), 13 | hr(), 14 | DT::dataTableOutput('dataset_grouped') %>% withSpinner(type = 6, color = '#3c8dbc') 15 | ) 16 | ) 17 | -------------------------------------------------------------------------------- /ui/body/load_and_transform.R: -------------------------------------------------------------------------------- 1 | fluidRow( 2 | width = '100%', 3 | box( 4 | width = 12, 5 | collapsible = TRUE, 6 | title = 'Load & Transform', 7 | solidHeader = TRUE, 8 | status = 'primary', 9 | 10 | box( 11 | width = 3, 12 | title = 'Load', 13 | # background = 'light-blue', 14 | 15 | selectizeInput( 16 | 'presetDataset', 17 | label = 'Example Datasets:', 18 | choices = c( 19 | 'Game Ratings', 20 | 'College Scorecards', 21 | 'Starbucks Nutrition', 22 | 'Border Patrol Apprehensions' 23 | ), 24 | selected = 'College Scorecards', 25 | multiple = FALSE 26 | ), 27 | 28 | br(), 29 | 30 | tags$label(class = 'control-label', 'User Dataset:'), 31 | fileInput( 32 | 'userFile', 33 | label = NA, 34 | buttonLabel = 'Upload', 35 | placeholder = 'CSV - Excel - RDS', 36 | multiple = FALSE, 37 | accept = c('.csv', '.xlsx', '.rds') 38 | ), 39 | # c("text/csv", "text/comma-separated-values,text/plain", ".csv")), 40 | 41 | actionButton( 42 | 'startOver', 43 | 'Undo Changes', 44 | icon = icon('undo'), 45 | width = '100%' 46 | ) 47 | ), 48 | 49 | box( 50 | width = 3, 51 | title = 'Combine / Rename / Drop', 52 | # background = 'light-blue', 53 | selectizeInput( 54 | 'columnsToCombine', 55 | label = 'Columns to Combine:', 56 | choices = NULL, 57 | multiple = TRUE 58 | ), 59 | textInput('combinedColName', label = NA, placeholder = 'new_column_name'), 60 | shiny::splitLayout( 61 | textInput('sepChar', label = NA, placeholder = 'separator'), 62 | checkboxInput('keepCombinedCols', label = 'Keep combined cols.', value = 63 | FALSE) 64 | ), 65 | actionButton( 66 | 'combineCols', 67 | width = '100%', 68 | icon = icon('compress'), 69 | label = 'Combine' 70 | ) 71 | ), 72 | 73 | box( 74 | width = 3, 75 | title = 'Separate', 76 | # background = 'light-blue', 77 | selectizeInput( 78 | 'columnToSplit', 79 | label = 'Column to Split:', 80 | choices = NULL, 81 | multiple = TRUE, 82 | options = list(maxItems = 1) 83 | ), 84 | shiny::splitLayout( 85 | textInput('splitChar', label = NA, placeholder = 'Split RegEx'), 86 | checkboxInput('keepSplitCols', label = 'Keep split col.', value = 87 | FALSE) 88 | ), 89 | actionButton( 90 | 'separateCols', 91 | width = '100%', 92 | icon = icon('sitemap'), 93 | label = 'Separate' 94 | ) 95 | ), 96 | 97 | box( 98 | width = 3, 99 | title = 'Reshape', 100 | # background = 'light-blue', 101 | selectizeInput( 102 | 'userFileIdCols', 103 | label = 'ID columns:', 104 | choices = NULL, 105 | multiple = TRUE 106 | ), 107 | 108 | shiny::splitLayout( 109 | textInput('meltedKeyName', label = NA, placeholder = 'key_column'), 110 | textInput('meltedValueName', label = NA, placeholder = 'value_column') 111 | ), 112 | 113 | actionButton( 114 | 'meltData', 115 | width = '100%', 116 | icon = icon('long-arrow-down'), 117 | label = 'Melt (wide to long)' 118 | ) 119 | ) 120 | ) 121 | ) 122 | -------------------------------------------------------------------------------- /ui/body/plot_options.R: -------------------------------------------------------------------------------- 1 | fluidRow( 2 | box( 3 | width = 12, 4 | collapsible = TRUE, 5 | title = 'Plot Options', 6 | solidHeader = TRUE, 7 | status = 'primary', 8 | box( 9 | width = 2, 10 | radioButtons( 11 | 'plotValues', 12 | label = 'Values to Plot:', 13 | inline = TRUE, 14 | choices = c('values', '# observations'), 15 | selected = '# observations' 16 | ), 17 | hr(), 18 | radioButtons( 19 | 'legendPos', 20 | label = 'Legend Position:', 21 | inline = TRUE, 22 | choices = c('bottom', 'right'), 23 | selected = 'bottom' 24 | ), 25 | hr(), 26 | checkboxInput('reactivity', label = 'Auto-Refresh', value = TRUE), 27 | conditionalPanel( 28 | 'input.reactivity==0', 29 | actionButton('submit', label = 'Refresh') 30 | ) 31 | ), 32 | box( 33 | width = 3, 34 | checkboxGroupInput( 35 | 'plotParams', 36 | label = 'Parameters:', 37 | inline = FALSE, 38 | choices = c( 39 | 'Swap Groups & Features' = 'swap', 40 | 'Facet Features' = 'facetFeatures', 41 | 'Rotate' = 'rotate', 42 | 'Fix X Limits' = 'fixLimsX', 43 | 'Fix Y Limits' = 'fixLimsY', 44 | 'Show Data Labels' = 'showLabels' 45 | ), 46 | selected = c('fixLimsX', 'fixLimsY') 47 | ), 48 | shiny::splitLayout( 49 | numericInput( 50 | 'n_x_breaks', 51 | 'Desired X breaks:', 52 | min = 1, 53 | value = 31, 54 | step = 1 55 | ), 56 | numericInput( 57 | 'n_y_breaks', 58 | 'Desired Y breaks:', 59 | min = 1, 60 | value = 10, 61 | step = 1 62 | ) 63 | ) 64 | ), 65 | box( 66 | width = 3, 67 | # height='85px', 68 | tags$label(class = 'control-label', 'Labels:'), 69 | # shiny::splitLayout( 70 | textInput( 71 | 'title', 72 | label = NA, 73 | value = NA, 74 | placeholder = 'Title' 75 | ), 76 | textInput( 77 | 'subtitle', 78 | label = NA, 79 | value = NA, 80 | placeholder = 'Subtitle' 81 | ), 82 | textInput( 83 | 'caption', 84 | label = NA, 85 | value = NA, 86 | placeholder = 'Caption' 87 | ), 88 | shiny::splitLayout( 89 | textInput( 90 | 'xlab', 91 | label = NA, 92 | value = NA, 93 | placeholder = 'x-label' 94 | ), 95 | textInput( 96 | 'ylab', 97 | label = NA, 98 | value = NA, 99 | placeholder = 'y-label' 100 | ) 101 | ), 102 | radioButtons( 103 | 'angleX', 104 | label = 'Text Angle (X):', 105 | choices = c(0, 35, 45, 90), 106 | inline = T, 107 | selected = 35 108 | ) 109 | # ) 110 | ), 111 | box( 112 | width = 4, 113 | selectizeInput( 114 | 'plotTheme', 115 | 'Plot Theme:', 116 | choices = all_themes <- 117 | list( 118 | 'Stock Themes' = ls('package:ggplot2') %>% .[grepl(., pattern = theme_pattern, perl = 119 | T)] %>% 120 | sub( 121 | pattern = theme_pattern, 122 | replacement = '', 123 | perl = T 124 | ), 125 | 'GG Themes' = ls('package:ggthemes') %>% .[grepl(., pattern = 126 | theme_pattern, perl = T)] %>% 127 | sub( 128 | pattern = theme_pattern, 129 | replacement = '', 130 | perl = T 131 | ) 132 | ), 133 | selected = 'gray', 134 | multiple = TRUE, 135 | options = list(maxItems = 1) 136 | ), 137 | 138 | selectizeInput( 139 | 'plotColors', 140 | 'Plot Colors:', 141 | choices = list( 142 | 'GG Colors' = ls('package:ggthemes') %>% .[grepl(., pattern = '(?% 143 | sub( 144 | pattern = '_pal', 145 | replacement = '', 146 | fixed = T 147 | ), 148 | 'Gradients' = colors(distinct = T) %>% .[!grepl(., pattern = 149 | '\\d')] 150 | ), 151 | selected = 'gdocs', 152 | multiple = TRUE, 153 | options = list(maxItems = 1) 154 | ), 155 | 156 | shiny::splitLayout( 157 | numericInput( 158 | 'plotHeight', 159 | label = 'Plot Image Height (in.)', 160 | min = 3, 161 | max = 99, 162 | value = 10 163 | ), 164 | numericInput( 165 | 'plotWidth', 166 | label = 'Plot Image Width (in.)', 167 | min = 3, 168 | max = 99, 169 | value = 16 170 | ) 171 | ) 172 | ) 173 | ) 174 | ) 175 | -------------------------------------------------------------------------------- /ui/body/plots.R: -------------------------------------------------------------------------------- 1 | fluidRow(box( 2 | width = 12, 3 | collapsible = TRUE, 4 | tabBox( 5 | id = 'tabContainer', 6 | width = 12, 7 | tabPanel( 8 | 'Distribution', 9 | icon = icon('bar-chart'), 10 | shiny::splitLayout( 11 | shiny::splitLayout( 12 | downloadButton('download_dist_plot', label = 'Download'), 13 | radioButtons( 14 | 'distGeom', 15 | label = 'Geom:', 16 | choices = c('Histogram', 'Boxplot'), 17 | selected = 'Histogram', 18 | inline = T 19 | ), 20 | checkboxInput('showRug', label = 'Show Rug', value = TRUE) 21 | ), 22 | conditionalPanel( 23 | 'input.distGeom=="Histogram"', 24 | radioButtons( 25 | 'histValuesAs', 26 | label = 'Values As:', 27 | choices = c('Frequency', '% of Grand Total', '% of Group Total'), 28 | selected = 'Frequency', 29 | inline = T 30 | ) 31 | ), 32 | conditionalPanel( 33 | 'input.distGeom=="Histogram"', 34 | numericInput( 35 | 'bins', 36 | 'Bins', 37 | min = 2, 38 | value = 30, 39 | step = 1, 40 | width = '50%' 41 | ) 42 | ), 43 | verbatimTextOutput('distPlotMessage', placeholder = TRUE) 44 | ), 45 | hr(), 46 | ggiraphOutput('distribution_plot') %>% withSpinner(type = 47 | 6, color = '#3c8dbc') 48 | ), 49 | tabPanel( 50 | 'Composition', 51 | icon = icon('pie-chart'), 52 | shiny::splitLayout( 53 | downloadButton('download_count_plot', label = 'Download'), 54 | radioButtons( 55 | 'countGeom', 56 | label = 'Geom:', 57 | choices = c('Bars', 'Bars Stacked', 'Pie'), 58 | selected = 'Bars', 59 | inline = T 60 | ), 61 | conditionalPanel( 62 | 'input.countGeom != "Pie"', 63 | radioButtons( 64 | 'countValuesAs', 65 | label = 'Values As:', 66 | choices = c('Values', '% of Grand Total', '% of Group Total'), 67 | selected = 'Values', 68 | inline = T 69 | ) 70 | ), 71 | verbatimTextOutput('countPlotMessage', placeholder = TRUE) 72 | ), 73 | hr(), 74 | ggiraphOutput('count_plot', width = '100%') %>% withSpinner(type = 75 | 6, color = '#3c8dbc') 76 | ), 77 | tabPanel( 78 | 'Trends', 79 | icon = icon('line-chart'), 80 | shiny::splitLayout( 81 | downloadButton('download_trend_plot', label = 'Download'), 82 | radioButtons( 83 | 'trendGeom', 84 | label = 'Geom:', 85 | choices = c('Lines', 'Bars'), 86 | selected = 'Lines', 87 | inline = T 88 | ), 89 | radioButtons( 90 | 'trendValuesAs', 91 | label = 'Values As:', 92 | choices = c('Values', '% of Grand Total', '% of Group Total'), 93 | selected = 'Values', 94 | inline = T 95 | ), 96 | verbatimTextOutput('trendPlotMessage', placeholder = TRUE) 97 | ), 98 | hr(), 99 | ggiraphOutput('trends_plot') %>% withSpinner(type = 100 | 6, color = '#3c8dbc') 101 | ), 102 | tabPanel( 103 | 'Feature Pairs', 104 | icon = icon('exchange'), 105 | shiny::splitLayout( 106 | downloadButton('download_pairs_plot', label = 'Download'), 107 | selectizeInput( 108 | 'featureX', 109 | label = 'X Feature', 110 | choices = NULL, 111 | selected = NA, 112 | multiple = TRUE, 113 | options = list(maxItems = 1) 114 | ), 115 | selectizeInput( 116 | 'featureY', 117 | label = 'Y Feature', 118 | choices = NULL, 119 | selected = NA, 120 | multiple = TRUE, 121 | options = list(maxItems = 1) 122 | ), 123 | # box(background = 'light-blue', actionButton('viewPairsPlot', 'View / Refresh', icon=icon('refresh'), width='100%')), 124 | verbatimTextOutput('pairsPlotMessage', placeholder = T) 125 | ), 126 | hr(), 127 | ggiraphOutput('pairs_plot') %>% withSpinner(type = 128 | 6, color = '#3c8dbc') 129 | ) 130 | ) 131 | )) 132 | -------------------------------------------------------------------------------- /ui/body/selected_dataset.R: -------------------------------------------------------------------------------- 1 | fluidRow( 2 | box( 3 | width = 12, 4 | title = 'Selected Dataset', 5 | solidHeader = TRUE, 6 | collapsible = FALSE, 7 | status = 'primary', 8 | div( 9 | downloadButton('download_selected', label = 'Download'), 10 | actionButton( 11 | 'selected_as_source', 12 | label = 'Set Selected as Source Dataset', 13 | icon = icon('arrow-circle-up') 14 | ), 15 | actionButton( 16 | 'original_as_source', 17 | 'Set Original as Source Dataset', 18 | icon = icon('undo') 19 | ) 20 | ), 21 | hr(), 22 | DT::dataTableOutput('dataset_selected') %>% withSpinner(type = 6, color = '#3c8dbc') 23 | ) 24 | ) 25 | -------------------------------------------------------------------------------- /ui/body/source_dataset.R: -------------------------------------------------------------------------------- 1 | fluidRow( 2 | box( 3 | width = 12, 4 | title = 'Source Dataset', 5 | solidHeader = TRUE, 6 | collapsible = FALSE, 7 | status = 'primary', 8 | splitLayout( 9 | downloadButton('download', label = 'Download'), 10 | verbatimTextOutput('sourceDatasetMessage', placeholder = TRUE) 11 | ), 12 | hr(), 13 | DT::dataTableOutput('dataset') %>% withSpinner(type = 6, color = '#3c8dbc') 14 | ) 15 | ) 16 | -------------------------------------------------------------------------------- /ui/date_formats.R: -------------------------------------------------------------------------------- 1 | date_format_list <- list('year-month-day' = c('ymd'='ymd', 'ymd_h'='ymd_H', 'ymd_hm'='ymd_HM', 'ymd_hms'='ymd_HMS'), 2 | 'month-day-year' = c('mdy'='mdy', 'mdy_h'='mdy_H', 'mdy_hm'='mdy_HM', 'mdy_hms'='mdy_HMS'), 3 | 'day-month-year' = c('dmy'='dmy', 'dmy_h'='dmy_H', 'dmy_hm'='dmy_HM', 'dmy_hms'='dmy_HMS'), 4 | 'Date Parts' = c('Year'='%Y', 'Month'='%m', 5 | 'Day of Year'='%j', 6 | 'Year-Month'='%Y-%m', 'Month-Year'='%m-%Y', 'Month-Day'='%m-%d'), 7 | 'Time Parts' = c('Hour'='%H', 'Minute'='%M', 'Second'='%S', 8 | 'Hour:Minute'='%H:%M', 'Hour:Minute:Second'='%H:%M:%S'), 9 | 'Other' = c(' - Guess - ' = '-', ' '='-')) 10 | 11 | date_trans_list <- list('year-month-day' = c('ymd'='%Y-%m-%d', 'ymd_h'='%Y-%m-%d %H', 'ymd_hm'='%Y-%m-%d %H:%M', 'ymd_hms'='%Y-%m-%d %H:%M:%S'), 12 | 'month-day-year' = c('mdy'='%m-%d-%Y', 'mdy_h'='%m-%d-%Y %H', 'mdy_hm'='%m-%d-%Y %H:%M', 'mdy_hms'='%m-%d-%Y %H:%M:%S'), 13 | 'day-month-year' = c('dmy'='%d-%m-%Y', 'dmy_h'='%d-%m-%Y %H', 'dmy_hm'='%d-%m-%Y %H:%M', 'dmy_hms'='%d-%m-%Y %H:%M:%S'), 14 | 'Date Parts' = c('Year'='year', 'Month'='month', 15 | 'Day of Year'='%j', 'Week of Year'='%V', 'Quarter of Year'='quarter', 16 | 'Day of Week'='wday', 'Day of Month'='mday', 17 | 'Year-Quarter'='quarter', 'Year-Month'='%Y-%m', 18 | 'Month-Day'='%m-%d'), 19 | 'Time Parts' = c('Hour'='hour', 'Minute'='minute', 'Second'='second', 20 | 'Hour:Minute'='%H:%M', 'Hour:Minute:Second'='%H:%M:%S')) 21 | -------------------------------------------------------------------------------- /ui/header.R: -------------------------------------------------------------------------------- 1 | dashboardHeader(titleWidth = 150, title = 'Shiny GEM') 2 | -------------------------------------------------------------------------------- /ui/sidebar.R: -------------------------------------------------------------------------------- 1 | dashboardSidebar(width = 150, 2 | sidebarMenu( 3 | id = 'sb_dataset', 4 | menuItem( 5 | 'Home', 6 | tabName = 'load_dataset', 7 | icon = icon('home'), 8 | selected = TRUE 9 | ), 10 | menuItem( 11 | 'Documentation', 12 | icon = icon('book'), 13 | href = 'https://www.donaldmellenbruch.com/doc/shinygem/', 14 | newtab = TRUE 15 | ), 16 | menuItem( 17 | 'GitHub', 18 | icon = icon('github'), 19 | href = 'https://github.com/dm3ll3n/Shiny-GEM', 20 | newtab = TRUE 21 | ) 22 | )) 23 | --------------------------------------------------------------------------------