update shiny code in vizapp

vizapp/server.R

@@ -10,12 +10,14 @@ library("gplots")
 
 shinyServer(function(input, output, session) {
 
-    data.dir <- Sys.getenv('outputDir')
+   # data.dir <- Sys.getenv('outputDir')
+    data.dir <-"workflow_322_output"
     rda.dir <- data.dir
     symsyn <- read.table(file='symbol2synonym.txt',header=FALSE)
     names(symsyn) <- c('symbol','synonyms')
     source('functions.R', local = TRUE)
     source('tools/intro.R', local = TRUE)
+    source('tools/intro_ui.R', local = TRUE)
     source('tools/gc.R', local = TRUE)
     source('tools/qc.R', local = TRUE)
     source('tools/altsplice.R', local = TRUE)

vizapp/tools/altsplice.R

 
- get.bgdata <- function(var) {
-   rdafile <- paste(data.dir,'bg.rda',sep='/')
+
+get.bgdata <- function(var) {
+  rdafile <- paste(data.dir, 'bg.rda', sep = '/')
   load(rdafile)
   genetrx <- indexes(bg)$t2g
   genetrx$SYMBOL <- geneNames(bg)
   
-   geneid <- as.character(unique(genetrx[genetrx$SYMBOL %in% var$symsearch,]$g_id))
+  geneid <- as.character(unique(genetrx[genetrx$SYMBOL %in% var$symsearch, ]$g_id))
   if (exists("var$enssearch") && var$enssearch != '') {
-       geneid <- as.character(unique(genetrx$g_id[grep(enssearch,genetrx$g_id)]))
+    geneid <- as.character(unique(genetrx$g_id[grep(enssearch, genetrx$g_id)]))
   }
-   genebg <- subset(bg,paste0("gene_id=='",geneid,"'"))
+  genebg <- subset(bg, paste0("gene_id=='", geneid, "'"))
   rownames(genetrx) <- transcriptNames(bg)
-   fpkm <- texpr(bg,meas='FPKM')
-   keep <- genetrx[genetrx$g_id == geneid,]$t_id
-   cttbl <- fpkm[keep,]
+  fpkm <- texpr(bg, meas = 'FPKM')
+  keep <- genetrx[genetrx$g_id == geneid, ]$t_id
+  cttbl <- fpkm[keep, ]
   grps <- pData(bg)$group
-   trxnames <-  genetrx[genetrx$g_id == geneid,]
+  trxnames <-  genetrx[genetrx$g_id == geneid, ]
   dtm <- melt(t(cttbl))
-   names(dtm) <- c('sample','transcript','value')
-   dtm$grps <- rep(grps,length(keep))
+  names(dtm) <- c('sample', 'transcript', 'value')
+  dtm$grps <- rep(grps, length(keep))
   if (length(keep) < 2) {
-     dtm$transcript <- rep(keep,length(keep))
+    dtm$transcript <- rep(keep, length(keep))
   }
-   dtm$grptrx <- paste(dtm$grps,dtm$transcript,sep='.')
-   test <- stattest(gown=genebg, pData=pData(bg), feature='transcript',covariate='group', libadjust=FALSE,getFC=TRUE)
+  dtm$grptrx <- paste(dtm$grps, dtm$transcript, sep = '.')
+  test <-
+    stattest(
+      gown = genebg,
+      pData = pData(bg),
+      feature = 'transcript',
+      covariate = 'group',
+      libadjust = FALSE,
+      getFC = TRUE
+    )
   if (length(keep) > 1) {
-     agg = collapseTranscripts(gene=geneid, gown=bg, k=var$kct, method='kmeans')
-     test <- stattest(gowntable=agg$tab, pData=pData(bg), feature='transcript_cluster',covariate='group', libadjust=FALSE,getFC=TRUE)
-   }
-   return(list(stattbl=test,gid=geneid,obj=genebg,cttbl=dtm,tname=trxnames))
+      agg = collapseTranscripts(
+      gene = geneid,
+      gown = bg,
+      k = var$kct,
+      method = 'kmeans'
+    )
+    test <-
+      stattest(
+        gowntable = agg$tab,
+        pData = pData(bg),
+        feature = 'transcript_cluster',
+        covariate = 'group',
+        libadjust = FALSE,
+        getFC = TRUE
+      )
   }
+  return(list(
+    stattbl = test,
+    gid = geneid,
+    obj = genebg,
+    cttbl = dtm,
+    tname = trxnames
+  ))
+}
 
 find_sym <- function (sym) {
-if (!(toupper(sym) %in% toupper(symsyn$symbol))) {
-     syns <- symsyn[grep(input$symsearch,symsyn$synonym,ignore.case=TRUE),]$symbol
-     synlist <- paste(as.character(syns),collapse=',')
+  if (!(toupper(sym) %in% toupper(symsyn$symbol))) {
+    syns <-
+      symsyn[grep(input$symsearch, symsyn$synonym, ignore.case = TRUE), ]$symbol
+    synlist <- paste(as.character(syns), collapse = ',')
     if (length(syns) > 1) {
-     paste("Please Use Official Gene Symbols",synlist,sep=':')
-   }else {"Please Use Official Gene Symbols"}  	 
- }else {NULL}  	 
+      paste("Please Use Official Gene Symbols", synlist, sep = ':')
+    } else {
+      "Please Use Official Gene Symbols"
+    }
+  } else {
+    NULL
+  }
 }
 
-getgeneid <- eventReactive(input$altButton,{
+getgeneid <- eventReactive(input$altButton, {
   if (input$symsearch == '' & input$enssearch != '') {
     validate (find_sym(input$symsearch))
   }
-get.bgdata(input)
+  get.bgdata(input)
 })
 
 output$plot.cluster <- renderPlot({
-  par(oma=c(4,4,1,1)) 
+  par(oma = c(0, 0, 0, 0))
   gid <- getgeneid()$gid
   bg <- getgeneid()$obj
   tname <- getgeneid()$tname
   if (nrow(tname) > 1) {
-    plotLatentTranscripts(gene=gid, gown=bg, k=input$kct, method='kmeans', returncluster=FALSE)
+    plotLatentTranscripts(
+      gene = gid,
+      gown = bg,
+      k = input$kct,
+      method = 'kmeans',
+      returncluster = FALSE
+    )
+  }
+}, height = "auto", width = 'auto')
+
+output$dlplotcluster <- renderUI({
+  if (!is.null(getgeneid()$gid) &
+      !is.null(getgeneid()$obj) & !is.null(getgeneid()$tname)) {
+    downloadButton('Downloadpcluster', 'Download PNG')
   }
 })
 
+output$Downloadpcluster <- downloadHandler(
+  file = function() {
+    paste('plotcluster', 'png', sep = ".")
+  },
+  content <- function(file) {
+    png(
+      file,
+      width = 8 * 120,
+      height = 4 * 120,
+      res = 120,
+      pointsize = 5
+    )
+    if (is.null(getgeneid()$gid) &
+        is.null(getgeneid()$obj) & is.null(getgeneid()$tname)) {
+      return()
+    }
+    par(oma = c(4, 4, 1, 1))
+    gid <- getgeneid()$gid
+    bg <- getgeneid()$obj
+    tname <- getgeneid()$tname
+    if (nrow(tname) > 1) {
+      plot <-
+        plotLatentTranscripts(
+          gene = gid,
+          gown = bg,
+          k = input$kct,
+          method = 'kmeans',
+          returncluster = FALSE
+        )
+    }
+    print(plot)
+    dev.off()
+  },
+  contentType = "image/png"
+)
+
+
 output$gene.stat <- DT::renderDataTable({
   getgeneid()$stattbl
-},escape=FALSE)
+}, escape = FALSE, options = list(dom = 'ft'))
 
 output$trx.name <- DT::renderDataTable({
   getgeneid()$tname
-},escape=FALSE)
+}, escape = FALSE , options = list(dom = 'ft'))
 
+output$downloadTrx <- renderUI({
+  if (!is.null(getgeneid()$tname)) {
+    downloadButton('DownloadTrx', 'Download CSV')
+  }
+})
+output$DownloadTrx <- downloadHandler(
+  file <- paste('Gene.trxname.txt'),
+  content = function(file) {
+    write.table(
+      getgeneid()$tname,
+      file,
+      quote = FALSE,
+      row.names = FALSE,
+      sep = '\t'
+    )
+  }
+)
 
 output$plot.means <- renderPlot({
-  par(oma=c(4,4,1,1))
-  par(cex.main=0.75)
+  par(oma = c(1, 4, 1, 8))
+  par(cex.main = 0.75)
+  gid <- getgeneid()$gid
+  bg <- getgeneid()$obj
+  tname <- getgeneid()$tname
+  if (nrow(tname) > 1) {
+    plotMeans(gid,
+              bg,
+              groupvar = 'group',
+              meas = 'cov',
+              colorby = 'transcript')
+  }
+}, height = 900, width = "auto")
+
+output$dlplotmean <- renderUI({
+  if (!is.null(getgeneid()$gid) & !is.null(getgeneid()$obj) & !is.null(getgeneid()$tname)) {
+    downloadButton('Downloadmean', 'Download PNG')
+  }
+})
+
+output$Downloadmean <- downloadHandler(
+  file = function() {
+    paste('mean', 'png', sep = ".")
+  },
+  content <- function(file) {
+    png(
+      file,
+      width = 8 * 120,
+      height = 4 * 180,
+      res = 140,
+      pointsize = 5
+    )
+    if (is.null(getgeneid()$gid) & is.null(getgeneid()$obj) & is.null(getgeneid()$tname)) {
+      return()
+    }
+    countTable <- getgeneid()$cttbl
+    par(oma = c(1, 4, 1, 8))
+    par(cex.main = 0.75)
     gid <- getgeneid()$gid
     bg <- getgeneid()$obj
     tname <- getgeneid()$tname
     if (nrow(tname) > 1) {
-    plotMeans(gid, bg, groupvar='group', meas='cov', colorby='transcript')
+      plot <- plotMeans(gid,
+                bg,
+                groupvar = 'group',
+                meas = 'cov',
+                colorby = 'transcript')
     }
-}, height = 900, width = 900)
+    print(plot)
+    dev.off()
+  },
+  contentType = "image/png"
+)
+
+
 
 output$trx.gene <- renderPlot({
   countTable <- getgeneid()$cttbl
-  par(oma=c(4,4,1,1))
-  p <- ggplot(countTable,aes(x=grptrx,y=log2(value+1))) + geom_boxplot(aes(fill = factor(grptrx))) + geom_jitter(height = 0) + theme(legend.position="left",axis.text.x=element_text(angle=45,hjust=1, vjust=1),legend.key.height=unit(0.5,"line"),legend.text=element_text(size=8),legend.title=element_blank()) + ylab("Relative Abundance (FPKM)") + xlab("")
+  par(oma = c(4, 1, 4, 1))
+  p <-
+    ggplot(countTable, aes(x = grptrx, y = log2(value + 1))) + geom_boxplot(aes(fill = factor(grptrx))) + geom_jitter(height = 0) + theme(
+      legend.position = "left",
+      axis.text.x = element_text(
+        angle = 45,
+        hjust = 1,
+        vjust = 1
+      ),
+      legend.key.height = unit(0.5, "line"),
+      legend.text = element_text(size = 8),
+      legend.title = element_blank()
+    ) + ylab("Relative Abundance (FPKM)") + xlab("")
   print(p)
+}, height = 'auto', width = 'auto')
+
+output$dltrxgene <- renderUI({
+  if (!is.null(getgeneid()$cttbl)) {
+    downloadButton('Downloadtregene', 'Download PNG')
+  }
 })
+
+output$Downloadtregene <- downloadHandler(
+  file = function() {
+    paste('tregene', 'png', sep = ".")
+  },
+  content <- function(file) {
+    png(
+      file,
+      width = 8 * 160,
+      height = 4 * 120,
+      res = 120,
+      pointsize = 5
+    )
+    if (is.null(getgeneid()$cttbl)) {
+      return()
+    }
+    countTable <- getgeneid()$cttbl
+    par(oma = c(4, 1, 4, 1))
+    p <-
+      ggplot(countTable, aes(x = grptrx, y = log2(value + 1))) + geom_boxplot(aes(fill = factor(grptrx))) + geom_jitter(height = 0) + theme(
+        legend.position = "left",
+        axis.text.x = element_text(
+          angle = 45,
+          hjust = 1,
+          vjust = 1
+        ),
+        legend.key.height = unit(0.5, "line"),
+        legend.text = element_text(size = 8),
+        legend.title = element_blank()
+      ) + ylab("Relative Abundance (FPKM)") + xlab("")
+    print(p)
+    dev.off()
+  },
+  contentType = "image/png"
+)
+

vizapp/tools/altsplice_ui.R

 output$ui_altsplice <- renderUI({
-  fluidPage(
+  list(fluidPage(
     includeCSS("www/style.css"),
-         sidebarLayout(
+    fluidRow(
       sidebarPanel(
         uiOutput("dir.splice"),
         textInput("symsearch", "Search By Gene Symbol", 'IL1B'),
-                       textInput("enssearch", "Search By ENS ID",''),
-                       numericInput("kct",label = "Number of Clusters",value = 2),   
-                       actionButton("altButton", "GO")
+        textInput("enssearch", "Search By ENS ID", ''),
+        numericInput("kct", label = "Number of Clusters", value = 2),
+        actionButton("altButton", "GO", class = "btn btn-primary btn-bg centerbtn")
       ),
-            mainPanel(
+      column(7,
              tabsetPanel(
-                       tabPanel("Gene Compare",
+               tabPanel(
+                 "Gene Compare",
+                 br(),br(),
                  dataTableOutput('gene.stat'),
+                 br(),br(),
                  dataTableOutput('trx.name'),
+                 br(),
+                 uiOutput('downloadTrx'),
                  plotOutput("plot.cluster"),
+                 uiOutput('dlplotcluster'),
+                 br(),br(),
                  plotOutput("trx.gene"),
-                             plotOutput("plot.means")
-                             )
-                    )
-                )
+                 uiOutput('dltrxgene'),
+                 plotOutput("plot.means", height = 900, width = 'auto'),
+                 uiOutput('dlplotmean')
                )
+             ))
     )
+  ))
   
 })
 

vizapp/tools/dea.R

 # UI-elements for DEA
 
-ctfile <-  paste(data.dir,'countTable.logCPM.txt',sep='/')
-samfile <-  paste(data.dir,'design.shiny.txt',sep='/')
-cts <- read.table(file=ctfile,header=TRUE,sep='\t')
-samtbl <- read.table(samfile,header=TRUE,sep="\t")
-samples <- colnames(cts[,4:length(cts)])
-mergetbl <- merge(as.data.frame(samples),samtbl,by.x="samples",by.y="SampleID",all.x=TRUE,sort=FALSE)
+ctfile <-  paste(data.dir, 'countTable.logCPM.txt', sep = '/')
+samfile <-  paste(data.dir, 'design.shiny.txt', sep = '/')
+cts <- read.table(file = ctfile, header = TRUE, sep = '\t')
+samtbl <- read.table(samfile, header = TRUE, sep = "\t")
+samples <- colnames(cts[, 4:length(cts)])
+mergetbl <-
+  merge(
+    as.data.frame(samples),
+    samtbl,
+    by.x = "samples",
+    by.y = "SampleID",
+    all.x = TRUE,
+    sort = FALSE
+  )
 grps <- mergetbl$SampleGroup
 grpnames <- levels(factor(grps))
-col.blocks <-col.grp(grps,grpnames)
-MSIG.geneSets <- read.gmt(paste(data.dir,'geneset.shiny.gmt',sep='/'))
+col.blocks <- col.grp(grps, grpnames)
+MSIG.geneSets <-
+  read.gmt(paste(data.dir, 'geneset.shiny.gmt', sep = '/'))
 
 output$pick.dea <- renderUI({
-    flist <- list.files(data.dir,pattern="*edgeR.txt$")
-    selectInput("file", "Choose Pair", choices=flist)
+  flist <- list.files(data.dir, pattern = "*edgeR.txt$")
+  selectInput("file", "Choose Pair", choices=flist, width = "100%")
 })
 output$pick.pathway <- renderUI({
   pathways <- names(MSIG.geneSets)
-    pathchoices = setNames(1:length(pathways),pathways)
-    selectInput("deapathname", "Choose Pair", choices=pathchoices)
+  pathchoices = setNames(1:length(pathways), pathways)
+  selectInput("deapathname", "Choose Pair", choices = pathchoices)
 })
 
 get.data <- function(var) {
-    f <- paste(data.dir,var$file,sep='/')
-    comp <- read.table(f,header=TRUE,sep='\t')
-    comp.filt <- na.omit(comp[abs(comp$logFC) >= var$fc.thresh & comp$rawP <= var$pval.thresh,])
+  f <- paste(data.dir, var$file, sep = '/')
+ # f <-paste(f, "edgeR.txt", sep = ".") #This line needs to comment out if input is fullname
+  f1 <- paste(data.dir, input$file, sep = '/')
+  hmcomp <-paste("Heatmap of all genes with an FDR < 0.05 using EdgeR Results", sep ='')
+  top50 <- paste("Top 50 User Defined Genes")
+  allgene <- paste("All Differentially Expressed Genes")
+  comp <- read.table(f, header = TRUE, sep = '\t')
+  comp.filt <-
+    na.omit(comp[abs(comp$logFC) >= var$fc.thresh &
+                   comp$rawP <= var$pval.thresh,])
   if (var$adjust == 'FDR') {
-        comp.filt <- na.omit(comp[abs(comp$logFC) >= var$fc.thresh & comp$fdr <= var$pval.thresh,])
+    comp.filt <-
+      na.omit(comp[abs(comp$logFC) >= var$fc.thresh &
+                     comp$fdr <= var$pval.thresh,])
   }
   if (var$adjust == 'BONF') {
-        comp.filt <- na.omit(comp[abs(comp$logFC) >= var$fc.thresh & comp$bonf <= var$pval.thresh,])
+    comp.filt <-
+      na.omit(comp[abs(comp$logFC) >= var$fc.thresh &
+                     comp$bonf <= var$pval.thresh,])
   }
-    genelist <- as.character(head(comp.filt[order(comp.filt$fdr),]$symbol,n=var$numgenes))
+  genelist <-
+    as.character(head(comp.filt[order(comp.filt$fdr),]$symbol, n = var$numgenes))
   if (var$heatmap == 'hgeneset') {
     genelist <- unlist(MSIG.geneSets[as.numeric(var$deapathname)])
   }
   if (var$heatmap == 'cgeneset') {
     genelist <- unlist(strsplit(as.character(var$genes), "[;\n]+"))
   }
-   return(list(filt=comp.filt,glist=genelist))
+  return(
+    list(
+      filt = comp.filt,
+      glist = genelist,
+      f1 = f1,
+      hmcomp = hmcomp,
+      top50 = top50,
+      allgene = allgene
+    )
+  )
 }
 
-tbls <-  eventReactive(input$deButton,{get.data(input)})
+tbls <-  eventReactive(input$deButton,
+                       {
+                         get.data(input)
+                       })
 
 output$selectgenes <- renderUI({
   symnames <- tbls()$glist
-   textAreaInput("genes", "Gene Symbols separated by ';'",value=paste(symnames,collapse=";"), width = '95%',rows=10)
+  textAreaInput(
+    "genes",
+    "Gene Symbols separated by ';'",
+    value = paste(symnames, collapse = ";"),
+    width = '95%',
+    rows = 10
+  )
 })
 
 output$dge.c <- DT::renderDataTable({
   t1 <- tbls()$filt
-    t1$symbol <- paste("<a href=http://www.genecards.org/cgi-bin/carddisp.pl?gene=",t1$symbol,'>',t1$symbol,"</a>",sep='')
-    t1$ensembl <- paste("<a href=http://www.ensembl.org/Homo_sapiens/Gene/Summary?g=",t1$ensembl,'>',t1$ensembl,"</a>",sep='')
+  t1$symbol <-
+    paste(
+      "<a href=http://www.genecards.org/cgi-bin/carddisp.pl?gene=",
+      t1$symbol,
+      '>',
+      t1$symbol,
+      "</a>",
+      sep = ''
+    )
+  t1$ensembl <-
+    paste(
+      "<a href=http://www.ensembl.org/Homo_sapiens/Gene/Summary?g=",
+      t1$ensembl,
+      '>',
+      t1$ensembl,
+      "</a>",
+      sep = ''
+    )
   t1
-},escape=FALSE,filter = 'top',options = list(lengthMenu = c(10, 25, 50, 200, -1)))
+}, escape = FALSE, filter = 'top', options = list(
+  lengthMenu = list(c(10, 25, 50, 100, -1), list('10', '25', '50', '100', 'All')),
+  autoWidth = TRUE,
+  columnDefs = list(list(width = '5%', targets = '0')),
+  scrollX = TRUE
+))
 
-output$downloadC <- downloadHandler(
-                                     file <- paste(input$file,".filt.txt",sep=""),
+output$downloadC <- renderUI({
+  if (!is.null(tbls()$filt)) {
+    downloadButton('OutputFile', 'Download CSV')
+  }
+})
+output$OutputFile <- downloadHandler(
+  file <- paste(input$file, ".filt.txt", sep = ""),
   content = function(file) {
-                                       write.table(tbls()$filt,file,quote=FALSE,row.names=FALSE,sep='\t')
-                                     })
-
+    write.table(
+      tbls()$filt,
+      file,
+      quote = FALSE,
+      row.names = FALSE,
+      sep = '\t'
+    )
+  }
+)
 plotHeatmap <- reactive({
   syms <- tbls()$glist
   ct2 <- cts[cts$SYMBOL %in% syms,]
-	subset <- ct2[,4:length(ct2)]
+  subset <- ct2[, 4:length(ct2)]
   row.names(subset) <- ct2$SYMBOL
   STREE <- hclust(dist(t(subset)))
   zscores <- scale(t(subset))
   ngenes <- length(colnames(zscores))
-      	textscale <- (1/(ngenes/30))
+  textscale <- (1 / (ngenes/30))
   if (textscale > 1) {
-           textscale <-1
+    textscale <- 12
   }
   if (textscale < 0.1) {
-           textscale <- 0.1
+    textscale <- 12
+  }
+  if (input$cluster == 2) {
+    heatmap.2(
+      zscores,
+      col = bluered(100),
+      #Rowv = as.dendrogram(STREE),
+      Rowv = FALSE,
+      Colv = FALSE,
+      lwid = c(0.5,3),
+      RowSideColors = col.blocks,
+      dendrogram = 'row',
+      cexCol = 1.1,
+      srtRow = 45,
+      srtCol = 45,
+      trace = "none",
+      margins = c(8, 7)
+    )
+  } else{
+    heatmap.2(