From daaa3a7bfc19248ebc387defd2e949efef05d8e3 Mon Sep 17 00:00:00 2001 From: Daniel Claborne Date: Fri, 4 Mar 2022 11:08:49 -0800 Subject: [PATCH 01/20] use corems branch of ftmsRanalysis --- Observers/startup_observers.R | 13 ++++++++++--- README.md | 2 +- renv.lock | 6 +++--- server.R | 8 ++++++-- 4 files changed, 20 insertions(+), 9 deletions(-) diff --git a/Observers/startup_observers.R b/Observers/startup_observers.R index 0e5474e..e855a0c 100644 --- a/Observers/startup_observers.R +++ b/Observers/startup_observers.R @@ -34,10 +34,17 @@ observe({ ) }) - names(fpaths) <- sapply(fpaths, basename) + names(fpaths) <- sapply(fpaths, function(x) basename(tools::file_path_sans_ext(x))) %>% + make.unique() + corems_revals[['combined_tables']] <- ftmsRanalysis::read_CoreMS_data( + unlist(fpaths), + sample_names = names(fpaths) + ) + for(name in names(fpaths)) { - corems_samples[[name]] <- read_csv(fpaths[[name]]) + corems_revals[['tables']][[name]] <- read_csv(fpaths[[name]]) + corems_revals[['fpaths']][[name]] <- fpaths[[name]] } modalmessage <- div(class = "column-scroll-sm", @@ -59,7 +66,7 @@ observe({ insertTab( "top_page", target = "Welcome", - tab = upload_tab(length(names(corems_samples)) > 0), + tab = upload_tab(length(corems_revals[['combined']]) > 0), position = "after" ) diff --git a/README.md b/README.md index 3e8fcde..2fb0736 100644 --- a/README.md +++ b/README.md @@ -58,7 +58,7 @@ corems_samples. #### 2. Using docker: Either build the container as described in the development section, or pull it from pnnl artifactory if you have access: -`docker login docker.artifactory.pnnl.gov` +`docker login docker.artifactory.pnnl.gov` `docker pull docker.artifactory.pnnl.gov/mscviz/freda:latest` Then run the docker container: `docker run -p 3838:3838 docker.artifactory.pnnl.gov/mscviz/freda:latest` diff --git a/renv.lock b/renv.lock index 26aba47..b79c7d0 100644 --- a/renv.lock +++ b/renv.lock @@ -74,9 +74,9 @@ "RemoteHost": "api.github.com", "RemoteRepo": "ftmsRanalysis", "RemoteUsername": "EMSL-computing", - "RemoteRef": "HEAD", - "RemoteSha": "6df6a14b2fbeb14f9578b058ba83dee2aba24b7b", - "Hash": "205ba328b26ecddbf46a14c5617385d2" + "RemoteRef": "CoreMS-compatibility", + "RemoteSha": "66352c9d71266564286032a515f18453cee0fdc0", + "Hash": "d4e9324869317775393099b9d3603c4e" }, "ggplot2": { "Package": "ggplot2", diff --git a/server.R b/server.R index 898e61a..5b7e042 100644 --- a/server.R +++ b/server.R @@ -104,8 +104,12 @@ shinyServer(function(session, input, output) { ) #' @details core-ms files loaded through a header parameter that points to a - #' 'folder' in minio containing all files. - corems_samples <- reactiveValues() + #' 'folder' in minio containing all files. + #' + #' @name data csv's resulting from read_csv() on the downloaded files from minio + #' @name fpaths The temp filepaths of the files downloaded from minio + corems_revals <- reactiveValues(tables = list(), + fpaths = list()) # Reload objects for debugging if they exist observeEvent(input$debug_reload,{ From c79ce2062f8f790b36fd39b16a6f3386d49df842 Mon Sep 17 00:00:00 2001 From: Daniel Claborne Date: Fri, 4 Mar 2022 14:05:47 -0800 Subject: [PATCH 02/20] create ftms objects from corems checkpoint --- Observers/startup_observers.R | 2 +- Reactive_Variables/corems_revals.R | 40 ++++++++++ srv_ui_elements/corems_UI.R | 111 ++++++++++++++++++++++++++ tab_factories/upload_tab.R | 120 ++++++++++++++++++++++++++++- 4 files changed, 268 insertions(+), 5 deletions(-) create mode 100644 Reactive_Variables/corems_revals.R create mode 100644 srv_ui_elements/corems_UI.R diff --git a/Observers/startup_observers.R b/Observers/startup_observers.R index e855a0c..5d63bf1 100644 --- a/Observers/startup_observers.R +++ b/Observers/startup_observers.R @@ -66,7 +66,7 @@ observe({ insertTab( "top_page", target = "Welcome", - tab = upload_tab(length(corems_revals[['combined']]) > 0), + tab = upload_tab(length(corems_revals[['combined_tables']]) > 0), position = "after" ) diff --git a/Reactive_Variables/corems_revals.R b/Reactive_Variables/corems_revals.R new file mode 100644 index 0000000..e8b8ed3 --- /dev/null +++ b/Reactive_Variables/corems_revals.R @@ -0,0 +1,40 @@ +#'@details The columns of the table resulting from reading in the multiple +#'corems files +corems_cols <- reactive({ + req(corems_revals[['combined_tables']]) + colnames(corems_revals[['combined_tables']]) +}) + +# create CoreMSData object upon button click +cms_data <- eventReactive(input$make_cmsdata, { + req(corems_revals[['combined_tables']]) + if (input$c13_cname == "Column not present") {c13 <- NULL} else {c13 <- input$c13_cname} + if (input$o18_cname == "Column not present") {o18 <- NULL} else {o18 <- input$o18_cname} + if (input$n15_cname == "Column not present") {n15 <- NULL} else {n15 <- input$n15_cname} + if (input$s34_cname == "Column not present") {s34 <- NULL} else {s34 <- input$s34_cname} + cms_dat <- as.CoreMSData(corems_revals[['combined_tables']], + c13_cname = c13, + o18_cname = o18, + n15_cname = n15, + s34_cname = s34) + return(cms_dat) +}) + +#'@details create conf_filt object for confidence filtering panel +conf_filt_obj <- reactive({ + conf_filter(cms_data()) +}) + +#' @details The filtered corems data. +cms_data_filtered <- eventReactive(input$apply_conf_filter, { + applyFilt(conf_filt_obj(), cms_data(), min_conf = input$min_conf) +}) + +########## Unique MF Assignment Tab ########## +cms_dat_unq_mf <- eventReactive(input$unique_mf, { + if (input$unq_mf_method == "Confidence score") {method <- "confidence"} + if (input$unq_mf_method == "Peak height") {method <- "peak_intensity"} + + unq_dat <- unique_mf_assingment(cms_data_filtered(), method) + return(unq_dat) +}) \ No newline at end of file diff --git a/srv_ui_elements/corems_UI.R b/srv_ui_elements/corems_UI.R new file mode 100644 index 0000000..e1c3993 --- /dev/null +++ b/srv_ui_elements/corems_UI.R @@ -0,0 +1,111 @@ +output$index_cname <- renderUI({ + selectInput("index_cname", "Index Column:", + choices = c("Select one", corems_cols())) +}) + +output$obs_mass_cname <- renderUI({ + selectInput("obs_mass_cname", "Observed Mass Column:", + choices = c("Select one", corems_cols())) +}) + +output$calc_mass_cname <- renderUI({ + selectInput("calc_mass_cname", "Calculated Mass Column:", + choices = c("Select one", corems_cols())) +}) + +output$pheight_cname <- renderUI({ + selectInput("pheight_cname", "Peak Height Column:", + choices = c("Select one", corems_cols())) +}) + +output$error_cname <- renderUI({ + selectInput("error_cname", "Mass Error Column:", + choices = c("Select one", corems_cols())) +}) + +output$conf_cname <- renderUI({ + selectInput("conf_cname", "Confidence Score Column:", + choices = c("Select one", corems_cols())) +}) + +output$file_cname <- renderUI({ + selectInput("file_cname", "Filename/Sample Column:", + choices = c("Select one", corems_cols())) +}) + +output$mono_index_cname <- renderUI({ + selectInput("mono_index_cname", "Mono Isotopic Index Column:", + choices = c("Select one", corems_cols())) +}) + +output$mf_cname <- renderUI({ + selectInput("mf_cname", "Molecular Formula Column:", + choices = c("Select one", corems_cols())) +}) + +output$c13_cname <- renderUI({ + selectInput("c13_cname", "C13 Column:", + choices = c("Select one", "Column not present", corems_cols())) +}) + +output$o18_cname <- renderUI({ + selectInput("o18_cname", "O18 Column:", + choices = c("Select one", "Column not present", corems_cols())) +}) + +output$n15_cname <- renderUI({ + selectInput("n15_cname", "N15 Column:", + choices = c("Select one", "Column not present", corems_cols())) +}) + +output$s34_cname <- renderUI({ + selectInput("s34_cname", "S34 Column:", + choices = c("Select one", "Column not present", corems_cols())) +}) + +output$cms_raw_data <- DT::renderDT( + corems_revals[['combined_tables']], + options = list(dom = 'ftp', + scrollX = TRUE) +) + +#'@details display plot of unique masses per sample +#'@app_location CoreMS Creation Tab +output$cmsdat_plot <- renderPlotly({ + req(cms_data()) + plot(cms_data()) +}) + +#'@details data table with kept/removed peaks +#'@app_location Confidence Filtering Tab +output$filt_peaks_dt <- DT::renderDT( + ftmsRanalysis:::conf_filter_dt(cms_data(), input$min_conf), + options = list(dom = 't') +) + +#'@details Plot of filtered corems data +#'@app_location Confidence Filtering Tab +output$cms_filt_plot <- renderPlotly({ + validate(need(cms_data_filtered(), "Create your filtered data to view filter plot")) + plot(cms_data_filtered()) +}) + +#'@details display mass error plot with min_conf slider values +#'@app_location Confidence Filtering Tab +output$me_plot <- renderPlotly({ + mass_error_plot(cms_data(), min_conf = input$min_conf) +}) + +#'@details Molecular formula plot +#'@app_location Unique molecular formula assignment tab +output$mf_plot <- renderPlotly({ + validate(need(cms_dat_unq_mf(), "Please assign molecular formulae to your CoreMS data")) + plot(cms_dat_unq_mf()) +}) + +#'@details Button to convert corems data to ftmsRanalysis peakData +#'@app_location Convert to peakdata tab +output$corems_to_peakdata_UI <- renderUI({ + validate(need(cms_dat_unq_mf(), "Please assign molecular formulae to your CoreMS data")) + actionButton("corems_to_peakdata", "Convert to peak data") +}) \ No newline at end of file diff --git a/tab_factories/upload_tab.R b/tab_factories/upload_tab.R index 0402733..7a59e8c 100644 --- a/tab_factories/upload_tab.R +++ b/tab_factories/upload_tab.R @@ -5,10 +5,7 @@ #' upload_tab <- function(from_corems = FALSE) { if(from_corems) { - navbarMenu("Core-MS Processing", - tabPanel("tab1", HTML("This is a tab")), - tabPanel("tab2", HTML("This is another tab")) - ) + corems_tabs() } else { tabPanel(div("Upload", icon('upload')), value = 'Upload', fluidRow( @@ -161,4 +158,119 @@ upload_tab <- function(from_corems = FALSE) { )) } +} + +corems_tabs <- function() { + navbarMenu("Core-MS Processing", + tabPanel("Create CoreMS Object", + fluidRow( + ## Sidebar panel on Upload tab ## + column(width = 4, + bsCollapse( + id = 'upload_collapse', open = c('Upload Data'), multiple = TRUE, + bsCollapsePanel( + title = "Specify Column Names", + div(id = 'specify_colnames', + uiOutput("index_cname"), + uiOutput("obs_mass_cname"), + uiOutput("calc_mass_cname"), + uiOutput("pheight_cname"), + uiOutput("error_cname"), + uiOutput("conf_cname"), + uiOutput("file_cname"), + uiOutput("mono_index_cname"), + uiOutput("mf_cname"), + uiOutput("c13_cname"), + uiOutput("o18_cname"), + uiOutput("n15_cname"), + uiOutput("s34_cname") + ) # end div + ) # end Collapse Panel + ), # end bsCollapse + + shiny::actionButton("make_cmsdata", + "Create CoreMSData Object", + icon = icon("cog"), + lib = "glyphicon") + ), # end sidebar column + + # main panel + column(width = 8, + # keeps table compact on page, no line wrapping: + tags$head(tags$style("#raw_data {white-space: nowrap; }")), + DT::dataTableOutput("cms_raw_data"), + plotlyOutput("cmsdat_plot") + ) # end main column + ) # end fluidRow + ), + ###################### Confidence Filter Panel ###################### + tabPanel("Confidence Filter", + fluidRow( + # sidebar column + column(width = 4, + bsCollapse(id = "filter_collapse", open = c("conf_thresh"), multiple = TRUE, + bsCollapsePanel( + title = "Select Confidence Threshold", + value = "conf_thresh", + + sliderInput(inputId = "min_conf", + label = "Minimum confidence score:", + min = 0, + max = 1, + value = .5) + ) # end collapse panel + ), # end collapse + + shiny::actionButton("apply_conf_filter", + "Filter Data", + icon = icon("cog"), + lib = "glyphicon"), + + shiny::actionButton("reset_filter", + "Reset Filter", + icon = icon("trash"), + lib = "glyphicon") + + ), # end sidebar column + + column(width = 8, + DT::dataTableOutput("filt_peaks_dt"), + plotlyOutput("me_plot"), + plotlyOutput("cms_filt_plot") + + ) # end main column + ) # end fluidRow + ), # end conf filter tabPanel + + ###################### Unique Formula Assingment Panel ###################### + tabPanel("Formula Assignment", + fluidRow( + # sidebar column + column(width = 4, + bsCollapse(id = 'unq_mf_collapse', open = "unq_mf_assign", multiple = TRUE, + bsCollapsePanel(title = "Unique Molecular Formula Assignment", + value = "unq_mf_assign", + + selectInput("unq_mf_method", label = "Method:", + choices = c("Select Method", "Confidence score", "Peak height")) + ) # end collapse panel + ), # end collapse + shiny::actionButton("unique_mf", + "Assign Unique Formula", + icon = icon("cog"), + lib = "glyphicon") + + ), # end sidebar column + + # main column + column(width = 8, + plotlyOutput("mf_plot") + ) # close main column + ) # close fluidrow + ), # close unique mf tabPanel + tabPanel( + "Convert to Peak Data", + uiOutput("corems_to_peakdata_UI") + ) + ) } \ No newline at end of file From 6c5fd826e480451d1e67a5a8eee9f064027bc9c5 Mon Sep 17 00:00:00 2001 From: Daniel Claborne Date: Fri, 2 Sep 2022 14:45:31 -0700 Subject: [PATCH 03/20] create ftms data from coreMS object --- Observers/corems_observers.R | 24 ++++++++++++++++++++++++ Observers/download_observers.R | 2 +- Observers/startup_observers.R | 3 ++- Reactive_Variables/corems_revals.R | 2 +- Reactive_Variables/upload_revals.R | 13 +++++++++---- 5 files changed, 37 insertions(+), 7 deletions(-) create mode 100644 Observers/corems_observers.R diff --git a/Observers/corems_observers.R b/Observers/corems_observers.R new file mode 100644 index 0000000..be229da --- /dev/null +++ b/Observers/corems_observers.R @@ -0,0 +1,24 @@ +#'@details Convert the filtered corems data to peakData +#'cms_dat_unq_mf() is converted into peakData using CoreMSData_to_ftmsData and +#'the result is stored in revals$uploaded_data +observeEvent(input$corems_to_peakdata, { + req(cms_dat_unq_mf()) + + res <- tryCatch({ + ftmsRanalysis::CoreMSData_to_ftmsData(cms_dat_unq_mf()) + }, + error = function(e){ + msg = paste0('Error converting your coreMS data to peakData: \n System error: ', e) + revals$warningmessage_corems$corems_to_peakdata <<- sprintf("

%s

", msg) + NULL + }) + + if(!is.null(res)){ + # need a fake f_data column. + if(ncol(res$f_data) == 1) { + res$f_data[,2] <- NA + } + + revals$uploaded_data <- res + } +}) \ No newline at end of file diff --git a/Observers/download_observers.R b/Observers/download_observers.R index 474a166..efd5ccd 100644 --- a/Observers/download_observers.R +++ b/Observers/download_observers.R @@ -19,7 +19,7 @@ observeEvent(input$makezipfile,{ if (input$report_selection == TRUE & !is.null(revals$peakData2)){ tryCatch({ fs <- c(fs, file.path(tempdir(), "report.html")) - report(revals$uploaded_data, revals$peakData2, Emeta(), output_file = file.path(tempdir(), "report.html"), output_format = "html_document", + report(revals$uploaded_data, revals$peakData2, revals$uploaded_data$e_meta, output_file = file.path(tempdir(), "report.html"), output_format = "html_document", C13_ID = input$iso_symbol, groups_list = revals$groups_list, db_tables_info = tables$saved_db_info) }, error = function(e){ diff --git a/Observers/startup_observers.R b/Observers/startup_observers.R index 5d63bf1..bcffb96 100644 --- a/Observers/startup_observers.R +++ b/Observers/startup_observers.R @@ -5,7 +5,8 @@ observe({ # establish minio connection if we are pulling cloud resources if(any(names(query) %in% VALID_MINIO_HEADER_PARAMS)) { - minio_con <<- mapDataAccess::map_data_connection("./cfg/minio_config.yml") + cfg_location = if(Sys.getenv("MINIO_CONFIG_PATH") == "") "./cfg/minio_config.yml" else Sys.getenv("MINIO_CONFIG_PATH") + minio_con <<- mapDataAccess::map_data_connection(cfg_location) } isolate({ diff --git a/Reactive_Variables/corems_revals.R b/Reactive_Variables/corems_revals.R index e8b8ed3..6759474 100644 --- a/Reactive_Variables/corems_revals.R +++ b/Reactive_Variables/corems_revals.R @@ -35,6 +35,6 @@ cms_dat_unq_mf <- eventReactive(input$unique_mf, { if (input$unq_mf_method == "Confidence score") {method <- "confidence"} if (input$unq_mf_method == "Peak height") {method <- "peak_intensity"} - unq_dat <- unique_mf_assingment(cms_data_filtered(), method) + unq_dat <- unique_mf_assignment(cms_data_filtered(), method) return(unq_dat) }) \ No newline at end of file diff --git a/Reactive_Variables/upload_revals.R b/Reactive_Variables/upload_revals.R index 49aff1c..1bcb03b 100644 --- a/Reactive_Variables/upload_revals.R +++ b/Reactive_Variables/upload_revals.R @@ -1,5 +1,12 @@ # Object: Get e_data from file input Edata <- reactive({ + if(!is.null(revals$uploaded_data)) { + return(revals$uploaded_data$e_data %>% + dplyr::select(-dplyr::one_of( + ftmsRanalysis::getEDataColName(revals$uploaded_data) + ))) + } + # Error handling: Need file_edata path req(input$file_edata$datapath) @@ -29,15 +36,13 @@ Emeta <- reactive({ }) # End Emeta # # Object: Emeta column names -# Note: created when emeta is loaded/updated emeta_cnames <- reactive({names(Emeta())}) # Object: Sample names from e_data -# Note: This object is created when e_data and edata_id are entered sample_names <- reactive({ setdiff(edata_cnames(), input$edata_id_col) - -}) # End sample_names # +}) + # Create reactive fake f_data (used when action button creates peakData()) fdata <- reactive({ col2 <- rep(NA, length(sample_names())) From 0bf61ef05e89a365c8e725b06d6ab0242fe7efbd Mon Sep 17 00:00:00 2001 From: Daniel Claborne Date: Fri, 2 Sep 2022 15:10:35 -0700 Subject: [PATCH 04/20] enable downstream tabs if data source is CoreMS --- Observers/upload_observers.R | 4 ++-- tab_factories/upload_tab.R | 19 +++++++++++-------- 2 files changed, 13 insertions(+), 10 deletions(-) diff --git a/Observers/upload_observers.R b/Observers/upload_observers.R index 766b5ed..dd75c74 100644 --- a/Observers/upload_observers.R +++ b/Observers/upload_observers.R @@ -391,7 +391,7 @@ observeEvent(input$iso_info_filter,{ observeEvent(revals$uploaded_data,{ #Error handling: revals$uploaded_data must exist req(revals$uploaded_data) - req(input$top_page == 'Upload') + req(grepl('^Upload$|^CoreMS-', input$top_page)) #___test-export___ if (isTRUE(getOption("shiny.testmode"))) { @@ -403,7 +403,7 @@ observeEvent(revals$uploaded_data,{ title = "Upload Success", fluidRow( column(10, align = "center", offset = 1, - HTML('

Your data has been successfully uploaded. + HTML('

Your data object has been successfully created. You may proceed to the subsequent tabs for analysis.

'), hr(), actionButton("upload_dismiss", "Review results", width = '75%'), diff --git a/tab_factories/upload_tab.R b/tab_factories/upload_tab.R index 7a59e8c..af0a2cb 100644 --- a/tab_factories/upload_tab.R +++ b/tab_factories/upload_tab.R @@ -162,7 +162,9 @@ upload_tab <- function(from_corems = FALSE) { corems_tabs <- function() { navbarMenu("Core-MS Processing", - tabPanel("Create CoreMS Object", + tabPanel( + "Create CoreMS Object", + value = "CoreMS-create", fluidRow( ## Sidebar panel on Upload tab ## column(width = 4, @@ -204,7 +206,9 @@ corems_tabs <- function() { ) # end fluidRow ), ###################### Confidence Filter Panel ###################### - tabPanel("Confidence Filter", + tabPanel( + "Confidence Filter", + value = "CoreMS-conf-filter", fluidRow( # sidebar column column(width = 4, @@ -243,7 +247,9 @@ corems_tabs <- function() { ), # end conf filter tabPanel ###################### Unique Formula Assingment Panel ###################### - tabPanel("Formula Assignment", + tabPanel( + "Formula Assignment", + value = "CoreMS-formula-assign", fluidRow( # sidebar column column(width = 4, @@ -266,11 +272,8 @@ corems_tabs <- function() { column(width = 8, plotlyOutput("mf_plot") ) # close main column - ) # close fluidrow - ), # close unique mf tabPanel - tabPanel( - "Convert to Peak Data", + ), # close fluidrow uiOutput("corems_to_peakdata_UI") - ) + ) # close unique mf tabPanel ) } \ No newline at end of file From c8bddf5d572de592ad7a70fbab0067262fc67b3e Mon Sep 17 00:00:00 2001 From: Daniel Claborne Date: Tue, 6 Sep 2022 16:38:31 -0700 Subject: [PATCH 05/20] mutually exclusive dropdowns for as.CoreMSData arguments --- Reactive_Variables/corems_revals.R | 34 ++++-- global.R | 26 ++++ srv_ui_elements/corems_UI.R | 188 +++++++++++++++++++++-------- 3 files changed, 187 insertions(+), 61 deletions(-) diff --git a/Reactive_Variables/corems_revals.R b/Reactive_Variables/corems_revals.R index 6759474..2e1cb4e 100644 --- a/Reactive_Variables/corems_revals.R +++ b/Reactive_Variables/corems_revals.R @@ -8,15 +8,20 @@ corems_cols <- reactive({ # create CoreMSData object upon button click cms_data <- eventReactive(input$make_cmsdata, { req(corems_revals[['combined_tables']]) - if (input$c13_cname == "Column not present") {c13 <- NULL} else {c13 <- input$c13_cname} - if (input$o18_cname == "Column not present") {o18 <- NULL} else {o18 <- input$o18_cname} - if (input$n15_cname == "Column not present") {n15 <- NULL} else {n15 <- input$n15_cname} - if (input$s34_cname == "Column not present") {s34 <- NULL} else {s34 <- input$s34_cname} - cms_dat <- as.CoreMSData(corems_revals[['combined_tables']], - c13_cname = c13, - o18_cname = o18, - n15_cname = n15, - s34_cname = s34) + + args = list(corems_revals[['combined_tables']]) + + for(argname in COREMSDATA_ARGS) { + if(isTRUE(input[[argname]] == NULLSELECT__) | !isTruthy(input[[argname]])) { + args[[argname]] <- NULL + } else { + args[[argname]] <- input[[argname]] + } + } + + + cms_dat <- do.call(as.CoreMSData, args) + return(cms_dat) }) @@ -37,4 +42,15 @@ cms_dat_unq_mf <- eventReactive(input$unique_mf, { unq_dat <- unique_mf_assignment(cms_data_filtered(), method) return(unq_dat) +}) + +#' @details Columns selected for creating the coreMS object. Used to maintain +#' mutual exclusivity +selected_coremsData <- reactive({ + lapply(COREMSDATA_ARGS, function(x) input[[x]]) +}) + +#'@details Remaining choices for as.coreMSdata dropdowns +coreMS_remaining_choices <- reactive({ + setdiff(corems_cols(), selected_coremsData()) }) \ No newline at end of file diff --git a/global.R b/global.R index 8f99a9d..dea961e 100644 --- a/global.R +++ b/global.R @@ -55,3 +55,29 @@ info_text = list( # cloud/minio resources VALID_MINIO_HEADER_PARAMS = c("corems-prefix") + + +#'@SECTION Variables for selectors/inputs ## + +# Use this global variable for 'nothing selected' options +NULLSELECT__ = "__nullselect__" + +# list of arguments to be passed to as.CoreMSData that need an input picker +COREMSDATA_ARGS = c( + "index_cname", + "obs_mass_cname", + "calc_mass_cname", + "pheight_cname", + "error_cname", + "conf_cname", + "file_cname", + "monoiso_index_cname", + "mf_cname", + "c13_cname", + "o18_cname", + "n15cname", + "s34_cname" +) + + + diff --git a/srv_ui_elements/corems_UI.R b/srv_ui_elements/corems_UI.R index e1c3993..1776cc6 100644 --- a/srv_ui_elements/corems_UI.R +++ b/srv_ui_elements/corems_UI.R @@ -1,67 +1,151 @@ -output$index_cname <- renderUI({ - selectInput("index_cname", "Index Column:", - choices = c("Select one", corems_cols())) -}) +## +#' Dropdowns for arguments to as.CoreMSData, all are named as +#' output$ +#' + +mutually_exclusive_dropdown <- function(id, title, selected = NULL) { + renderUI({ + choices = union( + input[[id]], + coreMS_remaining_choices() + ) %>% setdiff(NULLSELECT__) + + choices = c("Select one" = NULLSELECT__, choices) + + if(any(!(selected %in% choices),isTRUE(input[[id]] != NULLSELECT__))) { + selected = input[[id]] + } + + pickerInput(id, + title, + choices = choices, + selected = selected + ) + }) +} + +output$index_cname <- mutually_exclusive_dropdown( + "index_cname", "Index Column:", "Index" +) -output$obs_mass_cname <- renderUI({ - selectInput("obs_mass_cname", "Observed Mass Column:", - choices = c("Select one", corems_cols())) -}) +# output$index_cname <- renderUI({ +# selectInput("index_cname", +# "Index Column:", +# choices = union( +# c("Select one", input$index_cname), +# coreMS_remaining_choices() +# ), +# selected = input$index_cname +# ) +# }) + +output$obs_mass_cname <- mutually_exclusive_dropdown( + "obs_mass_cname", "Observed Mass Column:", "m/z" +) +# output$obs_mass_cname <- renderUI({ +# selectInput("obs_mass_cname", "Observed Mass Column:", +# choices = c("Select one", corems_cols())) +# }) -output$calc_mass_cname <- renderUI({ - selectInput("calc_mass_cname", "Calculated Mass Column:", - choices = c("Select one", corems_cols())) -}) +output$calc_mass_cname <- mutually_exclusive_dropdown( + "calc_mass_cname", "Calculated Mass Column:", "Calculated m/z" +) -output$pheight_cname <- renderUI({ - selectInput("pheight_cname", "Peak Height Column:", - choices = c("Select one", corems_cols())) -}) +# output$calc_mass_cname <- renderUI({ +# selectInput("calc_mass_cname", "Calculated Mass Column:", +# choices = c("Select one", corems_cols())) +# }) -output$error_cname <- renderUI({ - selectInput("error_cname", "Mass Error Column:", - choices = c("Select one", corems_cols())) -}) +output$pheight_cname <- mutually_exclusive_dropdown( + "pheight_cname", "Peak Height Column:", "Peak Height" +) -output$conf_cname <- renderUI({ - selectInput("conf_cname", "Confidence Score Column:", - choices = c("Select one", corems_cols())) -}) +# output$pheight_cname <- renderUI({ +# selectInput("pheight_cname", "Peak Height Column:", +# choices = c("Select one", corems_cols())) +# }) -output$file_cname <- renderUI({ - selectInput("file_cname", "Filename/Sample Column:", - choices = c("Select one", corems_cols())) -}) +output$error_cname <- mutually_exclusive_dropdown( + "error_cname", "Mass Error Column:", "Mass Error (ppm)" +) +# +# output$error_cname <- renderUI({ +# selectInput("error_cname", "Mass Error Column:", +# choices = c("Select one", corems_cols())) +# }) -output$mono_index_cname <- renderUI({ - selectInput("mono_index_cname", "Mono Isotopic Index Column:", - choices = c("Select one", corems_cols())) -}) -output$mf_cname <- renderUI({ - selectInput("mf_cname", "Molecular Formula Column:", - choices = c("Select one", corems_cols())) -}) +output$conf_cname <- mutually_exclusive_dropdown( + "conf_cname", "Confidence Score Column:", "Confidence Score" +) -output$c13_cname <- renderUI({ - selectInput("c13_cname", "C13 Column:", - choices = c("Select one", "Column not present", corems_cols())) -}) +# output$conf_cname <- renderUI({ +# selectInput("conf_cname", "Confidence Score Column:", +# choices = c("Select one", corems_cols())) +# }) -output$o18_cname <- renderUI({ - selectInput("o18_cname", "O18 Column:", - choices = c("Select one", "Column not present", corems_cols())) -}) +output$file_cname <- mutually_exclusive_dropdown( + "file_cname", "Filename/Sample Column:", "Filename" +) -output$n15_cname <- renderUI({ - selectInput("n15_cname", "N15 Column:", - choices = c("Select one", "Column not present", corems_cols())) -}) +# output$file_cname <- renderUI({ +# selectInput("file_cname", "Filename/Sample Column:", +# choices = c("Select one", corems_cols())) +# }) -output$s34_cname <- renderUI({ - selectInput("s34_cname", "S34 Column:", - choices = c("Select one", "Column not present", corems_cols())) -}) +output$mono_index_cname <- mutually_exclusive_dropdown( + "mono_index_cname", "Mono Isotopic Index Column:", "Mono Isotopic Index" +) + +# output$mono_index_cname <- renderUI({ +# selectInput("mono_index_cname", "Mono Isotopic Index Column:", +# choices = c("Select one", corems_cols())) +# }) + +output$mf_cname <- mutually_exclusive_dropdown( + "mf_cname", "Molecular Formula Column:", "Molecular Formula" +) + +# output$mf_cname <- renderUI({ +# selectInput("mf_cname", "Molecular Formula Column:", +# choices = c("Select one", corems_cols())) +# }) + +output$c13_cname <- mutually_exclusive_dropdown( + "c13_cname", "C13 Column:", "13C" +) + +# output$c13_cname <- renderUI({ +# selectInput("c13_cname", "C13 Column:", +# choices = c("Select one", "Column not present", corems_cols())) +# }) + +output$o18_cname <- mutually_exclusive_dropdown( + "o18_cname", "O18 Column:", "18O" +) + +# output$o18_cname <- renderUI({ +# selectInput("o18_cname", "O18 Column:", +# choices = c("Select one", "Column not present", corems_cols())) +# }) + +output$n15_cname <- mutually_exclusive_dropdown( + "n15_cname", "N15 Column:", "15N" +) + +# output$n15_cname <- renderUI({ +# selectInput("n15_cname", "N15 Column:", +# choices = c("Select one", "Column not present", corems_cols())) +# }) + +output$s34_cname <- mutually_exclusive_dropdown( + "s34_cname", "S34 Column:", "34S" +) + +# output$s34_cname <- renderUI({ +# selectInput("s34_cname", "S34 Column:", +# choices = c("Select one", "Column not present", corems_cols())) +# }) output$cms_raw_data <- DT::renderDT( corems_revals[['combined_tables']], From 8790fbdbc457532999e8609735caed47e9cf4974 Mon Sep 17 00:00:00 2001 From: Daniel Claborne Date: Tue, 6 Sep 2022 16:54:54 -0700 Subject: [PATCH 06/20] loading mask --- Observers/startup_observers.R | 89 ++++++++++++++++++----------------- ui.R | 11 ++++- www/yeti.css | 23 +++++++++ 3 files changed, 79 insertions(+), 44 deletions(-) diff --git a/Observers/startup_observers.R b/Observers/startup_observers.R index bcffb96..4b22f38 100644 --- a/Observers/startup_observers.R +++ b/Observers/startup_observers.R @@ -9,6 +9,11 @@ observe({ minio_con <<- mapDataAccess::map_data_connection(cfg_location) } + on.exit({ + Sys.sleep(1) + hide("loading-gray-overlay") + }) + isolate({ # store header params in a reactive variable for(key in names(query)){ @@ -17,51 +22,50 @@ observe({ } if('corems-prefix' %in% names(query)) { - withProgress(message = "Loading core-ms files...", value = 1, { - uris <- reticulate::iterate( - minio_con$client$list_objects( - minio_con$bucket, - prefix = header_params[['corems-prefix']], - recursive = TRUE), - function(x) x$object_name - ) - - if(length(uris) > 0) { - tryCatch({ - fpaths <- lapply(uris, function(uri) { - mapDataAccess::get_file( - minio_con, id = uri, filename = file.path(tempfile(), basename(uri)), - use_dir = FALSE - ) - }) - - names(fpaths) <- sapply(fpaths, function(x) basename(tools::file_path_sans_ext(x))) %>% - make.unique() - - corems_revals[['combined_tables']] <- ftmsRanalysis::read_CoreMS_data( - unlist(fpaths), - sample_names = names(fpaths) - ) - - for(name in names(fpaths)) { - corems_revals[['tables']][[name]] <- read_csv(fpaths[[name]]) - corems_revals[['fpaths']][[name]] <- fpaths[[name]] - } - - modalmessage <- div(class = "column-scroll-sm", - HTML(info_text[["COREMS_UPLOAD_SUCCESS"]]), - HTML(paste(names(fpaths), collapse = "
")) + html(selector = "#loading-gray-overlay > div", html = "Loading Core-MS data...") + + uris <- reticulate::iterate( + minio_con$client$list_objects( + minio_con$bucket, + prefix = header_params[['corems-prefix']], + recursive = TRUE), + function(x) x$object_name + ) + + if(length(uris) > 0) { + tryCatch({ + fpaths <- lapply(uris, function(uri) { + mapDataAccess::get_file( + minio_con, id = uri, filename = file.path(tempfile(), basename(uri)), + use_dir = FALSE ) - }, error = function(e) { - modalmessage <<- div(sprintf(info_text[["COREMS_UPLOAD_ERROR"]], e)) }) - } else { - modalmessage <- div(info_text[["COREMS_UPLOAD_NOSAMPS"]]) - } - - showModal(modalDialog(modalmessage, title = "Core-MS Upload")) + + names(fpaths) <- sapply(fpaths, function(x) basename(tools::file_path_sans_ext(x))) %>% + make.unique() + + corems_revals[['combined_tables']] <- ftmsRanalysis::read_CoreMS_data( + unlist(fpaths), + sample_names = names(fpaths) + ) - }) + for(name in names(fpaths)) { + corems_revals[['tables']][[name]] <- read_csv(fpaths[[name]]) + corems_revals[['fpaths']][[name]] <- fpaths[[name]] + } + + modalmessage <- div(class = "column-scroll-sm", + HTML(info_text[["COREMS_UPLOAD_SUCCESS"]]), + HTML(paste(names(fpaths), collapse = "
")) + ) + }, error = function(e) { + modalmessage <<- div(sprintf(info_text[["COREMS_UPLOAD_ERROR"]], e)) + }) + } else { + modalmessage <- div(info_text[["COREMS_UPLOAD_NOSAMPS"]]) + } + + showModal(modalDialog(modalmessage, title = "Core-MS Upload")) } insertTab( @@ -70,6 +74,5 @@ observe({ tab = upload_tab(length(corems_revals[['combined_tables']]) > 0), position = "after" ) - }) }) diff --git a/ui.R b/ui.R index 47aa6e1..b8107c4 100644 --- a/ui.R +++ b/ui.R @@ -1,6 +1,15 @@ # Define UI and wrap everything in a taglist that first calls useShinyjs() -ui <- tagList(useShinyjs(), navbarPage( +ui <- tagList(useShinyjs(), + + # loading message + div( + id = "loading-gray-overlay", + class = "loading-mask", + div(class = "fadein-out busy relative-centered", style = "font-size:xx-large", "Loading app resources...") + ), + + navbarPage( title = tags$div("FREDA", tags$span(style = "font-size:small", "v1.0.7")), windowTitle = 'FREDA', id = "top_page", diff --git a/www/yeti.css b/www/yeti.css index a8e52ed..dec149f 100644 --- a/www/yeti.css +++ b/www/yeti.css @@ -7087,6 +7087,29 @@ ADDED BY YOURS TRULY #################### */ +/* Loading message mask for app startup */ +.loading-mask { + width: 100%; + height: 100%; + top: 0; + left: 0; + position: fixed; + background-color: rgba(255, 255, 255, 0.75); + z-index: 9999; + text-align: center; +} + +.relative-centered { + position: relative; + top: 40%; +} + +.busy { + color:deepskyblue; + font-weight:bold; + margin:5px 0; +} + /* misc. style adjustments */ From 2deb18840e498c4cb53efb014d255b2421416553 Mon Sep 17 00:00:00 2001 From: Daniel Claborne Date: Wed, 7 Sep 2022 15:13:24 -0700 Subject: [PATCH 07/20] Collapse panels for CoreMS-create tab Modals/buttons to move from corems upload -> create -> filter --- Observers/corems_observers.R | 26 ++++++++ Observers/startup_observers.R | 3 +- Reactive_Variables/corems_revals.R | 5 +- srv_ui_elements/corems_UI.R | 103 +++++++++-------------------- tab_factories/upload_tab.R | 22 ++++-- 5 files changed, 80 insertions(+), 79 deletions(-) diff --git a/Observers/corems_observers.R b/Observers/corems_observers.R index be229da..118ab5f 100644 --- a/Observers/corems_observers.R +++ b/Observers/corems_observers.R @@ -21,4 +21,30 @@ observeEvent(input$corems_to_peakdata, { revals$uploaded_data <- res } +}) + +#'@details Show a modal for the completion of corems data +observeEvent(cms_data(), { + req(cms_data(), input$top_page == "CoreMS-create") + + updateCollapse(session, id = "corems-upload-summary-collapse", + open = c("corems-upload-visualize"), close = c("corems-upload-table")) + + showModal( + # defined in srv_ui_elements/corems_UI.R + corems_obj_creation_modal() + ) +}) + +#'@details Go to the corems filter tab from the object creation success tab. +observeEvent(input$goto_corems_filter, { + req(input$top_page == "CoreMS-create") + updateTabsetPanel(inputId = "top_page", selected = "CoreMS-conf-filter") + removeModal() +}) + +#'@details Move the user to the create CoreMSData tab after successful upload +observeEvent(input$goto_corems_creation, { + updateTabsetPanel(inputId = "top_page", selected = "CoreMS-create") + removeModal() }) \ No newline at end of file diff --git a/Observers/startup_observers.R b/Observers/startup_observers.R index 4b22f38..ccbfa01 100644 --- a/Observers/startup_observers.R +++ b/Observers/startup_observers.R @@ -65,7 +65,8 @@ observe({ modalmessage <- div(info_text[["COREMS_UPLOAD_NOSAMPS"]]) } - showModal(modalDialog(modalmessage, title = "Core-MS Upload")) + # defined in srv_ui_elements/corems_UI.R + showModal(corems_upload_modal(modalmessage)) } insertTab( diff --git a/Reactive_Variables/corems_revals.R b/Reactive_Variables/corems_revals.R index 2e1cb4e..19f0498 100644 --- a/Reactive_Variables/corems_revals.R +++ b/Reactive_Variables/corems_revals.R @@ -5,12 +5,13 @@ corems_cols <- reactive({ colnames(corems_revals[['combined_tables']]) }) -# create CoreMSData object upon button click +# Create CoreMSData object upon button click cms_data <- eventReactive(input$make_cmsdata, { req(corems_revals[['combined_tables']]) args = list(corems_revals[['combined_tables']]) + # Collect arguments specified by the user for(argname in COREMSDATA_ARGS) { if(isTRUE(input[[argname]] == NULLSELECT__) | !isTruthy(input[[argname]])) { args[[argname]] <- NULL @@ -19,7 +20,7 @@ cms_data <- eventReactive(input$make_cmsdata, { } } - + cms_dat <- do.call(as.CoreMSData, args) return(cms_dat) diff --git a/srv_ui_elements/corems_UI.R b/srv_ui_elements/corems_UI.R index 1776cc6..056e7ff 100644 --- a/srv_ui_elements/corems_UI.R +++ b/srv_ui_elements/corems_UI.R @@ -1,8 +1,39 @@ +#'@details Modal indicating corems data was successfully uploaded +corems_upload_modal <- function(modal_message) { + modalDialog( + modal_message, title = "Core-MS Upload Success", + footer = tagList( + div( + style = "float:left", + bsButton("goto_corems_creation", "Go to CoreMS-data creation tab") + ), + modalButton("Dismiss") + ) + ) +} + +#'@details Modal indicating ftmsRanalysis::CoreMSData was successfully created. +corems_obj_creation_modal <- function() { + modalDialog( + "Your CoreMS data object was successfully created, continue to filtering sub-tab or dismiss to review table/plots", + title = "Object Creation Success!", + footer = tagList( + div( + style = "float:left", + bsButton("goto_corems_filter", "Go to CoreMS filtering tab") + ), + modalButton("Dismiss") + ) + ) +} + ## #' Dropdowns for arguments to as.CoreMSData, all are named as #' output$ #' +#'Helper function to make a dropdown that is mutually exclusive with other +#'dropdowns that pull from the columns of the imported corems data. mutually_exclusive_dropdown <- function(id, title, selected = NULL) { renderUI({ choices = union( @@ -28,125 +59,55 @@ output$index_cname <- mutually_exclusive_dropdown( "index_cname", "Index Column:", "Index" ) -# output$index_cname <- renderUI({ -# selectInput("index_cname", -# "Index Column:", -# choices = union( -# c("Select one", input$index_cname), -# coreMS_remaining_choices() -# ), -# selected = input$index_cname -# ) -# }) - output$obs_mass_cname <- mutually_exclusive_dropdown( "obs_mass_cname", "Observed Mass Column:", "m/z" ) -# output$obs_mass_cname <- renderUI({ -# selectInput("obs_mass_cname", "Observed Mass Column:", -# choices = c("Select one", corems_cols())) -# }) output$calc_mass_cname <- mutually_exclusive_dropdown( "calc_mass_cname", "Calculated Mass Column:", "Calculated m/z" ) -# output$calc_mass_cname <- renderUI({ -# selectInput("calc_mass_cname", "Calculated Mass Column:", -# choices = c("Select one", corems_cols())) -# }) - output$pheight_cname <- mutually_exclusive_dropdown( "pheight_cname", "Peak Height Column:", "Peak Height" ) -# output$pheight_cname <- renderUI({ -# selectInput("pheight_cname", "Peak Height Column:", -# choices = c("Select one", corems_cols())) -# }) - output$error_cname <- mutually_exclusive_dropdown( "error_cname", "Mass Error Column:", "Mass Error (ppm)" ) -# -# output$error_cname <- renderUI({ -# selectInput("error_cname", "Mass Error Column:", -# choices = c("Select one", corems_cols())) -# }) - output$conf_cname <- mutually_exclusive_dropdown( "conf_cname", "Confidence Score Column:", "Confidence Score" ) -# output$conf_cname <- renderUI({ -# selectInput("conf_cname", "Confidence Score Column:", -# choices = c("Select one", corems_cols())) -# }) - output$file_cname <- mutually_exclusive_dropdown( "file_cname", "Filename/Sample Column:", "Filename" ) -# output$file_cname <- renderUI({ -# selectInput("file_cname", "Filename/Sample Column:", -# choices = c("Select one", corems_cols())) -# }) - output$mono_index_cname <- mutually_exclusive_dropdown( "mono_index_cname", "Mono Isotopic Index Column:", "Mono Isotopic Index" ) -# output$mono_index_cname <- renderUI({ -# selectInput("mono_index_cname", "Mono Isotopic Index Column:", -# choices = c("Select one", corems_cols())) -# }) - output$mf_cname <- mutually_exclusive_dropdown( "mf_cname", "Molecular Formula Column:", "Molecular Formula" ) -# output$mf_cname <- renderUI({ -# selectInput("mf_cname", "Molecular Formula Column:", -# choices = c("Select one", corems_cols())) -# }) - output$c13_cname <- mutually_exclusive_dropdown( "c13_cname", "C13 Column:", "13C" ) -# output$c13_cname <- renderUI({ -# selectInput("c13_cname", "C13 Column:", -# choices = c("Select one", "Column not present", corems_cols())) -# }) - output$o18_cname <- mutually_exclusive_dropdown( "o18_cname", "O18 Column:", "18O" ) -# output$o18_cname <- renderUI({ -# selectInput("o18_cname", "O18 Column:", -# choices = c("Select one", "Column not present", corems_cols())) -# }) - output$n15_cname <- mutually_exclusive_dropdown( "n15_cname", "N15 Column:", "15N" ) -# output$n15_cname <- renderUI({ -# selectInput("n15_cname", "N15 Column:", -# choices = c("Select one", "Column not present", corems_cols())) -# }) - output$s34_cname <- mutually_exclusive_dropdown( "s34_cname", "S34 Column:", "34S" ) -# output$s34_cname <- renderUI({ -# selectInput("s34_cname", "S34 Column:", -# choices = c("Select one", "Column not present", corems_cols())) -# }) - +#'@details Preview table output$cms_raw_data <- DT::renderDT( corems_revals[['combined_tables']], options = list(dom = 'ftp', diff --git a/tab_factories/upload_tab.R b/tab_factories/upload_tab.R index af0a2cb..aabc85c 100644 --- a/tab_factories/upload_tab.R +++ b/tab_factories/upload_tab.R @@ -169,8 +169,9 @@ corems_tabs <- function() { ## Sidebar panel on Upload tab ## column(width = 4, bsCollapse( - id = 'upload_collapse', open = c('Upload Data'), multiple = TRUE, + id = 'corems-upload-collapse', open = c("input_args"), multiple = TRUE, bsCollapsePanel( + value = "input_args", title = "Specify Column Names", div(id = 'specify_colnames', uiOutput("index_cname"), @@ -198,10 +199,21 @@ corems_tabs <- function() { # main panel column(width = 8, - # keeps table compact on page, no line wrapping: - tags$head(tags$style("#raw_data {white-space: nowrap; }")), - DT::dataTableOutput("cms_raw_data"), - plotlyOutput("cmsdat_plot") + bsCollapse( + id = "corems-upload-summary-collapse", + open = c("corems-upload-table", "corems-upload-visualize"), + multiple = TRUE, + bsCollapsePanel( + title = "Table Summary", value = "corems-upload-table", + # keeps table compact on page, no line wrapping: + tags$head(tags$style("#raw_data {white-space: nowrap; }")), + DT::dataTableOutput("cms_raw_data") + ), + bsCollapsePanel( + title = "Plot Summary", value = "corems-upload-visualize", + withSpinner(plotlyOutput("cmsdat_plot"), color = "deepskyblue", type = 8) + ) + ) ) # end main column ) # end fluidRow ), From e76f104d1f1594f3069083405bca429230363271 Mon Sep 17 00:00:00 2001 From: Daniel Claborne Date: Wed, 7 Sep 2022 15:37:13 -0700 Subject: [PATCH 08/20] modals, collapse/tab-panels, and progress-control for Core-MS filter tab --- Observers/corems_observers.R | 16 ++++++++++++++++ srv_ui_elements/corems_UI.R | 15 +++++++++++++++ tab_factories/upload_tab.R | 32 +++++++++++++++++++++++++++----- 3 files changed, 58 insertions(+), 5 deletions(-) diff --git a/Observers/corems_observers.R b/Observers/corems_observers.R index 118ab5f..5e1c9d2 100644 --- a/Observers/corems_observers.R +++ b/Observers/corems_observers.R @@ -47,4 +47,20 @@ observeEvent(input$goto_corems_filter, { observeEvent(input$goto_corems_creation, { updateTabsetPanel(inputId = "top_page", selected = "CoreMS-create") removeModal() +}) + +#'@details (CoreMS filter tab) Show summary plot and show progression modal +observeEvent(cms_data_filtered(), { + req(cms_data_filtered()) + updateCollapse(session, id = "corems-filter-summary-collapse", + open = c("viz")) + updateTabsetPanel(inputId = "corems-viz-tabset", selected = "filt_summary_plot") + + showModal(corems_filter_modal()) +}) + +#'@details Move user to the formula assignment tab after successful filtering +observeEvent(input$goto_corems_formula, { + updateTabsetPanel(inputId = "top_page", selected = "CoreMS-formula-assign") + removeModal() }) \ No newline at end of file diff --git a/srv_ui_elements/corems_UI.R b/srv_ui_elements/corems_UI.R index 056e7ff..6f34533 100644 --- a/srv_ui_elements/corems_UI.R +++ b/srv_ui_elements/corems_UI.R @@ -27,6 +27,21 @@ corems_obj_creation_modal <- function() { ) } +#'@details Modal indicating ftmsRanalysis::conf_filter was successfully applied. +corems_filter_modal <- function() { + modalDialog( + "Your CoreMS data object was successfully filtered, continue to formula assignment sub-tab or dismiss to review table/plots", + title = "Filter Success!", + footer = tagList( + div( + style = "float:left", + bsButton("goto_corems_formula", "Go to CoreMS formula assignment tab") + ), + modalButton("Dismiss") + ) + ) +} + ## #' Dropdowns for arguments to as.CoreMSData, all are named as #' output$ diff --git a/tab_factories/upload_tab.R b/tab_factories/upload_tab.R index aabc85c..8dcc37a 100644 --- a/tab_factories/upload_tab.R +++ b/tab_factories/upload_tab.R @@ -224,7 +224,7 @@ corems_tabs <- function() { fluidRow( # sidebar column column(width = 4, - bsCollapse(id = "filter_collapse", open = c("conf_thresh"), multiple = TRUE, + bsCollapse(id = "corems-filter-sidebar-collapse", open = c("conf_thresh"), multiple = TRUE, bsCollapsePanel( title = "Select Confidence Threshold", value = "conf_thresh", @@ -250,10 +250,32 @@ corems_tabs <- function() { ), # end sidebar column column(width = 8, - DT::dataTableOutput("filt_peaks_dt"), - plotlyOutput("me_plot"), - plotlyOutput("cms_filt_plot") - + bsCollapse( + id = "corems-filter-summary-collapse", + open = c("table", "viz"), multiple = TRUE, + bsCollapsePanel( + "Table Summary", + value = "table", + DT::dataTableOutput("filt_peaks_dt") + ), + bsCollapsePanel( + "Visualizations", + "viz", + tabsetPanel( + id = "corems-viz-tabset", + tabPanel( + "Mass Error Plot", + value = "me_plot", + plotlyOutput("me_plot") + ), + tabPanel( + "Filtered Data Plot", + value = "filt_summary_plot", + plotlyOutput("cms_filt_plot") + ) + ) + ) + ) ) # end main column ) # end fluidRow ), # end conf filter tabPanel From 2607f55674223bbd0594a9ec79c9e364539c3f0c Mon Sep 17 00:00:00 2001 From: Daniel Claborne Date: Thu, 8 Sep 2022 16:33:21 -0700 Subject: [PATCH 09/20] assign formulas to create peakData from CoreMS progression collapsePanels and table summary on assign formulas page --- .gitignore | 5 ++++ Observers/corems_observers.R | 40 ++++++++++++++++++++++---- Reactive_Variables/corems_revals.R | 1 + srv_ui_elements/corems_UI.R | 46 ++++++++++++++++++++++++++++-- tab_factories/upload_tab.R | 31 ++++++++++++++++++-- ui.R | 3 ++ www/yeti.css | 7 +++++ 7 files changed, 122 insertions(+), 11 deletions(-) diff --git a/.gitignore b/.gitignore index 6921adc..13896df 100644 --- a/.gitignore +++ b/.gitignore @@ -36,3 +36,8 @@ tests/test_*/ script_dump.R packrat/lib*/ Data/ +untracked_resources +.renvignore +cfg +!cfg/minio_config_example.yml +renv diff --git a/Observers/corems_observers.R b/Observers/corems_observers.R index 5e1c9d2..671df9f 100644 --- a/Observers/corems_observers.R +++ b/Observers/corems_observers.R @@ -1,8 +1,16 @@ #'@details Convert the filtered corems data to peakData #'cms_dat_unq_mf() is converted into peakData using CoreMSData_to_ftmsData and #'the result is stored in revals$uploaded_data -observeEvent(input$corems_to_peakdata, { +observeEvent( + c( + input$corems_to_peakdata, + input$corems_to_peakdata_modal + ),{ + req(cms_dat_unq_mf()) + req(isTruthy(input$corems_to_peakdata > 0) | isTruthy(input$corems_to_peakdata_modal > 0)) + + revals$uploaded_data <- revals$peakData2 <- NULL res <- tryCatch({ ftmsRanalysis::CoreMSData_to_ftmsData(cms_dat_unq_mf()) @@ -10,18 +18,30 @@ observeEvent(input$corems_to_peakdata, { error = function(e){ msg = paste0('Error converting your coreMS data to peakData: \n System error: ', e) revals$warningmessage_corems$corems_to_peakdata <<- sprintf("

%s

", msg) - NULL + revals$warningmessage_corems$corems_to_peakdata }) - if(!is.null(res)){ + if(inherits(res, "peakData")){ # need a fake f_data column. if(ncol(res$f_data) == 1) { res$f_data[,2] <- NA } revals$uploaded_data <- res + } else { + if(inherits(res, "character")) { + msg = res + } else { + msg = "Error converting your coreMS data to peakData" + } + + showNotification( + HTML(msg), + duration = NULL, + type = "error" + ) } -}) +}, ignoreInit = T) #'@details Show a modal for the completion of corems data observeEvent(cms_data(), { @@ -63,4 +83,14 @@ observeEvent(cms_data_filtered(), { observeEvent(input$goto_corems_formula, { updateTabsetPanel(inputId = "top_page", selected = "CoreMS-formula-assign") removeModal() -}) \ No newline at end of file +}) + +#'@details display table visualization panels and prompt user for next steps +#'when unique molecular formula are assigned. +observeEvent(cms_dat_unq_mf(), { + hide("corems_to_peakdata_toggle") + req(cms_dat_unq_mf()) + updateCollapse(session, id = "corems-assign-formula", open = c("viz", "tables")) + showModal(corems_unq_mf_modal()) + show("corems_to_peakdata_toggle") +}) diff --git a/Reactive_Variables/corems_revals.R b/Reactive_Variables/corems_revals.R index 19f0498..c613834 100644 --- a/Reactive_Variables/corems_revals.R +++ b/Reactive_Variables/corems_revals.R @@ -38,6 +38,7 @@ cms_data_filtered <- eventReactive(input$apply_conf_filter, { ########## Unique MF Assignment Tab ########## cms_dat_unq_mf <- eventReactive(input$unique_mf, { + req(input$unq_mf_method) if (input$unq_mf_method == "Confidence score") {method <- "confidence"} if (input$unq_mf_method == "Peak height") {method <- "peak_intensity"} diff --git a/srv_ui_elements/corems_UI.R b/srv_ui_elements/corems_UI.R index 6f34533..222d92a 100644 --- a/srv_ui_elements/corems_UI.R +++ b/srv_ui_elements/corems_UI.R @@ -42,6 +42,21 @@ corems_filter_modal <- function() { ) } +#'@details Modal indicating unique formulae have been assigned +corems_unq_mf_modal <- function() { + modalDialog( + "Unique molecular formula were assigned to your Core-MS object, convert your object to a peakData object to continue in FREDA, or dismiss to review.", + title = "Formulas Assigned!", + footer = tagList( + div( + style = "float:left", + actionButton("corems_to_peakdata_modal", "Convert your Core-MS data to peakData") + ), + modalButton("Dismiss") + ) + ) +} + ## #' Dropdowns for arguments to as.CoreMSData, all are named as #' output$ @@ -163,9 +178,34 @@ output$mf_plot <- renderPlotly({ plot(cms_dat_unq_mf()) }) +#'@details data table with kept/removed peaks +#'@app_location Confidence Filtering Tab +output$filt_peaks_dt <- DT::renderDT( + ftmsRanalysis:::conf_filter_dt(cms_data(), input$min_conf), + options = list(dom = 't') +) + +#'@details Isotopic peaks after formula assignment +#'@app_location Core-MS formula assignment tab +output$assign_formula_iso <- DT::renderDT({ + req(cms_dat_unq_mf()) + cms_dat_unq_mf()$iso_data + }, + options = list(dom = 't') +) + +#'@details Mono-isotopic peaks after formula assignment +#'@app_location Core-MS formula assignment tab +output$assign_formula_monoiso <- DT::renderDT({ + req(cms_dat_unq_mf()) + cms_dat_unq_mf()$monoiso_data +}, +options = list(dom = 't') +) + #'@details Button to convert corems data to ftmsRanalysis peakData -#'@app_location Convert to peakdata tab output$corems_to_peakdata_UI <- renderUI({ - validate(need(cms_dat_unq_mf(), "Please assign molecular formulae to your CoreMS data")) - actionButton("corems_to_peakdata", "Convert to peak data") + req(cms_dat_unq_mf()) + req(grepl("^CoreMS", input$top_page)) + actionButton("corems_to_peakdata", "Convert to peak data", class = "btn-primary") }) \ No newline at end of file diff --git a/tab_factories/upload_tab.R b/tab_factories/upload_tab.R index 8dcc37a..c6cf283 100644 --- a/tab_factories/upload_tab.R +++ b/tab_factories/upload_tab.R @@ -260,7 +260,7 @@ corems_tabs <- function() { ), bsCollapsePanel( "Visualizations", - "viz", + value = "viz", tabsetPanel( id = "corems-viz-tabset", tabPanel( @@ -292,7 +292,7 @@ corems_tabs <- function() { value = "unq_mf_assign", selectInput("unq_mf_method", label = "Method:", - choices = c("Select Method", "Confidence score", "Peak height")) + choices = c("Confidence score", "Peak height")) ) # end collapse panel ), # end collapse shiny::actionButton("unique_mf", @@ -304,10 +304,35 @@ corems_tabs <- function() { # main column column(width = 8, + bsCollapse( + id = "corems-assign-formula", + open = NULL, + multiple = TRUE, + bsCollapsePanel( + "Table Summary", + value = "tables", + tabsetPanel( + id = "corems-assign-formula-tables", + tabPanel( + "Mono-Isotopic Peaks", + value = "monoiso", + DTOutput("assign_formula_monoiso") + ), + tabPanel( + "Isotopic Peaks", + value = "iso", + DTOutput("assign_formula_iso") + ) + ) + ), + bsCollapsePanel( + "Visualizations", + value = "viz", plotlyOutput("mf_plot") + ) + ) ) # close main column ), # close fluidrow - uiOutput("corems_to_peakdata_UI") ) # close unique mf tabPanel ) } \ No newline at end of file diff --git a/ui.R b/ui.R index b8107c4..9b0ff64 100644 --- a/ui.R +++ b/ui.R @@ -537,6 +537,9 @@ ui <- tagList(useShinyjs(), ) ), + + hidden(div(id = "corems_to_peakdata_toggle", style = "position:fixed;left:15px;bottom:15px", uiOutput("corems_to_peakdata_UI"))), + div(id = "js_helpbutton", style = "position:absolute;top:3px;right:16px;z-index:1000;width:11%", div(style = 'float:right;width:25%', tipify( diff --git a/www/yeti.css b/www/yeti.css index dec149f..bb1d67a 100644 --- a/www/yeti.css +++ b/www/yeti.css @@ -7087,6 +7087,13 @@ ADDED BY YOURS TRULY #################### */ +/*centers the div that wraps all notifications*/ +#shiny-notification-panel { + position:fixed; + bottom: calc(4%); + left: calc(48%); +} + /* Loading message mask for app startup */ .loading-mask { width: 100%; From 647073ea2ee26c03aa825c244a5ada31f685fd2b Mon Sep 17 00:00:00 2001 From: Daniel Claborne Date: Fri, 9 Sep 2022 09:22:37 -0700 Subject: [PATCH 10/20] apply styler --- Observers/corems_observers.R | 98 +- Observers/database_observers.R | 294 +++-- Observers/download_observers.R | 128 +- Observers/filter_observers.R | 522 ++++---- Observers/global_observers.R | 380 +++--- Observers/groups_observers.R | 39 +- Observers/linked_plot_observers.R | 21 +- Observers/preprocess_observers.R | 252 ++-- Observers/qc_observers.R | 6 +- Observers/startup_observers.R | 52 +- Observers/upload_observers.R | 368 +++--- Observers/visualize_observers.R | 468 ++++--- Reactive_Variables/corems_revals.R | 32 +- Reactive_Variables/filter_revals.R | 52 +- Reactive_Variables/groups_revals.R | 28 +- Reactive_Variables/linked_plot_revals.R | 8 +- Reactive_Variables/misc_revals.R | 12 +- Reactive_Variables/preprocess_revals.R | 28 +- Reactive_Variables/upload_revals.R | 26 +- Reactive_Variables/visualize_revals.R | 143 ++- global.R | 13 +- helper_functions/database_utils.R | 40 +- helper_functions/report.R | 15 +- helper_functions/selection_addons.R | 41 +- helper_functions/summaryFilter.R | 78 +- helper_functions/summaryPreprocess.R | 68 +- server.R | 82 +- srv_ui_elements/corems_UI.R | 88 +- srv_ui_elements/database_UI.R | 136 +- srv_ui_elements/download_UI.R | 28 +- srv_ui_elements/filter_UI.R | 156 +-- srv_ui_elements/global_UI.R | 28 +- srv_ui_elements/groups_UI.R | 16 +- srv_ui_elements/preprocess_UI.R | 78 +- srv_ui_elements/qc_UI.R | 56 +- srv_ui_elements/upload_UI_mainpanel.R | 116 +- srv_ui_elements/upload_UI_sidebar.R | 122 +- .../visualize_UI_main_and_plot_opts.R | 232 ++-- srv_ui_elements/visualize_UI_misc.R | 18 +- srv_ui_elements/visualize_UI_sidebar.R | 210 ++-- srv_ui_elements/visualize_linked_plots_UI.R | 314 ++--- tab_factories/upload_tab.R | 460 +++---- ui.R | 1113 ++++++++--------- 43 files changed, 3224 insertions(+), 3241 deletions(-) diff --git a/Observers/corems_observers.R b/Observers/corems_observers.R index 671df9f..430dc44 100644 --- a/Observers/corems_observers.R +++ b/Observers/corems_observers.R @@ -1,92 +1,92 @@ -#'@details Convert the filtered corems data to peakData -#'cms_dat_unq_mf() is converted into peakData using CoreMSData_to_ftmsData and -#'the result is stored in revals$uploaded_data +#' @details Convert the filtered corems data to peakData +#' cms_dat_unq_mf() is converted into peakData using CoreMSData_to_ftmsData and +#' the result is stored in revals$uploaded_data observeEvent( c( input$corems_to_peakdata, input$corems_to_peakdata_modal - ),{ - - req(cms_dat_unq_mf()) - req(isTruthy(input$corems_to_peakdata > 0) | isTruthy(input$corems_to_peakdata_modal > 0)) - - revals$uploaded_data <- revals$peakData2 <- NULL - - res <- tryCatch({ - ftmsRanalysis::CoreMSData_to_ftmsData(cms_dat_unq_mf()) - }, - error = function(e){ - msg = paste0('Error converting your coreMS data to peakData: \n System error: ', e) - revals$warningmessage_corems$corems_to_peakdata <<- sprintf("

%s

", msg) - revals$warningmessage_corems$corems_to_peakdata - }) - - if(inherits(res, "peakData")){ - # need a fake f_data column. - if(ncol(res$f_data) == 1) { - res$f_data[,2] <- NA - } - - revals$uploaded_data <- res - } else { - if(inherits(res, "character")) { - msg = res + ), { + + req(cms_dat_unq_mf()) + req(isTruthy(input$corems_to_peakdata > 0) | isTruthy(input$corems_to_peakdata_modal > 0)) + + revals$uploaded_data <- revals$peakData2 <- NULL + + res <- tryCatch({ + ftmsRanalysis::CoreMSData_to_ftmsData(cms_dat_unq_mf()) + }, + error = function(e) { + msg = paste0('Error converting your coreMS data to peakData: \n System error: ', e) + revals$warningmessage_corems$corems_to_peakdata <<- sprintf("

%s

", msg) + revals$warningmessage_corems$corems_to_peakdata + }) + + if (inherits(res, "peakData")) { + # need a fake f_data column. + if (ncol(res$f_data) == 1) { + res$f_data[, 2] <- NA + } + + revals$uploaded_data <- res } else { - msg = "Error converting your coreMS data to peakData" + if (inherits(res, "character")) { + msg = res + } else { + msg = "Error converting your coreMS data to peakData" + } + + showNotification( + HTML(msg), + duration = NULL, + type = "error" + ) } - - showNotification( - HTML(msg), - duration = NULL, - type = "error" - ) - } }, ignoreInit = T) -#'@details Show a modal for the completion of corems data +#' @details Show a modal for the completion of corems data observeEvent(cms_data(), { req(cms_data(), input$top_page == "CoreMS-create") - + updateCollapse(session, id = "corems-upload-summary-collapse", - open = c("corems-upload-visualize"), close = c("corems-upload-table")) - + open = c("corems-upload-visualize"), close = c("corems-upload-table")) + showModal( # defined in srv_ui_elements/corems_UI.R corems_obj_creation_modal() ) }) -#'@details Go to the corems filter tab from the object creation success tab. +#' @details Go to the corems filter tab from the object creation success tab. observeEvent(input$goto_corems_filter, { req(input$top_page == "CoreMS-create") updateTabsetPanel(inputId = "top_page", selected = "CoreMS-conf-filter") removeModal() }) -#'@details Move the user to the create CoreMSData tab after successful upload +#' @details Move the user to the create CoreMSData tab after successful upload observeEvent(input$goto_corems_creation, { updateTabsetPanel(inputId = "top_page", selected = "CoreMS-create") removeModal() }) -#'@details (CoreMS filter tab) Show summary plot and show progression modal +#' @details (CoreMS filter tab) Show summary plot and show progression modal observeEvent(cms_data_filtered(), { req(cms_data_filtered()) updateCollapse(session, id = "corems-filter-summary-collapse", - open = c("viz")) + open = c("viz")) updateTabsetPanel(inputId = "corems-viz-tabset", selected = "filt_summary_plot") - + showModal(corems_filter_modal()) }) -#'@details Move user to the formula assignment tab after successful filtering +#' @details Move user to the formula assignment tab after successful filtering observeEvent(input$goto_corems_formula, { updateTabsetPanel(inputId = "top_page", selected = "CoreMS-formula-assign") removeModal() }) -#'@details display table visualization panels and prompt user for next steps -#'when unique molecular formula are assigned. +#' @details display table visualization panels and prompt user for next steps +#' when unique molecular formula are assigned. observeEvent(cms_dat_unq_mf(), { hide("corems_to_peakdata_toggle") req(cms_dat_unq_mf()) diff --git a/Observers/database_observers.R b/Observers/database_observers.R index 346f896..76339b3 100644 --- a/Observers/database_observers.R +++ b/Observers/database_observers.R @@ -4,281 +4,281 @@ observeEvent(input$create_mapping, { on.exit({ enable('create_mapping') }) - + revals$warningmessage_database$mapping_error <<- NULL - + req(revals$peakData2, !is.null(attr(revals$peakData2, 'cnames')$mf_cname)) - - maxrecords = if(isTruthy(input$max_records_database)) input$max_records_database else Inf - + + maxrecords = if (isTruthy(input$max_records_database)) input$max_records_database else Inf + ######## KEGG ######### tryCatch({ - if(input$database_select == 'Kegg'){ - if(!exists('kegg_compounds')){ + if (input$database_select == 'Kegg') { + if (!exists('kegg_compounds')) { data('kegg_compounds') } - + # get list of all formulae and subset kegg_compounds to identified formulae - forms <- revals$peakData2$e_meta %>% - filter(!is.na(!!rlang::sym(getMFColName(revals$peakData2)))) %>% + forms <- revals$peakData2$e_meta %>% + filter(!is.na(!!rlang::sym(getMFColName(revals$peakData2)))) %>% dplyr::rename(FORMULA = !!rlang::sym(getMFColName(revals$peakData2))) %>% dplyr::select(getEDataColName(revals$peakData2), FORMULA) - + # peaks to compounds - kegg_sub <- forms %>% - left_join(kegg_compounds, by = 'FORMULA') %>% - group_by(FORMULA) %>% - mutate(n = n()) %>% - ungroup() %>% + kegg_sub <- forms %>% + left_join(kegg_compounds, by = 'FORMULA') %>% + group_by(FORMULA) %>% + mutate(n = n()) %>% + ungroup() %>% filter((!is.na(COMPOUND) | !is.na(REACTION)) & n <= maxrecords) %>% tibble::as_tibble() %>% dplyr::select(getEDataColName(revals$peakData2), COMPOUND, FORMULA, URL) %>% - mutate(URL = paste0("", 'compound link')) - - ### Three conditionals, each which add a column where each row element is a list of all related - - if('comp2react' %in% input$which_mappings){ - kegg_sub <- kegg_sub %>% + mutate(URL = paste0("", 'compound link')) + + ### Three conditionals, each which add a column where each row element is a list of all related + + if ('comp2react' %in% input$which_mappings) { + kegg_sub <- kegg_sub %>% mutate(REACTION = map(COMPOUND, newcol_from_mapping, maxlen = Inf, map_list = 'kegg_compound_reaction_map')) } - + # compounds to modules - if('react2mod' %in% input$which_mappings){ + if ('react2mod' %in% input$which_mappings) { validate(need('comp2react' %in% input$which_mappings, "If retrieving modules, you must also retrieve reactions.")) - kegg_sub <- kegg_sub %>% + kegg_sub <- kegg_sub %>% mutate(MODULE = map(REACTION, newcol_from_mapping, maxlen = Inf, map_list = 'kegg_reaction_module_map')) } - + # modules to pathways - if('mod2path' %in% input$which_mappings){ + if ('mod2path' %in% input$which_mappings) { validate(need(all(c('react2mod', 'comp2react') %in% input$which_mappings), "If retrieving pathways, you must also retrieve modules and reactions.")) - kegg_sub <- kegg_sub %>% + kegg_sub <- kegg_sub %>% mutate(PATHWAY = map(MODULE, newcol_from_mapping, maxlen = Inf, map_list = 'kegg_module_pathway_map')) } - + ## conditional block which unnests calculated columns based on unique row selection # If none, simply create semicolon separated values of the elements in the three list columns - if(input$which_unique == 'None'){ - if('REACTION' %in% colnames(kegg_sub)){ + if (input$which_unique == 'None') { + if ('REACTION' %in% colnames(kegg_sub)) { kegg_sub <- kegg_sub %>% mutate(REACTION = map(REACTION, list2semicolon)) } - if('MODULE' %in% colnames(kegg_sub)){ + if ('MODULE' %in% colnames(kegg_sub)) { kegg_sub <- kegg_sub %>% mutate(MODULE = map(MODULE, list2semicolon)) } - if('PATHWAY' %in% colnames(kegg_sub)){ + if ('PATHWAY' %in% colnames(kegg_sub)) { kegg_sub <- kegg_sub %>% mutate(PATHWAY = map(PATHWAY, list2semicolon)) } } # Unnests REACTION and creates ;-collapsed versions of MODULE and PATHWAY - else if(input$which_unique == 'REACTION'){ - kegg_sub <- kegg_sub %>% - tidyr::unnest(REACTION, .drop = F) %>% + else if (input$which_unique == 'REACTION') { + kegg_sub <- kegg_sub %>% + tidyr::unnest(REACTION, .drop = F) %>% tidyr::unnest(REACTION, .drop = F) - - if('MODULE' %in% colnames(kegg_sub)){ + + if ('MODULE' %in% colnames(kegg_sub)) { kegg_sub <- kegg_sub %>% mutate(MODULE = map(MODULE, list2semicolon)) } - - if('PATHWAY' %in% colnames(kegg_sub)){ + + if ('PATHWAY' %in% colnames(kegg_sub)) { kegg_sub <- kegg_sub %>% mutate(PATHWAY = map(PATHWAY, list2semicolon)) } - + # Display EC numbers if unique reactions - kegg_sub <- kegg_sub %>% - left_join(kegg_reactions %>% dplyr::select(REACTION, ENZYME)) %>% + kegg_sub <- kegg_sub %>% + left_join(kegg_reactions %>% dplyr::select(REACTION, ENZYME)) %>% mutate(ENZYME = gsub('[[:space:]]+', ';', ENZYME)) - + } # Unnests REACTION and MODULE and creates ;-collapsed versions of PATHWAY - else if(input$which_unique == 'MODULE'){ - if('REACTION' %in% colnames(kegg_sub)){ + else if (input$which_unique == 'MODULE') { + if ('REACTION' %in% colnames(kegg_sub)) { kegg_sub <- kegg_sub %>% - tidyr::unnest(REACTION, .drop = F) %>% + tidyr::unnest(REACTION, .drop = F) %>% tidyr::unnest(REACTION, .drop = F) } - - if('MODULE' %in% colnames(kegg_sub)){ + + if ('MODULE' %in% colnames(kegg_sub)) { kegg_sub <- kegg_sub %>% mutate(MODULE = map2(REACTION, MODULE, unnest_by_key)) %>% - tidyr::unnest(MODULE, .drop = F) %>% + tidyr::unnest(MODULE, .drop = F) %>% tidyr::unnest(MODULE, .drop = F) } - - if('PATHWAY' %in% colnames(kegg_sub)){ + + if ('PATHWAY' %in% colnames(kegg_sub)) { kegg_sub <- kegg_sub %>% - mutate(PATHWAY = map2(MODULE, PATHWAY, unnest_by_key)) %>% + mutate(PATHWAY = map2(MODULE, PATHWAY, unnest_by_key)) %>% mutate(PATHWAY = map(PATHWAY, list2semicolon)) } - + # display class if modules are selected as unique - kegg_sub <- kegg_sub %>% - left_join(kegg_modules %>% dplyr::select(MODULE, CLASS)) %>% - rowwise() %>% + kegg_sub <- kegg_sub %>% + left_join(kegg_modules %>% dplyr::select(MODULE, CLASS)) %>% + rowwise() %>% mutate(CLASS = strsplit(CLASS, '\n')[[1]] %>% # get first row - {strsplit(.,';')[[1]]} %>% # split by semicolons + {strsplit(., ';')[[1]]} %>% # split by semicolons .[[length(.)]]) # get LAST element of semicolon separated list } - + # Unnests everything - else if(input$which_unique == 'PATHWAY'){ - - if('REACTION' %in% colnames(kegg_sub)){ + else if (input$which_unique == 'PATHWAY') { + + if ('REACTION' %in% colnames(kegg_sub)) { kegg_sub <- kegg_sub %>% - tidyr::unnest(REACTION, .drop = F) %>% + tidyr::unnest(REACTION, .drop = F) %>% tidyr::unnest(REACTION, .drop = F) } - - if('MODULE' %in% colnames(kegg_sub)){ + + if ('MODULE' %in% colnames(kegg_sub)) { kegg_sub <- kegg_sub %>% mutate(MODULE = map2(REACTION, MODULE, unnest_by_key)) %>% - tidyr::unnest(MODULE, .drop = F) %>% + tidyr::unnest(MODULE, .drop = F) %>% tidyr::unnest(MODULE, .drop = F) } - - if('PATHWAY' %in% colnames(kegg_sub)){ + + if ('PATHWAY' %in% colnames(kegg_sub)) { kegg_sub <- kegg_sub %>% mutate(PATHWAY = map2(MODULE, PATHWAY, unnest_by_key)) %>% - tidyr::unnest(PATHWAY, .drop = F) %>% + tidyr::unnest(PATHWAY, .drop = F) %>% tidyr::unnest(PATHWAY, .drop = F) } - + # display 'NAME' column if pathways are selected - kegg_sub <- kegg_sub %>% + kegg_sub <- kegg_sub %>% left_join(kegg_pathways %>% dplyr::select(PATHWAY, NAME)) - + } - + # tidy columns column_order <- c(getEDataColName(revals$peakData2), 'FORMULA', 'COMPOUND', 'URL', 'REACTION', 'ENZYME', 'MODULE', 'CLASS', 'PATHWAY', 'NAME') column_order <- column_order[which(column_order %in% colnames(kegg_sub))] - + tables$kegg_table <- kegg_sub %>% dplyr::select(column_order) updateRadioGroupButtons(session, 'which_table', selected = 1) } - + ##################### ###### METACYC ###### ##################### - - else if(input$database_select == 'MetaCyc'){ - if(!exists('mc_compounds')){ + + else if (input$database_select == 'MetaCyc') { + if (!exists('mc_compounds')) { data('mc_compounds') } - + # map peaks to compounds - mc_sub <- revals$peakData2 %>% + mc_sub <- revals$peakData2 %>% mapPeaksToCompounds() %>% {dplyr::select(.$e_meta, getEDataColName(revals$peakData2), getEDataColName(.), getCompoundColName(.))} %>% - group_by(ID) %>% - mutate(n = n()) %>% - ungroup() %>% - filter(n <= maxrecords) %>% - select(-one_of('n')) %>% + group_by(ID) %>% + mutate(n = n()) %>% + ungroup() %>% + filter(n <= maxrecords) %>% + select(-one_of('n')) %>% tibble::as_tibble() - + # compounds to reactions - if('comp2react' %in% input$which_mappings){ - mc_sub <- mc_sub %>% + if ('comp2react' %in% input$which_mappings) { + mc_sub <- mc_sub %>% mutate(REACTION = map(Compound, newcol_from_mapping, maxlen = Inf, 'mc_compound_reaction_map')) } - - if('react2mod' %in% input$which_mappings){ + + if ('react2mod' %in% input$which_mappings) { validate(need('comp2react' %in% input$which_mappings, "If retrieving modules, you must also retrieve reactions.")) - mc_sub <- mc_sub %>% + mc_sub <- mc_sub %>% mutate(MODULE = map(REACTION, newcol_from_mapping, maxlen = Inf, map_list = 'mc_reaction_module_map')) } - - if('mod2path' %in% input$which_mappings){ + + if ('mod2path' %in% input$which_mappings) { validate(need(all(c('react2mod', 'comp2react') %in% input$which_mappings), "If retrieving pathways, you must also retrieve modules and reactions.")) mc_sub <- mc_sub %>% mutate(SUPERPATHWAY = map(MODULE, newcol_from_mapping, maxlen = Inf, map_list = 'mc_module_superpathway_map')) } - + ## unnest block (MetaCyc) - - if(input$which_unique == 'None'){ - if('REACTION' %in% colnames(mc_sub)){ + + if (input$which_unique == 'None') { + if ('REACTION' %in% colnames(mc_sub)) { mc_sub <- mc_sub %>% mutate(REACTION = map(REACTION, list2semicolon)) } - if('MODULE' %in% colnames(mc_sub)){ + if ('MODULE' %in% colnames(mc_sub)) { mc_sub <- mc_sub %>% mutate(MODULE = map(MODULE, list2semicolon)) } - if('SUPERPATHWAY' %in% colnames(mc_sub)){ + if ('SUPERPATHWAY' %in% colnames(mc_sub)) { mc_sub <- mc_sub %>% mutate(SUPERPATHWAY = map(SUPERPATHWAY, list2semicolon)) } } # Unnests REACTION and creates ;-collapsed versions of MODULE and SUPERPATHWAY - else if(input$which_unique == 'REACTION'){ - mc_sub <- mc_sub %>% - tidyr::unnest(REACTION, .drop = F) %>% + else if (input$which_unique == 'REACTION') { + mc_sub <- mc_sub %>% + tidyr::unnest(REACTION, .drop = F) %>% tidyr::unnest(REACTION, .drop = F) - - if('MODULE' %in% colnames(mc_sub)){ + + if ('MODULE' %in% colnames(mc_sub)) { mc_sub <- mc_sub %>% mutate(MODULE = map(MODULE, list2semicolon)) } - - if('SUPERPATHWAY' %in% colnames(mc_sub)){ + + if ('SUPERPATHWAY' %in% colnames(mc_sub)) { mc_sub <- mc_sub %>% mutate(SUPERPATHWAY = map(SUPERPATHWAY, list2semicolon)) } } # Unnests REACTION and MODULE and creates ;-collapsed versions of SUPERPATHWAY - else if(input$which_unique == 'MODULE'){ - if('REACTION' %in% colnames(mc_sub)){ + else if (input$which_unique == 'MODULE') { + if ('REACTION' %in% colnames(mc_sub)) { mc_sub <- mc_sub %>% - tidyr::unnest(REACTION, .drop = F) %>% + tidyr::unnest(REACTION, .drop = F) %>% tidyr::unnest(REACTION, .drop = F) } - - if('MODULE' %in% colnames(mc_sub)){ + + if ('MODULE' %in% colnames(mc_sub)) { mc_sub <- mc_sub %>% mutate(MODULE = map2(REACTION, MODULE, unnest_by_key)) %>% - tidyr::unnest(MODULE, .drop = F) %>% + tidyr::unnest(MODULE, .drop = F) %>% tidyr::unnest(MODULE, .drop = F) } - - if('SUPERPATHWAY' %in% colnames(mc_sub)){ + + if ('SUPERPATHWAY' %in% colnames(mc_sub)) { mc_sub <- mc_sub %>% - mutate(SUPERPATHWAY = map2(MODULE, SUPERPATHWAY, unnest_by_key)) %>% + mutate(SUPERPATHWAY = map2(MODULE, SUPERPATHWAY, unnest_by_key)) %>% mutate(SUPERPATHWAY = map(SUPERPATHWAY, list2semicolon)) } - + } # Unnests everything - else if(input$which_unique == 'SUPERPATHWAY'){ - - if('REACTION' %in% colnames(mc_sub)){ + else if (input$which_unique == 'SUPERPATHWAY') { + + if ('REACTION' %in% colnames(mc_sub)) { mc_sub <- mc_sub %>% - tidyr::unnest(REACTION, .drop = F) %>% + tidyr::unnest(REACTION, .drop = F) %>% tidyr::unnest(REACTION, .drop = F) } - - if('MODULE' %in% colnames(mc_sub)){ + + if ('MODULE' %in% colnames(mc_sub)) { mc_sub <- mc_sub %>% mutate(MODULE = map2(REACTION, MODULE, unnest_by_key)) %>% - tidyr::unnest(MODULE, .drop = F) %>% + tidyr::unnest(MODULE, .drop = F) %>% tidyr::unnest(MODULE, .drop = F) } - - if('SUPERPATHWAY' %in% colnames(mc_sub)){ + + if ('SUPERPATHWAY' %in% colnames(mc_sub)) { mc_sub <- mc_sub %>% mutate(SUPERPATHWAY = map2(MODULE, SUPERPATHWAY, unnest_by_key)) %>% - tidyr::unnest(SUPERPATHWAY, .drop = F) %>% + tidyr::unnest(SUPERPATHWAY, .drop = F) %>% tidyr::unnest(SUPERPATHWAY, .drop = F) } } - + tables$mc_table <- mc_sub updateRadioGroupButtons(session, 'which_table', selected = 2) - + } }, - error = function(e){ + error = function(e) { msg = paste0('Error creating the kegg mapping: \n System error: ', e) revals$warningmessage_database$mapping_error <<- sprintf("

%s

", msg) }) - + updateCollapse(session, 'database_tables_parent_collapse', open = 'database_tables') - + }) ####### MODAL FUNCTIONALITY ####### @@ -294,8 +294,8 @@ observeEvent(input$view_db_tables, { DTOutput('selected_db_table') # display selected table ), footer = tagList( - div(style = 'float:left', - bsButton('remove_db_table', 'Remove selected table', icon = icon('remove')) + div(style = 'float:left', + bsButton('remove_db_table', 'Remove selected table', icon = icon('remove')) ), modalButton("Dismiss") ), @@ -306,44 +306,42 @@ observeEvent(input$view_db_tables, { # save tables to a list, maximum 5 allowed observeEvent(input$save_db_table, { - + # display warning message and retun NULL if they've stored too many tables revals$warningmessage_database$too_many_tables <- NULL - - if(length(tables$mapping_tables) >= 5){ + + if (length(tables$mapping_tables) >= 5) { msg = paste0('Maximum of 5 tables, please remove some of your saved tables') revals$warningmessage_database$too_many_tables <<- sprintf("

%s

", msg) return(NULL) } - + kegg_or_mc <- ifelse(input$which_table == 1, 'Kegg', 'Metacyc') table_name = sprintf('%s Table %s', kegg_or_mc, input$save_db_table) - - if(input$which_table == 1 & !is.null(tables$kegg_table)){ + + if (input$which_table == 1 & !is.null(tables$kegg_table)) { tables$mapping_tables[[table_name]] <- tables$kegg_table - tables$saved_db_info[nrow(tables$saved_db_info) + 1,] <- c(table_name, nrow(tables$kegg_table), paste(colnames(tables$kegg_table), collapse = ';')) + tables$saved_db_info[nrow(tables$saved_db_info) + 1, ] <- c(table_name, nrow(tables$kegg_table), paste(colnames(tables$kegg_table), collapse = ';')) } - else if(input$which_table == 2 & !is.null(tables$mc_table)){ + else if (input$which_table == 2 & !is.null(tables$mc_table)) { tables$mapping_tables[[table_name]] <- tables$mc_table - tables$saved_db_info[nrow(tables$saved_db_info) + 1,] <- c(table_name, nrow(tables$mc_table), paste(colnames(tables$mc_table), collapse = ';')) + tables$saved_db_info[nrow(tables$saved_db_info) + 1, ] <- c(table_name, nrow(tables$mc_table), paste(colnames(tables$mc_table), collapse = ';')) } - + addCssClass("view_db_tables", "pulse_bow") Sys.sleep(0.6) removeCssClass("view_db_tables", "pulse_bow") - + }) # remove the selected database table on button click # need to remove the entry tables$saved_db_info and the corresponding table in tables$mapping_tables observeEvent(input$remove_db_table, { req(length(input$saved_db_table_rows_selected) > 0) - table_name = tables$saved_db_info[input$saved_db_table_rows_selected,'Tables'] - + table_name = tables$saved_db_info[input$saved_db_table_rows_selected, 'Tables'] + tables$saved_db_info <- tables$saved_db_info %>% filter(Tables != table_name) tables$mapping_tables[[table_name]] <- NULL }) ################ - - diff --git a/Observers/download_observers.R b/Observers/download_observers.R index efd5ccd..e0be011 100644 --- a/Observers/download_observers.R +++ b/Observers/download_observers.R @@ -1,106 +1,106 @@ # observer which write files to temp directory in preparation for download # this needs to be outside the downloadhandler to get around the server timing out on long downloads -observeEvent(input$makezipfile,{ +observeEvent(input$makezipfile, { disable('makezipfile') on.exit({ enable('makezipfile') }) - + print(tempdir()) fs <- vector() # total_files <- sum(c(input$report_selection, input$download_mappings, length(input$download_selection), length(plots$plot_table))) + 1 - - plots_marked_for_death <- which(plots$plot_table[,2] == dt_checkmark) - - withProgress(message = "Writing files: ",{ + + plots_marked_for_death <- which(plots$plot_table[, 2] == dt_checkmark) + + withProgress(message = "Writing files: ", { # option to choose report output format? need to change inputs in report.R. - if (input$report_selection == TRUE & !is.null(revals$peakData2)){ + if (input$report_selection == TRUE & !is.null(revals$peakData2)) { tryCatch({ fs <- c(fs, file.path(tempdir(), "report.html")) - report(revals$uploaded_data, revals$peakData2, revals$uploaded_data$e_meta, output_file = file.path(tempdir(), "report.html"), output_format = "html_document", - C13_ID = input$iso_symbol, groups_list = revals$groups_list, db_tables_info = tables$saved_db_info) - }, - error = function(e){ + report(revals$uploaded_data, revals$peakData2, revals$uploaded_data$e_meta, output_file = file.path(tempdir(), "report.html"), output_format = "html_document", + C13_ID = input$iso_symbol, groups_list = revals$groups_list, db_tables_info = tables$saved_db_info) + }, + error = function(e) { msg = paste0('Error creating report: \n System error: ', e) revals$warningmessage_download$report_error <<- msg msg }) - incProgress(1/total_files, detail = 'HTML report done..') + incProgress(1 / total_files, detail = 'HTML report done..') } - + # kegg tables if (input$download_mappings) { - for(name in names(tables$mapping_tables)){ - fs <- c(fs, file.path(tempdir(), paste0(name,'.csv'))) - + for (name in names(tables$mapping_tables)) { + fs <- c(fs, file.path(tempdir(), paste0(name, '.csv'))) + # must convert list columns to character table_out <- tables$mapping_tables[[name]] %>% mutate_if(is.list, as.character) - write_csv(table_out, path = file.path(tempdir(), paste0(name,'.csv'))) - incProgress(1/total_files, detail = sprintf('%s done..', name)) + write_csv(table_out, path = file.path(tempdir(), paste0(name, '.csv'))) + incProgress(1 / total_files, detail = sprintf('%s done..', name)) } - # + # rm(table_out) } - - if ("separate" %in% input$download_selection & !is.null(revals$peakData2)){ + + if ("separate" %in% input$download_selection & !is.null(revals$peakData2)) { fs <- c(fs, file.path(tempdir(), "FREDA_processed_e_data.csv"), file.path(tempdir(), "FREDA_processed_e_meta.csv")) write_csv(revals$peakData2$e_data, path = file.path(tempdir(), "FREDA_processed_e_data.csv")) write_csv(revals$peakData2$e_meta, path = file.path(tempdir(), "FREDA_processed_e_meta.csv")) - incProgress(1/total_files, detail = 'Data and molecular identification file done..') + incProgress(1 / total_files, detail = 'Data and molecular identification file done..') } - if ("merged" %in% input$download_selection & !is.null(revals$peakData2)){ + if ("merged" %in% input$download_selection & !is.null(revals$peakData2)) { fs <- c(fs, file.path(tempdir(), "FREDA_processed_merged_data.csv")) merged_data <- merge(revals$peakData2$e_data, revals$peakData2$e_meta) write_csv(merged_data, path = file.path(tempdir(), "FREDA_processed_merged_data.csv")) rm(merged_data) - incProgress(1/total_files, detail = 'Merged file done..') + incProgress(1 / total_files, detail = 'Merged file done..') } - if ("group_data" %in% input$download_selection){ - if(length(plots$plot_data) != 0){ - for(name in names(plots$plot_data)){ - path <- file.path(tempdir(), paste0("FREDA_group_data_summary_", gsub("/", "-", name),".csv")) + if ("group_data" %in% input$download_selection) { + if (length(plots$plot_data) != 0) { + for (name in names(plots$plot_data)) { + path <- file.path(tempdir(), paste0("FREDA_group_data_summary_", gsub("/", "-", name), ".csv")) fs <- c(fs, path) - write_csv(plots$plot_data[[name]], path = path) + write_csv(plots$plot_data[[name]], path = path) } } - incProgress(1/total_files, detail = 'Group plot summaries done..') + incProgress(1 / total_files, detail = 'Group plot summaries done..') } - - if(length(plots_marked_for_death) > 0){ + + if (length(plots_marked_for_death) > 0) { # fix stupid, enforce maximum height/width - width = if(is_empty(input$download_img_width)) 1600 else input$download_img_width - height = if(is_empty(input$download_img_height)) 900 else input$download_img_height - - if(isTRUE(input$download_img_width > 2400)){ + width = if (is_empty(input$download_img_width)) 1600 else input$download_img_width + height = if (is_empty(input$download_img_height)) 900 else input$download_img_height + + if (isTRUE(input$download_img_width > 2400)) { width = 2400 } - - if(isTRUE(input$download_img_height > 2400)){ + + if (isTRUE(input$download_img_height > 2400)) { height = 2400 } # - - for(i in plots_marked_for_death){ + + for (i in plots_marked_for_death) { plot_key = plots$plot_table[i, 1] filename = paste0(plot_key, '.', input$image_format) path = file.path(tempdir(), filename) fs <- c(fs, path) - - if(inherits(plots$plot_list[[plot_key]], 'plotly')){ + + if (inherits(plots$plot_list[[plot_key]], 'plotly')) { # using withr until orca handles full paths withr::with_dir(tempdir(), orca(plots$plot_list[[plot_key]], filename, width = width, height = height, scale = 2)) # export(plots$plot_list[[plot_key]], file = path, zoom = 2) # deprecated for some ungodly reason } - else if(inherits(plots$plot_list[[plot_key]], 'ggplot')){ - #TODO: variable dpi for ggplots - ggsave(path, plots$plot_list[[plot_key]], width = width/300, height = height/300, units = 'in') + else if (inherits(plots$plot_list[[plot_key]], 'ggplot')) { + # TODO: variable dpi for ggplots + ggsave(path, plots$plot_list[[plot_key]], width = width / 300, height = height / 300, units = 'in') } - incProgress(1/total_files, detail = sprintf('Plot: %s done..', plot_key)) - } + incProgress(1 / total_files, detail = sprintf('Plot: %s done..', plot_key)) + } } - + print(fs) revals$fs <- fs }) @@ -108,27 +108,27 @@ observeEvent(input$makezipfile,{ # Check that files actually got written to the appropriate locations. If not, do not allow download observeEvent(revals$fs, { - if(length(revals$fs) > 0){ + if (length(revals$fs) > 0) { download_condition = sum(file.exists(revals$fs)) > 0 } else download_condition = FALSE - + toggleState("download_processed_data", condition = download_condition) - + }, ignoreNULL = FALSE) ### Plots # remove or add a plot from the download queue -observeEvent(input$mark_plot_download,{ +observeEvent(input$mark_plot_download, { req(length(input$download_plot_table_rows_selected) > 0) - cond = plots$plot_table[input$download_plot_table_rows_selected,2] == dt_minus - - if(cond){ - plots$plot_table[input$download_plot_table_rows_selected,2] <- dt_checkmark + cond = plots$plot_table[input$download_plot_table_rows_selected, 2] == dt_minus + + if (cond) { + plots$plot_table[input$download_plot_table_rows_selected, 2] <- dt_checkmark } - else{ - plots$plot_table[input$download_plot_table_rows_selected,2] <- dt_minus + else { + plots$plot_table[input$download_plot_table_rows_selected, 2] <- dt_minus } }) @@ -136,8 +136,8 @@ observeEvent(input$mark_plot_download,{ # need to remove the entry plots$plot_table and the corresponding plot in plots$allplots observeEvent(input$remove_plot_download, { req(length(input$download_plot_table_rows_selected) > 0) - plot_name = plots$plot_table[input$download_plot_table_rows_selected,1] - + plot_name = plots$plot_table[input$download_plot_table_rows_selected, 1] + plots$plot_table <- plots$plot_table %>% filter(`File Name` != plot_name) plots$plot_list[[plot_name]] <- NULL plots$plot_data[[plot_name]] <- NULL @@ -146,19 +146,19 @@ observeEvent(input$remove_plot_download, { ### # store separate table for the download page because js is picky -observeEvent(plots$plot_table,{ +observeEvent(plots$plot_table, { plots$plot_table_download <- plots$plot_table }) # enforce height/width limits observeEvent(c(input$download_img_width, input$download_img_height), { revals$warningmessage_download$excess_width <- revals$warningmessage_download$excess_height <- NULL - if(isTRUE(input$download_img_width > 2400)){ + if (isTRUE(input$download_img_width > 2400)) { revals$warningmessage_download$excess_width <- 'style = color:red>Max width is 2400, value will be truncated.' # updateNumericInput(session, 'download_img_width', value = 2400) } - if(isTRUE(input$download_img_height > 2400)){ + if (isTRUE(input$download_img_height > 2400)) { revals$warningmessage_download$excess_height <- 'style = color:red>Max height is 2400, value will be truncated.' # updateNumericInput(session, 'download_img_height', value = 2400) } -}) \ No newline at end of file +}) diff --git a/Observers/filter_observers.R b/Observers/filter_observers.R index b8af307..a21dffd 100644 --- a/Observers/filter_observers.R +++ b/Observers/filter_observers.R @@ -3,378 +3,378 @@ observeEvent(input$filter_click, { shinyjs::show('calc_filter', anim = T) shinyjs::disable('filter_click') - on.exit({ + on.exit({ shinyjs::enable('filter_click') shinyjs::hide('calc_filter', anim = T) }) - + # if the data is already filtered start over from the uploaded data - if (any(c("moleculeFilt", "massFilt", "formulaFilt") %in% names(attributes(revals$peakData2)$filters)) | - any(grepl("emetaFilt", names(attributes(revals$peakData2)$filters))) | - !all(colnames(revals$peakData2$e_data) %in% colnames(revals$uploaded_data$e_data))){ + if (any(c("moleculeFilt", "massFilt", "formulaFilt") %in% names(attributes(revals$peakData2)$filters)) | + any(grepl("emetaFilt", names(attributes(revals$peakData2)$filters))) | + !all(colnames(revals$peakData2$e_data) %in% colnames(revals$uploaded_data$e_data))) { revals$peakData2 <- revals$uploaded_data } - + n_filters = sum(sapply(list(input$massfilter, input$molfilter, input$samplefilter, input$formfilter, input$custom1, input$custom2, input$custom3), isTRUE)) - + tryCatch({ revals$warningmessage_filter$apply_fail <- NULL - withProgress(message = "Applying filters....",{ + withProgress(message = "Applying filters....", { # Apply sample filter - if(input$samplefilter){ + if (input$samplefilter) { req(length(input$keep_samples) > 0) revals$peakData2 <- subset(revals$peakData2, samples = input$keep_samples, check_rows = TRUE) revals$removed_samples <- c(revals$removed_samples, setdiff(sample_names(), input$keep_samples)) - + # remove empty lists - if(length(revals$groups_list) > 0){ - + if (length(revals$groups_list) > 0) { + # get indices of now empty groups - inds <- sapply(revals$groups_list, function(el){ + inds <- sapply(revals$groups_list, function(el) { length(intersect(el, input$keep_samples)) == 0 }) - + revals$groups_list[inds] <- NULL } - incProgress(1/n_filters, detail = 'Sample filter done.') - }else revals$removed_samples <- list() - + incProgress(1 / n_filters, detail = 'Sample filter done.') + } else revals$removed_samples <- list() + # Apply mass filter - if (input$massfilter){ - + if (input$massfilter) { + # Error handling: Min mass less than max mass, but greater than 0 req(input$min_mass < input$max_mass) req(input$min_mass > 0) - + # Create and apply mass filter to nonreactive peakData object filterMass <- mass_filter(revals$peakData2) - revals$peakData2 <- applyFilt(filterMass, revals$peakData2, min_mass = as.numeric(input$min_mass), - max_mass = as.numeric(input$max_mass)) + revals$peakData2 <- applyFilt(filterMass, revals$peakData2, min_mass = as.numeric(input$min_mass), + max_mass = as.numeric(input$max_mass)) rm(filterMass) - incProgress(1/n_filters, detail = 'Mass filter done.') + incProgress(1 / n_filters, detail = 'Mass filter done.') } - + # Apply molecule filter if (input$molfilter) { - + # Create and apply molecule filter to nonreactive peakData object filterMols <- molecule_filter(revals$peakData2) revals$peakData2 <- applyFilt(filterMols, revals$peakData2, min_num = as.integer(input$minobs)) rm(filterMols) - incProgress(1/n_filters, detail = 'Molecule filter done.') + incProgress(1 / n_filters, detail = 'Molecule filter done.') } # End molecule filter if statement - + # Apply formula filter - if (input$formfilter){ + if (input$formfilter) { filterForm <- formula_filter(revals$peakData2) revals$peakData2 <- applyFilt(filterForm, revals$peakData2) rm(filterForm) - incProgress(1/n_filters, detail = 'Formula filter done.') + incProgress(1 / n_filters, detail = 'Formula filter done.') } - + # Apply custom filters - if (input$customfilterz){ - - #apply the filter for each input - for(i in 1:3){ - - #require that a selection has been made for filter i - if (input[[paste0("custom",i)]] == "Select item") return(NULL) - - #make the filter based on selection - filter <- emeta_filter(revals$peakData2, input[[paste0("custom",i)]]) - + if (input$customfilterz) { + + # apply the filter for each input + for (i in 1:3) { + + # require that a selection has been made for filter i + if (input[[paste0("custom", i)]] == "Select item") return(NULL) + + # make the filter based on selection + filter <- emeta_filter(revals$peakData2, input[[paste0("custom", i)]]) + # if numeric, apply filter with specified max and min values - if (is.numeric(revals$peakData2$e_meta[,input[[paste0("custom",i)]]])){ - req(input[[paste0("minimum_custom",i)]], input[[paste0("maximum_custom", i)]]) + if (is.numeric(revals$peakData2$e_meta[, input[[paste0("custom", i)]]])) { + req(input[[paste0("minimum_custom", i)]], input[[paste0("maximum_custom", i)]]) revals$peakData2 <- applyFilt(filter, revals$peakData2, - min_val = input[[paste0("minimum_custom",i)]], - max_val = input[[paste0("maximum_custom", i)]], - na.rm = !input[[paste0("na_custom",i)]]) - + min_val = input[[paste0("minimum_custom", i)]], + max_val = input[[paste0("maximum_custom", i)]], + na.rm = !input[[paste0("na_custom", i)]]) + } # else apply with selected categories - else if (!is.numeric(revals$peakData2$e_meta[,input[[paste0("custom",i)]]])){ - req(input[[paste0("categorical_custom",i)]]) - revals$peakData2 <- applyFilt(filter, revals$peakData2, - cats = input[[paste0("categorical_custom",i)]], - na.rm = !input[[paste0("na_custom",i)]]) + else if (!is.numeric(revals$peakData2$e_meta[, input[[paste0("custom", i)]]])) { + req(input[[paste0("categorical_custom", i)]]) + revals$peakData2 <- applyFilt(filter, revals$peakData2, + cats = input[[paste0("categorical_custom", i)]], + na.rm = !input[[paste0("na_custom", i)]]) } - + rm(filter) - incProgress(1/n_filters, detail = sprintf('Custom filter %s done', i)) + incProgress(1 / n_filters, detail = sprintf('Custom filter %s done', i)) } - + } }) - },error = function(e){ + }, error = function(e) { filt_msg = paste0('Something went wrong applying your filters \n System error: ', e) revals$warningmessage_filter$apply_fail <- sprintf("

%s

", filt_msg) }) - - if(!exists('filt_msg')){ + + if (!exists('filt_msg')) { # display success modal showModal( modalDialog(title = "Filter Success", - fluidRow( - column(10, align = "center", offset = 1, - HTML('

Your data has been filtered.

+ fluidRow( + column(10, align = "center", offset = 1, + HTML('

Your data has been filtered.

The filtered data is stored and will be reset if you re-upload or re-process data.

'), - hr(), - actionButton("filter_dismiss", "Review Results", width = '75%'), - br(), - br(), - actionButton("goto_viz", "Continue to Visualization", width = '75%') - ) - ) - ,footer = NULL) + hr(), + actionButton("filter_dismiss", "Review Results", width = '75%'), + br(), + br(), + actionButton("goto_viz", "Continue to Visualization", width = '75%') + ) + ) + , footer = NULL) ) } - - #__test-export__ + + # __test-export__ exportTestValues(peakData2 = revals$peakData2) - + }) # End creating revals$peakData2 # creates three observers, one for each custom filter column selection dropdown -lapply(1:3, function(i){ - +lapply(1:3, function(i) { + # store input name el <- paste0("custom", i) - + # create a single observer observeEvent(input[[el]], { - + revals$redraw_filter_plot <- FALSE - + # observer first creates the range/category dropdowns output[[paste0("customfilter", i, "UI")]] <- renderUI({ - - # check that something is selected and the user has selected custom filters - if (isTRUE(isolate(input[[el]]) != "Select item") & input$customfilterz == TRUE){ - - # if theres no selection, we start with false, else we keep the current value of the NA checkbox - ischecked = ifelse(is.null(isolate(input[[paste0("na_custom",i)]])), FALSE, isolate(input[[paste0("na_custom",i)]])) - - # if the filter applies to numeric data, allow inputs for min, max, and keep NA checkbox - if (is.numeric(revals$uploaded_data$e_meta[, isolate(input[[el]])])) { - - # if no min or max specificed, automatically fill in max, otherwise use value currently specified - min = min(revals$uploaded_data$e_meta[, isolate(input[[el]])], na.rm = TRUE) - max = max(revals$uploaded_data$e_meta[, isolate(input[[el]])], na.rm = TRUE) - - # if user has defined min/max, use their values, otherwise default to data min/max - isolate({ - cond_min = ifelse(is.null(input[[paste0("minimum_custom",i)]]), min, input[[paste0("minimum_custom",i)]]) - cond_max = ifelse(is.null(input[[paste0("maximum_custom",i)]]), max, input[[paste0("maximum_custom",i)]]) - }) - - # create range and keepNA? inputs - splitLayout(id = paste0("js_range_custom", i), style = "position:relative;top:-15px;padding-left:5px", class = "squeezesplitlayout", cellWidths = c("40%", "40%", "20%"), - numericInput(inputId = paste0("minimum_custom",i), label = "Min", value = min, min = min, max = cond_max, step = 0.01), - numericInput(inputId = paste0("maximum_custom",i), label = "Max", value = max, min = cond_min, max = max, step = 0.01), - tagList( - br(), - div(class = 'adjustdown', style = 'float:right;margin-right:10%', checkboxInput(inputId = paste0("na_custom",i), label = "Keep NAs?", value = ischecked)) - ) - ) - - # if the filter applies to categorical data, populate a box of options and keep NA checkbox - } else if (!is.numeric(revals$uploaded_data$e_meta[, isolate(input[[el]])]) & input$customfilterz == TRUE) { - - cats <- unique(revals$uploaded_data$e_meta[, isolate(input[[el]])]) %>% setdiff(NA) - - splitLayout(id = paste0("js_range_custom", i), cellArgs = list(style = "overflow:visible"), - - pickerInput(inputId = paste0("categorical_custom",i), label = "Categories to Keep", choices = cats, - multiple = TRUE, selected = cats, options = pickerOptions(dropupAuto = FALSE, actionsBox = TRUE)), - tagList( - br(), - div(class = 'adjustdown', style = 'float:right;margin-right:10%', checkboxInput(inputId = paste0("na_custom",i), label = "Keep NAs?", value = ischecked)) - ) - ) - } - } - # If we initialized with select item, return an invisible panel with a stored value - else if (isTRUE(isolate(input[[el]]) == "Select item") & input$customfilterz == TRUE){ - conditionalPanel("false", { - tagList( - numericInput(inputId = paste0("minimum_custom",i), label = "Min", value = NULL, min = 0, max = 1, step = 0.01), - numericInput(inputId = paste0("maximum_custom",i), label = "Max", value = NULL, min = 0, max = 1, step = 0.01), - checkboxInput(inputId = paste0("na_custom",i), label = "Keep NAs?", value = NULL), - pickerInput(inputId = paste0("categorical_custom",i), label = "Categories to Keep", choices = NULL, selected = NULL) - ) - }) - - } + + # check that something is selected and the user has selected custom filters + if (isTRUE(isolate(input[[el]]) != "Select item") & input$customfilterz == TRUE) { + + # if theres no selection, we start with false, else we keep the current value of the NA checkbox + ischecked = ifelse(is.null(isolate(input[[paste0("na_custom", i)]])), FALSE, isolate(input[[paste0("na_custom", i)]])) + + # if the filter applies to numeric data, allow inputs for min, max, and keep NA checkbox + if (is.numeric(revals$uploaded_data$e_meta[, isolate(input[[el]])])) { + + # if no min or max specificed, automatically fill in max, otherwise use value currently specified + min = min(revals$uploaded_data$e_meta[, isolate(input[[el]])], na.rm = TRUE) + max = max(revals$uploaded_data$e_meta[, isolate(input[[el]])], na.rm = TRUE) + + # if user has defined min/max, use their values, otherwise default to data min/max + isolate({ + cond_min = ifelse(is.null(input[[paste0("minimum_custom", i)]]), min, input[[paste0("minimum_custom", i)]]) + cond_max = ifelse(is.null(input[[paste0("maximum_custom", i)]]), max, input[[paste0("maximum_custom", i)]]) }) - + + # create range and keepNA? inputs + splitLayout(id = paste0("js_range_custom", i), style = "position:relative;top:-15px;padding-left:5px", class = "squeezesplitlayout", cellWidths = c("40%", "40%", "20%"), + numericInput(inputId = paste0("minimum_custom", i), label = "Min", value = min, min = min, max = cond_max, step = 0.01), + numericInput(inputId = paste0("maximum_custom", i), label = "Max", value = max, min = cond_min, max = max, step = 0.01), + tagList( + br(), + div(class = 'adjustdown', style = 'float:right;margin-right:10%', checkboxInput(inputId = paste0("na_custom", i), label = "Keep NAs?", value = ischecked)) + ) + ) + + # if the filter applies to categorical data, populate a box of options and keep NA checkbox + } else if (!is.numeric(revals$uploaded_data$e_meta[, isolate(input[[el]])]) & input$customfilterz == TRUE) { + + cats <- unique(revals$uploaded_data$e_meta[, isolate(input[[el]])]) %>% setdiff(NA) + + splitLayout(id = paste0("js_range_custom", i), cellArgs = list(style = "overflow:visible"), + + pickerInput(inputId = paste0("categorical_custom", i), label = "Categories to Keep", choices = cats, + multiple = TRUE, selected = cats, options = pickerOptions(dropupAuto = FALSE, actionsBox = TRUE)), + tagList( + br(), + div(class = 'adjustdown', style = 'float:right;margin-right:10%', checkboxInput(inputId = paste0("na_custom", i), label = "Keep NAs?", value = ischecked)) + ) + ) + } + } + # If we initialized with select item, return an invisible panel with a stored value + else if (isTRUE(isolate(input[[el]]) == "Select item") & input$customfilterz == TRUE) { + conditionalPanel("false", { + tagList( + numericInput(inputId = paste0("minimum_custom", i), label = "Min", value = NULL, min = 0, max = 1, step = 0.01), + numericInput(inputId = paste0("maximum_custom", i), label = "Max", value = NULL, min = 0, max = 1, step = 0.01), + checkboxInput(inputId = paste0("na_custom", i), label = "Keep NAs?", value = NULL), + pickerInput(inputId = paste0("categorical_custom", i), label = "Categories to Keep", choices = NULL, selected = NULL) + ) + }) + + } + }) + # assign null to revals if we went back to no selection - if(is.null(input[[el]]) | input[[el]] == "Select item"){ + if (is.null(input[[el]]) | input[[el]] == "Select item") { revals[[paste0("custom", i, "_ids")]] <- NULL } - + }, priority = 10) }) # creates dropdowns when custom filter checkbox is clicked observeEvent(input$customfilterz, { charlist <- list("first", "second", "third") - + # if checked on: create three column selector dropdowns for custom filters - if(input$customfilterz){ - lapply(1:3, function(i){ - output[[paste0("filter",i,"UI")]] <- renderUI({ - selectInput(paste0("custom",i), label = tags$b(paste0("Select ",charlist[[i]]," filter item")), - choices = c("Select item", isolate(emeta_display_choices()))) + if (input$customfilterz) { + lapply(1:3, function(i) { + output[[paste0("filter", i, "UI")]] <- renderUI({ + selectInput(paste0("custom", i), label = tags$b(paste0("Select ", charlist[[i]], " filter item")), + choices = c("Select item", isolate(emeta_display_choices()))) }) }) } # if checked off, NULLify output objects and reactive ids - else{ - lapply(1:3, function(i){ + else { + lapply(1:3, function(i) { revals[[paste0("custom", i, "_ids")]] <- NULL - output[[paste0("filter",i,"UI")]] <- NULL + output[[paste0("filter", i, "UI")]] <- NULL revals$filter_click_disable[[paste0("disable_custom", i)]] <- TRUE }) - + } }) # create observers on each custom filter. Each observer reacts to changes in the numeric range or categories and stores a table of retained ids in a reactive value # these reactive values are what will invalidate the preview table (summaryFilterDataFrame()) -lapply(1:3, function(i){ - +lapply(1:3, function(i) { + # variable which stores the input id of a particular dropdow el = paste0("custom", i) - - observeEvent(c(input[[paste0("minimum_custom", i)]], input[[paste0("maximum_custom", i)]], - input[[paste0("categorical_custom", i)]], input[[paste0("na_custom", i)]], - input$top_page, revals$redraw_largedata), { - req(input[[el]] != "Select item" & !is.null(input[[el]])) - - revals$redraw_filter_plot <- FALSE - - if(!revals$redraw_largedata){ - revals[[paste0("custom", i, "_ids")]] <- NULL - } - # require that the input has a real selection - if(input$customfilterz == TRUE){ - - req(all(!is.null(input[[paste0("minimum_custom", i)]]), !is.null(input[[paste0("maximum_custom", i)]])) | !is.null(input[[paste0("categorical_custom", i)]])) - - # if the filter applies to numeric data, allow inputs for min, max, and keep NA checkbox - if (is.numeric(revals$uploaded_data$e_meta[, input[[el]]])) { - - revals[[paste0("custom", i, "_ids")]] <- emeta_filter(revals$uploaded_data, input[[el]]) %>% - # sorry about this filter statement, i swear dplyr is cool - filter((emeta_value >= input[[paste0("minimum_custom", i)]] & emeta_value <= input[[paste0("maximum_custom", i)]]) | (is.na(emeta_value) & input[[paste0("na_custom", i)]])) %>% - pluck(1) %>% as.character() - - # if the filter applies to categorical data, populate a box of options and keep NA checkbox - } - - else if (!is.numeric(revals$uploaded_data$e_meta[, input[[el]]]) & input$customfilterz == TRUE) { - - revals[[paste0("custom", i, "_ids")]] <- emeta_filter(revals$uploaded_data, input[[el]]) %>% - filter(emeta_value %in% input[[paste0("categorical_custom", i)]] | (is.na(emeta_value) & input[[paste0("na_custom", i)]])) %>% - pluck(1) %>% as.character() - } - } - else revals[[paste0("custom", i, "_ids")]] <- NULL - - }) - + + observeEvent(c(input[[paste0("minimum_custom", i)]], input[[paste0("maximum_custom", i)]], + input[[paste0("categorical_custom", i)]], input[[paste0("na_custom", i)]], + input$top_page, revals$redraw_largedata), { + req(input[[el]] != "Select item" & !is.null(input[[el]])) + + revals$redraw_filter_plot <- FALSE + + if (!revals$redraw_largedata) { + revals[[paste0("custom", i, "_ids")]] <- NULL + } + # require that the input has a real selection + if (input$customfilterz == TRUE) { + + req(all(!is.null(input[[paste0("minimum_custom", i)]]), !is.null(input[[paste0("maximum_custom", i)]])) | !is.null(input[[paste0("categorical_custom", i)]])) + + # if the filter applies to numeric data, allow inputs for min, max, and keep NA checkbox + if (is.numeric(revals$uploaded_data$e_meta[, input[[el]]])) { + + revals[[paste0("custom", i, "_ids")]] <- emeta_filter(revals$uploaded_data, input[[el]]) %>% + # sorry about this filter statement, i swear dplyr is cool + filter((emeta_value >= input[[paste0("minimum_custom", i)]] & emeta_value <= input[[paste0("maximum_custom", i)]]) | (is.na(emeta_value) & input[[paste0("na_custom", i)]])) %>% + pluck(1) %>% as.character() + + # if the filter applies to categorical data, populate a box of options and keep NA checkbox + } + + else if (!is.numeric(revals$uploaded_data$e_meta[, input[[el]]]) & input$customfilterz == TRUE) { + + revals[[paste0("custom", i, "_ids")]] <- emeta_filter(revals$uploaded_data, input[[el]]) %>% + filter(emeta_value %in% input[[paste0("categorical_custom", i)]] | (is.na(emeta_value) & input[[paste0("na_custom", i)]])) %>% + pluck(1) %>% as.character() + } + } + else revals[[paste0("custom", i, "_ids")]] <- NULL + + }) + }) # delay behavior for when users changed input ranges / categories. prevent redrawing multiple times observe({ c(sampfilter_ids(), massfilter_ids(), molfilter_ids(), formfilter_ids(), revals$custom1_ids, revals$custom2_ids, revals$custom3_ids) - - if(isolate(revals$redraw_filter_plot == FALSE)){ + + if (isolate(revals$redraw_filter_plot == FALSE)) { invalidateLater(800, session) isolate(revals$redraw_filter_plot <- TRUE) } - else{ + else { isolate(revals$reac_filter_plot <- !revals$reac_filter_plot) } - + }) # Three observers maintain mutual exclusivity of custom filter column choices (can be redone in lapply loop) observeEvent(c(input$custom2, input$custom3), { - updateSelectInput(session, "custom1", - choices = c("Select item", setdiff(emeta_display_choices(), c(input$custom2, input$custom3))), - selected = input$custom1) + updateSelectInput(session, "custom1", + choices = c("Select item", setdiff(emeta_display_choices(), c(input$custom2, input$custom3))), + selected = input$custom1) }) observeEvent(c(input$custom1, input$custom3), { - updateSelectInput(session, "custom2", - choices = c("Select item", setdiff(emeta_display_choices(), c(input$custom1, input$custom3))), - selected = input$custom2) + updateSelectInput(session, "custom2", + choices = c("Select item", setdiff(emeta_display_choices(), c(input$custom1, input$custom3))), + selected = input$custom2) }) observeEvent(c(input$custom1, input$custom2), { - updateSelectInput(session, "custom3", - choices = c("Select item", setdiff(emeta_display_choices(), c(input$custom1, input$custom2))), - selected = input$custom3) + updateSelectInput(session, "custom3", + choices = c("Select item", setdiff(emeta_display_choices(), c(input$custom1, input$custom2))), + selected = input$custom3) }) # observers on numeric values which raise warnings for invalid entries and disable filter button -lapply(1:3, function(i){ +lapply(1:3, function(i) { min = paste0("minimum_custom", i) max = paste0("maximum_custom", i) col = paste0("custom", i) - - observeEvent(c(input[[min]],input[[max]], input$customfilterz), { - if(input$customfilterz & isTRUE(input[[col]] != "Select item")){ + + observeEvent(c(input[[min]], input[[max]], input$customfilterz), { + if (input$customfilterz & isTRUE(input[[col]] != "Select item")) { min = min(revals$uploaded_data$e_meta[, input[[col]]], na.rm = TRUE) max = max(revals$uploaded_data$e_meta[, input[[col]]], na.rm = TRUE) - + isolate({ - cond_min = ifelse(is.null(input[[paste0("minimum_custom",i)]]), min, input[[paste0("minimum_custom",i)]]) - cond_max = ifelse(is.null(input[[paste0("maximum_custom",i)]]), max, input[[paste0("maximum_custom",i)]]) + cond_min = ifelse(is.null(input[[paste0("minimum_custom", i)]]), min, input[[paste0("minimum_custom", i)]]) + cond_max = ifelse(is.null(input[[paste0("maximum_custom", i)]]), max, input[[paste0("maximum_custom", i)]]) }) - + # specifies bad ranges condition = isTRUE(cond_min >= cond_max) - + # put up warning and disable filter button toggleCssClass(paste0("js_range_custom", i), "attention", condition = condition) - revals$filter_click_disable[[paste0("disable_custom", i)]] <- if(condition) FALSE else TRUE - revals$warningmessage_filter$bad_custom_range = if(isTRUE(condition)) "style = 'color:red'>Invalid range for a custom filter" else NULL + revals$filter_click_disable[[paste0("disable_custom", i)]] <- if (condition) FALSE else TRUE + revals$warningmessage_filter$bad_custom_range = if (isTRUE(condition)) "style = 'color:red'>Invalid range for a custom filter" else NULL } else { revals$warningmessage_filter$bad_custom_range = NULL } }) - + }) # warn and disable filter for invalid mass range observeEvent(c(input$min_mass, input$max_mass, input$massfilter), { - cond = (isTRUE(input$min_mass >= input$max_mass) | input$min_mass == 0) & input$massfilter - toggleCssClass("min_mass", "attention", condition = !cond) - revals$filter_click_disable$cond_mass <- if(isTRUE(cond)) FALSE else TRUE - revals$warningmessage_filter$bad_mass_range = if(isTRUE(cond)) "style = 'color:red'>Invalid range for mass filter. Must be 0 < min < max" else NULL + cond = (isTRUE(input$min_mass >= input$max_mass) | input$min_mass == 0) & input$massfilter + toggleCssClass("min_mass", "attention", condition = !cond) + revals$filter_click_disable$cond_mass <- if (isTRUE(cond)) FALSE else TRUE + revals$warningmessage_filter$bad_mass_range = if (isTRUE(cond)) "style = 'color:red'>Invalid range for mass filter. Must be 0 < min < max" else NULL }) # check that at least one sample is selected -observeEvent(c(input$keep_samples, input$samplefilter),{ +observeEvent(c(input$keep_samples, input$samplefilter), { cond = length(input$keep_samples) == 0 & input$samplefilter toggleCssClass("js_filter_samples", "attention", condition = cond) - revals$warningmessage_filter$nosamples <- if(isTRUE(cond)) "style = 'color:red'>Choose at least one sample to keep" else NULL - revals$filter_click_disable$cond_samples <- if(isTRUE(cond)) FALSE else TRUE + revals$warningmessage_filter$nosamples <- if (isTRUE(cond)) "style = 'color:red'>Choose at least one sample to keep" else NULL + revals$filter_click_disable$cond_samples <- if (isTRUE(cond)) FALSE else TRUE }, ignoreNULL = F) # check that not all rows are filtered by checking the last non-NA row of summaryFilterDataFrame() -observeEvent(summaryFilterDataFrame(),{ - filter_inds <- c(TRUE, isolate(input$samplefilter) & length(isolate(input$keep_samples)) > 0, isolate(input$massfilter), isolate(input$molfilter), isolate(input$formfilter), - any(c(isolate(input$custom1), isolate(input$custom2), isolate(input$custom3)) != "Select item") & isolate(input$customfilterz)) +observeEvent(summaryFilterDataFrame(), { + filter_inds <- c(TRUE, isolate(input$samplefilter) & length(isolate(input$keep_samples)) > 0, isolate(input$massfilter), isolate(input$molfilter), isolate(input$formfilter), + any(c(isolate(input$custom1), isolate(input$custom2), isolate(input$custom3)) != "Select item") & isolate(input$customfilterz)) final_peaks <- summaryFilterDataFrame()[max(which(filter_inds)), 'sum_peaks'] cond = isTRUE(final_peaks > 0) - revals$filter_click_disable$cond_peaks <- if(!cond) FALSE else TRUE - revals$warningmessage_filter$nopeaks <- if(!cond) "style = 'color:red'>Your filters removed all rows or have value errors, adjust some values and try again" else NULL + revals$filter_click_disable$cond_peaks <- if (!cond) FALSE else TRUE + revals$warningmessage_filter$nopeaks <- if (!cond) "style = 'color:red'>Your filters removed all rows or have value errors, adjust some values and try again" else NULL }) # all conditions must be met to click filter @@ -383,7 +383,7 @@ observe({ toggleState("filter_click", condition = cond) }) -# ----- Filter Reset Setup -----# +# ----- Filter Reset Setup -----# # clear_filters$clearFilters simply allows/denies the destruction of filters and plots, and the rest of data to pre-filtered state. clear_filters <- reactiveValues(clearFilters = FALSE) observeEvent(input$clear_filters_yes, { @@ -396,52 +396,52 @@ observeEvent(input$filter_click, { #-------- Reset Activity -------# # Allow a 'reset' that restores the uploaded object and unchecks the filter -# boxes. Will display a popup that warns the user of plot erasure and gives +# boxes. Will display a popup that warns the user of plot erasure and gives # the option to reset or to go back without clearing filters. -observeEvent(input$reset_filters,{ +observeEvent(input$reset_filters, { showModal(modalDialog( - + ##### There is probably a better way to code the display behavior of this dialog -DC - + fluidPage( fluidRow( column(10, align = "center", offset = 1, - tags$p("Caution: If you reset filters, plots you have currently stored for download will be ERASED. If you want to keep the plots you have already created, download them now. A summary of the data with the current filter settings will be included in your download.", style = "color:red;font:bold", align = "center"), - actionButton("clear_filters_yes", "Yes, clear filters without saving plots.", width = '100%'), - br(), - br(), - actionButton("clear_filters_no", "No, take me back.", width = '100%') - ))), + tags$p("Caution: If you reset filters, plots you have currently stored for download will be ERASED. If you want to keep the plots you have already created, download them now. A summary of the data with the current filter settings will be included in your download.", style = "color:red;font:bold", align = "center"), + actionButton("clear_filters_yes", "Yes, clear filters without saving plots.", width = '100%'), + br(), + br(), + actionButton("clear_filters_no", "No, take me back.", width = '100%') + ))), footer = NULL ) ) }) -observeEvent(c(input$samplefilter, input$keep_samples),{ +observeEvent(c(input$samplefilter, input$keep_samples), { # a list which contains vectors of logical indicating whether that sample will be kept or not - samples_tf <- lapply(revals$groups_list, function(el){ el %in% input$keep_samples }) - + samples_tf <- lapply(revals$groups_list, function(el) { el %in% input$keep_samples }) + # there is at least one group with samples that will be dropped, and the checkbox is clicked cond <- length(which(!sapply(samples_tf, all))) > 0 & input$samplefilter - - if(cond){ + + if (cond) { warn_string <- "

The following groups will have some of their samples removed:

" - + # for every list element, if not all are kept, append a warning - for(i in 1:length(samples_tf)){ - if(!all(samples_tf[[i]])){ - rmv_warning <- if(sum(samples_tf[[i]]) == 0) "This group will be removed" else "" - warn_string <- paste0(warn_string, - sprintf("

%s | Samples remaining: %i. %s

", names(samples_tf)[i], sum(samples_tf[[i]]), rmv_warning)) + for (i in 1:length(samples_tf)) { + if (!all(samples_tf[[i]])) { + rmv_warning <- if (sum(samples_tf[[i]]) == 0) "This group will be removed" else "" + warn_string <- paste0(warn_string, + sprintf("

%s | Samples remaining: %i. %s

", names(samples_tf)[i], sum(samples_tf[[i]]), rmv_warning)) } } } - - revals$warningmessage_filter$removed_groups <- if(cond) warn_string else NULL + + revals$warningmessage_filter$removed_groups <- if (cond) warn_string else NULL }) # if they click no, just exit the modal dialog -observeEvent(input$clear_filters_no,{ +observeEvent(input$clear_filters_no, { removeModal() }) @@ -454,37 +454,37 @@ observeEvent(input$clear_filters_yes, { updateCheckboxInput(session, inputId = "customfilterz", value = FALSE) updateCheckboxInput(session, inputId = "samplefilter", value = FALSE) } - + # reset parameter table, plot_list, and group plot data. revert to pre-filtered data - plots$plot_table <- data.frame("File Name" = character(0), 'Download?' = character(0), "Plot Type" = character(0), "Sample Type" = character(0), "Group 1 Samples" = character(0), - "Group 2 Samples" = character(0), "Boundary Set" = character(0), "Color By Variable" = character(0), "X Variable" = character(0), - "Y Variable" = character(0), "Presence Threshold" = character(0), "Absence Threshold" = character(0), "P-Value" = character(0), - "Comparisons Method" = character(0), check.names = FALSE, stringsAsFactors = FALSE) + plots$plot_table <- data.frame("File Name" = character(0), 'Download?' = character(0), "Plot Type" = character(0), "Sample Type" = character(0), "Group 1 Samples" = character(0), + "Group 2 Samples" = character(0), "Boundary Set" = character(0), "Color By Variable" = character(0), "X Variable" = character(0), + "Y Variable" = character(0), "Presence Threshold" = character(0), "Absence Threshold" = character(0), "P-Value" = character(0), + "Comparisons Method" = character(0), check.names = FALSE, stringsAsFactors = FALSE) plots$plot_list <- list() plots$plot_data <- list() revals$peakData2 <- revals$uploaded_data # - + # counter to control plot storage indices in case of reset revals$reset_counter <- input$saveplot - + # reset 'removed samples' reval revals$removed_samples <- list() - + removeModal() }) # Dismiss success message, draw large data plots, or move to next page? -observeEvent(input$filter_dismiss,{ +observeEvent(input$filter_dismiss, { removeModal() - if(uploaded_data_dim() > max_cells){ + if (uploaded_data_dim() > max_cells) { shinyjs::show('draw_large_filter_plot') revals$redraw_largedata <- TRUE revals$react_largedata <- !revals$react_largedata } }) -observeEvent(input$goto_viz,{ +observeEvent(input$goto_viz, { updateTabsetPanel(session, "top_page", selected = "Visualize") removeModal() }) diff --git a/Observers/global_observers.R b/Observers/global_observers.R index 65ff9bc..55da260 100644 --- a/Observers/global_observers.R +++ b/Observers/global_observers.R @@ -1,14 +1,14 @@ -#uncomment to do postmortem debugging/enable browser button +# uncomment to do postmortem debugging/enable browser button # observeEvent(revals$peakData2,{ # peakData2 <<- revals$peakData2 # }) -# +# # observeEvent(c(reactiveValuesToList(revals), reactiveValuesToList(tables)), { # revals_postmortem <<- reactiveValuesToList(revals) # tables_postmortem <<- reactiveValuesToList(tables) # }) -# +# # observeEvent(reactiveValuesToList(plots), { # plots_postmortem <<- reactiveValuesToList(plots) # }) @@ -19,8 +19,8 @@ observeEvent(input$debugger, { # -# display buttons depending on page selection -observeEvent(input$top_page,{ +# display buttons depending on page selection +observeEvent(input$top_page, { condition = input$top_page %in% c("Upload", "Groups", "Preprocess", "Quality Control", 'Filter', 'Visualize', 'Database Mapping', 'Linked Plots') toggleElement("viewplots", condition = condition) toggleElement('saveplot', condition = condition) @@ -29,20 +29,20 @@ observeEvent(input$top_page,{ # observeEvent(input$top_page,{ # toggleElement("js_saveplot", condition = input$top_page %in% c("Upload", "Groups", "Preprocess", "Quality Control", 'Filter', 'Visualize', 'Database Mapping', 'Linked Plots')) -# +# # }, priority = 10, ignoreInit = FALSE) # multipurpose observer for page transitions -observeEvent(input$top_page,{ - toggleElement('helpbutton', condition = input$top_page %in% - c('Upload', 'Groups', 'Preprocess', 'Filter', 'Visualize', 'Download', 'Quality Control', 'Linked Plots', 'Database Mapping')) - - if(input$top_page %in% c('Quality Control', 'Filter', 'Visualize', 'Database Mapping')){ - if(is.null(revals$peakData2)){ +observeEvent(input$top_page, { + toggleElement('helpbutton', condition = input$top_page %in% + c('Upload', 'Groups', 'Preprocess', 'Filter', 'Visualize', 'Download', 'Quality Control', 'Linked Plots', 'Database Mapping')) + + if (input$top_page %in% c('Quality Control', 'Filter', 'Visualize', 'Database Mapping')) { + if (is.null(revals$peakData2)) { revals$peakData2 <- revals$uploaded_data } } - + # button specific to data requirements page toggleElement('datareqs_video', condition = input$top_page == 'data_requirements') }, priority = 10) @@ -52,57 +52,57 @@ observeEvent(input$saveplot, { req(!is.null(plots$last_plot[[input$top_page]])) # keeps plot names unique ind <- input$saveplot - revals$reset_counter - + # initialize a new line # TODO: standardize column names for newrecords and plot_table, currently just reassigns column names before rowbinding, seems bad. - newRecords <- data.frame(FileName = NA, Download = dt_checkmark, PlotType = NA, SampleType = NA, Group_1_Samples = NA, Group_2_Samples = NA, BoundarySet = NA, - ColorBy = NA, x_var = NA, y_var = NA, pres_thresh = NA, absn_thresh = NA, pval = NA, compfn = NA, stringsAsFactors = FALSE) - + newRecords <- data.frame(FileName = NA, Download = dt_checkmark, PlotType = NA, SampleType = NA, Group_1_Samples = NA, Group_2_Samples = NA, BoundarySet = NA, + ColorBy = NA, x_var = NA, y_var = NA, pres_thresh = NA, absn_thresh = NA, pval = NA, compfn = NA, stringsAsFactors = FALSE) + # Main viztab, single record - if(input$top_page == 'Visualize'){ + if (input$top_page == 'Visualize') { # which type of plot newRecords$FileName <- ifelse(is.na(input$title_input) | input$title_input == '', sprintf('Plot_%s', ind), sprintf('Plot_%s_(%s)', ind, input$title_input)) newRecords$PlotType <- input$chooseplots # Single or Multiple Samples newRecords$SampleType <- ifelse(input$chooseplots == "PCOA Plot", 'None', - switch(as.character(input$choose_single), '1' = 'Single Sample', '2' = 'Single Group of Samples', '3' = 'Comparison of Two Groups', '4' = 'Comparison of Two Samples') + switch(as.character(input$choose_single), '1' = 'Single Sample', '2' = 'Single Group of Samples', '3' = 'Comparison of Two Groups', '4' = 'Comparison of Two Samples') ) # Sample(s) in The first group (depends on input$choose_single to decide if this is a single or multiple sample list) - newRecords$Group_1_Samples <- ifelse(input$choose_single %in% c(1,2), yes = paste(input$whichSamples, collapse = ','), no = paste(g1_samples(), collapse = ',')) + newRecords$Group_1_Samples <- ifelse(input$choose_single %in% c(1, 2), yes = paste(input$whichSamples, collapse = ','), no = paste(g1_samples(), collapse = ',')) # Sample(s) in the second group. Automatically NA if input$choose_single is single sample or single group - newRecords$Group_2_Samples <- ifelse(input$choose_single %in% c(3,4), yes = paste(g2_samples() , collapse = ','), no = 'None') + newRecords$Group_2_Samples <- ifelse(input$choose_single %in% c(3, 4), yes = paste(g2_samples(), collapse = ','), no = 'None') # Boundary set borders to use (NA for non-Van Krevelen plots) newRecords$BoundarySet <- ifelse(input$chooseplots == 'Van Krevelen Plot', yes = ifelse(input$vkbounds == 0, 'None', input$vkbounds), no = 'None') newRecords$ColorBy <- ifelse(input$chooseplots == 'PCOA Plot', 'None', input$vk_colors) newRecords$x_var <- input$scatter_x newRecords$y_var <- input$scatter_y - - newRecords$x_var <- switch(input$chooseplots, 'Van Krevelen Plot' = 'O:C Ratio', 'Kendrick Plot' = 'Kendrick Mass', - 'Density Plot' = input$vk_colors, 'Custom Scatter Plot' = input$scatter_x, - 'PCOA Plot' = paste0('Principal Component ', input$scatter_x)) - newRecords$y_var <- switch(input$chooseplots, 'Van Krevelen Plot' = 'H:C Ratio', 'Kendrick Plot' = 'Kendrick Defect', - 'Density Plot' = 'Density', 'Custom Scatter Plot' = input$scatter_y, - 'PCOA Plot' = paste0('Principal Component ', input$scatter_y)) - - - newRecords$compfn <- ifelse(isTRUE(input$choose_single %in% c(3,4)) & isTRUE(input$summary_fxn != ""), - switch(input$summary_fxn, - "select_none" = "None", - "uniqueness_gtest" = "G test", - "uniqueness_nsamps" = "Presence/absence thresholds", - "uniqueness_prop" = "Presence/absence thresholds"), - no = "None") - + + newRecords$x_var <- switch(input$chooseplots, 'Van Krevelen Plot' = 'O:C Ratio', 'Kendrick Plot' = 'Kendrick Mass', + 'Density Plot' = input$vk_colors, 'Custom Scatter Plot' = input$scatter_x, + 'PCOA Plot' = paste0('Principal Component ', input$scatter_x)) + newRecords$y_var <- switch(input$chooseplots, 'Van Krevelen Plot' = 'H:C Ratio', 'Kendrick Plot' = 'Kendrick Defect', + 'Density Plot' = 'Density', 'Custom Scatter Plot' = input$scatter_y, + 'PCOA Plot' = paste0('Principal Component ', input$scatter_y)) + + + newRecords$compfn <- ifelse(isTRUE(input$choose_single %in% c(3, 4)) & isTRUE(input$summary_fxn != ""), + switch(input$summary_fxn, + "select_none" = "None", + "uniqueness_gtest" = "G test", + "uniqueness_nsamps" = "Presence/absence thresholds", + "uniqueness_prop" = "Presence/absence thresholds"), + no = "None") + # special storage options for single and two-group plots - if (input$choose_single == 2){ + if (input$choose_single == 2) { # store edata_result of summarizeGroups() - plots$plot_data[[newRecords$FileName]] <- plot_data()$e_data + plots$plot_data[[newRecords$FileName]] <- plot_data()$e_data } - - if (input$choose_single %in% c(3,4)){ + + if (input$choose_single %in% c(3, 4)) { # store edata result of summarizeGroupComparisons() - plots$plot_data[[newRecords$FileName]] <- plot_data()$e_data - + plots$plot_data[[newRecords$FileName]] <- plot_data()$e_data + # parameters specific to group comparison plots newRecords$pres_thresh <- input$pres_thresh newRecords$absn_thresh <- input$absn_thresh @@ -110,20 +110,20 @@ observeEvent(input$saveplot, { } } # QC tab, single record - else if(input$top_page == 'Quality Control'){ + else if (input$top_page == 'Quality Control') { # which type of plot newRecords$FileName <- ifelse(is.na(input$qc_boxplot_title) | input$qc_boxplot_title == '', sprintf('Plot_%s', ind), sprintf('Plot_%s_%s', ind, input$qc_boxplot_title)) newRecords$PlotType <- paste0('QC boxplot with scale: ', input$qc_plot_scale) - + # Sample(s) in The first group (depends on input$choose_single to decide if this is a single or multiple sample list) - newRecords$Group_1_Samples <- if(!is.null(input$qc_select_groups)) (revals$groups_list[input$qc_select_groups] %>% unlist() %>% unique() %>% setdiff(revals$removed_samples) %>% paste(collapse=', ')) else 'All Samples' + newRecords$Group_1_Samples <- if (!is.null(input$qc_select_groups)) (revals$groups_list[input$qc_select_groups] %>% unlist() %>% unique() %>% setdiff(revals$removed_samples) %>% paste(collapse = ', ')) else 'All Samples' } # Linked plots, two plots are saved - else if(input$top_page == "Linked Plots"){ + else if (input$top_page == "Linked Plots") { temp <- data.frame() - for(name in lapply(plots$last_plot[[input$top_page]], names)){ + for (name in lapply(plots$last_plot[[input$top_page]], names)) { # copy the information from the selected linked plot and just change its name - newRecords[1,] <- linked_plots_table() %>% filter(`File Name` == name) %>% slice(1) + newRecords[1, ] <- linked_plots_table() %>% filter(`File Name` == name) %>% slice(1) newRecords$FileName <- sprintf('Linked_Pair_%s_(%s)', ind, name) newRecords$PlotType <- sprintf('(LINKED) %s', newRecords$PlotType) temp <- rbind(temp, newRecords) @@ -131,47 +131,47 @@ observeEvent(input$saveplot, { newRecords <- temp rm(temp) } - else{ + else { newRecords$FileName <- sprintf('Plot_%s:%s_tab', ind, input$top_page) } - + # store the current plots in a reactiveValue for later download - if(inherits(plots$last_plot[[input$top_page]], 'list')){ - for(i in 1:nrow(newRecords)){ - # TODO: Currently storing a single element list for every element of plots$last_plot[[input$top_page]], a bit ugly. + if (inherits(plots$last_plot[[input$top_page]], 'list')) { + for (i in 1:nrow(newRecords)) { + # TODO: Currently storing a single element list for every element of plots$last_plot[[input$top_page]], a bit ugly. plots$plot_list[[newRecords$FileName[i]]] <- plots$last_plot[[input$top_page]][[i]][[1]] } } - else{ + else { plots$plot_list[[newRecords$FileName]] <- plots$last_plot[[input$top_page]] } - + colnames(newRecords) <- colnames(plots$plot_table) plots$plot_table <- plots$plot_table %>% rbind(newRecords) - + # TODO: check table and plot list name consistency - + plots$last_plot[[input$top_page]] <- NULL - + # wooooo css addCssClass("viewplots", "pulse_bow") Sys.sleep(0.6) removeCssClass("viewplots", "pulse_bow") - + }) # display modal dialog of saved plot info -observeEvent(input$viewplots,{ +observeEvent(input$viewplots, { showModal(modalDialog( tags$h4('Click on a row to view a plot. You can select/deselect a plot for inclusion in the final download (Download Tab).'), DTOutput("modal_plot_table"), uiOutput('modal_plot'), - + footer = tagList( - #div(disabled(actionButton(inputId = "add_plot", width = '100%', label = "Save Current Plot for Later Download", icon = icon("save")))) - div(style = 'float:left', - bsButton('mark_plot', 'Select/de-select for download', icon = icon('minus')), - bsButton('remove_plot', 'Remove selected plot', icon = icon('remove')) + # div(disabled(actionButton(inputId = "add_plot", width = '100%', label = "Save Current Plot for Later Download", icon = icon("save")))) + div(style = 'float:left', + bsButton('mark_plot', 'Select/de-select for download', icon = icon('minus')), + bsButton('remove_plot', 'Remove selected plot', icon = icon('remove')) ), modalButton("Dismiss") ), @@ -180,36 +180,36 @@ observeEvent(input$viewplots,{ }) # update button text for adding/removing from download queue -observeEvent(c(input$modal_plot_table_rows_selected, input$download_plot_table_rows_selected),{ - cond = plots$plot_table[input$modal_plot_table_rows_selected,2] == dt_minus - cond_download = plots$plot_table[input$download_plot_table_rows_selected,2] == dt_minus - - if(isTRUE(cond)){ +observeEvent(c(input$modal_plot_table_rows_selected, input$download_plot_table_rows_selected), { + cond = plots$plot_table[input$modal_plot_table_rows_selected, 2] == dt_minus + cond_download = plots$plot_table[input$download_plot_table_rows_selected, 2] == dt_minus + + if (isTRUE(cond)) { updateButton(session, 'mark_plot', icon = icon('plus')) } - else{ + else { updateButton(session, 'mark_plot', icon = icon('minus')) } - - if(isTRUE(cond_download)){ + + if (isTRUE(cond_download)) { updateButton(session, 'mark_plot_download', icon = icon('plus')) } - else{ + else { updateButton(session, 'mark_plot_download', icon = icon('minus')) } - + }) # remove or add a plot from the download queue -observeEvent(input$mark_plot,{ +observeEvent(input$mark_plot, { req(length(input$modal_plot_table_rows_selected) > 0) - cond = plots$plot_table[input$modal_plot_table_rows_selected,2] == dt_minus - - if(cond){ - plots$plot_table[input$modal_plot_table_rows_selected,2] <- dt_checkmark + cond = plots$plot_table[input$modal_plot_table_rows_selected, 2] == dt_minus + + if (cond) { + plots$plot_table[input$modal_plot_table_rows_selected, 2] <- dt_checkmark } - else{ - plots$plot_table[input$modal_plot_table_rows_selected,2] <- dt_minus + else { + plots$plot_table[input$modal_plot_table_rows_selected, 2] <- dt_minus } }) @@ -217,39 +217,39 @@ observeEvent(input$mark_plot,{ # need to remove the entry plots$plot_table and the corresponding plot in plots$plot_list observeEvent(input$remove_plot, { req(length(input$modal_plot_table_rows_selected) > 0) - plot_name = plots$plot_table[input$modal_plot_table_rows_selected,1] - + plot_name = plots$plot_table[input$modal_plot_table_rows_selected, 1] + plots$plot_table <- plots$plot_table %>% filter(`File Name` != plot_name) plots$plot_list[[plot_name]] <- NULL plots$plot_data[[plot_name]] <- NULL }) # control drawing of filter plot for large data, show warnings on qc and filter that dynamic plotting is disabled -observeEvent(uploaded_data_dim(),{ - if(uploaded_data_dim() <= max_cells){ +observeEvent(uploaded_data_dim(), { + if (uploaded_data_dim() <= max_cells) { revals$redraw_largedata <- TRUE } - - revals$warningmessage_qc$not_dynamic <- if(uploaded_data_dim() > max_cells) "style = 'color:deepskyblue;font-weight:bold'>Dynamic plot disabled for large data. Press 'Update Boxplot Axes' to display plot." else NULL - revals$warningmessage_filter$not_dynamic <- if(uploaded_data_dim() > max_cells) "style = 'color:deepskyblue;font-weight:bold'>Dynamic plot disabled for large data. Table and barplot will be displayed upon review." else NULL + + revals$warningmessage_qc$not_dynamic <- if (uploaded_data_dim() > max_cells) "style = 'color:deepskyblue;font-weight:bold'>Dynamic plot disabled for large data. Press 'Update Boxplot Axes' to display plot." else NULL + revals$warningmessage_filter$not_dynamic <- if (uploaded_data_dim() > max_cells) "style = 'color:deepskyblue;font-weight:bold'>Dynamic plot disabled for large data. Table and barplot will be displayed upon review." else NULL }) -video_footer <- function(id, url){ +video_footer <- function(id, url) { tagList( - bsButton(id, 'Video Walkthrough', onclick =paste0("window.open('", url, "', '_blank')"), style = 'info', icon = icon('facetime-video', lib = 'glyphicon')), + bsButton(id, 'Video Walkthrough', onclick = paste0("window.open('", url, "', '_blank')"), style = 'info', icon = icon('facetime-video', lib = 'glyphicon')), modalButton("Dismiss") ) } # Help Button -observeEvent(input$helpbutton,{ - if(input$top_page == "Upload"){ +observeEvent(input$helpbutton, { + if (input$top_page == "Upload") { showModal( modalDialog("", - tags$h4(tags$b("Upload your data and specify its structure")), - br(), - tags$p("Generally, the steps involved are:"), - HTML("
    + tags$h4(tags$b("Upload your data and specify its structure")), + br(), + tags$p("Generally, the steps involved are:"), + HTML("
    1. Browse to and select your data file from the first download prompt.
    2. Browse to and select your molecular identification file from the second download prompt.
    3. In the 'Choose column with ID's' dropdown, indicate the column (contained in both files) which contains the ID's for each peak.
      4. @@ -261,77 +261,77 @@ observeEvent(input$helpbutton,{
    4. Indicate whether or not there is isotopic information contained in the molecular identification file. (If you select no, proceed to click 'Process Data'.
    5. If you selected yes, identify whether you would like to filter isotopic peaks, which column contains this information, and the symbol which identifies presence. Then hit 'Process Data'
    "), - footer = video_footer('upload_video', 'https://youtu.be/MYccEwz67K4') - ) + footer = video_footer('upload_video', 'https://youtu.be/MYccEwz67K4') + ) ) - + } - else if (input$top_page == "Groups"){ + else if (input$top_page == "Groups") { showModal( modalDialog("", - tags$h4(tags$b("Define groups of samples\n")), - br(), - tags$p("On the left panel, input a name for your group, select the samples to include, and click 'add this group'.\n - A table entry will appear on the right panel. You can select a row of that table and click 'Remove selected group' to remove the + tags$h4(tags$b("Define groups of samples\n")), + br(), + tags$p("On the left panel, input a name for your group, select the samples to include, and click 'add this group'.\n + A table entry will appear on the right panel. You can select a row of that table and click 'Remove selected group' to remove the group."), - br(), br(), - tags$p("Groups are allowed to share samples, there will be a warning under the side panel if you want to avoid this. + br(), br(), + tags$p("Groups are allowed to share samples, there will be a warning under the side panel if you want to avoid this. Plotting of overlapping groups is not allowed in some cases."), - footer = video_footer('groups_video', 'https://youtu.be/zyJADBxw3rA') - ) - ) - + footer = video_footer('groups_video', 'https://youtu.be/zyJADBxw3rA') + ) + ) + } - else if(input$top_page == "Preprocess"){ - showModal( - modalDialog("", - tags$h4(tags$b("Have FREDA compute additional values of interest")), - tags$p("Check boxes to select which values you want calculated and then hit 'Process Data'.", - br(),br(), - "The result of these calculations will be appended to your molecular identification file and can be used as filtering variables in the next tab.\n", - tags$span(style = 'font-weight:bold', 'Element ratios are selected by default as they are required to produce Van-Krevelen and Kendrick plots.'), - 'Table summaries and an interactive histogram/bar chart of the values you selected will be generated.' - ), - footer = video_footer('preprocess_video', 'https://youtu.be/h99fuBt3Tc8') - ) - ) + else if (input$top_page == "Preprocess") { + showModal( + modalDialog("", + tags$h4(tags$b("Have FREDA compute additional values of interest")), + tags$p("Check boxes to select which values you want calculated and then hit 'Process Data'.", + br(), br(), + "The result of these calculations will be appended to your molecular identification file and can be used as filtering variables in the next tab.\n", + tags$span(style = 'font-weight:bold', 'Element ratios are selected by default as they are required to produce Van-Krevelen and Kendrick plots.'), + 'Table summaries and an interactive histogram/bar chart of the values you selected will be generated.' + ), + footer = video_footer('preprocess_video', 'https://youtu.be/h99fuBt3Tc8') + ) + ) } - else if(input$top_page == "Filter"){ - showModal( - modalDialog("", - tags$h4(tags$b("Filter the data by samples or by variables")), - tags$p("The default options are to:"), - tags$ul( - tags$li("Retain certain samples and drop the rest (Sample Filter)."), - tags$li("Retain peaks within a mass range (Mass Filter)"), - tags$li("Retain peaks that appear a minimum number of times across all samples (Molecule Filter)"), - tags$li("Retain peaks that have elemental information - either elemental columns or a full formula column (Formula Filter)") - ), - tags$p("Additionally, one can filter by up to three variables contained in the molecular identification file.\n + else if (input$top_page == "Filter") { + showModal( + modalDialog("", + tags$h4(tags$b("Filter the data by samples or by variables")), + tags$p("The default options are to:"), + tags$ul( + tags$li("Retain certain samples and drop the rest (Sample Filter)."), + tags$li("Retain peaks within a mass range (Mass Filter)"), + tags$li("Retain peaks that appear a minimum number of times across all samples (Molecule Filter)"), + tags$li("Retain peaks that have elemental information - either elemental columns or a full formula column (Formula Filter)") + ), + tags$p("Additionally, one can filter by up to three variables contained in the molecular identification file.\n As you select options, a plot will update showing the remaining observations after the application of each filter.\n"), - tags$p("Check boxes to select which filters to apply, specify filtering criteria by a range for numeric data or a selection of values for categorical data and then click 'Filter Data'"), - footer = video_footer('filter_video', 'https://youtu.be/zgRizald6x8') - ) - ) + tags$p("Check boxes to select which filters to apply, specify filtering criteria by a range for numeric data or a selection of values for categorical data and then click 'Filter Data'"), + footer = video_footer('filter_video', 'https://youtu.be/zgRizald6x8') + ) + ) } - else if(input$top_page == "Quality Control"){ + else if (input$top_page == "Quality Control") { showModal( modalDialog("", - tags$h4(tags$b("Inspect and save boxplots of your data")), - tags$p("This is a simple page to review boxplots and summary statistics of your data."), - tags$p("Select samples and axes options and click 'Update Boxplot Axes' to draw a new plot."), - tags$p("Underneath the plot window you can save the currently displayed plot"), - footer = video_footer('filter_video', 'https://youtu.be/9r68469sDmE') + tags$h4(tags$b("Inspect and save boxplots of your data")), + tags$p("This is a simple page to review boxplots and summary statistics of your data."), + tags$p("Select samples and axes options and click 'Update Boxplot Axes' to draw a new plot."), + tags$p("Underneath the plot window you can save the currently displayed plot"), + footer = video_footer('filter_video', 'https://youtu.be/9r68469sDmE') ) ) } - else if(input$top_page == "Visualize"){ - showModal( - modalDialog("", - tags$h4(tags$b('Generate plots from your processed data')), - br(), - HTML( - "

    Roughly from top to bottom on the left panel, do the following:

    + else if (input$top_page == "Visualize") { + showModal( + modalDialog("", + tags$h4(tags$b('Generate plots from your processed data')), + br(), + HTML( + "

    Roughly from top to bottom on the left panel, do the following:

    1. Select the type of plot you want to generate.
    2. Choose whether you would like to plot a single sample, multiple samples, or a comparison of two samples/groups @@ -344,54 +344,54 @@ observeEvent(input$helpbutton,{
    3. If desired, specify axis and title labels and hit 'Generate Plot'
    - +
    " - - ), - hr(), - tags$p("A plot will appear and can be customized by selection menus beneath."), - tags$p("Plots can be saved and reviewed in the 'Savee plot and view saved plots' collapsible sidebar"), - footer = video_footer('visualize_video', 'https://youtu.be/fONBzKCyyiA') - ) - ) + + ), + hr(), + tags$p("A plot will appear and can be customized by selection menus beneath."), + tags$p("Plots can be saved and reviewed in the 'Savee plot and view saved plots' collapsible sidebar"), + footer = video_footer('visualize_video', 'https://youtu.be/fONBzKCyyiA') + ) + ) } - else if(input$top_page == "Linked Plots"){ + else if (input$top_page == "Linked Plots") { showModal( modalDialog("", - tags$h4(tags$b("Interactively compare two plots side by side.")), - br(), - tags$p('In the top collapsible panel, you will see a list of valid plots. Not all plots are valid, currently linking supports Van-Krevelen, Kendrick, single sample density, and custom scatter plots'), - tags$p('Select exactly two of these plots by clicking on the entries in the table and then click "Compare These Plots"'), - tags$p('In the bottom panel, you will see your plots appear side-by side. Click and drag to select points or bins in one plot and FREDA will highlight both your selection, and the corresponding points in the other plot.') + tags$h4(tags$b("Interactively compare two plots side by side.")), + br(), + tags$p('In the top collapsible panel, you will see a list of valid plots. Not all plots are valid, currently linking supports Van-Krevelen, Kendrick, single sample density, and custom scatter plots'), + tags$p('Select exactly two of these plots by clicking on the entries in the table and then click "Compare These Plots"'), + tags$p('In the bottom panel, you will see your plots appear side-by side. Click and drag to select points or bins in one plot and FREDA will highlight both your selection, and the corresponding points in the other plot.') ) ) } - else if(input$top_page == "Database Mapping"){ + else if (input$top_page == "Database Mapping") { showModal( modalDialog("", - tags$h4(tags$b("Map your observed peak masses to compounds, reactions, modules, and pathways/superpathways.\n")), - br(), - tags$p('In the left panel, specify the following from top to bottom:'), - tags$ul( - tags$li("Select if you would like to use Kegg or Metacyc to map your peaks."), - tags$li("A number which, if a peak maps to more than that many database elements, it is exluded from the results."), - tags$li("Which database values you would like included. Any value selected must also have the value(s) to its left selected. I.e. if you would like Kegg modules, you must also select Kegg reactions"), - tags$li("Which variable that you have calculated to expand such that each row of the results contains a single value of this variable.") - ) - ) - ) + tags$h4(tags$b("Map your observed peak masses to compounds, reactions, modules, and pathways/superpathways.\n")), + br(), + tags$p('In the left panel, specify the following from top to bottom:'), + tags$ul( + tags$li("Select if you would like to use Kegg or Metacyc to map your peaks."), + tags$li("A number which, if a peak maps to more than that many database elements, it is exluded from the results."), + tags$li("Which database values you would like included. Any value selected must also have the value(s) to its left selected. I.e. if you would like Kegg modules, you must also select Kegg reactions"), + tags$li("Which variable that you have calculated to expand such that each row of the results contains a single value of this variable.") + ) + ) + ) } - else if(input$top_page == "Download"){ + else if (input$top_page == "Download") { showModal( modalDialog("", - tags$h4(tags$b("Download plots, .csv's and a report of the results of your FREDA session.")), - br(), - tags$p('Check boxes to tell FREDA to include the described file in your download'), - tags$p('If you created plots, a table will be displayed giving information on them. The rows of this table can be selected, which tells FREDA that they should be included in the download.'), - tags$p('Once you are satisfied with your selection, click "Bundle up all selected items" which will prepare them for download. Then click "Download bundle" to download all items as a compressed .zip file.'), - footer = video_footer('download_video', 'https://youtu.be/qL-XlK8s80s') + tags$h4(tags$b("Download plots, .csv's and a report of the results of your FREDA session.")), + br(), + tags$p('Check boxes to tell FREDA to include the described file in your download'), + tags$p('If you created plots, a table will be displayed giving information on them. The rows of this table can be selected, which tells FREDA that they should be included in the download.'), + tags$p('Once you are satisfied with your selection, click "Bundle up all selected items" which will prepare them for download. Then click "Download bundle" to download all items as a compressed .zip file.'), + footer = video_footer('download_video', 'https://youtu.be/qL-XlK8s80s') ) ) } - + }) diff --git a/Observers/groups_observers.R b/Observers/groups_observers.R index ca3a3b9..002ecfd 100644 --- a/Observers/groups_observers.R +++ b/Observers/groups_observers.R @@ -3,7 +3,7 @@ observeEvent(input$add_group, { req(!is.null(input$group_name) & input$group_name != "") req(length(input$group_samples) > 0) req(!(input$group_name %in% names(revals$groups_list))) - + revals$groups_list[[input$group_name]] <- input$group_samples updateTextInput(session, "group_name", value = "") @@ -12,61 +12,60 @@ observeEvent(input$add_group, { }) # shinyjs observer which disables input if selection is not valid -observeEvent(c(input$group_name, input$group_samples),{ +observeEvent(c(input$group_name, input$group_samples), { cond_noname <- is.null(input$group_name) | input$group_name == "" cond_nosamples <- length(input$group_samples) == 0 cond_invalid_name <- input$group_name %in% names(revals$groups_list) - - revals$warningmessage_groups$noname <- if(cond_noname) "

    Please input a name for this group

    " else NULL - revals$warningmessage_groups$badname <- if(cond_invalid_name) "

    This group name has already been used

    " else NULL - revals$warningmessage_groups$nosamples <- if(cond_nosamples & !cond_noname) "

    Please select at least one sample for this group

    " else NULL + + revals$warningmessage_groups$noname <- if (cond_noname) "

    Please input a name for this group

    " else NULL + revals$warningmessage_groups$badname <- if (cond_invalid_name) "

    This group name has already been used

    " else NULL + revals$warningmessage_groups$nosamples <- if (cond_nosamples & !cond_noname) "

    Please select at least one sample for this group

    " else NULL toggleCssClass("js_group_name", "suggest", cond_noname) toggleCssClass("js_group_name", "attention", cond_invalid_name & !cond_noname) toggleCssClass("group_samples", "suggest", cond_nosamples) toggleState("add_group", condition = !any(cond_noname, cond_nosamples, cond_invalid_name)) - + }) # observer on sample seletion that warns of overlapping groups observeEvent(c(input$group_name, input$group_samples, input$remove_group), { # empty group name condition cond_noname <- is.null(input$group_name) | input$group_name == "" - + # list of intersections across already stored groups - xsamples <- lapply(revals$groups_list, function(x){ + xsamples <- lapply(revals$groups_list, function(x) { intersect(x, input$group_samples) }) - + # list indices that correspond to groups that have overlap xinds <- which(lapply(xsamples, length) > 0) - - if(length(xinds) > 0 & !cond_noname){ + + if (length(xinds) > 0 & !cond_noname) { warn_string <- "

    The following groups already contain some of the samples selected:

    " - for(ind in xinds){ + for (ind in xinds) { warn_string <- paste0(warn_string, sprintf("

    %s: %s

    ", names(revals$groups_list)[ind], paste(xsamples[[ind]], collapse = ", "))) - + } revals$warningmessage_groups$sample_intersect <- warn_string } else revals$warningmessage_groups$sample_intersect <- NULL - + }) # toggle remove button -observeEvent(input$group_table_rows_selected,{ +observeEvent(input$group_table_rows_selected, { toggleState("remove_group", length(input$group_table_rows_selected) > 0) }, ignoreNULL = F) # remove table and list entries of selected row on button click -observeEvent(input$remove_group,{ +observeEvent(input$remove_group, { req(input$group_table_rows_selected) ind <- input$group_table_rows_selected - + revals$groups_list[[ind]] <- NULL }, priority = 10) # continue to preprocess -observeEvent(input$goto_preprocess_main,{ +observeEvent(input$goto_preprocess_main, { updateTabsetPanel(session, "top_page", selected = "Preprocess") }) - diff --git a/Observers/linked_plot_observers.R b/Observers/linked_plot_observers.R index 7d7174d..4fd8592 100644 --- a/Observers/linked_plot_observers.R +++ b/Observers/linked_plot_observers.R @@ -1,26 +1,26 @@ # stores which plot we interacted with last -lp_lastEvent <- reactiveValues(source="none", trigger = 1) +lp_lastEvent <- reactiveValues(source = "none", trigger = 1) observeEvent(input$lp_compare_plots, { - #browser() + # browser() req(length(input$lp_plot_table_rows_selected) == 2) inds <- input$lp_plot_table_rows_selected - + plot_name1 <- linked_plots_table()[inds[1], 1] plot_name2 <- linked_plots_table()[inds[2], 1] - + plots$linked_plots$left <- plots$plot_list[[plot_name1]] %>% - layout(dragmode="select") + layout(dragmode = "select") plots$linked_plots$right <- plots$plot_list[[plot_name2]] %>% - layout(dragmode="select") - + layout(dragmode = "select") + plots$linked_plots$left$x$source <- 'left_source' plots$linked_plots$right$x$source <- 'right_source' - + lp_lastEvent$source <<- NULL - + updateCollapse(session, id = 'linked_plots_collapse', open = c('lp_mainpanel')) - + }, priority = 9) # Observe plotly-selected event from vk_source @@ -36,4 +36,3 @@ observeEvent(input$`plotly_selected-right_source`, { lp_lastEvent$source <- "right_source" lp_lastEvent$trigger = -lp_lastEvent$trigger }, priority = 10) - diff --git a/Observers/preprocess_observers.R b/Observers/preprocess_observers.R index 79d9e22..0bdad39 100644 --- a/Observers/preprocess_observers.R +++ b/Observers/preprocess_observers.R @@ -3,142 +3,142 @@ observeEvent(input$preprocess_click, { validate(need(input$tests, message = "Please choose at least one test to calculate")) req(!is.null(revals$uploaded_data)) - + disable('preprocess_click') - shinyjs::show('preprocess_waiting', anim=T) + shinyjs::show('preprocess_waiting', anim = T) on.exit({ enable('preprocess_click') - shinyjs::hide('preprocess_waiting', anim=T) + shinyjs::hide('preprocess_waiting', anim = T) }) - + # Apply all relevant functions - withProgress(message = "Calculating Values....",{ - + withProgress(message = "Calculating Values....", { + temp <- revals$uploaded_data - + ### construct params arguments <- list() choices <- calc_opts$Function - - tryCatch({ - for(x in choices) { - if(x == 'calc_kendrick'){ - if(!is.null(input$base_unit)){ + + tryCatch({ + for (x in choices) { + if (x == 'calc_kendrick') { + if (!is.null(input$base_unit)) { arguments[[x]] <- list(base_compounds = input$base_unit) } } - else if(x == 'calc_dbe'){ - if(!is.null(input$dbe_valences) & isTRUE(input$dbe_valences != '')){ + else if (x == 'calc_dbe') { + if (!is.null(input$dbe_valences) & isTRUE(input$dbe_valences != '')) { # input argument to calc_dbe is a dataframe with valences fore each element - valence_df <- data.frame('C' = numeric(0), 'H' = numeric(0), 'N' = numeric(0), 'O' = numeric(0), 'S' = numeric(0), 'P' = numeric(0)) - + valence_df <- data.frame('C' = numeric(0), 'H' = numeric(0), 'N' = numeric(0), 'O' = numeric(0), 'S' = numeric(0), 'P' = numeric(0)) + valence_list <- strsplit(input$dbe_valences, ';')[[1]] - valence_list <- lapply(valence_list, function(el){ - V <- strsplit(el, '(?<=.)(?=(C|H|N|O|S|P)[0-9]*)', perl=T)[[1]] # Stare not into the void that is regex. I have looked and seen the terror within; the terror that consumes the souls of men and deposits their husks like sand dollars on the beach of eternity. - counts <- lapply(V, function(x){ - if(x == ''){ - 2 # if they didnt specify, assume the valence that doesnt contribute to the dbe - } - else if(!grepl('[0-9]', x)){ - 1 # specified without number, assume they mean one, i.e. H = H1 - } - else as.numeric(gsub("[A-Z]", '', x)) - }) - Vnames <- sapply(V, function(x) gsub("[0-9]", '', x)) - names(counts) <- Vnames - counts + valence_list <- lapply(valence_list, function(el) { + V <- strsplit(el, '(?<=.)(?=(C|H|N|O|S|P)[0-9]*)', perl = T)[[1]] # Stare not into the void that is regex. I have looked and seen the terror within; the terror that consumes the souls of men and deposits their husks like sand dollars on the beach of eternity. + counts <- lapply(V, function(x) { + if (x == '') { + 2 # if they didnt specify, assume the valence that doesnt contribute to the dbe + } + else if (!grepl('[0-9]', x)) { + 1 # specified without number, assume they mean one, i.e. H = H1 + } + else as.numeric(gsub("[A-Z]", '', x)) }) - + Vnames <- sapply(V, function(x) gsub("[0-9]", '', x)) + names(counts) <- Vnames + counts + }) + # populate the empty dataframe - for(i in 1:length(valence_list)){ + for (i in 1:length(valence_list)) { V <- valence_list[[i]] - for(name in names(V)){ + for (name in names(V)) { print(V[[name]]) - valence_df[i,name] <- V[[name]] + valence_df[i, name] <- V[[name]] } } - + arguments[[x]] <- list(valences = valence_df) } } # end DBE } # end for }, - error = function(e){ + error = function(e) { msg <<- sprintf('Something went wrong applying extra options, double check your input. System error: %s', e) revals$warningmessage_preprocess$get_args <<- sprintf("

    %s

    ", msg) NULL }) - + tryCatch({ revals$warningmessage_preprocess$makeobject_error <- NULL - for(el in isolate(input$tests)){ + for (el in isolate(input$tests)) { args <- arguments[[el]] - - if(grepl("assign_class", el)){ + + if (grepl("assign_class", el)) { foo <- strsplit(el, ";")[[1]] - f <- get(foo[1], envir=asNamespace("ftmsRanalysis"), mode="function") + f <- get(foo[1], envir = asNamespace("ftmsRanalysis"), mode = "function") temp <- f(temp, foo[2]) - temp$e_meta[paste0(foo[2], "_class")] <- gsub(";.*", "", temp$e_meta[,paste0(foo[2], "_class")]) + temp$e_meta[paste0(foo[2], "_class")] <- gsub(";.*", "", temp$e_meta[, paste0(foo[2], "_class")]) } - else{ - f <- get(el, envir=asNamespace("ftmsRanalysis"), mode="function") - temp <- if(is.null(arguments[[el]])) f(temp) else do.call(f, c(list(temp), arguments[[el]])) + else { + f <- get(el, envir = asNamespace("ftmsRanalysis"), mode = "function") + temp <- if (is.null(arguments[[el]])) f(temp) else do.call(f, c(list(temp), arguments[[el]])) } - - incProgress(1/length(input$tests)) + + incProgress(1 / length(input$tests)) } }, - error = function(e){ + error = function(e) { msg = paste0('Error calculating some of your variables: \n System error: ', e) revals$warningmessage_preprocess$makeobject_error <<- sprintf("

    %s

    ", msg) }) - - if(!exists('msg')) revals$uploaded_data <- temp + + if (!exists('msg')) revals$uploaded_data <- temp }) - + # post mortem test object - # test_uploaded_data <<- revals$peakData2 - + # test_uploaded_data <<- revals$peakData2 + if (isTRUE(getOption("shiny.testmode"))) { exportTestValues(peakData2 = revals$peakData2) } - + }, priority = 10) # End action button event # Creates two reactive variables for continuous and categorical variables which are used to display separate tables # Note: dependent on preprocess click and the user-specified calculations observeEvent(input$preprocess_click, { # Error handling: revals$uploaded_data must have a non-NULL Kendrick Mass column name - #req(!is.null(attr(revals$uploaded_data, 'cnames')$kmass_cname)) + # req(!is.null(attr(revals$uploaded_data, 'cnames')$kmass_cname)) req(input$tests) - + # Get csv file of all possible calculation column names possible_calc_cnames <- read_csv("calculation_variables.csv") %>% as.data.frame(stringsAsFactors = FALSE) - + # Get column names from revals$uploaded_data's e_meta actual_cnames <- colnames(revals$uploaded_data$e_meta) - + # Find all columns with names that match names for calculated columns - v_index <- which(possible_calc_cnames[,1] %in% actual_cnames) - - # Save calculation column names from above and their display names - intersect <- possible_calc_cnames[v_index,] - + v_index <- which(possible_calc_cnames[, 1] %in% actual_cnames) + + # Save calculation column names from above and their display names + intersect <- possible_calc_cnames[v_index, ] + # get numeric columns - numeric_cols <- revals$uploaded_data$e_meta %>% - dplyr::select(which(sapply(.[intersect[,1]], is.numeric))) %>% + numeric_cols <- revals$uploaded_data$e_meta %>% + dplyr::select(which(sapply(.[intersect[, 1]], is.numeric))) %>% names() - + # get categorical columns - categorical_cols <- revals$uploaded_data$e_meta %>% - dplyr::select(which(!sapply(.[intersect[,1]], is.numeric))) %>% - names() - - #set reactive variables for observers + categorical_cols <- revals$uploaded_data$e_meta %>% + dplyr::select(which(!sapply(.[intersect[, 1]], is.numeric))) %>% + names() + + # set reactive variables for observers revals$numeric_cols <- intersect %>% filter(ColumnName %in% numeric_cols) revals$categorical_cols <- intersect %>% filter(ColumnName %in% categorical_cols) - -}) + +}) #### Main Panel #### @@ -147,58 +147,58 @@ observeEvent(input$preprocess_dismiss, { output$which_hist_out <- renderUI({ # Error handling: input csv of calculations variables required req(calc_vars, revals$numeric_cols, revals$categorical_cols) - + tagList( hr(), tags$p('I would like to see a histogram/bar-chart across all values of:'), selectInput('which_hist', NULL, - choices = emeta_display_choices(), - selected = colnames(revals$uploaded_data$e_meta)[ncol(revals$uploaded_data$e_meta) + 1]) + choices = emeta_display_choices(), + selected = colnames(revals$uploaded_data$e_meta)[ncol(revals$uploaded_data$e_meta) + 1]) ) - }) -})# End which_hist + }) +}) # End which_hist ### Summary Panel: Display table summaries of numeric and categorical columns in e_meta ### -observeEvent(input$preprocess_dismiss,{ - +observeEvent(input$preprocess_dismiss, { + req(c(revals$numeric_cols, revals$categorical_cols)) - - if(isTRUE(nrow(revals$numeric_cols) > 0)){ + + if (isTRUE(nrow(revals$numeric_cols) > 0)) { columns <- summaryPreprocess(isolate(revals$uploaded_data), revals$numeric_cols) %>% colnames() - + revals$preprocess_tables$numeric <- summaryPreprocess(isolate(revals$uploaded_data), revals$numeric_cols) %>% - datatable(options = list(dom = "t", pageLength = nrow(.))) %>% - formatRound(columns, digits = 2) + datatable(options = list(dom = "t", pageLength = nrow(.))) %>% + formatRound(columns, digits = 2) } - if(isTRUE(nrow(revals$categorical_cols) > 0)){ + if (isTRUE(nrow(revals$categorical_cols) > 0)) { revals$preprocess_tables$categorical <- summaryPreprocess(revals$uploaded_data, revals$categorical_cols, categorical = TRUE) } - + }) # For numeric columns: -observeEvent(input$preprocess_dismiss,{ - +observeEvent(input$preprocess_dismiss, { + req(revals$preprocess_tables) - - if(length(revals$preprocess_tables$numeric) > 0){ + + if (length(revals$preprocess_tables$numeric) > 0) { # Create Table Output - output$numeric_summary <- DT::renderDataTable({revals$preprocess_tables$numeric}) - + output$numeric_summary <- DT::renderDataTable({revals$preprocess_tables$numeric}) + # Summary Header output$numeric_header <- renderUI(tags$p("Summary Statistics for Numeric Variables")) } - if(length(revals$preprocess_tables$categorical) > 0){ - lapply(1:length(revals$preprocess_tables$categorical), function(i){ - output[[paste0('Table_',i)]] <- DT::renderDataTable({revals$preprocess_tables$categorical[[i]]}, options = list(scrollX = TRUE, dom = "t")) + if (length(revals$preprocess_tables$categorical) > 0) { + lapply(1:length(revals$preprocess_tables$categorical), function(i) { + output[[paste0('Table_', i)]] <- DT::renderDataTable({revals$preprocess_tables$categorical[[i]]}, options = list(scrollX = TRUE, dom = "t")) Sys.sleep(0.5) }) - + revals$ntables <- length(revals$preprocess_tables$categorical) - + output$cat_header <- renderUI(tags$p("Counts for Categorical Variables")) } }) @@ -206,12 +206,12 @@ observeEvent(input$preprocess_dismiss,{ # The renderUI call that takes input from the above observer output$categorical_summary <- renderUI({ req(revals$ntables) - - if(isTRUE(nrow(isolate(revals$categorical_cols)) == 0)) NULL - else{ - tagList(lapply(1:revals$ntables, function(i){ - DT::dataTableOutput(paste0('Table_',i)) - }) + + if (isTRUE(nrow(isolate(revals$categorical_cols)) == 0)) NULL + else { + tagList(lapply(1:revals$ntables, function(i) { + DT::dataTableOutput(paste0('Table_', i)) + }) ) } }) @@ -220,45 +220,45 @@ output$categorical_summary <- renderUI({ # display warning if nothing selected observeEvent(input$tests, { - revals$warningmessage_preprocess$no_selection <- if(!isTRUE(length(input$tests) > 0)) "

    Select at least one test to calculate

    " else NULL + revals$warningmessage_preprocess$no_selection <- if (!isTRUE(length(input$tests) > 0)) "

    Select at least one test to calculate

    " else NULL }, ignoreNULL = FALSE) # Success dialogs -observeEvent(revals$uploaded_data,{ +observeEvent(revals$uploaded_data, { req(revals$uploaded_data, input$top_page == 'Preprocess') validate(need(input$tests, message = "Please choose at least one test to calculate")) - - if(!is.null(attributes(revals$peakData2)$filters)){ + + if (!is.null(attributes(revals$peakData2)$filters)) { msg <- "

    You returned to this page after performing filtering, Re-apply filters to update your data

    " } else msg <- NULL - + showModal( modalDialog(title = "Preprocess Success", - fluidRow( - column(10, align = "center", offset = 1, - HTML('

    Your data has been preprocessed. Calculated variables have been added to the molecular identification file and can be used in subsequent filtering and visualization.

    '), - HTML(msg), - hr(), - actionButton('preprocess_dismiss', 'Review results', width = '75%'), - actionButton('goto_qc', 'Go to the QC tab to see some boxplots', style = 'width:75%;margin:5px'), - actionButton('goto_filter', 'Continue to filtering', width = '75%') - ) - ) - ,footer = NULL) - ) + fluidRow( + column(10, align = "center", offset = 1, + HTML('

    Your data has been preprocessed. Calculated variables have been added to the molecular identification file and can be used in subsequent filtering and visualization.

    '), + HTML(msg), + hr(), + actionButton('preprocess_dismiss', 'Review results', width = '75%'), + actionButton('goto_qc', 'Go to the QC tab to see some boxplots', style = 'width:75%;margin:5px'), + actionButton('goto_filter', 'Continue to filtering', width = '75%') + ) + ) + , footer = NULL) + ) }) # End successMessage -observeEvent(input$preprocess_dismiss,{ +observeEvent(input$preprocess_dismiss, { removeModal() - }, priority = 10) +}, priority = 10) -observeEvent(input$goto_filter,{ +observeEvent(input$goto_filter, { updateTabsetPanel(session, "top_page", selected = "Filter") removeModal() }) -observeEvent(input$goto_qc,{ +observeEvent(input$goto_qc, { updateTabsetPanel(session, 'top_page', selected = 'Quality Control') removeModal() -}) \ No newline at end of file +}) diff --git a/Observers/qc_observers.R b/Observers/qc_observers.R index fbc1605..7b107e7 100644 --- a/Observers/qc_observers.R +++ b/Observers/qc_observers.R @@ -1,11 +1,11 @@ -observeEvent(input$goto_filter_fromqc,{ +observeEvent(input$goto_filter_fromqc, { updateTabsetPanel(session, 'top_page', 'Filter') }) # temporarily allow drawing of plot for large data -observeEvent(input$update_boxplot_axes,{ +observeEvent(input$update_boxplot_axes, { revals$redraw_largedata <- TRUE }, priority = 10) -## things to remove input$add_qc_boxplot \ No newline at end of file +## things to remove input$add_qc_boxplot diff --git a/Observers/startup_observers.R b/Observers/startup_observers.R index ccbfa01..da32c7e 100644 --- a/Observers/startup_observers.R +++ b/Observers/startup_observers.R @@ -1,61 +1,61 @@ -#'@details Parse and store header parameters. If 'corems-prefix' is passed, load -#'the files and display a different tab for 'upload'. +#' @details Parse and store header parameters. If 'corems-prefix' is passed, load +#' the files and display a different tab for 'upload'. observe({ query <- parseQueryString(session$clientData$url_search) - + # establish minio connection if we are pulling cloud resources - if(any(names(query) %in% VALID_MINIO_HEADER_PARAMS)) { - cfg_location = if(Sys.getenv("MINIO_CONFIG_PATH") == "") "./cfg/minio_config.yml" else Sys.getenv("MINIO_CONFIG_PATH") + if (any(names(query) %in% VALID_MINIO_HEADER_PARAMS)) { + cfg_location = if (Sys.getenv("MINIO_CONFIG_PATH") == "") "./cfg/minio_config.yml" else Sys.getenv("MINIO_CONFIG_PATH") minio_con <<- mapDataAccess::map_data_connection(cfg_location) } - + on.exit({ Sys.sleep(1) hide("loading-gray-overlay") }) - + isolate({ # store header params in a reactive variable - for(key in names(query)){ + for (key in names(query)) { header_params[[key]] <- query[[key]] message(sprintf("INFO: stored parameter %s: %s", key, query[[key]])) } - - if('corems-prefix' %in% names(query)) { + + if ('corems-prefix' %in% names(query)) { html(selector = "#loading-gray-overlay > div", html = "Loading Core-MS data...") - + uris <- reticulate::iterate( minio_con$client$list_objects( minio_con$bucket, - prefix = header_params[['corems-prefix']], + prefix = header_params[['corems-prefix']], recursive = TRUE), function(x) x$object_name ) - - if(length(uris) > 0) { + + if (length(uris) > 0) { tryCatch({ fpaths <- lapply(uris, function(uri) { mapDataAccess::get_file( - minio_con, id = uri, filename = file.path(tempfile(), basename(uri)), + minio_con, id = uri, filename = file.path(tempfile(), basename(uri)), use_dir = FALSE ) }) - - names(fpaths) <- sapply(fpaths, function(x) basename(tools::file_path_sans_ext(x))) %>% + + names(fpaths) <- sapply(fpaths, function(x) basename(tools::file_path_sans_ext(x))) %>% make.unique() - + corems_revals[['combined_tables']] <- ftmsRanalysis::read_CoreMS_data( - unlist(fpaths), + unlist(fpaths), sample_names = names(fpaths) ) - - for(name in names(fpaths)) { + + for (name in names(fpaths)) { corems_revals[['tables']][[name]] <- read_csv(fpaths[[name]]) corems_revals[['fpaths']][[name]] <- fpaths[[name]] } - + modalmessage <- div(class = "column-scroll-sm", - HTML(info_text[["COREMS_UPLOAD_SUCCESS"]]), + HTML(info_text[["COREMS_UPLOAD_SUCCESS"]]), HTML(paste(names(fpaths), collapse = "
    ")) ) }, error = function(e) { @@ -64,16 +64,16 @@ observe({ } else { modalmessage <- div(info_text[["COREMS_UPLOAD_NOSAMPS"]]) } - + # defined in srv_ui_elements/corems_UI.R showModal(corems_upload_modal(modalmessage)) } - + insertTab( "top_page", target = "Welcome", tab = upload_tab(length(corems_revals[['combined_tables']]) > 0), - position = "after" + position = "after" ) }) }) diff --git a/Observers/upload_observers.R b/Observers/upload_observers.R index dd75c74..6cf1e62 100644 --- a/Observers/upload_observers.R +++ b/Observers/upload_observers.R @@ -2,169 +2,169 @@ observeEvent(input$upload_click, { # prevent multiple clicks shinyjs::disable('upload_click') - shinyjs::show('upload_waiting', anim=T) + shinyjs::show('upload_waiting', anim = T) on.exit({ shinyjs::enable('upload_click') - shinyjs::hide('upload_waiting', anim=T) + shinyjs::hide('upload_waiting', anim = T) }) - + # Error handling: unique identifier chosen validate(need(input$edata_id_col != 'Select one', 'Please select a unique identifier column'), - need(input$edata_id_col %in% edata_cnames() & input$edata_id_col %in% emeta_cnames(), - message = "The chosen ID column does not exist in one or both of the Data/Molecular Identification")) - - validate( + need(input$edata_id_col %in% edata_cnames() & input$edata_id_col %in% emeta_cnames(), + message = "The chosen ID column does not exist in one or both of the Data/Molecular Identification")) + + validate( need(input$select != 0, 'Please select either Formula or Elemental columns'), need(input$isotope_yn != 0, 'Please select yes or no on information for isotopes'), - need(sum(!(Edata()[,input$edata_id_col] %in% Emeta()[,input$edata_id_col])) == 0, - 'Not all peaks in data file are present in molecular identification file, please add/remove these peaks to emeta / from edata') - + need(sum(!(Edata()[, input$edata_id_col] %in% Emeta()[, input$edata_id_col])) == 0, + 'Not all peaks in data file are present in molecular identification file, please add/remove these peaks to emeta / from edata') + ) # End error handling # - + ## If formula column chosen if (input$select == 1) { - + # Error handling: f_column chosen and (if chosen) is of class 'character' validate( need((input$f_column != 'Select one'), - 'Please select a formula column'), + 'Please select a formula column'), need({ - if (input$f_column != 'Select one') - is.character(Emeta()[,input$f_column]) - else + if (input$f_column != 'Select one') + is.character(Emeta()[, input$f_column]) + else FALSE }, # End 'need' - + 'Formula column is not a character vector. Please select another.') - + ) # End error handling # tryCatch({ revals$warningmessage_upload$makeobject_error <- NULL - if (input$isotope_yn == 1 & isTRUE(input$iso_info_filter == 1)) { # If there's C13 # - + if (input$isotope_yn == 1 & isTRUE(input$iso_info_filter == 1)) { # If there's C13 # + # Error handling: entered isotopic notation must exist in the isotope information column validate( need(input$iso_info_column != "0", message = "Please choose a column of isotopic information"), - need(any(Emeta()[,input$iso_info_column] %in% input$iso_symbol), - 'The entered isotopic notation does not match the entries in the chosen isotope information column. Please revise.') + need(any(Emeta()[, input$iso_info_column] %in% input$iso_symbol), + 'The entered isotopic notation does not match the entries in the chosen isotope information column. Please revise.') ) # End error handling - + res <- as.peakData(e_data = Edata(), f_data = fdata(), - e_meta = Emeta(), edata_cname = input$edata_id_col, - fdata_cname = 'SampleId', mass_cname = input$edata_id_col, - mf_cname = input$f_column, - isotopic_cname = input$iso_info_column, - isotopic_notation = as.character(input$iso_symbol), - check_rows = TRUE, data_scale = input$data_scale) - + e_meta = Emeta(), edata_cname = input$edata_id_col, + fdata_cname = 'SampleId', mass_cname = input$edata_id_col, + mf_cname = input$f_column, + isotopic_cname = input$iso_info_column, + isotopic_notation = as.character(input$iso_symbol), + check_rows = TRUE, data_scale = input$data_scale) + } # End C13 / no C13 if statement - - if (input$isotope_yn == 2 | isTRUE(input$iso_info_filter) != 1) { #no C13 + + if (input$isotope_yn == 2 | isTRUE(input$iso_info_filter) != 1) { # no C13 # Calculate peakDataData with formula column res <- as.peakData(e_data = Edata(), f_data = fdata(), - e_meta = Emeta(), edata_cname = input$edata_id_col, - fdata_cname = 'SampleId', mass_cname = input$edata_id_col, - mf_cname = input$f_column, - check_rows = TRUE, data_scale = input$data_scale) - } + e_meta = Emeta(), edata_cname = input$edata_id_col, + fdata_cname = 'SampleId', mass_cname = input$edata_id_col, + mf_cname = input$f_column, + check_rows = TRUE, data_scale = input$data_scale) + } }, - error = function(e){ + error = function(e) { msg = paste0('Error making your peakData: \n System error: ', e) revals$warningmessage_upload$makeobject_error <<- sprintf("

    %s

    ", msg) }) } - + # If elemental columns chosen - if (input$select == 2){ - + if (input$select == 2) { + ## Error handling: all drop down columns nonempty and of class 'numeric' - + # first check that H and C columns are specified and numeric... validate( - need({(input$c_column != 'Select a column') & - (input$h_column != 'Select a column') - }, + need({(input$c_column != 'Select a column') & + (input$h_column != 'Select a column') + }, 'Hydrogen/carbon columns are required. Please double-check drop-down options.') ) validate( need({ - all(is.numeric(Emeta()[,input$c_column])) & - all(is.numeric(Emeta()[,input$h_column])) - }, + all(is.numeric(Emeta()[, input$c_column])) & + all(is.numeric(Emeta()[, input$h_column])) + }, 'One or more elemental columns are non-numeric.') ) # ...then check that -if- other columns are selected, they are numeric - for(col in c('n_column', 'o_column', 's_column', 'p_column')){ - if(input[[col]] != 'Select a column'){ - validate(need(is.numeric(Emeta()[,input[[col]]]), 'One or more elemental columns are non-numeric.')) - } - }# End error handling # + for (col in c('n_column', 'o_column', 's_column', 'p_column')) { + if (input[[col]] != 'Select a column') { + validate(need(is.numeric(Emeta()[, input[[col]]]), 'One or more elemental columns are non-numeric.')) + } + } # End error handling # tryCatch({ revals$warningmessage_upload$makeobject_error <- NULL # If no C13 if (input$isotope_yn == 2 | isTRUE(input$iso_info_filter == 2)) { # Create peakData object res <- as.peakData(e_data = Edata(), f_data = fdata(), - e_meta = Emeta(), edata_cname = input$edata_id_col, - fdata_cname = 'SampleId', mass_cname = input$edata_id_col, - c_cname = input$c_column, h_cname = input$h_column, - n_cname = if(input$n_column == 'Select a column') NULL else input$n_column, - o_cname = if(input$o_column == 'Select a column') NULL else input$o_column, - s_cname = if(input$s_column == 'Select a column') NULL else input$s_column, - p_cname = if(input$p_column == 'Select a column') NULL else input$p_column, - check_rows = TRUE, data_scale = input$data_scale) - + e_meta = Emeta(), edata_cname = input$edata_id_col, + fdata_cname = 'SampleId', mass_cname = input$edata_id_col, + c_cname = input$c_column, h_cname = input$h_column, + n_cname = if (input$n_column == 'Select a column') NULL else input$n_column, + o_cname = if (input$o_column == 'Select a column') NULL else input$o_column, + s_cname = if (input$s_column == 'Select a column') NULL else input$s_column, + p_cname = if (input$p_column == 'Select a column') NULL else input$p_column, + check_rows = TRUE, data_scale = input$data_scale) + } - if (input$isotope_yn == 1 & isTRUE(input$iso_info_filter == 1)) { # If there's C13 # - + if (input$isotope_yn == 1 & isTRUE(input$iso_info_filter == 1)) { # If there's C13 # + # Error handling: entered isotopic notation must exist in the isotope information column validate(need(input$iso_info_column != "0", message = "Please choose a column of isotopic information")) - validate(need(any(Emeta()[,input$iso_info_column] %in% input$iso_symbol), - 'The entered isotopic notation does not match the entries in the chosen isotope information column. Please revise.') + validate(need(any(Emeta()[, input$iso_info_column] %in% input$iso_symbol), + 'The entered isotopic notation does not match the entries in the chosen isotope information column. Please revise.') ) # End error handling - + res <- as.peakData(e_data = Edata(), f_data = fdata(), - e_meta = Emeta(), edata_cname = input$edata_id_col, - fdata_cname = 'SampleId', mass_cname = input$edata_id_col, - c_cname = input$c_column, h_cname = input$h_column, - n_cname = if(input$n_column == 'Select a column') NULL else input$n_column, - o_cname = if(input$o_column == 'Select a column') NULL else input$o_column, - s_cname = if(input$s_column == 'Select a column') NULL else input$s_column, - p_cname = if(input$p_column == 'Select a column') NULL else input$p_column, - isotopic_cname = input$iso_info_column, - isotopic_notation = as.character(input$iso_symbol), - check_rows = TRUE, data_scale = input$data_scale) - + e_meta = Emeta(), edata_cname = input$edata_id_col, + fdata_cname = 'SampleId', mass_cname = input$edata_id_col, + c_cname = input$c_column, h_cname = input$h_column, + n_cname = if (input$n_column == 'Select a column') NULL else input$n_column, + o_cname = if (input$o_column == 'Select a column') NULL else input$o_column, + s_cname = if (input$s_column == 'Select a column') NULL else input$s_column, + p_cname = if (input$p_column == 'Select a column') NULL else input$p_column, + isotopic_cname = input$iso_info_column, + isotopic_notation = as.character(input$iso_symbol), + check_rows = TRUE, data_scale = input$data_scale) + } # End C13 / no C13 if statement - - if (input$NA_value != "NA"){ - res <- edata_replace(res, input$NA_value, NA) + + if (input$NA_value != "NA") { + res <- edata_replace(res, input$NA_value, NA) } }, - error = function(e){ + error = function(e) { msg = paste0('Error making your peakData: \n System error: ', e) revals$warningmessage_upload$makeobject_error <<- sprintf("

    %s

    ", msg) }) - + } # End elemental column if statement - - if(exists('res')){ + + if (exists('res')) { shinyjs::show('upload_success') - + # reset 'removed samples' reval revals$removed_samples <- list() revals$groups_list <- list() updateCollapse(session, 'upload_collapse', close = c('file_upload', 'column_info')) shinyjs::show('ok_idcols') - + revals$uploaded_data <- res } - + }) # End peakData creation # if edata is big, warn the user and prevent plotting of filter barplot -observeEvent(Edata(),{ - if(prod(dim(Edata()[,-1])) > max_cells){ +observeEvent(Edata(), { + if (prod(dim(Edata()[, -1])) > max_cells) { content <- "style = 'color:deepskyblue;font-weight:bold'>Large data file detected, some plotting options and interactivity may be disabled for performance" revals$redraw_largedata <- FALSE } @@ -177,55 +177,55 @@ observeEvent(c(input$top_page, input$file_edata, input$file_emeta), { req(input$top_page == "Upload") toggleCssClass("js_file_edata", "suggest-upload", is.null(input$file_edata)) toggleCssClass("js_file_emeta", "suggest-upload", is.null(input$file_emeta)) - - if(!is.null(input$file_edata) & !is.null(input$file_emeta)){ + + if (!is.null(input$file_edata) & !is.null(input$file_emeta)) { revals$warningmessage_upload$upload <- NULL } - + }, priority = 2) # ID column not selected -observeEvent(input$edata_id_col,{ +observeEvent(input$edata_id_col, { condition <- input$edata_id_col == 'Select one' - if(condition){ + if (condition) { content = "style = 'color:deepskyblue'>Please select a unique identifier column" } else content = NULL toggleCssClass("edata_id", "suggest", condition) - #toggleCssClass("edata_id", "attention", conditions[2] & !conditions[1]) + # toggleCssClass("edata_id", "attention", conditions[2] & !conditions[1]) revals$warningmessage_upload$warnidcol <- content }, priority = 1) # ID column not present in both files, highlight cascade for element/isotope dropdowns -observeEvent(c(input$edata_id_col, Edata(), Emeta(), input$select, input$isotope_yn),{ +observeEvent(c(input$edata_id_col, Edata(), Emeta(), input$select, input$isotope_yn), { req(Edata(), Emeta(), input$edata_id_col != "Select one") - + conditions <- c(!(input$edata_id_col %in% edata_cnames() & input$edata_id_col %in% emeta_cnames()), - isTRUE(is.null(input$select)), - isTRUE(is.null(input$isotope_yn)), - isTRUE(input$f_column == "Select one"), - sum(!(Edata()[[input$edata_id_col]] %in% Emeta()[[input$edata_id_col]])) == 0) - - if(conditions[1]){ + isTRUE(is.null(input$select)), + isTRUE(is.null(input$isotope_yn)), + isTRUE(input$f_column == "Select one"), + sum(!(Edata()[[input$edata_id_col]] %in% Emeta()[[input$edata_id_col]])) == 0) + + if (conditions[1]) { content = "style = 'color:red'>The chosen ID column does not exist in one or both of the Data/Molecular Identification Files" } - else if(conditions[5]){ + else if (conditions[5]) { content = NULL # close top panel Sys.sleep(0.6) updateCollapse(session, 'upload_collapse', close = 'file_upload', open = 'column_info') } else content = NULL - - if(all(!conditions[1], conditions[2])){ + + if (all(!conditions[1], conditions[2])) { content2 = "style = 'color:deepskyblue'>Please select either Formula or Elemental columns" } else content2 = NULL - - if(isTRUE(input$select != 1)){ + + if (isTRUE(input$select != 1)) { revals$warningmessage_upload$formula_col <- NULL } @@ -234,11 +234,11 @@ observeEvent(c(input$edata_id_col, Edata(), Emeta(), input$select, input$isotope toggle('ok_files', condition = !conditions[1] & conditions[5]) revals$warningmessage_upload$warnidcol <- content revals$warningmessage_upload$chooselement <- content2 - + }) -observeEvent(input$select,{ +observeEvent(input$select, { toggleElement('element_select', condition = input$select == 2) }) @@ -246,52 +246,52 @@ observeEvent(input$select,{ observeEvent(c(Edata(), Emeta(), input$edata_id_col), { req(input$edata_id_col) conditions <- FALSE - - if(input$edata_id_col %in% edata_cnames() & input$edata_id_col %in% emeta_cnames()){ - conditions = sum(!(Edata()[,input$edata_id_col] %in% Emeta()[,input$edata_id_col])) != 0 - - if(conditions){ - indices <- (Edata()[,input$edata_id_col] %in% Emeta()[,input$edata_id_col]) - - content = paste0("style = 'color:red'>The following peaks in the data file are not present in the molecular identification file: ", - paste(setdiff(Edata()[,input$edata_id_col], Emeta()[,input$edata_id_col]), collapse = ", ")) + + if (input$edata_id_col %in% edata_cnames() & input$edata_id_col %in% emeta_cnames()) { + conditions = sum(!(Edata()[, input$edata_id_col] %in% Emeta()[, input$edata_id_col])) != 0 + + if (conditions) { + indices <- (Edata()[, input$edata_id_col] %in% Emeta()[, input$edata_id_col]) + + content = paste0("style = 'color:red'>The following peaks in the data file are not present in the molecular identification file: ", + paste(setdiff(Edata()[, input$edata_id_col], Emeta()[, input$edata_id_col]), collapse = ", ")) } else content = NULL } else content <- NULL - + toggleCssClass("js_file_edata", "attention-upload", any(conditions)) toggleCssClass("js_file_emeta", "attention-upload", any(conditions)) revals$warningmessage_upload$idcolmismatch <- content - + }) # Highlight # ISO info column not selected or doesn't contain selected symbol observeEvent(c(input$iso_info_column, input$iso_symbol, input$isotope_yn, input$select), { - - if(isTRUE(input$isotope_yn != "1")){ + + if (isTRUE(input$isotope_yn != "1")) { revals$warningmessage_upload$warniso <- NULL } - else{ + else { req(!is.null(input$iso_info_column)) req(!is.null(input$iso_symbol)) - + conditions <- isTRUE(input$iso_info_column == "0") - - if(conditions){ - if(isTRUE(input$select != 0)){ + + if (conditions) { + if (isTRUE(input$select != 0)) { content <- "style = 'color:deepskyblue'>Please choose a column of isotopic information" } else content <- NULL } - else if(isTRUE(!(any(Emeta()[,input$iso_info_column] %in% input$iso_symbol)))){ - conditions[2] <- isTRUE(!(any(Emeta()[,input$iso_info_column] %in% input$iso_symbol))) + else if (isTRUE(!(any(Emeta()[, input$iso_info_column] %in% input$iso_symbol)))) { + conditions[2] <- isTRUE(!(any(Emeta()[, input$iso_info_column] %in% input$iso_symbol))) content <- "style = 'color:red'>The entered isotopic notation does not match the entries in the chosen isotope information column. Please revise." } else content = NULL - + toggleCssClass("js_iso_info_column", "suggest", conditions[1] & input$select != 0) toggleCssClass("js_iso_symbol", "attention", isTRUE(conditions[2])) revals$warningmessage_upload$warniso <- content @@ -299,130 +299,130 @@ observeEvent(c(input$iso_info_column, input$iso_symbol, input$isotope_yn, input$ }) # Non-numeric or non-selected elemental columns -observeEvent(c(input$c_column, input$h_column, input$n_column, - input$o_column, input$s_column, input$p_column, - input$select, input$isotope_yn),{ - - req(Edata(), Emeta(), input$edata_id_col != "Select one") - +observeEvent(c(input$c_column, input$h_column, input$n_column, + input$o_column, input$s_column, input$p_column, + input$select, input$isotope_yn), { + + req(Edata(), Emeta(), input$edata_id_col != "Select one") + elcols <- c(input$c_column, input$h_column) conditions <- isTRUE(any(elcols == 'Select a column') | any(is.null(elcols))) - - if(conditions[1]){ - if(isTRUE(input$select == 2)){ + + if (conditions[1]) { + if (isTRUE(input$select == 2)) { content = "style = 'color:deepskyblue'>One or more element selections are missing, Please double-check drop-down options." } else content = NULL content_isoyn = NULL - }else if(isTRUE(any(sapply(elcols, function(col){!is.numeric(Emeta()[,col])}))) & isTRUE(input$select == 2)){ - conditions[2] <- isTRUE(any(sapply(elcols, function(col){!is.numeric(Emeta()[,col])}))) - if(isTRUE(input$select == 2)){ + } else if (isTRUE(any(sapply(elcols, function(col) {!is.numeric(Emeta()[, col])}))) & isTRUE(input$select == 2)) { + conditions[2] <- isTRUE(any(sapply(elcols, function(col) {!is.numeric(Emeta()[, col])}))) + if (isTRUE(input$select == 2)) { content = "style = 'color:red'>One or more elemental columns are non-numeric" } else content = NULL content_isoyn = NULL } - else{ + else { content = NULL - if(isTRUE(is.null(input$isotope_yn) & input$select != 0)){ + if (isTRUE(is.null(input$isotope_yn) & input$select != 0)) { content_isoyn = "style = 'color:deepskyblue'>Please indicate whether isotope information is present in the molecular identification file" } else content_isoyn = NULL } - + toggleCssClass("element_select", "blueoutline", isTRUE(conditions[1])) toggleCssClass("element_select", "redoutline", isTRUE(conditions[2])) toggleCssClass("js_isotope_yn", "suggest", all(!any(conditions), is.null(input$isotope_yn), input$select != 0)) revals$warningmessage_upload$elements <- content revals$warningmessage_upload$chooseiso <- content_isoyn - + }) -# Non-character elemental column -observeEvent(c(input$f_column,input$select, input$isotope_yn),{ - +# Non-character elemental column +observeEvent(c(input$f_column, input$select, input$isotope_yn), { + req(Edata(), Emeta(), input$edata_id_col != "Select one", input$f_column) - + conditions <- FALSE conditions[2] <- input$f_column == "Select one" - - if(conditions[2]){ - if(input$select == 1){ + + if (conditions[2]) { + if (input$select == 1) { content = "style = 'color:deepskyblue'>Specify a column which contains alphanumeric formulae" } else content = NULL - content_isoyn = NULL + content_isoyn = NULL } - else if(!is.character(Emeta()[,input$f_column]) & input$select == 1){ - conditions[1] <- !is.character(Emeta()[,input$f_column]) - if(input$select == 1){ + else if (!is.character(Emeta()[, input$f_column]) & input$select == 1) { + conditions[1] <- !is.character(Emeta()[, input$f_column]) + if (input$select == 1) { content = "style = 'color:red'>Specified formula column does not contain character strings" } else content = NULL content_isoyn = NULL } - else{ + else { content = NULL - if(is.null(input$isotope_yn) & input$select != 0){ + if (is.null(input$isotope_yn) & input$select != 0) { content_isoyn = "style = 'color:deepskyblue'>Please indicate whether isotope information is present in the molecular identification file" } else content_isoyn = NULL } - + toggleCssClass("f_column", "attention", conditions[1]) toggleCssClass("f_column", "suggest", !conditions[1] & conditions[2]) toggleCssClass("js_isotope_yn", "suggest", all(!any(conditions), is.null(input$isotope_yn), input$select != 0)) revals$warningmessage_upload$chooseiso <- content_isoyn revals$warningmessage_upload$formula_col <- content - + }) # warning dialog on iso filter -observeEvent(input$iso_info_filter,{ +observeEvent(input$iso_info_filter, { if (input$iso_info_filter == 2) showModal( - modalDialog("",h4("Warning!", style = "color:Orange; font-weight:bold"), - HTML("

    Leaving isotopic peaks in the data may confound analysis/visualization results. We recommend filtering isotopic peaks.") + modalDialog("", h4("Warning!", style = "color:Orange; font-weight:bold"), + HTML("

    Leaving isotopic peaks in the data may confound analysis/visualization results. We recommend filtering isotopic peaks.") ) ) }) -# Show success message when revals$uploaded_data is sucessfully created -observeEvent(revals$uploaded_data,{ - #Error handling: revals$uploaded_data must exist +# Show success message when revals$uploaded_data is sucessfully created +observeEvent(revals$uploaded_data, { + # Error handling: revals$uploaded_data must exist req(revals$uploaded_data) req(grepl('^Upload$|^CoreMS-', input$top_page)) - - #___test-export___ + + # ___test-export___ if (isTRUE(getOption("shiny.testmode"))) { revals$peakData_export <- revals$uploaded_data } - + showModal( modalDialog( title = "Upload Success", fluidRow( column(10, align = "center", offset = 1, - HTML('

    Your data object has been successfully created. + HTML('

    Your data object has been successfully created. You may proceed to the subsequent tabs for analysis.

    '), - hr(), - actionButton("upload_dismiss", "Review results", width = '75%'), - actionButton("goto_groups", "Continue to groups tab", style = "margin:5px;width:75%"), - actionButton("goto_preprocess", "Skip to preprocess tab", width = '75%') - ) + hr(), + actionButton("upload_dismiss", "Review results", width = '75%'), + actionButton("goto_groups", "Continue to groups tab", style = "margin:5px;width:75%"), + actionButton("goto_preprocess", "Skip to preprocess tab", width = '75%') + ) ) - ,footer = NULL) + , footer = NULL) ) - + message('enabling data upload inputs') # enable inputs that should only be available if data is sucessfully uploaded disabled_inputs <- c("preprocess_click", "filter_click", "reset_filters", "plot_submit", "update_axes", "visualize_goto_linked") lapply(disabled_inputs, enable) - + }) # modal dialog behavior -observeEvent(input$upload_dismiss,{removeModal()}) +observeEvent(input$upload_dismiss, {removeModal()}) observeEvent(input$goto_groups, { updateTabsetPanel(session, "top_page", selected = "Groups") @@ -433,7 +433,3 @@ observeEvent(input$goto_preprocess, { updateTabsetPanel(session, "top_page", selected = "Preprocess") removeModal() }) - - - - diff --git a/Observers/visualize_observers.R b/Observers/visualize_observers.R index 6606f41..3444ddf 100644 --- a/Observers/visualize_observers.R +++ b/Observers/visualize_observers.R @@ -2,117 +2,117 @@ ### REACTIVE PLOT OPTIONS BELOW MAIN PLOT WINDOW ### # When plot_data() is recalculated, repopulate the dropdowns under the plot. Specifically vk_colors and custom scatterplot options. -observeEvent(plot_data(),{ - +observeEvent(plot_data(), { + # store test value if (isTRUE(getOption("shiny.testmode"))) { revals$plot_data_export <- plot_data() } - + ## ifelse block determines how to populate vk_colors dropdown - + # Density plots care not for choose_single!!!! - if (input$chooseplots == "Density Plot"){ - numeric_cols <- which(sapply(plot_data()$e_meta %>% - dplyr::select(one_of(emeta_display_choices())), is.numeric)) + if (input$chooseplots == "Density Plot") { + numeric_cols <- which(sapply(plot_data()$e_meta %>% + dplyr::select(one_of(emeta_display_choices())), is.numeric)) color_by_choices <- emeta_display_choices()[numeric_cols] } - else if (input$choose_single == 1){ + else if (input$choose_single == 1) { color_by_choices <- emeta_display_choices() - - if (input$chooseplots == "Van Krevelen Plot"){ + + if (input$chooseplots == "Van Krevelen Plot") { color_by_choices <- switch(input$vkbounds, - 'bs1' = c('Van Krevelen Boundary Set' = 'bs1', color_by_choices), - 'bs2' = c('Van Krevelen Boundary Set' = 'bs2', color_by_choices), - "0" = c('Van Krevelen Boundary Set 1' = 'bs1', 'Van Krevelen Boundary Set 2' = 'bs2', color_by_choices)) + 'bs1' = c('Van Krevelen Boundary Set' = 'bs1', color_by_choices), + 'bs2' = c('Van Krevelen Boundary Set' = 'bs2', color_by_choices), + "0" = c('Van Krevelen Boundary Set 1' = 'bs1', 'Van Krevelen Boundary Set 2' = 'bs2', color_by_choices)) } } else if (input$choose_single == 2) { - + # create vector of color choices by combining unique elements from e_data and e_meta edata_colors <- plot_data()$e_data %>% dplyr::select(-one_of(getEDataColName(plot_data()))) %>% colnames() color_by_choices <- c(edata_colors[!(edata_colors %in% emeta_display_choices())], emeta_display_choices()) - - } else if (input$choose_single %in% c(3,4)) { + + } else if (input$choose_single %in% c(3, 4)) { color_by_choices <- c("Group membership" = input$summary_fxn) } - + # Give default names to unnamed choices - names(color_by_choices) <- sapply(1:length(color_by_choices), function(i){ + names(color_by_choices) <- sapply(1:length(color_by_choices), function(i) { ifelse(names(color_by_choices[i]) == "" | is.null(names(color_by_choices[i])), - yes = color_by_choices[i], - no = names(color_by_choices[i])) + yes = color_by_choices[i], + no = names(color_by_choices[i])) }) - + # if statements which prevent plot from resetting colors/axes when plot is redrawn. selected = color_by_choices[1] - - if (input$vk_colors %in% color_by_choices){ + + if (input$vk_colors %in% color_by_choices) { selected <- input$vk_colors } - + selected_x = color_by_choices[color_by_choices != selected][1] selected_y = color_by_choices[!(color_by_choices %in% c(selected, selected_x))][1] - - if ((input$scatter_x %in% color_by_choices) & (input$scatter_y %in% color_by_choices)){ + + if ((input$scatter_x %in% color_by_choices) & (input$scatter_y %in% color_by_choices)) { selected_x <- input$scatter_x selected_y <- input$scatter_y } - + # Density Colors if (input$chooseplots == 'Density Plot') { - updateSelectInput(session, 'vk_colors', 'Plot Distribution of Variable:', - choices = color_by_choices, - selected = selected) + updateSelectInput(session, 'vk_colors', 'Plot Distribution of Variable:', + choices = color_by_choices, + selected = selected) } - + # Kendrick Colors if (input$chooseplots == 'Kendrick Plot') { updateSelectInput(session, 'vk_colors', 'Color by:', - choices = color_by_choices, - selected = selected) + choices = color_by_choices, + selected = selected) } - + # Van Krevelen Colors if (input$chooseplots == 'Van Krevelen Plot') { updateSelectInput(session, 'vk_colors', 'Color by:', - choices = color_by_choices, - selected = selected) + choices = color_by_choices, + selected = selected) } - + if (input$chooseplots %in% c('Custom Scatter Plot', 'PCOA Plot')) { # allow only numeric columns for the axes but keep categorical coloring options numeric_cols <- which(sapply(full_join(plot_data()$e_meta, plot_data()$e_data) %>% dplyr::select(color_by_choices), is.numeric)) - + # maintain exclusivity of colorby and x-y variables only in scatterplot - if(input$chooseplots == 'Custom Scatter Plot'){ + if (input$chooseplots == 'Custom Scatter Plot') { axes_choices <- revals$axes_choices <- color_by_choices[numeric_cols] - + updateSelectInput(session, 'scatter_x', "Horizontal axis variable:", - choices = axes_choices[!(axes_choices %in% c(input$scatter_y, input$vk_colors))], - selected = selected_x) + choices = axes_choices[!(axes_choices %in% c(input$scatter_y, input$vk_colors))], + selected = selected_x) updateSelectInput(session, "scatter_y", "Vertical axis variable:", - choices = axes_choices[!(axes_choices %in% c(input$scatter_x, input$vk_colors))], - selected = selected_y) + choices = axes_choices[!(axes_choices %in% c(input$scatter_x, input$vk_colors))], + selected = selected_y) updateSelectInput(session, 'vk_colors', 'Color by:', - choices = color_by_choices[!(color_by_choices %in% c(input$scatter_x, input$scatter_y))], - selected = selected) + choices = color_by_choices[!(color_by_choices %in% c(input$scatter_x, input$scatter_y))], + selected = selected) } - else if(input$chooseplots == 'PCOA Plot'){ - axes_choices <- 1:min(5, ncol(revals$peakData2$e_data)-2) + else if (input$chooseplots == 'PCOA Plot') { + axes_choices <- 1:min(5, ncol(revals$peakData2$e_data) - 2) names(axes_choices) <- paste0('PC', axes_choices) selected_x <- 1 selected_y <- 2 } } - + revals$color_by_choices <- color_by_choices - + # The dropdown value will not be updated if this if statement's condition is true, force re-execution of plotting in this case with a reactive var - if (input$vk_colors %in% color_by_choices){ + if (input$vk_colors %in% color_by_choices) { revals$makeplot <- -revals$makeplot } - + }, priority = 9) # @@ -128,97 +128,97 @@ observeEvent(input$top_page, { }, priority = 10) # shinyjs helpers and reactive value storage for selection inputs -observeEvent(c(input$top_page, input$chooseplots, input$choose_single, input$whichSamples, - g1_samples(), g2_samples()),{ - req(input$top_page == "Visualize") - # show/hide dropdowns for sample selection depending on single sample/single group/group comparison - toggle("js_toggle_groups", condition = input$choose_single %in% c(3,4)) - toggle("js_toggle_single", condition = input$choose_single %in% c(1,2)) - - # conditionally apply blue outlines to help user along sample selection process - toggleCssClass("plot_type", "suggest", is.null(input$chooseplots)) - toggleCssClass("plotUI", "suggest", !is.null(input$chooseplots) & input$choose_single == 0) - toggleCssClass("js_whichSamples", "suggest", any(input$choose_single %in% c(1,2) & is.null(input$whichSamples), - input$choose_single == 2 & any(length(input$whichSamples) < 2, is.null(input$whichSamples)))) - toggleCssClass("js_whichGroups1", "suggest", input$choose_single == 3 & is.null(g1_samples())) - toggleCssClass("js_whichGroups2", "suggest", input$choose_single == 3 & is.null(g2_samples())) - - toggleElement("warnings_visualize", condition = isTRUE(input$choose_single != 0 & !is.null(input$chooseplots))) - - revals$chooseplots <- input$chooseplots - }) +observeEvent(c(input$top_page, input$chooseplots, input$choose_single, input$whichSamples, + g1_samples(), g2_samples()), { + req(input$top_page == "Visualize") + # show/hide dropdowns for sample selection depending on single sample/single group/group comparison + toggle("js_toggle_groups", condition = input$choose_single %in% c(3, 4)) + toggle("js_toggle_single", condition = input$choose_single %in% c(1, 2)) + + # conditionally apply blue outlines to help user along sample selection process + toggleCssClass("plot_type", "suggest", is.null(input$chooseplots)) + toggleCssClass("plotUI", "suggest", !is.null(input$chooseplots) & input$choose_single == 0) + toggleCssClass("js_whichSamples", "suggest", any(input$choose_single %in% c(1, 2) & is.null(input$whichSamples), + input$choose_single == 2 & any(length(input$whichSamples) < 2, is.null(input$whichSamples)))) + toggleCssClass("js_whichGroups1", "suggest", input$choose_single == 3 & is.null(g1_samples())) + toggleCssClass("js_whichGroups2", "suggest", input$choose_single == 3 & is.null(g2_samples())) + + toggleElement("warnings_visualize", condition = isTRUE(input$choose_single != 0 & !is.null(input$chooseplots))) + + revals$chooseplots <- input$chooseplots +}) # helpers for summary functions observeEvent(c(input$top_page, input$choose_single, g1_samples(), g2_samples(), - input$summary_fxn, input$pres_thresh, input$pres_fn, input$absn_thresh, input$pval),{ - req(input$top_page == "Visualize") - - toggleCssClass("js_summary_fxn", "suggest", input$choose_single %in% c(3,4) & all(!is.null(g1_samples()), !is.null(g2_samples())) & !(input$summary_fxn %in% ftmsRanalysis:::getGroupComparisonSummaryFunctionNames())) - - # conditions different between counts and proportion - if (isTRUE(input$pres_fn == "nsamps") & isTRUE(input$choose_single %in% c(3,4))){ - # g test warning conditions different from pres/absn conditions - if(isTRUE(input$summary_fxn == "uniqueness_gtest")){ - # logical conditions that are TRUE if the user did something wrong - cond_pval <- any(input$pval <= 0, input$pval >= 1) - cond_pres <- any(input$pres_thresh > min(length(g1_samples()), length(g2_samples())), - input$pres_thresh < 1, - !is.numeric(input$pres_thresh)) - toggleCssClass("js_pval", "attention", cond_pval) - toggleCssClass("js_pres_thresh", "attention", cond_pres) - - # warning message content displayed below dropdowns - content_pval <- if(isTRUE(cond_pval)) "

    P-value must be between 0 and 1

    " else NULL - content_pres <- if(isTRUE(cond_pres)) "

    Presence threshold must be a numeric value of at least 1 and no more than the minimum number of samples in a group

    " else NULL - content_absn <- NULL - } - else if(isTRUE(input$summary_fxn == "uniqueness_nsamps") & isTRUE(input$choose_single %in% c(3,4))){ - cond_pres <- any(input$pres_thresh > min(length(g1_samples()), length(g2_samples())), input$pres_thresh < 1, - !is.numeric(input$pres_thresh), input$absn_thresh >= input$pres_thresh) - cond_absn <- any(input$absn_thresh > min(length(g1_samples()), length(g2_samples())) - 1, input$absn_thresh < 0, - !is.numeric(input$absn_thresh), input$absn_thresh >= input$pres_thresh) - - toggleCssClass("js_pres_thresh", "attention", cond_pres) - toggleCssClass("js_absn_thresh", "attention", cond_absn) - - content_pval <- NULL - content_pres <- if(isTRUE(cond_pres)) "

    Presence threshold must be a numeric value of at least 1, no more than the minimum number of samples in a group, and greater than the absence threshold.

    " else NULL - content_absn <- if(isTRUE(cond_absn)) "

    Absence threshold must be a numeric value less than the minimum group size and less than the presence threshold.

    " else NULL - } - else content_pval <- content_pres <- content_absn <- NULL - } - else if (isTRUE(input$pres_fn == "prop") & isTRUE(input$choose_single %in% c(3,4))){ - if(isTRUE(input$summary_fxn == "uniqueness_gtest")){ - cond_pval <- any(input$pval <= 0, input$pval >= 1) - cond_pres <- any(input$pres_thresh > 1, input$pres_thresh <= 0, !is.numeric(input$pres_thresh)) - toggleCssClass("js_pval", "attention", cond_pval) - toggleCssClass("js_pres_thresh", "attention", cond_pres) - - content_pval <- if(isTRUE(cond_pval)) "

    P-value must be between 0 and 1

    " else NULL - content_pres <- if(isTRUE(cond_pres)) "

    Presence threshold must be a numeric value greater than 0 and at most 1

    " else NULL - content_absn <- NULL - } - else if(isTRUE(input$summary_fxn == "uniqueness_prop") & isTRUE(input$choose_single %in% c(3,4))){ - cond_pres <- any(input$pres_thresh > 1, input$pres_thresh <= 0, !is.numeric(input$pres_thresh), input$absn_thresh >= input$pres_thresh) - cond_absn <- any(input$absn_thresh >= 1, input$absn_thresh < 0, !is.numeric(input$absn_thresh), input$absn_thresh >= input$pres_thresh) - - toggleCssClass("js_pres_thresh", "attention", cond_pres) - toggleCssClass("js_absn_thresh", "attention", cond_absn) - - content_pval <- NULL - content_pres <- if(isTRUE(cond_pres)) "

    Presence threshold must be a numeric value greater than 0, at most 1, and greater than the absence threshold.

    " else NULL - content_absn <- if(isTRUE(cond_absn)) "

    Absence threshold must be a non-negative numeric value less than the presence threshold.

    " else NULL - - } - else content_pval <- content_pres <- content_absn <- NULL - } - else content_pval <- content_pres <- content_absn <- NULL - - # store warning messages in reactive list. this list is split and rendered in output$warningmessage_visualize - revals$warningmessage_visualize$content_pval <- content_pval - revals$warningmessage_visualize$content_pres <- content_pres - revals$warningmessage_visualize$content_absn <- content_absn - }) + input$summary_fxn, input$pres_thresh, input$pres_fn, input$absn_thresh, input$pval), { + req(input$top_page == "Visualize") + + toggleCssClass("js_summary_fxn", "suggest", input$choose_single %in% c(3, 4) & all(!is.null(g1_samples()), !is.null(g2_samples())) & !(input$summary_fxn %in% ftmsRanalysis:::getGroupComparisonSummaryFunctionNames())) + + # conditions different between counts and proportion + if (isTRUE(input$pres_fn == "nsamps") & isTRUE(input$choose_single %in% c(3, 4))) { + # g test warning conditions different from pres/absn conditions + if (isTRUE(input$summary_fxn == "uniqueness_gtest")) { + # logical conditions that are TRUE if the user did something wrong + cond_pval <- any(input$pval <= 0, input$pval >= 1) + cond_pres <- any(input$pres_thresh > min(length(g1_samples()), length(g2_samples())), + input$pres_thresh < 1, + !is.numeric(input$pres_thresh)) + toggleCssClass("js_pval", "attention", cond_pval) + toggleCssClass("js_pres_thresh", "attention", cond_pres) + + # warning message content displayed below dropdowns + content_pval <- if (isTRUE(cond_pval)) "

    P-value must be between 0 and 1

    " else NULL + content_pres <- if (isTRUE(cond_pres)) "

    Presence threshold must be a numeric value of at least 1 and no more than the minimum number of samples in a group

    " else NULL + content_absn <- NULL + } + else if (isTRUE(input$summary_fxn == "uniqueness_nsamps") & isTRUE(input$choose_single %in% c(3, 4))) { + cond_pres <- any(input$pres_thresh > min(length(g1_samples()), length(g2_samples())), input$pres_thresh < 1, + !is.numeric(input$pres_thresh), input$absn_thresh >= input$pres_thresh) + cond_absn <- any(input$absn_thresh > min(length(g1_samples()), length(g2_samples())) - 1, input$absn_thresh < 0, + !is.numeric(input$absn_thresh), input$absn_thresh >= input$pres_thresh) + + toggleCssClass("js_pres_thresh", "attention", cond_pres) + toggleCssClass("js_absn_thresh", "attention", cond_absn) + + content_pval <- NULL + content_pres <- if (isTRUE(cond_pres)) "

    Presence threshold must be a numeric value of at least 1, no more than the minimum number of samples in a group, and greater than the absence threshold.

    " else NULL + content_absn <- if (isTRUE(cond_absn)) "

    Absence threshold must be a numeric value less than the minimum group size and less than the presence threshold.

    " else NULL + } + else content_pval <- content_pres <- content_absn <- NULL + } + else if (isTRUE(input$pres_fn == "prop") & isTRUE(input$choose_single %in% c(3, 4))) { + if (isTRUE(input$summary_fxn == "uniqueness_gtest")) { + cond_pval <- any(input$pval <= 0, input$pval >= 1) + cond_pres <- any(input$pres_thresh > 1, input$pres_thresh <= 0, !is.numeric(input$pres_thresh)) + toggleCssClass("js_pval", "attention", cond_pval) + toggleCssClass("js_pres_thresh", "attention", cond_pres) + + content_pval <- if (isTRUE(cond_pval)) "

    P-value must be between 0 and 1

    " else NULL + content_pres <- if (isTRUE(cond_pres)) "

    Presence threshold must be a numeric value greater than 0 and at most 1

    " else NULL + content_absn <- NULL + } + else if (isTRUE(input$summary_fxn == "uniqueness_prop") & isTRUE(input$choose_single %in% c(3, 4))) { + cond_pres <- any(input$pres_thresh > 1, input$pres_thresh <= 0, !is.numeric(input$pres_thresh), input$absn_thresh >= input$pres_thresh) + cond_absn <- any(input$absn_thresh >= 1, input$absn_thresh < 0, !is.numeric(input$absn_thresh), input$absn_thresh >= input$pres_thresh) + + toggleCssClass("js_pres_thresh", "attention", cond_pres) + toggleCssClass("js_absn_thresh", "attention", cond_absn) + + content_pval <- NULL + content_pres <- if (isTRUE(cond_pres)) "

    Presence threshold must be a numeric value greater than 0, at most 1, and greater than the absence threshold.

    " else NULL + content_absn <- if (isTRUE(cond_absn)) "

    Absence threshold must be a non-negative numeric value less than the presence threshold.

    " else NULL + + } + else content_pval <- content_pres <- content_absn <- NULL + } + else content_pval <- content_pres <- content_absn <- NULL + + # store warning messages in reactive list. this list is split and rendered in output$warningmessage_visualize + revals$warningmessage_visualize$content_pval <- content_pval + revals$warningmessage_visualize$content_pres <- content_pres + revals$warningmessage_visualize$content_absn <- content_absn +}) # logical reactive value that clears the plot if a new type is selected v <- reactiveValues(clearPlot = TRUE) @@ -235,27 +235,27 @@ observeEvent(input$flip_colors, { }) # make the options mutually exclusive when doing a comparison of two groups -observeEvent(input$whichGroups2,{ +observeEvent(input$whichGroups2, { req(!is.null(revals$peakData2)) updatePickerInput(session, "whichGroups1", choices = setdiff(names(revals$groups_list), input$whichGroups2), selected = input$whichGroups1) }) -observeEvent(input$whichGroups1,{ +observeEvent(input$whichGroups1, { req(!is.null(revals$peakData2)) updatePickerInput(session, "whichGroups2", choices = setdiff(names(revals$groups_list), input$whichGroups1), selected = input$whichGroups2) }) # make the options mutually exclusive when doing a comparison of two samples -observeEvent(input$whichSample2,{ +observeEvent(input$whichSample2, { req(!is.null(revals$peakData2)) - updatePickerInput(session, "whichSample1", - choices = setdiff(colnames(revals$peakData2$e_data[-which(colnames(revals$peakData2$e_data) == getEDataColName(revals$peakData2))]), input$whichSample2), - selected = input$whichSample1) + updatePickerInput(session, "whichSample1", + choices = setdiff(colnames(revals$peakData2$e_data[-which(colnames(revals$peakData2$e_data) == getEDataColName(revals$peakData2))]), input$whichSample2), + selected = input$whichSample1) }) -observeEvent(input$whichSample1,{ +observeEvent(input$whichSample1, { req(!is.null(revals$peakData2)) - updatePickerInput(session, "whichSample2", - choices = setdiff(colnames(revals$peakData2$e_data[-which(colnames(revals$peakData2$e_data) == getEDataColName(revals$peakData2))]), input$whichSample1), - selected = input$whichSample2) + updatePickerInput(session, "whichSample2", + choices = setdiff(colnames(revals$peakData2$e_data[-which(colnames(revals$peakData2$e_data) == getEDataColName(revals$peakData2))]), input$whichSample1), + selected = input$whichSample2) }) # Multi purpose observer on input$chooseplots @@ -263,84 +263,84 @@ observeEvent(input$chooseplots, { # Pre-populate dropdowns so users can select colors and custom scatterplot axes before submitting plot. # Need a vector of the numeric columns to pass to scatterplot numeric_cols <- which(sapply(revals$peakData2$e_meta %>% dplyr::select(emeta_display_choices()), is.numeric)) - - color_select_label <- if(input$chooseplots == 'Density Plot') "Plot Distribution of Variable:" else "Color by:" - + + color_select_label <- if (input$chooseplots == 'Density Plot') "Plot Distribution of Variable:" else "Color by:" + updateSelectInput(session, 'vk_colors', label = color_select_label, choices = emeta_display_choices(), selected = emeta_display_choices()[1]) - - if(input$chooseplots == 'Custom Scatter Plot'){ + + if (input$chooseplots == 'Custom Scatter Plot') { updateSelectInput(session, 'scatter_x', choices = emeta_display_choices()[numeric_cols][-3], selected = emeta_display_choices()[numeric_cols][2]) updateSelectInput(session, 'scatter_y', choices = emeta_display_choices()[numeric_cols][-2], selected = emeta_display_choices()[numeric_cols][3]) } - else if(input$chooseplots == 'PCOA Plot') { - axes_choices <- 1:min(5, ncol(revals$peakData2$e_data)-2) + else if (input$chooseplots == 'PCOA Plot') { + axes_choices <- 1:min(5, ncol(revals$peakData2$e_data) - 2) names(axes_choices) <- paste0('PC', axes_choices) - updateSelectInput(session, 'scatter_x', choices = axes_choices, selected=1) - updateSelectInput(session, 'scatter_y', choices = axes_choices, selected=2) + updateSelectInput(session, 'scatter_x', choices = axes_choices, selected = 1) + updateSelectInput(session, 'scatter_y', choices = axes_choices, selected = 2) } - + # Rest of this observer controls shinyjs disable/enable behavior for reactive plot dropdowns dropdown_ids <- c('vkbounds', 'vk_colors', 'scatter_x', 'scatter_y', 'colorpal', 'legend_title_input') - choices = list('Van Krevelen Plot' = c('vk_colors', 'vkbounds', 'colorpal', 'legend_title_input'), - 'Kendrick Plot' = c('vk_colors', 'colorpal', 'legend_title_input'), - 'Density Plot' = 'vk_colors', - 'Custom Scatter Plot' = c('vk_colors', 'scatter_x', 'scatter_y', 'colorpal', 'legend_title_input'), - 'PCOA Plot' = c('scatter_x', 'scatter_y', 'legend_title_input'), - 'Select an Option' = '0') - + choices = list('Van Krevelen Plot' = c('vk_colors', 'vkbounds', 'colorpal', 'legend_title_input'), + 'Kendrick Plot' = c('vk_colors', 'colorpal', 'legend_title_input'), + 'Density Plot' = 'vk_colors', + 'Custom Scatter Plot' = c('vk_colors', 'scatter_x', 'scatter_y', 'colorpal', 'legend_title_input'), + 'PCOA Plot' = c('scatter_x', 'scatter_y', 'legend_title_input'), + 'Select an Option' = '0') + # Toggle axes and coloring options depending on plot type - lapply(dropdown_ids, function(inputid){ + lapply(dropdown_ids, function(inputid) { toggleState(inputid, condition = inputid %in% choices[[input$chooseplots]]) toggleCssClass(paste0("js_", inputid), "grey_out", condition = !(inputid %in% choices[[input$chooseplots]])) }) }) # maintain mutual exclusivity of scatterplot axes and colors -observeEvent(c(input$scatter_x, input$vk_colors),{ +observeEvent(c(input$scatter_x, input$vk_colors), { req(input$chooseplots == 'Custom Scatter Plot') - updateSelectInput(session, 'scatter_y', - choices = revals$axes_choices[!(revals$axes_choices %in% c(input$scatter_x, input$vk_colors))], - selected = input$scatter_y) + updateSelectInput(session, 'scatter_y', + choices = revals$axes_choices[!(revals$axes_choices %in% c(input$scatter_x, input$vk_colors))], + selected = input$scatter_y) }) -observeEvent(c(input$scatter_y, input$vk_colors),{ +observeEvent(c(input$scatter_y, input$vk_colors), { req(input$chooseplots == 'Custom Scatter Plot') - updateSelectInput(session, 'scatter_x', - choices = revals$axes_choices[!(revals$axes_choices %in% c(input$scatter_y, input$vk_colors))], - selected = input$scatter_x) + updateSelectInput(session, 'scatter_x', + choices = revals$axes_choices[!(revals$axes_choices %in% c(input$scatter_y, input$vk_colors))], + selected = input$scatter_x) }) -observeEvent(c(input$scatter_x, input$scatter_y),{ +observeEvent(c(input$scatter_x, input$scatter_y), { req(input$chooseplots == 'Custom Scatter Plot') - updateSelectInput(session, 'vk_colors', - choices = revals$color_by_choices[!(revals$color_by_choices %in% c(input$scatter_y, input$scatter_x))], - selected = input$vk_colors) + updateSelectInput(session, 'vk_colors', + choices = revals$color_by_choices[!(revals$color_by_choices %in% c(input$scatter_y, input$scatter_x))], + selected = input$vk_colors) }) # disable plot_submit and add warning if groups are overlapping -observeEvent(c(input$whichGroups1, input$whichGroups2, input$chooseplots, g1_samples(), g2_samples()),{ +observeEvent(c(input$whichGroups1, input$whichGroups2, input$chooseplots, g1_samples(), g2_samples()), { overlap <- intersect(g1_samples(), g2_samples()) cond_overlap <- length(overlap) != 0 - + toggleState('plot_submit', !(cond_overlap & isTRUE(input$choose_single == 3))) - revals$warningmessage_visualize$group_overlap <- if(cond_overlap & isTRUE(input$choose_single == 3)) sprintf("

    Please choose mutually exclusive groups. The following samples were present in both groups: %s.

    ", paste(overlap, collapse = ", ")) else NULL - + revals$warningmessage_visualize$group_overlap <- if (cond_overlap & isTRUE(input$choose_single == 3)) sprintf("

    Please choose mutually exclusive groups. The following samples were present in both groups: %s.

    ", paste(overlap, collapse = ", ")) else NULL + }) # Observer which greys-out colorscale selection if we have not selected a numeric column to color by -observeEvent(numeric_selected(),{ +observeEvent(numeric_selected(), { req(input$chooseplots != "Density Plot") - if(numeric_selected()){ + if (numeric_selected()) { enable("colorpal") removeCssClass("js_colorpal", "grey_out") - + enable("legend_title_input") removeCssClass("js_legend_title_input", "grey_out") } - else if(!numeric_selected()){ - if(!(input$choose_single %in% c(3,4))){ + else if (!numeric_selected()) { + if (!(input$choose_single %in% c(3, 4))) { disable("colorpal") - addCssClass("js_colorpal", "grey_out") + addCssClass("js_colorpal", "grey_out") } disable("legend_title_input") addCssClass("js_legend_title_input", "grey_out") @@ -348,46 +348,46 @@ observeEvent(numeric_selected(),{ }) # show extra options panel if we are doing a comparison plot -observeEvent(c(input$choose_single, input$chooseplots),{ - cond <- input$choose_single %in% c(3,4) & input$chooseplots != 0 +observeEvent(c(input$choose_single, input$chooseplots), { + cond <- input$choose_single %in% c(3, 4) & input$chooseplots != 0 toggle('js_summary_fxn', condition = cond) }) ### Summary comparison plot selection control ### -observeEvent(c(input$pres_fn, g1_samples(), g2_samples(), input$choose_single),{ - - cond_smallgrp <- any(length(g1_samples()) < 3, length(g2_samples()) < 3) & isTRUE(input$choose_single %in% c(3,4)) & input$chooseplots != "Density Plot" +observeEvent(c(input$pres_fn, g1_samples(), g2_samples(), input$choose_single), { + + cond_smallgrp <- any(length(g1_samples()) < 3, length(g2_samples()) < 3) & isTRUE(input$choose_single %in% c(3, 4)) & input$chooseplots != "Density Plot" # cond_onesample <- any(length(input$whichGroups1) < 2, length(input$whichGroups2) < 2) & isTRUE(input$choose_single == 3) & input$chooseplots != "Density Plot" - content <- if(cond_smallgrp & isTRUE(input$summary_fxn == "uniqueness_gtest")) "

    G-test disabled for groups with less than 3 samples

    " else NULL + content <- if (cond_smallgrp & isTRUE(input$summary_fxn == "uniqueness_gtest")) "

    G-test disabled for groups with less than 3 samples

    " else NULL # content_onesample <- if(cond_onesample) "style = 'color:deepskyblue'>Input at least 2 samples per group for group comparison." else NULL - - if (isTRUE(input$pres_fn == "nsamps")){ - if(cond_smallgrp){ + + if (isTRUE(input$pres_fn == "nsamps")) { + if (cond_smallgrp) { choices = c("Select one" = "select_none", "Presence/absence thresholds" = "uniqueness_nsamps") } else choices = c("Select one" = "select_none", "G test" = "uniqueness_gtest", "Presence/absence thresholds" = "uniqueness_nsamps") updateNumericInput(session, "thresh", min = 1, max = min(length(g1_samples()), length(g2_samples()))) } - else if (isTRUE(input$pres_fn == "prop")){ - if(cond_smallgrp){ + else if (isTRUE(input$pres_fn == "prop")) { + if (cond_smallgrp) { choices = c("Select one" = "select_none", "Presence/absence thresholds" = "uniqueness_prop") } else choices = c("Select one" = "select_none", "G test" = "uniqueness_gtest", "Presence/absence thresholds" = "uniqueness_prop") updateNumericInput(session, "thresh", min = 0, max = 1) } else choices = NULL - - selected = if(isTRUE(input$summary_fxn %in% c("uniqueness_nsamps", "uniqueness_prop"))) choices["Presence/absence thresholds"] - else if(!cond_smallgrp & isTRUE(input$summary_fxn %in% c("uniqueness_gtest"))) choices["G test"] - else choices["Select one"] - + + selected = if (isTRUE(input$summary_fxn %in% c("uniqueness_nsamps", "uniqueness_prop"))) choices["Presence/absence thresholds"] + else if (!cond_smallgrp & isTRUE(input$summary_fxn %in% c("uniqueness_gtest"))) choices["G test"] + else choices["Select one"] + updateSelectInput(session, "summary_fxn", choices = choices, selected = selected) - revals$warningmessage_visualize$small_groups <- content - # revals$warningmessage_visualize$one_sample <- content_onesample + revals$warningmessage_visualize$small_groups <- content + # revals$warningmessage_visualize$one_sample <- content_onesample }) # Control state for presence/absence threshold and p-value inputs -observeEvent(input$summary_fxn,{ +observeEvent(input$summary_fxn, { req(input$chooseplots != "Density Plot") toggleState("pval", input$summary_fxn == "uniqueness_gtest") toggleCssClass("js_pval", "grey_out", condition = input$summary_fxn != "uniqueness_gtest") @@ -399,47 +399,45 @@ observeEvent(input$summary_fxn,{ # NOTE: fxnplot does NOT redraw when input$vkbounds is invalidated. The dependency is entirely through revals$makeplot observeEvent(input$vkbounds, { req(isTRUE(input$chooseplots == "Van Krevelen Plot")) - if(isTRUE(input$choose_single == 1)){ - if(input$vkbounds == 0){ + if (isTRUE(input$choose_single == 1)) { + if (input$vkbounds == 0) { selected <- input$vk_colors - updateSelectInput(session, "vk_colors", - choices = c('Van Krevelen Boundary Set 1' = 'bs1','Van Krevelen Boundary Set 2' = 'bs2', revals$color_by_choices[!(revals$color_by_choices %in% c("bs1", "bs2"))]), - selected = input$vk_colors) + updateSelectInput(session, "vk_colors", + choices = c('Van Krevelen Boundary Set 1' = 'bs1', 'Van Krevelen Boundary Set 2' = 'bs2', revals$color_by_choices[!(revals$color_by_choices %in% c("bs1", "bs2"))]), + selected = input$vk_colors) } - else if(input$vkbounds == 'bs1'){ - selected <- if(input$vk_colors == "bs2") NULL else input$vk_colors - updateSelectInput(session, "vk_colors", - choices = c('Van Krevelen Boundary Set' = 'bs1', revals$color_by_choices[!(revals$color_by_choices %in% c("bs1", "bs2"))]), - selected = selected) + else if (input$vkbounds == 'bs1') { + selected <- if (input$vk_colors == "bs2") NULL else input$vk_colors + updateSelectInput(session, "vk_colors", + choices = c('Van Krevelen Boundary Set' = 'bs1', revals$color_by_choices[!(revals$color_by_choices %in% c("bs1", "bs2"))]), + selected = selected) } - else if(input$vkbounds == "bs2"){ - selected <- if(input$vk_colors == "bs1") NULL else input$vk_colors - updateSelectInput(session, "vk_colors", - choices = c('Van Krevelen Boundary Set' = 'bs2', revals$color_by_choices[!(revals$color_by_choices %in% c("bs1", "bs2"))]), - selected = selected) + else if (input$vkbounds == "bs2") { + selected <- if (input$vk_colors == "bs1") NULL else input$vk_colors + updateSelectInput(session, "vk_colors", + choices = c('Van Krevelen Boundary Set' = 'bs2', revals$color_by_choices[!(revals$color_by_choices %in% c("bs1", "bs2"))]), + selected = selected) } - + # still want to redraw if the colors didn't change, fxnplot does NOT invalidate on input$vkbounds - if(isTRUE(selected == input$vk_colors)){ + if (isTRUE(selected == input$vk_colors)) { revals$makeplot <- -revals$makeplot } } - else if(isTRUE(input$choose_single > 1)){ + else if (isTRUE(input$choose_single > 1)) { revals$makeplot <- -revals$makeplot } }) # Observer which stores sample selections so user (me testing the app) doesn't have to re-input -observeEvent(c(input$whichGroups1, input$whichGroups2, input$whichSamples, input$whichSample1, input$whichSample2),{ +observeEvent(c(input$whichGroups1, input$whichGroups2, input$whichSamples, input$whichSample1, input$whichSample2), { revals$group_1 <- input$whichGroups1 revals$group_2 <- input$whichGroups2 - if(isTRUE(input$choose_single == 1)) revals$single_sample <- input$whichSamples - if(isTRUE(input$choose_single == 2)) revals$single_group <- input$whichSamples - if(isTRUE(input$choose_single == 4)){ - revals$sample_1 <- input$whichSample1 - revals$sample_2 <- input$whichSample2 + if (isTRUE(input$choose_single == 1)) revals$single_sample <- input$whichSamples + if (isTRUE(input$choose_single == 2)) revals$single_group <- input$whichSamples + if (isTRUE(input$choose_single == 4)) { + revals$sample_1 <- input$whichSample1 + revals$sample_2 <- input$whichSample2 } }) #### ### - - diff --git a/Reactive_Variables/corems_revals.R b/Reactive_Variables/corems_revals.R index c613834..7204071 100644 --- a/Reactive_Variables/corems_revals.R +++ b/Reactive_Variables/corems_revals.R @@ -1,5 +1,5 @@ -#'@details The columns of the table resulting from reading in the multiple -#'corems files +#' @details The columns of the table resulting from reading in the multiple +#' corems files corems_cols <- reactive({ req(corems_revals[['combined_tables']]) colnames(corems_revals[['combined_tables']]) @@ -8,25 +8,25 @@ corems_cols <- reactive({ # Create CoreMSData object upon button click cms_data <- eventReactive(input$make_cmsdata, { req(corems_revals[['combined_tables']]) - + args = list(corems_revals[['combined_tables']]) - + # Collect arguments specified by the user - for(argname in COREMSDATA_ARGS) { - if(isTRUE(input[[argname]] == NULLSELECT__) | !isTruthy(input[[argname]])) { - args[[argname]] <- NULL + for (argname in COREMSDATA_ARGS) { + if (isTRUE(input[[argname]] == NULLSELECT__) | !isTruthy(input[[argname]])) { + args[[argname]] <- NULL } else { - args[[argname]] <- input[[argname]] + args[[argname]] <- input[[argname]] } } - - - cms_dat <- do.call(as.CoreMSData, args) + + + cms_dat <- do.call(as.CoreMSData, args) return(cms_dat) }) -#'@details create conf_filt object for confidence filtering panel +#' @details create conf_filt object for confidence filtering panel conf_filt_obj <- reactive({ conf_filter(cms_data()) }) @@ -37,11 +37,11 @@ cms_data_filtered <- eventReactive(input$apply_conf_filter, { }) ########## Unique MF Assignment Tab ########## -cms_dat_unq_mf <- eventReactive(input$unique_mf, { +cms_dat_unq_mf <- eventReactive(input$unique_mf, { req(input$unq_mf_method) if (input$unq_mf_method == "Confidence score") {method <- "confidence"} if (input$unq_mf_method == "Peak height") {method <- "peak_intensity"} - + unq_dat <- unique_mf_assignment(cms_data_filtered(), method) return(unq_dat) }) @@ -52,7 +52,7 @@ selected_coremsData <- reactive({ lapply(COREMSDATA_ARGS, function(x) input[[x]]) }) -#'@details Remaining choices for as.coreMSdata dropdowns +#' @details Remaining choices for as.coreMSdata dropdowns coreMS_remaining_choices <- reactive({ setdiff(corems_cols(), selected_coremsData()) -}) \ No newline at end of file +}) diff --git a/Reactive_Variables/filter_revals.R b/Reactive_Variables/filter_revals.R index 3fead8e..9d45a3a 100644 --- a/Reactive_Variables/filter_revals.R +++ b/Reactive_Variables/filter_revals.R @@ -4,15 +4,15 @@ summaryFilterDataFrame <- eventReactive(revals$reac_filter_plot, { req(input$top_page == "Filter") req(revals$redraw_largedata, cancelOutput = TRUE) print('recalculating summaryfilter dataframe...') - - if(uploaded_data_dim() > max_cells){ + + if (uploaded_data_dim() > max_cells) { on.exit(revals$redraw_largedata <- FALSE) } - + # determine which, if any, custom filters to apply conds <- c(!is.null(revals$custom1_ids), !is.null(revals$custom2_ids), !is.null(revals$custom3_ids)) - - if (any(conds) & isolate(input$customfilterz)){ + + if (any(conds) & isolate(input$customfilterz)) { customids_to_keep <- data.frame(ids = c(revals$custom1_ids, revals$custom2_ids, revals$custom3_ids), stringsAsFactors = FALSE) %>% group_by(ids) %>% mutate(n = n()) %>% @@ -22,27 +22,27 @@ summaryFilterDataFrame <- eventReactive(revals$reac_filter_plot, { else customids_to_keep <- NULL # Get summary table from sourced file 'summaryFilter.R' df <- summaryFilt(revals$uploaded_data, sampfilter_ids(), massfilter_ids(), molfilter_ids(), formfilter_ids(), customids_to_keep) - + return(df) - + }, ignoreInit = TRUE) # End summaryFilterDataFrame ### ids which are passed to summaryFilt() to calculate the remaining peaks for table and bar plot # removed sample filter ids -sampfilter_ids <- eventReactive(c(input$keep_samples, input$samplefilter, input$top_page, revals$react_largedata),{ +sampfilter_ids <- eventReactive(c(input$keep_samples, input$samplefilter, input$top_page, revals$react_largedata), { req(!is.null(revals$peakData2)) - if(!revals$redraw_largedata){ + if (!revals$redraw_largedata) { return(NULL) } - else if(input$samplefilter){ - if(length(input$keep_samples) == 0){ # no samples kept + else if (input$samplefilter) { + if (length(input$keep_samples) == 0) { # no samples kept return(NULL) } - else if(length(intersect(colnames(revals$peakData2$e_data), input$keep_samples)) == 0){ # selected samples not in data + else if (length(intersect(colnames(revals$peakData2$e_data), input$keep_samples)) == 0) { # selected samples not in data return(NULL) } - else{ - revals$uploaded_data %>% + else { + revals$uploaded_data %>% subset(samples = input$keep_samples, check_rows = TRUE) %>% {.$e_data} %>% pluck(getMassColName(revals$peakData2)) @@ -52,15 +52,15 @@ sampfilter_ids <- eventReactive(c(input$keep_samples, input$samplefilter, input$ }) # removed mass filter filter ids -massfilter_ids <- eventReactive(c(input$massfilter, input$min_mass, input$max_mass, input$top_page, revals$react_largedata),{ +massfilter_ids <- eventReactive(c(input$massfilter, input$min_mass, input$max_mass, input$top_page, revals$react_largedata), { req(!is.null(revals$peakData2), input$top_page == "Filter") - if(!revals$redraw_largedata){ + if (!revals$redraw_largedata) { return(NULL) } revals$redraw_filter_plot <- FALSE - if (input$massfilter){ + if (input$massfilter) { req(length(input$max_mass) > 0, length(input$min_mass) > 0) - mass_filter(revals$uploaded_data) %>% + mass_filter(revals$uploaded_data) %>% dplyr::filter(!!sym(getMassColName(revals$peakData2)) <= input$max_mass, !!sym(getMassColName(revals$peakData2)) >= input$min_mass) %>% pluck(getMassColName(revals$peakData2)) } @@ -70,20 +70,20 @@ massfilter_ids <- eventReactive(c(input$massfilter, input$min_mass, input$max_ma # removed molecule filter ids molfilter_ids <- eventReactive(c(input$minobs, input$molfilter, input$keep_samples, input$samplefilter, input$top_page, revals$react_largedata), { req(!is.null(revals$peakData2)) - if(!revals$redraw_largedata){ + if (!revals$redraw_largedata) { return(NULL) } - else if (input$molfilter){ + else if (input$molfilter) { req(length(input$minobs) > 0) # if we are subsampling and samples are selected and the selected samples are in the data - if(input$samplefilter & length(input$keep_samples) > 0 & length(intersect(colnames(revals$peakData2$e_data), input$keep_samples)) !=0 ){ - revals$uploaded_data %>% + if (input$samplefilter & length(input$keep_samples) > 0 & length(intersect(colnames(revals$peakData2$e_data), input$keep_samples)) != 0) { + revals$uploaded_data %>% subset(samples = input$keep_samples, check_rows = TRUE) %>% - molecule_filter() %>% + molecule_filter() %>% dplyr::filter(Num_Observations >= as.integer(input$minobs)) %>% pluck(getMassColName(revals$peakData2)) } - else{ + else { molecule_filter(revals$uploaded_data) %>% dplyr::filter(Num_Observations >= as.integer(input$minobs)) %>% pluck(getMassColName(revals$peakData2)) @@ -95,10 +95,10 @@ molfilter_ids <- eventReactive(c(input$minobs, input$molfilter, input$keep_sampl # removed formula filter ids formfilter_ids <- eventReactive(c(input$formfilter, input$top_page, revals$react_largedata), { req(!is.null(revals$peakData2)) - if(!revals$redraw_largedata){ + if (!revals$redraw_largedata) { return(NULL) } - else if (input$formfilter){ + else if (input$formfilter) { formula_filter(revals$uploaded_data) %>% dplyr::filter(Formula_Assigned == TRUE) %>% pluck(getMassColName(revals$peakData2)) diff --git a/Reactive_Variables/groups_revals.R b/Reactive_Variables/groups_revals.R index f94e2a3..5e1ebc0 100644 --- a/Reactive_Variables/groups_revals.R +++ b/Reactive_Variables/groups_revals.R @@ -1,32 +1,32 @@ -groupstab_df <- eventReactive(c(revals$groups_list, revals$removed_samples),{ - +groupstab_df <- eventReactive(c(revals$groups_list, revals$removed_samples), { + # names of the groups names <- names(revals$groups_list) - + # samples in each group - samples <- sapply(revals$groups_list, function(x){ + samples <- sapply(revals$groups_list, function(x) { diff <- setdiff(x, revals$removed_samples) paste(diff, collapse = ";")}) - + # samples removed in filtering step - removed_samples <- sapply(revals$groups_list, function(x){ + removed_samples <- sapply(revals$groups_list, function(x) { intersect <- intersect(x, revals$removed_samples) paste(intersect, collapse = " ")}) - + # make a dataframe with number of rows equal to the number of groups rows <- length(names) groupstab_df = data.frame("Group Name" = character(rows), "Group Samples" = character(rows), "Filtered Samples" = character(rows), - stringsAsFactors = FALSE, check.names = FALSE) - - if(rows == 0){ + stringsAsFactors = FALSE, check.names = FALSE) + + if (rows == 0) { return(groupstab_df) } - + # populate the table groupstab_df["Group Name"] <- names groupstab_df["Group Samples"] <- samples groupstab_df["Filtered Samples"] <- removed_samples - + groupstab_df - -}) \ No newline at end of file + +}) diff --git a/Reactive_Variables/linked_plot_revals.R b/Reactive_Variables/linked_plot_revals.R index cbc327e..115abcf 100644 --- a/Reactive_Variables/linked_plot_revals.R +++ b/Reactive_Variables/linked_plot_revals.R @@ -5,8 +5,8 @@ linked_plots_table <- reactive({ is_single_sample = plots$plot_table_download['Sample Type'] == 'Single Sample' is_pcoa = plots$plot_table_download['Plot Type'] == 'PCOA Plot' has_sample = !is.na(plots$plot_table_download['Sample Type']) - is_linked = grepl("^\\(LINKED\\)", plots$plot_table_download[,'Plot Type']) - - plots$plot_table_download %>% + is_linked = grepl("^\\(LINKED\\)", plots$plot_table_download[, 'Plot Type']) + + plots$plot_table_download %>% filter(!((is_density & !is_single_sample) | is_pcoa) & has_sample & !is_linked) -}) \ No newline at end of file +}) diff --git a/Reactive_Variables/misc_revals.R b/Reactive_Variables/misc_revals.R index c72a622..235f560 100644 --- a/Reactive_Variables/misc_revals.R +++ b/Reactive_Variables/misc_revals.R @@ -1,12 +1,12 @@ # keep track of dimension of peakData2.... peakData2_dim <- eventReactive(revals$peakData2, { - prod(dim(revals$peakData2$e_data[,-1])) + prod(dim(revals$peakData2$e_data[, -1])) }) -#... and dimension of uploaded_data -uploaded_data_dim <- eventReactive(revals$uploaded_data,{ - prod(dim(revals$uploaded_data$e_data[,-1])) +# ... and dimension of uploaded_data +uploaded_data_dim <- eventReactive(revals$uploaded_data, { + prod(dim(revals$uploaded_data$e_data[, -1])) }) edata_dim <- eventReactive(Edata(), { - prod(dim(Edata()[,-1])) -}) \ No newline at end of file + prod(dim(Edata()[, -1])) +}) diff --git a/Reactive_Variables/preprocess_revals.R b/Reactive_Variables/preprocess_revals.R index f77b3c0..276dc5a 100644 --- a/Reactive_Variables/preprocess_revals.R +++ b/Reactive_Variables/preprocess_revals.R @@ -2,25 +2,25 @@ emeta_display_choices <- reactive({ # do not allow mass or isotopic info column as options drop_cols <- c(attr(revals$uploaded_data, "cnames")$mass_cname, - input$iso_info_column) - - # get column names - column_choices <- revals$uploaded_data$e_meta %>% + input$iso_info_column) + + # get column names + column_choices <- revals$uploaded_data$e_meta %>% dplyr::select(-one_of(drop_cols)) %>% - dplyr::select(which(sapply(., function(col){ length(unique(col)) < 12 } ) | sapply(., is.numeric))) %>% #dont include columns with too many categories - colnames() - - #columns included in calculation_options.csv get their prettified names, everything else gets the column name - names(column_choices) <- lapply(column_choices, function(x){ - if (x %in% calc_vars$ColumnName){ + dplyr::select(which(sapply(., function(col) { length(unique(col)) < 12 }) | sapply(., is.numeric))) %>% # dont include columns with too many categories + colnames() + + # columns included in calculation_options.csv get their prettified names, everything else gets the column name + names(column_choices) <- lapply(column_choices, function(x) { + if (x %in% calc_vars$ColumnName) { calc_vars %>% filter(ColumnName == x) %>% pluck("DisplayName") } else x }) %>% unlist() - - #____test export_____ + + # ____test export_____ exportTestValues(display_names = column_choices) - + column_choices - + }) diff --git a/Reactive_Variables/upload_revals.R b/Reactive_Variables/upload_revals.R index 1bcb03b..4531ee2 100644 --- a/Reactive_Variables/upload_revals.R +++ b/Reactive_Variables/upload_revals.R @@ -1,21 +1,21 @@ # Object: Get e_data from file input Edata <- reactive({ - if(!is.null(revals$uploaded_data)) { + if (!is.null(revals$uploaded_data)) { return(revals$uploaded_data$e_data %>% - dplyr::select(-dplyr::one_of( - ftmsRanalysis::getEDataColName(revals$uploaded_data) - ))) + dplyr::select(-dplyr::one_of( + ftmsRanalysis::getEDataColName(revals$uploaded_data) + ))) } - + # Error handling: Need file_edata path req(input$file_edata$datapath) - + # Load file filename <- input$file_edata$datapath - + exportTestValues(e_data = read_csv(filename) %>% as.data.frame(stringsAsFactors = FALSE)) read_csv(filename) %>% as.data.frame(stringsAsFactors = FALSE) - + }) # End Edata # # Object: Get list of column names of Edata @@ -35,17 +35,17 @@ Emeta <- reactive({ read_csv(filename) %>% as.data.frame(stringsAsFactors = FALSE) }) # End Emeta # -# Object: Emeta column names -emeta_cnames <- reactive({names(Emeta())}) +# Object: Emeta column names +emeta_cnames <- reactive({names(Emeta())}) # Object: Sample names from e_data sample_names <- reactive({ setdiff(edata_cnames(), input$edata_id_col) -}) +}) # Create reactive fake f_data (used when action button creates peakData()) fdata <- reactive({ col2 <- rep(NA, length(sample_names())) data.frame('SampleId' = sample_names(), 'Var1' = col2) - -}) # End fdata # \ No newline at end of file + +}) # End fdata # diff --git a/Reactive_Variables/visualize_revals.R b/Reactive_Variables/visualize_revals.R index 032c864..39150d1 100644 --- a/Reactive_Variables/visualize_revals.R +++ b/Reactive_Variables/visualize_revals.R @@ -6,14 +6,14 @@ plot_defaults <- reactive({ )) if (input$chooseplots == 'Van Krevelen Plot') { defs <- formals(vanKrevelenPlot) - #defs$legendTitle = names(emeta_display_choices())[emeta_display_choices() == input$vk_colors] - } else if (input$chooseplots == "Custom Scatter Plot"){ + # defs$legendTitle = names(emeta_display_choices())[emeta_display_choices() == input$vk_colors] + } else if (input$chooseplots == "Custom Scatter Plot") { defs <- formals(scatterPlot) defs$ylabel = NULL defs$xlabel = NULL } else if (input$chooseplots == 'Kendrick Plot') { defs <- formals(kendrickPlot) - #defs$legendTitle = input$vk_colors + # defs$legendTitle = input$vk_colors } else if (input$chooseplots == 'Density Plot') { defs <- formals(densityPlot) defs$ylabel = "Density" @@ -27,161 +27,160 @@ plot_defaults <- reactive({ }) # Object: reactive variable that keeps track of whether the selected column is numeric or categorical. -numeric_selected <- eventReactive(c(input$vk_colors, plot_data()),{ +numeric_selected <- eventReactive(c(input$vk_colors, plot_data()), { edata_col <- plot_data()$e_data %>% pluck(input$vk_colors) emeta_col <- plot_data()$e_meta %>% pluck(input$vk_colors) - if (input$vk_colors %in% (plot_data()$e_data %>% colnames())){ + if (input$vk_colors %in% (plot_data()$e_data %>% colnames())) { (is.numeric(edata_col) & !(is_integer(edata_col) & length(unique(edata_col)) < 12)) - }else if (input$vk_colors %in% (plot_data()$e_meta %>% colnames())){ + } else if (input$vk_colors %in% (plot_data()$e_meta %>% colnames())) { (is.numeric(emeta_col) & !(is_integer(emeta_col) & length(unique(emeta_col)) < 12)) - }else if (input$vk_colors %in% c("bs1", "bs2")){ + } else if (input$vk_colors %in% c("bs1", "bs2")) { FALSE - }else TRUE + } else TRUE }, ignoreNULL = FALSE) # Objects: vectors of sample names. Depend on group/sample selection dropdown when doing a comparison -g1_samples <- eventReactive(c(input$whichGroups1, input$whichSample1, input$choose_single, input$top_page),{ - if(is.null(isolate(input$whichGroups1)) & is.null(isolate(input$whichSample1))) NULL - else if(isolate(input$choose_single == 3)) setdiff(unique(unlist(revals$groups_list[isolate(input$whichGroups1)])), revals$removed_samples) - else if(isolate(input$choose_single == 4)) isolate(input$whichSample1) +g1_samples <- eventReactive(c(input$whichGroups1, input$whichSample1, input$choose_single, input$top_page), { + if (is.null(isolate(input$whichGroups1)) & is.null(isolate(input$whichSample1))) NULL + else if (isolate(input$choose_single == 3)) setdiff(unique(unlist(revals$groups_list[isolate(input$whichGroups1)])), revals$removed_samples) + else if (isolate(input$choose_single == 4)) isolate(input$whichSample1) }) -g2_samples <- eventReactive(c(input$whichGroups2, input$whichSample2, input$choose_single, input$top_page),{ - if(is.null(isolate(input$whichGroups2)) & is.null(isolate(input$whichSample2))) NULL - else if(isolate(input$choose_single == 3)) setdiff(unique(unlist(revals$groups_list[isolate(input$whichGroups2)])), revals$removed_samples) - else if(isolate(input$choose_single == 4)) isolate(input$whichSample2) +g2_samples <- eventReactive(c(input$whichGroups2, input$whichSample2, input$choose_single, input$top_page), { + if (is.null(isolate(input$whichGroups2)) & is.null(isolate(input$whichSample2))) NULL + else if (isolate(input$choose_single == 3)) setdiff(unique(unlist(revals$groups_list[isolate(input$whichGroups2)])), revals$removed_samples) + else if (isolate(input$choose_single == 4)) isolate(input$whichSample2) }) # # Object: Plotting dataframe to be passed to output$FxnPlot -plot_data <- eventReactive(input$plot_submit,{ - +plot_data <- eventReactive(input$plot_submit, { + req(calc_vars) - validate(need(!is.null(input$chooseplots) & input$choose_single !=0, message = "Please select plot type")) - - if(input$chooseplots=='PCOA Plot'){ + validate(need(!is.null(input$chooseplots) & input$choose_single != 0, message = "Please select plot type")) + + if (input$chooseplots == 'PCOA Plot') { req(!is.null(revals$peakData2)) - validate(need(length(sample_names()>0), "No data found, or only 1 sample")) - + validate(need(length(sample_names() > 0), "No data found, or only 1 sample")) + samples <- setdiff(sample_names(), revals$removed_samples) - + # for each sample create a string indicating each group it belongs to - if(!is.null(input$viztab_select_groups)){ - groups <- sapply(samples, function(sampname){ + if (!is.null(input$viztab_select_groups)) { + groups <- sapply(samples, function(sampname) { tempgroup = NULL - for(grp in names(revals$groups_list[input$viztab_select_groups])){ - if(isTRUE(sampname %in% revals$groups_list[[grp]])) tempgroup[length(tempgroup)+1] <- grp + for (grp in names(revals$groups_list[input$viztab_select_groups])) { + if (isTRUE(sampname %in% revals$groups_list[[grp]])) tempgroup[length(tempgroup) + 1] <- grp } - - if(is.null(tempgroup)){ + + if (is.null(tempgroup)) { return("Unassigned") } - else return(paste(tempgroup, collapse="&")) + else return(paste(tempgroup, collapse = "&")) }) - + group_DF <- data.frame(samples, groups) colnames(group_DF) <- c(getFDataColName(revals$peakData2), "Group") } else group_DF <- NULL - + temp_data <- ftmsRanalysis:::setGroupDF(revals$peakData2, group_DF) return(temp_data) } - if (is.null(input$choose_single)){ # corresponds to data with a single sample + if (is.null(input$choose_single)) { # corresponds to data with a single sample return(revals$peakData2) # no need to subset } if (input$choose_single == 1) { # single sample -selected- but multiple samples present validate(need(!is.null(input$whichSamples), message = "Please select a sample to plot")) return(subset(revals$peakData2, input$whichSamples)) - #key_name <- paste(attributes(revals$peakData2)$cnames$fdata_cname, "=", input$whichSamples, sep = "") + # key_name <- paste(attributes(revals$peakData2)$cnames$fdata_cname, "=", input$whichSamples, sep = "") } if (input$chooseplots == "Custom Scatter Plot") req(input$scatter_x != input$scatter_y) #---------- Group Plots ------------# else if (input$choose_single == 2) { # single group' - + validate(need(!is.null(input$whichSamples), message = "Please select samples for grouping")) validate(need(length(input$whichSamples) > 1, message = "Please select at least 2 samples")) - + temp_group_df <- data.frame(input$whichSamples, "Group") colnames(temp_group_df) <- c(getFDataColName(revals$peakData2), "Group") - - temp_data <- revals$peakData2 %>% + + temp_data <- revals$peakData2 %>% subset(input$whichSamples) - + temp_data <- ftmsRanalysis:::setGroupDF(temp_data, temp_group_df) - + # no need to summarize for density plot function - if (input$chooseplots == "Density Plot"){ + if (input$chooseplots == "Density Plot") { return(temp_data) } - + temp_data <- summarizeGroups(temp_data, summary_functions = getGroupSummaryFunctionNames()) temp_data$e_meta <- cbind(temp_data$e_meta, temp_data$e_data %>% dplyr::select(-one_of(getEDataColName(temp_data)))) - + return(temp_data) - - } else if (isolate(input$choose_single) %in% c(3,4)) {# two groups + + } else if (isolate(input$choose_single) %in% c(3, 4)) { # two groups # Make sure at least one test has been calculated validate(need(!is.null(g1_samples()), message = "Please select samples for first grouping")) # validate(need(length(g1_samples) > 1, message = "Please select at least 1 sample")) validate(need(!is.null(g2_samples()), message = "Please select samples for second grouping")) # validate(need(length(g2_samples) > 1, message = "Please select at least 1 sample")) - + group1 <- ifelse(is.null(input$group1_name) | isTRUE(input$group1_name == ""), "Group 1", input$group1_name) group2 <- ifelse(is.null(input$group2_name) | isTRUE(input$group2_name == ""), "Group 2", input$group2_name) - + # assign a group DF to the data with a level for each of the two groups - temp_group_df <- data.frame(c(g1_samples(), g2_samples()), c(rep(group1, times=length(g1_samples())), rep(group2, length(g2_samples())))) + temp_group_df <- data.frame(c(g1_samples(), g2_samples()), c(rep(group1, times = length(g1_samples())), rep(group2, length(g2_samples())))) colnames(temp_group_df) <- c(getFDataColName(revals$peakData2), "Group") temp_group_df$Group <- as.factor(temp_group_df$Group) temp_data <- revals$peakData2 %>% - subset(samples=c(g1_samples(), g2_samples())) - + subset(samples = c(g1_samples(), g2_samples())) + temp_data <- ftmsRanalysis:::setGroupDF(temp_data, temp_group_df) - + # no need to summarize for density plot function - if (input$chooseplots == "Density Plot"){ + if (input$chooseplots == "Density Plot") { return(temp_data) } - + # error checking after passing density plots validate(need(input$summary_fxn %in% ftmsRanalysis:::getGroupComparisonSummaryFunctionNames(), "Please select a summary function")) - - # get the value of the single pairwise comparison + + # get the value of the single pairwise comparison grpComparisonsObj <- divideByGroupComparisons(temp_data, comparisons = "all")[[1]]$value - + # paramaters specific to uniqueness_gtest() - if (input$summary_fxn == "uniqueness_gtest"){ + if (input$summary_fxn == "uniqueness_gtest") { validate(need(isTRUE(input$pval < 1 & input$pval > 0) & is.numeric(input$pval), message = "Specify a p-value between 0 and 1")) gtest_parms <- list(pres_fn = input$pres_fn, pvalue_thresh = input$pval) } else { gtest_parms <- list(absn_thresh = input$absn_thresh) } - + # conditional error checking depending on nsamps and proportion - if (input$pres_fn == "nsamps"){ + if (input$pres_fn == "nsamps") { validate(need(input$pres_thresh <= min(length(g1_samples()), length(g2_samples())), "Maximum threshold is above the minimum number of samples in a group"), - need(is.numeric(input$pres_thresh), "Please enter a numeric value for threshold to determine presence"), - need(input$absn_thresh < input$pres_thresh & input$absn_thresh >= 0, "absence threshold must be non-negative and lower than presence threshold")) + need(is.numeric(input$pres_thresh), "Please enter a numeric value for threshold to determine presence"), + need(input$absn_thresh < input$pres_thresh & input$absn_thresh >= 0, "absence threshold must be non-negative and lower than presence threshold")) } - else if (input$pres_fn == "prop"){ + else if (input$pres_fn == "prop") { validate(need(input$pres_thresh <= 1 & input$pres_thresh > 0, "Proportion threshold is not in the interval (0,1]"), - need(is.numeric(input$pres_thresh), "Please enter a numeric proportion threshold to determine presence"), - need(input$absn_thresh < input$pres_thresh & input$absn_thresh >= 0, "absence threshold must be non-negative and lower than presence threshold")) + need(is.numeric(input$pres_thresh), "Please enter a numeric proportion threshold to determine presence"), + need(input$absn_thresh < input$pres_thresh & input$absn_thresh >= 0, "absence threshold must be non-negative and lower than presence threshold")) } - + # populate a list of args to pass to summarizeGroupComparisons() parms <- list() parms[[input$summary_fxn]] <- c(list(pres_thresh = input$pres_thresh), gtest_parms) - + # create the group comparisons object, passing the user specified function and its (user specified) list of args. - summaryObj <- summarizeGroupComparisons(grpComparisonsObj, summary_functions = input$summary_fxn, - summary_function_params = parms) - + summaryObj <- summarizeGroupComparisons(grpComparisonsObj, summary_functions = input$summary_fxn, + summary_function_params = parms) + return(summaryObj) - + } }) - diff --git a/global.R b/global.R index dea961e..dc4d3d7 100644 --- a/global.R +++ b/global.R @@ -36,7 +36,7 @@ kendrick_opts_info <- 'The base compound(s) used to calculate the Kendrick Mass. dt_checkmark <- '' dt_minus <- '' -ttip_text = list("plot_save"="Save the last created plot", "plot_review"="Review saved plots", "page_help"="How do I use this page?") +ttip_text = list("plot_save" = "Save the last created plot", "plot_review" = "Review saved plots", "page_help" = "How do I use this page?") #------ Download Example Data ---------# example_edata <- read_csv('Data/example12T_edata.csv') %>% as.data.frame(stringsAsFactors = FALSE) @@ -57,7 +57,7 @@ info_text = list( VALID_MINIO_HEADER_PARAMS = c("corems-prefix") -#'@SECTION Variables for selectors/inputs ## +#' @SECTION Variables for selectors/inputs ## # Use this global variable for 'nothing selected' options NULLSELECT__ = "__nullselect__" @@ -65,12 +65,12 @@ NULLSELECT__ = "__nullselect__" # list of arguments to be passed to as.CoreMSData that need an input picker COREMSDATA_ARGS = c( "index_cname", - "obs_mass_cname", + "obs_mass_cname", "calc_mass_cname", - "pheight_cname", + "pheight_cname", "error_cname", "conf_cname", - "file_cname", + "file_cname", "monoiso_index_cname", "mf_cname", "c13_cname", @@ -78,6 +78,3 @@ COREMSDATA_ARGS = c( "n15cname", "s34_cname" ) - - - diff --git a/helper_functions/database_utils.R b/helper_functions/database_utils.R index 7a6f0a4..7b33fba 100644 --- a/helper_functions/database_utils.R +++ b/helper_functions/database_utils.R @@ -1,15 +1,15 @@ -# identify null elements or elements with more sub-elements than the specified threshold -null_or_maxlen <- function(x, maxlen){ +# identify null elements or elements with more sub-elements than the specified threshold +null_or_maxlen <- function(x, maxlen) { is.null(x) | length(x) > maxlen | isTRUE(is.na(x)) } # helper function passed to map(). Given a list column containing elements x, create a new list column with ALL elements of map_list[x] -newcol_from_mapping = function(x, maxlen, map_list){ - if(!all(is.na(x))){ +newcol_from_mapping = function(x, maxlen, map_list) { + if (!all(is.na(x))) { x <- x %>% unlist() %>% unique() - temp <- if(is.character(map_list)) get(map_list)[x] else map_list[x] + temp <- if (is.character(map_list)) get(map_list)[x] else map_list[x] temp <- temp[which(lapply(temp, null_or_maxlen, maxlen = maxlen) == F)] - if(length(temp) > 0){ + if (length(temp) > 0) { return(temp) } else return(list(NA)) @@ -18,12 +18,12 @@ newcol_from_mapping = function(x, maxlen, map_list){ } # function for un-listing elements of a particular column which contains lists (dict) which are named after elements of another column (keys) -unnest_by_key = function(keys,dict){ - if(!all(is.na(dict))){ - if(!all(is.na(keys))){ +unnest_by_key = function(keys, dict) { + if (!all(is.na(dict))) { + if (!all(is.na(keys))) { # the elements of the column will be lists with elements named after the specified keys foo <- dict[[keys]] - if(length(foo) > 0){ + if (length(foo) > 0) { return(foo) } else NA @@ -33,21 +33,21 @@ unnest_by_key = function(keys,dict){ else NA } -list2semicolon <- function(x){ - x %>% - unlist() %>% - unname() %>% - unique() %>% +list2semicolon <- function(x) { + x %>% + unlist() %>% + unname() %>% + unique() %>% paste(collapse = ';') } # from a list of [thing : elements_things_maps_to] key-value pairs create the reverse mapping -make_reverse_mapping <- function(mapping, key_name, value_name){ - mapping %>% - tibble::enframe(name = key_name, value = value_name) %>% - tidyr::unnest() %>% +make_reverse_mapping <- function(mapping, key_name, value_name) { + mapping %>% + tibble::enframe(name = key_name, value = value_name) %>% + tidyr::unnest() %>% group_by(!!rlang::sym(value_name)) %>% - tidyr::nest(.key = !!rlang::sym(key_name)) %>% + tidyr::nest(.key = !!rlang::sym(key_name)) %>% mutate(!!rlang::sym(key_name) := map(!!rlang::sym(key_name), function(x) unname(unlist))) %>% tibble::deframe() } diff --git a/helper_functions/report.R b/helper_functions/report.R index 0a6a997..2344ad0 100644 --- a/helper_functions/report.R +++ b/helper_functions/report.R @@ -4,7 +4,7 @@ #' #' @param peakData a list containing peakData objects, including at least one data object (of the class 'peakData' created by \code{\link{as.seqData}} and any other peakData objects to include in the report. #' -#' @details This function generates a .docx report for a peakData data object. The report includes attributes of the original data, calculated metadata, and filtering procedures applied. +#' @details This function generates a .docx report for a peakData data object. The report includes attributes of the original data, calculated metadata, and filtering procedures applied. #' #' @return A .docx report of the preprocessing and filtering performed on the data #' @@ -12,25 +12,24 @@ #' \dontrun{ #' library(mintJansson) #' data(cDNA_hiseq_data) -#' mycdnadata <- group_designation(omicsData = cDNA_hiseq_data, main_effects = c("treatment"), time_course=NULL) +#' mycdnadata <- group_designation(omicsData = cDNA_hiseq_data, main_effects = c("treatment"), time_course = NULL) #' mycdnadata_norm <- normalize_data(omicsData = mycdnadata, norm_fn = "percentile") #' mycdnadata_results <- countSTAT(omicsData = mycdnadata_norm, comparisons = "all", control = NULL, test = c("dw", "eq", "el", "ef"), pval_adjust = "none", pval_thresh = 0.05) -#' report(omicsData = list(Norm=mycdnadata_norm, Statistics = mycdnadata_results), output_file = "cDNAdata_Report.docx") +#' report(omicsData = list(Norm = mycdnadata_norm, Statistics = mycdnadata_results), output_file = "cDNAdata_Report.docx") #' } #' #' @author Allison Thompson #' #' @export -report <- function(uploaded_data, processed_data, emeta, output_file=NULL, output_format = 'html_document', ...){ +report <- function(uploaded_data, processed_data, emeta, output_file = NULL, output_format = 'html_document', ...) { library(rmarkdown) - if(!all(inherits(uploaded_data, "peakData"), inherits(processed_data, "peakData"))){ + if (!all(inherits(uploaded_data, "peakData"), inherits(processed_data, "peakData"))) { stop("One or both of the input data objects are not of class 'peakData'") } - params <- list(upload=uploaded_data, processed = processed_data, emeta = emeta, ...) + params <- list(upload = uploaded_data, processed = processed_data, emeta = emeta, ...) - render("peakData_Report.Rmd", output_file=output_file, output_format = output_format, params=params, envir = new.env()) + render("peakData_Report.Rmd", output_file = output_file, output_format = output_format, params = params, envir = new.env()) } - diff --git a/helper_functions/selection_addons.R b/helper_functions/selection_addons.R index f4db47a..d31deb1 100644 --- a/helper_functions/selection_addons.R +++ b/helper_functions/selection_addons.R @@ -1,42 +1,41 @@ -##Function which creates info hover icons for preprocessing checkboxes. -##Thanks to @K. Rohde on stackoverflow for this. https://stackoverflow.com/questions/36670065/tooltip-in-shiny-ui-for-help-text +## Function which creates info hover icons for preprocessing checkboxes. +## Thanks to @K. Rohde on stackoverflow for this. https://stackoverflow.com/questions/36670065/tooltip-in-shiny-ui-for-help-text -tooltip_checkbox <- function(..., extensions, options){ +tooltip_checkbox <- function(..., extensions, options) { output <- checkboxGroupInput(...) - - #number of checkboxes + + # number of checkboxes n <- length(output$children[[2]]$children[[1]]) - + # output$children[[2]]$children[[1]][[i]] references the i-th row of the checkbox group ... # ... from there, each list element identifies a 'column' of that row. - lapply(1:n, function(i){ - #second column gets checkboxes + lapply(1:n, function(i) { + # second column gets checkboxes output$children[[2]]$children[[1]][[i]]$children[[2]] <<- output$children[[2]]$children[[1]][[i]]$children[[1]] - #first column which previously held checkboxes gets tipify icons + # first column which previously held checkboxes gets tipify icons output$children[[2]]$children[[1]][[i]]$children[[1]] <<- extensions[[i]] - - if(!is.null(options[[i]])){ + + if (!is.null(options[[i]])) { output$children[[2]]$children[[1]][[i]] <<- div(output$children[[2]]$children[[1]][[i]], options[[i]]) } }) - + output } -##Function which creates info hover icons for viztab radio buttons +## Function which creates info hover icons for viztab radio buttons -colored_radiobuttons <- function(..., extensions){ +colored_radiobuttons <- function(..., extensions) { output <- radioButtons(...) - #number of checkboxes + # number of checkboxes n <- length(output$children[[2]]$children[[1]]) - - lapply(1:n, function(i){ - #second column gets checkboxes + + lapply(1:n, function(i) { + # second column gets checkboxes output$children[[2]]$children[[1]][[i]]$children[[2]] <<- extensions[[i]] - + }) - + output } - diff --git a/helper_functions/summaryFilter.R b/helper_functions/summaryFilter.R index ade53a7..f87477b 100644 --- a/helper_functions/summaryFilter.R +++ b/helper_functions/summaryFilter.R @@ -1,83 +1,83 @@ #' Create a Summary of the Results from Filtering a peakData object -#' +#' #' This function takes a peakData object and determines the summary figure if certain filters should be applied. -#' +#' #' @param ftmsRobject A peakData object, nonfiltered. #' @param massfilt_ids,molfilt_ids,formfilt_ids vectors containing the retained peak ID's for any applied mass, molecule, or formula filters. #' @param customfilt_ids vectors containing the retained peak ID's resulting from the application of ALL OF up to 3 custom filters -#' -#' @return a dataframe containing filter display names, and the remaining assigned and unassigned -#' +#' +#' @return a dataframe containing filter display names, and the remaining assigned and unassigned +#' summaryFilt <- function(ftmsRobject, sampfilt_ids = NULL, massfilt_ids = NULL, molfilt_ids = NULL, formfilt_ids = NULL, customfilt_ids = NULL) { - + # Checks: minMass < molMass # if (minMass > maxMass) { # stop('Error: Minimum mass must be greater than maximum mass') # } # TODO: minMol is <= the total number of samples - + mass_cname <- attr(ftmsRobject, 'cnames')$mass_cname edata_cname <- attr(ftmsRobject, 'cnames')$edata_cname - + # Create 3-by-5 dataframe to store all data - data_state <- list('Unfiltered' = NULL, 'After Sample Filter' = sampfilt_ids, 'After Mass Filter' = massfilt_ids, 'After Molecule Filter' = molfilt_ids, - "After Formula Filter" = formfilt_ids, "After Custom Filters" = customfilt_ids) + data_state <- list('Unfiltered' = NULL, 'After Sample Filter' = sampfilt_ids, 'After Mass Filter' = massfilt_ids, 'After Molecule Filter' = molfilt_ids, + "After Formula Filter" = formfilt_ids, "After Custom Filters" = customfilt_ids) nfilters <- length(data_state) - summaryTable <- data.frame(data_state = factor(names(data_state), levels = names(data_state)), - assigned = numeric(nfilters), - unassigned = numeric(nfilters), - min_mass = numeric(nfilters), - max_mass = numeric(nfilters), - sum_peaks = numeric(nfilters), - dispText = 'NA', - stringsAsFactors = FALSE) - + summaryTable <- data.frame(data_state = factor(names(data_state), levels = names(data_state)), + assigned = numeric(nfilters), + unassigned = numeric(nfilters), + min_mass = numeric(nfilters), + max_mass = numeric(nfilters), + sum_peaks = numeric(nfilters), + dispText = 'NA', + stringsAsFactors = FALSE) + # Assign unfiltered sum and the display text summaryTable[1, 'sum_peaks'] <- dim(ftmsRobject$e_data)[1] summaryTable[1, 'dispText'] <- as.character(summaryTable[1, 'sum_peaks']) - + # Scope: Create fcol to store T/F Assigned/Unassigned list fcol <- NULL - + # If f_column exists - if(!is.null(attr(ftmsRobject, 'cnames')$mf_cname)) { + if (!is.null(attr(ftmsRobject, 'cnames')$mf_cname)) { fcol <- formula_filter(ftmsRobject) - - }else{fcol <- assign_mf(ftmsRobject) %>% formula_filter} - + + } else {fcol <- assign_mf(ftmsRobject) %>% formula_filter} + # Find assigned and unassigned for unfiltered - summaryTable[1,'assigned'] <- sum(fcol$Formula_Assigned) + summaryTable[1, 'assigned'] <- sum(fcol$Formula_Assigned) summaryTable[1, 'unassigned'] <- summaryTable[1, 'sum_peaks'] - summaryTable[1, 'assigned'] - + # Find minimum and maximum mass summaryTable[1, 'min_mass'] <- min(as.numeric(ftmsRobject$e_data[, mass_cname])) summaryTable[1, 'max_mass'] <- max(as.numeric(ftmsRobject$e_data[, mass_cname])) - - filteredFTMS <- ftmsRobject$e_data %>% - dplyr::select(attr(ftmsRobject, 'cnames')$edata_cname, attr(ftmsRobject, 'cnames')$mass_cname) %>% + + filteredFTMS <- ftmsRobject$e_data %>% + dplyr::select(attr(ftmsRobject, 'cnames')$edata_cname, attr(ftmsRobject, 'cnames')$mass_cname) %>% left_join(fcol) - - for(el in names(data_state[-1])){ - if(!is.null(data_state[[el]])){ + + for (el in names(data_state[-1])) { + if (!is.null(data_state[[el]])) { filteredFTMS <- filteredFTMS %>% filter(!!sym(edata_cname) %in% data_state[[el]]) - + row = which(summaryTable$data_state == el) - + # Find total number of peaks / rows summaryTable[row, 'sum_peaks'] <- nrow(filteredFTMS) summaryTable[row, 'dispText'] <- as.character(summaryTable[row, 'sum_peaks']) - + # Find assigned and unassigned summaryTable[row, 'assigned'] <- nrow(filteredFTMS %>% filter(Formula_Assigned == TRUE)) - + summaryTable[row, 'unassigned'] <- summaryTable[row, 'sum_peaks'] - summaryTable[row, 'assigned'] - + # Find minimum and maximum mass summaryTable[row, 'min_mass'] <- min(filteredFTMS %>% pluck(mass_cname)) summaryTable[row, 'max_mass'] <- max(filteredFTMS %>% pluck(mass_cname)) } } - + return(summaryTable) } diff --git a/helper_functions/summaryPreprocess.R b/helper_functions/summaryPreprocess.R index 7794cbe..09c040a 100644 --- a/helper_functions/summaryPreprocess.R +++ b/helper_functions/summaryPreprocess.R @@ -1,11 +1,11 @@ #' Create a Summary For the Information created On Preprocess Tab -#' -#' This function takes as input a preprocessed peakData object (created when the -#' Preprocess Data button is clicked) and what tests have been applied, and then finds the min, +#' +#' This function takes as input a preprocessed peakData object (created when the +#' Preprocess Data button is clicked) and what tests have been applied, and then finds the min, #' mean, median, and max for the summary table. -#' +#' #' @param ftmsRobject an object of class 'peakData', with the default calculations already applied -#' @param testsSelected A two-column data frame with real names of the test columns in one column +#' @param testsSelected A two-column data frame with real names of the test columns in one column #' and the display names in the second #' @param categorial set to TRUE if the tests selected are on categorical variables #' @param split_chars Character that divides categories for observations that belong to more than one category @@ -14,61 +14,61 @@ summaryPreprocess <- function(ftmsRobject, testsSelected, categorical = FALSE, split_chars = ";") { ## Categorical variable handling block - if(categorical){ - - #Apply to each column name - lapply(testsSelected[,1], function(colname){ - + if (categorical) { + + # Apply to each column name + lapply(testsSelected[, 1], function(colname) { + # split any values in the column that have 2 categories - split_col <- strsplit(ftmsRobject$e_meta[,colname], split_chars) %>% unlist() - + split_col <- strsplit(ftmsRobject$e_meta[, colname], split_chars) %>% unlist() + tab_na <- table(split_col, useNA = "ifany") tab <- table(split_col) - + # get levels/number of levels cats <- names(tab_na) N_cats <- length(cats) - + # make a dummy dataframe that will contain a column for the mode and counts of each category df <- data.frame(matrix(ncol = N_cats, nrow = 0)) %>% {`colnames<-`(., cats)} - - df[1,] <- tab_na # store counts + + df[1, ] <- tab_na # store counts rownames(df) <- testsSelected %>% filter(ColumnName == colname) %>% pluck(2) # set rowname for display purposes - + return(df) }) } - + ## Numeric variable handling block - - else{ - # Set up rownames for use in table - rowNames <- testsSelected[,2] + + else { + # Set up rownames for use in table + rowNames <- testsSelected[, 2] rowNum <- length(rowNames) - + # Set up data frame (finally!) - summaryTable <- data.frame('Min' = numeric(length = rowNum), - 'Mean' = numeric(length = rowNum), - 'Median' = numeric(length = rowNum), - 'Max' = numeric(length = rowNum)) - + summaryTable <- data.frame('Min' = numeric(length = rowNum), + 'Mean' = numeric(length = rowNum), + 'Median' = numeric(length = rowNum), + 'Max' = numeric(length = rowNum)) + row.names(summaryTable) <- rowNames - + # Call summary and extract info - allCols <- ftmsRobject$e_meta %>% dplyr::select(testsSelected[,1]) + allCols <- ftmsRobject$e_meta %>% dplyr::select(testsSelected[, 1]) # NOT YET WORKING: Sapply the summary # summaryTable <- t(sapply(allCols, function(x) unname(summary(x)[c('Min.', 'Mean', 'Median', 'Max.')]))) - + # For loop alternative: because sometimes sapply is unreadable for (i in 1:rowNum) { # Get summary - summary_tests <- summary(allCols[,i]) - + summary_tests <- summary(allCols[, i]) + # Put into summaryTable summaryTable[i, ] <- unname(summary_tests[c('Min.', 'Mean', 'Median', 'Max.')]) } - return (summaryTable) + return(summaryTable) } } diff --git a/server.R b/server.R index 5b7e042..5723ce3 100644 --- a/server.R +++ b/server.R @@ -5,18 +5,18 @@ ########### # Modify maximum file size (currently 250 mb) -options(shiny.maxRequestSize=250*1024^2, ch.dir = TRUE) +options(shiny.maxRequestSize = 250 * 1024^2, ch.dir = TRUE) # Uncomment for error checking on server -#options(shiny.sanitize.errors = FALSE) +# options(shiny.sanitize.errors = FALSE) shinyServer(function(session, input, output) { # onStop(function() rm(revals$peakData2, pos = 1)) - Sys.setenv(R_ZIPCMD="/usr/bin/zip") - - # source error handling file if exists, will be a script with observers that + Sys.setenv(R_ZIPCMD = "/usr/bin/zip") + + # source error handling file if exists, will be a script with observers that # store objects that will show up the workspace after disconnect, like so: - + # reactive values, including peakdata objects # observeEvent(reactiveValuesToList(revals),{ # revals$uploaded_emeta <- Emeta() @@ -26,18 +26,18 @@ shinyServer(function(session, input, output) { tryCatch({ source('untracked_resources/store_postmortem_objects.R', local = TRUE) }, error = function(e) message('Not storing postmortem objects')) - + # Source all scripts for (f in Sys.glob("./helper_functions/*.R")) source(f, local = TRUE) for (f in Sys.glob("./Reactive_Variables/*.R")) source(f, local = TRUE) for (f in Sys.glob("./Observers/*.R")) source(f, local = TRUE) - for (f in Sys.glob("./srv_ui_elements/*.R")) source(f, local = TRUE) - for (f in Sys.glob("./tab_factories/*.R")) source(f, local = TRUE) - - #'@details Store any values passed in the URL + for (f in Sys.glob("./srv_ui_elements/*.R")) source(f, local = TRUE) + for (f in Sys.glob("./tab_factories/*.R")) source(f, local = TRUE) + + #' @details Store any values passed in the URL header_params = reactiveValues() - - #'@details General unorganized reactiveValues + + #' @details General unorganized reactiveValues revals <- reactiveValues( ntables = 0, @@ -64,7 +64,7 @@ shinyServer(function(session, input, output) { groups_list = list(), removed_samples = list() ) - + plots <- reactiveValues( last_plot = NULL, @@ -90,7 +90,7 @@ shinyServer(function(session, input, output) { stringsAsFactors = FALSE ) ) - + tables <- reactiveValues( mapping_tables = list(), @@ -102,38 +102,38 @@ shinyServer(function(session, input, output) { stringsAsFactors = F ) ) - + #' @details core-ms files loaded through a header parameter that points to a - #' 'folder' in minio containing all files. - #' + #' 'folder' in minio containing all files. + #' #' @name data csv's resulting from read_csv() on the downloaded files from minio #' @name fpaths The temp filepaths of the files downloaded from minio - corems_revals <- reactiveValues(tables = list(), - fpaths = list()) - + corems_revals <- reactiveValues(tables = list(), + fpaths = list()) + # Reload objects for debugging if they exist - observeEvent(input$debug_reload,{ - if(exists('RELOAD_POSTMORTEM_PLOTS__')){ - lapply(names(RELOAD_POSTMORTEM_PLOTS__), function(x){ + observeEvent(input$debug_reload, { + if (exists('RELOAD_POSTMORTEM_PLOTS__')) { + lapply(names(RELOAD_POSTMORTEM_PLOTS__), function(x) { plots[[x]] <<- RELOAD_POSTMORTEM_PLOTS__[[x]] }) } - - if(exists('RELOAD_POSTMORTEM_OBJECTS__')){ - lapply(names(RELOAD_POSTMORTEM_OBJECTS__), function(x){ + + if (exists('RELOAD_POSTMORTEM_OBJECTS__')) { + lapply(names(RELOAD_POSTMORTEM_OBJECTS__), function(x) { revals[[x]] <<- RELOAD_POSTMORTEM_OBJECTS__[[x]] }) } - - if(exists('RELOAD_POSTMORTEM_TABLES__')){ - lapply(names(RELOAD_POSTMORTEM_TABLES__), function(x){ + + if (exists('RELOAD_POSTMORTEM_TABLES__')) { + lapply(names(RELOAD_POSTMORTEM_TABLES__), function(x) { tables[[x]] <<- RELOAD_POSTMORTEM_TABLES__[[x]] }) } }) exportTestValues(plot_data = revals$plot_data_export, peakData = revals$peakData_export, color_choices = revals$color_by_choices) - + ############################## ######## Welcome Tab ######### ############################## @@ -148,27 +148,27 @@ shinyServer(function(session, input, output) { print(tempdir()) fs <- c("example12T_edata.csv", "example12T_emeta.csv") write_csv(example_edata, path = file.path(tmpdir, "example12T_edata.csv")) - write_csv(example_emeta, path = file.path(tmpdir, "example12T_emeta.csv")) + write_csv(example_emeta, path = file.path(tmpdir, "example12T_emeta.csv")) print(fs) - zip(zipfile=fname, files=file.path(tmpdir, fs), flags = "-j") + zip(zipfile = fname, files = file.path(tmpdir, fs), flags = "-j") }, contentType = "application/zip" ) #---- processed data download --------# output$download_processed_data <- downloadHandler( - filename = paste("FREDA_Output_",proc.time()[1],".zip", sep = ""), - content = function(fname){ - zip(zipfile=fname, files=revals$fs, flags = "-j") - if (file.exists(paste0(fname,".zip"))){file.rename(paste0(fname,".zip"),fname)} - + filename = paste("FREDA_Output_", proc.time()[1], ".zip", sep = ""), + content = function(fname) { + zip(zipfile = fname, files = revals$fs, flags = "-j") + if (file.exists(paste0(fname, ".zip"))) {file.rename(paste0(fname, ".zip"), fname)} + }, contentType = "application/zip" ) - + # UI objects to be rendered when hidden - lapply(c('colorpal_out'), function(name){ + lapply(c('colorpal_out'), function(name) { outputOptions(output, name, suspendWhenHidden = FALSE) }) - + }) diff --git a/srv_ui_elements/corems_UI.R b/srv_ui_elements/corems_UI.R index 222d92a..fd996b6 100644 --- a/srv_ui_elements/corems_UI.R +++ b/srv_ui_elements/corems_UI.R @@ -1,4 +1,4 @@ -#'@details Modal indicating corems data was successfully uploaded +#' @details Modal indicating corems data was successfully uploaded corems_upload_modal <- function(modal_message) { modalDialog( modal_message, title = "Core-MS Upload Success", @@ -12,10 +12,10 @@ corems_upload_modal <- function(modal_message) { ) } -#'@details Modal indicating ftmsRanalysis::CoreMSData was successfully created. +#' @details Modal indicating ftmsRanalysis::CoreMSData was successfully created. corems_obj_creation_modal <- function() { modalDialog( - "Your CoreMS data object was successfully created, continue to filtering sub-tab or dismiss to review table/plots", + "Your CoreMS data object was successfully created, continue to filtering sub-tab or dismiss to review table/plots", title = "Object Creation Success!", footer = tagList( div( @@ -27,10 +27,10 @@ corems_obj_creation_modal <- function() { ) } -#'@details Modal indicating ftmsRanalysis::conf_filter was successfully applied. +#' @details Modal indicating ftmsRanalysis::conf_filter was successfully applied. corems_filter_modal <- function() { modalDialog( - "Your CoreMS data object was successfully filtered, continue to formula assignment sub-tab or dismiss to review table/plots", + "Your CoreMS data object was successfully filtered, continue to formula assignment sub-tab or dismiss to review table/plots", title = "Filter Success!", footer = tagList( div( @@ -42,10 +42,10 @@ corems_filter_modal <- function() { ) } -#'@details Modal indicating unique formulae have been assigned +#' @details Modal indicating unique formulae have been assigned corems_unq_mf_modal <- function() { modalDialog( - "Unique molecular formula were assigned to your Core-MS object, convert your object to a peakData object to continue in FREDA, or dismiss to review.", + "Unique molecular formula were assigned to your Core-MS object, convert your object to a peakData object to continue in FREDA, or dismiss to review.", title = "Formulas Assigned!", footer = tagList( div( @@ -58,31 +58,31 @@ corems_unq_mf_modal <- function() { } ## -#' Dropdowns for arguments to as.CoreMSData, all are named as +#' Dropdowns for arguments to as.CoreMSData, all are named as #' output$ -#' +#' -#'Helper function to make a dropdown that is mutually exclusive with other -#'dropdowns that pull from the columns of the imported corems data. +#' Helper function to make a dropdown that is mutually exclusive with other +#' dropdowns that pull from the columns of the imported corems data. mutually_exclusive_dropdown <- function(id, title, selected = NULL) { renderUI({ choices = union( - input[[id]], + input[[id]], coreMS_remaining_choices() ) %>% setdiff(NULLSELECT__) - + choices = c("Select one" = NULLSELECT__, choices) - - if(any(!(selected %in% choices),isTRUE(input[[id]] != NULLSELECT__))) { + + if (any(!(selected %in% choices), isTRUE(input[[id]] != NULLSELECT__))) { selected = input[[id]] } - + pickerInput(id, - title, - choices = choices, - selected = selected + title, + choices = choices, + selected = selected ) - }) + }) } output$index_cname <- mutually_exclusive_dropdown( @@ -137,65 +137,65 @@ output$s34_cname <- mutually_exclusive_dropdown( "s34_cname", "S34 Column:", "34S" ) -#'@details Preview table +#' @details Preview table output$cms_raw_data <- DT::renderDT( corems_revals[['combined_tables']], options = list(dom = 'ftp', - scrollX = TRUE) + scrollX = TRUE) ) -#'@details display plot of unique masses per sample -#'@app_location CoreMS Creation Tab +#' @details display plot of unique masses per sample +#' @app_location CoreMS Creation Tab output$cmsdat_plot <- renderPlotly({ req(cms_data()) plot(cms_data()) }) -#'@details data table with kept/removed peaks -#'@app_location Confidence Filtering Tab +#' @details data table with kept/removed peaks +#' @app_location Confidence Filtering Tab output$filt_peaks_dt <- DT::renderDT( ftmsRanalysis:::conf_filter_dt(cms_data(), input$min_conf), options = list(dom = 't') ) -#'@details Plot of filtered corems data -#'@app_location Confidence Filtering Tab +#' @details Plot of filtered corems data +#' @app_location Confidence Filtering Tab output$cms_filt_plot <- renderPlotly({ validate(need(cms_data_filtered(), "Create your filtered data to view filter plot")) plot(cms_data_filtered()) }) -#'@details display mass error plot with min_conf slider values -#'@app_location Confidence Filtering Tab +#' @details display mass error plot with min_conf slider values +#' @app_location Confidence Filtering Tab output$me_plot <- renderPlotly({ mass_error_plot(cms_data(), min_conf = input$min_conf) }) -#'@details Molecular formula plot -#'@app_location Unique molecular formula assignment tab +#' @details Molecular formula plot +#' @app_location Unique molecular formula assignment tab output$mf_plot <- renderPlotly({ validate(need(cms_dat_unq_mf(), "Please assign molecular formulae to your CoreMS data")) plot(cms_dat_unq_mf()) }) -#'@details data table with kept/removed peaks -#'@app_location Confidence Filtering Tab +#' @details data table with kept/removed peaks +#' @app_location Confidence Filtering Tab output$filt_peaks_dt <- DT::renderDT( ftmsRanalysis:::conf_filter_dt(cms_data(), input$min_conf), options = list(dom = 't') ) -#'@details Isotopic peaks after formula assignment -#'@app_location Core-MS formula assignment tab +#' @details Isotopic peaks after formula assignment +#' @app_location Core-MS formula assignment tab output$assign_formula_iso <- DT::renderDT({ - req(cms_dat_unq_mf()) - cms_dat_unq_mf()$iso_data - }, - options = list(dom = 't') + req(cms_dat_unq_mf()) + cms_dat_unq_mf()$iso_data +}, +options = list(dom = 't') ) -#'@details Mono-isotopic peaks after formula assignment -#'@app_location Core-MS formula assignment tab +#' @details Mono-isotopic peaks after formula assignment +#' @app_location Core-MS formula assignment tab output$assign_formula_monoiso <- DT::renderDT({ req(cms_dat_unq_mf()) cms_dat_unq_mf()$monoiso_data @@ -203,9 +203,9 @@ output$assign_formula_monoiso <- DT::renderDT({ options = list(dom = 't') ) -#'@details Button to convert corems data to ftmsRanalysis peakData +#' @details Button to convert corems data to ftmsRanalysis peakData output$corems_to_peakdata_UI <- renderUI({ req(cms_dat_unq_mf()) req(grepl("^CoreMS", input$top_page)) actionButton("corems_to_peakdata", "Convert to peak data", class = "btn-primary") -}) \ No newline at end of file +}) diff --git a/srv_ui_elements/database_UI.R b/srv_ui_elements/database_UI.R index 9af6425..dfca0d9 100644 --- a/srv_ui_elements/database_UI.R +++ b/srv_ui_elements/database_UI.R @@ -1,153 +1,153 @@ list( # show a table of saved tables - output$saved_db_table <- renderDT(tables$saved_db_info, options = list(scrollX = TRUE), - selection = 'single', escape = FALSE), - + output$saved_db_table <- renderDT(tables$saved_db_info, options = list(scrollX = TRUE), + selection = 'single', escape = FALSE), + # show the table selected in 'output$saved_db_table' output$selected_db_table <- renderDT({ req(length(input$saved_db_table_rows_selected) > 0) - tables$mapping_tables[[tables$saved_db_info[input$saved_db_table_rows_selected,'Tables']]] + tables$mapping_tables[[tables$saved_db_info[input$saved_db_table_rows_selected, 'Tables']]] }, options = list(scrollX = TRUE), selection = 'single', escape = FALSE), - + # determine which variable(s) to make a unique row for each output$which_unique <- renderUI({ choices = c('None', 'Reactions' = 'REACTION', 'Modules' = 'MODULE', 'Pathways' = 'PATHWAY') chosen_vars <- c(T, input$comp2react_x, input$react2mod_x, input$mod2path_x) choices = choices[chosen_vars] - - pickerInput('which_unique', NULL, - choices = choices, - multiple = FALSE) + + pickerInput('which_unique', NULL, + choices = choices, + multiple = FALSE) }), - + # KeggData table output output$kegg_table <- renderDT({ req(!is.null(tables$kegg_table), cancelOutput = TRUE) temp <- tables$kegg_table target_columns = which(colnames(temp) %in% c('MODULE', 'REACTION', 'PATHWAY')) temp <- temp %>% - mutate_at(target_columns, function(x){paste0('
    ', x, '
    ')}) + mutate_at(target_columns, function(x) {paste0('
    ', x, '
    ')}) temp }, - options = list(scrollX = TRUE, - pageLength = 10, - columnDefs = list(list(width = '200px', targets = '_all'))), + options = list(scrollX = TRUE, + pageLength = 10, + columnDefs = list(list(width = '200px', targets = '_all'))), server = TRUE, escape = FALSE), - + # MetaCyc table output output$mc_table <- renderDT({ req(!is.null(tables$mc_table), cancelOutput = TRUE) temp <- tables$mc_table target_columns = which(colnames(temp) %in% c('MODULE', 'REACTION', 'SUPERPATHWAY')) temp <- temp %>% - mutate_at(target_columns, function(x){paste0('
    ', x, '
    ')}) + mutate_at(target_columns, function(x) {paste0('
    ', x, '
    ')}) temp }, - options = list(scrollX = TRUE, - pageLength = 10, - columnDefs = list(list(width = '200px', targets = '_all'))), + options = list(scrollX = TRUE, + pageLength = 10, + columnDefs = list(list(width = '200px', targets = '_all'))), server = TRUE, escape = FALSE), - + # Display Kegg or Metacyc depending on button selection output$conditional_database_table <- renderUI({ - if(input$which_table == 1){ + if (input$which_table == 1) { DTOutput('kegg_table') } - else if(input$which_table == 2){ + else if (input$which_table == 2) { DTOutput('mc_table') } }), - + # button label for viewing saved tables output$n_saved_db_tables <- renderUI({ tags$span(paste0('View saved tables: (', length(tables$mapping_tables), ')')) }), - + # summary counts from kegg table output$mapping_summary <- renderDT({ req(revals$uploaded_data, revals$peakData2) req(!is.null(tables$kegg_table) | !is.null(tables$mc_table)) - - if(input$which_table == 1){ + + if (input$which_table == 1) { compare_table <- tables$kegg_table } - else if(input$which_table == 2){ + else if (input$which_table == 2) { compare_table <- tables$mc_table } - + n_peaks = revals$uploaded_data$e_meta %>% pluck(getMassColName(revals$uploaded_data)) %>% unique() %>% length() n_peaks_formula = revals$peakData2$e_meta %>% filter(!is.na(!!rlang::sym(getMFColName(revals$peakData2)))) %>% nrow() - - if(!is.null(tables$kegg_table)){ - n_map_to_kegg = tables$kegg_table %>% - dplyr::select(matches('compound', ignore.case=TRUE)) %>% + + if (!is.null(tables$kegg_table)) { + n_map_to_kegg = tables$kegg_table %>% + dplyr::select(matches('compound', ignore.case = TRUE)) %>% unique() %>% {!is.na(.)} %>% sum() } else n_map_to_kegg <- 'no table' - - if(!is.null(tables$mc_table)){ - n_map_to_mc = tables$mc_table %>% - dplyr::select(matches('compound', ignore.case=TRUE)) %>% + + if (!is.null(tables$mc_table)) { + n_map_to_mc = tables$mc_table %>% + dplyr::select(matches('compound', ignore.case = TRUE)) %>% unique() %>% {!is.na(.)} %>% sum() } else n_map_to_mc <- 'no table' - + data.frame('Original No. peaks' = n_peaks, 'No. peaks with formula (filtered data)' = n_peaks_formula, 'No. peaks mapping to Kegg' = n_map_to_kegg, 'No. peaks mapping to Metacyc' = n_map_to_mc, stringsAsFactors = FALSE, check.names = FALSE) - + }), - + # kegg barplot output$kegg_barplot <- renderPlotly({ req(tables$kegg_table, revals$peakData2) input$which_table - - p <- tables$kegg_table %>% - group_by(!!rlang::sym(getMassColName(revals$peakData2))) %>% - mutate(n = n()) %>% - slice(1) %>% - plot_ly(x = ~n, type = 'histogram') %>% - layout(title = 'Histogram of number of matching Kegg compounds', - xaxis = list(title = 'Database elements peak maps to'), - yaxis = list(title = 'Number of peaks')) - + + p <- tables$kegg_table %>% + group_by(!!rlang::sym(getMassColName(revals$peakData2))) %>% + mutate(n = n()) %>% + slice(1) %>% + plot_ly(x = ~n, type = 'histogram') %>% + layout(title = 'Histogram of number of matching Kegg compounds', + xaxis = list(title = 'Database elements peak maps to'), + yaxis = list(title = 'Number of peaks')) + isolate(plots$last_plot[[input$top_page]] <- p) - + toWebGL(p) - + }), - + # mc barplot output$mc_barplot <- renderPlotly({ req(tables$mc_table, revals$peakData2) input$which_table - - p <- tables$mc_table %>% - group_by(!!rlang::sym(getMassColName(revals$peakData2))) %>% - mutate(n = n()) %>% - slice(1) %>% - plot_ly(x = ~n, type = 'histogram') %>% - layout(title = 'Histogram of number of matching Metacyc compounds', - xaxis = list(title = 'Database elements peak maps to'), - yaxis = list(title = 'Number of peaks')) - + + p <- tables$mc_table %>% + group_by(!!rlang::sym(getMassColName(revals$peakData2))) %>% + mutate(n = n()) %>% + slice(1) %>% + plot_ly(x = ~n, type = 'histogram') %>% + layout(title = 'Histogram of number of matching Metacyc compounds', + xaxis = list(title = 'Database elements peak maps to'), + yaxis = list(title = 'Number of peaks')) + isolate(plots$last_plot[[input$top_page]] <- p) - + toWebGL(p) - + }), - + # conditionally display barplot for kegg or metacyc output$conditional_database_barplot <- renderUI({ - if(input$which_table == 1){ + if (input$which_table == 1) { plotlyOutput('kegg_barplot') } - else if(input$which_table == 2){ + else if (input$which_table == 2) { plotlyOutput('mc_barplot') } }), - + output$warnings_database <- renderUI({ HTML(paste(revals$warningmessage_database, collapse = "")) }) diff --git a/srv_ui_elements/download_UI.R b/srv_ui_elements/download_UI.R index 095dc27..abf2c92 100644 --- a/srv_ui_elements/download_UI.R +++ b/srv_ui_elements/download_UI.R @@ -1,40 +1,40 @@ list( # copy the table from the visualize tab so as not to confuse javascript output$download_plot_table <- DT::renderDataTable(plots$plot_table_download, - options = list(scrollX = TRUE, columnDefs = list(list(className = 'nowrap_scroll', targets = '_all'))), - escape = FALSE, selection = 'single'), - + options = list(scrollX = TRUE, columnDefs = list(list(className = 'nowrap_scroll', targets = '_all'))), + escape = FALSE, selection = 'single'), + ### Two outputs since we need to conditionally render either plotly or ggplot objects output$download_plotly <- renderPlotly({ req(length(input$download_plot_table_rows_selected) > 0, cancelOutput = TRUE) ind <- input$download_plot_table_rows_selected plot_name <- plots$plot_table[ind, 1] return(toWebGL(plots$plot_list[[plot_name]])) - }), - + }), + output$download_ggplot <- renderPlot({ req(length(input$download_plot_table_rows_selected) > 0, cancelOutput = TRUE) ind <- input$download_plot_table_rows_selected plot_name <- plots$plot_table[ind, 1] return(plots$plot_list[[plot_name]]) }), - + # display the selected plot from the modal table, depending on what type of plot is selected output$download_plot <- renderUI({ req(length(input$download_plot_table_rows_selected) > 0, cancelOutput = TRUE) ind <- input$download_plot_table_rows_selected plot_name <- plots$plot_table[ind, 1] - if(inherits(plots$plot_list[[plot_name]], 'plotly')){ + if (inherits(plots$plot_list[[plot_name]], 'plotly')) { plotlyOutput('download_plotly', width = 'auto', height = 'auto') } - else if(inherits(plots$plot_list[[plot_name]], 'ggplot')){ + else if (inherits(plots$plot_list[[plot_name]], 'ggplot')) { plotOutput('download_ggplot', width = 'auto', height = 'auto') - } + } }), - - # + + # output$warnings_download <- renderUI({ - HTML(lapply(revals$warningmessage_download, function(el){paste0("

    ")}) %>% - paste(collapse = "")) + HTML(lapply(revals$warningmessage_download, function(el) {paste0("

    ")}) %>% + paste(collapse = "")) }) -) \ No newline at end of file +) diff --git a/srv_ui_elements/filter_UI.R b/srv_ui_elements/filter_UI.R index 84d44cf..1e510ba 100644 --- a/srv_ui_elements/filter_UI.R +++ b/srv_ui_elements/filter_UI.R @@ -1,185 +1,185 @@ list( #### Main Panel (Filter Tab) #### - + # Show table from summaryFilt # Depends on: summaryFilterDataFrame output$summary_filter <- renderTable({ - + # Set default results: NA if no filters selected afterResults <- c(NA, NA, NA, NA) - last_filt_ind <- max(which(summaryFilterDataFrame()[,'dispText'] != 'NA')) + last_filt_ind <- max(which(summaryFilterDataFrame()[, 'dispText'] != 'NA')) afterResults <- unlist(summaryFilterDataFrame()[last_filt_ind, c('sum_peaks', 'assigned', 'min_mass', 'max_mass')]) - + # Find which row in summaryFilterDataFrame represents the Unfiltered information rowNum = which(summaryFilterDataFrame()$data_state == 'Unfiltered') - + # Create a dataframe out of Before and After results from summaryFilterDataFrame - summary_table <- data.frame('Before' = as.numeric(unlist(summaryFilterDataFrame()[rowNum, c('sum_peaks', 'assigned', - 'min_mass', 'max_mass')])), - 'After' = as.numeric(afterResults), - row.names = c('Number of peaks', - 'Number of peaks assigned a formula', - 'Minimum mass observed', - 'Maximum Mass observed'), stringsAsFactors = FALSE) - + summary_table <- data.frame('Before' = as.numeric(unlist(summaryFilterDataFrame()[rowNum, c('sum_peaks', 'assigned', + 'min_mass', 'max_mass')])), + 'After' = as.numeric(afterResults), + row.names = c('Number of peaks', + 'Number of peaks assigned a formula', + 'Minimum mass observed', + 'Maximum Mass observed'), stringsAsFactors = FALSE) + # Format the last two rows of this table to have decimal places and the first two rows to have a comma # this requires converting the table to a string, keep two copies in case the string changes display_table <- summary_table - - display_table[1:2, 1] <- formatC(round(summary_table[1:2,1]), big.mark = ",", format = "d") - display_table[1:2, 2] <- formatC(round(summary_table[1:2,2]), big.mark = ",", format = "d") + + display_table[1:2, 1] <- formatC(round(summary_table[1:2, 1]), big.mark = ",", format = "d") + display_table[1:2, 2] <- formatC(round(summary_table[1:2, 2]), big.mark = ",", format = "d") display_table[3:4, 1] <- formatC(round(summary_table[3:4, 1], digits = 4), format = "f", big.mark = ",") display_table[3:4, 2] <- formatC(round(summary_table[3:4, 2], digits = 4), format = "f", big.mark = ",") - - #___test-export___ + + # ___test-export___ exportTestValues(rem_peaks = as.numeric(summaryFilterDataFrame()[last_filt_ind, 'sum_peaks'])) - + return(display_table) }, # End code portion of summary_filter - + # Options: include rownames, no decimal places rownames = TRUE ), # End summary_filter - + # Plot bar chart # Depends on: summaryFilterDataFrame output$barplot_filter <- renderPlot({ summaryFilterDataFrame() req(isolate(revals$redraw_filter_plot) == TRUE | (isolate(uploaded_data_dim()) > max_cells)) - - filter_inds <- c(TRUE, isolate(input$samplefilter) & length(isolate(input$keep_samples)) > 0, isolate(input$massfilter), isolate(input$molfilter), isolate(input$formfilter), - any(c(isolate(input$custom1), isolate(input$custom2), isolate(input$custom3)) != "Select item") & isolate(input$customfilterz)) - + + filter_inds <- c(TRUE, isolate(input$samplefilter) & length(isolate(input$keep_samples)) > 0, isolate(input$massfilter), isolate(input$molfilter), isolate(input$formfilter), + any(c(isolate(input$custom1), isolate(input$custom2), isolate(input$custom3)) != "Select item") & isolate(input$customfilterz)) + which_filts <- c("Unfiltered", "After Sample Filter", "After Mass Filter", "After Molecule Filter", "After Formula Filter", "After Custom Filters")[filter_inds] - + # Melt dataframe into 2 objects - ggdata_barplot <- melt(summaryFilterDataFrame()[,c('data_state', 'assigned', 'unassigned')]) %>% filter(data_state %in% which_filts) + ggdata_barplot <- melt(summaryFilterDataFrame()[, c('data_state', 'assigned', 'unassigned')]) %>% filter(data_state %in% which_filts) ggdata_text <- summaryFilterDataFrame()[, c('data_state', 'sum_peaks', 'dispText')] %>% filter(data_state %in% which_filts) - + # Aesthetic purposes: get max height, divide by 30, use as offset in geom_text num_displaced <- round(ggdata_text[1, 2] / 35, digits = -1) - + shinyjs::hide('draw_large_filter_plot') - + # Plot using ggplot2 p <- ggplot() + geom_bar(data = ggdata_barplot, aes(x = data_state, y = value, fill = variable), stat = 'identity') + - theme_bw(base_size = 16) + - geom_text(data = ggdata_text, aes(x = data_state, y = sum_peaks + num_displaced, label = dispText), size = 6) + - scale_fill_brewer(name = 'Peak Type', labels = c('Formulae Assigned', 'Formulae Unassigned'), palette="Blues") + - labs(x = 'Data State', y = 'Number of peaks') - + theme_bw(base_size = 16) + + geom_text(data = ggdata_text, aes(x = data_state, y = sum_peaks + num_displaced, label = dispText), size = 6) + + scale_fill_brewer(name = 'Peak Type', labels = c('Formulae Assigned', 'Formulae Unassigned'), palette = "Blues") + + labs(x = 'Data State', y = 'Number of peaks') + isolate(plots$last_plot[[input$top_page]] <- p) - + p - + }), # End barplot_filter # - + #### Sidebar Panel (Filter Tab) #### - + # Drop down list: Minimum Number of observations # Depends on edata_cnames() output$minobs <- renderUI({ - selectInput('minobs', "Minimum number observed", choices = seq(1, max(length(input$keep_samples),1), 1), selected = 2) + selectInput('minobs', "Minimum number observed", choices = seq(1, max(length(input$keep_samples), 1), 1), selected = 2) }), # End minobs - + # Sample selection for sample filter output$filter_samples <- renderUI({ req(revals$uploaded_data) - inds = grepl(input$filter_regex, revals$uploaded_data$f_data[,getFDataColName(revals$uploaded_data)]) - subset = revals$uploaded_data$f_data[,getFDataColName(revals$uploaded_data)][inds] - selectInput('keep_samples', NULL, choices = revals$uploaded_data$f_data[,getFDataColName(revals$uploaded_data)], selected = subset, multiple = TRUE) + inds = grepl(input$filter_regex, revals$uploaded_data$f_data[, getFDataColName(revals$uploaded_data)]) + subset = revals$uploaded_data$f_data[, getFDataColName(revals$uploaded_data)][inds] + selectInput('keep_samples', NULL, choices = revals$uploaded_data$f_data[, getFDataColName(revals$uploaded_data)], selected = subset, multiple = TRUE) }), - + ### icon control for filter tab collapsible sections output$massfilter_icon <- renderUI({ req(input$top_page == 'Filter') - clicked = if(input$massfilter) div(id = 'ok_massfilt', style = 'color:deepskyblue;display:inline-block;margin-right:5px', icon('ok', lib='glyphicon')) else NULL - if('massfilt_collapse' %in% input$filter_sidebar){ + clicked = if (input$massfilter) div(id = 'ok_massfilt', style = 'color:deepskyblue;display:inline-block;margin-right:5px', icon('ok', lib = 'glyphicon')) else NULL + if ('massfilt_collapse' %in% input$filter_sidebar) { div( - clicked, + clicked, icon('chevron-up', lib = 'glyphicon') ) } - else{ + else { div( - clicked, + clicked, icon('chevron-down', lib = 'glyphicon') ) } }), - + output$samplefilter_icon <- renderUI({ req(input$top_page == 'Filter') - clicked = if(input$samplefilter) div(id = 'ok_samplefilter', style = 'color:deepskyblue;display:inline-block;margin-right:5px', icon('ok', lib='glyphicon')) else NULL - if('samplefilt_collapse' %in% input$filter_sidebar){ + clicked = if (input$samplefilter) div(id = 'ok_samplefilter', style = 'color:deepskyblue;display:inline-block;margin-right:5px', icon('ok', lib = 'glyphicon')) else NULL + if ('samplefilt_collapse' %in% input$filter_sidebar) { div( - clicked, + clicked, icon('chevron-up', lib = 'glyphicon') ) } - else{ + else { div( - clicked, + clicked, icon('chevron-down', lib = 'glyphicon') ) } }), - + output$formfilter_icon <- renderUI({ req(input$top_page == 'Filter') - clicked = if(input$formfilter) div(id = 'ok_formfilter', style = 'color:deepskyblue;display:inline-block;margin-right:5px', icon('ok', lib='glyphicon')) else NULL - if('formfilt_collapse' %in% input$filter_sidebar){ + clicked = if (input$formfilter) div(id = 'ok_formfilter', style = 'color:deepskyblue;display:inline-block;margin-right:5px', icon('ok', lib = 'glyphicon')) else NULL + if ('formfilt_collapse' %in% input$filter_sidebar) { div( - clicked, + clicked, icon('chevron-up', lib = 'glyphicon') ) } - else{ + else { div( - clicked, + clicked, icon('chevron-down', lib = 'glyphicon') ) } }), - + output$molfilter_icon <- renderUI({ req(input$top_page == 'Filter') - clicked = if(input$molfilter) div(id = 'ok_molfilter', style = 'color:deepskyblue;display:inline-block;margin-right:5px', icon('ok', lib='glyphicon')) else NULL - if('molfilt_collapse' %in% input$filter_sidebar){ + clicked = if (input$molfilter) div(id = 'ok_molfilter', style = 'color:deepskyblue;display:inline-block;margin-right:5px', icon('ok', lib = 'glyphicon')) else NULL + if ('molfilt_collapse' %in% input$filter_sidebar) { div( - clicked, + clicked, icon('chevron-up', lib = 'glyphicon') ) } - else{ + else { div( - clicked, + clicked, icon('chevron-down', lib = 'glyphicon') ) } }), - + output$customfilter_icon <- renderUI({ req(input$top_page == 'Filter') - clicked = if(input$customfilterz) div(id = 'ok_customfilterz', style = 'color:deepskyblue;display:inline-block;margin-right:5px', icon('ok', lib='glyphicon')) else NULL - if('customfilt_collapse' %in% input$filter_sidebar){ + clicked = if (input$customfilterz) div(id = 'ok_customfilterz', style = 'color:deepskyblue;display:inline-block;margin-right:5px', icon('ok', lib = 'glyphicon')) else NULL + if ('customfilt_collapse' %in% input$filter_sidebar) { div( - clicked, + clicked, icon('chevron-up', lib = 'glyphicon') ) } - else{ + else { div( - clicked, + clicked, icon('chevron-down', lib = 'glyphicon') ) } }), # - + # filter warnings output$warnings_filter_UI <- renderUI({ - HTML(lapply(revals$warningmessage_filter, function(el){paste0("

    ")}) %>% - paste(collapse = "")) + HTML(lapply(revals$warningmessage_filter, function(el) {paste0("

    ")}) %>% + paste(collapse = "")) }) -) \ No newline at end of file +) diff --git a/srv_ui_elements/global_UI.R b/srv_ui_elements/global_UI.R index c649f7f..e808c9f 100644 --- a/srv_ui_elements/global_UI.R +++ b/srv_ui_elements/global_UI.R @@ -1,6 +1,6 @@ list( output$enter_debugger <- renderUI({ - if(isTRUE(getOption("shiny.testmode"))){ + if (isTRUE(getOption("shiny.testmode"))) { tagList( actionButton("debugger", "whats wrong!?!?"), actionButton("debug_reload", "reload resources") @@ -8,43 +8,43 @@ list( } else return(NULL) }), - + # view plot table button UI output$viewplots_label <- renderUI({ n_plots <- nrow(plots$plot_table) tags$span(sprintf("(%i)", n_plots)) }), - + # display table of plots in modal dialog - output$modal_plot_table <- renderDataTable(plots$plot_table, - options = list(scrollX = TRUE, columnDefs = list(list(className = 'nowrap_scroll', targets = '_all'))), - escape = FALSE, selection = 'single'), - + output$modal_plot_table <- renderDataTable(plots$plot_table, + options = list(scrollX = TRUE, columnDefs = list(list(className = 'nowrap_scroll', targets = '_all'))), + escape = FALSE, selection = 'single'), + ### Two outputs since we need to conditionally render either plotly or ggplot objects output$modal_plotly <- renderPlotly({ req(length(input$modal_plot_table_rows_selected) > 0, cancelOutput = TRUE) ind <- input$modal_plot_table_rows_selected plot_name <- plots$plot_table[ind, 1] return(toWebGL(plots$plot_list[[plot_name]])) - }), - + }), + output$modal_ggplot <- renderPlot({ req(length(input$modal_plot_table_rows_selected) > 0, cancelOutput = TRUE) ind <- input$modal_plot_table_rows_selected plot_name <- plots$plot_table[ind, 1] return(plots$plot_list[[plot_name]]) }), - + # display the selected plot from the modal table, depending on what type of plot is selected output$modal_plot <- renderUI({ req(length(input$modal_plot_table_rows_selected) > 0, cancelOutput = TRUE) ind <- input$modal_plot_table_rows_selected plot_name <- plots$plot_table[ind, 1] - if(inherits(plots$plot_list[[plot_name]], 'plotly')){ + if (inherits(plots$plot_list[[plot_name]], 'plotly')) { plotlyOutput('modal_plotly', width = 'auto', height = '500px') } - else if(inherits(plots$plot_list[[plot_name]], 'ggplot')){ + else if (inherits(plots$plot_list[[plot_name]], 'ggplot')) { plotOutput('modal_ggplot', width = 'auto', height = '500px') - } + } }) -) \ No newline at end of file +) diff --git a/srv_ui_elements/groups_UI.R b/srv_ui_elements/groups_UI.R index b62ba8b..241e29a 100644 --- a/srv_ui_elements/groups_UI.R +++ b/srv_ui_elements/groups_UI.R @@ -5,17 +5,17 @@ list( req(!is.null(input$group_regex)) # filter sample names inds = grepl(input$group_regex, sample_names()) - - pickerInput("group_samples", "Samples to include in this group:", choices = sample_names()[inds], - options = pickerOptions(dropupAuto = FALSE, actionsBox = TRUE), multiple = TRUE) + + pickerInput("group_samples", "Samples to include in this group:", choices = sample_names()[inds], + options = pickerOptions(dropupAuto = FALSE, actionsBox = TRUE), multiple = TRUE) }), - + # table which displays stored groups output$group_table <- DT::renderDataTable(groupstab_df(), - selection = 'single', - options = list(scrollX = TRUE)), - + selection = 'single', + options = list(scrollX = TRUE)), + output$warnings_groups <- renderUI({ HTML(paste(revals$warningmessage_groups, collapse = "")) }) -) \ No newline at end of file +) diff --git a/srv_ui_elements/preprocess_UI.R b/srv_ui_elements/preprocess_UI.R index 5d60af8..3b89399 100644 --- a/srv_ui_elements/preprocess_UI.R +++ b/srv_ui_elements/preprocess_UI.R @@ -3,83 +3,83 @@ list( output$which_calcs <- renderUI({ choices <- calc_opts$Function names(choices) <- calc_opts$DisplayName - + # create list of extra html elements to add to the checkboxgroup - extensions = lapply(1:length(choices), function(i){ + extensions = lapply(1:length(choices), function(i) { div(style = "color:deepskyblue;display:inline-block", - tipify(icon("question-sign", lib = "glyphicon"), title = calc_opts$Info[i], placement = "top", trigger = 'hover') + tipify(icon("question-sign", lib = "glyphicon"), title = calc_opts$Info[i], placement = "top", trigger = 'hover') ) }) - + isolate({ # create a list of html objects which are extra options for certain functions, these will appear below the checkbox. - options = lapply(choices, function(x){ - if(x == 'calc_kendrick' & 'calc_kendrick' %in% input$tests){ - kendrick_selected = if(is.null(input$base_unit)) 'CH2' else input$base_unit - div(style='padding-left:20px;', - tipify(icon("question-sign", lib = "glyphicon"), kendrick_opts_info, placement = "top", trigger = 'hover'), - div(style = 'width:50%;display:inline-block', - pickerInput('base_unit', 'Choose Base Compound', choices = c('CH2', 'CO2', 'H2', 'H2O', 'CHO'), selected = kendrick_selected, multiple = T) - ) + options = lapply(choices, function(x) { + if (x == 'calc_kendrick' & 'calc_kendrick' %in% input$tests) { + kendrick_selected = if (is.null(input$base_unit)) 'CH2' else input$base_unit + div(style = 'padding-left:20px;', + tipify(icon("question-sign", lib = "glyphicon"), kendrick_opts_info, placement = "top", trigger = 'hover'), + div(style = 'width:50%;display:inline-block', + pickerInput('base_unit', 'Choose Base Compound', choices = c('CH2', 'CO2', 'H2', 'H2O', 'CHO'), selected = kendrick_selected, multiple = T) + ) ) } - else if(x == 'calc_dbe' & 'calc_dbe' %in% input$tests){ - dbe_selected = if(is.null(input$dbe_valences)) 'C4HN3O2S2P3' else input$dbe_valences + else if (x == 'calc_dbe' & 'calc_dbe' %in% input$tests) { + dbe_selected = if (is.null(input$dbe_valences)) 'C4HN3O2S2P3' else input$dbe_valences div(style='padding-left:20px;', - tipify(icon("question-sign", lib = "glyphicon"), dbe_opts_info, placement = "top", trigger = 'hover'), - div(style = 'display:inline-block', textInput('dbe_valences', 'Specify DBE valences', value = dbe_selected)) + tipify(icon("question-sign", lib = "glyphicon"), dbe_opts_info, placement = "top", trigger = 'hover'), + div(style = 'display:inline-block', textInput('dbe_valences', 'Specify DBE valences', value = dbe_selected)) ) } else NULL }) - + tagList(options) }) - - selected = if(is.null(input$tests)) c("calc_element_ratios", "calc_kendrick") else input$tests - + + selected = if (is.null(input$tests)) c("calc_element_ratios", "calc_kendrick") else input$tests + tooltip_checkbox("tests", "What Values Should be Calculated?", choices, selected = selected, - extensions = extensions, - options = options + extensions = extensions, + options = options ) }), - + # Warnings for preprocess tab output$warnings_preprocess <- renderUI({ HTML(paste(revals$warningmessage_preprocess, collapse = "")) }), - + # Plot the histogram chosen above # Depends on: which_hist output$preprocess_hist <- renderPlotly({ - + # Error handling: Require some columns to be selected req(input$which_hist) - + isolate({ # Save column name for later display columnName <- input$which_hist - + # set display name displayName <- calc_vars %>% filter(ColumnName == columnName) %>% pluck("DisplayName") - + # Plot histogram using plotly - p <- plot_ly(x = revals$uploaded_data$e_meta[,columnName], type = 'histogram') %>% - layout( title = paste('Observed distribution of', displayName), - scene = list( - xaxis = list(title = displayName), - yaxis = list(title = 'Frequency'))) + p <- plot_ly(x = revals$uploaded_data$e_meta[, columnName], type = 'histogram') %>% + layout(title = paste('Observed distribution of', displayName), + scene = list( + xaxis = list(title = displayName), + yaxis = list(title = 'Frequency'))) p$elementId <- NULL - - #____test export_____ + + # ____test export_____ exportTestValues(preprocess_hist = p, hist_attrs = p$x$attrs[[p$x$cur_data]], hist_layout = p$x$layout, hist_visdat = p$x$visdat[[p$x$cur_data]]()) - + isolate(plots$last_plot[[input$top_page]] <- p) - + return(toWebGL(p)) }) - + }) # End process_hist -) \ No newline at end of file +) diff --git a/srv_ui_elements/qc_UI.R b/srv_ui_elements/qc_UI.R index d4a5b31..580ef1d 100644 --- a/srv_ui_elements/qc_UI.R +++ b/srv_ui_elements/qc_UI.R @@ -2,60 +2,60 @@ list( # Y axis scale select for boxplots output$qc_plot_scale <- renderUI({ validate(need(!is.null(revals$peakData2), message = "No data object found, please verify you have successfully uploaded data")) - pickerInput("qc_plot_scale", "Plot on scale:", - choices = list('Log base 2' = 'log2', 'Log base 10'='log10', 'Natural log'='log', - 'Presence/absence' = 'pres', 'Raw intensity'='abundance'), - selected = 'pres') - + pickerInput("qc_plot_scale", "Plot on scale:", + choices = list('Log base 2' = 'log2', 'Log base 10' = 'log10', 'Natural log' = 'log', + 'Presence/absence' = 'pres', 'Raw intensity' = 'abundance'), + selected = 'pres') + }), - + # Group selection output$qc_select_groups <- renderUI({ - pickerInput("qc_select_groups", "Select groups:", - choices = names(revals$groups_list), - multiple = TRUE + pickerInput("qc_select_groups", "Select groups:", + choices = names(revals$groups_list), + multiple = TRUE ) }), - + # Boxplots output$qc_boxplots <- renderPlotly({ input$update_boxplot_axes req(!is.null(revals$peakData2)) req(!is.null(input$qc_plot_scale)) - if(uploaded_data_dim() > max_cells) isolate(on.exit(revals$redraw_largedata <- FALSE)) + if (uploaded_data_dim() > max_cells) isolate(on.exit(revals$redraw_largedata <- FALSE)) req(isolate(revals$redraw_largedata)) - - color_by <- if(isTRUE(input$qc_plot_scale %in% c('log2', 'log10', 'log', 'abundance'))) 'groups' else 'molform' + + color_by <- if (isTRUE(input$qc_plot_scale %in% c('log2', 'log10', 'log', 'abundance'))) 'groups' else 'molform' ds = attributes(revals$peakData2)$data_info$data_scale - + # subset the data if a group is selected - if(isTRUE(all(input$qc_select_groups %in% names(revals$groups_list)) & !is.null(input$qc_select_groups))){ + if (isTRUE(all(input$qc_select_groups %in% names(revals$groups_list)) & !is.null(input$qc_select_groups))) { # get set of unique samples in all selected groups samples <- revals$groups_list[input$qc_select_groups] %>% unlist() %>% unique() %>% setdiff(revals$removed_samples) temp_peakData2 <- subset(revals$peakData2, samples = samples) - } + } else temp_peakData2 <- revals$peakData2 - + # if their data scale selection does not match the object's data scale, transform before plotting - if(isTRUE(ds != input$qc_plot_scale)){ - p <- plot(edata_transform(temp_peakData2, input$qc_plot_scale), - xlabel=isolate(input$qc_boxplot_xlab), ylabel=isolate(input$qc_boxplot_ylab), - title = isolate(input$qc_boxplot_title),colorBy = color_by) %>% layout(margin = list(b = 100), xaxis = list(tickangle = 45)) + if (isTRUE(ds != input$qc_plot_scale)) { + p <- plot(edata_transform(temp_peakData2, input$qc_plot_scale), + xlabel = isolate(input$qc_boxplot_xlab), ylabel = isolate(input$qc_boxplot_ylab), + title = isolate(input$qc_boxplot_title), colorBy = color_by) %>% layout(margin = list(b = 100), xaxis = list(tickangle = 45)) } - else p <- plot(temp_peakData2, xlabel=isolate(input$qc_boxplot_xlab), ylabel=isolate(input$qc_boxplot_ylab), - title = isolate(input$qc_boxplot_title), colorBy=color_by) %>% layout(margin = list(b = 100), xaxis = list(tickangle = 45)) - + else p <- plot(temp_peakData2, xlabel = isolate(input$qc_boxplot_xlab), ylabel = isolate(input$qc_boxplot_ylab), + title = isolate(input$qc_boxplot_title), colorBy = color_by) %>% layout(margin = list(b = 100), xaxis = list(tickangle = 45)) + isolate(plots$last_plot[[input$top_page]] <- p) - + toWebGL(p) }), - + # qc warnings output$warnings_qc <- renderUI({ - HTML(lapply(revals$warningmessage_qc, function(el){ + HTML(lapply(revals$warningmessage_qc, function(el) { paste0("

    ") }) %>% paste(collapse = "") ) }) -) \ No newline at end of file +) diff --git a/srv_ui_elements/upload_UI_mainpanel.R b/srv_ui_elements/upload_UI_mainpanel.R index 4c01729..49fecd1 100644 --- a/srv_ui_elements/upload_UI_mainpanel.R +++ b/srv_ui_elements/upload_UI_mainpanel.R @@ -3,145 +3,145 @@ list( output$num_peaks <- renderText({ revals$uploaded_data c('Number of peaks: ', nrow(revals$uploaded_data$e_data)) - + }), # End num_peaks - + output$num_samples <- renderText({ revals$uploaded_data c('Number of samples: ', (length(edata_cnames()) - 1)) - - }), # End num_samples # - + + }), # End num_samples # + # Display success message OR display errors output$success_upload <- renderUI({ - + # Error handling: revals$uploaded_data must exist req(revals$uploaded_data) - + # If no errors, show Success message HTML('

    Your data object is created, and can be manipulated in subsequent tabs.

    ') - + }), # End success # - + # Display explanation for e_meta output$emeta_text <- renderUI({ - + req(Emeta()) HTML('

    Displaying Uploaded Molecular Identification File

    ') - - }),# End emeta_text - + + }), # End emeta_text + # Display explanation above e_data output$edata_text <- renderUI({ - + # Error handling: Edata() must exist req(Edata()) - + HTML('

    Displaying Uploaded Data File

    ') - + }), # End edata_text - + # display list of warnings pasted on separate lines output$warnings_upload_UI <- renderUI({ - HTML(lapply(revals$warningmessage_upload, function(el){ + HTML(lapply(revals$warningmessage_upload, function(el) { paste0("

    ") }) %>% paste(collapse = "") ) }), - + # e_data display output$head_edata <- DT::renderDT({ tmp <- Edata() - + # coerce logical to character for display purposes. tmp[, which(sapply(tmp, is.logical))] <- as.character(tmp[, which(sapply(tmp, is.logical))]) tmp }, options = list(scrollX = TRUE)), - + # e_meta display output$head_emeta <- DT::renderDataTable({ tmp <- Emeta() - + # coerce logical to character for display purposes. tmp[, which(sapply(tmp, is.logical))] <- as.character(tmp[, which(sapply(tmp, is.logical))]) tmp }, options = list(scrollX = TRUE)), - + # Summary: Display number of peaks with formulas output$num_peaks_formula <- renderText({ - + # Error handling: Require e_meta and others req(Emeta()) req(input$select != 0) - + # Scope: Set up num_rows_formula to edit in if statements num_rows_formula = nrow(Edata()) - + # If f_columns have been identified - if (input$select == 1){ - + if (input$select == 1) { + # Error handling: need formula column req(input$f_column) req(input$f_column != 'Select one') - req(is.character(Emeta()[,input$f_column])) - + req(is.character(Emeta()[, input$f_column])) + # Count all non-NA columns - f_column <- Emeta()[,input$f_column] - + f_column <- Emeta()[, input$f_column] + # Count all nonempty and non-NA entries num_rows_formula <- length(which((!is.na(f_column)) & (f_column != ""))) - + } else if (input$select == 2) { # If elemental columns have been identified - + # Error handling: drop down columns must exist and be numeric req({ - (input$c_column != 'Select a column') && - (input$h_column != 'Select a column') && + (input$c_column != 'Select a column') && + (input$h_column != 'Select a column') && (input$n_column != 'Select a column') && (input$o_column != 'Select a column') && (input$s_column != 'Select a column') && (input$p_column != 'Select a column') && - all(is.numeric(Emeta()[,input$c_column])) && - all(is.numeric(Emeta()[,input$h_column])) && - all(is.numeric(Emeta()[,input$n_column])) && - all(is.numeric(Emeta()[,input$o_column])) && - all(is.numeric(Emeta()[,input$s_column])) && - all(is.numeric(Emeta()[,input$p_column])) + all(is.numeric(Emeta()[, input$c_column])) && + all(is.numeric(Emeta()[, input$h_column])) && + all(is.numeric(Emeta()[, input$n_column])) && + all(is.numeric(Emeta()[, input$o_column])) && + all(is.numeric(Emeta()[, input$s_column])) && + all(is.numeric(Emeta()[, input$p_column])) }) # End error handling for elemental columns # - + # Set up list of column names - elem_cnames <- c(input$c_column, input$h_column, - input$n_column, input$o_column, - input$s_column, input$p_column) - + elem_cnames <- c(input$c_column, input$h_column, + input$n_column, input$o_column, + input$s_column, input$p_column) + # Create data frame of all elemental columns to sum across - elem_columns <- data.frame(Emeta()[,elem_cnames]) + elem_columns <- data.frame(Emeta()[, elem_cnames]) req(input$isotope_yn) req(input$iso_info_filter) # If isotopic information is included and matching entered notation, filter out where isotopes = denoted symbol if (input$isotope_yn == 1 & input$iso_info_filter == 1) { req(input$iso_info_column) validate(need(input$iso_info_column != 0, message = "Please choose a column of isotopic information")) - if (any(Emeta()[,input$iso_info_column] %in% input$iso_symbol)) { - iso <- Emeta()[,input$iso_info_column] - elem_columns <- elem_columns[-(which(as.character(iso) == as.character(input$iso_symbol))),] + if (any(Emeta()[, input$iso_info_column] %in% input$iso_symbol)) { + iso <- Emeta()[, input$iso_info_column] + elem_columns <- elem_columns[-(which(as.character(iso) == as.character(input$iso_symbol))), ] } - }# End if isotopic information is chosen and correctly denoted# - + } # End if isotopic information is chosen and correctly denoted# + # Count all remaining rows with nonzero sums num_rows_formula <- length(which(rowSums(elem_columns) > 0)) - + } # End elemental columns option - + validate( need(!is.null(revals$uploaded_data), message = "") ) # Display number of peaks/rows with formula assigned c('Number of peaks with formulas: ', num_rows_formula) - - + + }) # End num_peaks_formula in summary panel -) \ No newline at end of file +) diff --git a/srv_ui_elements/upload_UI_sidebar.R b/srv_ui_elements/upload_UI_sidebar.R index 17b157f..49bd4ba 100644 --- a/srv_ui_elements/upload_UI_sidebar.R +++ b/srv_ui_elements/upload_UI_sidebar.R @@ -3,109 +3,109 @@ list( output$edata_id <- renderUI({ # Drop down list with options from column names selectInput("edata_id_col", "Choose column with IDs", - choices = c('Select one', edata_cnames())) + choices = c('Select one', edata_cnames())) }), # End edata_id # - + output$NA_value_UI <- renderUI({ validate(need(Edata(), "Upload data file")) - + n_zeros = sum(Edata() == 0) - prop_zeros = n_zeros/(prod(dim(Edata())) - nrow(Edata())) - value = if(prop_zeros > 0.1) "0" else "NA" + prop_zeros = n_zeros / (prod(dim(Edata())) - nrow(Edata())) + value = if (prop_zeros > 0.1) "0" else "NA" textInput("NA_value", "What value specifies missing data?", value = value) }), - + # Drop-down lists: Choose formula column output$f_column <- renderUI({ selectInput("f_column", "Choose formula column", - choices = c('Select one', emeta_cnames())) + choices = c('Select one', emeta_cnames())) }), # End f_column # - + # Drop-down lists: Select which column represents C / H / N / O / etc # First try to locate the column name with a grepl # Note: All require emeta_cnames() output$c_column <- renderUI({ selectInput("c_column", "Carbon:", - choices = c('Select a column', emeta_cnames()), - selected = ifelse(grepl("^c$", tolower(emeta_cnames())), - yes = emeta_cnames()[grepl("^c$", tolower(emeta_cnames()))][1], - no = 'Select a column')) - + choices = c('Select a column', emeta_cnames()), + selected = ifelse(grepl("^c$", tolower(emeta_cnames())), + yes = emeta_cnames()[grepl("^c$", tolower(emeta_cnames()))][1], + no = 'Select a column')) + }), - + output$h_column <- renderUI({ - + selectInput("h_column", "Hydrogen:", - choices = c('Select a column', emeta_cnames()), - selected = ifelse(grepl("^h$", tolower(emeta_cnames())), - yes = emeta_cnames()[grepl("^h$", tolower(emeta_cnames()))][1], - no = 'Select a column')) - + choices = c('Select a column', emeta_cnames()), + selected = ifelse(grepl("^h$", tolower(emeta_cnames())), + yes = emeta_cnames()[grepl("^h$", tolower(emeta_cnames()))][1], + no = 'Select a column')) + }), - + output$n_column <- renderUI({ - + selectInput("n_column", "Nitrogen:", - choices = c('Select a column', emeta_cnames()), - selected = ifelse(grepl("^n$", tolower(emeta_cnames())), - yes = emeta_cnames()[grepl("^n$", tolower(emeta_cnames()))][1], - no = 'Select a column')) - + choices = c('Select a column', emeta_cnames()), + selected = ifelse(grepl("^n$", tolower(emeta_cnames())), + yes = emeta_cnames()[grepl("^n$", tolower(emeta_cnames()))][1], + no = 'Select a column')) + }), - + output$o_column <- renderUI({ - + selectInput("o_column", "Oxygen:", - choices = c('Select a column', emeta_cnames()), - selected = ifelse(grepl("^o$", tolower(emeta_cnames())), - yes = emeta_cnames()[grepl("^o$", tolower(emeta_cnames()))][1], - no = 'Select a column')) - - }), - + choices = c('Select a column', emeta_cnames()), + selected = ifelse(grepl("^o$", tolower(emeta_cnames())), + yes = emeta_cnames()[grepl("^o$", tolower(emeta_cnames()))][1], + no = 'Select a column')) + + }), + output$s_column <- renderUI({ - + selectInput("s_column", "Sulfur:", - choices = c('Select a column', emeta_cnames()), - selected = ifelse(grepl("^s$", tolower(emeta_cnames())), - yes = emeta_cnames()[grepl("^s$", tolower(emeta_cnames()))][1], - no = 'Select a column')) - + choices = c('Select a column', emeta_cnames()), + selected = ifelse(grepl("^s$", tolower(emeta_cnames())), + yes = emeta_cnames()[grepl("^s$", tolower(emeta_cnames()))][1], + no = 'Select a column')) + }), - + output$p_column <- renderUI({ - + selectInput("p_column", "Phosphorus:", - choices = c('Select a column', emeta_cnames()), - selected = ifelse(grepl("^p$", tolower(emeta_cnames())), - yes = emeta_cnames()[grepl("^p$", tolower(emeta_cnames()))][1], - no = 'Select a column')) + choices = c('Select a column', emeta_cnames()), + selected = ifelse(grepl("^p$", tolower(emeta_cnames())), + yes = emeta_cnames()[grepl("^p$", tolower(emeta_cnames()))][1], + no = 'Select a column')) }), ### END of CHNOSP DROP DOWN LISTS ### - + # C13 # output$iso_info_filter_out <- renderUI({ - radioGroupButtons(inputId = "iso_info_filter", label = "Filter isotopic peaks?", - choices = list('Yes' = 1, - 'No' = 2), - selected = 'Yes', - justified = TRUE + radioGroupButtons(inputId = "iso_info_filter", label = "Filter isotopic peaks?", + choices = list('Yes' = 1, + 'No' = 2), + selected = 'Yes', + justified = TRUE ) }), - + output$iso_info_column_out <- renderUI({ - req(input$iso_info_filter ) + req(input$iso_info_filter) if (input$iso_info_filter == 1) { selectInput("iso_info_column", "Which column contains isotopic information?", - choices = c('Select a column' = '0', emeta_cnames())) + choices = c('Select a column' = '0', emeta_cnames())) } else (return(NULL)) }), - + output$iso_symbol_out <- renderUI({ - req(input$iso_info_filter ) + req(input$iso_info_filter) if (input$iso_info_filter == 1) { textInput("iso_symbol", label = "Enter a symbol denoting isotopic notation:", - value = "1") + value = "1") } else (return(NULL)) }) -) \ No newline at end of file +) diff --git a/srv_ui_elements/visualize_UI_main_and_plot_opts.R b/srv_ui_elements/visualize_UI_main_and_plot_opts.R index 8cfb8a9..3b56776 100644 --- a/srv_ui_elements/visualize_UI_main_and_plot_opts.R +++ b/srv_ui_elements/visualize_UI_main_and_plot_opts.R @@ -3,249 +3,249 @@ list( # Main plotting output # output$FxnPlot <- renderPlotly({ req(!is.null(input$chooseplots)) - + # reactive dependencies input$update_axes input$vk_colors input$colorpal input$flip_colors - revals$makeplot #in case vk_colors does not change we still want to redraw the plot. - + revals$makeplot # in case vk_colors does not change we still want to redraw the plot. + disable('plot_submit') on.exit({ enable('plot_submit') }) - + # for testing if plot actually got updated in test mode exportTestValues(plot = NULL, plot_attrs = NULL) - isolate({ - if (v$clearPlot){ + isolate({ + if (v$clearPlot) { return(NULL) - } + } else { # Make sure a plot style selection has been chosen validate(need(input$choose_single != 0, message = "Please select plotting criteria")) - + revals$legendTitle = ifelse(is.null(input$legend_title_input) || (input$legend_title_input == ""), - yes = names(revals$color_by_choices[revals$color_by_choices == input$vk_colors]), - no = input$legend_title_input + yes = names(revals$color_by_choices[revals$color_by_choices == input$vk_colors]), + no = input$legend_title_input ) - + # Apply custom color scale if numeric is selected - if (numeric_selected() & !(input$vk_colors %in% c("bs1", "bs2"))){ + if (numeric_selected() & !(input$vk_colors %in% c("bs1", "bs2"))) { diverging_options = c("RdYlGn") pal <- RColorBrewer::brewer.pal(n = 9, input$colorpal) - + # diverging_options specify color palletes that look weird if they are truncated: [3:9], only truncate the 'normal' ones - if (!(input$colorpal %in% diverging_options)){ + if (!(input$colorpal %in% diverging_options)) { pal <- RColorBrewer::brewer.pal(n = 9, input$colorpal)[3:9] } - + # flip the color scale on button click - if (input$flip_colors %% 2 != 0){ + if (input$flip_colors %% 2 != 0) { pal <- rev(pal) } - + # get domain and obtain color pallette function - domain = range(plot_data()$e_meta[,input$vk_colors], na.rm = TRUE) + domain = range(plot_data()$e_meta[, input$vk_colors], na.rm = TRUE) colorPal <- scales::col_numeric(pal, domain) } - else if(!(input$choose_single %in% c(3,4)) & !(input$vk_colors %in% c("bs1", "bs2"))){ + else if (!(input$choose_single %in% c(3, 4)) & !(input$vk_colors %in% c("bs1", "bs2"))) { # if there are too many categories, warn user and provide color palette - if(length(unique(plot_data()$e_meta[, input$vk_colors])) > 12){ + if (length(unique(plot_data()$e_meta[, input$vk_colors])) > 12) { ramp <- colorRampPalette(RColorBrewer::brewer.pal(12, "Set3")) pal <- ramp(length(unique(plot_data()$e_meta[, input$vk_colors]))) colorPal <- scales::col_factor(pal, domain = unique(plot_data()$e_meta[, input$vk_colors])) } else colorPal <- NA } - else if(input$choose_single %in% c(3,4)){ + else if (input$choose_single %in% c(3, 4)) { pal = switch(input$colorpal, - 'default' = c("#7fa453", "#a16db8", "#cb674a"), 'bpr' = c("#0175ee", '#7030A0', "#fd003d"), - 'neutral' = c("#FC8D59", '#7030A0', "#91CF60"), 'bpg' = c('#8377cb', '#c95798', '#60a862'), - 'rblkgn' = c('red', 'black', 'green')) #TODO move color choices to static object - + 'default' = c("#7fa453", "#a16db8", "#cb674a"), 'bpr' = c("#0175ee", '#7030A0', "#fd003d"), + 'neutral' = c("#FC8D59", '#7030A0', "#91CF60"), 'bpg' = c('#8377cb', '#c95798', '#60a862'), + 'rblkgn' = c('red', 'black', 'green')) # TODO move color choices to static object + # still allow color_inversion, even though it looks weird - if (input$flip_colors %% 2 != 0){ + if (input$flip_colors %% 2 != 0) { pal <- rev(pal) } - - pal <- pal[c(1,3,2)] # dont ask - - domain <- unique(plot_data()$e_data[,which(grepl('^uniqueness', colnames(plot_data()$e_data)))]) + + pal <- pal[c(1, 3, 2)] # dont ask + + domain <- unique(plot_data()$e_data[, which(grepl('^uniqueness', colnames(plot_data()$e_data)))]) domain <- domain[which(!is.na(domain))] colorPal <- scales::col_factor(pal, domain = domain) } else colorPal <- NA # just in case.... - + #----------- Single sample plots ------------# - #-------Kendrick Plot-----------# + #-------Kendrick Plot-----------# if (input$chooseplots == 'Kendrick Plot') { validate(need(!is.null(input$whichSamples) | !(is.null(g1_samples()) & is.null(g2_samples())), message = "Please select at least 1 sample")) p <- kendrickPlot(plot_data(), colorCName = input$vk_colors, colorPal = colorPal, - xlabel = input$x_axis_input, ylabel = input$y_axis_input, - title = input$title_input,legendTitle = revals$legendTitle) - + xlabel = input$x_axis_input, ylabel = input$y_axis_input, + title = input$title_input, legendTitle = revals$legendTitle) + if (input$vk_colors %in% c('bs1', 'bs2')) { p <- kendrickPlot(plot_data(), vkBoundarySet = input$vk_colors, - xlabel = input$x_axis_input, ylabel = input$y_axis_input, - title = input$title_input,legendTitle = revals$legendTitle) + xlabel = input$x_axis_input, ylabel = input$y_axis_input, + title = input$title_input, legendTitle = revals$legendTitle) } else { # if color selection doesn't belong to a boundary, color by test p <- kendrickPlot(plot_data(), colorCName = input$vk_colors, colorPal = colorPal, - xlabel = input$x_axis_input, ylabel = input$y_axis_input, - title = input$title_input,legendTitle = revals$legendTitle) + xlabel = input$x_axis_input, ylabel = input$y_axis_input, + title = input$title_input, legendTitle = revals$legendTitle) } } #-------VanKrevelen Plot--------# if (input$chooseplots == 'Van Krevelen Plot') { validate(need(!is.null(input$whichSamples) | !(is.null(g1_samples()) & is.null(g2_samples())), message = "Please select at least 1 sample")) - if (input$vkbounds == 0) { #no bounds + if (input$vkbounds == 0) { # no bounds # if no boundary lines, leave the option to color by boundary if (input$vk_colors %in% c('bs1', 'bs2')) { p <- vanKrevelenPlot(plot_data(), showVKBounds = FALSE, vkBoundarySet = input$vk_colors, - xlabel = input$x_axis_input, ylabel = input$y_axis_input, - title = input$title_input,legendTitle = revals$legendTitle) + xlabel = input$x_axis_input, ylabel = input$y_axis_input, + title = input$title_input, legendTitle = revals$legendTitle) } else { # if no boundary lines and color selection doesn't belong to a boundary, color by test p <- vanKrevelenPlot(plot_data(), showVKBounds = FALSE, vkBoundarySet = NA, - colorCName = input$vk_colors, colorPal = colorPal, - xlabel = input$x_axis_input, ylabel = input$y_axis_input, - title = input$title_input,legendTitle = revals$legendTitle) + colorCName = input$vk_colors, colorPal = colorPal, + xlabel = input$x_axis_input, ylabel = input$y_axis_input, + title = input$title_input, legendTitle = revals$legendTitle) } } else { - # if boundary lines, allow a color by boundary class + # if boundary lines, allow a color by boundary class if (input$vk_colors %in% c('bs1', 'bs2')) { p <- vanKrevelenPlot(plot_data(), vkBoundarySet = input$vkbounds, showVKBounds = TRUE, - xlabel = input$x_axis_input, ylabel = input$y_axis_input, - title = input$title_input,legendTitle = revals$legendTitle) + xlabel = input$x_axis_input, ylabel = input$y_axis_input, + title = input$title_input, legendTitle = revals$legendTitle) } else { # if boundary lines and color isn't a boundary class - p <- vanKrevelenPlot(plot_data(), vkBoundarySet = input$vkbounds, showVKBounds = TRUE, - colorCName = input$vk_colors, colorPal = colorPal, - xlabel = input$x_axis_input, ylabel = input$y_axis_input, - title = input$title_input,legendTitle = revals$legendTitle) + p <- vanKrevelenPlot(plot_data(), vkBoundarySet = input$vkbounds, showVKBounds = TRUE, + colorCName = input$vk_colors, colorPal = colorPal, + xlabel = input$x_axis_input, ylabel = input$y_axis_input, + title = input$title_input, legendTitle = revals$legendTitle) } } } - + #--------- Density Plot --------# if (input$chooseplots == 'Density Plot') { validate(need(!is.null(input$whichSamples) | !(is.null(g1_samples()) & is.null(g2_samples())), message = "Please select at least 1 sample"), - need(!is.na(input$vk_colors), message = "Please select a variable") + need(!is.na(input$vk_colors), message = "Please select a variable") ) - + # sample/group inputs depending on whether or not we are doing a comparison of groups - if (input$choose_single %in% c(3,4)){ + if (input$choose_single %in% c(3, 4)) { samples = FALSE groups = unique(attr(plot_data(), "group_DF")$Group) } - else if (input$choose_single == 2){ + else if (input$choose_single == 2) { samples = input$whichSamples groups = "Group" } - else if (input$choose_single == 1){ + else if (input$choose_single == 1) { samples = input$whichSamples groups = FALSE } - + # if x axis input field is empty, get the display name of the color_by_choices vector index that equals vk_colors, otherwise use what the user typed xlabel = ifelse(is.null(input$x_axis_input) || input$x_axis_input == "", - yes = names(revals$color_by_choices[revals$color_by_choices == input$vk_colors]), - no = input$x_axis_input) - - p <- densityPlot(plot_data(),variable = input$vk_colors, samples = samples, groups = groups, - plot_hist = ifelse(input$choose_single == 1, TRUE, FALSE), - xlabel = xlabel, ylabel = input$y_axis_input, title = input$title_input) + yes = names(revals$color_by_choices[revals$color_by_choices == input$vk_colors]), + no = input$x_axis_input) + + p <- densityPlot(plot_data(), variable = input$vk_colors, samples = samples, groups = groups, + plot_hist = ifelse(input$choose_single == 1, TRUE, FALSE), + xlabel = xlabel, ylabel = input$y_axis_input, title = input$title_input) } - + #---------- Custom Scatter Plot --------# - if (input$chooseplots == 'Custom Scatter Plot'){ + if (input$chooseplots == 'Custom Scatter Plot') { validate(need(!is.null(input$whichSamples), message = "Please select at least 1 sample"), - need(!is.na(input$vk_colors), message = "Please select a variable to color by")) + need(!is.na(input$vk_colors), message = "Please select a variable to color by")) req(!is.null(input$scatter_x), !is.null(input$scatter_y), !("" %in% c(input$scatter_x, input$scatter_y))) - + p <- scatterPlot(plot_data(), input$scatter_x, input$scatter_y, colorCName = input$vk_colors, colorPal = colorPal, - xlabel = ifelse(is.null(input$x_axis_input) | (input$x_axis_input == ""), - yes = names(revals$color_by_choices[revals$color_by_choices == input$scatter_x]), - no = input$x_axis_input), - ylabel = ifelse(is.null(input$y_axis_input) | (input$y_axis_input == ""), - yes = names(revals$color_by_choices[revals$color_by_choices == input$scatter_y]), - no = input$y_axis_input), - title = input$title_input, legendTitle = revals$legendTitle) - + xlabel = ifelse(is.null(input$x_axis_input) | (input$x_axis_input == ""), + yes = names(revals$color_by_choices[revals$color_by_choices == input$scatter_x]), + no = input$x_axis_input), + ylabel = ifelse(is.null(input$y_axis_input) | (input$y_axis_input == ""), + yes = names(revals$color_by_choices[revals$color_by_choices == input$scatter_y]), + no = input$y_axis_input), + title = input$title_input, legendTitle = revals$legendTitle) + } #----------- PCOA Plot ----------# - if(input$chooseplots==('PCOA Plot')){ + if (input$chooseplots == ('PCOA Plot')) { # maximum of 5 pcs or the number of samples - 2 (#columns - ID column - 1) - xlabel = ifelse(is.null(input$x_axis_input) | (input$x_axis_input == ""), - yes = paste0('PC ', input$scatter_x), - no = input$x_axis_input) - ylabel = ifelse(is.null(input$y_axis_input) | (input$y_axis_input == ""), - yes = paste0('PC ', input$scatter_y), - no = input$y_axis_input) - - pcs <- getPrincipalCoordinates(plot_data(), n_dims = min(5, ncol(plot_data()$e_data)-2), dist_metric = input$choose_dist) - p <- plotPrincipalCoordinates(pcs, title = input$title_input, x=as.numeric(input$scatter_x), y=as.numeric(input$scatter_y), - xlabel = xlabel, ylabel=ylabel, - ftmsObj = plot_data(), size = 10) + xlabel = ifelse(is.null(input$x_axis_input) | (input$x_axis_input == ""), + yes = paste0('PC ', input$scatter_x), + no = input$x_axis_input) + ylabel = ifelse(is.null(input$y_axis_input) | (input$y_axis_input == ""), + yes = paste0('PC ', input$scatter_y), + no = input$y_axis_input) + + pcs <- getPrincipalCoordinates(plot_data(), n_dims = min(5, ncol(plot_data()$e_data) - 2), dist_metric = input$choose_dist) + p <- plotPrincipalCoordinates(pcs, title = input$title_input, x = as.numeric(input$scatter_x), y = as.numeric(input$scatter_y), + xlabel = xlabel, ylabel = ylabel, + ftmsObj = plot_data(), size = 10) } } }) # Axes Options f <- list(family = "Arial", size = 18, color = "#7f7f7f") - + x <- y <- list(titlefont = f) - + p <- p %>% layout(xaxis = x, yaxis = y, titlefont = f) - + # Null assignment bypasses plotly bug p$elementId <- NULL - + # ___test-export___ exportTestValues(plot = p, plot_attrs = p$x$attrs[[p$x$cur_data]], plot_layout = p$x$layout, plot_visdat = p$x$visdat[[p$x$cur_data]]()) - + # inspect <<- p - + revals$current_plot <- p isolate(plots$last_plot[[input$top_page]] <- p) - + p <- p %>% layout(margin = list(b = 50, l = 75)) # I dont know why but webGL crops axes titles, must reset p <- toWebGL(p) - + return(p) }), # END FXNPLOT - + # Axis and title label input menus output$title_out <- renderUI({ - + validate( need(!is.null(input$chooseplots), message = "") ) textInput(inputId = "title_input", label = "Plot title", value = "") }), - + output$x_axis_out <- renderUI({ validate( need(!is.null(input$chooseplots), message = "") ) textInput(inputId = "x_axis_input", label = "X axis label", value = plot_defaults()$xlabel) }), - + output$y_axis_out <- renderUI({ validate( need(!is.null(input$chooseplots), message = "") ) textInput(inputId = "y_axis_input", label = "Y axis label", value = plot_defaults()$ylabel) }), - + # legend input output$legend_title_out <- renderUI({ validate( need(!is.null(input$chooseplots), message = "") ) - if (input$chooseplots == "Density Plot"){ + if (input$chooseplots == "Density Plot") { addCssClass("js_legend_title_input", "grey_out") disabled(textInput(inputId = "legend_title_input", label = "Legend label", value = "")) } @@ -253,32 +253,32 @@ list( removeCssClass("js_legend_title_input", "grey_out") textInput(inputId = "legend_title_input", label = "Legend label", value = "") } - + }), - + # color palette selection (last collapse panel on sidebar) output$colorpal_out <- renderUI({ req(input$choose_single) - if(!(input$choose_single %in% c(3,4)) | isTRUE(input$chooseplots == "Density Plot")){ - choices = c("YlOrRd", "YlGnBu", "YlGn", "RdYlGn") #TODO move color choices to static object + if (!(input$choose_single %in% c(3, 4)) | isTRUE(input$chooseplots == "Density Plot")) { + choices = c("YlOrRd", "YlGnBu", "YlGn", "RdYlGn") # TODO move color choices to static object fnames = paste0(choices, '.png') } - else if(input$choose_single %in% c(3,4)){ - choices = c('default', 'bpr', 'neutral', 'bpg', 'rblkgn') #TODO move color choices to static object - fnames = c('default.png', 'bl_prp_rd.png', 'neutral.png', 'bl_pnk_gn.png', 'rd_blk_gn.png') + else if (input$choose_single %in% c(3, 4)) { + choices = c('default', 'bpr', 'neutral', 'bpg', 'rblkgn') # TODO move color choices to static object + fnames = c('default.png', 'bl_prp_rd.png', 'neutral.png', 'bl_pnk_gn.png', 'rd_blk_gn.png') } - + # create raw html to include in choicesOpt arg of pickerInput - extensions = sapply(1:length(choices), function(i){ + extensions = sapply(1:length(choices), function(i) { sprintf("

    %s
    ", fnames[i], choices[i])}) - + # no choices for density plots yet - if (isTRUE(input$chooseplots == "Density Plot")){ + if (isTRUE(input$chooseplots == "Density Plot")) { addClass("js_colorpal", "grey_out") disabled(pickerInput(inputId = 'colorpal', 'Color Scheme', choices = choices, choicesOpt = list(content = extensions))) - }else { + } else { removeClass("js_colorpal", "grey_out") pickerInput(inputId = 'colorpal', 'Color Scheme', choices = choices, choicesOpt = list(content = extensions)) } }) -) \ No newline at end of file +) diff --git a/srv_ui_elements/visualize_UI_misc.R b/srv_ui_elements/visualize_UI_misc.R index e0a5e85..f103e52 100644 --- a/srv_ui_elements/visualize_UI_misc.R +++ b/srv_ui_elements/visualize_UI_misc.R @@ -3,34 +3,34 @@ list( output$warnings_visualize_UI <- renderUI({ HTML(paste(revals$warningmessage_visualize, collapse = "")) }), - + # icon control for viztab collapsible sections output$chooseplots_icon <- renderUI({ req(input$top_page == 'Visualize') - if('peakplots' %in% input$viz_sidebar) + if ('peakplots' %in% input$viz_sidebar) icon('chevron-up', lib = 'glyphicon') else icon('chevron-down', lib = 'glyphicon') }), - + output$axlabs_icon <- renderUI({ req(input$top_page == 'Visualize') - if('axlabs' %in% input$viz_sidebar) + if ('axlabs' %in% input$viz_sidebar) icon('chevron-up', lib = 'glyphicon') else icon('chevron-down', lib = 'glyphicon') }), - + output$saveplots_icon <- renderUI({ req(input$top_page == 'Visualize') - if('downloads' %in% input$viz_sidebar) + if ('downloads' %in% input$viz_sidebar) icon('chevron-up', lib = 'glyphicon') else icon('chevron-down', lib = 'glyphicon') }), - + output$dynamic_opts_icon <- renderUI({ req(input$top_page == 'Visualize') - if('reactive_plot_opts' %in% input$viz_sidebar) + if ('reactive_plot_opts' %in% input$viz_sidebar) icon('chevron-up', lib = 'glyphicon') else icon('chevron-down', lib = 'glyphicon') }) # -) \ No newline at end of file +) diff --git a/srv_ui_elements/visualize_UI_sidebar.R b/srv_ui_elements/visualize_UI_sidebar.R index 49f5cdb..b922ffc 100644 --- a/srv_ui_elements/visualize_UI_sidebar.R +++ b/srv_ui_elements/visualize_UI_sidebar.R @@ -5,194 +5,194 @@ list( input$top_page validate(need(revals$peakData2, "A peakData object was not found, please check that you have successfully uploaded data")) req(input$top_page == "Visualize") - + choices <- c('Van Krevelen Plot', 'Kendrick Plot', 'Density Plot', 'Custom Scatter Plot', 'PCOA Plot') - + # disallow kendrick plots if either kmass or kdefect not calculated/present in emeta - if (is.null(attr(revals$peakData2, "cnames")$kmass_cname) | is.null(attr(revals$peakData2, "cnames")$kdefect_cname)){ + if (is.null(attr(revals$peakData2, "cnames")$kmass_cname) | is.null(attr(revals$peakData2, "cnames")$kdefect_cname)) { choices <- choices[choices != "Kendrick Plot"] } - + # disallow vk plots if o:c or h:c ratios not calculated/present in emeta or only contain zeros/NA's - if (is.null(attr(revals$peakData2, "cnames")$o2c_cname) | is.null(attr(revals$peakData2, "cnames")$h2c_cname)){ + if (is.null(attr(revals$peakData2, "cnames")$o2c_cname) | is.null(attr(revals$peakData2, "cnames")$h2c_cname)) { choices <- choices[choices != "Van Krevelen Plot"] } - else if(any(all(revals$peakData2$e_meta[[attr(revals$peakData2, "cnames")$o2c_cname]] %in% c(0,NA)), - all(revals$peakData2$e_meta[[attr(revals$peakData2, "cnames")$h2c_cname]] %in% c(0,NA)))){ + else if (any(all(revals$peakData2$e_meta[[attr(revals$peakData2, "cnames")$o2c_cname]] %in% c(0, NA)), + all(revals$peakData2$e_meta[[attr(revals$peakData2, "cnames")$h2c_cname]] %in% c(0, NA)))) { choices <- choices[choices != "Van Krevelen Plot"] } - + # disallow density plots if there are no numeric columns - if (!any(sapply(revals$peakData2$e_meta %>% dplyr::select(-one_of(getEDataColName(revals$peakData2))), is.numeric))){ + if (!any(sapply(revals$peakData2$e_meta %>% dplyr::select(-one_of(getEDataColName(revals$peakData2))), is.numeric))) { choices <- choices[choices != c("Density Plot", "Custom Scatter Plot")] } - + # disallow custom scatter plot if we have large data - if (peakData2_dim() > max_cells){ + if (peakData2_dim() > max_cells) { choices <- choices[choices != 'Custom Scatter Plot'] } - + # disallow pcoa plot for 1 sample data - if (nrow(revals$peakData2$f_data) < 2){ + if (nrow(revals$peakData2$f_data) < 2) { choices <- choices[choices != 'PCOA Plot'] } - - #if everything is disallowed, give warning and silently stop execution. + + # if everything is disallowed, give warning and silently stop execution. if (length(choices) == 0) return(tags$p("There is not enough information in the molecular identification file to produce any plots. Choose more variables to calculate in the preprocess tab or append some metadata to the molecular identification file prior to uploading", style = "color:gray")) - + selectInput('chooseplots', 'Choose a plot type', - choices = choices, - selected = 0 + choices = choices, + selected = 0 ) }), - + # Logic to force single sample selection in the case where only 1 sample is present output$plotUI <- renderUI({ req(!is.null(input$chooseplots)) - if (nrow(revals$peakData2$f_data) == 1 | (input$chooseplots %in% c('Custom Scatter Plot', 'PCOA Plot'))){ + if (nrow(revals$peakData2$f_data) == 1 | (input$chooseplots %in% c('Custom Scatter Plot', 'PCOA Plot'))) { return(tagList( tags$div(class = 'grey_out', - hidden(selectInput('choose_single', 'I want to plot using:', - choices = c('Make a selection' = 0, 'A single sample' = 1, 'Multiple samples by group' = 2, - 'A comparison of groups' = 3, 'A comparison of two samples' = 4), - selected = 1)) + hidden(selectInput('choose_single', 'I want to plot using:', + choices = c('Make a selection' = 0, 'A single sample' = 1, 'Multiple samples by group' = 2, + 'A comparison of groups' = 3, 'A comparison of two samples' = 4), + selected = 1)) ) - #tags$p("No grouping options for custom scatter plots and single sample datasets.", style = "color:gray;font-size:small;margin-top:3px") + # tags$p("No grouping options for custom scatter plots and single sample datasets.", style = "color:gray;font-size:small;margin-top:3px") )) } else { return(selectInput('choose_single', 'I want to plot using:', - choices = c('Make a selection' = 0, 'A single sample' = 1, 'Multiple samples' = 2, - 'A comparison of groups' = 3, 'A comparison of two samples' = 4), - selected = 0)) + choices = c('Make a selection' = 0, 'A single sample' = 1, 'Multiple samples' = 2, + 'A comparison of groups' = 3, 'A comparison of two samples' = 4), + selected = 0)) } }), - + # pcoa distance metric dropdown output$pcoa_dist <- renderUI({ - req(input$chooseplots=='PCOA Plot') - dist_choices = c('manhattan', 'euclidean', 'canberra', 'clark', 'bray', 'kulczynski', - 'jaccard', 'gower', 'altGower', 'morisita', 'horn', 'mountford', 'raup', - 'binomial', 'cao','mahalanobis') - + req(input$chooseplots == 'PCOA Plot') + dist_choices = c('manhattan', 'euclidean', 'canberra', 'clark', 'bray', 'kulczynski', + 'jaccard', 'gower', 'altGower', 'morisita', 'horn', 'mountford', 'raup', + 'binomial', 'cao', 'mahalanobis') + selectInput('choose_dist', "Choose a distance metric", choices = dist_choices, selected = 'bray') }), - + # select groups to color by output$viztab_select_groups <- renderUI({ - req(input$chooseplots=='PCOA Plot') - pickerInput("viztab_select_groups", "Select groups:", - choices = names(revals$groups_list), - multiple = TRUE + req(input$chooseplots == 'PCOA Plot') + pickerInput("viztab_select_groups", "Select groups:", + choices = names(revals$groups_list), + multiple = TRUE ) }), - + ## UI outputs for group/sample comparisons ## - ## conditional display depending on whether comparing two samples or two groups ## + ## conditional display depending on whether comparing two samples or two groups ## output$plotUI_comparison_1 <- renderUI({ req(input$choose_single != 0, !is.null(input$chooseplots)) - if(input$choose_single == 3){ + if (input$choose_single == 3) { choice_diff <- setdiff(names(revals$groups_list), isolate(input$whichGroups2)) name_label = HTML("") pickerInput('whichGroups1', name_label, - choices = choice_diff, - selected = if(is.null(isolate(revals$group_1))) choice_diff[1] else isolate(revals$group_1), - options = pickerOptions(dropupAuto = FALSE, actionsBox = TRUE)) + choices = choice_diff, + selected = if (is.null(isolate(revals$group_1))) choice_diff[1] else isolate(revals$group_1), + options = pickerOptions(dropupAuto = FALSE, actionsBox = TRUE)) } - else if(input$choose_single == 4){ + else if (input$choose_single == 4) { choice_diff <- setdiff(colnames(revals$peakData2$e_data[-which(colnames(revals$peakData2$e_data) == getEDataColName(revals$peakData2))]), isolate(input$whichSample2)) pickerInput('whichSample1', "Sample 1:", - choices = choice_diff, - selected = if(is.null(isolate(revals$whichSample1))) choice_diff[1] else isolate(revals$whichSample1), - options = pickerOptions(dropupAuto = FALSE)) + choices = choice_diff, + selected = if (is.null(isolate(revals$whichSample1))) choice_diff[1] else isolate(revals$whichSample1), + options = pickerOptions(dropupAuto = FALSE)) } }), - + output$plotUI_comparison_2 <- renderUI({ req(input$choose_single != 0, !is.null(input$chooseplots)) - if(input$choose_single == 3){ + if (input$choose_single == 3) { choice_diff <- setdiff(names(revals$groups_list), isolate(input$whichGroups1)) name_label = HTML("") - pickerInput("whichGroups2", name_label, - choices = setdiff(names(revals$groups_list), isolate(input$whichGroups1)), - selected = if(is.null(isolate(revals$group_2))) choice_diff[2] else isolate(revals$group_2), - options = pickerOptions(dropupAuto = FALSE, actionsBox = TRUE)) + pickerInput("whichGroups2", name_label, + choices = setdiff(names(revals$groups_list), isolate(input$whichGroups1)), + selected = if (is.null(isolate(revals$group_2))) choice_diff[2] else isolate(revals$group_2), + options = pickerOptions(dropupAuto = FALSE, actionsBox = TRUE)) } - else if(input$choose_single == 4){ + else if (input$choose_single == 4) { choice_diff <- setdiff(colnames(revals$peakData2$e_data[-which(colnames(revals$peakData2$e_data) == getEDataColName(revals$peakData2))]), isolate(input$whichSample1)) - pickerInput("whichSample2", "Sample 2:", - choices = choice_diff, - selected = if(is.null(isolate(revals$whichSample2))) choice_diff[2] else isolate(revals$whichSample2), - options = pickerOptions(dropupAuto = FALSE)) + pickerInput("whichSample2", "Sample 2:", + choices = choice_diff, + selected = if (is.null(isolate(revals$whichSample2))) choice_diff[2] else isolate(revals$whichSample2), + options = pickerOptions(dropupAuto = FALSE)) } }), - + ## - + # UI output for single sample or single group output$plotUI_single <- renderUI({ req(input$choose_single != 0, !is.null(input$chooseplots), input$chooseplots != 'PCOA Plot') - if(input$choose_single == 2){ + if (input$choose_single == 2) { tagList( div(id = "js_whichSamples", - pickerInput('whichSamples', 'Grouped Samples', - choices = colnames(revals$peakData2$e_data %>% dplyr::select(-one_of(getEDataColName(revals$peakData2)))), - multiple = TRUE, selected = isolate(revals$single_group), - options = pickerOptions(dropupAuto = FALSE, actionsBox = TRUE))), + pickerInput('whichSamples', 'Grouped Samples', + choices = colnames(revals$peakData2$e_data %>% dplyr::select(-one_of(getEDataColName(revals$peakData2)))), + multiple = TRUE, selected = isolate(revals$single_group), + options = pickerOptions(dropupAuto = FALSE, actionsBox = TRUE))), conditionalPanel( condition = 'input.whichSamples.length < 2', tags$p("Please select at least 2 samples", style = "color:gray") - )# End conditional output multiple samples# + ) # End conditional output multiple samples# ) } - else return(div(id = "js_whichSamples", selectInput('whichSamples', 'Sample', - choices = colnames(revals$peakData2$e_data %>% dplyr::select(-one_of(getEDataColName(revals$peakData2)))), - selected = revals$single_sample))) + else return(div(id = "js_whichSamples", selectInput('whichSamples', 'Sample', + choices = colnames(revals$peakData2$e_data %>% dplyr::select(-one_of(getEDataColName(revals$peakData2)))), + selected = revals$single_sample))) }), - + # selector for summary funcion output$summary_fxn_out <- renderUI({ - req(!(input$choose_single %in% c(1,2)), cancelOutput = T) + req(!(input$choose_single %in% c(1, 2)), cancelOutput = T) text_pres_fn <- "For a given peak, should the count or proportion of nonmissing values across samples in a group be used to determine whether or not that peak is present/absent within the group" - text_test <- HTML("

    Should a G-test or presence absence thresholds be used to determine whether a sample is unique to a particular group?

    Depending on your selection, you will be asked for a presence threshold and a p-value (G-test) or a presence AND absence threshold

    ") - + text_test <- HTML("

    Should a G-test or presence absence thresholds be used to determine whether a sample is unique to a particular group?

    Depending on your selection, you will be asked for a presence threshold and a p-value (G-test) or a presence AND absence threshold

    ") + # density plot has group summary options disabled - if (isTRUE(input$chooseplots == "Density Plot")){ + if (isTRUE(input$chooseplots == "Density Plot")) { summary_dropdown <- tags$div(class = "grey_out", - tags$p("No summary functions for comparison density plots", style = "color:gray;font-size:small;margin-top:3px;font-weight:bold"), - hidden( - radioButtons("pres_fn", - div("Determine presence/absence by:", div(style = "display:inline-block;right:5px", tipify(icon("question-sign", lib = "glyphicon"), title = text_pres_fn, placement = "top", trigger = 'hover'))), - choices = c("No. of Samples Present" = "nsamps", "Proportion of Samples Present" = "prop"), inline = TRUE, selected = "nsamps") - ), - - hidden(selectInput("summary_fxn", - div("Determine uniqueness using:", div(style = "display:inline-block", tipify(icon("question-sign", lib = "glyphicon"), title = text_test, placement = "top", trigger = 'hover'))), - choices = c("Select one" = "select_none", "G test" = "uniqueness_gtest", "Presence/absence thresholds" = "uniqueness_nsamps"), selected = "select_none")), - hidden(numericInput("pres_thresh", "Presence threshold", value = 1, step = 0.1)), - hidden(numericInput("absn_thresh", "Absence threshold", value = 0, step = 0.1)), - hidden(numericInput("pval", "p-value", min = 0, max = 1, value = 0.05, step = 0.1)) + tags$p("No summary functions for comparison density plots", style = "color:gray;font-size:small;margin-top:3px;font-weight:bold"), + hidden( + radioButtons("pres_fn", + div("Determine presence/absence by:", div(style = "display:inline-block;right:5px", tipify(icon("question-sign", lib = "glyphicon"), title = text_pres_fn, placement = "top", trigger = 'hover'))), + choices = c("No. of Samples Present" = "nsamps", "Proportion of Samples Present" = "prop"), inline = TRUE, selected = "nsamps") + ), + + hidden(selectInput("summary_fxn", + div("Determine uniqueness using:", div(style = "display:inline-block", tipify(icon("question-sign", lib = "glyphicon"), title = text_test, placement = "top", trigger = 'hover'))), + choices = c("Select one" = "select_none", "G test" = "uniqueness_gtest", "Presence/absence thresholds" = "uniqueness_nsamps"), selected = "select_none")), + hidden(numericInput("pres_thresh", "Presence threshold", value = 1, step = 0.1)), + hidden(numericInput("absn_thresh", "Absence threshold", value = 0, step = 0.1)), + hidden(numericInput("pval", "p-value", min = 0, max = 1, value = 0.05, step = 0.1)) ) - # non-density plots - }else{ + # non-density plots + } else { summary_dropdown <- tagList( hr(style = 'margin-top:2px;height:3px;background-color:#1A5276'), - radioButtons("pres_fn", - div("Determine presence/absence by:", div(style = "color:deepskyblue;display:inline-block", tipify(icon("question-sign", lib = "glyphicon"), title = text_pres_fn, placement = "top", trigger = 'hover'))), - choices = c("No. of Samples Present" = "nsamps", "Proportion of Samples Present" = "prop"), inline = TRUE, selected = "nsamps"), - + radioButtons("pres_fn", + div("Determine presence/absence by:", div(style = "color:deepskyblue;display:inline-block", tipify(icon("question-sign", lib = "glyphicon"), title = text_pres_fn, placement = "top", trigger = 'hover'))), + choices = c("No. of Samples Present" = "nsamps", "Proportion of Samples Present" = "prop"), inline = TRUE, selected = "nsamps"), + hr(style = "margin-top:2px"), - - div(id = "js_summary_fxn", selectInput("summary_fxn", - div("Determine uniqueness using:", div(style = "color:deepskyblue;display:inline-block", tipify(icon("question-sign", lib = "glyphicon"), title = text_test, placement = "top", trigger = 'hover'))), - choices = c("Select one" = "select_none", "G test" = "uniqueness_gtest", "Presence/absence thresholds" = "uniqueness_nsamps"))), - - splitLayout(class = "squeezesplitlayout", - div(id = "js_pres_thresh", numericInput("pres_thresh", "Presence threshold", value = 1, step = 0.1)), - div(id = "js_absn_thresh", numericInput("absn_thresh", "Absence threshold", value = 0, step = 0.1)), - div(id ="js_pval", numericInput("pval", "p-value", min = 0, max = 1, value = 0.05, step = 0.1)) + + div(id = "js_summary_fxn", selectInput("summary_fxn", + div("Determine uniqueness using:", div(style = "color:deepskyblue;display:inline-block", tipify(icon("question-sign", lib = "glyphicon"), title = text_test, placement = "top", trigger = 'hover'))), + choices = c("Select one" = "select_none", "G test" = "uniqueness_gtest", "Presence/absence thresholds" = "uniqueness_nsamps"))), + + splitLayout(class = "squeezesplitlayout", + div(id = "js_pres_thresh", numericInput("pres_thresh", "Presence threshold", value = 1, step = 0.1)), + div(id = "js_absn_thresh", numericInput("absn_thresh", "Absence threshold", value = 0, step = 0.1)), + div(id = "js_pval", numericInput("pval", "p-value", min = 0, max = 1, value = 0.05, step = 0.1)) ) )} return(summary_dropdown) }) -) \ No newline at end of file +) diff --git a/srv_ui_elements/visualize_linked_plots_UI.R b/srv_ui_elements/visualize_linked_plots_UI.R index 149f313..2c5baeb 100644 --- a/srv_ui_elements/visualize_linked_plots_UI.R +++ b/srv_ui_elements/visualize_linked_plots_UI.R @@ -2,292 +2,292 @@ list( # Table of plots that have the ability to be linked/compared output$lp_plot_table <- DT::renderDataTable({ linked_plots_table() - }, - options = list(scrollX = TRUE, columnDefs = list(list(className = 'nowrap_scroll', targets = '_all'))), - escape = FALSE, selection = 'multiple'), - + }, + options = list(scrollX = TRUE, columnDefs = list(list(className = 'nowrap_scroll', targets = '_all'))), + escape = FALSE, selection = 'multiple'), + # Left linked plot (corresponds to the first row selected) output$lp_left <- renderPlotly({ req(revals$peakData2) input$lp_compare_plots lp_lastEvent$trigger - + # big ol' isolate block isolate({ # get the data corresponding to selected points # usually we will link plot components through e_meta - d <- event_data('plotly_selected', source= lp_lastEvent$source) - + d <- event_data('plotly_selected', source = lp_lastEvent$source) + # must have two selected rows row1 <- input$lp_plot_table_rows_selected[1] row2 <- input$lp_plot_table_rows_selected[2] req(all(!is.null(row1), !is.null(row2))) - + ## GET VARIABLE RESOURCES FOR DRAWING PLOTS/CONSTRUCTING DATA## - + # We need: - - #' 1. Plot type of the plot that was interacted with, since this determines + + #' 1. Plot type of the plot that was interacted with, since this determines #' the structure of 'd'. - #' - #' 2. Type of the plot that is currently being drawn, since this determines + #' + #' 2. Type of the plot that is currently being drawn, since this determines #' how we should add extra elements - #' - #' 1/2 Will be the same if we interacted with the plot currently + #' + #' 1/2 Will be the same if we interacted with the plot currently #' being drawn. - #' - #' x-variable of the interacted-with plot and the current plot, usually + #' + #' x-variable of the interacted-with plot and the current plot, usually #' for if we are dealing with data from/for a histogram - + pname_current = linked_plots_table()[row1, 'File Name'] xvar_current = linked_plots_table()[row1, 'X Variable'] ptype_current = linked_plots_table()[row1, 'Plot Type'] - - #' The samples that are contained in each plot, mostly for purposes of - #' filtering out observations that dont appear in these samples + + #' The samples that are contained in each plot, mostly for purposes of + #' filtering out observations that dont appear in these samples #' (edata_inds below...) - sampnames = revals$peakData2$f_data[,getFDataColName(revals$peakData2)] - g1_samples = linked_plots_table()[row1, 'Group 1 Samples'] %>% - stringr::str_extract_all(paste(sampnames, collapse="|")) %>% + sampnames = revals$peakData2$f_data[, getFDataColName(revals$peakData2)] + g1_samples = linked_plots_table()[row1, 'Group 1 Samples'] %>% + stringr::str_extract_all(paste(sampnames, collapse = "|")) %>% purrr::pluck(1) - g2_samples = linked_plots_table()[row1, 'Group 2 Samples'] %>% - stringr::str_extract_all(paste(sampnames, collapse="|")) %>% + g2_samples = linked_plots_table()[row1, 'Group 2 Samples'] %>% + stringr::str_extract_all(paste(sampnames, collapse = "|")) %>% purrr::pluck(1) - + #' indices of e_data for all the peaks that have at least one nonzero #' observation for all the samples for this plot. - edata_inds = revals$peakData2$e_data %>% - select(getEDataColName(revals$peakData2)) %>% + edata_inds = revals$peakData2$e_data %>% + select(getEDataColName(revals$peakData2)) %>% mutate(`__INCLUDE_EDATA__` = revals$peakData2$e_data %>% - select(g1_samples) %>% - rowSums(na.rm = T) %>% - {. != 0} + select(g1_samples) %>% + rowSums(na.rm = T) %>% + {. != 0} ) ## - - if(!is_empty(d)){ - d <- d[!sapply(d$key, is.null),] # some keys are null, these are the elements we add to the plot to highlight selected points - + + if (!is_empty(d)) { + d <- d[!sapply(d$key, is.null), ] # some keys are null, these are the elements we add to the plot to highlight selected points + # plot type and x variable for -selected- plot - if(lp_lastEvent$source == 'left_source'){ + if (lp_lastEvent$source == 'left_source') { ptype_selected = linked_plots_table()[row1, 'Plot Type'] xvar_selected = linked_plots_table()[row1, 'X Variable'] } - else if(lp_lastEvent$source == 'right_source'){ + else if (lp_lastEvent$source == 'right_source') { ptype_selected = linked_plots_table()[row2, 'Plot Type'] xvar_selected = linked_plots_table()[row2, 'X Variable'] } - - #### CONSTRUCT E-META CORRESPONDING TO SELECTED DATA #### - + + #### CONSTRUCT E-META CORRESPONDING TO SELECTED DATA #### + # These all depend on the edata id field scatter_types = c('Van Krevelen Plot', 'Kendrick Plot', 'Custom Scatter Plot') - + # if we selected a scatter plot, the d[['key']] will hold selected ids - if(ptype_selected %in% scatter_types){ + if (ptype_selected %in% scatter_types) { tmp_dat <- dplyr::filter(revals$peakData2$e_meta, !!rlang::sym(getEDataColName(revals$peakData2)) %in% d[["key"]]) } - else if(ptype_selected %in% c('Density Plot')){ + else if (ptype_selected %in% c('Density Plot')) { #' A dataframe that indicates if certain values of the variable in #' question lie inside any of the bins selected on the histogram. - emeta_inds <- revals$peakData2$e_meta %>% - select(getEDataColName(revals$peakData2)) %>% + emeta_inds <- revals$peakData2$e_meta %>% + select(getEDataColName(revals$peakData2)) %>% mutate(`__INCLUDE_EMETA__` = sapply(d$key, function(x) { - # histogram data includes values on the right edge, not the left - revals$peakData2$e_meta[[xvar_selected]] > as.numeric(x[1]) & + # histogram data includes values on the right edge, not the left + revals$peakData2$e_meta[[xvar_selected]] > as.numeric(x[1]) & revals$peakData2$e_meta[[xvar_selected]] <= as.numeric(x[2]) - }) %>% + }) %>% apply(1, any) ) - - #' filter down to observations that fell within selected histogram + + #' filter down to observations that fell within selected histogram #' bins AND have at least one observation in the selected samples - selected_rows <- emeta_inds %>% - left_join(edata_inds) %>% - select(-one_of(getEDataColName(revals$peakData2))) %>% + selected_rows <- emeta_inds %>% + left_join(edata_inds) %>% + select(-one_of(getEDataColName(revals$peakData2))) %>% apply(1, all) - - tmp_dat <- revals$peakData2$e_meta[selected_rows,] + + tmp_dat <- revals$peakData2$e_meta[selected_rows, ] } - + #### UPDATE PLOTS BASED ON TYPE #### - + # c('Van Krevelen Plot', 'Kendrick Plot', 'Density Plot', 'Custom Scatter Plot', 'PCOA Plot') - if(ptype_current == "Van Krevelen Plot"){ - p <- plots$linked_plots$left %>% - add_markers(x=~get(getOCRatioColName(revals$peakData2)), y=~get(getHCRatioColName(revals$peakData2)), data=tmp_dat, - marker=list(color="cyan"), name="Selected", inherit = F) + if (ptype_current == "Van Krevelen Plot") { + p <- plots$linked_plots$left %>% + add_markers(x = ~ get(getOCRatioColName(revals$peakData2)), y = ~ get(getHCRatioColName(revals$peakData2)), data = tmp_dat, + marker = list(color = "cyan"), name = "Selected", inherit = F) } - else if(ptype_current == 'Kendrick Plot'){ - p <- plots$linked_plots$left %>% - add_markers(x=~get(getKendrickMassColName(revals$peakData2)), y=~get(getKendrickDefectColName(revals$peakData2)), data=tmp_dat, - marker=list(color="cyan"), name="Selected", inherit = F) + else if (ptype_current == 'Kendrick Plot') { + p <- plots$linked_plots$left %>% + add_markers(x = ~ get(getKendrickMassColName(revals$peakData2)), y = ~ get(getKendrickDefectColName(revals$peakData2)), data = tmp_dat, + marker = list(color = "cyan"), name = "Selected", inherit = F) } - else if(ptype_current == 'Custom Scatter Plot'){ + else if (ptype_current == 'Custom Scatter Plot') { # need the y variable as well for custom scatter plots, since it is not fixed yvar = linked_plots_table()[row1, 'Y Variable'] - - p <- plots$linked_plots$left %>% - add_markers(x=~get(xvar_current), y=~get(yvar), data=tmp_dat, - marker=list(color="cyan"), name="Selected", inherit = F) + + p <- plots$linked_plots$left %>% + add_markers(x = ~ get(xvar_current), y = ~ get(yvar), data = tmp_dat, + marker = list(color = "cyan"), name = "Selected", inherit = F) } - else if(ptype_current == 'Density Plot'){ - #' plotly objects with histogram traces have a 'hist_data' attribute + else if (ptype_current == 'Density Plot') { + #' plotly objects with histogram traces have a 'hist_data' attribute #' containing bins, bindwidths, etc. hist_dat <- attr(plots$linked_plots$left, 'hist_data') - + #' for each range, get the counts of FILTERED data that fall in that range counts <- sapply(hist_dat$key, function(x) { nrow( - tmp_dat %>% + tmp_dat %>% filter( - !!rlang::sym(xvar_current) > x[1] & - !!rlang::sym(xvar_current) <= x[2] + !!rlang::sym(xvar_current) > x[1] & + !!rlang::sym(xvar_current) <= x[2] ) ) }) - - #' normalize by the number of rows in the original data that had - #' nonmissing observations in the current plots displayed samples, + + #' normalize by the number of rows in the original data that had + #' nonmissing observations in the current plots displayed samples, #' as well as the bin width - density <- counts/sum(edata_inds$`__INCLUDE_EDATA__`)/hist_dat$barwidth - + density <- counts / sum(edata_inds$`__INCLUDE_EDATA__`) / hist_dat$barwidth + hist_dat$counts <- counts hist_dat$density <- density - - p <- plots$linked_plots$left %>% - add_bars(x=~x, y=~density, width=~barwidth, marker = list(color='cyan'), data = hist_dat) + + p <- plots$linked_plots$left %>% + add_bars(x = ~x, y = ~density, width = ~barwidth, marker = list(color = 'cyan'), data = hist_dat) } } - else{ + else { p <- plots$linked_plots$left } - + isolate({ plots$last_plot[[input$top_page]][['left']] <- list(p) names(plots$last_plot[[input$top_page]][['left']]) <- pname_current }) - + p - + }) }), - - #' Right linked plot, does the same as above, except the 'current plot' is + + #' Right linked plot, does the same as above, except the 'current plot' is #' referenced by the SECOND row selected. output$lp_right <- renderPlotly({ req(revals$peakData2) input$lp_compare_plots lp_lastEvent$trigger - + isolate({ - d <- event_data('plotly_selected', source= lp_lastEvent$source) - + d <- event_data('plotly_selected', source = lp_lastEvent$source) + row1 <- input$lp_plot_table_rows_selected[1] row2 <- input$lp_plot_table_rows_selected[2] req(all(!is.null(row1), !is.null(row2))) - + pname_current = linked_plots_table()[row2, 'File Name'] xvar_current = linked_plots_table()[row2, 'X Variable'] ptype_current = linked_plots_table()[row2, 'Plot Type'] - sampnames = revals$peakData2$f_data[,getFDataColName(revals$peakData2)] - g1_samples = linked_plots_table()[row2, 'Group 1 Samples'] %>% - stringr::str_extract_all(paste(sampnames, collapse="|")) %>% + sampnames = revals$peakData2$f_data[, getFDataColName(revals$peakData2)] + g1_samples = linked_plots_table()[row2, 'Group 1 Samples'] %>% + stringr::str_extract_all(paste(sampnames, collapse = "|")) %>% purrr::pluck(1) - g2_samples = linked_plots_table()[row2, 'Group 2 Samples'] %>% - stringr::str_extract_all(paste(sampnames, collapse="|")) %>% + g2_samples = linked_plots_table()[row2, 'Group 2 Samples'] %>% + stringr::str_extract_all(paste(sampnames, collapse = "|")) %>% purrr::pluck(1) - edata_inds = revals$peakData2$e_data %>% - select(getEDataColName(revals$peakData2)) %>% + edata_inds = revals$peakData2$e_data %>% + select(getEDataColName(revals$peakData2)) %>% mutate(`__INCLUDE_EDATA__` = revals$peakData2$e_data %>% - select(g1_samples) %>% - rowSums(na.rm = T) %>% - {. != 0} + select(g1_samples) %>% + rowSums(na.rm = T) %>% + {. != 0} ) - + scatter_types = c('Van Krevelen Plot', 'Kendrick Plot', 'Custom Scatter Plot') - - if(!is_empty(d)){ - d <- d[!sapply(d$key, is.null),] - - if(lp_lastEvent$source == 'left_source'){ + + if (!is_empty(d)) { + d <- d[!sapply(d$key, is.null), ] + + if (lp_lastEvent$source == 'left_source') { ptype_selected = linked_plots_table()[row1, 'Plot Type'] xvar_selected = linked_plots_table()[row1, 'X Variable'] } - else if(lp_lastEvent$source == 'right_source'){ + else if (lp_lastEvent$source == 'right_source') { ptype_selected = linked_plots_table()[row2, 'Plot Type'] xvar_selected = linked_plots_table()[row2, 'X Variable'] } - - if(ptype_selected %in% scatter_types){ + + if (ptype_selected %in% scatter_types) { tmp_dat <- dplyr::filter(revals$peakData2$e_meta, !!rlang::sym(getEDataColName(revals$peakData2)) %in% d[["key"]]) } - else if(ptype_selected %in% c('Density Plot')){ - emeta_inds <- revals$peakData2$e_meta %>% - select(getEDataColName(revals$peakData2)) %>% + else if (ptype_selected %in% c('Density Plot')) { + emeta_inds <- revals$peakData2$e_meta %>% + select(getEDataColName(revals$peakData2)) %>% mutate(`__INCLUDE_EMETA__` = sapply(d$key, function(x) { - revals$peakData2$e_meta[[xvar_selected]] > as.numeric(x[1]) & + revals$peakData2$e_meta[[xvar_selected]] > as.numeric(x[1]) & revals$peakData2$e_meta[[xvar_selected]] <= as.numeric(x[2]) - }) %>% + }) %>% apply(1, any) ) - - selected_rows <- emeta_inds %>% - left_join(edata_inds) %>% - select(-one_of(getEDataColName(revals$peakData2))) %>% + + selected_rows <- emeta_inds %>% + left_join(edata_inds) %>% + select(-one_of(getEDataColName(revals$peakData2))) %>% apply(1, all) - - tmp_dat <- revals$peakData2$e_meta[selected_rows,] + + tmp_dat <- revals$peakData2$e_meta[selected_rows, ] } - - if(ptype_current == "Van Krevelen Plot"){ - p <- plots$linked_plots$right %>% - add_markers(x=~get(getOCRatioColName(revals$peakData2)), y=~get(getHCRatioColName(revals$peakData2)), data=tmp_dat, - marker=list(color="cyan"), name="Selected", inherit = F) + + if (ptype_current == "Van Krevelen Plot") { + p <- plots$linked_plots$right %>% + add_markers(x = ~ get(getOCRatioColName(revals$peakData2)), y = ~ get(getHCRatioColName(revals$peakData2)), data = tmp_dat, + marker = list(color = "cyan"), name = "Selected", inherit = F) } - else if(ptype_current == 'Kendrick Plot'){ - p <- plots$linked_plots$right %>% - add_markers(x=~get(getKendrickMassColName(revals$peakData2)), y=~get(getKendrickDefectColName(revals$peakData2)), data=tmp_dat, - marker=list(color="cyan"), name="Selected", inherit = F) + else if (ptype_current == 'Kendrick Plot') { + p <- plots$linked_plots$right %>% + add_markers(x = ~ get(getKendrickMassColName(revals$peakData2)), y = ~ get(getKendrickDefectColName(revals$peakData2)), data = tmp_dat, + marker = list(color = "cyan"), name = "Selected", inherit = F) } - else if(ptype_current == 'Custom Scatter Plot'){ + else if (ptype_current == 'Custom Scatter Plot') { yvar = linked_plots_table()[row2, 'Y Variable'] - - p <- plots$linked_plots$right %>% - add_markers(x=~get(xvar_current), y=~get(yvar), data=tmp_dat, - marker=list(color="cyan"), name="Selected", inherit = F) + + p <- plots$linked_plots$right %>% + add_markers(x = ~ get(xvar_current), y = ~ get(yvar), data = tmp_dat, + marker = list(color = "cyan"), name = "Selected", inherit = F) } - else if(ptype_current == 'Density Plot'){ + else if (ptype_current == 'Density Plot') { hist_dat <- attr(plots$linked_plots$right, 'hist_data') - + counts <- sapply(hist_dat$key, function(x) { - nrow( - tmp_dat %>% - filter( - !!rlang::sym(xvar_current) > x[1] & + nrow( + tmp_dat %>% + filter( + !!rlang::sym(xvar_current) > x[1] & !!rlang::sym(xvar_current) <= x[2] - ) - ) - }) - - density <- counts/sum(edata_inds$`__INCLUDE_EDATA__`)/hist_dat$barwidth - + ) + ) + }) + + density <- counts / sum(edata_inds$`__INCLUDE_EDATA__`) / hist_dat$barwidth + hist_dat$counts <- counts hist_dat$density <- density - - p <- plots$linked_plots$right %>% - add_bars(x=~x, y=~density, width=~barwidth, marker = list(color='cyan'), data = hist_dat) + + p <- plots$linked_plots$right %>% + add_bars(x = ~x, y = ~density, width = ~barwidth, marker = list(color = 'cyan'), data = hist_dat) } } - else{ + else { p <- plots$linked_plots$right } - + isolate({ plots$last_plot[[input$top_page]][['right']] <- list(p) names(plots$last_plot[[input$top_page]][['right']]) <- pname_current }) - + p }) }) diff --git a/tab_factories/upload_tab.R b/tab_factories/upload_tab.R index c6cf283..ef2d964 100644 --- a/tab_factories/upload_tab.R +++ b/tab_factories/upload_tab.R @@ -1,162 +1,162 @@ -#'@details Create the upload tab +#' @details Create the upload tab #' The upload tab can differ based on whether we are loading data from core-ms #' If we are loading from core-ms, then we have sub-tabs for processing the #' core-ms output. -#' +#' upload_tab <- function(from_corems = FALSE) { - if(from_corems) { - corems_tabs() + if (from_corems) { + corems_tabs() } else { tabPanel(div("Upload", icon('upload')), value = 'Upload', - fluidRow( - ## Sidebar panel on Upload tab ## - column(width = 4, - bsCollapse(id = 'upload_collapse', open = c('file_upload'), multiple = TRUE, - bsCollapsePanel(div('Upload two linked csv files', - hidden(div(id = 'ok_files', style = 'color:deepskyblue;float:right', icon('ok', lib='glyphicon') - ) - ) - ), value = 'file_upload', - - # Load e_data file - div(id = "js_file_edata", - fileInput("file_edata", "Upload Data File (.csv)", - multiple = TRUE, - accept = c("text/csv", - "text/comma-separated-values,text/plain", - ".csv")) - ), - - ## Get unique identifier column from e_data ## - uiOutput('edata_id'), - - # Load e_meta file - div(id = "js_file_emeta", fileInput("file_emeta", "Upload Molecular Identification File (.csv)", - multiple = TRUE, - accept = c("text/csv", - "text/comma-separated-values,text/plain", - ".csv"))) - ), - bsCollapsePanel(div('Specify data structure', - hidden(div(id = 'ok_idcols', style = 'color:deepskyblue;float:right', icon('ok', lib='glyphicon') - ) - ) - ), value = 'column_info', - # Get which instrument generated the data # - inlineCSS('#js_data_scale .filter-option{text-align:center;}'), - div(id = "js_data_scale", pickerInput('data_scale', - label = 'On what scale are your data?', - choices = list('Log base 2' = 'log2', 'Log base 10'='log10', 'Natural log'='log', - 'Presence/absence' = 'pres', 'Raw intensity'='abundance'), - selected = 'abundance' - ) - ), - div( - id = "js_NA_value", - uiOutput("NA_value_UI") - ), - - tags$hr(style = "margin:20px 0px 20px 0px"), - - # Get whether formulas or elemental columns are included # - div(id = "js_select", radioGroupButtons('select', - label = 'Does this file have formulas + fluidRow( + ## Sidebar panel on Upload tab ## + column(width = 4, + bsCollapse(id = 'upload_collapse', open = c('file_upload'), multiple = TRUE, + bsCollapsePanel(div('Upload two linked csv files', + hidden(div(id = 'ok_files', style = 'color:deepskyblue;float:right', icon('ok', lib = 'glyphicon') + ) + ) + ), value = 'file_upload', + + # Load e_data file + div(id = "js_file_edata", + fileInput("file_edata", "Upload Data File (.csv)", + multiple = TRUE, + accept = c("text/csv", + "text/comma-separated-values,text/plain", + ".csv")) + ), + + ## Get unique identifier column from e_data ## + uiOutput('edata_id'), + + # Load e_meta file + div(id = "js_file_emeta", fileInput("file_emeta", "Upload Molecular Identification File (.csv)", + multiple = TRUE, + accept = c("text/csv", + "text/comma-separated-values,text/plain", + ".csv"))) + ), + bsCollapsePanel(div('Specify data structure', + hidden(div(id = 'ok_idcols', style = 'color:deepskyblue;float:right', icon('ok', lib = 'glyphicon') + ) + ) + ), value = 'column_info', + # Get which instrument generated the data # + inlineCSS('#js_data_scale .filter-option{text-align:center;}'), + div(id = "js_data_scale", pickerInput('data_scale', + label = 'On what scale are your data?', + choices = list('Log base 2' = 'log2', 'Log base 10' = 'log10', 'Natural log' = 'log', + 'Presence/absence' = 'pres', 'Raw intensity' = 'abundance'), + selected = 'abundance' + ) + ), + div( + id = "js_NA_value", + uiOutput("NA_value_UI") + ), + + tags$hr(style = "margin:20px 0px 20px 0px"), + + # Get whether formulas or elemental columns are included # + div(id = "js_select", radioGroupButtons('select', + label = 'Does this file have formulas or elemental columns?', - choices = list('Formulas' = 1, - 'Elemental Columns' = 2), - selected = 'Select an option', justified = TRUE) - ), - - # (Conditional on the above selectInput) Formula: - ## which column contains the formula? # - conditionalPanel( - condition = "input.select == 1", - uiOutput('f_column') - ), - - # (Conditional on the above selectInput) Elemental columns: - ## which columns contain the elements? - - inlineCSS('#element_select button {width:100%}'), - hidden(div(id = "element_select", style = 'width:92.5%;margin-left:2.5%;border-radius:4px', - dropdownButton(inputId = "element_dropdown", circle = FALSE, label = "Specify Elemental Count Columns", width = '100%', - fluidRow( - column(width = 4, - uiOutput("c_column"), - uiOutput("h_column") - ), - column(width = 4, - uiOutput("n_column"), - uiOutput("o_column") - ), - column(width = 4, - uiOutput("s_column"), - uiOutput("p_column") - ) - ) - ) - )), #hidden div - - tags$hr(style = "margin:20px 0px 20px 0px"), - - # Create an option for Isotopic Analysis - div(id = "js_isotope_yn", radioGroupButtons('isotope_yn', - label = 'Were isotopic peaks identified in the molecular assignments file?', - choices = list('Yes' = 1, - 'No' = 2), - selected = 'Select an Option', justified = TRUE) - ), - # Condition on presence of isotope information - conditionalPanel( - condition = "input.isotope_yn == 1", - uiOutput("iso_info_filter_out"), - div(id = "js_iso_info_column", uiOutput('iso_info_column_out')), - div(id = "js_iso_symbol", uiOutput('iso_symbol_out')) - ) - ) - ), - tags$hr(), - - # Action button: pressing this creates the peakData object - div( - actionButton('upload_click', 'Process Data', icon = icon("cog"), lib = "glyphicon"), - hidden(div('Making data object, please wait...', id = 'upload_waiting', class='fadein-out', - style='font-weight:bold;color:deepskyblue;display:inline')) - ), - # Summary panel - hidden(div(id = 'upload_success', style = 'width:75%;margin-top:10px', - wellPanel(style='border-radius:4px', - # Show 'Success' message if peakData created successfully - uiOutput('success_upload'), - - # Number of peaks, samples, and peaks with formulas assigned - textOutput('num_peaks'), - textOutput('num_samples'), - textOutput('num_peaks_formula') - ) - )) - - ), # End sidebar panel - - column(width = 8, - # warnings panel - div(id = "warnings_upload", style = "overflow-y:auto;max-height:250px", uiOutput("warnings_upload_UI")), - - tags$hr(), - - # Show preview of e_data - htmlOutput('edata_text'), - DTOutput("head_edata", width = "90%"), - - tags$hr(), - - # Show preview of e_meta - htmlOutput('emeta_text'), - DTOutput("head_emeta", width = "90%") - - ) # End main panel - - )) + choices = list('Formulas' = 1, + 'Elemental Columns' = 2), + selected = 'Select an option', justified = TRUE) + ), + + # (Conditional on the above selectInput) Formula: + ## which column contains the formula? # + conditionalPanel( + condition = "input.select == 1", + uiOutput('f_column') + ), + + # (Conditional on the above selectInput) Elemental columns: + ## which columns contain the elements? + + inlineCSS('#element_select button {width:100%}'), + hidden(div(id = "element_select", style = 'width:92.5%;margin-left:2.5%;border-radius:4px', + dropdownButton(inputId = "element_dropdown", circle = FALSE, label = "Specify Elemental Count Columns", width = '100%', + fluidRow( + column(width = 4, + uiOutput("c_column"), + uiOutput("h_column") + ), + column(width = 4, + uiOutput("n_column"), + uiOutput("o_column") + ), + column(width = 4, + uiOutput("s_column"), + uiOutput("p_column") + ) + ) + ) + )), # hidden div + + tags$hr(style = "margin:20px 0px 20px 0px"), + + # Create an option for Isotopic Analysis + div(id = "js_isotope_yn", radioGroupButtons('isotope_yn', + label = 'Were isotopic peaks identified in the molecular assignments file?', + choices = list('Yes' = 1, + 'No' = 2), + selected = 'Select an Option', justified = TRUE) + ), + # Condition on presence of isotope information + conditionalPanel( + condition = "input.isotope_yn == 1", + uiOutput("iso_info_filter_out"), + div(id = "js_iso_info_column", uiOutput('iso_info_column_out')), + div(id = "js_iso_symbol", uiOutput('iso_symbol_out')) + ) + ) + ), + tags$hr(), + + # Action button: pressing this creates the peakData object + div( + actionButton('upload_click', 'Process Data', icon = icon("cog"), lib = "glyphicon"), + hidden(div('Making data object, please wait...', id = 'upload_waiting', class = 'fadein-out', + style = 'font-weight:bold;color:deepskyblue;display:inline')) + ), + # Summary panel + hidden(div(id = 'upload_success', style = 'width:75%;margin-top:10px', + wellPanel(style='border-radius:4px', + # Show 'Success' message if peakData created successfully + uiOutput('success_upload'), + + # Number of peaks, samples, and peaks with formulas assigned + textOutput('num_peaks'), + textOutput('num_samples'), + textOutput('num_peaks_formula') + ) + )) + + ), # End sidebar panel + + column(width = 8, + # warnings panel + div(id = "warnings_upload", style = "overflow-y:auto;max-height:250px", uiOutput("warnings_upload_UI")), + + tags$hr(), + + # Show preview of e_data + htmlOutput('edata_text'), + DTOutput("head_edata", width = "90%"), + + tags$hr(), + + # Show preview of e_meta + htmlOutput('emeta_text'), + DTOutput("head_emeta", width = "90%") + + ) # End main panel + + )) } } @@ -168,52 +168,52 @@ corems_tabs <- function() { fluidRow( ## Sidebar panel on Upload tab ## column(width = 4, - bsCollapse( - id = 'corems-upload-collapse', open = c("input_args"), multiple = TRUE, - bsCollapsePanel( - value = "input_args", - title = "Specify Column Names", - div(id = 'specify_colnames', - uiOutput("index_cname"), - uiOutput("obs_mass_cname"), - uiOutput("calc_mass_cname"), - uiOutput("pheight_cname"), - uiOutput("error_cname"), - uiOutput("conf_cname"), - uiOutput("file_cname"), - uiOutput("mono_index_cname"), - uiOutput("mf_cname"), - uiOutput("c13_cname"), - uiOutput("o18_cname"), - uiOutput("n15_cname"), - uiOutput("s34_cname") - ) # end div - ) # end Collapse Panel - ), # end bsCollapse - - shiny::actionButton("make_cmsdata", - "Create CoreMSData Object", - icon = icon("cog"), - lib = "glyphicon") + bsCollapse( + id = 'corems-upload-collapse', open = c("input_args"), multiple = TRUE, + bsCollapsePanel( + value = "input_args", + title = "Specify Column Names", + div(id = 'specify_colnames', + uiOutput("index_cname"), + uiOutput("obs_mass_cname"), + uiOutput("calc_mass_cname"), + uiOutput("pheight_cname"), + uiOutput("error_cname"), + uiOutput("conf_cname"), + uiOutput("file_cname"), + uiOutput("mono_index_cname"), + uiOutput("mf_cname"), + uiOutput("c13_cname"), + uiOutput("o18_cname"), + uiOutput("n15_cname"), + uiOutput("s34_cname") + ) # end div + ) # end Collapse Panel + ), # end bsCollapse + + shiny::actionButton("make_cmsdata", + "Create CoreMSData Object", + icon = icon("cog"), + lib = "glyphicon") ), # end sidebar column - - # main panel + + # main panel column(width = 8, - bsCollapse( - id = "corems-upload-summary-collapse", - open = c("corems-upload-table", "corems-upload-visualize"), - multiple = TRUE, - bsCollapsePanel( - title = "Table Summary", value = "corems-upload-table", - # keeps table compact on page, no line wrapping: - tags$head(tags$style("#raw_data {white-space: nowrap; }")), - DT::dataTableOutput("cms_raw_data") - ), - bsCollapsePanel( - title = "Plot Summary", value = "corems-upload-visualize", - withSpinner(plotlyOutput("cmsdat_plot"), color = "deepskyblue", type = 8) - ) - ) + bsCollapse( + id = "corems-upload-summary-collapse", + open = c("corems-upload-table", "corems-upload-visualize"), + multiple = TRUE, + bsCollapsePanel( + title = "Table Summary", value = "corems-upload-table", + # keeps table compact on page, no line wrapping: + tags$head(tags$style("#raw_data {white-space: nowrap; }")), + DT::dataTableOutput("cms_raw_data") + ), + bsCollapsePanel( + title = "Plot Summary", value = "corems-upload-visualize", + withSpinner(plotlyOutput("cmsdat_plot"), color = "deepskyblue", type = 8) + ) + ) ) # end main column ) # end fluidRow ), @@ -228,30 +228,30 @@ corems_tabs <- function() { bsCollapsePanel( title = "Select Confidence Threshold", value = "conf_thresh", - + sliderInput(inputId = "min_conf", - label = "Minimum confidence score:", - min = 0, - max = 1, - value = .5) + label = "Minimum confidence score:", + min = 0, + max = 1, + value = .5) ) # end collapse panel - ), # end collapse - - shiny::actionButton("apply_conf_filter", - "Filter Data", - icon = icon("cog"), - lib = "glyphicon"), - - shiny::actionButton("reset_filter", - "Reset Filter", - icon = icon("trash"), - lib = "glyphicon") - + ), # end collapse + + shiny::actionButton("apply_conf_filter", + "Filter Data", + icon = icon("cog"), + lib = "glyphicon"), + + shiny::actionButton("reset_filter", + "Reset Filter", + icon = icon("trash"), + lib = "glyphicon") + ), # end sidebar column - + column(width = 8, bsCollapse( - id = "corems-filter-summary-collapse", + id = "corems-filter-summary-collapse", open = c("table", "viz"), multiple = TRUE, bsCollapsePanel( "Table Summary", @@ -279,7 +279,7 @@ corems_tabs <- function() { ) # end main column ) # end fluidRow ), # end conf filter tabPanel - + ###################### Unique Formula Assingment Panel ###################### tabPanel( "Formula Assignment", @@ -288,20 +288,20 @@ corems_tabs <- function() { # sidebar column column(width = 4, bsCollapse(id = 'unq_mf_collapse', open = "unq_mf_assign", multiple = TRUE, - bsCollapsePanel(title = "Unique Molecular Formula Assignment", - value = "unq_mf_assign", - - selectInput("unq_mf_method", label = "Method:", - choices = c("Confidence score", "Peak height")) - ) # end collapse panel + bsCollapsePanel(title = "Unique Molecular Formula Assignment", + value = "unq_mf_assign", + + selectInput("unq_mf_method", label = "Method:", + choices = c("Confidence score", "Peak height")) + ) # end collapse panel ), # end collapse - shiny::actionButton("unique_mf", - "Assign Unique Formula", - icon = icon("cog"), - lib = "glyphicon") - + shiny::actionButton("unique_mf", + "Assign Unique Formula", + icon = icon("cog"), + lib = "glyphicon") + ), # end sidebar column - + # main column column(width = 8, bsCollapse( @@ -329,10 +329,10 @@ corems_tabs <- function() { "Visualizations", value = "viz", plotlyOutput("mf_plot") + ) ) - ) ) # close main column ), # close fluidrow ) # close unique mf tabPanel ) -} \ No newline at end of file +} diff --git a/ui.R b/ui.R index 9b0ff64..4f12b1b 100644 --- a/ui.R +++ b/ui.R @@ -1,568 +1,567 @@ # Define UI and wrap everything in a taglist that first calls useShinyjs() -ui <- tagList(useShinyjs(), - - # loading message - div( - id = "loading-gray-overlay", - class = "loading-mask", - div(class = "fadein-out busy relative-centered", style = "font-size:xx-large", "Loading app resources...") - ), - - navbarPage( - title = tags$div("FREDA", tags$span(style = "font-size:small", "v1.0.7")), - windowTitle = 'FREDA', - id = "top_page", - theme = "yeti.css", - ############# Welcome Panel ######################### - navbarMenu("Welcome", - tabPanel(title = "Introduction", class = "background_FTICR", - includeMarkdown("./Welcome to FREDA.md"), - h4(tags$b('Citing FREDA')), - tags$p('A publication is forthcoming for FREDA. In the meantime, we ask that you cite FREDA by url', tags$b('(https://msc-viz.emsl.pnnl.gov/FREDA/)'),'for any figures or analysis included in a publication or report.'), - hr(), - br(), - bsButton('all_tutorials', 'See a playlist of video tutorials', - onclick = "window.open('https://www.youtube.com/watch?v=uU5Q7r_pEGM&list=PLvozcBqO8i7wsMWo5PnOREX0sHSk3mAjE', '_blank')", - style = 'info', icon = icon('facetime-video', lib = 'glyphicon')) - ), - tabPanel(title = "Data Requirements", class = "background_FTICR", value = 'data_requirements', - includeMarkdown("./DataRequirements.md"), - downloadButton('downloadData', 'Download')), - tabPanel(title = "Resources/Contact", class = "background_FTICR", - includeMarkdown('resources_and_contact.md') - ) - ), - ################## Groups Panel ############################################### - tabPanel(div("Groups", icon('th-large', lib = 'glyphicon')), value = 'Groups', - fluidRow(style = "display:flex;flex-direction:row;align-items:stretch", - column(4, - wellPanel(style = "height:100%", - tags$h4("Define a Group"), - div(id = "js_group_name", textInput("group_name", "Name of this group:")), - fluidRow( - column(6, uiOutput("group_samples")), - column(6, textInput("group_regex", "Search sample names")) - ), - actionButton("add_group", "Add this group"), - br(), - br(), - uiOutput("warnings_groups") - ) - ), - column(8, - wellPanel(style = "height:100%", - dataTableOutput("group_table"), - actionButton("remove_group", "Remove selected group") - ) - ) - ), - hr(), - actionButton("goto_preprocess_main", "Continue to preprocess tab") - ), - ################## Preprocess Panel ############################################### - tabPanel(div("Preprocess", icon('cogs')), value = 'Preprocess', - - sidebarLayout( - - # Sidebar panel - sidebarPanel( - - div(class = "adjustdown",uiOutput("which_calcs")), - - # Action button: add test columns with results to peakData2 - div( - disabled(actionButton('preprocess_click', 'Process Data', icon = icon("cog"), lib = "glyphicon")), - hidden(div('Calculating values, please wait...', id = 'preprocess_waiting', - style = 'font-weight:bold;color:deepskyblue;display:inline', class = 'fadein-out')) - ), - br(), - uiOutput("warnings_preprocess") - ), # End sidebar panel - - mainPanel( - - # Set default main panel width - width = 8, - - # Include numeric and categorical summaries in a well panel - - wellPanel( - tags$div(class = "row", - tags$div(class = "col-sm-5", style = "height:350px;overflow-y:scroll;", - uiOutput("numeric_header"), - dataTableOutput('numeric_summary') - ), - tags$div(class = "col-sm-7", style = "height:350px;overflow-y:scroll;", - uiOutput("cat_header"), - uiOutput('categorical_summary') - - ) - - ) - ), - - # Drop down list: which histogram should be displayed? - uiOutput('which_hist_out'), - - # Plot: histogram - plotlyOutput('preprocess_hist') - - ) # End main panel on Preprocess tab # - - )), # End Preprocess tab # - - ##################### QUALITY CONTROL PANEL ########################### - tabPanel(div("Quality Control", icon('chart-bar')), value = 'Quality Control', - fluidRow(style = 'display:flex;flex-direction:row;align-items:stretch', - column(4, - wellPanel(style = 'height:100%', - uiOutput('qc_select_groups', style = "width:50%"), - hr(style='margin:2px'), - uiOutput('qc_plot_scale', style = "width:50%"), - textInput('qc_boxplot_xlab', "X axis label"), - textInput('qc_boxplot_ylab', 'Y axis label'), - textInput('qc_boxplot_title', 'Title'), - actionButton('update_boxplot_axes', "Update Boxplot Axes"), - br(), br(), - uiOutput('warnings_qc') - ) - ), - column(8, - wellPanel(style = 'height:100%', - div(id='style_qc_boxplots', style='border-style:solid;border-width:1px;padding-top:5px', - plotlyOutput("qc_boxplots") %>% withSpinner(color = "orange", type = 8) - ) - ) - ) - ), - hr(), - actionButton('goto_filter_fromqc', "Continue to the filter tab") - ), +ui <- tagList(useShinyjs(), + + # loading message + div( + id = "loading-gray-overlay", + class = "loading-mask", + div(class = "fadein-out busy relative-centered", style = "font-size:xx-large", "Loading app resources...") + ), - ################## Filter Panel ############################################## - tabPanel(div("Filter", icon('filter')), value = 'Filter', - - sidebarLayout( - sidebarPanel( - - # Set default width for panel - width = 5, - - # Checkbox: Mass filter yes/no - bsCollapse(id = 'filter_sidebar', - open = c('samplefilt_collapse', 'massfilt_collapse', 'formfilt_collapse', 'molfilt_collapse'), - multiple = TRUE, - bsCollapsePanel(div('Sample Filter', - div(style = "color:deepskyblue;display:inline-block", - tipify(icon("question-sign", lib = "glyphicon"), - title = "Retain a subset of all samples", - placement = "top", trigger = 'hover') - ), - div(style = 'float:right', uiOutput('samplefilter_icon')) - ), value = 'samplefilt_collapse', - div(class="adjustdown", - checkboxInput('samplefilter', tags$b("Apply this filter, keeping only the following samples:", style = "display:inline-block"), value = FALSE) - ), - - div(id = "js_filter_samples", - uiOutput("filter_samples") - ), - textInput('filter_regex', 'Search sample names') - ), - bsCollapsePanel(div('Mass Filter', - div(style = "color:deepskyblue;display:inline-block", - tipify(icon("question-sign", lib = "glyphicon"), - title = "Retain peaks within a mass range specified below", - placement = "top", trigger = 'hover') - ), - div(style = 'float:right', uiOutput('massfilter_icon')) - ), value = 'massfilt_collapse', - div(class="adjustdown", checkboxInput('massfilter', tags$b("Apply this filter, removing peaks outside the mass range:", style = "display:inline-block"), value = FALSE) - ), - - # Numeric: Min/max mass filter - splitLayout( - numericInput('min_mass', 'Minimum Mass value', - min = 0, value = 200), - numericInput('max_mass', "Maximum Mass value", - min = 0, value = 900) - ) - ), - - bsCollapsePanel(div('Molecule Filter', - div(style = "color:deepskyblue;display:inline-block", - tipify(icon("question-sign", lib = "glyphicon"), - title = "Retain peaks that are observed in a minimum number of samples, specified below", - placement = "top", trigger = 'hover') - ), - div(style = 'float:right', uiOutput('molfilter_icon')) - ), - value = 'molfilt_collapse', - # Checkbox: Mass filter yes/no - div(class = "adjustdown", checkboxInput('molfilter', tags$b("Apply this filter, removing peaks with too few observations: ", style = "display:inline-block"), value = FALSE) - ), - # Drop-down list: Min/max mass filter - uiOutput('minobs') - ), - bsCollapsePanel(div('Formula Presence Filter', - div(style = "color:deepskyblue;display:inline-block", - tipify(icon("question-sign", lib = "glyphicon"), - title = "Retain peaks that have a molecular formula specified or calculated from elemental values", - placement = "top", trigger = 'hover') - ), - div(style = 'float:right', uiOutput('formfilter_icon')) - ), - value = 'formfilt_collapse', - div(class = "adjustdown", checkboxInput('formfilter', tags$b("Apply this filter, removing peaks without a molecular formula", style = "display:inline-block"), value = FALSE) - ) - ), - - bsCollapsePanel(div('Implement up to 3 custom filters', - div(style = "color:deepskyblue;display:inline-block", - tipify(icon("question-sign", lib = "glyphicon"), - title = "Filter based on up to 3 variables in the post-processed molecular identification file", - placement = "top", trigger = 'hover') - ), - div(style = 'float:right', uiOutput('customfilter_icon')) - ), - value = 'customfilt_collapse', - div(class = "adjustdown", checkboxInput('customfilterz', tags$b("Show dropdowns and apply all specified filters", style = "display:inline-block"), value = FALSE) - ), - - conditionalPanel(id = "custom_cond_panel", condition = "input.customfilterz == true", - uiOutput("filter1UI"), - uiOutput("customfilter1UI"), - uiOutput("filter2UI"), - uiOutput("customfilter2UI"), - uiOutput("filter3UI"), - uiOutput("customfilter3UI") - ) - ) - ), # end collapse panel - hr(), - - disabled( - fluidRow( - column( - width = 6, actionButton('filter_click', "Filter Data", icon = icon("cog", lib = "glyphicon")) - ), - column( - width = 6, actionButton('reset_filters', "Reset Filters", icon = icon("trash", lib = "glyphicon")) - ) - ) - ), - - br(), - br(), - - div(id = "warnings_filter", style = "overflow-y:auto;max-height:150px", uiOutput("warnings_filter_UI")) - - ), # End sidebar panel on Filter tab - - mainPanel( - - # Set default width for panel - width = 7, - - # waiting messages for large data during filtering and plot calculation - hidden(div('Applying your filters, please wait...', id = 'calc_filter', class = 'fadein-out', - style = 'color:deepskyblue;font-weight:bold;margin-bottom:5px')), - hidden(div('Drawing your plot, please wait...', id = 'draw_large_filter_plot', class = 'fadein-out', - style = 'color:deepskyblue;font-weight:bold;margin-bottom:5px')), - - # Summary panel: display summary of filters - wellPanel( - tableOutput('summary_filter') - ), - - # Plot: Show number of peaks before/after filters applied - plotOutput('barplot_filter') - ) # End main panel on Filter tab - - )), # End Filter tab - - ################## Visualize Panel ############################################### - navbarMenu(div('Visualize', icon('eye-open', lib = 'glyphicon'), style = 'display:inline-block'), - # Main plot creation sub-panel - tabPanel(div("Create Plots"), value = 'Visualize', - - fluidRow( - # Sidebar Panel - div(id='viz_sidebar_column', column(4, - - # Begin collapsible section - bsCollapse(id='viz_sidebar', open = c('peakplots', 'axlabs'), multiple=TRUE, - - # Plot Parameters - bsCollapsePanel(div('Construct a plot', div(style = 'float:right', uiOutput('chooseplots_icon'))), value = 'peakplots', - # Select Plot Type - inlineCSS("#chooseplots .btn{font-size:10.5pt;} #chooseplots .btn-group-container-sw{display:block;}" ), - uiOutput('plot_type', style = "margin-top:-10px"), - - # Select samples/groups - uiOutput('plotUI'), - - uiOutput('pcoa_dist'), - - uiOutput('viztab_select_groups'), - - # Single dropdown for 1 sample/group or.... - hidden(div(id = "js_toggle_single", uiOutput("plotUI_single"))), - - # ...two dropdowns and extra options for group comparison - hidden(div(id = "js_toggle_groups", - tagList(div(id = "js_whichGroups1", uiOutput("plotUI_comparison_1")), - div(id = "js_whichGroups2", uiOutput("plotUI_comparison_2")) - ) - ) - ), - - hidden(div(id = 'js_summary_fxn', uiOutput("summary_fxn_out", class = "adjustdown") - ) - ) - - ), - # Axes Options - bsCollapsePanel(div('Axes labels', div(style = 'float:right', uiOutput('axlabs_icon'))), value = 'axlabs', - splitLayout( - uiOutput("title_out"), - tags$div(id = "js_legend_title_input", uiOutput("legend_title_out")) - ), - splitLayout( - uiOutput("x_axis_out"), - uiOutput("y_axis_out") - ) - ), - - bsCollapsePanel(div('Coloring/Appearance', div(style = 'float:right', uiOutput('dynamic_opts_icon'))), value = 'reactive_plot_opts', - # plot options - wellPanel( - # color and van-krevelen bounds dropdowns - fluidRow( - column(width = 6, class = "grey_out", id = "js_vk_colors", - disabled(selectInput("vk_colors", "Color by:", choices = NULL, selected = NULL)) - ), - column(width = 6, class = "grey_out", id = "js_vkbounds", - disabled(selectInput('vkbounds', 'Van Krevelen boundary set:', - choices = c('BS1' = 'bs1', 'BS2' = 'bs2', 'None' = 0), - selected = 0)) - ) - ), - - # x and y axis variable dropdowns for custom scatter plot - fluidRow( - column(width = 6, class = "grey_out", id = "js_scatter_x", - disabled(selectInput("scatter_x", "Horizontal axis variable:", choices = NULL, selected = NULL)) - ), - column(width = 6, class = "grey_out", id = "js_scatter_y", - disabled(selectInput("scatter_y", "Vertical axis variable:", choices = NULL, selected = NULL)) - ) - ), - - # color pallete options and button to flip colorscale direction - fluidRow( - column(6, - tags$div(id = "js_colorpal", uiOutput("colorpal_out"), style = "display:inline-block"), - actionButton("flip_colors", "Invert color scale") - ) - ) - ) - ) - ) - )),# End sidebar conditionals on Visualize tab # - - # Plot panel and generate plot buttons - column(8, - inlineCSS("#FxnPlot {width:inherit;}"), - wellPanel(style = "margin-top:-10px", - div(class = 'plot_border', style = "width:65%", - plotlyOutput('FxnPlot', width = 'auto', height = '600px') %>% - withSpinner(color = "orange", type = 8) - ), - # Separate buttons to generate plot or simply update labels without recalculating data - disabled( - div(style = 'display:inline-block;margin-top:10px', - bsButton("plot_submit", label = "Generate Plot", icon = icon("plus"), lib = "glyphicon"), - bsButton("update_axes", label = "Update Labels", icon = icon("refresh"), lib = "glyphicon"), - hidden(bsButton('make_goto_linked', label = 'Compare in Linked Plots', icon = icon('link'))) - ) - ), - - br(), - br(), - - div(id = "warnings_visualize", style = "overflow-y:auto;max-height:150px", uiOutput("warnings_visualize_UI")) - ), - )# End main panel on Visualize tab # - )# end fluidrow - ), - - # Linked plots sub-panel - tabPanel('Linked Plots', value = 'Linked Plots', - bsCollapse(id = 'linked_plots_collapse', open = c('lp_select_plots'), multiple = TRUE, - bsCollapsePanel(title = 'Choose Two Plots to Compare', value = 'lp_select_plots', - tags$i(info_text[['VALID_LINKED_PLOTS']]), - tags$hr(), - DTOutput('lp_plot_table'), - bsButton('lp_compare_plots', 'Compare These Plots')), - # bsCollapsePanel(title = 'Create A Linked Plot', value = 'lp_create_plot', - # DTOutput('lp_plot_table'), - # bsButton('lp_create_plot', 'Create and Compare With Selected Plot')), - bsCollapsePanel(title = 'View and Interact', value = 'lp_mainpanel', - splitLayout(cellArgs = list(class = 'plot_border'), - withSpinner(plotlyOutput('lp_left', height = '600px'), color = 'orange', type = 8), - withSpinner(plotlyOutput('lp_right', height = '600px'), color = 'orange', type = 8) - ) - ) - - ) - ) - ),# End Visualize tab # - - ################## Database Mapping Panel #################### - tabPanel(div('Database Mapping', icon('th-list', lib = 'glyphicon')), value = 'Database Mapping', - fluidRow(style = "display:flex;flex-direction:row;align-items:stretch", - column(4, - bsCollapse(id='db_mapping_sidebar', open = c('mappings'), multiple=TRUE, - bsCollapsePanel('Choose which mappings to calculate', value = 'mappings', - radioGroupButtons('database_select', label = "Choose a Database", choices = c('Kegg', 'MetaCyc')), - numericInput('max_records_database', 'Exclude formulae that map to more than this many records:', value = 5), - checkboxGroupButtons('which_mappings', label = "Include which variables in mapping:", - choices = c('Reactions' = 'comp2react', 'Modules' = 'react2mod', 'Pathways' = 'mod2path')), - hr(), - tags$p('Make unique rows for which variable?'), - div( - div(style='display:inline-block', - uiOutput('which_unique') - ), - bsButton('create_mapping', 'Perform Mapping', style = 'info') - ), - uiOutput('warnings_database') - ) - ) - ),# column 4 - column(8, - bsCollapse(id = 'database_tables_parent_collapse', open = 'database_tables', multiple = TRUE, - bsCollapsePanel('Table Preview', value = 'database_tables', - span(id = "toggle_table", - div(style = 'display:inline-block;margin-top:10px;margin-right:10px;font-weight:bold', "Display results:"), - div(style = 'display:inline-block', radioGroupButtons('which_table', choices = c('Kegg'=1, 'MetaCyc'=2))), - div(style = 'display:inline-block', bsButton('save_db_table', 'Save current table', style = 'info')), - div(style = 'display:inline-block', bsButton('view_db_tables', uiOutput('n_saved_db_tables'), style = 'info')) - - ), - uiOutput('conditional_database_table') - ), - bsCollapsePanel('Summary Counts', value = 'database_plots', - DTOutput('mapping_summary'), - uiOutput('conditional_database_barplot') - # splitLayout(plotlyOutput('kegg_barplot'), - # plotlyOutput('mc_barplot')) - ) - )# parent collapse - ) # column 8 - )#fluidrow - ),#tabpanel - - ################## Download Panel ############################################## - tabPanel(div('Download', icon('download')), value = 'Download', - fluidRow(style = "display:flex;flex-direction:row;align-items:stretch", - column(width = 6, - wellPanel(style = "height:100%", - tags$h4(icon("table", "fa-2x"), tags$b("Processed Data")), - checkboxGroupInput("download_selection", label = "Check Download Selection", - choices = c('Data File as one .csv and Molecular Identification File as another .csv' = "separate", - 'Merged Data File and Molecular Identification File as a single .csv' = "merged", - 'Data summaries for grouped plots' = "group_data"), - width = "80%") - ) - ), - column(width = 5, - wellPanel(style = "height:100%", - tags$h4(icon("align-left", "fa-2x"), tags$b("Summary Report and Database Mapping Tables")), - checkboxInput("report_selection", label = "Download a summary of preprocessing and filtering", value = TRUE), - checkboxInput("download_mappings", label = "Download Database Mapping Tables", value = FALSE) - ) - ) - ), - fluidRow(style = "margin-top:10px", - column(width = 11, - wellPanel( - div(style='display:flex', - column(width = 5, - tags$h4(icon("image", "fa-2x"), tags$b("Figures")), - tags$h5(tags$b("Select figures by row. When clicked, the download selection will highlight.")), - DTOutput("download_plot_table") - ), - column(width = 7, - div(style = 'height:100%', class = 'plot_border', uiOutput('download_plot')) - ) - ), - hr(), - br(), - div(style = 'display:flex', - div(style = 'float:left;width:50%;margin-left:10px', - bsButton('mark_plot_download', 'Select/de-select for download', icon = icon('minus')), - bsButton('remove_plot_download', 'Remove selected plot', icon = icon('remove')) - ), - div(style='float:right;width:50%', class='spaced_flexbox', - inlineCSS('[id=download_dimensions] > .shiny-input-container {width:49%;display:inline-block;}'), - div(id = 'download_dimensions', - numericInput('download_img_width', 'Download width', value = 1600, min=100, max=2000, step = 1), - numericInput('download_img_height', 'Download height', value = 900, min=100, max=2000, step = 1) - ), - radioButtons(inputId = "image_format", label = "Select an image format", - choices = c( "png", "pdf", "jpeg"), selected = "png", inline = TRUE) - ) - ), - uiOutput('warnings_download') - ) - ) - ), - div(style = 'width:75%', - actionButton('makezipfile', label = tags$b('Bundle up all selected items'), icon = icon("briefcase"), lib = "glyphicon", style = 'width:45%'), - disabled(downloadButton('download_processed_data', tags$b('Download bundle'), style = 'width:45%;float:right')) - ), - tags$br() - - ), - - ################## Glossary Panel ############################################## - tabPanel(div('Glossary', icon('question-sign', lib = 'glyphicon')), value = 'Glossary', - #mainPanel( - #includeHTML("./README/Glossary.html") - withMathJax(includeMarkdown("./README/Glossary.md")) - # ) - - ) + navbarPage( + title = tags$div("FREDA", tags$span(style = "font-size:small", "v1.0.7")), + windowTitle = 'FREDA', + id = "top_page", + theme = "yeti.css", + ############# Welcome Panel ######################### + navbarMenu("Welcome", + tabPanel(title = "Introduction", class = "background_FTICR", + includeMarkdown("./Welcome to FREDA.md"), + h4(tags$b('Citing FREDA')), + tags$p('A publication is forthcoming for FREDA. In the meantime, we ask that you cite FREDA by url', tags$b('(https://msc-viz.emsl.pnnl.gov/FREDA/)'), 'for any figures or analysis included in a publication or report.'), + hr(), + br(), + bsButton('all_tutorials', 'See a playlist of video tutorials', + onclick = "window.open('https://www.youtube.com/watch?v=uU5Q7r_pEGM&list=PLvozcBqO8i7wsMWo5PnOREX0sHSk3mAjE', '_blank')", + style = 'info', icon = icon('facetime-video', lib = 'glyphicon')) + ), + tabPanel(title = "Data Requirements", class = "background_FTICR", value = 'data_requirements', + includeMarkdown("./DataRequirements.md"), + downloadButton('downloadData', 'Download')), + tabPanel(title = "Resources/Contact", class = "background_FTICR", + includeMarkdown('resources_and_contact.md') + ) ), - - hidden(div(id = "corems_to_peakdata_toggle", style = "position:fixed;left:15px;bottom:15px", uiOutput("corems_to_peakdata_UI"))), - - div(id = "js_helpbutton", style = "position:absolute;top:3px;right:16px;z-index:1000;width:11%", - div(style = 'float:right;width:25%', - tipify( - hidden(bsButton("helpbutton", icon("question-sign", lib = "glyphicon", style = "color:white"), style = "info")), - ttip_text[['page_help']] - ) + ################## Groups Panel ############################################### + tabPanel(div("Groups", icon('th-large', lib = 'glyphicon')), value = 'Groups', + fluidRow(style = "display:flex;flex-direction:row;align-items:stretch", + column(4, + wellPanel(style = "height:100%", + tags$h4("Define a Group"), + div(id = "js_group_name", textInput("group_name", "Name of this group:")), + fluidRow( + column(6, uiOutput("group_samples")), + column(6, textInput("group_regex", "Search sample names")) + ), + actionButton("add_group", "Add this group"), + br(), + br(), + uiOutput("warnings_groups") + ) + ), + column(8, + wellPanel(style = "height:100%", + dataTableOutput("group_table"), + actionButton("remove_group", "Remove selected group") + ) + ) + ), + hr(), + actionButton("goto_preprocess_main", "Continue to preprocess tab") + ), + ################## Preprocess Panel ############################################### + tabPanel(div("Preprocess", icon('cogs')), value = 'Preprocess', + + sidebarLayout( + + # Sidebar panel + sidebarPanel( + + div(class = "adjustdown", uiOutput("which_calcs")), + + # Action button: add test columns with results to peakData2 + div( + disabled(actionButton('preprocess_click', 'Process Data', icon = icon("cog"), lib = "glyphicon")), + hidden(div('Calculating values, please wait...', id = 'preprocess_waiting', + style = 'font-weight:bold;color:deepskyblue;display:inline', class = 'fadein-out')) ), - div(style = 'float:right;width:50%%;margin-left:1px;margin-right:1px', - tipify( - hidden(bsButton("viewplots", uiOutput('viewplots_label', style = 'float:left;margin-right:10px'), style = "info", icon = icon("folder-open", lib = "glyphicon"))), - ttip_text[['plot_review']] + br(), + uiOutput("warnings_preprocess") + ), # End sidebar panel + + mainPanel( + + # Set default main panel width + width = 8, + + # Include numeric and categorical summaries in a well panel + + wellPanel( + tags$div(class = "row", + tags$div(class = "col-sm-5", style = "height:350px;overflow-y:scroll;", + uiOutput("numeric_header"), + dataTableOutput('numeric_summary') + ), + tags$div(class = "col-sm-7", style = "height:350px;overflow-y:scroll;", + uiOutput("cat_header"), + uiOutput('categorical_summary') + ) + + ) ), - div(style = 'float:right;width:25%', - tipify( - hidden(bsButton("saveplot", icon("save", lib = "glyphicon"), style = "info")), - ttip_text[['plot_save']] + + # Drop down list: which histogram should be displayed? + uiOutput('which_hist_out'), + + # Plot: histogram + plotlyOutput('preprocess_hist') + + ) # End main panel on Preprocess tab # + + )), # End Preprocess tab # + + ##################### QUALITY CONTROL PANEL ########################### + tabPanel(div("Quality Control", icon('chart-bar')), value = 'Quality Control', + fluidRow(style = 'display:flex;flex-direction:row;align-items:stretch', + column(4, + wellPanel(style = 'height:100%', + uiOutput('qc_select_groups', style = "width:50%"), + hr(style = 'margin:2px'), + uiOutput('qc_plot_scale', style = "width:50%"), + textInput('qc_boxplot_xlab', "X axis label"), + textInput('qc_boxplot_ylab', 'Y axis label'), + textInput('qc_boxplot_title', 'Title'), + actionButton('update_boxplot_axes', "Update Boxplot Axes"), + br(), br(), + uiOutput('warnings_qc') + ) + ), + column(8, + wellPanel(style = 'height:100%', + div(id = 'style_qc_boxplots', style = 'border-style:solid;border-width:1px;padding-top:5px', + plotlyOutput("qc_boxplots") %>% withSpinner(color = "orange", type = 8) + ) + ) + ) + ), + hr(), + actionButton('goto_filter_fromqc', "Continue to the filter tab") + ), + + ################## Filter Panel ############################################## + tabPanel(div("Filter", icon('filter')), value = 'Filter', + + sidebarLayout( + sidebarPanel( + + # Set default width for panel + width = 5, + + # Checkbox: Mass filter yes/no + bsCollapse(id = 'filter_sidebar', + open = c('samplefilt_collapse', 'massfilt_collapse', 'formfilt_collapse', 'molfilt_collapse'), + multiple = TRUE, + bsCollapsePanel(div('Sample Filter', + div(style = "color:deepskyblue;display:inline-block", + tipify(icon("question-sign", lib = "glyphicon"), + title = "Retain a subset of all samples", + placement = "top", trigger = 'hover') + ), + div(style = 'float:right', uiOutput('samplefilter_icon')) + ), value = 'samplefilt_collapse', + div(class = "adjustdown", + checkboxInput('samplefilter', tags$b("Apply this filter, keeping only the following samples:", style = "display:inline-block"), value = FALSE) + ), + + div(id = "js_filter_samples", + uiOutput("filter_samples") + ), + textInput('filter_regex', 'Search sample names') + ), + bsCollapsePanel(div('Mass Filter', + div(style = "color:deepskyblue;display:inline-block", + tipify(icon("question-sign", lib = "glyphicon"), + title = "Retain peaks within a mass range specified below", + placement = "top", trigger = 'hover') + ), + div(style = 'float:right', uiOutput('massfilter_icon')) + ), value = 'massfilt_collapse', + div(class = "adjustdown", checkboxInput('massfilter', tags$b("Apply this filter, removing peaks outside the mass range:", style = "display:inline-block"), value = FALSE) + ), + + # Numeric: Min/max mass filter + splitLayout( + numericInput('min_mass', 'Minimum Mass value', + min = 0, value = 200), + numericInput('max_mass', "Maximum Mass value", + min = 0, value = 900) + ) + ), + + bsCollapsePanel(div('Molecule Filter', + div(style = "color:deepskyblue;display:inline-block", + tipify(icon("question-sign", lib = "glyphicon"), + title = "Retain peaks that are observed in a minimum number of samples, specified below", + placement = "top", trigger = 'hover') + ), + div(style = 'float:right', uiOutput('molfilter_icon')) + ), + value = 'molfilt_collapse', + # Checkbox: Mass filter yes/no + div(class = "adjustdown", checkboxInput('molfilter', tags$b("Apply this filter, removing peaks with too few observations: ", style = "display:inline-block"), value = FALSE) + ), + # Drop-down list: Min/max mass filter + uiOutput('minobs') + ), + bsCollapsePanel(div('Formula Presence Filter', + div(style = "color:deepskyblue;display:inline-block", + tipify(icon("question-sign", lib = "glyphicon"), + title = "Retain peaks that have a molecular formula specified or calculated from elemental values", + placement = "top", trigger = 'hover') + ), + div(style = 'float:right', uiOutput('formfilter_icon')) + ), + value = 'formfilt_collapse', + div(class = "adjustdown", checkboxInput('formfilter', tags$b("Apply this filter, removing peaks without a molecular formula", style = "display:inline-block"), value = FALSE) + ) + ), + + bsCollapsePanel(div('Implement up to 3 custom filters', + div(style = "color:deepskyblue;display:inline-block", + tipify(icon("question-sign", lib = "glyphicon"), + title = "Filter based on up to 3 variables in the post-processed molecular identification file", + placement = "top", trigger = 'hover') + ), + div(style = 'float:right', uiOutput('customfilter_icon')) + ), + value = 'customfilt_collapse', + div(class = "adjustdown", checkboxInput('customfilterz', tags$b("Show dropdowns and apply all specified filters", style = "display:inline-block"), value = FALSE) + ), + + conditionalPanel(id = "custom_cond_panel", condition = "input.customfilterz == true", + uiOutput("filter1UI"), + uiOutput("customfilter1UI"), + uiOutput("filter2UI"), + uiOutput("customfilter2UI"), + uiOutput("filter3UI"), + uiOutput("customfilter3UI") + ) + ) + ), # end collapse panel + hr(), + + disabled( + fluidRow( + column( + width = 6, actionButton('filter_click', "Filter Data", icon = icon("cog", lib = "glyphicon")) + ), + column( + width = 6, actionButton('reset_filters', "Reset Filters", icon = icon("trash", lib = "glyphicon")) + ) ) ), - hidden(bsButton('datareqs_video', 'Data requirements tutorial', - onclick = "window.open('https://youtu.be/uU5Q7r_pEGM', '_blank')", - style = 'info', icon = icon('facetime-video', lib = 'glyphicon'))), + + br(), + br(), + + div(id = "warnings_filter", style = "overflow-y:auto;max-height:150px", uiOutput("warnings_filter_UI")) + + ), # End sidebar panel on Filter tab + + mainPanel( + + # Set default width for panel + width = 7, + + # waiting messages for large data during filtering and plot calculation + hidden(div('Applying your filters, please wait...', id = 'calc_filter', class = 'fadein-out', + style = 'color:deepskyblue;font-weight:bold;margin-bottom:5px')), + hidden(div('Drawing your plot, please wait...', id = 'draw_large_filter_plot', class = 'fadein-out', + style = 'color:deepskyblue;font-weight:bold;margin-bottom:5px')), + + # Summary panel: display summary of filters + wellPanel( + tableOutput('summary_filter') + ), + + # Plot: Show number of peaks before/after filters applied + plotOutput('barplot_filter') + ) # End main panel on Filter tab + + )), # End Filter tab + + ################## Visualize Panel ############################################### + navbarMenu(div('Visualize', icon('eye-open', lib = 'glyphicon'), style = 'display:inline-block'), + # Main plot creation sub-panel + tabPanel(div("Create Plots"), value = 'Visualize', + + fluidRow( + # Sidebar Panel + div(id = 'viz_sidebar_column', column(4, + + # Begin collapsible section + bsCollapse(id = 'viz_sidebar', open = c('peakplots', 'axlabs'), multiple = TRUE, + + # Plot Parameters + bsCollapsePanel(div('Construct a plot', div(style = 'float:right', uiOutput('chooseplots_icon'))), value = 'peakplots', + # Select Plot Type + inlineCSS("#chooseplots .btn{font-size:10.5pt;} #chooseplots .btn-group-container-sw{display:block;}"), + uiOutput('plot_type', style = "margin-top:-10px"), + + # Select samples/groups + uiOutput('plotUI'), + + uiOutput('pcoa_dist'), + + uiOutput('viztab_select_groups'), + + # Single dropdown for 1 sample/group or.... + hidden(div(id = "js_toggle_single", uiOutput("plotUI_single"))), + + # ...two dropdowns and extra options for group comparison + hidden(div(id = "js_toggle_groups", + tagList(div(id = "js_whichGroups1", uiOutput("plotUI_comparison_1")), + div(id = "js_whichGroups2", uiOutput("plotUI_comparison_2")) + ) + ) + ), + + hidden(div(id = 'js_summary_fxn', uiOutput("summary_fxn_out", class = "adjustdown") + ) + ) + + ), + # Axes Options + bsCollapsePanel(div('Axes labels', div(style = 'float:right', uiOutput('axlabs_icon'))), value = 'axlabs', + splitLayout( + uiOutput("title_out"), + tags$div(id = "js_legend_title_input", uiOutput("legend_title_out")) + ), + splitLayout( + uiOutput("x_axis_out"), + uiOutput("y_axis_out") + ) + ), + + bsCollapsePanel(div('Coloring/Appearance', div(style = 'float:right', uiOutput('dynamic_opts_icon'))), value = 'reactive_plot_opts', + # plot options + wellPanel( + # color and van-krevelen bounds dropdowns + fluidRow( + column(width = 6, class = "grey_out", id = "js_vk_colors", + disabled(selectInput("vk_colors", "Color by:", choices = NULL, selected = NULL)) + ), + column(width = 6, class = "grey_out", id = "js_vkbounds", + disabled(selectInput('vkbounds', 'Van Krevelen boundary set:', + choices = c('BS1' = 'bs1', 'BS2' = 'bs2', 'None' = 0), + selected = 0)) + ) + ), + + # x and y axis variable dropdowns for custom scatter plot + fluidRow( + column(width = 6, class = "grey_out", id = "js_scatter_x", + disabled(selectInput("scatter_x", "Horizontal axis variable:", choices = NULL, selected = NULL)) + ), + column(width = 6, class = "grey_out", id = "js_scatter_y", + disabled(selectInput("scatter_y", "Vertical axis variable:", choices = NULL, selected = NULL)) + ) + ), + + # color pallete options and button to flip colorscale direction + fluidRow( + column(6, + tags$div(id = "js_colorpal", uiOutput("colorpal_out"), style = "display:inline-block"), + actionButton("flip_colors", "Invert color scale") + ) + ) + ) + ) + ) + )), # End sidebar conditionals on Visualize tab # + + # Plot panel and generate plot buttons + column(8, + inlineCSS("#FxnPlot {width:inherit;}"), + wellPanel(style = "margin-top:-10px", + div(class = 'plot_border', style = "width:65%", + plotlyOutput('FxnPlot', width = 'auto', height = '600px') %>% + withSpinner(color = "orange", type = 8) + ), + # Separate buttons to generate plot or simply update labels without recalculating data + disabled( + div(style = 'display:inline-block;margin-top:10px', + bsButton("plot_submit", label = "Generate Plot", icon = icon("plus"), lib = "glyphicon"), + bsButton("update_axes", label = "Update Labels", icon = icon("refresh"), lib = "glyphicon"), + hidden(bsButton('make_goto_linked', label = 'Compare in Linked Plots', icon = icon('link'))) + ) + ), + + br(), + br(), + + div(id = "warnings_visualize", style = "overflow-y:auto;max-height:150px", uiOutput("warnings_visualize")) + ), + ) # End main panel on Visualize tab # + ) # end fluidrow + ), + + # Linked plots sub-panel + tabPanel('Linked Plots', value = 'Linked Plots', + bsCollapse(id = 'linked_plots_collapse', open = c('lp_select_plots'), multiple = TRUE, + bsCollapsePanel(title = 'Choose Two Plots to Compare', value = 'lp_select_plots', + tags$i(info_text[['VALID_LINKED_PLOTS']]), + tags$hr(), + DTOutput('lp_plot_table'), + bsButton('lp_compare_plots', 'Compare These Plots')), + # bsCollapsePanel(title = 'Create A Linked Plot', value = 'lp_create_plot', + # DTOutput('lp_plot_table'), + # bsButton('lp_create_plot', 'Create and Compare With Selected Plot')), + bsCollapsePanel(title = 'View and Interact', value = 'lp_mainpanel', + splitLayout(cellArgs = list(class = 'plot_border'), + withSpinner(plotlyOutput('lp_left', height = '600px'), color = 'orange', type = 8), + withSpinner(plotlyOutput('lp_right', height = '600px'), color = 'orange', type = 8) + ) + ) + + ) + ) + ), # End Visualize tab # + + ################## Database Mapping Panel #################### + tabPanel(div('Database Mapping', icon('th-list', lib = 'glyphicon')), value = 'Database Mapping', + fluidRow(style = "display:flex;flex-direction:row;align-items:stretch", + column(4, + bsCollapse(id = 'db_mapping_sidebar', open = c('mappings'), multiple = TRUE, + bsCollapsePanel('Choose which mappings to calculate', value = 'mappings', + radioGroupButtons('database_select', label = "Choose a Database", choices = c('Kegg', 'MetaCyc')), + numericInput('max_records_database', 'Exclude formulae that map to more than this many records:', value = 5), + checkboxGroupButtons('which_mappings', label = "Include which variables in mapping:", + choices = c('Reactions' = 'comp2react', 'Modules' = 'react2mod', 'Pathways' = 'mod2path')), + hr(), + tags$p('Make unique rows for which variable?'), + div( + div(style = 'display:inline-block', + uiOutput('which_unique') + ), + bsButton('create_mapping', 'Perform Mapping', style = 'info') + ), + uiOutput('warnings_database') + ) + ) + ), # column 4 + column(8, + bsCollapse(id = 'database_tables_parent_collapse', open = 'database_tables', multiple = TRUE, + bsCollapsePanel('Table Preview', value = 'database_tables', + span(id = "toggle_table", + div(style = 'display:inline-block;margin-top:10px;margin-right:10px;font-weight:bold', "Display results:"), + div(style = 'display:inline-block', radioGroupButtons('which_table', choices = c('Kegg' = 1, 'MetaCyc' = 2))), + div(style = 'display:inline-block', bsButton('save_db_table', 'Save current table', style = 'info')), + div(style = 'display:inline-block', bsButton('view_db_tables', uiOutput('n_saved_db_tables'), style = 'info')) + + ), + uiOutput('conditional_database_table') + ), + bsCollapsePanel('Summary Counts', value = 'database_plots', + DTOutput('mapping_summary'), + uiOutput('conditional_database_barplot') + # splitLayout(plotlyOutput('kegg_barplot'), + # plotlyOutput('mc_barplot')) + ) + ) # parent collapse + ) # column 8 + ) # fluidrow + ), # tabpanel + + ################## Download Panel ############################################## + tabPanel(div('Download', icon('download')), value = 'Download', + fluidRow(style = "display:flex;flex-direction:row;align-items:stretch", + column(width = 6, + wellPanel(style = "height:100%", + tags$h4(icon("table", "fa-2x"), tags$b("Processed Data")), + checkboxGroupInput("download_selection", label = "Check Download Selection", + choices = c('Data File as one .csv and Molecular Identification File as another .csv' = "separate", + 'Merged Data File and Molecular Identification File as a single .csv' = "merged", + 'Data summaries for grouped plots' = "group_data"), + width = "80%") + ) + ), + column(width = 5, + wellPanel(style = "height:100%", + tags$h4(icon("align-left", "fa-2x"), tags$b("Summary Report and Database Mapping Tables")), + checkboxInput("report_selection", label = "Download a summary of preprocessing and filtering", value = TRUE), + checkboxInput("download_mappings", label = "Download Database Mapping Tables", value = FALSE) + ) + ) + ), + fluidRow(style = "margin-top:10px", + column(width = 11, + wellPanel( + div(style = 'display:flex', + column(width = 5, + tags$h4(icon("image", "fa-2x"), tags$b("Figures")), + tags$h5(tags$b("Select figures by row. When clicked, the download selection will highlight.")), + DTOutput("download_plot_table") + ), + column(width = 7, + div(style = 'height:100%', class = 'plot_border', uiOutput('download_plot')) + ) + ), + hr(), + br(), + div(style = 'display:flex', + div(style = 'float:left;width:50%;margin-left:10px', + bsButton('mark_plot_download', 'Select/de-select for download', icon = icon('minus')), + bsButton('remove_plot_download', 'Remove selected plot', icon = icon('remove')) + ), + div(style = 'float:right;width:50%', class = 'spaced_flexbox', + inlineCSS('[id=download_dimensions] > .shiny-input-container {width:49%;display:inline-block;}'), + div(id = 'download_dimensions', + numericInput('download_img_width', 'Download width', value = 1600, min = 100, max = 2000, step = 1), + numericInput('download_img_height', 'Download height', value = 900, min = 100, max = 2000, step = 1) + ), + radioButtons(inputId = "image_format", label = "Select an image format", + choices = c("png", "pdf", "jpeg"), selected = "png", inline = TRUE) + ) + ), + uiOutput('warnings_download') + ) + ) + ), + div(style = 'width:75%', + actionButton('makezipfile', label = tags$b('Bundle up all selected items'), icon = icon("briefcase"), lib = "glyphicon", style = 'width:45%'), + disabled(downloadButton('download_processed_data', tags$b('Download bundle'), style = 'width:45%;float:right')) + ), + tags$br() + ), - uiOutput("enter_debugger") - ) + ################## Glossary Panel ############################################## + tabPanel(div('Glossary', icon('question-sign', lib = 'glyphicon')), value = 'Glossary', + # mainPanel( + # includeHTML("./README/Glossary.html") + withMathJax(includeMarkdown("./README/Glossary.md")) + # ) + + ) + ), + + hidden(div(id = "corems_to_peakdata_toggle", style = "position:fixed;left:15px;bottom:15px", uiOutput("corems_to_peakdata_UI"))), + + div(id = "js_helpbutton", style = "position:absolute;top:3px;right:16px;z-index:1000;width:11%", + div(style = 'float:right;width:25%', + tipify( + hidden(bsButton("helpbutton", icon("question-sign", lib = "glyphicon", style = "color:white"), style = "info")), + ttip_text[['page_help']] + ) + ), + div(style = 'float:right;width:50%%;margin-left:1px;margin-right:1px', + tipify( + hidden(bsButton("viewplots", uiOutput('viewplots_label', style = 'float:left;margin-right:10px'), style = "info", icon = icon("folder-open", lib = "glyphicon"))), + ttip_text[['plot_review']] + ) + ), + div(style = 'float:right;width:25%', + tipify( + hidden(bsButton("saveplot", icon("save", lib = "glyphicon"), style = "info")), + ttip_text[['plot_save']] + ) + ), + hidden(bsButton('datareqs_video', 'Data requirements tutorial', + onclick = "window.open('https://youtu.be/uU5Q7r_pEGM', '_blank')", + style = 'info', icon = icon('facetime-video', lib = 'glyphicon'))), + ), + uiOutput("enter_debugger") +) From d29eb3c6526f397a7d508d58b60782d0f153c584 Mon Sep 17 00:00:00 2001 From: Daniel Claborne Date: Mon, 12 Sep 2022 09:34:54 -0700 Subject: [PATCH 11/20] renv -> 0.15.4 --- renv.lock | 200 +++++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 159 insertions(+), 41 deletions(-) diff --git a/renv.lock b/renv.lock index b79c7d0..8e8010b 100644 --- a/renv.lock +++ b/renv.lock @@ -14,7 +14,10 @@ "Version": "0.19", "Source": "Repository", "Repository": "CRAN", - "Hash": "6df7d86466f183ab0edcd8e6050b38e1" + "Hash": "6df7d86466f183ab0edcd8e6050b38e1", + "Requirements": [ + "htmlwidgets" + ] }, "KeggData": { "Package": "KeggData", @@ -26,7 +29,8 @@ "RemoteUsername": "lmbramer", "RemoteRef": "new_dbmappings", "RemoteSha": "bd6bf12f1bbbd3d0543962e1729dd61271f3e3a8", - "Hash": "ce03ab7b4111dd280f973574c02d3830" + "Hash": "ce03ab7b4111dd280f973574c02d3830", + "Requirements": [] }, "MetaCycData": { "Package": "MetaCycData", @@ -38,14 +42,16 @@ "RemoteUsername": "EMSL-computing", "RemoteRef": "new_dbmappings", "RemoteSha": "e103875c4cbdd33bfacadbbc24ebb801ee4992ab", - "Hash": "b35d881fa52fefba6c57652ae399e218" + "Hash": "b35d881fa52fefba6c57652ae399e218", + "Requirements": [] }, "RColorBrewer": { "Package": "RColorBrewer", "Version": "1.1-2", "Source": "Repository", "Repository": "CRAN", - "Hash": "e031418365a7f7a766181ab5a41a5716" + "Hash": "e031418365a7f7a766181ab5a41a5716", + "Requirements": [] }, "datadr": { "Package": "datadr", @@ -57,14 +63,21 @@ "RemoteUsername": "delta-rho", "RemoteRef": "HEAD", "RemoteSha": "f3ffebd8e1c43a5d11cd3543bbe672c88f8c52f3", - "Hash": "4ddf60dd3cd5d3baf559f44d872fc74e" + "Hash": "4ddf60dd3cd5d3baf559f44d872fc74e", + "Requirements": [ + "dplyr" + ] }, "dplyr": { "Package": "dplyr", "Version": "1.0.7", "Source": "Repository", "Repository": "CRAN", - "Hash": "36f1ae62f026c8ba9f9b5c9a08c03297" + "Hash": "36f1ae62f026c8ba9f9b5c9a08c03297", + "Requirements": [ + "rlang", + "tibble" + ] }, "ftmsRanalysis": { "Package": "ftmsRanalysis", @@ -73,38 +86,69 @@ "RemoteType": "github", "RemoteHost": "api.github.com", "RemoteRepo": "ftmsRanalysis", - "RemoteUsername": "EMSL-computing", - "RemoteRef": "CoreMS-compatibility", - "RemoteSha": "66352c9d71266564286032a515f18453cee0fdc0", - "Hash": "d4e9324869317775393099b9d3603c4e" + "RemoteUsername": "EMSL-Computing", + "RemoteRef": "CoreMS-compatibility-rb", + "RemoteSha": "2fc565c32ae8a48ac1cd4eb6390d8eb97034bd8d", + "Hash": "d5a0c80ae27e356f43d9de01f2958b66", + "Requirements": [ + "RColorBrewer", + "dplyr", + "ggplot2", + "plotly", + "readr", + "reshape2", + "rlang", + "scales", + "stringr", + "tibble", + "tidyr" + ] }, "ggplot2": { "Package": "ggplot2", "Version": "3.3.5", "Source": "Repository", "Repository": "CRAN", - "Hash": "d7566c471c7b17e095dd023b9ef155ad" + "Hash": "d7566c471c7b17e095dd023b9ef155ad", + "Requirements": [ + "rlang", + "scales", + "tibble", + "withr" + ] }, "htmlwidgets": { "Package": "htmlwidgets", "Version": "1.5.4", "Source": "Repository", "Repository": "CRAN", - "Hash": "76147821cd3fcd8c4b04e1ef0498e7fb" + "Hash": "76147821cd3fcd8c4b04e1ef0498e7fb", + "Requirements": [] }, "kableExtra": { "Package": "kableExtra", "Version": "1.3.4", "Source": "Repository", "Repository": "CRAN", - "Hash": "49b625e6aabe4c5f091f5850aba8ff78" + "Hash": "49b625e6aabe4c5f091f5850aba8ff78", + "Requirements": [ + "knitr", + "rmarkdown", + "scales", + "stringr", + "webshot" + ] }, "knitr": { "Package": "knitr", "Version": "1.37", "Source": "Repository", "Repository": "CRAN", - "Hash": "a4ec675eb332a33fe7b7fe26f70e1f98" + "Hash": "a4ec675eb332a33fe7b7fe26f70e1f98", + "Requirements": [ + "stringr", + "xfun" + ] }, "mapDataAccess": { "Package": "mapDataAccess", @@ -116,175 +160,249 @@ "RemoteUsername": "multiomics-analyses", "RemoteRef": "HEAD", "RemoteSha": "12e6bd1e85a406a0d28b636f8c23754d81745ac5", - "Hash": "16970b5f8a17a3d5e2dc74911b59c0b2" + "Hash": "16970b5f8a17a3d5e2dc74911b59c0b2", + "Requirements": [ + "reticulate" + ] }, "markdown": { "Package": "markdown", "Version": "1.1", "Source": "Repository", "Repository": "CRAN", - "Hash": "61e4a10781dd00d7d81dd06ca9b94e95" + "Hash": "61e4a10781dd00d7d81dd06ca9b94e95", + "Requirements": [ + "xfun" + ] }, "pander": { "Package": "pander", "Version": "0.6.4", "Source": "Repository", "Repository": "CRAN", - "Hash": "0eae8a954e0c51bd356f8c6f0e00e805" + "Hash": "0eae8a954e0c51bd356f8c6f0e00e805", + "Requirements": [] }, "plotly": { "Package": "plotly", "Version": "4.9.4.1", "Source": "Repository", "Repository": "CRAN", - "Hash": "af4b92cb3828aa30002e2f945c49c2d7" + "Hash": "af4b92cb3828aa30002e2f945c49c2d7", + "Requirements": [ + "RColorBrewer", + "dplyr", + "ggplot2", + "htmlwidgets", + "purrr", + "rlang", + "scales", + "tibble", + "tidyr" + ] }, "purrr": { "Package": "purrr", "Version": "0.3.4", "Source": "Repository", "Repository": "CRAN", - "Hash": "97def703420c8ab10d8f0e6c72101e02" + "Hash": "97def703420c8ab10d8f0e6c72101e02", + "Requirements": [ + "rlang" + ] }, "raster": { "Package": "raster", "Version": "3.4-13", "Source": "Repository", "Repository": "CRAN", - "Hash": "4543b272b756a4ff0f80370c886ef90a" + "Hash": "4543b272b756a4ff0f80370c886ef90a", + "Requirements": [ + "sp" + ] }, "readr": { "Package": "readr", "Version": "2.0.2", "Source": "Repository", "Repository": "CRAN", - "Hash": "7cb2c3ecfbc2c6786221d2c0c1f6ed68" + "Hash": "7cb2c3ecfbc2c6786221d2c0c1f6ed68", + "Requirements": [ + "rlang", + "tibble" + ] }, "renv": { "Package": "renv", - "Version": "0.14.0", + "Version": "0.15.4", "Source": "Repository", "Repository": "CRAN", - "Hash": "30e5eba91b67f7f4d75d31de14bbfbdc" + "Hash": "c1078316e1d4f70275fc1ea60c0bc431", + "Requirements": [] }, "reshape2": { "Package": "reshape2", "Version": "1.4.4", "Source": "Repository", "Repository": "CRAN", - "Hash": "bb5996d0bd962d214a11140d77589917" + "Hash": "bb5996d0bd962d214a11140d77589917", + "Requirements": [ + "stringr" + ] }, "reticulate": { "Package": "reticulate", "Version": "1.22", "Source": "Repository", "Repository": "CRAN", - "Hash": "b34a8bb69005168078d1d546a53912b2" + "Hash": "b34a8bb69005168078d1d546a53912b2", + "Requirements": [ + "withr" + ] }, "rlang": { "Package": "rlang", - "Version": "1.0.2", + "Version": "1.0.5", "Source": "Repository", "Repository": "CRAN", - "Hash": "04884d9a75d778aca22c7154b8333ec9" + "Hash": "971c3d698fc06dabdac6bc4bcda72dc4", + "Requirements": [] }, "rmarkdown": { "Package": "rmarkdown", "Version": "2.13", "Source": "Repository", "Repository": "CRAN", - "Hash": "ac78f4d2e0289d4cba73b88af567b8b1" + "Hash": "ac78f4d2e0289d4cba73b88af567b8b1", + "Requirements": [ + "knitr", + "stringr", + "xfun" + ] }, "scales": { "Package": "scales", "Version": "1.1.1", "Source": "Repository", "Repository": "CRAN", - "Hash": "6f76f71042411426ec8df6c54f34e6dd" + "Hash": "6f76f71042411426ec8df6c54f34e6dd", + "Requirements": [ + "RColorBrewer" + ] }, "shiny": { "Package": "shiny", "Version": "1.6.0", "Source": "Repository", "Repository": "CRAN", - "Hash": "6e3b6ae7fe02b5859e4bb277f218b8ae" + "Hash": "6e3b6ae7fe02b5859e4bb277f218b8ae", + "Requirements": [ + "rlang", + "withr" + ] }, "shinyBS": { "Package": "shinyBS", "Version": "0.61", "Source": "Repository", "Repository": "CRAN", - "Hash": "f895dafd39733c4a70d425f605a832e7" + "Hash": "f895dafd39733c4a70d425f605a832e7", + "Requirements": [ + "shiny" + ] }, "shinyWidgets": { "Package": "shinyWidgets", "Version": "0.6.2", "Source": "Repository", "Repository": "CRAN", - "Hash": "9bdabea3a78fd6a0768c2a319d36264e" + "Hash": "9bdabea3a78fd6a0768c2a319d36264e", + "Requirements": [ + "shiny" + ] }, "shinycssloaders": { "Package": "shinycssloaders", "Version": "1.0.0", "Source": "Repository", "Repository": "CRAN", - "Hash": "f39bb3c44a9b496723ec7e86f9a771d8" + "Hash": "f39bb3c44a9b496723ec7e86f9a771d8", + "Requirements": [ + "shiny" + ] }, "shinyjs": { "Package": "shinyjs", "Version": "2.0.0", "Source": "Repository", "Repository": "CRAN", - "Hash": "9ddfc91d4280eaa34c2103951538976f" + "Hash": "9ddfc91d4280eaa34c2103951538976f", + "Requirements": [ + "shiny" + ] }, "sp": { "Package": "sp", "Version": "1.4-5", "Source": "Repository", "Repository": "CRAN", - "Hash": "dfd843ee98246cf932823acf613b05dd" + "Hash": "dfd843ee98246cf932823acf613b05dd", + "Requirements": [] }, "stringr": { "Package": "stringr", "Version": "1.4.0", "Source": "Repository", "Repository": "CRAN", - "Hash": "0759e6b6c0957edb1311028a49a35e76" + "Hash": "0759e6b6c0957edb1311028a49a35e76", + "Requirements": [] }, "tibble": { "Package": "tibble", "Version": "3.1.5", "Source": "Repository", "Repository": "CRAN", - "Hash": "36eb05ad4cfdfeaa56f5a9b2a1311efd" + "Hash": "36eb05ad4cfdfeaa56f5a9b2a1311efd", + "Requirements": [ + "rlang" + ] }, "tidyr": { "Package": "tidyr", "Version": "1.1.4", "Source": "Repository", "Repository": "CRAN", - "Hash": "c8fbdbd9fcac223d6c6fe8e406f368e1" + "Hash": "c8fbdbd9fcac223d6c6fe8e406f368e1", + "Requirements": [ + "dplyr", + "purrr", + "rlang", + "tibble" + ] }, "webshot": { "Package": "webshot", "Version": "0.5.2", "Source": "Repository", "Repository": "CRAN", - "Hash": "e99d80ad34457a4853674e89d5e806de" + "Hash": "e99d80ad34457a4853674e89d5e806de", + "Requirements": [] }, "withr": { "Package": "withr", "Version": "2.4.2", "Source": "Repository", "Repository": "CRAN", - "Hash": "ad03909b44677f930fa156d47d7a3aeb" + "Hash": "ad03909b44677f930fa156d47d7a3aeb", + "Requirements": [] }, "xfun": { "Package": "xfun", "Version": "0.30", "Source": "Repository", "Repository": "CRAN", - "Hash": "e83f48136b041845e50a6658feffb197" + "Hash": "e83f48136b041845e50a6658feffb197", + "Requirements": [] } } } From 3bbab3ce3fab9972bbc45182eb84cd3f74962c8c Mon Sep 17 00:00:00 2001 From: Daniel Claborne Date: Mon, 12 Sep 2022 09:35:32 -0700 Subject: [PATCH 12/20] prevent Edata() from recalculating incorrectly if we're uploading from disk --- Reactive_Variables/misc_revals.R | 4 ---- Reactive_Variables/upload_revals.R | 3 ++- ui.R | 3 --- 3 files changed, 2 insertions(+), 8 deletions(-) diff --git a/Reactive_Variables/misc_revals.R b/Reactive_Variables/misc_revals.R index 235f560..85a8a07 100644 --- a/Reactive_Variables/misc_revals.R +++ b/Reactive_Variables/misc_revals.R @@ -6,7 +6,3 @@ peakData2_dim <- eventReactive(revals$peakData2, { uploaded_data_dim <- eventReactive(revals$uploaded_data, { prod(dim(revals$uploaded_data$e_data[, -1])) }) - -edata_dim <- eventReactive(Edata(), { - prod(dim(Edata()[, -1])) -}) diff --git a/Reactive_Variables/upload_revals.R b/Reactive_Variables/upload_revals.R index 4531ee2..a0626aa 100644 --- a/Reactive_Variables/upload_revals.R +++ b/Reactive_Variables/upload_revals.R @@ -1,6 +1,7 @@ # Object: Get e_data from file input Edata <- reactive({ - if (!is.null(revals$uploaded_data)) { + # Handle scenario where we made edata from another source. + if (!is.null(revals$uploaded_data) & is.null(input$file_edata$datapath)) { return(revals$uploaded_data$e_data %>% dplyr::select(-dplyr::one_of( ftmsRanalysis::getEDataColName(revals$uploaded_data) diff --git a/ui.R b/ui.R index 4f12b1b..30513e9 100644 --- a/ui.R +++ b/ui.R @@ -530,10 +530,7 @@ ui <- tagList(useShinyjs(), ################## Glossary Panel ############################################## tabPanel(div('Glossary', icon('question-sign', lib = 'glyphicon')), value = 'Glossary', - # mainPanel( - # includeHTML("./README/Glossary.html") withMathJax(includeMarkdown("./README/Glossary.md")) - # ) ) ), From b934a7fc0fa49c35978ed43422a82f7170af6faa Mon Sep 17 00:00:00 2001 From: Daniel Claborne Date: Wed, 28 Sep 2022 17:18:46 -0700 Subject: [PATCH 13/20] remove isotope identificaiton dropdowns in favor of auto-detect in ftmsRanalysis --- .dockerignore | 1 + Observers/corems_observers.R | 27 ++ Reactive_Variables/corems_revals.R | 3 +- global.R | 13 +- isotopes.json | 483 +++++++++++++++++++++++++++++ renv.lock | 35 ++- srv_ui_elements/corems_UI.R | 50 ++- tab_factories/upload_tab.R | 29 +- 8 files changed, 590 insertions(+), 51 deletions(-) create mode 100644 isotopes.json diff --git a/.dockerignore b/.dockerignore index 6006e1d..00781fc 100644 --- a/.dockerignore +++ b/.dockerignore @@ -3,6 +3,7 @@ !calculation_options.csv !calculation_variables.csv !processedCols.csv +!isotopes.json !DataRequirements.md !Docker_instructions.md !peakData_Report.Rmd diff --git a/Observers/corems_observers.R b/Observers/corems_observers.R index 430dc44..e85f8c1 100644 --- a/Observers/corems_observers.R +++ b/Observers/corems_observers.R @@ -94,3 +94,30 @@ observeEvent(cms_dat_unq_mf(), { showModal(corems_unq_mf_modal()) show("corems_to_peakdata_toggle") }) + +#' @details disable functionality and helper css for arguments required for corems +observe({ + req(input$top_page == "CoreMS-create") + fields_filled = TRUE + + for(arg in COREMSDATA_REQ_ARGS) { + is_selected = isTruthy(input[[arg]] != NULLSELECT__) + toggleCssClass(sprintf("%s_UI", arg), "attention", !is_selected) + if(!is_selected) { + fields_filled = FALSE + } + } + + toggleState("make_cmsdata", condition = fields_filled) + + if (!fields_filled) { + showNotification( + ui = "One or more required fields for making your coreMS data object are not specified", + type = "warning", + id = "as-corems-args-notification" + ) + } else { + removeNotification("as-corems-args-notification") + } + +}) diff --git a/Reactive_Variables/corems_revals.R b/Reactive_Variables/corems_revals.R index 7204071..04a2d17 100644 --- a/Reactive_Variables/corems_revals.R +++ b/Reactive_Variables/corems_revals.R @@ -12,7 +12,7 @@ cms_data <- eventReactive(input$make_cmsdata, { args = list(corems_revals[['combined_tables']]) # Collect arguments specified by the user - for (argname in COREMSDATA_ARGS) { + for (argname in COREMSDATA_REQ_ARGS) { if (isTRUE(input[[argname]] == NULLSELECT__) | !isTruthy(input[[argname]])) { args[[argname]] <- NULL } else { @@ -20,7 +20,6 @@ cms_data <- eventReactive(input$make_cmsdata, { } } - cms_dat <- do.call(as.CoreMSData, args) return(cms_dat) diff --git a/global.R b/global.R index dc4d3d7..06b9738 100644 --- a/global.R +++ b/global.R @@ -56,7 +56,6 @@ info_text = list( # cloud/minio resources VALID_MINIO_HEADER_PARAMS = c("corems-prefix") - #' @SECTION Variables for selectors/inputs ## # Use this global variable for 'nothing selected' options @@ -67,9 +66,12 @@ COREMSDATA_ARGS = c( "index_cname", "obs_mass_cname", "calc_mass_cname", + "calib_mass_cname", "pheight_cname", "error_cname", "conf_cname", + "heteroatom_cname", + "iontype_cname", "file_cname", "monoiso_index_cname", "mf_cname", @@ -78,3 +80,12 @@ COREMSDATA_ARGS = c( "n15cname", "s34_cname" ) + +COREMSDATA_OPTIONAL_ARGS = c("c13_cname", "o18_cname", "n15cname", "s34_cname") +COREMSDATA_REQ_ARGS = setdiff(COREMSDATA_ARGS, COREMSDATA_OPTIONAL_ARGS) + +# Isotopes as determined by CoreMS static files +COREMS_ISOTOPES = jsonlite::read_json("isotopes.json") +COREMSDATA_ISOTOPE_ARGS = list("c13_cname" = "13C", "o18_cname" = "18O", "n15cname" = "15N", "s34_cname" = "34S") + +FREDA_ISOTOPES_OF_INTEREST = c("34S", "18O", "13C", "15N") diff --git a/isotopes.json b/isotopes.json new file mode 100644 index 0000000..30ea80d --- /dev/null +++ b/isotopes.json @@ -0,0 +1,483 @@ +{ + "F": [ + "Flourine" + ], + "Na": [ + "Sodium" + ], + "Al": [ + "Aluminum" + ], + "P": [ + "Phosphorus" + ], + "Sc": [ + "Scandium" + ], + "Co": [ + "Cobalt" + ], + "He": [ + "Helium" + ], + "Ar": [ + "Argon" + ], + "H": [ + "Hydrogen", + [ + "D" + ] + ], + "Cl": [ + "Chlorine", + [ + "37Cl" + ] + ], + "Li": [ + "Lithium", + [ + "6Li" + ] + ], + "Be": [ + "Beryllium" + ], + "B": [ + "Boron", + [ + "11B" + ] + ], + "C": [ + "Carbon", + [ + "13C" + ] + ], + "O": [ + "Oxygen", + [ + "18O", + "17O" + ] + ], + "S": [ + "Sulfur", + [ + "34S" + ] + ], + "N": [ + "Nitrogen", + [ + "15N" + ] + ], + "V": [ + "Vanadium", + [ + "50V" + ] + ], + "Ne": [ + "Neon", + [ + "20Ne", + "22Ne" + ] + ], + "Mg": [ + "Magnesium", + [ + "24Mg", + "26Mg", + "25Mg" + ] + ], + "Si": [ + "Silicon", + [ + "28Si", + "29Si", + "30Si" + ] + ], + "K": [ + "Potassium", + [ + "40K", + "41K" + ] + ], + "Ca": [ + "Calcium", + [ + "43Ca", + "44Ca" + ] + ], + "Ti": [ + "Titanium", + [ + "48Ti", + "46Ti", + "47Ti", + "49Ti", + "50Ti" + ] + ], + "Cr": [ + "Chromium", + [ + "53Cr", + "50Cr", + "54Cr" + ] + ], + "Fe": [ + "Iron", + [ + "54Fe", + "57Fe", + "58Fe" + ] + ], + "Mn": [ + "Manganese" + ], + "Ni": [ + "Nickel", + [ + "60Ni", + "62Ni", + "61Ni" + ] + ], + "Cu": [ + "Copper", + [ + "65Cu" + ] + ], + "Zn": [ + "Zinc", + [ + "66Zn", + "68Zn", + "67Zn", + "70Zn" + ] + ], + "Ga": [ + "Gallium", + [ + "69Ga", + "71Ga" + ] + ], + "Ge": [ + "Germanium", + [ + "74Ge", + "72Ge", + "70Ge", + "73Ge", + "76Ge" + ] + ], + "As": [ + "Arsenic" + ], + "Se": [ + "Selenium", + [ + "78Se", + "76Se", + "82Se", + "77Se" + ] + ], + "Br": [ + "Bromine", + [ + "81Br" + ] + ], + "Kr": [ + "Krypton", + [ + "84Kr", + "86Kr", + "82Kr", + "83Kr", + "80Kr" + ] + ], + "Rb": [ + "Rubidium", + [ + "85Rb", + "87Rb" + ] + ], + "Sr": [ + "Strontium", + [ + "88Sr", + "86Sr", + "87Sr" + ] + ], + "Y": [ + "Yttrium" + ], + "Zr": [ + "Zironium", + [ + "90Zr", + "94Zr", + "92Zr", + "91Zr", + "96Zr" + ] + ], + "Nb": [ + "Niobium" + ], + "Mo": [ + "Molybdenum", + [ + "96Mo", + "95Mo", + "92Mo", + "100Mo", + "97Mo", + "94Mo" + ] + ], + "Tc": [ + "Technetium" + ], + "Ru": [ + "Ruthenium", + [ + "102Ru", + "104Ru", + "101Ru", + "99Ru", + "100Ru", + "96Ru", + "98Ru" + ] + ], + "Rh": [ + "Rhodium" + ], + "Pd": [ + "Palladium", + [ + "106Pd", + "108Pd", + "105Pd", + "110Pd", + "104Pd", + "102Pd" + ] + ], + "Ag": [ + "Silver", + [ + "107Ag", + "109Ag" + ] + ], + "Cd": [ + "Cadmium", + [ + "114Cd", + "111Cd", + "110Cd", + "113Cd", + "116Cd", + "106Cd", + "108Cd" + ] + ], + "In": [ + "Indium", + [ + "113In" + ] + ], + "Sn": [ + "Tin", + [ + "120Sn", + "118Sn", + "116Sn", + "119Sn", + "117Sn", + "124Sn", + "122Sn", + "112Sn" + ] + ], + "Sb": [ + "Antimony", + [ + "121Sb", + "123Sb" + ] + ], + "Te": [ + "Tellurium", + [ + "130Te", + "128Te", + "126Te", + "125Te", + "124Te", + "122Te" + ] + ], + "I": [ + "Iodine" + ], + "Xe": [ + "Xenon", + [ + "132Xe", + "129Xe", + "131Xe", + "134Xe", + "136Xe", + "130Xe", + "128Xe" + ] + ], + "Cs": [ + "Cesium" + ], + "Ba": [ + "Barium", + [ + "138Ba", + "137Ba", + "136Ba", + "135Ba", + "134Ba" + ] + ], + "La": [ + "Lanthanum" + ], + "Hf": [ + "Hafnium", + [ + "180Hf", + "178Hf", + "177Hf", + "179Hf", + "176Hf" + ] + ], + "Ta": [ + "Tantalum" + ], + "W": [ + "Tungsten", + [ + "184W", + "186W", + "182W", + "183W" + ] + ], + "Re": [ + "Rhenium", + [ + "187Re", + "185Re" + ] + ], + "Os": [ + "Osmium", + [ + "192Os", + "190Os", + "189Os", + "188Os", + "187Os", + "186Os" + ] + ], + "Ir": [ + "Iridium", + [ + "193Ir", + "191Ir" + ] + ], + "Pt": [ + "Platinum", + [ + "195Pt", + "194Pt", + "196Pt", + "198Pt", + "192Pt" + ] + ], + "Au": [ + "Gold" + ], + "Hg": [ + "Mercury", + [ + "202Hg", + "200Hg", + "199Hg", + "201Hg", + "198Hg", + "204Hg" + ] + ], + "Tl": [ + "Thallium", + [ + "205Tl", + "203Tl" + ] + ], + "Pb": [ + "Lead", + [ + "206Pb", + "207Pb", + "204Pb" + ] + ], + "Bi": [ + "Bismuth" + ], + "Po": [ + "Polonium" + ], + "At": [ + "Aslatine" + ], + "Rn": [ + "Radon" + ], + "Fr": [ + "Francium" + ], + "Ra": [ + "Radium" + ], + "Ac": [ + "Actinium" + ] +} \ No newline at end of file diff --git a/renv.lock b/renv.lock index 8e8010b..b04df77 100644 --- a/renv.lock +++ b/renv.lock @@ -11,12 +11,13 @@ "Packages": { "DT": { "Package": "DT", - "Version": "0.19", + "Version": "0.25", "Source": "Repository", "Repository": "CRAN", - "Hash": "6df7d86466f183ab0edcd8e6050b38e1", + "Hash": "d35337fd4278be35c50d7eeeec439f68", "Requirements": [ - "htmlwidgets" + "htmlwidgets", + "jsonlite" ] }, "KeggData": { @@ -88,8 +89,8 @@ "RemoteRepo": "ftmsRanalysis", "RemoteUsername": "EMSL-Computing", "RemoteRef": "CoreMS-compatibility-rb", - "RemoteSha": "2fc565c32ae8a48ac1cd4eb6390d8eb97034bd8d", - "Hash": "d5a0c80ae27e356f43d9de01f2958b66", + "RemoteSha": "ebc788a659a6a1445374b72025c1838d2c53e22e", + "Hash": "c52c1f930ebc524cbfc331f2ee677d09", "Requirements": [ "RColorBrewer", "dplyr", @@ -123,6 +124,16 @@ "Source": "Repository", "Repository": "CRAN", "Hash": "76147821cd3fcd8c4b04e1ef0498e7fb", + "Requirements": [ + "jsonlite" + ] + }, + "jsonlite": { + "Package": "jsonlite", + "Version": "1.7.2", + "Source": "Repository", + "Repository": "CRAN", + "Hash": "98138e0994d41508c7a6b84a0600cfcb", "Requirements": [] }, "kableExtra": { @@ -194,6 +205,7 @@ "dplyr", "ggplot2", "htmlwidgets", + "jsonlite", "purrr", "rlang", "scales", @@ -257,6 +269,7 @@ "Repository": "CRAN", "Hash": "b34a8bb69005168078d1d546a53912b2", "Requirements": [ + "jsonlite", "withr" ] }, @@ -275,6 +288,7 @@ "Repository": "CRAN", "Hash": "ac78f4d2e0289d4cba73b88af567b8b1", "Requirements": [ + "jsonlite", "knitr", "stringr", "xfun" @@ -297,6 +311,7 @@ "Repository": "CRAN", "Hash": "6e3b6ae7fe02b5859e4bb277f218b8ae", "Requirements": [ + "jsonlite", "rlang", "withr" ] @@ -318,6 +333,7 @@ "Repository": "CRAN", "Hash": "9bdabea3a78fd6a0768c2a319d36264e", "Requirements": [ + "jsonlite", "shiny" ] }, @@ -338,6 +354,7 @@ "Repository": "CRAN", "Hash": "9ddfc91d4280eaa34c2103951538976f", "Requirements": [ + "jsonlite", "shiny" ] }, @@ -386,14 +403,16 @@ "Source": "Repository", "Repository": "CRAN", "Hash": "e99d80ad34457a4853674e89d5e806de", - "Requirements": [] + "Requirements": [ + "jsonlite" + ] }, "withr": { "Package": "withr", - "Version": "2.4.2", + "Version": "2.5.0", "Source": "Repository", "Repository": "CRAN", - "Hash": "ad03909b44677f930fa156d47d7a3aeb", + "Hash": "c0e49a9760983e81e55cdd9be92e7182", "Requirements": [] }, "xfun": { diff --git a/srv_ui_elements/corems_UI.R b/srv_ui_elements/corems_UI.R index fd996b6..183cf7a 100644 --- a/srv_ui_elements/corems_UI.R +++ b/srv_ui_elements/corems_UI.R @@ -72,8 +72,8 @@ mutually_exclusive_dropdown <- function(id, title, selected = NULL) { ) %>% setdiff(NULLSELECT__) choices = c("Select one" = NULLSELECT__, choices) - - if (any(!(selected %in% choices), isTRUE(input[[id]] != NULLSELECT__))) { + + if(!is.null(input[[id]])) { selected = input[[id]] } @@ -85,56 +85,52 @@ mutually_exclusive_dropdown <- function(id, title, selected = NULL) { }) } -output$index_cname <- mutually_exclusive_dropdown( +output$index_cname_UI <- mutually_exclusive_dropdown( "index_cname", "Index Column:", "Index" ) -output$obs_mass_cname <- mutually_exclusive_dropdown( +output$obs_mass_cname_UI <- mutually_exclusive_dropdown( "obs_mass_cname", "Observed Mass Column:", "m/z" ) -output$calc_mass_cname <- mutually_exclusive_dropdown( +output$calc_mass_cname_UI <- mutually_exclusive_dropdown( "calc_mass_cname", "Calculated Mass Column:", "Calculated m/z" ) -output$pheight_cname <- mutually_exclusive_dropdown( - "pheight_cname", "Peak Height Column:", "Peak Height" +output$calib_mass_cname_UI <- mutually_exclusive_dropdown( + "calib_mass_cname", "Calibrated Mass Column:", "Calibrated m/z" ) -output$error_cname <- mutually_exclusive_dropdown( - "error_cname", "Mass Error Column:", "Mass Error (ppm)" +output$pheight_cname_UI <- mutually_exclusive_dropdown( + "pheight_cname", "Peak Height Column:", "Peak Height" ) -output$conf_cname <- mutually_exclusive_dropdown( - "conf_cname", "Confidence Score Column:", "Confidence Score" +output$error_cname_UI <- mutually_exclusive_dropdown( + "error_cname", "Mass Error Column:", "m/z Error (ppm)" ) -output$file_cname <- mutually_exclusive_dropdown( - "file_cname", "Filename/Sample Column:", "Filename" -) - -output$mono_index_cname <- mutually_exclusive_dropdown( - "mono_index_cname", "Mono Isotopic Index Column:", "Mono Isotopic Index" +output$conf_cname_UI <- mutually_exclusive_dropdown( + "conf_cname", "Confidence Score Column:", "Confidence Score" ) -output$mf_cname <- mutually_exclusive_dropdown( - "mf_cname", "Molecular Formula Column:", "Molecular Formula" +output$heteroatom_cname_UI <- mutually_exclusive_dropdown( + "heteroatom_cname", "Heteroatom Column:", "Heteroatom Class" ) -output$c13_cname <- mutually_exclusive_dropdown( - "c13_cname", "C13 Column:", "13C" +output$iontype_cname_UI <- mutually_exclusive_dropdown( + "iontype_cname", "Ion Type Column:", "Ion Type" ) -output$o18_cname <- mutually_exclusive_dropdown( - "o18_cname", "O18 Column:", "18O" +output$file_cname_UI <- mutually_exclusive_dropdown( + "file_cname", "Filename/Sample Column:", "Filename" ) -output$n15_cname <- mutually_exclusive_dropdown( - "n15_cname", "N15 Column:", "15N" +output$monoiso_index_cname_UI <- mutually_exclusive_dropdown( + "monoiso_index_cname", "Mono Isotopic Index Column:", "Mono Isotopic Index" ) -output$s34_cname <- mutually_exclusive_dropdown( - "s34_cname", "S34 Column:", "34S" +output$mf_cname_UI <- mutually_exclusive_dropdown( + "mf_cname", "Molecular Formula Column:", "Molecular Formula" ) #' @details Preview table diff --git a/tab_factories/upload_tab.R b/tab_factories/upload_tab.R index ef2d964..32cc620 100644 --- a/tab_factories/upload_tab.R +++ b/tab_factories/upload_tab.R @@ -174,19 +174,22 @@ corems_tabs <- function() { value = "input_args", title = "Specify Column Names", div(id = 'specify_colnames', - uiOutput("index_cname"), - uiOutput("obs_mass_cname"), - uiOutput("calc_mass_cname"), - uiOutput("pheight_cname"), - uiOutput("error_cname"), - uiOutput("conf_cname"), - uiOutput("file_cname"), - uiOutput("mono_index_cname"), - uiOutput("mf_cname"), - uiOutput("c13_cname"), - uiOutput("o18_cname"), - uiOutput("n15_cname"), - uiOutput("s34_cname") + uiOutput("index_cname_UI"), + uiOutput("obs_mass_cname_UI"), + uiOutput("calc_mass_cname_UI"), + uiOutput("calib_mass_cname_UI"), + uiOutput("pheight_cname_UI"), + uiOutput("error_cname_UI"), + uiOutput("conf_cname_UI"), + uiOutput("heteroatom_cname_UI"), + uiOutput("iontype_cname_UI"), + uiOutput("file_cname_UI"), + uiOutput("monoiso_index_cname_UI"), + uiOutput("mf_cname_UI"), + uiOutput("c13_cname_UI"), + uiOutput("o18_cname_UI"), + uiOutput("n15_cname_UI"), + uiOutput("s34_cname_UI") ) # end div ) # end Collapse Panel ), # end bsCollapse From 61fd844c0a4fd6dc64cf7a09d50e09d6431ccc56 Mon Sep 17 00:00:00 2001 From: Daniel Claborne Date: Mon, 3 Oct 2022 13:32:36 -0700 Subject: [PATCH 14/20] rotate axis tick labels, fix aspect ratio on corems upload plots --- srv_ui_elements/corems_UI.R | 28 +++++++++++++++++++++------- tab_factories/upload_tab.R | 12 ++++++++---- 2 files changed, 29 insertions(+), 11 deletions(-) diff --git a/srv_ui_elements/corems_UI.R b/srv_ui_elements/corems_UI.R index 183cf7a..f6ee55a 100644 --- a/srv_ui_elements/corems_UI.R +++ b/srv_ui_elements/corems_UI.R @@ -144,21 +144,31 @@ output$cms_raw_data <- DT::renderDT( #' @app_location CoreMS Creation Tab output$cmsdat_plot <- renderPlotly({ req(cms_data()) - plot(cms_data()) + p <- plot(cms_data()) + p %>% + layout( + xaxis = list(tickangle = -45), + margin = list(b = 160) + ) }) #' @details data table with kept/removed peaks #' @app_location Confidence Filtering Tab output$filt_peaks_dt <- DT::renderDT( ftmsRanalysis:::conf_filter_dt(cms_data(), input$min_conf), - options = list(dom = 't') + options = list(dom = 't', scrollX = T) ) #' @details Plot of filtered corems data #' @app_location Confidence Filtering Tab output$cms_filt_plot <- renderPlotly({ validate(need(cms_data_filtered(), "Create your filtered data to view filter plot")) - plot(cms_data_filtered()) + p <- plot(cms_data_filtered()) + p %>% + layout( + xaxis = list(tickangle = -45), + margin = list(b = 160) + ) }) #' @details display mass error plot with min_conf slider values @@ -171,14 +181,18 @@ output$me_plot <- renderPlotly({ #' @app_location Unique molecular formula assignment tab output$mf_plot <- renderPlotly({ validate(need(cms_dat_unq_mf(), "Please assign molecular formulae to your CoreMS data")) - plot(cms_dat_unq_mf()) + p <- plot(cms_dat_unq_mf()) + p %>% layout( + xaxis = list(tickangle = -45), + margin = list(b = 160) + ) }) #' @details data table with kept/removed peaks #' @app_location Confidence Filtering Tab output$filt_peaks_dt <- DT::renderDT( ftmsRanalysis:::conf_filter_dt(cms_data(), input$min_conf), - options = list(dom = 't') + options = list(dom = 't', scollX = T) ) #' @details Isotopic peaks after formula assignment @@ -187,7 +201,7 @@ output$assign_formula_iso <- DT::renderDT({ req(cms_dat_unq_mf()) cms_dat_unq_mf()$iso_data }, -options = list(dom = 't') +options = list(dom = 't', scrollX = T) ) #' @details Mono-isotopic peaks after formula assignment @@ -196,7 +210,7 @@ output$assign_formula_monoiso <- DT::renderDT({ req(cms_dat_unq_mf()) cms_dat_unq_mf()$monoiso_data }, -options = list(dom = 't') +options = list(dom = 't', scrollX = T) ) #' @details Button to convert corems data to ftmsRanalysis peakData diff --git a/tab_factories/upload_tab.R b/tab_factories/upload_tab.R index 32cc620..5ecf3d5 100644 --- a/tab_factories/upload_tab.R +++ b/tab_factories/upload_tab.R @@ -214,7 +214,8 @@ corems_tabs <- function() { ), bsCollapsePanel( title = "Plot Summary", value = "corems-upload-visualize", - withSpinner(plotlyOutput("cmsdat_plot"), color = "deepskyblue", type = 8) + inlineCSS("#cmsdat_plot {aspect-ratio:2/1;}"), + withSpinner(plotlyOutput("cmsdat_plot", height = "auto"), color = "deepskyblue", type = 8) ) ) ) # end main column @@ -269,12 +270,14 @@ corems_tabs <- function() { tabPanel( "Mass Error Plot", value = "me_plot", - plotlyOutput("me_plot") + inlineCSS("#me_plot {aspect-ratio:4/3;}"), + withSpinner(plotlyOutput("me_plot", height="auto"), color = "deepskyblue", type = 8) ), tabPanel( "Filtered Data Plot", value = "filt_summary_plot", - plotlyOutput("cms_filt_plot") + inlineCSS("#cms_filt_plot {aspect-ratio:2/1;}"), + withSpinner(plotlyOutput("cms_filt_plot", height = "auto"), color = "deepskyblue", type = 8) ) ) ) @@ -331,7 +334,8 @@ corems_tabs <- function() { bsCollapsePanel( "Visualizations", value = "viz", - plotlyOutput("mf_plot") + inlineCSS("#mf_plot {aspect-ratio:2/1;}"), + withSpinner(plotlyOutput("mf_plot", height = "auto"), color = "deepskyblue", type = 8) ) ) ) # close main column From 03898814e89bfaa0754e290feca99a525779c048 Mon Sep 17 00:00:00 2001 From: Daniel Claborne Date: Thu, 11 Jan 2024 15:38:39 -0800 Subject: [PATCH 15/20] update README --- README.md | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) diff --git a/README.md b/README.md index 2fb0736..99a3dc4 100644 --- a/README.md +++ b/README.md @@ -18,13 +18,6 @@ The FT-MS R Exploratory Data Analysis (FREDA) tool is designed to allow users up *** -#### **Recent Updates:** - v1.0.4 - * *Linked plots sub-tab of the Visualize tab. Interactively compare scatter or single sample histogram plots.* - * *Map peaks to values in the Kegg and Metacyc databases.* - -*** - ### Running the app locally: #### 1. Using R/Rstudio/Shiny @@ -50,7 +43,7 @@ example, do the following: 1. Create a folder in the minio UI (call it test_folder, for example) and put a couple csv files in it. 2. Launch FREDA from Rstudio. -3. Nagivate to wherever FREDA is being served at, adding /?corems-prefix=test_folder to the url. +3. Nagivate to wherever FREDA is being served at, adding `/?corems-prefix=test_folder` to the url. FREDA will attempt to read all the files in the minio folder `test_folder` and load them into the reactiveValue corems_samples. @@ -89,7 +82,7 @@ Now, replacing <base tag> with whatever version, run: **To build the 'top' container**: Simply make sure Dockerfile refers to the correct base container if you have updated any dependencies (rebuilt the base container) and run: -`docker build -t docker.artifactory.pnnl.gov/mscviz/freda: .` +`docker build --build-arg base_tag= -t docker.artifactory.pnnl.gov/mscviz/freda: .` If all is well, push new containers to the registry: `docker push docker.artifactory.pnnl.gov/mscviz/freda/base:` From d844cb88447a04e5f83b4e92fd8e3205d56741e0 Mon Sep 17 00:00:00 2001 From: Daniel Claborne Date: Thu, 18 Jan 2024 11:45:00 -0800 Subject: [PATCH 16/20] add docker compose file --- docker-compose-freda.yml | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) create mode 100644 docker-compose-freda.yml diff --git a/docker-compose-freda.yml b/docker-compose-freda.yml new file mode 100644 index 0000000..718e176 --- /dev/null +++ b/docker-compose-freda.yml @@ -0,0 +1,22 @@ +# + +version: "3" +services: + freda: + image: docker.artifactory.pnnl.gov/mscviz/freda:develop.2 + container_name: freda + ports: + - "3838:3838" + volumes: + - "./cfg/minio_config_corems_docker.yml:/srv/shiny-server/FREDA/cfg/minio_config.yml" + minio: + image: minio/minio + container_name: minio-freda + ports: + - "9002:9000" + - "9003:9001" + command: server --console-address ":9001" /data + +networks: + default: + name: freda-net \ No newline at end of file From 0bc618e3d8f6a07ec2bb23269c5e46a7078b699a Mon Sep 17 00:00:00 2001 From: Daniel Claborne Date: Thu, 18 Jan 2024 14:46:19 -0800 Subject: [PATCH 17/20] update lockfile, renv to 1.0.3 --- .gitignore | 3 +- .renvignore | 3 + renv.lock | 1631 +++++++++++++++++++++++++++++++++++++++---- renv_dependencies.R | 11 - 4 files changed, 1506 insertions(+), 142 deletions(-) create mode 100644 .renvignore delete mode 100644 renv_dependencies.R diff --git a/.gitignore b/.gitignore index 13896df..242eb23 100644 --- a/.gitignore +++ b/.gitignore @@ -37,7 +37,8 @@ script_dump.R packrat/lib*/ Data/ untracked_resources -.renvignore cfg !cfg/minio_config_example.yml +!cfg/minio_config_corems.yml renv +!renv/settings.json diff --git a/.renvignore b/.renvignore new file mode 100644 index 0000000..138a486 --- /dev/null +++ b/.renvignore @@ -0,0 +1,3 @@ +untracked_resources +.git +tests/ \ No newline at end of file diff --git a/renv.lock b/renv.lock index b04df77..56b2b77 100644 --- a/renv.lock +++ b/renv.lock @@ -1,6 +1,6 @@ { "R": { - "Version": "4.1.1", + "Version": "4.2.3", "Repositories": [ { "Name": "CRAN", @@ -9,16 +9,29 @@ ] }, "Packages": { + "BH": { + "Package": "BH", + "Version": "1.84.0-0", + "Source": "Repository", + "Repository": "CRAN", + "Hash": "a8235afbcd6316e6e91433ea47661013" + }, "DT": { "Package": "DT", - "Version": "0.25", + "Version": "0.31", "Source": "Repository", "Repository": "CRAN", - "Hash": "d35337fd4278be35c50d7eeeec439f68", "Requirements": [ + "crosstalk", + "htmltools", "htmlwidgets", - "jsonlite" - ] + "httpuv", + "jquerylib", + "jsonlite", + "magrittr", + "promises" + ], + "Hash": "77b5189f5272ae2b21e3ac2175ad107c" }, "KeggData": { "Package": "KeggData", @@ -30,8 +43,41 @@ "RemoteUsername": "lmbramer", "RemoteRef": "new_dbmappings", "RemoteSha": "bd6bf12f1bbbd3d0543962e1729dd61271f3e3a8", - "Hash": "ce03ab7b4111dd280f973574c02d3830", - "Requirements": [] + "Requirements": [ + "R" + ], + "Hash": "ce03ab7b4111dd280f973574c02d3830" + }, + "MASS": { + "Package": "MASS", + "Version": "7.3-58.2", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "grDevices", + "graphics", + "methods", + "stats", + "utils" + ], + "Hash": "e02d1a0f6122fd3e634b25b433704344" + }, + "Matrix": { + "Package": "Matrix", + "Version": "1.5-3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "graphics", + "grid", + "lattice", + "methods", + "stats", + "utils" + ], + "Hash": "4006dffe49958d2dd591c17e61e60591" }, "MetaCycData": { "Package": "MetaCycData", @@ -40,19 +86,286 @@ "RemoteType": "github", "RemoteHost": "api.github.com", "RemoteRepo": "MetaCycData", - "RemoteUsername": "EMSL-computing", - "RemoteRef": "new_dbmappings", - "RemoteSha": "e103875c4cbdd33bfacadbbc24ebb801ee4992ab", - "Hash": "b35d881fa52fefba6c57652ae399e218", - "Requirements": [] + "RemoteUsername": "EMSL-Computing", + "RemoteRef": "HEAD", + "RemoteSha": "2519b228293d24d085615371771912acc54f429e", + "Requirements": [ + "R" + ], + "Hash": "9c6debe0e6495fc0cd5604ae11a48b0b" + }, + "R6": { + "Package": "R6", + "Version": "2.5.1", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "470851b6d5d0ac559e9d01bb352b4021" }, "RColorBrewer": { "Package": "RColorBrewer", - "Version": "1.1-2", + "Version": "1.1-3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "45f0398006e83a5b10b72a90663d8d8c" + }, + "RcppTOML": { + "Package": "RcppTOML", + "Version": "0.2.2", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "Rcpp" + ], + "Hash": "c232938949fcd8126034419cc529333a" + }, + "anytime": { + "Package": "anytime", + "Version": "0.3.9", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "BH", + "R", + "Rcpp" + ], + "Hash": "74a64813f17b492da9c6afda6b128e3d" + }, + "ape": { + "Package": "ape", + "Version": "5.7-1", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "Rcpp", + "digest", + "graphics", + "lattice", + "methods", + "nlme", + "parallel", + "stats", + "utils" + ], + "Hash": "10705eec964349f270504754d8fe8ef1" + }, + "askpass": { + "Package": "askpass", + "Version": "1.2.0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "sys" + ], + "Hash": "cad6cf7f1d5f6e906700b9d3e718c796" + }, + "base64enc": { + "Package": "base64enc", + "Version": "0.1-3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "543776ae6848fde2f48ff3816d0628bc" + }, + "bit": { + "Package": "bit", + "Version": "4.0.5", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "d242abec29412ce988848d0294b208fd" + }, + "bit64": { + "Package": "bit64", + "Version": "4.0.5", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "bit", + "methods", + "stats", + "utils" + ], + "Hash": "9fe98599ca456d6552421db0d6772d8f" + }, + "bslib": { + "Package": "bslib", + "Version": "0.6.1", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "base64enc", + "cachem", + "grDevices", + "htmltools", + "jquerylib", + "jsonlite", + "lifecycle", + "memoise", + "mime", + "rlang", + "sass" + ], + "Hash": "c0d8599494bc7fb408cd206bbdd9cab0" + }, + "cachem": { + "Package": "cachem", + "Version": "1.0.8", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "fastmap", + "rlang" + ], + "Hash": "c35768291560ce302c0a6589f92e837d" + }, + "callr": { + "Package": "callr", + "Version": "3.7.3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "R6", + "processx", + "utils" + ], + "Hash": "9b2191ede20fa29828139b9900922e51" + }, + "cli": { + "Package": "cli", + "Version": "3.6.2", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "utils" + ], + "Hash": "1216ac65ac55ec0058a6f75d7ca0fd52" + }, + "clipr": { + "Package": "clipr", + "Version": "0.8.0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "utils" + ], + "Hash": "3f038e5ac7f41d4ac41ce658c85e3042" + }, + "cluster": { + "Package": "cluster", + "Version": "2.1.4", "Source": "Repository", "Repository": "CRAN", - "Hash": "e031418365a7f7a766181ab5a41a5716", - "Requirements": [] + "Requirements": [ + "R", + "grDevices", + "graphics", + "stats", + "utils" + ], + "Hash": "5edbbabab6ce0bf7900a74fd4358628e" + }, + "codetools": { + "Package": "codetools", + "Version": "0.2-19", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "c089a619a7fae175d149d89164f8c7d8" + }, + "colorspace": { + "Package": "colorspace", + "Version": "2.1-0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "grDevices", + "graphics", + "methods", + "stats" + ], + "Hash": "f20c47fd52fae58b4e377c37bb8c335b" + }, + "commonmark": { + "Package": "commonmark", + "Version": "1.9.0", + "Source": "Repository", + "Repository": "CRAN", + "Hash": "d691c61bff84bd63c383874d2d0c3307" + }, + "cpp11": { + "Package": "cpp11", + "Version": "0.4.7", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "5a295d7d963cc5035284dcdbaf334f4e" + }, + "crayon": { + "Package": "crayon", + "Version": "1.5.2", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "grDevices", + "methods", + "utils" + ], + "Hash": "e8a1e41acf02548751f45c718d55aa6a" + }, + "crosstalk": { + "Package": "crosstalk", + "Version": "1.2.1", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R6", + "htmltools", + "jsonlite", + "lazyeval" + ], + "Hash": "ab12c7b080a57475248a30f4db6298c0" + }, + "curl": { + "Package": "curl", + "Version": "5.2.0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "ce88d13c0b10fe88a37d9c59dba2d7f9" + }, + "data.table": { + "Package": "data.table", + "Version": "1.14.10", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "methods" + ], + "Hash": "6ea17a32294d8ca00455825ab0cf71b9" }, "datadr": { "Package": "datadr", @@ -64,37 +377,144 @@ "RemoteUsername": "delta-rho", "RemoteRef": "HEAD", "RemoteSha": "f3ffebd8e1c43a5d11cd3543bbe672c88f8c52f3", - "Hash": "4ddf60dd3cd5d3baf559f44d872fc74e", "Requirements": [ - "dplyr" - ] + "codetools", + "data.table", + "digest", + "dplyr", + "hexbin", + "magrittr", + "methods", + "parallel" + ], + "Hash": "4ddf60dd3cd5d3baf559f44d872fc74e" + }, + "digest": { + "Package": "digest", + "Version": "0.6.34", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "utils" + ], + "Hash": "7ede2ee9ea8d3edbf1ca84c1e333ad1a" }, "dplyr": { "Package": "dplyr", - "Version": "1.0.7", + "Version": "1.1.4", "Source": "Repository", "Repository": "CRAN", - "Hash": "36f1ae62f026c8ba9f9b5c9a08c03297", "Requirements": [ + "R", + "R6", + "cli", + "generics", + "glue", + "lifecycle", + "magrittr", + "methods", + "pillar", "rlang", - "tibble" - ] + "tibble", + "tidyselect", + "utils", + "vctrs" + ], + "Hash": "fedd9d00c2944ff00a0e2696ccf048ec" + }, + "ellipsis": { + "Package": "ellipsis", + "Version": "0.3.2", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "rlang" + ], + "Hash": "bb0eec2fe32e88d9e2836c2f73ea2077" + }, + "evaluate": { + "Package": "evaluate", + "Version": "0.23", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "methods" + ], + "Hash": "daf4a1246be12c1fa8c7705a0935c1a0" + }, + "fansi": { + "Package": "fansi", + "Version": "1.0.6", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "grDevices", + "utils" + ], + "Hash": "962174cf2aeb5b9eea581522286a911f" + }, + "farver": { + "Package": "farver", + "Version": "2.1.1", + "Source": "Repository", + "Repository": "CRAN", + "Hash": "8106d78941f34855c440ddb946b8f7a5" + }, + "fastmap": { + "Package": "fastmap", + "Version": "1.1.1", + "Source": "Repository", + "Repository": "CRAN", + "Hash": "f7736a18de97dea803bde0a2daaafb27" + }, + "fontawesome": { + "Package": "fontawesome", + "Version": "0.5.2", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "htmltools", + "rlang" + ], + "Hash": "c2efdd5f0bcd1ea861c2d4e2a883a67d" + }, + "fs": { + "Package": "fs", + "Version": "1.6.3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "methods" + ], + "Hash": "47b5f30c720c23999b913a1a635cf0bb" }, "ftmsRanalysis": { "Package": "ftmsRanalysis", - "Version": "1.0.0", + "Version": "1.1.0", "Source": "GitHub", + "Remotes": "github::delta-rho/datadr, github::EMSL-Computing/MetaCycData", "RemoteType": "github", "RemoteHost": "api.github.com", "RemoteRepo": "ftmsRanalysis", "RemoteUsername": "EMSL-Computing", - "RemoteRef": "CoreMS-compatibility-rb", - "RemoteSha": "ebc788a659a6a1445374b72025c1838d2c53e22e", - "Hash": "c52c1f930ebc524cbfc331f2ee677d09", + "RemoteRef": "1.1.0", + "RemoteSha": "48167675088e41b0249ea4dd273274535a6a09ba", "Requirements": [ + "R", "RColorBrewer", + "ape", + "data.table", "dplyr", "ggplot2", + "igraph", + "lazyeval", + "magrittr", "plotly", "readr", "reshape2", @@ -102,64 +522,353 @@ "scales", "stringr", "tibble", - "tidyr" - ] + "tidyr", + "vegan" + ], + "Hash": "d0a553102fe7ff130884c1dc7b97ca53" + }, + "generics": { + "Package": "generics", + "Version": "0.1.3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "methods" + ], + "Hash": "15e9634c0fcd294799e9b2e929ed1b86" }, "ggplot2": { "Package": "ggplot2", - "Version": "3.3.5", + "Version": "3.4.4", "Source": "Repository", "Repository": "CRAN", - "Hash": "d7566c471c7b17e095dd023b9ef155ad", "Requirements": [ + "MASS", + "R", + "cli", + "glue", + "grDevices", + "grid", + "gtable", + "isoband", + "lifecycle", + "mgcv", "rlang", "scales", + "stats", "tibble", + "vctrs", "withr" - ] + ], + "Hash": "313d31eff2274ecf4c1d3581db7241f9" + }, + "glue": { + "Package": "glue", + "Version": "1.7.0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "methods" + ], + "Hash": "e0b3a53876554bd45879e596cdb10a52" + }, + "gtable": { + "Package": "gtable", + "Version": "0.3.4", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "cli", + "glue", + "grid", + "lifecycle", + "rlang" + ], + "Hash": "b29cf3031f49b04ab9c852c912547eef" + }, + "here": { + "Package": "here", + "Version": "1.0.1", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "rprojroot" + ], + "Hash": "24b224366f9c2e7534d2344d10d59211" + }, + "hexbin": { + "Package": "hexbin", + "Version": "1.28.3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "grDevices", + "graphics", + "grid", + "lattice", + "methods", + "stats", + "utils" + ], + "Hash": "124e384c01d8746f1c12f9dc1b80a161" + }, + "highr": { + "Package": "highr", + "Version": "0.10", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "xfun" + ], + "Hash": "06230136b2d2b9ba5805e1963fa6e890" + }, + "hms": { + "Package": "hms", + "Version": "1.1.3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "lifecycle", + "methods", + "pkgconfig", + "rlang", + "vctrs" + ], + "Hash": "b59377caa7ed00fa41808342002138f9" + }, + "htmltools": { + "Package": "htmltools", + "Version": "0.5.7", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "base64enc", + "digest", + "ellipsis", + "fastmap", + "grDevices", + "rlang", + "utils" + ], + "Hash": "2d7b3857980e0e0d0a1fd6f11928ab0f" }, "htmlwidgets": { "Package": "htmlwidgets", - "Version": "1.5.4", + "Version": "1.6.4", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "grDevices", + "htmltools", + "jsonlite", + "knitr", + "rmarkdown", + "yaml" + ], + "Hash": "04291cc45198225444a397606810ac37" + }, + "httpuv": { + "Package": "httpuv", + "Version": "1.6.13", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "R6", + "Rcpp", + "later", + "promises", + "utils" + ], + "Hash": "d23d2879001f3d82ee9dc38a9ef53c4c" + }, + "httr": { + "Package": "httr", + "Version": "1.4.7", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "R6", + "curl", + "jsonlite", + "mime", + "openssl" + ], + "Hash": "ac107251d9d9fd72f0ca8049988f1d7f" + }, + "igraph": { + "Package": "igraph", + "Version": "1.5.1", "Source": "Repository", "Repository": "CRAN", - "Hash": "76147821cd3fcd8c4b04e1ef0498e7fb", "Requirements": [ - "jsonlite" - ] + "Matrix", + "R", + "cli", + "cpp11", + "grDevices", + "graphics", + "lifecycle", + "magrittr", + "methods", + "pkgconfig", + "rlang", + "stats", + "utils" + ], + "Hash": "80401cb5ec513e8ddc56764d03f63669" + }, + "isoband": { + "Package": "isoband", + "Version": "0.2.7", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "grid", + "utils" + ], + "Hash": "0080607b4a1a7b28979aecef976d8bc2" + }, + "jquerylib": { + "Package": "jquerylib", + "Version": "0.1.4", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "htmltools" + ], + "Hash": "5aab57a3bd297eee1c1d862735972182" }, "jsonlite": { "Package": "jsonlite", - "Version": "1.7.2", + "Version": "1.8.8", "Source": "Repository", "Repository": "CRAN", - "Hash": "98138e0994d41508c7a6b84a0600cfcb", - "Requirements": [] + "Requirements": [ + "methods" + ], + "Hash": "e1b9c55281c5adc4dd113652d9e26768" }, "kableExtra": { "Package": "kableExtra", "Version": "1.3.4", "Source": "Repository", "Repository": "CRAN", - "Hash": "49b625e6aabe4c5f091f5850aba8ff78", "Requirements": [ + "R", + "digest", + "glue", + "grDevices", + "graphics", + "htmltools", "knitr", + "magrittr", "rmarkdown", + "rstudioapi", + "rvest", "scales", + "stats", "stringr", - "webshot" - ] + "svglite", + "tools", + "viridisLite", + "webshot", + "xml2" + ], + "Hash": "49b625e6aabe4c5f091f5850aba8ff78" }, "knitr": { "Package": "knitr", - "Version": "1.37", + "Version": "1.45", "Source": "Repository", "Repository": "CRAN", - "Hash": "a4ec675eb332a33fe7b7fe26f70e1f98", "Requirements": [ - "stringr", - "xfun" - ] + "R", + "evaluate", + "highr", + "methods", + "tools", + "xfun", + "yaml" + ], + "Hash": "1ec462871063897135c1bcbe0fc8f07d" + }, + "labeling": { + "Package": "labeling", + "Version": "0.4.3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "graphics", + "stats" + ], + "Hash": "b64ec208ac5bc1852b285f665d6368b3" + }, + "later": { + "Package": "later", + "Version": "1.3.2", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "Rcpp", + "rlang" + ], + "Hash": "a3e051d405326b8b0012377434c62b37" + }, + "lattice": { + "Package": "lattice", + "Version": "0.20-45", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "grDevices", + "graphics", + "grid", + "stats", + "utils" + ], + "Hash": "b64cdbb2b340437c4ee047a1f4c4377b" + }, + "lazyeval": { + "Package": "lazyeval", + "Version": "0.2.2", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "d908914ae53b04d4c0c0fd72ecc35370" + }, + "lifecycle": { + "Package": "lifecycle", + "Version": "1.0.4", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "cli", + "glue", + "rlang" + ], + "Hash": "b8552d117e1b808b09a832f589b79035" + }, + "magrittr": { + "Package": "magrittr", + "Version": "2.0.3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "7ce2733a9826b3aeb1775d56fd305472" }, "mapDataAccess": { "Package": "mapDataAccess", @@ -170,258 +879,920 @@ "RemoteRepo": "mapdataaccess-lib", "RemoteUsername": "multiomics-analyses", "RemoteRef": "HEAD", - "RemoteSha": "12e6bd1e85a406a0d28b636f8c23754d81745ac5", - "Hash": "16970b5f8a17a3d5e2dc74911b59c0b2", + "RemoteSha": "0737a77df7767bbfd7fcf8b4daca70007c5321db", "Requirements": [ - "reticulate" - ] + "magrittr", + "reticulate", + "uuid", + "yaml" + ], + "Hash": "9afd5cd45e65f8f1155d2bb25ade058f" }, "markdown": { "Package": "markdown", - "Version": "1.1", + "Version": "1.12", "Source": "Repository", "Repository": "CRAN", - "Hash": "61e4a10781dd00d7d81dd06ca9b94e95", "Requirements": [ + "R", + "commonmark", + "utils", "xfun" - ] + ], + "Hash": "765cf53992401b3b6c297b69e1edb8bd" + }, + "memoise": { + "Package": "memoise", + "Version": "2.0.1", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "cachem", + "rlang" + ], + "Hash": "e2817ccf4a065c5d9d7f2cfbe7c1d78c" + }, + "mgcv": { + "Package": "mgcv", + "Version": "1.8-42", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "Matrix", + "R", + "graphics", + "methods", + "nlme", + "splines", + "stats", + "utils" + ], + "Hash": "3460beba7ccc8946249ba35327ba902a" + }, + "mime": { + "Package": "mime", + "Version": "0.12", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "tools" + ], + "Hash": "18e9c28c1d3ca1560ce30658b22ce104" + }, + "munsell": { + "Package": "munsell", + "Version": "0.5.0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "colorspace", + "methods" + ], + "Hash": "6dfe8bf774944bd5595785e3229d8771" + }, + "nlme": { + "Package": "nlme", + "Version": "3.1-162", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "graphics", + "lattice", + "stats", + "utils" + ], + "Hash": "0984ce8da8da9ead8643c5cbbb60f83e" + }, + "openssl": { + "Package": "openssl", + "Version": "2.1.1", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "askpass" + ], + "Hash": "2a0dc8c6adfb6f032e4d4af82d258ab5" }, "pander": { "Package": "pander", - "Version": "0.6.4", + "Version": "0.6.5", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "Rcpp", + "digest", + "grDevices", + "graphics", + "methods", + "stats", + "tools", + "utils" + ], + "Hash": "737924139a1e4fc96356ff377c754c35" + }, + "permute": { + "Package": "permute", + "Version": "0.9-7", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "stats" + ], + "Hash": "abf0ca85c1c752e0d04f46334e635046" + }, + "pillar": { + "Package": "pillar", + "Version": "1.9.0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "cli", + "fansi", + "glue", + "lifecycle", + "rlang", + "utf8", + "utils", + "vctrs" + ], + "Hash": "15da5a8412f317beeee6175fbc76f4bb" + }, + "pkgconfig": { + "Package": "pkgconfig", + "Version": "2.0.3", "Source": "Repository", "Repository": "CRAN", - "Hash": "0eae8a954e0c51bd356f8c6f0e00e805", - "Requirements": [] + "Requirements": [ + "utils" + ], + "Hash": "01f28d4278f15c76cddbea05899c5d6f" }, "plotly": { "Package": "plotly", - "Version": "4.9.4.1", + "Version": "4.10.3", "Source": "Repository", "Repository": "CRAN", - "Hash": "af4b92cb3828aa30002e2f945c49c2d7", "Requirements": [ + "R", "RColorBrewer", + "base64enc", + "crosstalk", + "data.table", + "digest", "dplyr", "ggplot2", + "htmltools", "htmlwidgets", + "httr", "jsonlite", + "lazyeval", + "magrittr", + "promises", "purrr", "rlang", "scales", "tibble", - "tidyr" - ] + "tidyr", + "tools", + "vctrs", + "viridisLite" + ], + "Hash": "56914cc61df53f2d0283d5498680867e" + }, + "plyr": { + "Package": "plyr", + "Version": "1.8.9", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "Rcpp" + ], + "Hash": "6b8177fd19982f0020743fadbfdbd933" + }, + "png": { + "Package": "png", + "Version": "0.1-8", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "bd54ba8a0a5faded999a7aab6e46b374" + }, + "prettyunits": { + "Package": "prettyunits", + "Version": "1.2.0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "6b01fc98b1e86c4f705ce9dcfd2f57c7" + }, + "processx": { + "Package": "processx", + "Version": "3.8.3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "R6", + "ps", + "utils" + ], + "Hash": "82d48b1aec56084d9438dbf98087a7e9" + }, + "progress": { + "Package": "progress", + "Version": "1.2.3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "R6", + "crayon", + "hms", + "prettyunits" + ], + "Hash": "f4625e061cb2865f111b47ff163a5ca6" + }, + "promises": { + "Package": "promises", + "Version": "1.2.1", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R6", + "Rcpp", + "fastmap", + "later", + "magrittr", + "rlang", + "stats" + ], + "Hash": "0d8a15c9d000970ada1ab21405387dee" + }, + "ps": { + "Package": "ps", + "Version": "1.7.6", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "utils" + ], + "Hash": "dd2b9319ee0656c8acf45c7f40c59de7" }, "purrr": { "Package": "purrr", - "Version": "0.3.4", + "Version": "1.0.2", "Source": "Repository", "Repository": "CRAN", - "Hash": "97def703420c8ab10d8f0e6c72101e02", "Requirements": [ - "rlang" - ] + "R", + "cli", + "lifecycle", + "magrittr", + "rlang", + "vctrs" + ], + "Hash": "1cba04a4e9414bdefc9dcaa99649a8dc" + }, + "rappdirs": { + "Package": "rappdirs", + "Version": "0.3.3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "5e3c5dc0b071b21fa128676560dbe94d" }, "raster": { "Package": "raster", - "Version": "3.4-13", + "Version": "3.6-26", "Source": "Repository", "Repository": "CRAN", - "Hash": "4543b272b756a4ff0f80370c886ef90a", "Requirements": [ - "sp" - ] + "R", + "Rcpp", + "methods", + "sp", + "terra" + ], + "Hash": "7d6eda494f34a644420ac1bfd2a8023a" }, "readr": { "Package": "readr", - "Version": "2.0.2", + "Version": "2.1.5", "Source": "Repository", "Repository": "CRAN", - "Hash": "7cb2c3ecfbc2c6786221d2c0c1f6ed68", "Requirements": [ + "R", + "R6", + "cli", + "clipr", + "cpp11", + "crayon", + "hms", + "lifecycle", + "methods", "rlang", - "tibble" - ] + "tibble", + "tzdb", + "utils", + "vroom" + ], + "Hash": "9de96463d2117f6ac49980577939dfb3" }, "renv": { "Package": "renv", - "Version": "0.15.4", + "Version": "1.0.3", "Source": "Repository", "Repository": "CRAN", - "Hash": "c1078316e1d4f70275fc1ea60c0bc431", - "Requirements": [] + "Requirements": [ + "utils" + ], + "Hash": "41b847654f567341725473431dd0d5ab" }, "reshape2": { "Package": "reshape2", "Version": "1.4.4", "Source": "Repository", "Repository": "CRAN", - "Hash": "bb5996d0bd962d214a11140d77589917", "Requirements": [ + "R", + "Rcpp", + "plyr", "stringr" - ] + ], + "Hash": "bb5996d0bd962d214a11140d77589917" }, "reticulate": { "Package": "reticulate", - "Version": "1.22", + "Version": "1.34.0", "Source": "Repository", "Repository": "CRAN", - "Hash": "b34a8bb69005168078d1d546a53912b2", "Requirements": [ + "Matrix", + "R", + "Rcpp", + "RcppTOML", + "graphics", + "here", "jsonlite", + "methods", + "png", + "rappdirs", + "rlang", + "utils", "withr" - ] + ], + "Hash": "a69f815bcba8a055de0b08339b943f9e" }, "rlang": { "Package": "rlang", - "Version": "1.0.5", + "Version": "1.1.3", "Source": "Repository", "Repository": "CRAN", - "Hash": "971c3d698fc06dabdac6bc4bcda72dc4", - "Requirements": [] + "Requirements": [ + "R", + "utils" + ], + "Hash": "42548638fae05fd9a9b5f3f437fbbbe2" }, "rmarkdown": { "Package": "rmarkdown", - "Version": "2.13", + "Version": "2.25", "Source": "Repository", "Repository": "CRAN", - "Hash": "ac78f4d2e0289d4cba73b88af567b8b1", "Requirements": [ + "R", + "bslib", + "evaluate", + "fontawesome", + "htmltools", + "jquerylib", "jsonlite", "knitr", + "methods", "stringr", - "xfun" - ] + "tinytex", + "tools", + "utils", + "xfun", + "yaml" + ], + "Hash": "d65e35823c817f09f4de424fcdfa812a" + }, + "rprojroot": { + "Package": "rprojroot", + "Version": "2.0.4", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "4c8415e0ec1e29f3f4f6fc108bef0144" + }, + "rstudioapi": { + "Package": "rstudioapi", + "Version": "0.15.0", + "Source": "Repository", + "Repository": "CRAN", + "Hash": "5564500e25cffad9e22244ced1379887" + }, + "rvest": { + "Package": "rvest", + "Version": "1.0.3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "cli", + "glue", + "httr", + "lifecycle", + "magrittr", + "rlang", + "selectr", + "tibble", + "withr", + "xml2" + ], + "Hash": "a4a5ac819a467808c60e36e92ddf195e" + }, + "sass": { + "Package": "sass", + "Version": "0.4.8", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R6", + "fs", + "htmltools", + "rappdirs", + "rlang" + ], + "Hash": "168f9353c76d4c4b0a0bbf72e2c2d035" }, "scales": { "Package": "scales", - "Version": "1.1.1", + "Version": "1.3.0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "R6", + "RColorBrewer", + "cli", + "farver", + "glue", + "labeling", + "lifecycle", + "munsell", + "rlang", + "viridisLite" + ], + "Hash": "c19df082ba346b0ffa6f833e92de34d1" + }, + "selectr": { + "Package": "selectr", + "Version": "0.4-2", "Source": "Repository", "Repository": "CRAN", - "Hash": "6f76f71042411426ec8df6c54f34e6dd", "Requirements": [ - "RColorBrewer" - ] + "R", + "R6", + "methods", + "stringr" + ], + "Hash": "3838071b66e0c566d55cc26bd6e27bf4" }, "shiny": { "Package": "shiny", - "Version": "1.6.0", + "Version": "1.8.0", "Source": "Repository", "Repository": "CRAN", - "Hash": "6e3b6ae7fe02b5859e4bb277f218b8ae", "Requirements": [ + "R", + "R6", + "bslib", + "cachem", + "commonmark", + "crayon", + "ellipsis", + "fastmap", + "fontawesome", + "glue", + "grDevices", + "htmltools", + "httpuv", "jsonlite", + "later", + "lifecycle", + "methods", + "mime", + "promises", "rlang", - "withr" - ] + "sourcetools", + "tools", + "utils", + "withr", + "xtable" + ], + "Hash": "3a1f41807d648a908e3c7f0334bf85e6" }, "shinyBS": { "Package": "shinyBS", - "Version": "0.61", + "Version": "0.61.1", "Source": "Repository", "Repository": "CRAN", - "Hash": "f895dafd39733c4a70d425f605a832e7", "Requirements": [ + "htmltools", "shiny" - ] + ], + "Hash": "e44255f073ecdc26ba6bc2ce3fcf174d" }, "shinyWidgets": { "Package": "shinyWidgets", - "Version": "0.6.2", + "Version": "0.8.1", "Source": "Repository", "Repository": "CRAN", - "Hash": "9bdabea3a78fd6a0768c2a319d36264e", "Requirements": [ + "R", + "anytime", + "bslib", + "grDevices", + "htmltools", "jsonlite", + "rlang", + "sass", "shiny" - ] + ], + "Hash": "96bb249d21b7473dbeb0311702ef5288" }, "shinycssloaders": { "Package": "shinycssloaders", "Version": "1.0.0", "Source": "Repository", "Repository": "CRAN", - "Hash": "f39bb3c44a9b496723ec7e86f9a771d8", "Requirements": [ + "R", + "digest", + "glue", + "grDevices", "shiny" - ] + ], + "Hash": "f39bb3c44a9b496723ec7e86f9a771d8" }, "shinyjs": { "Package": "shinyjs", - "Version": "2.0.0", + "Version": "2.1.0", "Source": "Repository", "Repository": "CRAN", - "Hash": "9ddfc91d4280eaa34c2103951538976f", "Requirements": [ + "R", + "digest", "jsonlite", "shiny" - ] + ], + "Hash": "802e4786b353a4bb27116957558548d5" + }, + "sourcetools": { + "Package": "sourcetools", + "Version": "0.1.7-1", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "5f5a7629f956619d519205ec475fe647" }, "sp": { "Package": "sp", - "Version": "1.4-5", + "Version": "2.1-2", "Source": "Repository", "Repository": "CRAN", - "Hash": "dfd843ee98246cf932823acf613b05dd", - "Requirements": [] + "Requirements": [ + "R", + "grDevices", + "graphics", + "grid", + "lattice", + "methods", + "stats", + "utils" + ], + "Hash": "40a9887191d33b2521a1d741f8c8aea2" + }, + "stringi": { + "Package": "stringi", + "Version": "1.8.3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "stats", + "tools", + "utils" + ], + "Hash": "058aebddea264f4c99401515182e656a" }, "stringr": { "Package": "stringr", - "Version": "1.4.0", + "Version": "1.5.1", "Source": "Repository", "Repository": "CRAN", - "Hash": "0759e6b6c0957edb1311028a49a35e76", - "Requirements": [] + "Requirements": [ + "R", + "cli", + "glue", + "lifecycle", + "magrittr", + "rlang", + "stringi", + "vctrs" + ], + "Hash": "960e2ae9e09656611e0b8214ad543207" + }, + "svglite": { + "Package": "svglite", + "Version": "2.1.3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "cpp11", + "systemfonts" + ], + "Hash": "124a41fdfa23e8691cb744c762f10516" + }, + "sys": { + "Package": "sys", + "Version": "3.4.2", + "Source": "Repository", + "Repository": "CRAN", + "Hash": "3a1be13d68d47a8cd0bfd74739ca1555" + }, + "systemfonts": { + "Package": "systemfonts", + "Version": "1.0.5", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "cpp11" + ], + "Hash": "15b594369e70b975ba9f064295983499" + }, + "terra": { + "Package": "terra", + "Version": "1.7-65", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "Rcpp", + "methods" + ], + "Hash": "8e245fd4eab07bf55ddb2e6ea353c0e1" }, "tibble": { "Package": "tibble", - "Version": "3.1.5", + "Version": "3.2.1", "Source": "Repository", "Repository": "CRAN", - "Hash": "36eb05ad4cfdfeaa56f5a9b2a1311efd", "Requirements": [ - "rlang" - ] + "R", + "fansi", + "lifecycle", + "magrittr", + "methods", + "pillar", + "pkgconfig", + "rlang", + "utils", + "vctrs" + ], + "Hash": "a84e2cc86d07289b3b6f5069df7a004c" }, "tidyr": { "Package": "tidyr", - "Version": "1.1.4", + "Version": "1.3.0", "Source": "Repository", "Repository": "CRAN", - "Hash": "c8fbdbd9fcac223d6c6fe8e406f368e1", "Requirements": [ + "R", + "cli", + "cpp11", "dplyr", + "glue", + "lifecycle", + "magrittr", "purrr", "rlang", - "tibble" - ] + "stringr", + "tibble", + "tidyselect", + "utils", + "vctrs" + ], + "Hash": "e47debdc7ce599b070c8e78e8ac0cfcf" + }, + "tidyselect": { + "Package": "tidyselect", + "Version": "1.2.0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "cli", + "glue", + "lifecycle", + "rlang", + "vctrs", + "withr" + ], + "Hash": "79540e5fcd9e0435af547d885f184fd5" + }, + "tinytex": { + "Package": "tinytex", + "Version": "0.49", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "xfun" + ], + "Hash": "5ac22900ae0f386e54f1c307eca7d843" + }, + "tzdb": { + "Package": "tzdb", + "Version": "0.4.0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "cpp11" + ], + "Hash": "f561504ec2897f4d46f0c7657e488ae1" + }, + "utf8": { + "Package": "utf8", + "Version": "1.2.4", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "62b65c52671e6665f803ff02954446e9" + }, + "uuid": { + "Package": "uuid", + "Version": "1.1-1", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "3d78edfb977a69fc7a0341bee25e163f" + }, + "vctrs": { + "Package": "vctrs", + "Version": "0.6.5", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "cli", + "glue", + "lifecycle", + "rlang" + ], + "Hash": "c03fa420630029418f7e6da3667aac4a" + }, + "vegan": { + "Package": "vegan", + "Version": "2.6-4", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "MASS", + "R", + "cluster", + "lattice", + "mgcv", + "permute" + ], + "Hash": "659fe7589b8e0b16baa49043a61a0ce0" + }, + "viridisLite": { + "Package": "viridisLite", + "Version": "0.4.2", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R" + ], + "Hash": "c826c7c4241b6fc89ff55aaea3fa7491" + }, + "vroom": { + "Package": "vroom", + "Version": "1.6.5", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "bit64", + "cli", + "cpp11", + "crayon", + "glue", + "hms", + "lifecycle", + "methods", + "progress", + "rlang", + "stats", + "tibble", + "tidyselect", + "tzdb", + "vctrs", + "withr" + ], + "Hash": "390f9315bc0025be03012054103d227c" }, "webshot": { "Package": "webshot", - "Version": "0.5.2", + "Version": "0.5.5", "Source": "Repository", "Repository": "CRAN", - "Hash": "e99d80ad34457a4853674e89d5e806de", "Requirements": [ - "jsonlite" - ] + "R", + "callr", + "jsonlite", + "magrittr" + ], + "Hash": "16858ee1aba97f902d24049d4a44ef16" }, "withr": { "Package": "withr", - "Version": "2.5.0", + "Version": "3.0.0", "Source": "Repository", "Repository": "CRAN", - "Hash": "c0e49a9760983e81e55cdd9be92e7182", - "Requirements": [] + "Requirements": [ + "R", + "grDevices", + "graphics" + ], + "Hash": "d31b6c62c10dcf11ec530ca6b0dd5d35" }, "xfun": { "Package": "xfun", - "Version": "0.30", + "Version": "0.41", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "stats", + "tools" + ], + "Hash": "460a5e0fe46a80ef87424ad216028014" + }, + "xml2": { + "Package": "xml2", + "Version": "1.3.6", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "cli", + "methods", + "rlang" + ], + "Hash": "1d0336142f4cd25d8d23cd3ba7a8fb61" + }, + "xtable": { + "Package": "xtable", + "Version": "1.8-4", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "stats", + "utils" + ], + "Hash": "b8acdf8af494d9ec19ccb2481a9b11c2" + }, + "yaml": { + "Package": "yaml", + "Version": "2.3.8", "Source": "Repository", "Repository": "CRAN", - "Hash": "e83f48136b041845e50a6658feffb197", - "Requirements": [] + "Hash": "29240487a071f535f5e5d5a323b7afbd" } } } diff --git a/renv_dependencies.R b/renv_dependencies.R deleted file mode 100644 index 2c14138..0000000 --- a/renv_dependencies.R +++ /dev/null @@ -1,11 +0,0 @@ -#'This script is never actually run, it is for packages that need to be captured -#'in a snapshot() but we dont actually want to call library() for in the app. -#'For example datadr is only suggested by ftmsRanalysis, but is called in the -#'app by one of ftmsRanalysis' functions. -#' -#'Other libraries need to be included so that the correct version installs. For -#'some reason 'xfun' is not updated to the correct version for rmarkdown. - -library(datadr) -library(xfun) -library(kableExtra) From 0283854e87e1d75ec77781f7dafa02dceab02f1c Mon Sep 17 00:00:00 2001 From: Daniel Claborne Date: Thu, 18 Jan 2024 15:03:01 -0800 Subject: [PATCH 18/20] add DESCRIPTION file --- DESCRIPTION | 50 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 50 insertions(+) create mode 100644 DESCRIPTION diff --git a/DESCRIPTION b/DESCRIPTION new file mode 100644 index 0000000..90d3f95 --- /dev/null +++ b/DESCRIPTION @@ -0,0 +1,50 @@ +Package: FREDA +Title: An app for the processing and visualization of Fourier-transform mass spectrometry data. +Version: 1.7 +Authors@R: + person("Daniel", "Claborne", "daniel.claborne@pnnl.gov", role = c("aut", "cre")) +Description: A frontend application which exposes functionality of the ftmsRanalysis R package. See +License: GPL (>= 3) + file LICENSE +Encoding: UTF-8 +Roxygen: list(markdown = TRUE) +RoxygenNote: 7.2.1 +Depends: + R (>= 4.1.0) +Imports: + dplyr, + DT, + ggplot2, + htmlwidgets, + jsonlite, + kableExtra, + KeggData, + knitr, + markdown, + pander, + plotly, + purrr, + raster, + RColorBrewer, + readr, + reshape2, + reticulate, + rlang, + rmarkdown, + scales, + shiny, + shinyBS, + shinycssloaders, + shinyjs, + shinyWidgets, + sp, + stringr, + tibble, + tidyr, + webshot, + withr, + xfun, + MetaCycData, + mapDataAccess, + ftmsRanalysis, + datadr + From 05afcc8cabcc2f8aa914a4efe0a98fc88e9d83f6 Mon Sep 17 00:00:00 2001 From: Daniel Claborne Date: Thu, 18 Jan 2024 15:07:33 -0800 Subject: [PATCH 19/20] update docker and renv instructions --- DESCRIPTION | 4 ++-- Docker_instructions.md | 11 ----------- README.md | 6 ++---- resources_and_contact.md | 3 +-- 4 files changed, 5 insertions(+), 19 deletions(-) delete mode 100644 Docker_instructions.md diff --git a/DESCRIPTION b/DESCRIPTION index 90d3f95..2cd28f9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: FREDA Title: An app for the processing and visualization of Fourier-transform mass spectrometry data. Version: 1.7 -Authors@R: - person("Daniel", "Claborne", "daniel.claborne@pnnl.gov", role = c("aut", "cre")) +Authors@R: c(person("Lisa", "Bramer", "lisa.bramer@pnnl.gov", role = "aut", "cre"), + person("Daniel", "Claborne", "daniel.claborne@pnnl.gov", role = c("aut"))) Description: A frontend application which exposes functionality of the ftmsRanalysis R package. See License: GPL (>= 3) + file LICENSE Encoding: UTF-8 diff --git a/Docker_instructions.md b/Docker_instructions.md deleted file mode 100644 index 49b3b48..0000000 --- a/Docker_instructions.md +++ /dev/null @@ -1,11 +0,0 @@ -# Instructions for using the FREDA Docker container - -0. Be using a Mac, not Windows. :-) -1. Clone the FREDA repository from github at: https://github.com/lmbramer/FREDA. Check out the docker branch. -2. Install Docker Desktop: https://hub.docker.com/ -3. At the bash prompt in the directory where FREDA was cloned execute these commands: - * docker pull rocker/shiny-verse - * docker build -t freda:latest . - * docker run -p 3838:3838 -u shiny -e APPLICATION_LOGS_TO_STDOUT=false -v /tmp:/var/log/shiny-server freda -4. In a browser navigate to http://localhost:3838/FREDA/ -5. To halt the Docker container and stop the FREDA app, hit Ctrl-C in the Terminal window. (Yes Ctrl not Cmd.) \ No newline at end of file diff --git a/README.md b/README.md index 99a3dc4..35bc887 100644 --- a/README.md +++ b/README.md @@ -92,10 +92,8 @@ If all is well, push new containers to the registry: We use [renv](https://rstudio.github.io/renv/articles/renv.html) to track dependencies. The renv.lock file contains a list of dependencies and various details about them. We use renv to manage the details about dependencies. When updating the lockfile, we will do the following: -1. Set renv to only install sub-dependencies in the "Depends" field of installed packages. `renv::settings$package.dependency.fields("Depends")`. This should get recorded in ./renv/settings.dcf so you only have to do it once. -2. Snapshot only packages mentioned in the project, as well as any packages mentioned in their "Depends" field by calling `renv::snapshot(type="implicit")` - -Certain dependencies are forced to be recognized by renv without being explicitly loaded in the app by adding `library(somepackage)` to `renv_dependencies.R` +1. Set renv to only install sub-dependencies in the "Depends", "Imports", and "LinkingTo field of installed packages. `renv::settings$package.dependency.fields(c("Depends", "Imports", "LinkingTo))`. This should get recorded in ./renv/settings.dcf so you only have to do it once. +2. Snapshot only packages mentioned in the DESCRIPTION, as well as any packages mentioned in their "Depends", "Imports", and "LinkingTo fields by calling `renv::snapshot(type="implicit")`. #### **Misc** diff --git a/resources_and_contact.md b/resources_and_contact.md index 770ba67..cdeda1d 100644 --- a/resources_and_contact.md +++ b/resources_and_contact.md @@ -16,8 +16,7 @@ A publication is forthcoming for FREDA. In the meantime, we ask that you cite F ### **Using FREDA Locally** -You can use FREDA locally via a Docker container. Instructions for deploying locally on a Mac can be found here -*** +You can use FREDA locally via a Docker container. Instructions for building and running the container can be found in the "Using docker" section of the README.md ### **Contact Information** From 9da191853a3d4b514e039e412a854b5d5913b143 Mon Sep 17 00:00:00 2001 From: Daniel Claborne Date: Fri, 19 Jan 2024 13:54:29 -0800 Subject: [PATCH 20/20] Switch to kaleido from orca update Dockerfiles --- DESCRIPTION | 1 + Dockerfile | 2 +- Dockerfile-base | 37 ++++++++-------------------------- Observers/corems_observers.R | 2 +- Observers/download_observers.R | 4 +++- docker-compose-freda.yml | 4 +++- python_requirements.txt | 5 ++++- renv.lock | 27 +++++++++++++++++++++++++ 8 files changed, 48 insertions(+), 34 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 2cd28f9..b356a7d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -40,6 +40,7 @@ Imports: stringr, tibble, tidyr, + viridis, webshot, withr, xfun, diff --git a/Dockerfile b/Dockerfile index ef161ac..eca1d2c 100644 --- a/Dockerfile +++ b/Dockerfile @@ -15,4 +15,4 @@ COPY . /srv/shiny-server/FREDA COPY shiny-server.conf /etc/shiny-server/shiny-server.conf # App is run as user shiny, need to change ownership -RUN chown -R shiny:shiny /srv/shiny-server/FREDA /opt/orca/squashfs-root +RUN chown -R shiny:shiny /srv/shiny-server/FREDA diff --git a/Dockerfile-base b/Dockerfile-base index cfae471..15cef6c 100644 --- a/Dockerfile-base +++ b/Dockerfile-base @@ -1,4 +1,4 @@ -FROM rocker/shiny:4.1.1 +FROM rocker/shiny:4.2.3 RUN apt-get update -qq && apt-get install -y \ git-core \ @@ -6,18 +6,21 @@ RUN apt-get update -qq && apt-get install -y \ libcurl4-gnutls-dev \ libmagick++-dev \ libv8-dev \ - vim python3-venv + vim python3-venv \ + libgdal-dev WORKDIR /srv/shiny-server/ -COPY renv.lock . # pre-install renv -RUN R -e "install.packages('renv', repos = 'https://cran.rstudio.com')" +ENV RENV_VERSION 1.0.3 +RUN R -e "install.packages('remotes', repos = c(CRAN = 'https://cloud.r-project.org'))" +RUN R -e "options('repos'=c(CRAN = 'https://cloud.r-project.org'));remotes::install_version('renv', version = '${RENV_VERSION}')" # install all packages listed in renv.lock +COPY renv.lock . RUN --mount=type=secret,id=access_tokens set -a \ && . /run/secrets/access_tokens && set +a \ -&& R -e 'renv::restore()' +&& R -e 'options(renv.config.connect.timeout=300);options(timeout=300);renv::restore()' ## Setup Python venv ## USER root @@ -25,28 +28,4 @@ COPY python_requirements.txt . RUN python3 -m venv /venv RUN /venv/bin/pip install --upgrade pip RUN /venv/bin/pip install -r python_requirements.txt - -# Install all plotly's dependencies -RUN R -e "install.packages('plotly', dependencies = T)" - -# Download orca binary and make it executable under xvfb -RUN apt-get update && \ - apt-get install -y --no-install-recommends \ - xvfb \ - xauth \ - libgtk2.0-0 \ - libxtst6 \ - libxss1 \ - libgconf-2-4 \ - libnss3 \ - libasound2 && \ - mkdir -p /opt/orca && \ - cd /opt/orca && \ - wget https://github.com/plotly/orca/releases/download/v1.2.1/orca-1.2.1-x86_64.AppImage && \ - chmod +x orca-1.2.1-x86_64.AppImage && \ - ./orca-1.2.1-x86_64.AppImage --appimage-extract && \ - rm orca-1.2.1-x86_64.AppImage && \ - printf '#!/bin/bash \nxvfb-run --auto-servernum --server-args "-screen 0 640x480x24" /opt/orca/squashfs-root/app/orca "$@"' > /usr/bin/orca && \ - chmod +x /usr/bin/orca && \ - apt-get remove -y libnode-dev \ No newline at end of file diff --git a/Observers/corems_observers.R b/Observers/corems_observers.R index e85f8c1..2eedcae 100644 --- a/Observers/corems_observers.R +++ b/Observers/corems_observers.R @@ -13,7 +13,7 @@ observeEvent( revals$uploaded_data <- revals$peakData2 <- NULL res <- tryCatch({ - ftmsRanalysis::CoreMSData_to_ftmsData(cms_dat_unq_mf()) + ftmsRanalysis::coreMSDataToFtmsData(cms_dat_unq_mf()) }, error = function(e) { msg = paste0('Error converting your coreMS data to peakData: \n System error: ', e) diff --git a/Observers/download_observers.R b/Observers/download_observers.R index e0be011..4c30bf1 100644 --- a/Observers/download_observers.R +++ b/Observers/download_observers.R @@ -82,6 +82,8 @@ observeEvent(input$makezipfile, { } # + scope <- kaleido() + for (i in plots_marked_for_death) { plot_key = plots$plot_table[i, 1] filename = paste0(plot_key, '.', input$image_format) @@ -90,7 +92,7 @@ observeEvent(input$makezipfile, { if (inherits(plots$plot_list[[plot_key]], 'plotly')) { # using withr until orca handles full paths - withr::with_dir(tempdir(), orca(plots$plot_list[[plot_key]], filename, width = width, height = height, scale = 2)) + scope$transform(plots$plot_list[[plot_key]], path, width = width, height = height, scale = 2) # export(plots$plot_list[[plot_key]], file = path, zoom = 2) # deprecated for some ungodly reason } else if (inherits(plots$plot_list[[plot_key]], 'ggplot')) { diff --git a/docker-compose-freda.yml b/docker-compose-freda.yml index 718e176..3c01ac1 100644 --- a/docker-compose-freda.yml +++ b/docker-compose-freda.yml @@ -3,12 +3,14 @@ version: "3" services: freda: - image: docker.artifactory.pnnl.gov/mscviz/freda:develop.2 + image: docker.artifactory.pnnl.gov/mscviz/freda:develop.corems container_name: freda ports: - "3838:3838" volumes: - "./cfg/minio_config_corems_docker.yml:/srv/shiny-server/FREDA/cfg/minio_config.yml" + environment: + - RETICULATE_PYTHON=/venv/bin/python minio: image: minio/minio container_name: minio-freda diff --git a/python_requirements.txt b/python_requirements.txt index 72aba03..1a8c669 100644 --- a/python_requirements.txt +++ b/python_requirements.txt @@ -1 +1,4 @@ -minio==7.0.2 \ No newline at end of file +minio==7.0.2 +plotly==5.10.0 +kaleido==0.1.0post1; platform_system == "Windows" +kaleido==0.2.1; platform_system != "Windows" \ No newline at end of file diff --git a/renv.lock b/renv.lock index 56b2b77..3363776 100644 --- a/renv.lock +++ b/renv.lock @@ -574,6 +574,20 @@ ], "Hash": "e0b3a53876554bd45879e596cdb10a52" }, + "gridExtra": { + "Package": "gridExtra", + "Version": "2.3", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "grDevices", + "graphics", + "grid", + "gtable", + "utils" + ], + "Hash": "7d7f283939f563670a697165b2cf5560" + }, "gtable": { "Package": "gtable", "Version": "0.3.4", @@ -1690,6 +1704,19 @@ ], "Hash": "659fe7589b8e0b16baa49043a61a0ce0" }, + "viridis": { + "Package": "viridis", + "Version": "0.6.4", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "ggplot2", + "gridExtra", + "viridisLite" + ], + "Hash": "80cd127bc8c9d3d9f0904ead9a9102f1" + }, "viridisLite": { "Package": "viridisLite", "Version": "0.4.2",