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

update shiny code in vizapp

parent b60b1a75
Pipeline #1810 failed with stage
in 2171 minutes and 58 seconds
library(shiny) library(shiny)
library(Vennerable) library(Vennerable)
library(qusage) library(qusage)
library(DT) library(DT)
library(ggplot2) library(ggplot2)
library(ballgown) library(ballgown)
library(sqldf) library(sqldf)
library(reshape2) library(reshape2)
library("gplots") library("gplots")
shinyServer(function(input, output, session) { shinyServer(function(input, output, session) {
data.dir <- Sys.getenv('outputDir') # data.dir <- Sys.getenv('outputDir')
rda.dir <- data.dir data.dir <-"workflow_322_output"
symsyn <- read.table(file='symbol2synonym.txt',header=FALSE) rda.dir <- data.dir
names(symsyn) <- c('symbol','synonyms') symsyn <- read.table(file='symbol2synonym.txt',header=FALSE)
source('functions.R', local = TRUE) names(symsyn) <- c('symbol','synonyms')
source('tools/intro.R', local = TRUE) source('functions.R', local = TRUE)
source('tools/gc.R', local = TRUE) source('tools/intro.R', local = TRUE)
source('tools/qc.R', local = TRUE) source('tools/intro_ui.R', local = TRUE)
source('tools/altsplice.R', local = TRUE) source('tools/gc.R', local = TRUE)
source('tools/dea.R', local = TRUE) source('tools/qc.R', local = TRUE)
source('tools/gsea.R', local = TRUE) source('tools/altsplice.R', local = TRUE)
#source('tools/fastqc.R', local = TRUE) source('tools/dea.R', local = TRUE)
source('tools/gc_ui.R', local = TRUE) source('tools/gsea.R', local = TRUE)
source('tools/qc_ui.R', local = TRUE) #source('tools/fastqc.R', local = TRUE)
source('tools/dea_ui.R', local = TRUE) source('tools/gc_ui.R', local = TRUE)
source('tools/gsea_ui.R', local = TRUE) source('tools/qc_ui.R', local = TRUE)
#source('tools/fastqc_ui.R', local = TRUE) source('tools/dea_ui.R', local = TRUE)
source('tools/altsplice_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='/') get.bgdata <- function(var) {
load(rdafile) rdafile <- paste(data.dir, 'bg.rda', sep = '/')
genetrx <- indexes(bg)$t2g load(rdafile)
genetrx$SYMBOL <- geneNames(bg) 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[genetrx$SYMBOL %in% var$symsearch, ]$g_id))
geneid <- as.character(unique(genetrx$g_id[grep(enssearch,genetrx$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) genebg <- subset(bg, paste0("gene_id=='", geneid, "'"))
fpkm <- texpr(bg,meas='FPKM') rownames(genetrx) <- transcriptNames(bg)
keep <- genetrx[genetrx$g_id == geneid,]$t_id fpkm <- texpr(bg, meas = 'FPKM')
cttbl <- fpkm[keep,] keep <- genetrx[genetrx$g_id == geneid, ]$t_id
grps <- pData(bg)$group cttbl <- fpkm[keep, ]
trxnames <- genetrx[genetrx$g_id == geneid,] grps <- pData(bg)$group
dtm <- melt(t(cttbl)) trxnames <- genetrx[genetrx$g_id == geneid, ]
names(dtm) <- c('sample','transcript','value') dtm <- melt(t(cttbl))
dtm$grps <- rep(grps,length(keep)) names(dtm) <- c('sample', 'transcript', 'value')
if (length(keep) < 2) { dtm$grps <- rep(grps, length(keep))
dtm$transcript <- rep(keep,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) dtm$grptrx <- paste(dtm$grps, dtm$transcript, sep = '.')
if (length(keep) > 1) { test <-
agg = collapseTranscripts(gene=geneid, gown=bg, k=var$kct, method='kmeans') stattest(
test <- stattest(gowntable=agg$tab, pData=pData(bg), feature='transcript_cluster',covariate='group', libadjust=FALSE,getFC=TRUE) gown = genebg,
} pData = pData(bg),
return(list(stattbl=test,gid=geneid,obj=genebg,cttbl=dtm,tname=trxnames)) 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) { find_sym <- function (sym) {
if (!(toupper(sym) %in% toupper(symsyn$symbol))) { if (!(toupper(sym) %in% toupper(symsyn$symbol))) {
syns <- symsyn[grep(input$symsearch,symsyn$synonym,ignore.case=TRUE),]$symbol syns <-
synlist <- paste(as.character(syns),collapse=',') symsyn[grep(input$symsearch, symsyn$synonym, ignore.case = TRUE), ]$symbol
if (length(syns) > 1) { synlist <- paste(as.character(syns), collapse = ',')
paste("Please Use Official Gene Symbols",synlist,sep=':') if (length(syns) > 1) {
}else {"Please Use Official Gene Symbols"} paste("Please Use Official Gene Symbols", synlist, sep = ':')
}else {NULL} } else {
} "Please Use Official Gene Symbols"
}
getgeneid <- eventReactive(input$altButton,{ } else {
if (input$symsearch == '' & input$enssearch != '') { NULL
}
}
getgeneid <- eventReactive(input$altButton, {
if (input$symsearch == '' & input$enssearch != '') {
validate (find_sym(input$symsearch)) validate (find_sym(input$symsearch))
} }
get.bgdata(input) get.bgdata(input)
}) })
output$plot.cluster <- renderPlot({ output$plot.cluster <- renderPlot({
par(oma=c(4,4,1,1)) par(oma = c(0, 0, 0, 0))
gid <- getgeneid()$gid gid <- getgeneid()$gid
bg <- getgeneid()$obj bg <- getgeneid()$obj
tname <- getgeneid()$tname tname <- getgeneid()$tname
if (nrow(tname) > 1) { 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({ output$gene.stat <- DT::renderDataTable({
getgeneid()$stattbl getgeneid()$stattbl
},escape=FALSE) }, escape = FALSE, options = list(dom = 'ft'))
output$trx.name <- DT::renderDataTable({ output$trx.name <- DT::renderDataTable({
getgeneid()$tname 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({ output$plot.means <- renderPlot({
par(oma=c(4,4,1,1)) par(oma = c(1, 4, 1, 8))
par(cex.main=0.75) par(cex.main = 0.75)
gid <- getgeneid()$gid gid <- getgeneid()$gid
bg <- getgeneid()$obj bg <- getgeneid()$obj
tname <- getgeneid()$tname tname <- getgeneid()$tname
if (nrow(tname) > 1) { 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({ output$trx.gene <- renderPlot({
countTable <- getgeneid()$cttbl countTable <- getgeneid()$cttbl
par(oma=c(4,4,1,1)) 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("") 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) 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({ output$ui_altsplice <- renderUI({
fluidPage( list(fluidPage(
includeCSS("www/style.css"), includeCSS("www/style.css"),
sidebarLayout( fluidRow(
sidebarPanel( sidebarPanel(
uiOutput("dir.splice"), uiOutput("dir.splice"),
textInput("symsearch", "Search By Gene Symbol", 'IL1B'), textInput("symsearch", "Search By Gene Symbol", 'IL1B'),
textInput("enssearch", "Search By ENS ID",''), textInput("enssearch", "Search By ENS ID", ''),
numericInput("kct",label = "Number of Clusters",value = 2), numericInput("kct", label = "Number of Clusters", value = 2),
actionButton("altButton", "GO") actionButton("altButton", "GO", class = "btn btn-primary btn-bg centerbtn")
), ),
mainPanel( column(7,
tabsetPanel( tabsetPanel(
tabPanel("Gene Compare", tabPanel(
dataTableOutput('gene.stat'), "Gene Compare",
dataTableOutput('trx.name'), br(),br(),
plotOutput("plot.cluster"), dataTableOutput('gene.stat'),
plotOutput("trx.gene"), br(),br(),
plotOutput("plot.means") 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 # UI-elements for DEA
ctfile <- paste(data.dir,'countTable.logCPM.txt',sep='/') ctfile <- paste(data.dir, 'countTable.logCPM.txt', sep = '/')
samfile <- paste(data.dir,'design.shiny.txt',sep='/') samfile <- paste(data.dir, 'design.shiny.txt', sep = '/')
cts <- read.table(file=ctfile,header=TRUE,sep='\t') cts <- read.table(file = ctfile, header = TRUE, sep = '\t')
samtbl <- read.table(samfile,header=TRUE,sep="\t") samtbl <- read.table(samfile, header = TRUE, sep = "\t")
samples <- colnames(cts[,4:length(cts)]) samples <- colnames(cts[, 4:length(cts)])
mergetbl <- merge(as.data.frame(samples),samtbl,by.x="samples",by.y="SampleID",all.x=TRUE,sort=FALSE) mergetbl <-
merge(
as.data.frame(samples),
samtbl,
by.x = "samples",
by.y = "SampleID",
all.x = TRUE,
sort = FALSE
)
grps <- mergetbl$SampleGroup grps <- mergetbl$SampleGroup
grpnames <- levels(factor(grps)) grpnames <- levels(factor(grps))
col.blocks <-col.grp(grps,grpnames) col.blocks <- col.grp(grps, grpnames)
MSIG.geneSets <- read.gmt(paste(data.dir,'geneset.shiny.gmt',sep='/')) MSIG.geneSets <-
read.gmt(paste(data.dir, 'geneset.shiny.gmt', sep = '/'))
output$pick.dea <- renderUI({ output$pick.dea <- renderUI({
flist <- list.files(data.dir,pattern="*edgeR.txt$") flist <- list.files(data.dir, pattern = "*edgeR.txt$")
selectInput("file", "Choose Pair", choices=flist) selectInput("file", "Choose Pair", choices=flist, width = "100%")
}) })
output$pick.pathway <- renderUI({ output$pick.pathway <- renderUI({
pathways <- names(MSIG.geneSets) pathways <- names(MSIG.geneSets)
pathchoices = setNames(1:length(pathways),pathways) pathchoices = setNames(1:length(pathways), pathways)
selectInput("deapathname", "Choose Pair", choices=pathchoices) selectInput("deapathname", "Choose Pair", choices = pathchoices)
}) })
get.data <- function(var) { get.data <- function(var) {
f <- paste(data.dir,var$file,sep='/') f <- paste(data.dir, var$file, sep = '/')
comp <- read.table(f,header=TRUE,sep='\t') # f <-paste(f, "edgeR.txt", sep = ".") #This line needs to comment out if input is fullname
comp.filt <- na.omit(comp[abs(comp$logFC) >= var$fc.thresh & comp$rawP <= var$pval.thresh,]) f1 <- paste(data.dir, input$file, sep = '/')
if (var$adjust == 'FDR') { hmcomp <-paste("Heatmap of all genes with an FDR < 0.05 using EdgeR Results", sep ='')
comp.filt <- na.omit(comp[abs(comp$logFC) >= var$fc.thresh & comp$fdr <= var$pval.thresh,]) top50 <- paste("Top 50 User Defined Genes")
} allgene <- paste("All Differentially Expressed Genes")
if (var$adjust == 'BONF') { comp <- read.table(f, header = TRUE, sep = '\t')
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 &
genelist <- as.character(head(comp.filt[order(comp.filt$fdr),]$symbol,n=var$numgenes)) comp$rawP <= var$pval.thresh,])
if (var$heatmap == 'hgeneset') { if (var$adjust == 'FDR') {
genelist <- unlist(MSIG.geneSets[as.numeric(var$deapathname)]) comp.filt <-
} na.omit(comp[abs(comp$logFC) >= var$fc.thresh &
if (var$heatmap == 'cgeneset') { comp$fdr <= var$pval.thresh,])
genelist <- unlist(strsplit(as.character(var$genes), "[;\n]+")) }
} if (var$adjust == 'BONF') {
return(list(filt=comp.filt,glist=genelist)) 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
)
)
} }
tbls <- eventReactive(input$deButton,{get.data(input)}) tbls <- eventReactive(input$deButton,
{
get.data(input)
})
output$selectgenes <- renderUI({ output$selectgenes <- renderUI({
symnames <- tbls()$glist symnames <- tbls()$glist