diff --git a/R/app_module_profiling.R b/R/app_module_profiling.R index a2fa727..8065546 100644 --- a/R/app_module_profiling.R +++ b/R/app_module_profiling.R @@ -110,6 +110,8 @@ profiling_completeviewUI <- function(id){ ns <- NS(id) tagList( shinycssloaders::withSpinner(trelliscopejs::trelliscopeOutput(ns("trelliscope"))), + uiOutput(ns("trelvizoptions_ui")), + br(), DT::dataTableOutput(ns("complete_profres_tab")) ) } @@ -235,7 +237,7 @@ profilingServer <- function(id, xpmt_data, ref_data, connec){ if(any(temp$`Chemical shift tolerance (ppm)` > round(abs(temp$`ROI right edge (ppm)` - temp$`Chemical shift(ppm)`), 3)) | any(temp$`Chemical shift tolerance (ppm)` > round(abs(temp$`ROI left edge (ppm)` - temp$`Chemical shift(ppm)`), 3))){ badsignals <- paste(temp$SigName[(temp$`Chemical shift tolerance (ppm)` > round(abs(temp$`ROI right edge (ppm)` - temp$`Chemical shift(ppm)`), 3)) | - (temp$`Chemical shift tolerance (ppm)` > round(abs(temp$`ROI left edge (ppm)` - temp$`Chemical shift(ppm)`), 3))], collapse = "; ") + (temp$`Chemical shift tolerance (ppm)` > round(abs(temp$`ROI left edge (ppm)` - temp$`Chemical shift(ppm)`), 3))], collapse = "; ") shinyWidgets::show_alert( title = "Fitting parameter error.", @@ -355,7 +357,8 @@ profilingServer <- function(id, xpmt_data, ref_data, connec){ .data$`Half bandwidth (Hz)`, .data$Multiplicity, .data$`J coupling (Hz)`, .data$`J coupling 2 (Hz)`, .data$`Roof effect`, .data$`Roof effect 2`, .data$`Frequency (MHz)`, .data$`pH`, .data$`Concentration (mM)`, .data$`Temperature (K)`, .data$`Solvent`) - + # temp2 <- dplyr::mutate(temp2, `Quantification Mode` = as.character(selectInput("sel", "", choices = c("Baseline Fitting", "Baseline Sum")))) + #temp2 <- dplyr::mutate(`Quantification Mode` = as.character(for(i in 1:nrow(temp2$Signal)){selectInput(paste0("sel", i), "", choices = c("Baseline Fitting", "Baseline Sum"))})) temp2 %>% DT::datatable(rownames = FALSE, editable = FALSE, @@ -872,13 +875,10 @@ profilingServer <- function(id, xpmt_data, ref_data, connec){ rv <- reactiveValues(obs_show_subplot_suspend = TRUE, new_profiling = FALSE) - output$trelliscope <- trelliscopejs::renderTrelliscope({ - + plot.data <- reactive({ req(user_profiling()) + # browser() # Create a new directory in the temp directory for each new instance of this trelliscope. - treldir <- file.path(tempdir(), paste0("Result_", format(Sys.time(), format = "%H-%m-%s", tz = "UTC"))) - dir.create(treldir) - #browser() user_profiling <- user_profiling() profiling_data = user_profiling signals_to_plot = NULL @@ -891,6 +891,10 @@ profilingServer <- function(id, xpmt_data, ref_data, connec){ # list of number of samples p <- vector(mode = "list", length = nrow(profiling_data$final_output$quantification)) + user_profiling$final_output$quantification <- 1 + #user_profiling$final_output$fitting_error <- user_profiling$final_output$fitting_error[which(user_profiling$final_output$fitting_error > 5)] + + # user_profiling$final_output <- user_profiling$final_output[which(user_profiling$final_output$fitting_error > 0.05)] plotdataall.out <- list() @@ -1007,16 +1011,48 @@ profilingServer <- function(id, xpmt_data, ref_data, connec){ # Add Quantification, Signal to Area Ratio, Fitting Error, Chemical Shift, Intensity, Half Bandwidth - plotdataall2 <- plotdataall %>% dplyr::full_join(temp_quantdat, by = c("Sample", "Signal")) %>% + plot.data <- plotdataall %>% dplyr::full_join(temp_quantdat, by = c("Sample", "Signal")) %>% dplyr::full_join(temp_sardat, by = c("Sample", "Signal")) %>% dplyr::full_join(temp_fedat, by = c("Sample", "Signal")) %>% dplyr::full_join(temp_csdat, by = c("Sample", "Signal")) %>% dplyr::full_join(temp_intdat, by = c("Sample", "Signal")) %>% dplyr::full_join(temp_hwdat, by = c("Sample", "Signal")) - ############################## - # plot.data <- format_plotting(profiling_data = user_profiling) - plot.data <- plotdataall2 + return(plot.data) + }) + ############################## + + # plot.data <- format_plotting(profiling_data = user_profiling) + # plot.data <- plotdataall2 + output$trelliscope <- trelliscopejs::renderTrelliscope({ + #creating temp dir for telliscope + treldir <- file.path(tempdir(), paste0("Result_", format(Sys.time(), format = "%H-%m-%s", tz = "UTC"))) + dir.create(treldir) + filter_trel <- input$filter_trel + isolate(trel_samp <- input$trel_samp) + isolate(trel_fethresh <- input$trel_fethresh) + plot.data <- plot.data() + plot.data <- plot.data[which(plot.data$Sample == trel_samp),] + plot.data <- plot.data[which(plot.data$`Fitting Error` >= trel_fethresh[1] & plot.data$`Fitting Error` <= trel_fethresh[2]),] + if(length(plot.data[,1]) == 0){ + if(filter_trel > 0){ + shinyWidgets::show_alert( + title = "No Data Within Range", + text = "There are no trelliscopes that fit the parameters that you've given. Please change them and Apply Filters", + type = "error" + ) + }} + # if(length(unique(plot.data$Signal) > 1000)){ + # if(filter_trel > 0){ + # shinyWidgets::show_alert( + # title = "Too Many Trelliscopes in Memory", + # text = "The parameters you've given (or the default parameters) generate too many trelliscopes at once (>1000). Please change the parameters and Apply Filters", + # type = "error" + # ) + # }} + req(length(plot.data[,1]) > 0) + # req(length(unique(plot.data$Signal) <= 1000)) + plot.data %>% tidyr::nest(data = !tidyselect::one_of(c("Sample", "Signal"))) %>% dplyr::mutate( @@ -1190,11 +1226,17 @@ profilingServer <- function(id, xpmt_data, ref_data, connec){ h4(), # Toggle for subplot display - shinyWidgets::materialSwitch(inputId = NS(id, "show_subplot"), - label = "Show subplot on box select", - value = FALSE, - status = "primary", - right = TRUE), + fluidRow(column(9, shinyWidgets::materialSwitch(inputId = NS(id, "show_subplot"), + label = "Show subplot on box select", + value = FALSE, + status = "primary", + right = TRUE)), + column(3, actionButton(inputId = NS(id, "show_subplot_help"), + label = "?"))), + shinyBS::bsTooltip(id = NS(id, "show_subplot_help"), + title = "Use the Box Select tool in the upper-right corner of the plot to select a region to be shown in a subplot.", + placement = "bottom", + trigger = "hover"), # HTML output to display the filters currently applied htmlOutput(NS(id, "applied_filters_text")), @@ -1206,6 +1248,33 @@ profilingServer <- function(id, xpmt_data, ref_data, connec){ ) }) + output$trelvizoptions_ui <- renderUI({ + + req(xpmt_data()) + req(ref_data()) + plot.data <- plot.data() + req(!is.null(plot.data)) + #browser() + # Allows users to select which sample spectrum to display. + fluidRow( + column(4, + selectInput(inputId = NS(id, "trel_samp"), + label = "Choose a spectrum to display in the trelliscope", + choices = unique(plot.data$Sample), + selected = unique(plot.data$Sample)[1])), + column(3, + shinyWidgets::numericRangeInput(inputId = NS(id, "trel_fethresh"), + label = "Specify a filter range:", + value = c(0.5,100))), + column(5, + br(), + actionButton(inputId = NS(id, "filter_trel"), + label = "Apply Filter", + style="color: #fff; background-color: #337ab7; border-color: #2e6da4")), + ) + }) + + # Output (in HTML format) to display the filters that are currently applied to the data. output$applied_filters_text <- renderUI({ #browser() @@ -1707,6 +1776,7 @@ profilingServer <- function(id, xpmt_data, ref_data, connec){ # Begin direct pull from rDolphin source code. # We pull directly from source so that we could generate progress bars + signals_names <- make.names(paste(ROI_data[,4], ROI_data[,5], sep='_')) dummy <- matrix(NaN, nrow(imported_data$dataset), length(signals_names), dimnames = list(imported_data$Experiments, signals_names)) @@ -1828,7 +1898,7 @@ profilingServer <- function(id, xpmt_data, ref_data, connec){ signal_index = NULL) # Note that Ydata is internally defined by profiling function despite # what is supplied to the argument above. See automatic_profiling.R and - # profiling_func(). + # profiling_func() final_output <- output$final_output reproducibility_data <- output$reproducibility_data sumit <- sumit + 1 diff --git a/R/app_module_ref_data_modify.R b/R/app_module_ref_data_modify.R index c188e1e..add4100 100644 --- a/R/app_module_ref_data_modify.R +++ b/R/app_module_ref_data_modify.R @@ -129,7 +129,7 @@ ref_data_add_delUI <- function(id){ uiOutput(ns("ui_refmet_add_new_entry")) ) ), - actionButton(ns("refmet_add"), "Add"), + actionButton(ns("refmet_add"), "Add", style="color: #fff; background-color: #337ab7; border-color: #2e6da4"), h4(""), fluidRow( @@ -138,7 +138,7 @@ ref_data_add_delUI <- function(id){ uiOutput(ns("ui_refmet_remove_options")) ) ), - actionButton(ns("refmet_remove"), "Remove"), + actionButton(ns("refmet_remove"), "Remove", style="color: #fff; background-color: #337ab7; border-color: #2e6da4"), h4(""), DT::dataTableOutput(ns("refmet_database")) @@ -666,11 +666,17 @@ ref_data_editingServer <- function(id, xpmt_data, ref_data, ref_db, connec){ choices = unique(ref_data()$bestmatch_ref_data$Metabolite)), # Toggle for subplot display - shinyWidgets::materialSwitch(inputId = NS(id, "show_subplot"), - label = "Show subplot on box select", - value = FALSE, - status = "primary", - right = TRUE), + fluidRow(column(9, shinyWidgets::materialSwitch(inputId = NS(id, "show_subplot"), + label = "Show subplot on box select", + value = FALSE, + status = "primary", + right = TRUE)), + column(3, actionButton(inputId = NS(id, "show_subplot_help"), + label = "?"))), + shinyBS::bsTooltip(id = NS(id, "show_subplot_help"), + title = "Use the Box Select tool in the upper-right corner of the plot to select a region to be shown in a subplot.", + placement = "bottom", + trigger = "hover"), # HTML output to display the filters currently applied @@ -816,7 +822,7 @@ ref_data_editingServer <- function(id, xpmt_data, ref_data, ref_db, connec){ req(rv$unsaved_change[[input$which_refmet_dspedt]]) actionButton(NS(id, "save_refmet_plot_changes"), - label = "Save") + label = "Save", style="color: #fff; background-color: #337ab7; border-color: #2e6da4") }) # Dynamic action button to revert save changes made to plot of reference metabolite @@ -827,7 +833,7 @@ ref_data_editingServer <- function(id, xpmt_data, ref_data, ref_db, connec){ req(rv$change_counter[[input$which_refmet_dspedt]] > 0) actionButton(NS(id, "revert_last_refmet_save_changes"), - label = "Revert Last Save") + label = "Revert Last Save", style="color: #fff; background-color: #337ab7; border-color: #2e6da4") }) # Dynamic action button to revert all save changes made to plot of reference metabolite @@ -846,7 +852,7 @@ ref_data_editingServer <- function(id, xpmt_data, ref_data, ref_db, connec){ req(!identical(og_version, curr_version)) actionButton(NS(id, "revert_all_refmet_save_changes"), - label = "Revert All Saves") + label = "Revert All Saves", style="color: #fff; background-color: #337ab7; border-color: #2e6da4") }) #---------------------------------------------------------------------------------------------------------- @@ -1318,7 +1324,7 @@ ref_data_editingServer <- function(id, xpmt_data, ref_data, ref_db, connec){ ), column( width = 2, - actionButton(NS(id, "show_metquant"), label = "Check Signal Fit") + actionButton(NS(id, "show_metquant"), label = "Check Signal Fit", style="color: #fff; background-color: #337ab7; border-color: #2e6da4") ) ) @@ -1950,7 +1956,7 @@ ref_data_editingServer <- function(id, xpmt_data, ref_data, ref_db, connec){ req(ref_data()) shinyBS::bsCollapse(id = NS(id, "global_fitting_params"), - shinyBS::bsCollapsePanel(title = "Global Profiling Parameters", + shinyBS::bsCollapsePanel(title = "▽ Global Profiling Parameters", # These are never used by rDolphin...not sure why they are defined # fluidRow( # column(width = 6, @@ -2213,7 +2219,7 @@ ref_data_editingServer <- function(id, xpmt_data, ref_data, ref_db, connec){ `Spectrometer Frequency (MHz)` = .data$Field_strength, `Metabolite` = .data$Solute) %>% DT::datatable(rownames = FALSE, - options = list(scrollX = TRUE)) + options = list(scrollX = TRUE, selection = "none")) }) # Options for metabolite signals @@ -2221,11 +2227,11 @@ ref_data_editingServer <- function(id, xpmt_data, ref_data, ref_db, connec){ req(ref_data()) shinyBS::bsCollapse(id = NS(id, "metabolite_signal_options"), - shinyBS::bsCollapsePanel(title = "Metabolite Signal Options", + shinyBS::bsCollapsePanel(title = "▽ Metabolite Signal Options", fluidRow( column(width = 2, - actionButton(NS(id, "signal_add"), "Add New Signal")), + actionButton(NS(id, "signal_add"), "Add New Signal", style="color: #fff; background-color: #337ab7; border-color: #2e6da4")), column(width = 3, uiOutput(NS(id, "ui_remove_signal"))), column(width = 3, @@ -2308,7 +2314,7 @@ ref_data_editingServer <- function(id, xpmt_data, ref_data, ref_db, connec){ req(nrow(rv$user_reference_data %>% dplyr::filter(.data$Metabolite %in% input$which_refmet_dspedt)) > nrow(temp)) - actionButton(NS(id, "signal_remove"), "Remove Last Added Signal") + actionButton(NS(id, "signal_remove"), "Remove Last Added Signal", style="color: #fff; background-color: #337ab7; border-color: #2e6da4") }) # Add Signal diff --git a/R/app_module_ref_data_upload.R b/R/app_module_ref_data_upload.R index c6e6e6e..21eaadc 100644 --- a/R/app_module_ref_data_upload.R +++ b/R/app_module_ref_data_upload.R @@ -179,7 +179,21 @@ ref_data_uploadServer <- function(id, xpmt_data, ref_db, connec){ choices = unique(ref_db$Solute)) }) + observeEvent(input$ref_upload_method, { + if(input$process_ref_inputs > 0){ + shinyWidgets::show_alert( + title = "Selection cannot be changed", + text = "The metabolite upload method cannot be changed once selected. Please use the \"Add/Remove Metabolites\" + tab or start a new session.", + type = "error" + ) + } + }, ignoreInit = T) + output$process_ref_inputs <- renderUI({ + if(!is.null(input$process_ref_inputs)){ + req(input$process_ref_inputs == 0) + } if(input$ref_upload_method == "prevsesh"){ shinyWidgets::actionBttn(inputId = NS(id, "process_ref_inputs"), label = "Load Session Data", @@ -198,6 +212,9 @@ ref_data_uploadServer <- function(id, xpmt_data, ref_db, connec){ # Observer to control which set of options for refmet upload are displayed: file upload or manual specification observeEvent(c(input$ref_upload_method), { + if(!is.null(input$process_ref_inputs)){ + req(input$process_ref_inputs == 0) + } req(xpmt_data()) updateTabsetPanel(inputId = "refmet_upload", selected = input$ref_upload_method) @@ -212,6 +229,9 @@ ref_data_uploadServer <- function(id, xpmt_data, ref_db, connec){ #observer to check for project name and query of user ref db observe({ + if(!is.null(isolate(input$process_ref_inputs))){ + req(isolate(input$process_ref_inputs == 0)) + } req(input$ref_upload_method == "prevsesh") req(xpmt_data()) diff --git a/R/app_module_xpmt_data_viz.R b/R/app_module_xpmt_data_viz.R index fe8e607..5fbb8c0 100644 --- a/R/app_module_xpmt_data_viz.R +++ b/R/app_module_xpmt_data_viz.R @@ -79,6 +79,378 @@ xpmt_data_vizoptionsUI <- function(id){ ) } +#' Module: Server functions specific to experimental data and metadata visualization +#' +#' @description Copyright (C) 2022 Battelle Memorial Institute +#' +#' This program is free software; you can redistribute it and/or modify +#' it under the terms of the GNU General Public License as published by +#' the Free Software Foundation; either version 2 of the License, or +#' (at your option) any later version. +#' +#' This program is distributed in the hope that it will be useful, +#' but WITHOUT ANY WARRANTY; without even the implied warranty of +#' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +#' GNU General Public License for more details. +#' +#' You should have received a copy of the GNU General Public License along +#' with this program; if not, write to the Free Software Foundation, Inc., +#' 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +#' +#' @param id A string denoting the namespace id. +#' @param xpmt_data The reactive object returned by the xpmt_data_uploadServer() server module containing +#' the experimental data as a nmRanalysis ppmData object. +#' +#' @details This is the UI component for the module created to handle the visualization of experimental data and metadata. +#' The value provided for 'id' should be identical across xpmt_data_vizUI(), xpmt_data_vizoptionsUI(), +#' and xpmt_data_vizServer(). +#' +#' This module component provides the back-end code that: +#' 1) Generates the plotly figure of experimental data +#' 2) Generates the datatable of experimental metadata +#' 3) Creates and displays subplots corresponding to selected regions +#' 4) Applies or removes filters to the data +#' +#' @return A reactive object containing the uploaded experimental data with any modifications (i.e. filters) applied. Note that +#' any applied filters are stored as an attribute of the object. The attribute contains both the filtered range and the set of data +#' that was filtered within this range. +#' +#' @import shiny +#' @importFrom magrittr %>% +#' @importFrom rlang .data +#' +xpmt_data_vizServer <- function(id, xpmt_data){ + stopifnot(is.reactive(xpmt_data)) + moduleServer(id, function(input, output, session){ + + # Initialize reactiveValues object that will be used to store version of uploaded experimental data (xpmt_data()) + # that may be modified/updated at various points. Cannot call xpmt_data() directly in the initialization because + # reactiveValues() is not a reactive environment. Therefore, we use the observer seen immediately below. + rv <- reactiveValues(obs_show_subplot_suspend = TRUE, + subplot_dat = NULL) + + observe(priority = 10, { + req(xpmt_data()) + rv$modified_xpmt_data <- xpmt_data() + }) + + # UI element creating a dropdown button containing several options that relate + # to experimental data visualization. These options include: + # 1) Choosing which sample spectrum to display + # 2) Toggle for whether subplots should be displayed on region select + # 3) The ability to specify a numeric (PPM) range for a filter to be applied, or, + # if filters are currently applied, to be removed. + # 4) Not an option, but a text display indicating the filters that are currently applied to + # the data. + output$vizoptions_ui <- renderUI({ + + req(xpmt_data()) + + shinyWidgets::dropdownButton( + # Allows users to select which sample spectrum to display. + selectInput(inputId = NS(id, "sample_to_plot"), + label = "Choose a spectrum to plot", + choices = colnames(xpmt_data()$e_data)[-1]), + + # Toggle for subplot display + fluidRow(column(9, shinyWidgets::materialSwitch(inputId = NS(id, "show_subplot"), + label = "Show subplot on box select", + value = FALSE, + status = "primary", + right = TRUE)), + column(3, actionButton(inputId = NS(id, "show_subplot_help"), + label = "?"))), + shinyBS::bsTooltip(id = NS(id, "show_subplot_help"), + title = "Use the Box Select tool in the upper-right corner of the plot to select a region to be shown in a subplot.", + placement = "bottom", + trigger = "hover"), + + # Allows users to specify filter range + shinyWidgets::numericRangeInput(inputId = NS(id, "range"), + label = "Specify a filter range:", + value = 0), + + # Buttons to apply or remove specified filters. + fluidRow( + column( + width = 6, + actionButton(inputId = NS(id, "apply_filter"), + label = "Apply Filter"), + shinyBS::bsTooltip(id = NS(id, "apply_filter"), + title = "Changes to this filters will carry over to downstream plots", + placement = "bottom", + trigger = "hover"), + ), + column( + width = 6, + actionButton(inputId = NS(id, "remove_filter"), + label = "Remove Filter"), + shinyBS::bsTooltip(id = NS(id, "remove_filter"), + title = "Changes to this filters will carry over to downstream plots", + placement = "bottom", + trigger = "hover"), + ), + ), + h4(""), + + # HTML output to display the filters currently applied + htmlOutput(NS(id,"applied_filters_text")), + + circle = TRUE, status = "info", + icon = icon("cog"), width = "300px", + + tooltip = shinyWidgets::tooltipOptions(title = "Data Options") + ) + }) + + # Output (in HTML format) to display the filters that are currently applied to the data. + output$applied_filters_text <- renderUI({ + + req(xpmt_data()) + + if(length(attr(rv$modified_xpmt_data, "filters")) == 0){ + htmltools::HTML("Currently applied filters:
None") + + } else{ + allfilts <- rlist::list.ungroup(rlist::list.select(attr(rv$modified_xpmt_data, "filters"), range)) + allfilts <- Reduce("c", lapply(allfilts, function(x){paste0("(", x$min, ", ", x$max, ")")})) + htmltools::HTML(paste0("Currently applied filters:
", paste(allfilts, collapse = "
"))) + + } + }) + + + # Initialize plot of single spectrum from uploaded experimental data + output$e_data_plot <- plotly::renderPlotly({ + # Will not evaluate unless experimental data has been uploaded + req(xpmt_data()) + req(input$sample_to_plot) + req(input$sample_to_plot %in% names(xpmt_data()$e_data)) + + # Code to resume the observer that was started in a suspended state. We also update the value of + # rv$obs_show_subplot_suspend so that $resume() is not called every time this plot is rendered, + # but only after the first rendering of the plot. + if(rv$obs_show_subplot_suspend){ + obs_show_subplot$resume() + rv$obs_show_subplot_suspend <- FALSE + } + + plot_xpmt_data(xpmt_data = isolate(rv$modified_xpmt_data$e_data), + sourceid = "e_data_plot", + sample_to_plot = input$sample_to_plot) + }) + + # Proxy object of the main plot of the single selected spectrum data. + e_data_plot_proxy <- plotly::plotlyProxy("e_data_plot") + + # Plotting of the subplot of ppm data across all sample spectra at the selected region + output$e_data_subplot <- plotly::renderPlotly({ + # Will not evaluate unless experimental data has been uploaded + # and toggle to show subplot on region select is activated. + req(xpmt_data()) + req(input$show_subplot) + + brushedData <- plotly::event_data("plotly_brushed", source = "e_data_plot") + + if(is.null(brushedData)){ + return(NULL) + } + + plot_xpmt_data(xpmt_data = isolate(rv$modified_xpmt_data$e_data), + sourceid = "e_data_subplot", + sample_to_plot = input$sample_to_plot, + brushed_data = brushedData) + }) + + # Observer to control pop-up (i.e. modal) containing the subplot of spectral data at a selected region. + # Note: This works fine, but the only thing that I would like to change is + # loading of subsequent plots generated by different brush events. + # On initial plot, the loading spinner shows, but on subsequent plots, it does not. + # Not sure how to fix this yet, but I suspect the issue lies in the execution order. + # This observer triggers before "e_data_subplot" invalidates. + # Note that we specify suspended = TRUE. This forces the observer to begin in a suspended state on app initialization. + # We do this here because on app start e_data_plot is not defined and so a warning error is output. Given that the + # observer is in a suspended state, we need to resume it after e_data_plot is defined so that the observer can + # operate as intended. See the code snippet under output$e_data_plot for how this is done. + obs_show_subplot <- observeEvent(plotly::event_data("plotly_brushed", source = "e_data_plot"), suspended = TRUE, { + req(input$show_subplot) + req(xpmt_data()) + + + brushedData <- plotly::event_data("plotly_brushed", source = "e_data_plot") + + req(!identical(brushedData, rv$subplot_dat)) + + removeModal() + showModal( + modalDialog( + shinycssloaders::withSpinner(plotly::plotlyOutput(NS(id, 'e_data_subplot'))), + title = paste0("All Sample Spectra: ", round(min(brushedData$x),3)," PPM to ", round(max(brushedData$x),3), " PPM"), + size = "xl", + easyClose = TRUE, + fade = FALSE + )) + + rv$subplot_dat <- brushedData + }) + + + # This datatable corresponds to the metadata + output$f_data_df <- DT::renderDataTable({ + # Will not evaluate unless experimental data has been uploaded + req(xpmt_data()) + + xpmt_data()$f_data %>% + DT::datatable(rownames = FALSE, + options = list(scrollX = TRUE)) + }) + + # Observer to apply filter specified to ALL data, not just the data of the selected sample spectrum. + observeEvent(c(input$apply_filter), ignoreInit = TRUE, ignoreNULL = TRUE, + { + req(xpmt_data()) + req(input$apply_filter > 0) + + shinyFeedback::feedbackDanger("range", + input$range[1] > input$range[2], + 'Filter range format is "a to b", where a < b.') + + req(input$range[1] < input$range[2]) + + allfilts <- rlist::list.ungroup(rlist::list.select(attr(rv$modified_xpmt_data, "filters"), range)) + idx_of_filt2add <- which(lapply(allfilts, function(x){all(input$range %in% c(x$min, x$max))}) == TRUE) + req(length(idx_of_filt2add) == 0) + + rv$modified_xpmt_data <- filter_ppm(rv$modified_xpmt_data, + range = list(min = min(as.numeric(input$range)), + max = max(as.numeric(input$range)))) + + plotly::plotlyProxyInvoke(e_data_plot_proxy, "deleteTraces", as.list(as.integer(0))) + + plotly::plotlyProxyInvoke(e_data_plot_proxy, "addTraces", + list(x = rv$modified_xpmt_data$e_data[["PPM"]], + y = rv$modified_xpmt_data$e_data[[input$sample_to_plot]], + type = 'scatter', + mode = 'lines', + line = list(width = 1))) + }) + + # Observer to remove filter specified from ALL data, not just the data of the selected sample spectrum. + observeEvent(c(input$remove_filter), ignoreInit = TRUE, ignoreNULL = TRUE, + { + req(xpmt_data()) + req(input$remove_filter > 0) + + allfilts <- rlist::list.ungroup(rlist::list.select(attr(rv$modified_xpmt_data, "filters"), range)) + req(allfilts) + + idx_of_filt2rm <- which(lapply(allfilts, function(x){all(input$range %in% c(x$min, x$max))}) == TRUE) + req(idx_of_filt2rm) + + rv$modified_xpmt_data <- remove_filter_ppm(rv$modified_xpmt_data, + filters = as.numeric(idx_of_filt2rm)) + rv$modified_xpmt_data$e_data <- rv$modified_xpmt_data$e_data %>% dplyr::arrange(.data[["PPM"]]) + + plotly::plotlyProxyInvoke(e_data_plot_proxy, "deleteTraces", as.list(as.integer(0))) + + plotly::plotlyProxyInvoke(e_data_plot_proxy, "addTraces", + list(x = rv$modified_xpmt_data$e_data[["PPM"]], + y = rv$modified_xpmt_data$e_data[[input$sample_to_plot]], + type = 'scatter', + mode = 'lines', + line = list(width = 1))) + + }) + + # This reactive generates the output of this module. The output is the uploaded experimental data with any modifications + # applied. + reactive({ + req(xpmt_data()) + rv$modified_xpmt_data + }) + }) +} +#' Module: UI elements specific to experimental data visualization +#' +#' @description Copyright (C) 2022 Battelle Memorial Institute +#' +#' This program is free software; you can redistribute it and/or modify +#' it under the terms of the GNU General Public License as published by +#' the Free Software Foundation; either version 2 of the License, or +#' (at your option) any later version. +#' +#' This program is distributed in the hope that it will be useful, +#' but WITHOUT ANY WARRANTY; without even the implied warranty of +#' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +#' GNU General Public License for more details. +#' +#' You should have received a copy of the GNU General Public License along +#' with this program; if not, write to the Free Software Foundation, Inc., +#' 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +#' +#' @param id A string denoting the namespace id. +#' +#' @details This is the UI component for the module created to handle the visualization of experimental data. +#' The value provided for 'id' should be identical across xpmt_data_vizUI(), xpmt_data_vizoptionsUI(), +#' and xpmt_data_vizServer(). +#' +#' This module component provides the UI elements that allow users to: +#' 1) Visualize uploaded experimental data through an interactive plotly figure +#' 2) Visualize experimental metadata through a searchable datatable. +#' +#' @import shiny +#' @importFrom magrittr %>% +#' +xpmt_data_vizUI <- function(id){ + ns <- NS(id) + tagList( + shinycssloaders::withSpinner(plotly::plotlyOutput(ns('e_data_plot'))), + DT::dataTableOutput(ns("f_data_df")) + ) +} + +#' Module: UI elements specific to data visualization options (e.g. filters, subplots) +#' +#' @description Copyright (C) 2022 Battelle Memorial Institute +#' +#' This program is free software; you can redistribute it and/or modify +#' it under the terms of the GNU General Public License as published by +#' the Free Software Foundation; either version 2 of the License, or +#' (at your option) any later version. +#' +#' This program is distributed in the hope that it will be useful, +#' but WITHOUT ANY WARRANTY; without even the implied warranty of +#' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +#' GNU General Public License for more details. +#' +#' You should have received a copy of the GNU General Public License along +#' with this program; if not, write to the Free Software Foundation, Inc., +#' 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +#' +#' @param id A string denoting the namespace id. +#' +#' @details This is the UI component for the module created to handle editing of uploaded experimental data. +#' The value provided for 'id' should be identical across xpmt_data_vizUI(), xpmt_data_vizoptionsUI(), +#' xpmt_metadata_vizUI, and xpmt_data_vizServer(). +#' +#' This module component provides the dynamic UI elements that allow users to: +#' 1) Select which sample spectrum should be displayed on the main plotly plot +#' 2) Toggle the option for subplot display of any selected plot region. This subplot +#' will shown the intensities across all sample spectra at the selected region. +#' 3) Apply or remove uploaded data filter(s) +#' +#' Note that since this UI component is dynamic, its code is found within the corresponding server component of the +#' module, xpmt_data_vizServer(). +#' +#' @import shiny +#' +xpmt_data_vizoptionsUI <- function(id){ + ns <- NS(id) + tagList( + uiOutput(ns("vizoptions_ui")) + ) +} + #' Module: Server functions specific to experimental data and metadata visualization #' #' @description Copyright (C) 2022 Battelle Memorial Institute diff --git a/R/connect_db.R b/R/connect_db.R index 9951373..da14b86 100644 --- a/R/connect_db.R +++ b/R/connect_db.R @@ -29,6 +29,7 @@ connect_db <- function(){ # dsn_database = "nmRanalysis" # dsn_port = "5432" # dsn_hostname = "localhost" + # dsn_uid = "postgres" # dsn_uid = "developer" # dsn_pwd = "developer" diff --git a/README.md b/README.md index b1b6746..33802f3 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # nmRanalysis -### `0.0.99993` +### `0.0.99994` ### Services: