Commit 422f4fa1 authored by Brandi Cantarel's avatar Brandi Cantarel

update shiny code, process scripts

parent 5a4a99e9
Pipeline #2905 failed with stage
in 0 seconds
......@@ -188,19 +188,26 @@ workflow_parameters:
# The workflow must publish all final output into $baseDir
# Name of the R module that the vizapp will run against
vizapp_r_module: 'R/3.2.1-intel'
vizapp_r_module: 'R/3.4.1-gccmkl'
# List of any CRAN packages, not provided by the modules, that must be made
# available to the vizapp
vizapp_cran_packages:
- sqldf
- crosstalk
- htmltools
- htmlwidgets
- httpuv
- shiny
- Vennerable
- DT
- grid
- gridExtra
- ggplot2
- gplots
- gtools
- RColorBrewer
- tidyverse
# # List of any Bioconductor packages, not provided by the modules, that must be made
......
options("repos"="http://cran.rstudio.com/")
update.packages()
install.packages("sqldf",dep=TRUE)
#install.packages("sqldf",dep=TRUE)
install.packages("gmp",dep=TRUE)
install.packages("shinythemes",dep=TRUE)
install.packages(c('gplots','lattice','latticeExtra','vegan','labdsv','cluster','ggplot2'))
install.packages(c('gplots','lattice','latticeExtra','vegan','labdsv','cluster','ggplot2',"tidyverse"))
install.packages("Vennerable", repos="http://R-Forge.R-project.org",type='source')
source("http://bioconductor.org/biocLite.R")
biocLite(c('graph', 'RBGL', 'RColorBrewer', 'reshape', 'gtools',"edgeR", "DESeq2","qusage","ballgown"))
......@@ -4,9 +4,11 @@ library(qusage)
library(DT)
library(ggplot2)
library(ballgown)
library(sqldf)
library(tidyverse)
library(reshape2)
library("gplots")
library(gridExtra)
library(grid)
shinyServer(function(input, output, session) {
......
# 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, width = "800px")
flist <- list.files(data.dir,pattern="*edgeR.txt$")
selectInput("file", "Choose Pair", choices=flist)
})
output$pick.pathway <- renderUI({
pathways <- names(MSIG.geneSets)
pathchoices = setNames(1:length(pathways), pathways)
selectInput("deapathname", "Choose Pair", choices = pathchoices)
pathways <- names(MSIG.geneSets)
pathchoices = setNames(1:length(pathways),pathways)
selectInput("deapathname", "Choose Pair", choices=pathchoices)
})
get.data <- function(var) {
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,])
}
if (var$adjust == 'BONF') {
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))
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,
f1 = f1,
hmcomp = hmcomp,
top50 = top50,
allgene = allgene,
cluster=input$cluster
)
)
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,])
if (var$adjust == 'FDR') {
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,])
}
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))
}
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
)
symnames <- tbls()$glist
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
}, 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
))
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
},escape=FALSE,filter = 'top',options = list(lengthMenu = c(10, 25, 50, 200, -1)))
output$downloadC <- downloadHandler(
file <- paste(input$file,".filt.txt",sep=""),
content = function(file) {
write.table(tbls()$filt,file,quote=FALSE,row.names=FALSE,sep='\t')
})
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'
)
}
)
plotHeatmap <- reactive({
syms <- tbls()$glist
ct2 <- cts[cts$SYMBOL %in% syms,]
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))
if (textscale > 1) {
textscale <- 12
}
if (textscale < 0.1) {
textscale <- 12
}
if (tbls()$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(
zscores,
col = bluered(100),
Rowv = as.dendrogram(STREE),
RowSideColors = col.blocks,
dendrogram = 'row',
cexCol = 1.1,
srtRow = 45,
srtCol = 45,
lwid = c(0.5,3),
trace = "none",
margins = c(8, 7)
)
}
legend("top",
legend = grpnames,
col = rainbow(length(grpnames)),
pch = 20)
syms <- tbls()$glist
ct2 <- cts[cts$SYMBOL %in% syms,]
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))
if (textscale > 1) {
textscale <-1
}
if (textscale < 0.1) {
textscale <- 0.1
}
heatmap.2(zscores, col = bluered(100),Rowv = as.dendrogram(STREE), RowSideColors = col.blocks,dendrogram='row', cexCol=textscale,srtRow=45,srtCol=45,trace="none",margins=c(8,16))
legend("topright",legend=grpnames,col=rainbow(length(grpnames)),pch=20)
})
output$plot.heatmap <- renderPlot({
plotHeatmap()
})
output$dlheatmap <- renderUI({
if (!is.null(tbls()$glist)) {
downloadButton('Downloadhp', 'Download PNG')
}
plotHeatmap()
})
output$Downloadhp <- downloadHandler(
file = function() {
paste('mean', 'png', sep = ".")
},
content <- function(file) {
png(
file,
width = 8 * 140,
height = 4 * 100,
res = 140,
pointsize = 5
)
if (is.null(tbls()$glist)) {
return()
}
syms <- tbls()$glist
ct2 <- cts[cts$SYMBOL %in% syms,]
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))
if (textscale > 1) {
textscale <- 12
}
if (textscale < 0.1) {
textscale <- 12
}
if (tbls()$cluster == 2) {
plot <- heatmap.2(
zscores,
col = bluered(100),
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{
plot <- heatmap.2(
zscores,
col = bluered(100),
Rowv = as.dendrogram(STREE),
RowSideColors = col.blocks,
dendrogram = 'row',
cexCol = 1.1,
srtRow = 45,
srtCol = 45,
lwid = c(0.5,3),
trace = "none",
margins = c(8, 7)
)
}
legend("top",
legend = grpnames,
col = rainbow(length(grpnames)),
pch = 20)
print(plot)
dev.off()
},
contentType = "image/png"
)
output$downloadpdf = downloadHandler(
filename = "output.heatmap.pdf",
content = function(file) {
pdf(file = file, paper = "letter")
plotHeatmap()
dev.off()
}
)
filename = "output.heatmap.pdf",
content = function(file) {
pdf(file = file,paper="letter")
plotHeatmap()
dev.off()
})
output$hm.comp <- renderImage({
f1 <- paste(tbls()$f1)
png <- gsub('edgeR.txt', 'heatmap.edgeR.png', f1)
list(
src = png,
alt = paste("HeatMap Comparison"),
width = "100%",
height = "auto"
)
}, deleteFile = FALSE)
f1 <- paste(data.dir,input$file,sep='/')
png <- gsub('edgeR.txt','heatmap.edgeR.png',f1)
list(src=png, alt=paste("HeatMap Comparison"))
},deleteFile=FALSE)
output$dlhmcomp <- renderUI({
if (!is.null(tbls()$f1)) {
downloadButton('Downloadhm', 'Download PNG')
}
})
output$Downloadhm <- downloadHandler(
file = function() {
paste('heatmap_comp', 'png', sep = ".")
},
content <- function(file) {
f1 <- paste(tbls()$f1)
png <- gsub('edgeR.txt', 'heatmap.edgeR.png', f1)
file.copy(png, file)
}
)
output$hmcomp.allgene <- renderText({
paste(tbls()$allgene)
})
output$hmcomp.top50 <- renderText({
paste(tbls()$top50)
})
output$hmcomp.desc <- renderText({
paste(tbls()$hmcomp)
})
output$hmcomp.desc <- renderText({
paste("Heatmap of all genes with an FDR < 0.05 using EdgeR Results",sep='')
})
samfile <- paste(data.dir, 'design.shiny.txt', sep = '/')
samtbl <- read.table(samfile, header = TRUE, sep = "\t")
samtbl <- read_tsv(paste(data.dir,'design.shiny.txt',sep='/'))
wrapper <- function(x, ...)
{
paste(strwrap(x, ...), collapse = "\n")
}
output$pick.group <- renderUI({
opts <- names(samtbl)
selectInput("groupname",
"Plot By",
choices = opts,
selected = 'SampleGroup')
opts <- names(samtbl)
selectInput("groupname", "Plot By", choices=opts,selected='SampleGroup')
})
get.ct <- function(var) {
ctfile <- paste(data.dir, 'countTable.logCPM.txt', sep = '/')
statfile <- paste(data.dir, 'edgeR.results.txt', sep = '/')
wp.df <- data.frame(Column1 = c(0), Column2 = c(0))
bx <-
paste(
"Relative Abudance of",
input$gc_symsearch,
"calculated by Log2(Counts Per Million Reads). Boxplots draw to represent the 25th and 75th percentile (the lower and upper quartiles, respectively) as a box with a band in the box representing 50th percentile (the median). The upper whisker is located at the 'smaller' of the maximum x value and Q_3 + 1.5 inner quantile range(IRQ), whereas the lower whisker is located at the 'larger' of the smallest x value and Q_1 - 1.5 IQR",
sep = ' '
)
vio <- paste(
"Relative Abudance of",
input$gc_symsearch,
input$gc_enssearch,
"calculated by Log2(Counts Per Million Reads). Violin plot is similar to box plots above, except that it also show the kernel probability density of the data at different value. Violin plots include a marker for the median of the data and a box indicating the interquartile range, as in boxplot above.",
sep = ' '
)
if (nchar(as.vector(var$gc_symsearch)) > 2) {
cts <-
read.csv.sql(
ctfile,
sql = paste("select * from file where symbol ='", var$gc_symsearch, "'", sep =
''),
sep = "\t"
)
if (file.exists(statfile)) {
wp.df <-
read.csv.sql(
statfile,
sql = paste(
"select * from file where symbol ='",
var$gc_symsearch,
"'",
sep = ''
),
sep = "\t"
)
cttbl <- read_tsv(paste(data.dir,'countTable.logCPM.txt',sep='/'))
if ("symsearch" %in% names(var)) {
if (length(as.character(var$symsearch)) > 2) {
cts <- filter(cttbl,SYMBOL == var$symsearch)
}
}
else {
if (nchar(as.vector(var$gc_enssearch)) > 2) {
cts <-
read.csv.sql(
ctfile,
sql = paste(
"select * from file where ENSEMBL ='",
var$gc_enssearch,
"'",
sep = ''
),
sep = "\t"
)
if (file.exists(statfile)) {
wp.df <-
read.csv.sql(
statfile,
sql = paste(
"select * from file where ENSEMBL ='",
var$gc_enssearch,
"'",
sep = ''
),
sep = "\t"
)
}
}
if ("enssearch" %in% names(var)) {
if (length(as.character(var$enssearch)) > 2) {
cts <- filter(cttbl,ENSEMBL == var$enssearch)
}
}
countTable <- gather(select(cts,4:length(cts)),key="SampleID",value="cts")
newdf <- inner_join(countTable,samtbl)
return(list(ctable=newdf))
}
countTable <- cts[, 4:length(cts)]
samples <- colnames(countTable)
mergetbl <-
merge(
as.data.frame(samples),
samtbl,
by.x = "samples",
by.y = "SampleID",
all.x = TRUE,
sort = FALSE
)
grps <- mergetbl[, var$groupname]
newdf <- data.frame(ct = t(countTable), grp = as.character(grps))
names(newdf) = c('cts', 'grp')
return(list(
ctable = newdf,
tbl = cts,
design = samtbl,
stats = wp.df,
bx = bx,
vio = vio
))
}
forct <- eventReactive(input$gcButton, {
get.ct(input)
})
forct <- eventReactive(input$gcButton,{get.ct(input)})
output$plot.gene <- renderPlot({
countTable <- forct()$ctable
par(oma = c(4, 4, 1, 1))
grpnames <- levels(factor(as.character(countTable$grp)))
p <- ggplot(countTable, aes(x = grp, y = cts)) + ggtitle(input$groupname) + theme_bw() +
theme(plot.title = element_text(
hjust = 0.5,
size = 18,
margin = margin(b = 20, unit = "pt")
)) + geom_boxplot(trim = FALSE, aes(fill = factor(grp))) +
theme(
legend.position = "none",
axis.title.y = element_text(size =14),
axis.text.y = element_text(size =14),
axis.text.x = element_text(
angle = 45,
hjust = 1,
vjust = 1,
size =14
)
) + ylab("Relative Abundance (logCPM)") + xlab("")
print(p)
}, height = "auto", width = 'auto')
newdf <- forct()$ctable
p1 <- ggplot(newdf, aes(x=!!as.symbol(input$groupname), y=cts,fill=!!as.symbol(input$groupname))) + geom_boxplot() + theme(legend.position="top",axis.text.x=element_text(angle=45,hjust=1, vjust=1)) + labs(title=paste("Relative Abudance of",input$symsearch),x=input$groupname, y = "Relative Abundance (logCPM)",caption=wrapper("Boxplots draw to represent the 25th and 75th percentile (the lower and upper quartiles, respectively) as a box with a band in the box representing 50th percentile (the median). The upper whisker is located at the 'smaller' of the maximum x value and Q_3 + 1.5 inner quantile range(IRQ), whereas the lower whisker is located at the 'larger' of the smallest x value and Q_1 - 1.5 IQR")) + theme(legend.position = "bottom",plot.margin = margin(15, 15, 15, 15),plot.caption = element_text(size = 10, hjust = 0))
p2 <- ggplot(newdf, aes(x=!!as.symbol(input$groupname), y=cts,fill=!!as.symbol(input$groupname))) + geom_violin() + theme(legend.position="top",axis.text.x=element_text(angle=45,hjust=1, vjust=1)) + labs(title=paste("Relative Abudance of",input$symsearch),x=input$groupname, y = "Relative Abundance (logCPM)",caption=wrapper("Violin plot shows the kernel probability density of the data at different value. Violin plots include a marker for the median of the data and a box indicating the interquartile range")) + theme(legend.position = "bottom",plot.margin = margin(15, 15, 15, 15),plot.caption = element_text(size = 10, hjust = 0))
grid.arrange(p1,p2,nrow=2)
}, height = 900, width = 900)
output$dlboxplot <- renderUI({
if (!is.null(forct()$ctable)) {
downloadButton('Downloadbp', 'Download PNG')
}
})
output$Downloadbp <- downloadHandler(
file = function() {