Skip to content

limited number of trels, fix ref_data_upload crash #1

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
LogLew12 wants to merge 1 commit into
base: master
Choose a base branch
from
Open

limited number of trels, fix ref_data_upload crash #1

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
104 changes: 87 additions & 17 deletions R/app_module_profiling.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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"))
)
}
Expand Down Expand Up @@ -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.",
Expand Down Expand Up @@ -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,
Expand Down Expand Up @@ -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
Expand All @@ -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()

Expand Down Expand Up @@ -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(
Expand Down Expand Up @@ -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")),
Expand All @@ -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()
Expand Down Expand Up @@ -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))
Expand Down Expand Up @@ -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
Expand Down
38 changes: 22 additions & 16 deletions R/app_module_ref_data_modify.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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(
Expand All @@ -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"))
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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")
})

#----------------------------------------------------------------------------------------------------------
Expand Down Expand Up @@ -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")
)
)

Expand Down Expand Up @@ -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,
Expand Down Expand Up @@ -2213,19 +2219,19 @@ 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
output$ui_metabolite_signal_options <- renderUI({
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,
Expand Down Expand Up @@ -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
Expand Down
20 changes: 20 additions & 0 deletions R/app_module_ref_data_upload.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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",
Expand All @@ -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)
Expand All @@ -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())

Expand Down
Loading