Commit 6c5b9379 authored by Danni Luo's avatar Danni Luo
Browse files

update shiny code in vizapp

parent b60b1a75
Pipeline #1810 failed with stage
in 2171 minutes and 58 seconds
library(shiny)
library(Vennerable)
library(qusage)
library(DT)
library(ggplot2)
library(ballgown)
library(sqldf)
library(reshape2)
library("gplots")
shinyServer(function(input, output, session) {
data.dir <- Sys.getenv('outputDir')
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/gc.R', local = TRUE)
source('tools/qc.R', local = TRUE)
source('tools/altsplice.R', local = TRUE)
source('tools/dea.R', local = TRUE)
source('tools/gsea.R', local = TRUE)
#source('tools/fastqc.R', local = TRUE)
source('tools/gc_ui.R', local = TRUE)
source('tools/qc_ui.R', local = TRUE)
source('tools/dea_ui.R', local = TRUE)
source('tools/gsea_ui.R', local = TRUE)
#source('tools/fastqc_ui.R', local = TRUE)
source('tools/altsplice_ui.R', local = TRUE)
})
library(shiny)
library(Vennerable)
library(qusage)
library(DT)
library(ggplot2)
library(ballgown)
library(sqldf)
library(reshape2)
library("gplots")
shinyServer(function(input, output, session) {
# 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)
source('tools/dea.R', local = TRUE)
source('tools/gsea.R', local = TRUE)
#source('tools/fastqc.R', local = TRUE)
source('tools/gc_ui.R', local = TRUE)
source('tools/qc_ui.R', local = TRUE)
source('tools/dea_ui.R', local = TRUE)
source('tools/gsea_ui.R', local = TRUE)
#source('tools/fastqc_ui.R', local = TRUE)
source('tools/altsplice_ui.R', local = TRUE)
})
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))
if (exists("var$enssearch") && var$enssearch != '') {
geneid <- as.character(unique(genetrx$g_id[grep(enssearch,genetrx$g_id)]))
}
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,]
grps <- pData(bg)$group
trxnames <- genetrx[genetrx$g_id == geneid,]
dtm <- melt(t(cttbl))
names(dtm) <- c('sample','transcript','value')
dtm$grps <- rep(grps,length(keep))
if (length(keep) < 2) {
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)
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))
}
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))
if (exists("var$enssearch") && var$enssearch != '') {
geneid <- as.character(unique(genetrx$g_id[grep(enssearch, genetrx$g_id)]))
}
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, ]
grps <- pData(bg)$group
trxnames <- genetrx[genetrx$g_id == geneid, ]
dtm <- melt(t(cttbl))
names(dtm) <- c('sample', 'transcript', 'value')
dtm$grps <- rep(grps, length(keep))
if (length(keep) < 2) {
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
)
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
))
}
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 (length(syns) > 1) {
paste("Please Use Official Gene Symbols",synlist,sep=':')
}else {"Please Use Official Gene Symbols"}
}else {NULL}
}
getgeneid <- eventReactive(input$altButton,{
if (input$symsearch == '' & input$enssearch != '') {
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
}
}
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')
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')
}
}, height = 900, width = 900)
})
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) {
plot <- plotMeans(gid,
bg,
groupvar = 'group',
meas = 'cov',
colorby = 'transcript')
}
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"
)
output$ui_altsplice <- renderUI({
fluidPage(
includeCSS("www/style.css"),
sidebarLayout(
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")
),
mainPanel(
tabsetPanel(
tabPanel("Gene Compare",
dataTableOutput('gene.stat'),
dataTableOutput('trx.name'),
plotOutput("plot.cluster"),
plotOutput("trx.gene"),
plotOutput("plot.means")
)
)
)
)
)
list(fluidPage(
includeCSS("www/style.css"),
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", class = "btn btn-primary btn-bg centerbtn")
),
column(7,
tabsetPanel(
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"),
uiOutput('dltrxgene'),
plotOutput("plot.means", height = 900, width = 'auto'),
uiOutput('dlplotmean')
)
))
)
))
})
# 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)
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='/')
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))
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
)
)