In montilab/K2Taxonomer: Creating annotated submodules of high-throughput data through recursive partitioning
if (file.exists("about.md")) {
cat(paste(readLines("about.md"), collapse=" \n"))
}
library(shiny)
library(K2Taxonomer)
library(visNetwork)
library(plotly)
library(heatmaply)
library(DT)
library(Biobase)
library(RColorBrewer)
library(limma)
library(dendextend)
## Read in helper functions
source(system.file("dashboard", "DashHelper.R", package="K2Taxonomer"))
## Read in analysis results
K2res <- readRDS("K2results.rds")
## Parse results
info <- K2meta(K2res)$info; infoMat <- as.matrix(info) ## Get Information
K2list <- K2results(K2res) ## Get K2 results list
dataMatrix <- K2data(K2res) ## Get dataMatrix
genesets <- K2genesets(K2res) ## Get geneset lists
gene2Pathway <- K2gene2Pathway(K2res) ## Get gene2pathway matching
if(nrow(K2eMatDS(K2res)) != 0) {
eMat <- K2eMatDS(K2res)
} else {
eMat <- K2eMat(K2res)
}
gMat <- K2gMat(K2res) ## Get gene set projection expression set
meta <- K2meta(K2res) ## Get meta data
geneURL <- K2geneURL(K2res) ## Get meta data
genesetURL <- K2genesetURL(K2res) ## Get meta data
K2dendrogram <- K2dendro(K2res) ## Create static dendrogram
colDat <- K2colData(K2res) ## Get obervation level meta data
# Get differential gene expression results
dgeTable <- getDGETable(K2res)
# Get enrichment results
enrTable <- getEnrichmentTable(K2res)
## Remove dge from K2list
K2list <- lapply(K2list, function(x) {
x$dge <- NULL; return(x)
})
## Remove gse from K2list
K2list <- lapply(K2list, function(x) {
x$gse <- NULL; return(x)
})
## Remove dsse from K2list
K2list <- lapply(K2list, function(x) {
x$dsse <- NULL; return(x)
})
## Create interactive dendrogram
vNetOut <- K2visNetwork(K2res, labelsize = 100)
## Remove K2res to save space
rm(K2res); invisible(gc(verbose = FALSE))
## If too many observations in terminal labels, unlabel them
if (max(lengths(regmatches(vNetOut$x$nodes$label, gregexpr("\n",
vNetOut$x$nodes$label)))) > 20 ) {
## Fix font size
vNetOut$x$nodes$font.size <- 25
vNetOut$x$nodes$font.size[vNetOut$x$nodes$shape == "box"] <- 0
## Change shape
vNetOut$x$nodes$shape[vNetOut$x$nodes$shape == "box"] <- "square"
}
## Format enrichment table
## Remove unnecessary columns
enrTable <- enrTable[, !colnames(enrTable) %in% c("ntot", "t")]
## Add aliases for plotting and looking up
enrTable$Plot <- paste0("<label for='PlotRow",
seq(nrow(enrTable)),
"'>📊</label>")
enrTable$Send <- paste0("<label for='SendRow",
seq(nrow(enrTable)),
"'>✈</label>")
## Add links to gene sets
geneSetStringL <- "<a href='"
geneSetStringR <- "' style='text-decoration:none' target='_blank'>🔍</a>"
genesetURLsub <- genesetURL[enrTable$category]
enrTable$Link <- paste0(geneSetStringL, genesetURLsub, geneSetStringR)
## Format numbers to fit in table
for (i in c("pval_fisher", "fdr_fisher", "pval_limma", "fdr_limma")) {
enrTable[,i] <- signif(enrTable[,i], digits=2)
}
## Format numbers to fit in table
for (i in c("coef", "mean")) {
enrTable[,i] <- round(enrTable[,i], digits=2)
}
colnames(enrTable) <- c("Gene Set", "Node", "Edge", "Direction",
"P Value_Fisher", "FDR_Fisher", "N_Overlap", "N_Sig. Genes", "N_Gene Set",
"P Value_Score", "FDR_Score", "Diff_Score", "Mean_Score", "Hits",
"Plot", "Send", "Link")
## Format differential gene expression results
## Add aliases for plotting and looking up
dgeTable$Plot <- paste0("<label for='PlotRow",
seq(nrow(dgeTable)),
"'>📊</label>")
dgeTable$Send <- paste0("<label for='SendRow",
seq(nrow(dgeTable)),
"'>✈</label>")
### Add links to genes
geneStringL <- "<a href='"
geneStringR <- "' style='text-decoration:none' target='_blank'>🔍</a>"
geneURLsub <- geneURL[dgeTable$gene]
dgeTable$Link <- paste0(geneStringL, geneURLsub, geneStringR)
## Reorder columns
dgeTable <- dgeTable[,c("gene", "node", "edge", "direction", "pval", "fdr",
"coef", "mean", "Plot", "Send", "Link")]
## Format numbers to fit in table
for (i in c("pval", "fdr")) {
dgeTable[,i] <- signif(dgeTable[,i], digits=2)
}
## Format numbers to fit in table
for (i in c("coef", "mean")) {
dgeTable[,i] <- round(dgeTable[,i], digits=2)
}
## Rename columns
colnames(dgeTable) <- c("Gene", "Node", "Edge", "Direction", "P Value", "FDR",
"Diff", "Mean", "Plot", "Send", "Link")
### Set select input options for annotations bar
varOptions <- sort(colnames(info)[-1])
names(varOptions) <- varOptions
varOptions <- c("Add Variables:"="", varOptions, "Reset"="RESET")
### Get sample order
labs <- get_leaves_attr(K2dendrogram, "label")
## Get IDs of each group
obsMap <- unlist(lapply(K2list, function(x) x$obs), recursive=FALSE)
## Set enrichment score label
ScoreGeneSetMethod <- meta$ScoreGeneSetMethod
## Set enrichment score label
if(meta$ScoreGeneSetMethod == "GSVA") {
enrYlab <- "GSVA Score"
} else {
enrYlab <- "Log2 AUCell Score"
}
observeEvent(values$gp, {
withProgress({
input$`plotly_afterplot-A`
for(i in seq(10)) {
incProgress(1/10)
Sys.sleep(0.05)
}
}, message="Rendering...", min=0, max=1, value=1)
values$gp <- NULL
})
K2Taxonomer Results {data-orientation=rows}
## Reactive values
values <- reactiveValues(nodeSel="A", pathSel="A", nodeSelHE = "A", nodeSel = "A")
Sidebar {.sidebar}
## Out of global help button
textInput("mstring", "Member Search:", value="")
uiOutput("SI")
Row {data-height=600}
K2Taxonomer Results
visNetworkOutput("dendro")
Subgroup Information (↑=Edge:1; ↓=Edge:2)
# Show tabset of node information
div(
tabsetPanel(type="tabs",
tabPanel("Stability", fillCol(
fluidRow(
column(width=10, selectInput("selCov", NULL, varOptions), offset=1),
plotlyOutput("heatmapPlot", width = "100%"),
column(width=10, htmlOutput("stabStats"), offset=1)
))),
tabPanel("Node members", fillCol(
DT::dataTableOutput("infoTab")
))
), style='height: 600px'
)
sendString <- eventReactive({input$mstring}, {
## Get info matches for this string
if (!is.null(input$mstring) && (input$mstring != "" &
sum(grepl(input$mstring, infoMat, ignore.case=TRUE)) != 0)) {
## Find matches in the terminal leafs
infoInd <- unique(which(`dim<-`(grepl(input$mstring, infoMat,
ignore.case=TRUE), dim(infoMat)), arr.ind=TRUE)[,1])
## Generate string to show
showString <- vapply(infoInd, function(row) paste0(
paste(paste0(colnames(infoMat), ":", infoMat[row,]),
collapse="\n"), "\n"), FUN.VALUE=character(1))
## Get number of matches
nMatches <- paste0(length(infoInd), " match(es)")
valueString <- c(nMatches, rownames(infoMat)[infoInd])
names(valueString) <- c(nMatches, showString)
} else {
valueString <- c("No Matches")
}
valueString
})
output$SI <- renderUI({
selectizeInput("mVal", label = "Select a Match:", choices = sendString())
})
## Reactive row selection
observeEvent({input$mVal}, {
## Select path to a specific member by searching
if (!is.null(input$mVal) && input$mVal %in% rownames(info) &&
input$mVal != values$nodeSel){
values$pathSel <- as.character(vNetOut$x$nodes$id[
grep(paste0("^", input$mVal, "<br>|<br>", input$mVal,
"<br>|", input$mVal, "$"), vNetOut$x$nodes$title)])
}
})
## Render Dendrogram
output$dendro <- renderVisNetwork({
values$gp <- TRUE
vNetOut %>%
visOptions(autoResize=TRUE,
height="100%",
nodesIdSelection=list(enabled=TRUE,
main="Node ID",
style='width: 100px; height: 25px;',
selected=values$pathSel),
#style='width: 100px; height: 25px;'),
highlightNearest=list(enabled=TRUE,
algorithm="hierarchical",
degree=1E10)) %>%
visNodes(font=list(size=50),
size=40,
color=list(
background="white",
border="#2B7CE9",
highlight="red")) %>%
visEdges(width=11, smooth=TRUE) %>%
visPhysics(hierarchicalRepulsion=list(nodeDistance=200)) %>%
visHierarchicalLayout(direction="LR", levelSeparation=300) %>%
visInteraction(dragNodes=FALSE, zoomSpeed = 0.1)
})
## Render heatmap of cluster stability
output$heatmapPlot <- renderPlotly({
## Get values to add
if (!is.null(input$selCov) && input$selCov %in% colnames(info)) {
values$selCov <- unique(c(values$selCov, input$selCov))
} else {
values$selCov <- NULL
}
if (values$nodeSel %in% names(K2list)){
## Get matrix and sort
samp_stab <- as.matrix(K2list[[values$nodeSel]]$stability$samples)
ord <- order(match(colnames(samp_stab), labs))
samp_stab <- as.matrix(samp_stab)[ord, ord]
## Get sample groups
modList <- K2list[[values$nodeSel]]$obs
## Create column annotation
colrowAnnot <- data.frame(Group=c(rep("Edge:1", length(modList[[1]])),
rep("Edge:2", length(modList[[2]]))),
row.names=c(modList[[1]], modList[[2]])
)[colnames(samp_stab), , drop=FALSE]
## If no selections just color groups
colSidePalette <- c("#000000", "#808080")
names(colSidePalette) <- c("Edge:1", "Edge:2")
## If selections are made add colors
if (!is.null(values$selCov)){
## Initialize
colValues <- c()
colSidePalette <- c()
## Get info for these samples
infoSub <- info[colnames(samp_stab), values$selCov]
colrowAnnot <- cbind(infoSub, colrowAnnot)
colnames(colrowAnnot) <- c(values$selCov, "Edge")
## SET VALUES AND COLOR PALLETES
for (i in values$selCov) {
colrowAnnot[,i] <- paste(i, colrowAnnot[,i], sep=":")
addValues <- info[,i]; addValues <- addValues[!is.na(addValues)]
addValuesUnique <- unique(addValues)
colValues <- c(colValues, paste(i, addValuesUnique, sep=":"))
## If a factor or character add unique values for each unique value
if ( class(addValues) %in% c("character", "factor") ) {
colSidePalette <- c(colSidePalette,
heatmaply:::default_side_colors(length(addValuesUnique)))
## Otherwise use a color gradient based on z-scored quantile
} else {
addValuesNorm <- unique(qnorm(rank(addValues)/
(length(addValues)+1)))
addValuesCut <- rep(NA, length(addValuesNorm))
cuts <- c(-Inf, -2, -1.5, -1, -0.5, 0.5, 1, 1.5, 2)
for (j in seq(length(cuts))) {
addValuesCut[addValuesNorm > cuts[j]] <- j
}
contPallete <- brewer.pal(9, "Greens")[addValuesCut]
colSidePalette <- c(colSidePalette, contPallete)
}
}
## Create pallette of all possible factors
colSidePalette <- c(colSidePalette, "#000000", "#808080",
rep("#D3D3D3", length(values$selCov)))
names(colSidePalette) <- c(colValues, "Edge:1", "Edge:2",
paste0(values$selCov, ":NA"))
}
values$gp <- TRUE
hm <- heatmaply(x=samp_stab,
color=rev(RdBu(n=256)),
limits=c(-1, 1),
col_side_colors=colrowAnnot,
col_side_palette=colSidePalette,
hide_colorbar=TRUE,
margins=c(0,25,50,25),
key.title=NULL,
dendrogram=FALSE,
showticklabels=FALSE)
## Remove legend
hm$x$layout$showlegend <- FALSE
## Change value to cosine similarity
whHeatmap <- which(unlist(lapply(hm$x$data, function(x) {
x$type == "heatmap"
}))) ## Get heatmap index
hm$x$data[[whHeatmap]]$text <- sub("value:", "cos similarity:",
hm$x$data[[whHeatmap]]$text)
return(hm)
} else {
text=paste("\n No node selected. \n")
hm <- ggplot() +
annotate("text", x=0, y=0, size=8, label=text) +
theme_bw() +
theme(axis.line=element_blank(),
axis.text.x=element_blank(),
axis.text.y=element_blank(),
axis.ticks=element_blank(),
axis.title.x=element_blank(),
axis.title.y=element_blank(),
legend.position="none",
panel.background=element_blank(),
panel.border=element_blank(),
panel.grid.major=element_blank(),
panel.grid.minor=element_blank(),
plot.background=element_blank())
return(ggplotly(hm))
}
})
## Render stability statistics
output$stabStats <- renderUI({
if (values$nodeSel %in% names(K2list)){
bootProb <- K2list[[values$nodeSel]]$bootP
nodeStab <- K2list[[values$nodeSel]]$stability$node
sampStab <- K2list[[values$nodeSel]]$stability$clusters
outBoot <- paste0("<br> Bootstrap Probability: <b>", bootProb, "</b>")
outNode <- paste0("<br> Partition Stability: <b>", signif(nodeStab, 2),
"</b> <br>")
outStab <- paste0("Subgroup Stability <br>   Edge:1= <b>",
signif(sampStab[1], 2), "</b>   Edge:2= <b>",
signif(sampStab[2], 2))
HTML(paste(outBoot, outNode, outStab))
} else {
HTML("")
}
})
## Render table of information for each node
output$infoTab <- renderDataTable({
## Get observations
obs1 <- K2list[[values$nodeSel]]$obs[[1]]
obs2 <- K2list[[values$nodeSel]]$obs[[2]]
## Format Cluster information
infoSub <- info[c(obs1, obs2), , drop=FALSE]
infoSub$Edge <- "1"
infoSub$Edge[rownames(infoSub) %in% obs2] <- "2"
infoSub <- infoSub[ , c(ncol(infoSub), seq(ncol(infoSub) - 1)) ]
datatable(infoSub,
rownames=FALSE,
filter=list(position='top', clear=FALSE),
extensions='Buttons',
options=list(dom='Brt',
search=list(regex=TRUE, caseInsensitive=FALSE),
scrollX=TRUE,
scrollY="400px",
paging=FALSE,
pageLength=nrow(infoSub),
buttons=c('csv', 'excel'),
columnDefs=list(
list(className='dt-center', targets="_all")
)),
selection="none")
})
## Selections of dendrogram
observeEvent({
input$dendro_selected
}, {
node=input$dendro_selected
if (node %in% names(K2list) & node != values$nodeSel) {
values$nodeSel <- node
values$nodeSelDGE <- node
values$nodeSelHE <- node
values$geneList <-
values$groupDGE <-
values$dgeHits <-
values$Hits <-
values$groupDGE <- NULL
}
},
ignoreNULL=TRUE,
ignoreInit=TRUE
)
Row {data-height=550}
Differential Expression Analysis Results
## Show genetable results
DT::dataTableOutput("DGE")
## Render genetable results
output$DGE <- renderDataTable({
values$dgeHeld
geneTable(dgeTable, values$nodeSelHE, values$geneList)
})
## Control Searches
observeEvent(input$DGE_search_columns, {
if (!is.null(values$geneList)) {
if (input$DGE_search_columns[1] != values$geneList) {
values$heHeld <- runif(1, 0, 1)
values$geneList <- NULL
values$nodeSelHE <- gsub("\\$|\\^", "", input$DGE_search_columns[2])
}
}
})
## Functions for help and download the data
geneHelpShow <- function() {
div(id="geneHelp",
modalDialog("1) Use ^SEARCHTERM$ to filter for exact matches in
columns",
br(),
HTML("2) Select '📊' to plot gene expression below."),
br(),
HTML("3) Select '✈' to send row information to look up
pathways which include this gene in enrichment results above."),
br(),
easyClose=TRUE, title="Help")
)
}
## Functions to download the data
geneTabDL <- function() {
div(id="geneDL",
modalDialog(downloadButton("downloadGeneCSV",
"Download Table as CSV file"),
br(),
br(),
easyClose=TRUE, title="Download Table")
)
}
## Pop-up for help
observeEvent(input$geneHelp, {
showModal(geneHelpShow())
})
## Download CSV File
output$downloadGeneCSV <- downloadHandler(
filename=function() {
paste("generesults-", Sys.Date(), ".csv", sep="")
},
content=function(file) {
write.csv(dgeTable[,seq(8)], file, row.names=FALSE)
}
)
## Pop-up for CSV file
observeEvent(input$geneDL, {
showModal(geneTabDL())
})
## Get output
observeEvent(input$DGE_cell_clicked,
{
if (!is.null(input$DGE_cell_clicked$value)) {
## Get Value
dgeVal <- gsub(
"<label for='|'>✈</label>|'>📊</label>",
"",
as.character(input$DGE_cell_clicked$value))
## Check that a link was clicked
if (grepl("PlotRow|SendRow", dgeVal)) {
rowNum <- as.numeric(sub("PlotRow|SendRow", "", dgeVal))
GENERow <- dgeTable[rowNum, , drop=FALSE]
## If plotting send the node to plot, otherwise global
if (grepl("PlotRow", dgeVal)) {
values$Genep <- GENERow[, "Gene"]
values$nodeSelDGEp <- GENERow[, "Node"]
} else {
values$Gene <- GENERow[, "Gene"]
values$nodeSelDGE <- GENERow[, "Node"]
values$groupDGE <- GENERow[, "Edge"]
if (values$Gene %in% names(gene2Pathway)) {
values$dgeHits <- paste0("^", gsub("; ", "$|^",
gene2Pathway[[values$Gene]]), "$")
} else {
values$dgeHits <- "NO GENE SETS FOUND."
}
}
}
}
})
Row {data-height=500}
Gene Expression
## Render genePlot
output$genePlot <- renderPlotly({
if (!is.null(values$nodeSelDGEp)){
values$gp <- TRUE
plotGenePathwayDash(eMat,
colDat,
values$Genep,
K2list[[values$nodeSelDGEp]]$obs[[1]],
K2list[[values$nodeSelDGEp]]$obs[[2]],
meta$cohorts,
meta$vehicle)
} else {
text=paste("\n Select a gene above \n to show observation-level
expression.")
hm <- ggplot() +
annotate("text", x=0, y=0, size=4, label=text) +
theme_bw() +
theme(axis.line=element_blank(),
axis.text.x=element_blank(),
axis.text.y=element_blank(),
axis.ticks=element_blank(),
axis.title.x=element_blank(),
axis.title.y=element_blank(),
legend.position="none",
panel.background=element_blank(),
panel.border=element_blank(),
panel.grid.major=element_blank(),
panel.grid.minor=element_blank(),
plot.background=element_blank())
ggplotly(hm)
}
})
## Show genePlot output
plotly::plotlyOutput("genePlot")
Row {data-height=550}
Enrichment Results
## Show enrichment table output
DT::dataTableOutput("HE")
## Render enrichment table
output$HE <- renderDataTable({
values$heHeld
genesetTable(enrTable, values$nodeSelHE, values$groupDGE, values$dgeHits)
})
## Control Searches
observeEvent(input$HE_search_columns, {
if (!is.null(values$dgeHits)) {
if (input$HE_search_columns[1] != values$dgeHits) {
values$dgeHeld <- runif(1, 0, 1)
values$dgeHits <- NULL
values$nodeSelDGE <- gsub("\\$|\\^", "", input$HE_search_columns[2])
values$groupDGE <- input$HE_search_columns[3]
}
}
})
## Functions for help
enrHelpShow <- function() {
div(id="enrHelp",
modalDialog(
"1) Use ^SEARCHTERM$ to filter for exact matches in columns",
br(),
HTML(
"2) Select '📊' to plot Gene Set Enrichment Score below."
),
br(),
HTML("3) Select '✈' to send row information to look up results
for individual genes in this pathway below."),
br(),
easyClose=TRUE, title="Help")
)
}
## Functions for download the data
enrTabDL <- function() {
div(id="enrDL",
modalDialog(downloadButton("downloadFisherCSV",
"Download Table as CSV file"),
br(),
br(),
easyClose=TRUE, title="Download Table")
)
}
## Pop-up for help
observeEvent(input$enrHelp, {
showModal(enrHelpShow())
})
## Download CSV File
output$downloadFisherCSV <- downloadHandler(
filename=function() {
paste("enrresults-", Sys.Date(), ".csv", sep="")
},
content=function(file) {
write.csv(enrTable[,seq(10)], file, row.names=FALSE)
}
)
## Pop-up for download
observeEvent(input$enrDL, {
showModal(enrTabDL())
})
## Reactive row selection
observeEvent({input$HE_cell_clicked},
{
if (!is.null(input$HE_cell_clicked$value)) {
## Get Value
enrVal <- gsub(
"<label for='|'>✈</label>|'>📊</label>",
"", as.character(input$HE_cell_clicked$value))
## If PlotRow then set nodeSelHE
if (grepl("PlotRow|SendRow", enrVal)) {
rowNum <- as.numeric(sub("PlotRow|SendRow", "", enrVal))
HYPERRow <- enrTable[rowNum, , drop=FALSE]
## If plotting send the node to plot, otherwise global
if (grepl("PlotRow", enrVal)) {
values$GeneSetp <- HYPERRow[, "Gene Set"]
values$nodeSelHEp <- HYPERRow[, "Node"]
values$groupSelHEp <-HYPERRow[, "Edge"]
values$dirSelHEp <-HYPERRow[, "Direction"]
} else {
values$nodeSelHE <- HYPERRow[, "Node"]
values$Hits <- strsplit(HYPERRow[, "Hits"], ",")[[1]]
values$GeneSet <- HYPERRow[, "Gene Set"]
values$geneList <- paste(paste0("^",
genesets[[values$GeneSet]], "$"), collapse="|")
}
}
}
})
Row {data-height=500}
Gene Set Enrichment Score
## Render pathwayPlot
output$pathwayPlot <- renderPlotly({
if (!is.null(values$nodeSelHEp)){
values$gp <- TRUE
plotGenePathwayDash(gMat,
colDat,
values$GeneSetp,
K2list[[values$nodeSelHEp]]$obs[[1]],
K2list[[values$nodeSelHEp]]$obs[[2]],
meta$cohorts,
meta$vehicle,
ScoreGeneSetMethod)
} else {
text <- paste(
"\n Select a pathway above
to show observation-level enrichment. \n")
hm <- ggplot() +
annotate("text", x=0, y=0, size=4, label=text) +
theme_bw() +
theme(axis.line=element_blank(),
axis.text.x=element_blank(),
axis.text.y=element_blank(),
axis.ticks=element_blank(),
axis.title.x=element_blank(),
axis.title.y=element_blank(),
legend.position="none",
panel.background=element_blank(),
panel.border=element_blank(),
panel.grid.major=element_blank(),
panel.grid.minor=element_blank(),
plot.background=element_blank())
ggplotly(hm)
}
})
## Show pathwayPlot output
plotly::plotlyOutput("pathwayPlot")
Compare Multiple {data-orientation=rows}
## Generate Dendrogram
output$dendroSelect <- renderVisNetwork({
values$Held
values$gp <- TRUE
vNetOut %>%
visOptions(autoResize=TRUE,
nodesIdSelection=list(enabled=TRUE,
style='width: 0px; height: 0px;'),
highlightNearest=list(enabled=TRUE,
algorithm="hierarchical",
degree=1E10)) %>%
visNodes(font=list(size=50), size=40) %>%
visEdges(width=11,
smooth=TRUE,
color=list(inherit='to')) %>%
visPhysics(hierarchicalRepulsion=list(nodeDistance=200)) %>%
visHierarchicalLayout(direction="LR", levelSeparation=300) %>%
visInteraction(multiselect=TRUE) %>%
visEvents(type="on",
hold="function(nodes) {
Shiny.onInputChange('Held', nodes.nodes);
;}",
deselectNode="function(nodes) {
Shiny.onInputChange('Held', null);
;}")
})
## Allow multiple selections
observeEvent(input$Held, {
## Get selection
nodeMulti <- input$Held
## Reset Plot?
if (is.null(nodeMulti) & !is.null(input$dendroSelect_selected)) {
values$Held <- runif(1, 0, 1)
}
## If unclicked initialize or reset values$groupList
if (is.null(nodeMulti)) {
values$colSel <- c()
values$groupList <- list()
values$obsUsed <- c()
} else {
values$colSel <- unique(c(values$colSel, nodeMulti))
}
## Get current value
curVal <- values$colSel[length(values$colSel)]
if (!is.null(curVal)) {
if (curVal %in% names(K2list)) {
obs <- unlist(K2list[[curVal]]$obs)
} else {
obs <- strsplit(as.character(
vNetOut$x$nodes$label[vNetOut$x$nodes$id == curVal]), "\n")[[1]]
}
## Get unique observations
obsWhole <- obs
obs <- obs[!obs %in% values$obsUsed]
## Get mapped group
if (length(obs) > 0) {
gMap <- names(obsMap)[which.max(unlist(lapply(
obsMap,
function(x) {
mean(x %in% obs)
}
)))]
if ( length(gMap) > 0 ) {
values$groupList[[gMap]] <- obs
values$obsUsed <- unique(c(values$obsUsed, obs))
}
}
}
}, ignoreNULL=FALSE)
Row {data-height=600}
Click and hold nodes to select subgroups (Click whitespace to reset)
## Show dendroselect output
visNetworkOutput("dendroSelect")
Selections
## Render action button
output$compare <- renderUI({
if (length(values$groupList) > 1) {
actionButton("compareGo", "Compare")
}
})
## Render subgroup selection
output$groupSel <- renderUI({
HTML(paste(unlist(lapply(names(values$groupList), function(gName) {
pName <- paste0("<b>Node ", substr(gName, 1, nchar(gName) - 1),
", Edge ", substr(gName, nchar(gName), nchar(gName)),
" (", gName, ")")
Obs <- paste(values$groupList[[gName]], collapse="  ")
paste0(pName, "</b>: ", Obs)
})), collapse="<br><br><br>"))
})
## Show buttong and group selection
div(htmlOutput("compare", inline=TRUE),
br(),
htmlOutput("groupSel", inline=TRUE),
style='height: 600px; overflow: scroll;')
## Run analysis after compareGo is selected
observeEvent(input$compareGo, {
## Set clicked groupList
values$groupListClicked <- values$groupList
withProgress(message="Comparing Selected Subgroups:", value=0, {
## Create data.frame of mods
mods <- as.factor(unlist(lapply(seq(length(values$groupListClicked)),
function(x) rep(x, length(values$groupListClicked[[x]])))))
names(mods) <- unlist(values$groupListClicked)
## Genereate gene expression results
incProgress(1/10, detail="Differential Analysis")
clusterRes <- DashSignatureWrapper(eMat,
colDat,
cohorts=meta$cohorts,
mods,
vehicle=meta$vehicle,
variables=meta$variables,
logCounts=meta$logCounts,
DGEexpThreshold=meta$DGEexpThreshold,
GENE = TRUE)
## Add Subgroup and gene column
clusterRes$Subgroup <- names(values$groupListClicked)[
as.numeric(clusterRes$edge)]
colnames(clusterRes)[1] <- "gene"
## Generete enrichment results
incProgress(1/4, detail="Pathway Enrichment")
fisherEnrRes <- enrichmentClusters(clusterRes,
values$groupListClicked,
genesets,
meta$qthresh,
meta$cthresh,
meta$ntotal)
## Add Subgroup ID
fisherEnrRes <- do.call(rbind, lapply(names(fisherEnrRes), function(x) {
## Get GSE tables
HYPERtab <- fisherEnrRes[[x]]
if (nrow(HYPERtab) > 0) {
HYPERtab$Subgroup <- x
}
return(HYPERtab)
}))
## Add type of test
colnames(fisherEnrRes)[colnames(fisherEnrRes) %in% c("pval", "fdr")] <-
paste(colnames(fisherEnrRes)[colnames(fisherEnrRes) %in%
c("pval", "fdr")],
"fisher", sep="_")
## Generete enrichment results
incProgress(1/4, detail="Pathway Differential Enrichment")
ssEnrRes <- DashSignatureWrapper(gMat,
colDat,
cohorts=meta$cohorts,
mods,
vehicle=NULL,
variables=meta$variables,
DGEexpThreshold=meta$DGEexpThreshold,
GENE = FALSE)
## Add Subgroup and category
ssEnrRes$Subgroup <- names(values$groupListClicked)[
as.numeric(ssEnrRes$edge)]
colnames(ssEnrRes)[1] <- "category"
## Add type of test
colnames(ssEnrRes)[colnames(ssEnrRes) %in% c("pval", "fdr")] <-
paste(colnames(ssEnrRes)[colnames(ssEnrRes) %in% c("pval", "fdr")],
"limma", sep="_")
## Format enrichment table
incProgress(1/3, detail="Formatting Results")
## Merge the two and sort by fisher p-value
EnrRes <- merge(fisherEnrRes, ssEnrRes, all=TRUE)
### Order by pvalue
EnrRes <- EnrRes[order(EnrRes$pval_limma, partial = EnrRes$pval_fisher),]
## Sort columns
EnrRes <- EnrRes[, c("category", "Subgroup", "pval_fisher", "fdr_fisher",
"nhits", "ndrawn", "ncats", "pval_limma", "fdr_limma", "coef",
"mean", "hits")]
## Add aliases for plotting and looking up
EnrRes$Plot <- paste0("<label for='PlotRow",
seq(nrow(EnrRes)),
"'>📊</label>")
EnrRes$Send <- paste0("<label for='SendRow",
seq(nrow(EnrRes)),
"'>✈</label>")
## Add links to gene sets
genesetURLsub <- genesetURL[EnrRes$category]
EnrRes$Link <- paste0(geneSetStringL, genesetURLsub, geneSetStringR)
## Format numbers to fit in table
for (i in c("pval_fisher", "fdr_fisher", "pval_limma", "fdr_limma")) {
EnrRes[,i] <- signif(EnrRes[,i], digits=2)
}
## Format numbers to fit in table
for (i in c("coef", "mean")) {
EnrRes[,i] <- round(EnrRes[,i], digits=2)
}
## Change column names
colnames(EnrRes) <- c("Gene Set", "Subgroup", "P Value_Fisher",
"FDR_Fisher", "N_Overlap", "N_Sig. Genes", "N_Gene Set",
"P Value_Score", "FDR_Score", "Diff_Score", "Mean_Score",
"Hits", "Plot", "Send", "Link")
## Assign to reactiveValues
values$EnrRes <- EnrRes
### Order by pvalue
clusterRes <- clusterRes[order(clusterRes$pval),]
### Add links to genes
geneURLsub <- geneURL[rownames(clusterRes$gene)]
clusterRes$Link <- paste0(geneStringL, geneURLsub, geneStringR)
## Add aliases for plotting and looking up
clusterRes$Send <- paste0("<label for='SendRow",
seq(nrow(clusterRes)),
"'>✈</label>")
clusterRes$Plot <- paste0("<label for='PlotRow",
seq(nrow(clusterRes)),
"'>📊</label>")
clusterRes <- clusterRes[,c("gene", "Subgroup", "pval", "fdr", "coef",
"mean", "Plot", "Send", "Link")]
## Format numbers to fit in table
for (i in c("pval", "fdr")) {
clusterRes[,i] <- signif(clusterRes[,i], digits=2)
}
## Format numbers to fit in table
for (i in c("coef", "mean")) {
clusterRes[,i] <- round(clusterRes[,i], digits=2)
}
## Rename columns
colnames(clusterRes) <- c("Gene", "Subgroup", "P Value", "FDR", "Diff",
"Mean", "Plot", "Send", "Link")
## Assign to reactiveValues
values$clusterRes <- clusterRes
})
})
Row {data-height=550}
Differential Expression Analysis Results
## Show geneTable from multiple group analysis
DT::dataTableOutput("DGEmulti")
## Render geneTable from multiple group analysis
output$DGEmulti <- renderDataTable({
values$dgeMultiHeld
if (!is.null(values$clusterRes)) {
geneTableClusters(values$clusterRes, values$nodeSelHEMulti,
values$geneListMulti)
}
})
## Control Searches
observeEvent(input$DGEmulti_search_columns, {
if (!is.null(values$geneListMulti)) {
if (input$DGEmulti_search_columns[1] != values$geneListMulti) {
values$heMultiHeld <- runif(1, 0, 1)
values$geneListMulti <- NULL
values$nodeSelHEMulti <- gsub("\\$|\\^", "",
input$DGEmulti_search_columns[2])
}
}
})
## Functions for help and download the data
geneHelpShowMulti <- function() {
div(id="geneHelpMulti",
modalDialog(
"1) Use ^SEARCHTERM$ to filter for exact matches in columns",
br(),
HTML("2) Select '📊' to plot gene expression below."),
br(),
HTML("3) Select '✈' to send row information to look up
pathways which include this gene in enrichment results
above."),
br(),
easyClose=TRUE, title="Help")
)
}
## Functions to download the data
geneTabDLMulti <- function() {
div(id="geneDLMulti",
modalDialog(downloadButton("downloadGeneCSVMulti",
"Download Table as CSV file"),
br(),
br(),
easyClose=TRUE, title="Download Table")
)
}
## Pop-up for help
observeEvent(input$geneHelpMulti, {
showModal(geneHelpShowMulti())
})
## Download gene expression results
output$downloadGeneCSVMulti <- downloadHandler(
filename=function() {
paste("generesultsmulti-", Sys.Date(), ".csv", sep="")
},
content=function(file) {
write.csv(values$clusterRes[,seq(6)], file, row.names=FALSE)
}
)
## Download when prompted
observeEvent(input$geneDLMulti, {
showModal(geneTabDLMulti())
})
## Get output
observeEvent({input$DGEmulti_cell_clicked},
{
if (!is.null(input$DGEmulti_cell_clicked$value)){
## Get Value
dgeVal <- gsub(
"<label for='|'>✈</label>|'>📊</label>",
"",
as.character(input$DGEmulti_cell_clicked$value))
## Check that a link was clicked
if (grepl("PlotRow|SendRow", dgeVal)) {
rowNum <- as.numeric(sub("PlotRow|SendRow", "", dgeVal))
GENERowMulti <- values$clusterRes[rowNum, , drop=FALSE]
## If plotting send the node to plot, otherwise global
if (grepl("PlotRow", dgeVal)) {
values$GeneMultip <- GENERowMulti[, "Gene"]
} else {
values$GeneMulti <- GENERowMulti[, "Gene"]
values$nodeSelDGEMulti <- GENERowMulti[, "Subgroup"]
if (values$GeneMulti %in% names(gene2Pathway)) {
values$dgeHitsMulti <- paste0("^", gsub("; ", "$|^",
gene2Pathway[[values$GeneMulti]]), "$")
} else {
values$dgeHitsMulti <- "NO GENE SETS FOUND."
}
}
}
}
})
Row {data-height=500}
Gene Expression
## Show genePlot for multiple clusters
plotly::plotlyOutput("genePlotCluster")
## Render genePlot for multiple clusters
output$genePlotCluster <- renderPlotly({
if (!is.null(values$GeneMultip)) {
values$gp <- TRUE
plotGenePathwayClustersDash(eMat,
colDat,
values$GeneMultip,
values$groupListClicked,
meta$cohorts,
meta$vehicle)
} else {
text=paste(
"\n Select a gene above \n to show observation-level expression.")
hm <- ggplot() +
annotate("text", x=0, y=0, size=4, label=text) +
theme_bw() +
theme(axis.line=element_blank(),
axis.text.x=element_blank(),
axis.text.y=element_blank(),
axis.ticks=element_blank(),
axis.title.x=element_blank(),
axis.title.y=element_blank(),
legend.position="none",
panel.background=element_blank(),
panel.border=element_blank(),
panel.grid.major=element_blank(),
panel.grid.minor=element_blank(),
plot.background=element_blank())
ggplotly(hm)
}
})
Row {data-height=550}
Enrichment Results
## Show table of enrichment
DT::dataTableOutput("HEmulti")
## Render table of enrichment
output$HEmulti <- renderDataTable({
values$heMultiHeld
if (!is.null(values$EnrRes)) {
genesetTableClusters(values$EnrRes, values$nodeSelDGEMulti,
values$dgeHitsMulti)
}
})
## Control Searches
observeEvent(input$HEmulti_search_columns, {
if (!is.null(values$dgeHitsMulti)) {
if (input$HEmulti_search_columns[1] != values$dgeHitsMulti) {
values$dgeMultiHeld <- runif (1, 0, 1)
values$dgeHitsMulti <- NULL
values$nodeSelDGEMulti <- gsub("\\$|\\^", "",
input$HEmulti_search_columns[2])
}
}
})
## Render genetable results
output$DGE <- renderDataTable({
values$dgeHeld
geneTable(dgeTable, values$nodeSelHE, values$geneList)
})
## Control Searches
observeEvent(input$DGE_search_columns, {
if (!is.null(values$geneList)) {
if (input$DGE_search_columns[1] != values$geneList) {
values$heHeld <- runif(1, 0, 1)
values$geneList <- NULL
values$nodeSelHE <- gsub("\\$|\\^", "", input$DGE_search_columns[2])
}
}
})
## Functions for help and download the data
enrHelpShowMulti <- function() {
div(id="enrHelpMulti",
modalDialog(
"1) Use ^SEARCHTERM$ to filter for exact matches in columns",
br(),
HTML("2) Select '📊' to plot Gene Set Enrichment Score below."
),
br(),
HTML("3) Select '✈' to send row information to look up
results for individual genes in this pathway below."),
br(),
easyClose=TRUE, title="Help")
)
}
## Functions for help and download the data
enrTabDLMulti <- function() {
div(id="enrDLMulti",
modalDialog(downloadButton("downloadFisherCSVMulti",
"Download Table as CSV file"),
br(),
br(),
easyClose=TRUE, title="Download Table")
)
}
## Pop-up for help
observeEvent(input$enrHelpMulti, {
showModal(enrHelpShowMulti())
})
output$downloadFisherCSVMulti <- downloadHandler(
filename=function() {
paste("enrresultsmulti-", Sys.Date(), ".csv", sep="")
},
content=function(file) {
write.csv(values$EnrRes[,seq(12)], file, row.names=FALSE)
}
)
## Pop-up for download
observeEvent(input$enrDLMulti, {
showModal(enrTabDLMulti())
})
## Reactive row selection
observeEvent({input$HEmulti_cell_clicked},
{
if (!is.null(input$HEmulti_cell_clicked$value)) {
## Get Value
enrVal <- gsub(
"<label for='|'>✈</label>|'>📊</label>", "",
as.character(input$HEmulti_cell_clicked$value))
## If PlotRow then set nodeSelHE
if (grepl("PlotRow|SendRow", enrVal)) {
rowNum <- as.numeric(sub("PlotRow|SendRow", "", enrVal))
HYPERRowMulti <- values$EnrRes[rowNum, , drop=FALSE]
## If plotting send the node to plot, otherwise global
if (grepl("PlotRow", enrVal)) {
values$GeneSetMultip <- HYPERRowMulti[, "Gene Set"]
} else {
values$nodeSelHEMulti <- HYPERRowMulti[, "Subgroup"]
values$GeneSetMulti <- HYPERRowMulti[, "Gene Set"]
values$geneListMulti <- paste(paste0("^",
genesets[[values$GeneSetMulti]], "$"), collapse="|")
}
}
}
})
Row {data-height=500}
Gene Set Enrichment Score
## Show plot of enrichment of multiple clusters
plotly::plotlyOutput("hePlotCluster")
## Render plot of enrichment of multiple clusters
output$hePlotCluster <- renderPlotly({
if (!is.null(values$GeneSetMultip)) {
values$gp <- TRUE
plotGenePathwayClustersDash(gMat,
colDat,
values$GeneSetMultip,
values$groupListClicked,
cohorts=meta$cohorts,
vehicle=meta$vehicle,
enrYlab)
} else {
text=paste("\n Select a pathway above \n to show observation-level
enrichment. \n")
hm <- ggplot() +
annotate("text", x=0, y=0, size=4, label=text) +
theme_bw() +
theme(axis.line=element_blank(),
axis.text.x=element_blank(),
axis.text.y=element_blank(),
axis.ticks=element_blank(),
axis.title.x=element_blank(),
axis.title.y=element_blank(),
legend.position="none",
panel.background=element_blank(),
panel.border=element_blank(),
panel.grid.major=element_blank(),
panel.grid.minor=element_blank(),
plot.background=element_blank())
ggplotly(hm)
}
})
montilab/K2Taxonomer documentation built on April 5, 2025, 3:58 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
if (file.exists("about.md")) { cat(paste(readLines("about.md"), collapse=" \n")) }
library(shiny) library(K2Taxonomer) library(visNetwork) library(plotly) library(heatmaply) library(DT) library(Biobase) library(RColorBrewer) library(limma) library(dendextend) ## Read in helper functions source(system.file("dashboard", "DashHelper.R", package="K2Taxonomer"))
## Read in analysis results K2res <- readRDS("K2results.rds") ## Parse results info <- K2meta(K2res)$info; infoMat <- as.matrix(info) ## Get Information K2list <- K2results(K2res) ## Get K2 results list dataMatrix <- K2data(K2res) ## Get dataMatrix genesets <- K2genesets(K2res) ## Get geneset lists gene2Pathway <- K2gene2Pathway(K2res) ## Get gene2pathway matching if(nrow(K2eMatDS(K2res)) != 0) { eMat <- K2eMatDS(K2res) } else { eMat <- K2eMat(K2res) } gMat <- K2gMat(K2res) ## Get gene set projection expression set meta <- K2meta(K2res) ## Get meta data geneURL <- K2geneURL(K2res) ## Get meta data genesetURL <- K2genesetURL(K2res) ## Get meta data K2dendrogram <- K2dendro(K2res) ## Create static dendrogram colDat <- K2colData(K2res) ## Get obervation level meta data # Get differential gene expression results dgeTable <- getDGETable(K2res) # Get enrichment results enrTable <- getEnrichmentTable(K2res) ## Remove dge from K2list K2list <- lapply(K2list, function(x) { x$dge <- NULL; return(x) }) ## Remove gse from K2list K2list <- lapply(K2list, function(x) { x$gse <- NULL; return(x) }) ## Remove dsse from K2list K2list <- lapply(K2list, function(x) { x$dsse <- NULL; return(x) }) ## Create interactive dendrogram vNetOut <- K2visNetwork(K2res, labelsize = 100) ## Remove K2res to save space rm(K2res); invisible(gc(verbose = FALSE)) ## If too many observations in terminal labels, unlabel them if (max(lengths(regmatches(vNetOut$x$nodes$label, gregexpr("\n", vNetOut$x$nodes$label)))) > 20 ) { ## Fix font size vNetOut$x$nodes$font.size <- 25 vNetOut$x$nodes$font.size[vNetOut$x$nodes$shape == "box"] <- 0 ## Change shape vNetOut$x$nodes$shape[vNetOut$x$nodes$shape == "box"] <- "square" } ## Format enrichment table ## Remove unnecessary columns enrTable <- enrTable[, !colnames(enrTable) %in% c("ntot", "t")] ## Add aliases for plotting and looking up enrTable$Plot <- paste0("<label for='PlotRow", seq(nrow(enrTable)), "'>📊</label>") enrTable$Send <- paste0("<label for='SendRow", seq(nrow(enrTable)), "'>✈</label>") ## Add links to gene sets geneSetStringL <- "<a href='" geneSetStringR <- "' style='text-decoration:none' target='_blank'>🔍</a>" genesetURLsub <- genesetURL[enrTable$category] enrTable$Link <- paste0(geneSetStringL, genesetURLsub, geneSetStringR) ## Format numbers to fit in table for (i in c("pval_fisher", "fdr_fisher", "pval_limma", "fdr_limma")) { enrTable[,i] <- signif(enrTable[,i], digits=2) } ## Format numbers to fit in table for (i in c("coef", "mean")) { enrTable[,i] <- round(enrTable[,i], digits=2) } colnames(enrTable) <- c("Gene Set", "Node", "Edge", "Direction", "P Value_Fisher", "FDR_Fisher", "N_Overlap", "N_Sig. Genes", "N_Gene Set", "P Value_Score", "FDR_Score", "Diff_Score", "Mean_Score", "Hits", "Plot", "Send", "Link") ## Format differential gene expression results ## Add aliases for plotting and looking up dgeTable$Plot <- paste0("<label for='PlotRow", seq(nrow(dgeTable)), "'>📊</label>") dgeTable$Send <- paste0("<label for='SendRow", seq(nrow(dgeTable)), "'>✈</label>") ### Add links to genes geneStringL <- "<a href='" geneStringR <- "' style='text-decoration:none' target='_blank'>🔍</a>" geneURLsub <- geneURL[dgeTable$gene] dgeTable$Link <- paste0(geneStringL, geneURLsub, geneStringR) ## Reorder columns dgeTable <- dgeTable[,c("gene", "node", "edge", "direction", "pval", "fdr", "coef", "mean", "Plot", "Send", "Link")] ## Format numbers to fit in table for (i in c("pval", "fdr")) { dgeTable[,i] <- signif(dgeTable[,i], digits=2) } ## Format numbers to fit in table for (i in c("coef", "mean")) { dgeTable[,i] <- round(dgeTable[,i], digits=2) } ## Rename columns colnames(dgeTable) <- c("Gene", "Node", "Edge", "Direction", "P Value", "FDR", "Diff", "Mean", "Plot", "Send", "Link") ### Set select input options for annotations bar varOptions <- sort(colnames(info)[-1]) names(varOptions) <- varOptions varOptions <- c("Add Variables:"="", varOptions, "Reset"="RESET") ### Get sample order labs <- get_leaves_attr(K2dendrogram, "label") ## Get IDs of each group obsMap <- unlist(lapply(K2list, function(x) x$obs), recursive=FALSE) ## Set enrichment score label ScoreGeneSetMethod <- meta$ScoreGeneSetMethod ## Set enrichment score label if(meta$ScoreGeneSetMethod == "GSVA") { enrYlab <- "GSVA Score" } else { enrYlab <- "Log2 AUCell Score" }
observeEvent(values$gp, { withProgress({ input$`plotly_afterplot-A` for(i in seq(10)) { incProgress(1/10) Sys.sleep(0.05) } }, message="Rendering...", min=0, max=1, value=1) values$gp <- NULL })
K2Taxonomer Results {data-orientation=rows}
## Reactive values values <- reactiveValues(nodeSel="A", pathSel="A", nodeSelHE = "A", nodeSel = "A")
Sidebar {.sidebar}
## Out of global help button textInput("mstring", "Member Search:", value="") uiOutput("SI")
Row {data-height=600}
K2Taxonomer Results
visNetworkOutput("dendro")
Subgroup Information (↑=Edge:1; ↓=Edge:2)
# Show tabset of node information div( tabsetPanel(type="tabs", tabPanel("Stability", fillCol( fluidRow( column(width=10, selectInput("selCov", NULL, varOptions), offset=1), plotlyOutput("heatmapPlot", width = "100%"), column(width=10, htmlOutput("stabStats"), offset=1) ))), tabPanel("Node members", fillCol( DT::dataTableOutput("infoTab") )) ), style='height: 600px' )
sendString <- eventReactive({input$mstring}, { ## Get info matches for this string if (!is.null(input$mstring) && (input$mstring != "" & sum(grepl(input$mstring, infoMat, ignore.case=TRUE)) != 0)) { ## Find matches in the terminal leafs infoInd <- unique(which(`dim<-`(grepl(input$mstring, infoMat, ignore.case=TRUE), dim(infoMat)), arr.ind=TRUE)[,1]) ## Generate string to show showString <- vapply(infoInd, function(row) paste0( paste(paste0(colnames(infoMat), ":", infoMat[row,]), collapse="\n"), "\n"), FUN.VALUE=character(1)) ## Get number of matches nMatches <- paste0(length(infoInd), " match(es)") valueString <- c(nMatches, rownames(infoMat)[infoInd]) names(valueString) <- c(nMatches, showString) } else { valueString <- c("No Matches") } valueString }) output$SI <- renderUI({ selectizeInput("mVal", label = "Select a Match:", choices = sendString()) }) ## Reactive row selection observeEvent({input$mVal}, { ## Select path to a specific member by searching if (!is.null(input$mVal) && input$mVal %in% rownames(info) && input$mVal != values$nodeSel){ values$pathSel <- as.character(vNetOut$x$nodes$id[ grep(paste0("^", input$mVal, "<br>|<br>", input$mVal, "<br>|", input$mVal, "$"), vNetOut$x$nodes$title)]) } })
## Render Dendrogram output$dendro <- renderVisNetwork({ values$gp <- TRUE vNetOut %>% visOptions(autoResize=TRUE, height="100%", nodesIdSelection=list(enabled=TRUE, main="Node ID", style='width: 100px; height: 25px;', selected=values$pathSel), #style='width: 100px; height: 25px;'), highlightNearest=list(enabled=TRUE, algorithm="hierarchical", degree=1E10)) %>% visNodes(font=list(size=50), size=40, color=list( background="white", border="#2B7CE9", highlight="red")) %>% visEdges(width=11, smooth=TRUE) %>% visPhysics(hierarchicalRepulsion=list(nodeDistance=200)) %>% visHierarchicalLayout(direction="LR", levelSeparation=300) %>% visInteraction(dragNodes=FALSE, zoomSpeed = 0.1) })
## Render heatmap of cluster stability output$heatmapPlot <- renderPlotly({ ## Get values to add if (!is.null(input$selCov) && input$selCov %in% colnames(info)) { values$selCov <- unique(c(values$selCov, input$selCov)) } else { values$selCov <- NULL } if (values$nodeSel %in% names(K2list)){ ## Get matrix and sort samp_stab <- as.matrix(K2list[[values$nodeSel]]$stability$samples) ord <- order(match(colnames(samp_stab), labs)) samp_stab <- as.matrix(samp_stab)[ord, ord] ## Get sample groups modList <- K2list[[values$nodeSel]]$obs ## Create column annotation colrowAnnot <- data.frame(Group=c(rep("Edge:1", length(modList[[1]])), rep("Edge:2", length(modList[[2]]))), row.names=c(modList[[1]], modList[[2]]) )[colnames(samp_stab), , drop=FALSE] ## If no selections just color groups colSidePalette <- c("#000000", "#808080") names(colSidePalette) <- c("Edge:1", "Edge:2") ## If selections are made add colors if (!is.null(values$selCov)){ ## Initialize colValues <- c() colSidePalette <- c() ## Get info for these samples infoSub <- info[colnames(samp_stab), values$selCov] colrowAnnot <- cbind(infoSub, colrowAnnot) colnames(colrowAnnot) <- c(values$selCov, "Edge") ## SET VALUES AND COLOR PALLETES for (i in values$selCov) { colrowAnnot[,i] <- paste(i, colrowAnnot[,i], sep=":") addValues <- info[,i]; addValues <- addValues[!is.na(addValues)] addValuesUnique <- unique(addValues) colValues <- c(colValues, paste(i, addValuesUnique, sep=":")) ## If a factor or character add unique values for each unique value if ( class(addValues) %in% c("character", "factor") ) { colSidePalette <- c(colSidePalette, heatmaply:::default_side_colors(length(addValuesUnique))) ## Otherwise use a color gradient based on z-scored quantile } else { addValuesNorm <- unique(qnorm(rank(addValues)/ (length(addValues)+1))) addValuesCut <- rep(NA, length(addValuesNorm)) cuts <- c(-Inf, -2, -1.5, -1, -0.5, 0.5, 1, 1.5, 2) for (j in seq(length(cuts))) { addValuesCut[addValuesNorm > cuts[j]] <- j } contPallete <- brewer.pal(9, "Greens")[addValuesCut] colSidePalette <- c(colSidePalette, contPallete) } } ## Create pallette of all possible factors colSidePalette <- c(colSidePalette, "#000000", "#808080", rep("#D3D3D3", length(values$selCov))) names(colSidePalette) <- c(colValues, "Edge:1", "Edge:2", paste0(values$selCov, ":NA")) } values$gp <- TRUE hm <- heatmaply(x=samp_stab, color=rev(RdBu(n=256)), limits=c(-1, 1), col_side_colors=colrowAnnot, col_side_palette=colSidePalette, hide_colorbar=TRUE, margins=c(0,25,50,25), key.title=NULL, dendrogram=FALSE, showticklabels=FALSE) ## Remove legend hm$x$layout$showlegend <- FALSE ## Change value to cosine similarity whHeatmap <- which(unlist(lapply(hm$x$data, function(x) { x$type == "heatmap" }))) ## Get heatmap index hm$x$data[[whHeatmap]]$text <- sub("value:", "cos similarity:", hm$x$data[[whHeatmap]]$text) return(hm) } else { text=paste("\n No node selected. \n") hm <- ggplot() + annotate("text", x=0, y=0, size=8, label=text) + theme_bw() + theme(axis.line=element_blank(), axis.text.x=element_blank(), axis.text.y=element_blank(), axis.ticks=element_blank(), axis.title.x=element_blank(), axis.title.y=element_blank(), legend.position="none", panel.background=element_blank(), panel.border=element_blank(), panel.grid.major=element_blank(), panel.grid.minor=element_blank(), plot.background=element_blank()) return(ggplotly(hm)) } })
## Render stability statistics output$stabStats <- renderUI({ if (values$nodeSel %in% names(K2list)){ bootProb <- K2list[[values$nodeSel]]$bootP nodeStab <- K2list[[values$nodeSel]]$stability$node sampStab <- K2list[[values$nodeSel]]$stability$clusters outBoot <- paste0("<br> Bootstrap Probability: <b>", bootProb, "</b>") outNode <- paste0("<br> Partition Stability: <b>", signif(nodeStab, 2), "</b> <br>") outStab <- paste0("Subgroup Stability <br>   Edge:1= <b>", signif(sampStab[1], 2), "</b>   Edge:2= <b>", signif(sampStab[2], 2)) HTML(paste(outBoot, outNode, outStab)) } else { HTML("") } })
## Render table of information for each node output$infoTab <- renderDataTable({ ## Get observations obs1 <- K2list[[values$nodeSel]]$obs[[1]] obs2 <- K2list[[values$nodeSel]]$obs[[2]] ## Format Cluster information infoSub <- info[c(obs1, obs2), , drop=FALSE] infoSub$Edge <- "1" infoSub$Edge[rownames(infoSub) %in% obs2] <- "2" infoSub <- infoSub[ , c(ncol(infoSub), seq(ncol(infoSub) - 1)) ] datatable(infoSub, rownames=FALSE, filter=list(position='top', clear=FALSE), extensions='Buttons', options=list(dom='Brt', search=list(regex=TRUE, caseInsensitive=FALSE), scrollX=TRUE, scrollY="400px", paging=FALSE, pageLength=nrow(infoSub), buttons=c('csv', 'excel'), columnDefs=list( list(className='dt-center', targets="_all") )), selection="none") })
## Selections of dendrogram observeEvent({ input$dendro_selected }, { node=input$dendro_selected if (node %in% names(K2list) & node != values$nodeSel) { values$nodeSel <- node values$nodeSelDGE <- node values$nodeSelHE <- node values$geneList <- values$groupDGE <- values$dgeHits <- values$Hits <- values$groupDGE <- NULL } }, ignoreNULL=TRUE, ignoreInit=TRUE )
Row {data-height=550}
Differential Expression Analysis Results
## Show genetable results DT::dataTableOutput("DGE")
## Render genetable results output$DGE <- renderDataTable({ values$dgeHeld geneTable(dgeTable, values$nodeSelHE, values$geneList) }) ## Control Searches observeEvent(input$DGE_search_columns, { if (!is.null(values$geneList)) { if (input$DGE_search_columns[1] != values$geneList) { values$heHeld <- runif(1, 0, 1) values$geneList <- NULL values$nodeSelHE <- gsub("\\$|\\^", "", input$DGE_search_columns[2]) } } })
## Functions for help and download the data geneHelpShow <- function() { div(id="geneHelp", modalDialog("1) Use ^SEARCHTERM$ to filter for exact matches in columns", br(), HTML("2) Select '📊' to plot gene expression below."), br(), HTML("3) Select '✈' to send row information to look up pathways which include this gene in enrichment results above."), br(), easyClose=TRUE, title="Help") ) } ## Functions to download the data geneTabDL <- function() { div(id="geneDL", modalDialog(downloadButton("downloadGeneCSV", "Download Table as CSV file"), br(), br(), easyClose=TRUE, title="Download Table") ) }
## Pop-up for help observeEvent(input$geneHelp, { showModal(geneHelpShow()) }) ## Download CSV File output$downloadGeneCSV <- downloadHandler( filename=function() { paste("generesults-", Sys.Date(), ".csv", sep="") }, content=function(file) { write.csv(dgeTable[,seq(8)], file, row.names=FALSE) } ) ## Pop-up for CSV file observeEvent(input$geneDL, { showModal(geneTabDL()) }) ## Get output observeEvent(input$DGE_cell_clicked, { if (!is.null(input$DGE_cell_clicked$value)) { ## Get Value dgeVal <- gsub( "<label for='|'>✈</label>|'>📊</label>", "", as.character(input$DGE_cell_clicked$value)) ## Check that a link was clicked if (grepl("PlotRow|SendRow", dgeVal)) { rowNum <- as.numeric(sub("PlotRow|SendRow", "", dgeVal)) GENERow <- dgeTable[rowNum, , drop=FALSE] ## If plotting send the node to plot, otherwise global if (grepl("PlotRow", dgeVal)) { values$Genep <- GENERow[, "Gene"] values$nodeSelDGEp <- GENERow[, "Node"] } else { values$Gene <- GENERow[, "Gene"] values$nodeSelDGE <- GENERow[, "Node"] values$groupDGE <- GENERow[, "Edge"] if (values$Gene %in% names(gene2Pathway)) { values$dgeHits <- paste0("^", gsub("; ", "$|^", gene2Pathway[[values$Gene]]), "$") } else { values$dgeHits <- "NO GENE SETS FOUND." } } } } })
Row {data-height=500}
Gene Expression
## Render genePlot output$genePlot <- renderPlotly({ if (!is.null(values$nodeSelDGEp)){ values$gp <- TRUE plotGenePathwayDash(eMat, colDat, values$Genep, K2list[[values$nodeSelDGEp]]$obs[[1]], K2list[[values$nodeSelDGEp]]$obs[[2]], meta$cohorts, meta$vehicle) } else { text=paste("\n Select a gene above \n to show observation-level expression.") hm <- ggplot() + annotate("text", x=0, y=0, size=4, label=text) + theme_bw() + theme(axis.line=element_blank(), axis.text.x=element_blank(), axis.text.y=element_blank(), axis.ticks=element_blank(), axis.title.x=element_blank(), axis.title.y=element_blank(), legend.position="none", panel.background=element_blank(), panel.border=element_blank(), panel.grid.major=element_blank(), panel.grid.minor=element_blank(), plot.background=element_blank()) ggplotly(hm) } })
## Show genePlot output plotly::plotlyOutput("genePlot")
Row {data-height=550}
Enrichment Results
## Show enrichment table output DT::dataTableOutput("HE")
## Render enrichment table output$HE <- renderDataTable({ values$heHeld genesetTable(enrTable, values$nodeSelHE, values$groupDGE, values$dgeHits) }) ## Control Searches observeEvent(input$HE_search_columns, { if (!is.null(values$dgeHits)) { if (input$HE_search_columns[1] != values$dgeHits) { values$dgeHeld <- runif(1, 0, 1) values$dgeHits <- NULL values$nodeSelDGE <- gsub("\\$|\\^", "", input$HE_search_columns[2]) values$groupDGE <- input$HE_search_columns[3] } } })
## Functions for help enrHelpShow <- function() { div(id="enrHelp", modalDialog( "1) Use ^SEARCHTERM$ to filter for exact matches in columns", br(), HTML( "2) Select '📊' to plot Gene Set Enrichment Score below." ), br(), HTML("3) Select '✈' to send row information to look up results for individual genes in this pathway below."), br(), easyClose=TRUE, title="Help") ) } ## Functions for download the data enrTabDL <- function() { div(id="enrDL", modalDialog(downloadButton("downloadFisherCSV", "Download Table as CSV file"), br(), br(), easyClose=TRUE, title="Download Table") ) }
## Pop-up for help observeEvent(input$enrHelp, { showModal(enrHelpShow()) }) ## Download CSV File output$downloadFisherCSV <- downloadHandler( filename=function() { paste("enrresults-", Sys.Date(), ".csv", sep="") }, content=function(file) { write.csv(enrTable[,seq(10)], file, row.names=FALSE) } ) ## Pop-up for download observeEvent(input$enrDL, { showModal(enrTabDL()) }) ## Reactive row selection observeEvent({input$HE_cell_clicked}, { if (!is.null(input$HE_cell_clicked$value)) { ## Get Value enrVal <- gsub( "<label for='|'>✈</label>|'>📊</label>", "", as.character(input$HE_cell_clicked$value)) ## If PlotRow then set nodeSelHE if (grepl("PlotRow|SendRow", enrVal)) { rowNum <- as.numeric(sub("PlotRow|SendRow", "", enrVal)) HYPERRow <- enrTable[rowNum, , drop=FALSE] ## If plotting send the node to plot, otherwise global if (grepl("PlotRow", enrVal)) { values$GeneSetp <- HYPERRow[, "Gene Set"] values$nodeSelHEp <- HYPERRow[, "Node"] values$groupSelHEp <-HYPERRow[, "Edge"] values$dirSelHEp <-HYPERRow[, "Direction"] } else { values$nodeSelHE <- HYPERRow[, "Node"] values$Hits <- strsplit(HYPERRow[, "Hits"], ",")[[1]] values$GeneSet <- HYPERRow[, "Gene Set"] values$geneList <- paste(paste0("^", genesets[[values$GeneSet]], "$"), collapse="|") } } } })
Row {data-height=500}
Gene Set Enrichment Score
## Render pathwayPlot output$pathwayPlot <- renderPlotly({ if (!is.null(values$nodeSelHEp)){ values$gp <- TRUE plotGenePathwayDash(gMat, colDat, values$GeneSetp, K2list[[values$nodeSelHEp]]$obs[[1]], K2list[[values$nodeSelHEp]]$obs[[2]], meta$cohorts, meta$vehicle, ScoreGeneSetMethod) } else { text <- paste( "\n Select a pathway above to show observation-level enrichment. \n") hm <- ggplot() + annotate("text", x=0, y=0, size=4, label=text) + theme_bw() + theme(axis.line=element_blank(), axis.text.x=element_blank(), axis.text.y=element_blank(), axis.ticks=element_blank(), axis.title.x=element_blank(), axis.title.y=element_blank(), legend.position="none", panel.background=element_blank(), panel.border=element_blank(), panel.grid.major=element_blank(), panel.grid.minor=element_blank(), plot.background=element_blank()) ggplotly(hm) } })
## Show pathwayPlot output plotly::plotlyOutput("pathwayPlot")
Compare Multiple {data-orientation=rows}
## Generate Dendrogram output$dendroSelect <- renderVisNetwork({ values$Held values$gp <- TRUE vNetOut %>% visOptions(autoResize=TRUE, nodesIdSelection=list(enabled=TRUE, style='width: 0px; height: 0px;'), highlightNearest=list(enabled=TRUE, algorithm="hierarchical", degree=1E10)) %>% visNodes(font=list(size=50), size=40) %>% visEdges(width=11, smooth=TRUE, color=list(inherit='to')) %>% visPhysics(hierarchicalRepulsion=list(nodeDistance=200)) %>% visHierarchicalLayout(direction="LR", levelSeparation=300) %>% visInteraction(multiselect=TRUE) %>% visEvents(type="on", hold="function(nodes) { Shiny.onInputChange('Held', nodes.nodes); ;}", deselectNode="function(nodes) { Shiny.onInputChange('Held', null); ;}") })
## Allow multiple selections observeEvent(input$Held, { ## Get selection nodeMulti <- input$Held ## Reset Plot? if (is.null(nodeMulti) & !is.null(input$dendroSelect_selected)) { values$Held <- runif(1, 0, 1) } ## If unclicked initialize or reset values$groupList if (is.null(nodeMulti)) { values$colSel <- c() values$groupList <- list() values$obsUsed <- c() } else { values$colSel <- unique(c(values$colSel, nodeMulti)) } ## Get current value curVal <- values$colSel[length(values$colSel)] if (!is.null(curVal)) { if (curVal %in% names(K2list)) { obs <- unlist(K2list[[curVal]]$obs) } else { obs <- strsplit(as.character( vNetOut$x$nodes$label[vNetOut$x$nodes$id == curVal]), "\n")[[1]] } ## Get unique observations obsWhole <- obs obs <- obs[!obs %in% values$obsUsed] ## Get mapped group if (length(obs) > 0) { gMap <- names(obsMap)[which.max(unlist(lapply( obsMap, function(x) { mean(x %in% obs) } )))] if ( length(gMap) > 0 ) { values$groupList[[gMap]] <- obs values$obsUsed <- unique(c(values$obsUsed, obs)) } } } }, ignoreNULL=FALSE)
Row {data-height=600}
Click and hold nodes to select subgroups (Click whitespace to reset)
## Show dendroselect output visNetworkOutput("dendroSelect")
Selections
## Render action button output$compare <- renderUI({ if (length(values$groupList) > 1) { actionButton("compareGo", "Compare") } }) ## Render subgroup selection output$groupSel <- renderUI({ HTML(paste(unlist(lapply(names(values$groupList), function(gName) { pName <- paste0("<b>Node ", substr(gName, 1, nchar(gName) - 1), ", Edge ", substr(gName, nchar(gName), nchar(gName)), " (", gName, ")") Obs <- paste(values$groupList[[gName]], collapse="  ") paste0(pName, "</b>: ", Obs) })), collapse="<br><br><br>")) })
## Show buttong and group selection div(htmlOutput("compare", inline=TRUE), br(), htmlOutput("groupSel", inline=TRUE), style='height: 600px; overflow: scroll;')
## Run analysis after compareGo is selected observeEvent(input$compareGo, { ## Set clicked groupList values$groupListClicked <- values$groupList withProgress(message="Comparing Selected Subgroups:", value=0, { ## Create data.frame of mods mods <- as.factor(unlist(lapply(seq(length(values$groupListClicked)), function(x) rep(x, length(values$groupListClicked[[x]]))))) names(mods) <- unlist(values$groupListClicked) ## Genereate gene expression results incProgress(1/10, detail="Differential Analysis") clusterRes <- DashSignatureWrapper(eMat, colDat, cohorts=meta$cohorts, mods, vehicle=meta$vehicle, variables=meta$variables, logCounts=meta$logCounts, DGEexpThreshold=meta$DGEexpThreshold, GENE = TRUE) ## Add Subgroup and gene column clusterRes$Subgroup <- names(values$groupListClicked)[ as.numeric(clusterRes$edge)] colnames(clusterRes)[1] <- "gene" ## Generete enrichment results incProgress(1/4, detail="Pathway Enrichment") fisherEnrRes <- enrichmentClusters(clusterRes, values$groupListClicked, genesets, meta$qthresh, meta$cthresh, meta$ntotal) ## Add Subgroup ID fisherEnrRes <- do.call(rbind, lapply(names(fisherEnrRes), function(x) { ## Get GSE tables HYPERtab <- fisherEnrRes[[x]] if (nrow(HYPERtab) > 0) { HYPERtab$Subgroup <- x } return(HYPERtab) })) ## Add type of test colnames(fisherEnrRes)[colnames(fisherEnrRes) %in% c("pval", "fdr")] <- paste(colnames(fisherEnrRes)[colnames(fisherEnrRes) %in% c("pval", "fdr")], "fisher", sep="_") ## Generete enrichment results incProgress(1/4, detail="Pathway Differential Enrichment") ssEnrRes <- DashSignatureWrapper(gMat, colDat, cohorts=meta$cohorts, mods, vehicle=NULL, variables=meta$variables, DGEexpThreshold=meta$DGEexpThreshold, GENE = FALSE) ## Add Subgroup and category ssEnrRes$Subgroup <- names(values$groupListClicked)[ as.numeric(ssEnrRes$edge)] colnames(ssEnrRes)[1] <- "category" ## Add type of test colnames(ssEnrRes)[colnames(ssEnrRes) %in% c("pval", "fdr")] <- paste(colnames(ssEnrRes)[colnames(ssEnrRes) %in% c("pval", "fdr")], "limma", sep="_") ## Format enrichment table incProgress(1/3, detail="Formatting Results") ## Merge the two and sort by fisher p-value EnrRes <- merge(fisherEnrRes, ssEnrRes, all=TRUE) ### Order by pvalue EnrRes <- EnrRes[order(EnrRes$pval_limma, partial = EnrRes$pval_fisher),] ## Sort columns EnrRes <- EnrRes[, c("category", "Subgroup", "pval_fisher", "fdr_fisher", "nhits", "ndrawn", "ncats", "pval_limma", "fdr_limma", "coef", "mean", "hits")] ## Add aliases for plotting and looking up EnrRes$Plot <- paste0("<label for='PlotRow", seq(nrow(EnrRes)), "'>📊</label>") EnrRes$Send <- paste0("<label for='SendRow", seq(nrow(EnrRes)), "'>✈</label>") ## Add links to gene sets genesetURLsub <- genesetURL[EnrRes$category] EnrRes$Link <- paste0(geneSetStringL, genesetURLsub, geneSetStringR) ## Format numbers to fit in table for (i in c("pval_fisher", "fdr_fisher", "pval_limma", "fdr_limma")) { EnrRes[,i] <- signif(EnrRes[,i], digits=2) } ## Format numbers to fit in table for (i in c("coef", "mean")) { EnrRes[,i] <- round(EnrRes[,i], digits=2) } ## Change column names colnames(EnrRes) <- c("Gene Set", "Subgroup", "P Value_Fisher", "FDR_Fisher", "N_Overlap", "N_Sig. Genes", "N_Gene Set", "P Value_Score", "FDR_Score", "Diff_Score", "Mean_Score", "Hits", "Plot", "Send", "Link") ## Assign to reactiveValues values$EnrRes <- EnrRes ### Order by pvalue clusterRes <- clusterRes[order(clusterRes$pval),] ### Add links to genes geneURLsub <- geneURL[rownames(clusterRes$gene)] clusterRes$Link <- paste0(geneStringL, geneURLsub, geneStringR) ## Add aliases for plotting and looking up clusterRes$Send <- paste0("<label for='SendRow", seq(nrow(clusterRes)), "'>✈</label>") clusterRes$Plot <- paste0("<label for='PlotRow", seq(nrow(clusterRes)), "'>📊</label>") clusterRes <- clusterRes[,c("gene", "Subgroup", "pval", "fdr", "coef", "mean", "Plot", "Send", "Link")] ## Format numbers to fit in table for (i in c("pval", "fdr")) { clusterRes[,i] <- signif(clusterRes[,i], digits=2) } ## Format numbers to fit in table for (i in c("coef", "mean")) { clusterRes[,i] <- round(clusterRes[,i], digits=2) } ## Rename columns colnames(clusterRes) <- c("Gene", "Subgroup", "P Value", "FDR", "Diff", "Mean", "Plot", "Send", "Link") ## Assign to reactiveValues values$clusterRes <- clusterRes }) })
Row {data-height=550}
Differential Expression Analysis Results
## Show geneTable from multiple group analysis DT::dataTableOutput("DGEmulti")
## Render geneTable from multiple group analysis output$DGEmulti <- renderDataTable({ values$dgeMultiHeld if (!is.null(values$clusterRes)) { geneTableClusters(values$clusterRes, values$nodeSelHEMulti, values$geneListMulti) } }) ## Control Searches observeEvent(input$DGEmulti_search_columns, { if (!is.null(values$geneListMulti)) { if (input$DGEmulti_search_columns[1] != values$geneListMulti) { values$heMultiHeld <- runif(1, 0, 1) values$geneListMulti <- NULL values$nodeSelHEMulti <- gsub("\\$|\\^", "", input$DGEmulti_search_columns[2]) } } })
## Functions for help and download the data geneHelpShowMulti <- function() { div(id="geneHelpMulti", modalDialog( "1) Use ^SEARCHTERM$ to filter for exact matches in columns", br(), HTML("2) Select '📊' to plot gene expression below."), br(), HTML("3) Select '✈' to send row information to look up pathways which include this gene in enrichment results above."), br(), easyClose=TRUE, title="Help") ) } ## Functions to download the data geneTabDLMulti <- function() { div(id="geneDLMulti", modalDialog(downloadButton("downloadGeneCSVMulti", "Download Table as CSV file"), br(), br(), easyClose=TRUE, title="Download Table") ) }
## Pop-up for help observeEvent(input$geneHelpMulti, { showModal(geneHelpShowMulti()) }) ## Download gene expression results output$downloadGeneCSVMulti <- downloadHandler( filename=function() { paste("generesultsmulti-", Sys.Date(), ".csv", sep="") }, content=function(file) { write.csv(values$clusterRes[,seq(6)], file, row.names=FALSE) } ) ## Download when prompted observeEvent(input$geneDLMulti, { showModal(geneTabDLMulti()) }) ## Get output observeEvent({input$DGEmulti_cell_clicked}, { if (!is.null(input$DGEmulti_cell_clicked$value)){ ## Get Value dgeVal <- gsub( "<label for='|'>✈</label>|'>📊</label>", "", as.character(input$DGEmulti_cell_clicked$value)) ## Check that a link was clicked if (grepl("PlotRow|SendRow", dgeVal)) { rowNum <- as.numeric(sub("PlotRow|SendRow", "", dgeVal)) GENERowMulti <- values$clusterRes[rowNum, , drop=FALSE] ## If plotting send the node to plot, otherwise global if (grepl("PlotRow", dgeVal)) { values$GeneMultip <- GENERowMulti[, "Gene"] } else { values$GeneMulti <- GENERowMulti[, "Gene"] values$nodeSelDGEMulti <- GENERowMulti[, "Subgroup"] if (values$GeneMulti %in% names(gene2Pathway)) { values$dgeHitsMulti <- paste0("^", gsub("; ", "$|^", gene2Pathway[[values$GeneMulti]]), "$") } else { values$dgeHitsMulti <- "NO GENE SETS FOUND." } } } } })
Row {data-height=500}
Gene Expression
## Show genePlot for multiple clusters plotly::plotlyOutput("genePlotCluster")
## Render genePlot for multiple clusters output$genePlotCluster <- renderPlotly({ if (!is.null(values$GeneMultip)) { values$gp <- TRUE plotGenePathwayClustersDash(eMat, colDat, values$GeneMultip, values$groupListClicked, meta$cohorts, meta$vehicle) } else { text=paste( "\n Select a gene above \n to show observation-level expression.") hm <- ggplot() + annotate("text", x=0, y=0, size=4, label=text) + theme_bw() + theme(axis.line=element_blank(), axis.text.x=element_blank(), axis.text.y=element_blank(), axis.ticks=element_blank(), axis.title.x=element_blank(), axis.title.y=element_blank(), legend.position="none", panel.background=element_blank(), panel.border=element_blank(), panel.grid.major=element_blank(), panel.grid.minor=element_blank(), plot.background=element_blank()) ggplotly(hm) } })
Row {data-height=550}
Enrichment Results
## Show table of enrichment DT::dataTableOutput("HEmulti")
## Render table of enrichment output$HEmulti <- renderDataTable({ values$heMultiHeld if (!is.null(values$EnrRes)) { genesetTableClusters(values$EnrRes, values$nodeSelDGEMulti, values$dgeHitsMulti) } }) ## Control Searches observeEvent(input$HEmulti_search_columns, { if (!is.null(values$dgeHitsMulti)) { if (input$HEmulti_search_columns[1] != values$dgeHitsMulti) { values$dgeMultiHeld <- runif (1, 0, 1) values$dgeHitsMulti <- NULL values$nodeSelDGEMulti <- gsub("\\$|\\^", "", input$HEmulti_search_columns[2]) } } }) ## Render genetable results output$DGE <- renderDataTable({ values$dgeHeld geneTable(dgeTable, values$nodeSelHE, values$geneList) }) ## Control Searches observeEvent(input$DGE_search_columns, { if (!is.null(values$geneList)) { if (input$DGE_search_columns[1] != values$geneList) { values$heHeld <- runif(1, 0, 1) values$geneList <- NULL values$nodeSelHE <- gsub("\\$|\\^", "", input$DGE_search_columns[2]) } } })
## Functions for help and download the data enrHelpShowMulti <- function() { div(id="enrHelpMulti", modalDialog( "1) Use ^SEARCHTERM$ to filter for exact matches in columns", br(), HTML("2) Select '📊' to plot Gene Set Enrichment Score below." ), br(), HTML("3) Select '✈' to send row information to look up results for individual genes in this pathway below."), br(), easyClose=TRUE, title="Help") ) } ## Functions for help and download the data enrTabDLMulti <- function() { div(id="enrDLMulti", modalDialog(downloadButton("downloadFisherCSVMulti", "Download Table as CSV file"), br(), br(), easyClose=TRUE, title="Download Table") ) }
## Pop-up for help observeEvent(input$enrHelpMulti, { showModal(enrHelpShowMulti()) }) output$downloadFisherCSVMulti <- downloadHandler( filename=function() { paste("enrresultsmulti-", Sys.Date(), ".csv", sep="") }, content=function(file) { write.csv(values$EnrRes[,seq(12)], file, row.names=FALSE) } ) ## Pop-up for download observeEvent(input$enrDLMulti, { showModal(enrTabDLMulti()) }) ## Reactive row selection observeEvent({input$HEmulti_cell_clicked}, { if (!is.null(input$HEmulti_cell_clicked$value)) { ## Get Value enrVal <- gsub( "<label for='|'>✈</label>|'>📊</label>", "", as.character(input$HEmulti_cell_clicked$value)) ## If PlotRow then set nodeSelHE if (grepl("PlotRow|SendRow", enrVal)) { rowNum <- as.numeric(sub("PlotRow|SendRow", "", enrVal)) HYPERRowMulti <- values$EnrRes[rowNum, , drop=FALSE] ## If plotting send the node to plot, otherwise global if (grepl("PlotRow", enrVal)) { values$GeneSetMultip <- HYPERRowMulti[, "Gene Set"] } else { values$nodeSelHEMulti <- HYPERRowMulti[, "Subgroup"] values$GeneSetMulti <- HYPERRowMulti[, "Gene Set"] values$geneListMulti <- paste(paste0("^", genesets[[values$GeneSetMulti]], "$"), collapse="|") } } } })
Row {data-height=500}
Gene Set Enrichment Score
## Show plot of enrichment of multiple clusters plotly::plotlyOutput("hePlotCluster")
## Render plot of enrichment of multiple clusters output$hePlotCluster <- renderPlotly({ if (!is.null(values$GeneSetMultip)) { values$gp <- TRUE plotGenePathwayClustersDash(gMat, colDat, values$GeneSetMultip, values$groupListClicked, cohorts=meta$cohorts, vehicle=meta$vehicle, enrYlab) } else { text=paste("\n Select a pathway above \n to show observation-level enrichment. \n") hm <- ggplot() + annotate("text", x=0, y=0, size=4, label=text) + theme_bw() + theme(axis.line=element_blank(), axis.text.x=element_blank(), axis.text.y=element_blank(), axis.ticks=element_blank(), axis.title.x=element_blank(), axis.title.y=element_blank(), legend.position="none", panel.background=element_blank(), panel.border=element_blank(), panel.grid.major=element_blank(), panel.grid.minor=element_blank(), plot.background=element_blank()) ggplotly(hm) } })
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.