inst/server.r

In mariev/chromatoplotsgui: Interactive graphics and interface for chromatoplots

library(shiny)
library(shinyIncubator)
library(chromatoplotsgui)
library(chromatoplots)
options(shiny.maxRequestSize=30*1024^2)


shinyServer(function(input, output) {
  
#########################################
## instantiate shared variables
#########################################
  values <- reactiveValues()
  values$newfiles <- data.frame(name = NULL)
  values$displayraws <- TRUE
  values$genprofmethod <- 'binlinbase'
  values$newrungenprof <- 0
  values$new_gpstep <- 1
  values$bspace <- 0
  values$blevels <- NULL
  values$rawdatapath <- getwd()
  values$old_data <- data.frame(name = NULL)

  
  # data that cannot be stored as a reactive
  newLS <- list()
  newGP <- list()
  newRB <- list()
  newFP <- list()
  resumEnv <- new.env()
  meta <- NULL

#########################################
## transformation functions
#########################################

## store user input for cdf filenames during NEW
##    into shared variables
getnewfiles <- function(){
    if(!is.null(input$file1)){
    values$newfiles <- input$file1  
    values$lsVals <- vector('list', length = nrow(values$newfiles))
  }
}


getdisplaynewraws <- function(){
  values$displayraws <- input$displayraw
  
}

## if user selected to display, print cgRawPlot obj 
##  ****** don't save this to a reactive object! causes rshiny to loop indef [=/]
loadnewraws <- function(){
    if(length(values$newfiles) > 0  ){
      sapply(1:nrow(values$newfiles), FUN = function(x){
        newLS[[x]] <<- loadSample( values$newfiles[x, "datapath"])
        if(values$displayraws){
          print(cgRawPlot(newLS[[x]]))    
        }})
    }
}

## initialize the variables for the genProf step
initGPvar <- function(){
  values$genprofmethod <- input$integrate
  values$new_gpstep <- input$step
  if(is.na(input$baselevel)){
    values$blevel <- NULL
  } else {
    values$blevel <- input$baselevel
  }
  values$bspace <- input$basespace
  
}

## populate the graphs and create chromatoplots objects
popGP <- function(display = TRUE){
  sapply(1:length(values$newfiles$name), FUN = function(x){
    
    newGP[[x]] <<- genProfile(newLS[[x]], integrate = values$genprofmethod, 
                              basespace = values$bspace, baselevel = values$blevel,
                              step = values$new_gpstep)
    if(display){
      print(cgProfPlot(newGP[[x]]))
    }
    
  })
}

## creating the genprof plots for the first time
rungenprof <- function(){
  initGPvar()
  if(is.null(values$newfiles$name)){
    values$newrungenprof <- -1
  } else {
    values$newrungenprof <- input$runGenProf
  }
  

  if(values$newrungenprof > 0){
    
  }
 
}

## initialize variables for the removeBaseline step
initRBvar <- function(){
  if(input$remBase == 'med'){
    values$newrmbasemethod <- 'median'      
  } else {
    values$newrmbasemethod <- 'rbe'
  }
  values$mzrad <- input$mzrad
  values$scanrad <- input$scanrad
  values$span <- input$span
  values$runs <- input$runs
  values$b <- input$b
}

## populate the graphs and create chromatoplots objects
popRB <- function(display = TRUE){
  sapply(1:length(values$newfiles$name), FUN = function(x){
    newGP[[x]] <<- genProfile(newLS[[x]], integrate = values$genprofmethod, 
                              basespace = values$bspace, baselevel = values$blevel,
                              step = values$new_gpstep)
    if(values$newrmbasemethod == "median"){
      newRB[[x]] <<- removeBaseline(newGP[[x]], values$newrmbasemethod,  
                                    mzrad = values$mzrad, scanrad = values$scanrad)
    } else {
      newRB[[x]] <<- removeBaseline(newGP[[x]], values$newrmbasemethod, 
                                    span = values$span, runs = values$runs, 
                                    b = valuesb)
    }
    
    if(display){
      print(cgRmBasePlot(newRB[[x]], mz = 112))
    }
  })
}

## creating the removeBaseline plots for the first time
runrembase <- function(){
  initRBvar()
  
  if(is.null(values$newfiles$name)){
    values$newrunrmbs <- -1
  } else {
    values$newrunrmbs <- input$runRemBase
  }
  

  if(values$newrunrmbs > 0){
    initGPvar()
    popGP(display = FALSE)
    popRB()

  }

}

## initialize variables for the findPeaks step
initFPvar <- function(){
  if(input$fPeaks == "Gaussian Fitting"){
    values$fpeaksMethod <- "gauss"
    values$alpha <- input$alpha
    values$egh <- input$egh
  } else if(input$fPeaks == "Parabola Fitting"){
    values$fpeaksMethod <- "parabola"
    values$alpha <- input$alpha
    values$egh <- input$egh
  } else if(input$fPeaks == "Matched Filter"){
    
    values$fpeaksMethod <<- "matchedFilter"
    values$fwhm <- input$fwhm
    values$sigma <- input$sigma
    values$maxpeaks <- input$maxpeaks
    values$snthresh <- input$snthresh
    values$stepsize <- input$stepsize
    values$mergesteps <- input$mergesteps
    values$mzdiff <- input$mzdiff
    values$index <- input$index
  } else if(input$fPeaks == "Centroid Wavelet"){
    #       scanrange <<- call("numeric")
    #       minEntries <<- numeric()
    #       dev <<- numeric()
    #       noiserange <<- numeric()
    #       minPeakWidth <<- numeric()
    #       scales <<- numeric()
    #       maxGaussOverlap <<- numeric()
    #       minPtsAboveBaseline <<- numeric()
    #       scRangeTol <<- numeric()
    #       maxDescOutlier <<- numeric()
    #       mzdiff <<- -.001
    #       rtdiff <<- numeric()
    #       integrate <<- 1
    #       fitgauss <<- FALSE
  }
}

## populate graphs and create chromatoplots objects
popFP <- function(display = TRUE){
  sapply(1:length(values$newfiles$name), FUN = function(x){
      if(values$fpeaksMethod %in% c("parabola", "gauss")){
        newFP[[x ]] <<- findPeaks(newRB[[x]], values$fpeaksMethod, 
                                  alpha = values$alpha,
                                  egh = values$egh)
      } else if(values$fpeaksMethod == "matchedFilter"){
        newFP[[x]] <<- findPeaks(newRB[[x]], "matchedFilter", 
                                  fwhm = values$fwhm, sigma = values$sigma, 
                                  max = values$maxpeak,
                                  snthresh = values$snthresh, step = values$stepsize,
                                  steps = values$mergesteps, mzdiff = values$mzdiff,
                                  index = values$index)
      } else if(values$fpeaksMethod == "centWave"){
        newFP[[x]] <<- findPeaks(newRB[[x]], "centWave")
      }
      if(display){
        print(cgfindPeaksPlot(newFP[[x]], newRB[[x]], 112))
      }
    })
}

## creating findpeaks plots for the first time
runfindpeaks <- function(){
  initFPvar()
  if(is.null(values$newfiles$name)){
    values$newrunfp <- -1
  } else {
    values$newrunfp <- input$runfpeaks
  }
  if(values$newrunfp > 0){
    initGPvar()
    popGP(display = FALSE)
    initRBvar()
    popRB(display = FALSE)
    popFP()
  }
  
}


##
resumeFiles <- function(){
  resumEnv <- new.env()
  ## update values$ to flag for position to display
  values$rawdatapath <- input$rawdatapath
  
  if(is.null(input$file2)){
    values$old_data <- data.frame(name = NULL)
  } else{
    values$old_data <- input$file2
  }
  
  if(length(values$old_data) > 0){
    load(values$old_data$datapath, envir = resumEnv)
  }
  
  ## check that the imported file was output from cg
  if(!exists('cgmeta', envir = resumEnv)){
    stop('Imported data not generated in chromatoplotsGUI')
  } 
  
  oldValList <- get('valList', envir = resumEnv)
    
  
  ## compare filenames in import to raw data available
  setwd(values$rawdatapath)
  oldDF <- dir(recursive = TRUE)
  oldDF <- basename(oldDF[grep(pattern = '.cdf', ignore.case = TRUE,
                  x = oldDF)])
  oldDF <- oldValList$newfiles[oldValList$newfiles$name %in% oldDF, 'name']
  
  if(length(oldDF) == 0){
    oldDF <- 'warning: could not locate raw CDF files.'
  }
  
  values$old_matchfiles <- oldDF
}
#########################################
## output values
#########################################
  ## confirmation of filenames on new tab
  output$newraws <- renderText({
    getnewfiles()
    getdisplaynewraws()
    loadnewraws()
    return(values$newfiles$name)
  })

  ## debugging for running genprof
  output$genprofRun <- renderText({
    rungenprof()
    return(values$newrungenprof)
  })

  ## debugging for running rembase
  output$rmbsRun <- renderText({
    runrembase()
    return(values$newrunrmbs)
  })

  ## debugging for running fpeaks
  output$fpeaksrun <- renderText({
    runfindpeaks()
    return(values$newrunfp)
  })

  output$againfiles <- renderText({
    resumeFiles()
    return(values$old_matchfiles)
  })
  ## save  handler for genprofile stage
  output$saveGenProf <- downloadHandler(
    filename = 'genprofData.rda',
    content = function(file) {
      initGPvar()
      popGP(display = FALSE)
      cgmeta <- new('cgMetaProp', tab = 'genProf')
      valList <- isolate(reactiveValuesToList(values))
      save(valList, 
           newLS, newGP, cgmeta, file = file)
    }
  )

  ## save handler for rmbase stage
  output$savermbase <- downloadHandler(
    filename = 'rmBaseData.rda',
    content = function(file){
      initGPvar()
      popGP(display = FALSE)
      initRBvar()
      popRB(display = FALSE)

      cgmeta <- new('cgMetaProp', tab = 'rmBase')
      valList <- isolate(reactiveValuesToList(values))
      save(valList, newLS, newGP, newRB, cgmeta, file = file)
    }
  )

  ## save handler for fpeaks stage
  output$savefpeaks <- downloadHandler(
    filename = 'fpeaksData.rda',
    content = function(file){
      initGPvar()
      popGP(display = FALSE)
      initRBvar()
      popRB(display = FALSE)
      initFPvar()
      popFP(display = FALSE)
      cgmeta <- new('cgMetaProp', tab = 'fpeaks')
      valList <- isolate(reactiveValuesToList(values))
      save(valList, newLS, newGP, newRB, newFP, cgmeta, file = file)
    })
  


  

})