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(GSVA)
library(Biobase)
library(RColorBrewer)
library(limma)
library(dendextend)
## Read in helper functions
source(system.file("dashboard", "DashHelper.R", package="K2Taxonomer"))
## Read in analysis results
K2summary <- readRDS("K2results.rds")
## Parse results
info <- K2info(K2summary); infoMat <- as.matrix(info) ## Format information
K2res <- K2results(K2summary) ## Format K2 results
dataMatrix <- K2data(K2summary) ## Format dataMatrix
genesets <- K2genesets(K2summary) ## Get geneset lists
gene2Pathway <- K2gene2Pathway(K2summary) ## Get gene2pathway matching
eSet <- K2eSet(K2summary) ## Get expression set
gSet <- K2gSet(K2summary) ## Get gene set projection expression set
meta <- K2meta(K2summary) ## Get meta data
geneURL <- K2geneURL(K2summary) ## Get meta data
genesetURL <- K2genesetURL(K2summary) ## Get meta data
K2dendrogram <- K2dendro(K2summary) ## Create static dendrogram
# Get differential gene expression results
dgeTable <- getDGETable(K2summary)
# Get enrichment results
enrTable <- getEnrichmentTable(K2summary)
# Get phenotypic variable results
if (!is.null(K2res[[1]]$modTests)) {
modTestsTable <- getTestsModTable(K2summary)
}
## Create interactive dendrogram
vNetOut <- K2visNetwork(K2summary)
## Remove K2summary to save space
rm(K2summary)
## 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("B", "ntot", "t")]
## Remove gse from K2res
K2res <- lapply(K2res, function(x) {x$gse <- NULL; return(x)} )
## 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_hyper", "fdr_hyper", "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_Hyper", "FDR_Hyper", "N_Overlap", "N_Sig. Genes", "N_Gene Set",
"P Value_ssGSEA", "FDR_ssGSEA", "Diff_ssGSEA", "Mean_ssGSEA", "Hits",
"Plot", "Send", "Link")
## Formatdifferential gene expression results
## Remove gse from K2res
K2res <- lapply(K2res, function(x) {
x$dge <- NULL; return(x)
})
## 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))
names(varOptions) <- varOptions
if (!is.null(meta$cohorts)) {
varOptions <- varOptions[varOptions != "meta$cohorts"]
} else {
varOptions <- varOptions[varOptions != "sampleID"]
}
varOptions <- c("Add Annotation to Heatmap:"="", "RESET"="RESET", varOptions)
### Get sample order
labs <- get_leaves_attr(K2dendrogram, "label")
## Get IDs of each group
obsMap <- unlist(lapply(K2res, function(x) x$obs), recursive=FALSE)
## Reactive values
values <- reactiveValues(nodeSel="A", pathSel="A")
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}
Selections {.sidebar}
output$Search <- renderUI({
textInput("mstring", "Member Search:", value="")
})
output$Match <- renderUI({
## 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), " matche(s)")
valueString <- c("NOMATCH", rownames(infoMat)[infoInd])
names(valueString) <- c(nMatches, showString)
} else {
valueString <- c("No Matches")
}
selectInput("mVal", "Select a Match:", valueString)
})
## 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)])
updateTextInput(session, "mstring", value="")
values$reset <- runif(1, 0, 1)
}
})
## Out of global help button
htmlOutput("Search")
uiOutput("Match")
Row {data-height=600}
K2Taxonomer Results
## Render Dendrogram
output$dendro <- renderVisNetwork({
if (!is.null(values$mvTabSub)) {
if (nrow(values$mvTabSub) > 0) {
## Change width of edges
mEdge <- values$mvTabSub[, c("node", "Child", "width")]
colnames(mEdge) <- c("from", "to", "width")
edgeFram <- merge(vNetOut$x$edges, mEdge, all.x=TRUE, sort=FALSE)
edgeFram$width[is.na(edgeFram$width)] <- 1
edgeFram$color.inherit <- 'to'
vNetOut$x$edges <- edgeFram
## Change color of edges
mNode <- values$mvTabSub[, c("Child", "color")]
colnames(mNode) <- c("id", "color.border")
nodeFram <- merge(vNetOut$x$nodes, mNode, all.x=TRUE, sort=FALSE)
nodeFram$color.border[is.na(nodeFram$color.border)] <- brewer.pal(6,
"Greens")[1]
nodeFram$color.background <- nodeFram$color.border
nodeFram$color.highlight <- 'red'
vNetOut$x$nodes <- nodeFram
}
}
values$reset
values$gp <- TRUE
vNetOut %>%
visOptions(autoResize=TRUE,
height="100%",
nodesIdSelection=list(enabled=TRUE,
main="Node ID",
style='width: 100px; height: 25px;',
selected=values$pathSel),
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)
})
## Show dendrogram output
visNetworkOutput("dendro")
## Selections of dendrogram
observeEvent({
input$dendro_selected
}, {
node=input$dendro_selected
if (node %in% names(K2res) & node != values$nodeSel) {
values$nodeSel <- node
values$nodeSelDGE <- node
values$nodeSelHE <- node
values$geneList <-
values$groupDGE <-
values$dgeHits <-
values$Hits <-
values$nodeSelDGE <-
values$groupDGE <- NULL
}
},
ignoreNULL=TRUE,
ignoreInit=TRUE
)
Subgroup Information (↑=Edge:1; ↓=Edge:2)
## Create input selector for cluster info
output$AddVariable <- renderUI({
selectInput("selCov", NULL, varOptions)
})
## 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(K2res)){
## Get matrix and sort
samp_stab <- as.matrix(K2res[[values$nodeSel]]$stability$samples)
ord <- order(match(colnames(samp_stab), labs))
samp_stab <- as.matrix(samp_stab)[ord, ord]
## Get sample groups
modList <- K2res[[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(K2res)){
bootProb <- K2res[[values$nodeSel]]$bootP
nodeStab <- K2res[[values$nodeSel]]$stability$node
sampStab <- K2res[[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("")
}
})
## Generate table of phenotypic variable tests
if (!is.null(K2res[[1]]$modTests)) {
K2modTestFram <- modTestsTable[,c("node", "edge", "value", "pval", "fdr")]
## Get child
K2modTestFram$Child <- apply(K2modTestFram[, c("node", "edge")], 1,
function(x){
vSub <- vNetOut$x$edges[vNetOut$x$edges$from == x[1],]
vSub$to[as.numeric(x[2])]
})
## Get node
K2modTestFram$Subgroup <- paste0(K2modTestFram$node, K2modTestFram$edge)
## Format p-values
K2modTestFram <- K2modTestFram[!is.na(K2modTestFram$pval),]
K2modTestFram <- K2modTestFram[order(K2modTestFram$pval),]
output$metaVarTab <- renderDataTable({
values$mvTab <- K2modTestFram
K2modTestFram <- K2modTestFram[, c("Subgroup", "Child", "value", "pval",
"fdr")]
colnames(K2modTestFram) <- c("Subgroup", "Child", "Variable",
"P Value", "Q Value")
K2modTestFram$`P Value` <- signif(K2modTestFram$`P Value`, 2)
K2modTestFram$`Q Value` <- signif(K2modTestFram$`Q Value`, 2)
datatable(K2modTestFram,
rownames=FALSE,
extensions='Buttons',
escape=FALSE,
filter=list(position='top', clear=FALSE),
options=list(dom='Brt',
search=list(regex=TRUE, caseInsensitive=FALSE),
scrollX=TRUE,
scrollY="400px",
paging=FALSE,
pageLength=nrow(K2modTestFram),
buttons=list(list(extend="collection", text="Help",
action=DT::JS("function ( e, dt, node, config ) {
Shiny.setInputValue('phenoHelp', true, {priority: 'event'});
}")),
list(extend="collection", text="Download All Results",
action=DT::JS("function ( e, dt, node, config ) {
Shiny.setInputValue('phenoDL', true, {priority: 'event'});
}"))),
columnDefs=list(list(className='dt-center', targets="_all"))),
selection="single")
})
} else {
output$metaVarTab <- renderDataTable({
## Set null data table
values$mvTab <- NULL
K2modTestFramNULL <- data.frame("No phenotypic variable results.")
colnames(K2modTestFramNULL) <- NULL
datatable(K2modTestFramNULL,
rownames=FALSE,
extensions='Buttons',
escape=FALSE,
options=list(dom='Brt',
search=list(regex=TRUE, caseInsensitive=FALSE),
scrollX=TRUE,
scrollY="400px",
paging=FALSE,
pageLength=nrow(K2modTestFramNULL),
columnDefs=list(list(className='dt-center',
targets="_all"))),
selection="single")
})
}
## Functions for help and download the data
if (!is.null(K2res[[1]]$modTests)) {
phenoHelpShow <- function() {
div(id="phenoHelp",
modalDialog("1) Select row to visualize results in dendrogram.",
br(),
tags$div("2) Download table to view full set of statistical
values. For description of this table go",
tags$a(href=
'https://montilab.github.io/K2Taxonomer/reference/getTestsModTable.html',
'here'),
"."),
br(),
easyClose=TRUE, title="Help")
)
}
## Functions to download the data
phenoTabDL <- function() {
div(id="phenoDL",
modalDialog(downloadButton("downloadPhenoCSV",
"Download Table as CSV file"),
br(),
br(),
easyClose=TRUE, title="Download Table")
)
}
}
if (!is.null(K2res[[1]]$modTests)) {
## Pop-up for help
observeEvent(input$phenoHelp, {
showModal(phenoHelpShow())
})
## Download CSV File
output$downloadPhenoCSV <- downloadHandler(
filename=function() {
paste("phenoresults-", Sys.Date(), ".csv", sep="")
},
content=function(file) {
write.csv(modTestsTable, file, row.names=FALSE)
}
)
## Pop-up for CSV file
observeEvent(input$phenoDL, {
showModal(phenoTabDL())
})
}
## MetaVariable Clicks will change dendrogram
observeEvent({
input$metaVarTab_cell_clicked
}, {
if (!is.null(values$mvTab)) {
cat <- values$mvTab[input$metaVarTab_cell_clicked$row, "value"]
mvTabSub <- values$mvTab[values$mvTab$value == cat,]
## Color breaks
breaks <- c(1, 0.25, 0.1, 0.05, 0.01, 0.001, 0)
breakColors <- brewer.pal(7, "Greens")
mvTabSub$color <- vapply(mvTabSub$pval, function(pval) {
breakColors[which.min(breaks >= pval)]
}, FUN.VALUE=character(1))
## Size breaks
breaks <- c(1, 0.1, 0.05, 0.01, 0.001, 0.0001, 0)
breakSize <- seq(length(breaks)) * 7
mvTabSub$width <- vapply(mvTabSub$pval, function(pval) {
breakSize[which.min(breaks >= pval)]
}, FUN.VALUE=double(1))
## Add 2 values
values$mvTabSub <- mvTabSub
}
}
)
## Selections of dendrogram
observeEvent({
input$dendro_selected
}, {
node=input$dendro_selected
if (node %in% names(K2res)) {
values$nodeSel <- node
values$nodeSelDGE <- node
values$nodeSelHE <- node
values$geneList <- values$groupDGE <- values$dgeHits <- NULL
}
},
ignoreNULL=TRUE,
ignoreInit=TRUE
)
## Render table of information for each node
output$infoTab <- renderDataTable({
if (values$nodeSel != "No Selection"){
## Get observations
obs1 <- K2res[[values$nodeSel]]$obs[[1]]
obs2 <- K2res[[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")
}
})
## Show tabset of node information
div(
tabsetPanel(type="tabs",
tabPanel("Stability", fillCol(
fluidRow(
column(width=10, uiOutput("AddVariable"), offset=1),
plotlyOutput("heatmapPlot"),
column(width=10, htmlOutput("stabStats"), offset=1)
))),
tabPanel("Node members", fillCol(
DT::dataTableOutput("infoTab")
)),
tabPanel("Phenotypic variable results", fillCol(
DT::dataTableOutput("metaVarTab")
))
), style='height: 600px'
)
Row {data-height=550}
Differential 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 hyperenrichment 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
plotGenePathway(eSet,
values$Genep,
K2res[[values$nodeSelDGEp]]$obs[[1]],
K2res[[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 hyperenrichment table output
DT::dataTableOutput("HE")
## Render hyperenrichment table
output$HE <- renderDataTable({
values$heHeld
genesetTable(enrTable, values$nodeSelDGE, 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
hyperHelpShow <- function() {
div(id="hyperHelp",
modalDialog(
"1) Use ^SEARCHTERM$ to filter for exact matches in columns",
br(),
HTML(
"2) Select '📊' to plot single-sample enrichment 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
hyperTabDL <- function() {
div(id="hyperDL",
modalDialog(downloadButton("downloadHyperCSV",
"Download Table as CSV file"),
br(),
br(),
easyClose=TRUE, title="Download Table")
)
}
## Pop-up for help
observeEvent(input$hyperHelp, {
showModal(hyperHelpShow())
})
## Download CSV File
output$downloadHyperCSV <- 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$hyperDL, {
showModal(hyperTabDL())
})
## Reactive row selection
observeEvent({input$HE_cell_clicked},
{
if (!is.null(input$HE_cell_clicked$value)) {
## Get Value
hyperVal <- gsub(
"<label for='|'>✈</label>|'>📊</label>",
"", as.character(input$HE_cell_clicked$value))
## If PlotRow then set nodeSelHE
if (grepl("PlotRow|SendRow", hyperVal)) {
rowNum <- as.numeric(sub("PlotRow|SendRow", "", hyperVal))
HYPERRow <- enrTable[rowNum, , drop=FALSE]
## If plotting send the node to plot, otherwise global
if (grepl("PlotRow", hyperVal)) {
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}
Single-Sample Enrichment
## Render pathwayPlot
output$pathwayPlot <- renderPlotly({
if (!is.null(values$nodeSelHEp)){
values$gp <- TRUE
plotGenePathway(gSet,
values$GeneSetp,
K2res[[values$nodeSelHEp]]$obs[[1]],
K2res[[values$nodeSelHEp]]$obs[[2]],
meta$cohorts,
meta$vehicle,
"Enrichment Score")
} 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(K2res)) {
obs <- unlist(K2res[[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 <- .signatureWrapper(eSet,
cohorts=meta$cohorts,
mods,
vehicle=meta$vehicle,
covariates=meta$covariates,
logCounts=meta$logCounts)
## Add Subgroup and gene column
clusterRes$Subgroup <- names(values$groupListClicked)[
as.numeric(clusterRes$edge)]
clusterRes$gene <- rownames(clusterRes)
## Generete hyperenrichment results
incProgress(1/4, detail="Pathway Hyperenrichment")
hyperEnrRes <- hyperenrichmentClusters(clusterRes,
values$groupListClicked,
genesets,
meta$qthresh,
meta$cthresh,
meta$ntotal)
## Add Subgroup ID
hyperEnrRes <- do.call(rbind, lapply(names(hyperEnrRes), function(x) {
## Get GSE tables
HYPERtab <- hyperEnrRes[[x]]
if (nrow(HYPERtab) > 0) {
HYPERtab$Subgroup <- x
}
return(HYPERtab)
}))
## Add type of test
colnames(hyperEnrRes)[colnames(hyperEnrRes) %in% c("pval", "fdr")] <-
paste(colnames(hyperEnrRes)[colnames(hyperEnrRes) %in%
c("pval", "fdr")],
"hyper", sep="_")
## Generete hyperenrichment results
incProgress(1/4, detail="Pathway Differential Enrichment")
ssEnrRes <- .signatureWrapper(gSet,
cohorts=meta$cohorts,
mods,
vehicle=NULL,
covariates=meta$covariates)
## Add Subgroup and category
ssEnrRes$Subgroup <- names(values$groupListClicked)[
as.numeric(ssEnrRes$edge)]
ssEnrRes$category <- rownames(ssEnrRes)
## Add type of test
colnames(ssEnrRes)[colnames(ssEnrRes) %in% c("pval", "fdr")] <-
paste(colnames(ssEnrRes)[colnames(ssEnrRes) %in% c("pval", "fdr")],
"limma", sep="_")
## Format hyperenrichment table
incProgress(1/3, detail="Formatting Results")
## Merge the two and sort by hyper p-value
EnrRes <- merge(hyperEnrRes, ssEnrRes, all=TRUE)
### Order by pvalue
EnrRes <- EnrRes[order(EnrRes$pval_hyper),]
## Sort columns
EnrRes <- EnrRes[, c("category", "Subgroup", "pval_hyper", "fdr_hyper",
"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_hyper", "fdr_hyper", "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_Hyper",
"FDR_Hyper", "N_Overlap", "N_Sig. Genes", "N_Gene Set",
"P Value_ssGSEA", "FDR_ssGSEA", "Diff_ssGSEA", "Mean_ssGSEA",
"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 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 hyperenrichment 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
plotGenePathwayClusters(eSet,
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}
Hyperenrichment Results
## Show table of hyperenrichment
DT::dataTableOutput("HEmulti")
## Render table of hyperenrichment
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])
}
}
})
## Functions for help and download the data
hyperHelpShowMulti <- function() {
div(id="hyperHelpMulti",
modalDialog(
"1) Use ^SEARCHTERM$ to filter for exact matches in columns",
br(),
HTML("2) Select '📊' to plot single-sample enrichment 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
hyperTabDLMulti <- function() {
div(id="hyperDLMulti",
modalDialog(downloadButton("downloadHyperCSVMulti",
"Download Table as CSV file"),
br(),
br(),
easyClose=TRUE, title="Download Table")
)
}
## Pop-up for help
observeEvent(input$hyperHelpMulti, {
showModal(hyperHelpShowMulti())
})
output$downloadHyperCSVMulti <- 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$hyperDLMulti, {
showModal(hyperTabDLMulti())
})
## Reactive row selection
observeEvent({input$HEmulti_cell_clicked},
{
if (!is.null(input$HEmulti_cell_clicked$value)) {
## Get Value
hyperVal <- gsub(
"<label for='|'>✈</label>|'>📊</label>", "",
as.character(input$HEmulti_cell_clicked$value))
## If PlotRow then set nodeSelHE
if (grepl("PlotRow|SendRow", hyperVal)) {
rowNum <- as.numeric(sub("PlotRow|SendRow", "", hyperVal))
HYPERRowMulti <- values$EnrRes[rowNum, , drop=FALSE]
## If plotting send the node to plot, otherwise global
if (grepl("PlotRow", hyperVal)) {
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}
Single-sample Enrichment
## Show plot of hyperenrichment of multiple clusters
plotly::plotlyOutput("hePlotCluster")
## Render plot of hyperenrichment of multiple clusters
output$hePlotCluster <- renderPlotly({
if (!is.null(values$GeneSetMultip)) {
values$gp <- TRUE
plotGenePathwayClusters(gSet,
values$GeneSetMultip,
values$groupListClicked,
cohorts=meta$cohorts,
vehicle=meta$vehicle,
"Enrichment Score")
} 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 Jan. 25, 2024, 4:29 p.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(GSVA) library(Biobase) library(RColorBrewer) library(limma) library(dendextend) ## Read in helper functions source(system.file("dashboard", "DashHelper.R", package="K2Taxonomer"))
## Read in analysis results K2summary <- readRDS("K2results.rds") ## Parse results info <- K2info(K2summary); infoMat <- as.matrix(info) ## Format information K2res <- K2results(K2summary) ## Format K2 results dataMatrix <- K2data(K2summary) ## Format dataMatrix genesets <- K2genesets(K2summary) ## Get geneset lists gene2Pathway <- K2gene2Pathway(K2summary) ## Get gene2pathway matching eSet <- K2eSet(K2summary) ## Get expression set gSet <- K2gSet(K2summary) ## Get gene set projection expression set meta <- K2meta(K2summary) ## Get meta data geneURL <- K2geneURL(K2summary) ## Get meta data genesetURL <- K2genesetURL(K2summary) ## Get meta data K2dendrogram <- K2dendro(K2summary) ## Create static dendrogram # Get differential gene expression results dgeTable <- getDGETable(K2summary) # Get enrichment results enrTable <- getEnrichmentTable(K2summary) # Get phenotypic variable results if (!is.null(K2res[[1]]$modTests)) { modTestsTable <- getTestsModTable(K2summary) } ## Create interactive dendrogram vNetOut <- K2visNetwork(K2summary) ## Remove K2summary to save space rm(K2summary) ## 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("B", "ntot", "t")] ## Remove gse from K2res K2res <- lapply(K2res, function(x) {x$gse <- NULL; return(x)} ) ## 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_hyper", "fdr_hyper", "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_Hyper", "FDR_Hyper", "N_Overlap", "N_Sig. Genes", "N_Gene Set", "P Value_ssGSEA", "FDR_ssGSEA", "Diff_ssGSEA", "Mean_ssGSEA", "Hits", "Plot", "Send", "Link") ## Formatdifferential gene expression results ## Remove gse from K2res K2res <- lapply(K2res, function(x) { x$dge <- NULL; return(x) }) ## 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)) names(varOptions) <- varOptions if (!is.null(meta$cohorts)) { varOptions <- varOptions[varOptions != "meta$cohorts"] } else { varOptions <- varOptions[varOptions != "sampleID"] } varOptions <- c("Add Annotation to Heatmap:"="", "RESET"="RESET", varOptions) ### Get sample order labs <- get_leaves_attr(K2dendrogram, "label") ## Get IDs of each group obsMap <- unlist(lapply(K2res, function(x) x$obs), recursive=FALSE)
## Reactive values values <- reactiveValues(nodeSel="A", pathSel="A")
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}
Selections {.sidebar}
output$Search <- renderUI({ textInput("mstring", "Member Search:", value="") }) output$Match <- renderUI({ ## 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), " matche(s)") valueString <- c("NOMATCH", rownames(infoMat)[infoInd]) names(valueString) <- c(nMatches, showString) } else { valueString <- c("No Matches") } selectInput("mVal", "Select a Match:", valueString) }) ## 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)]) updateTextInput(session, "mstring", value="") values$reset <- runif(1, 0, 1) } })
## Out of global help button htmlOutput("Search") uiOutput("Match")
Row {data-height=600}
K2Taxonomer Results
## Render Dendrogram output$dendro <- renderVisNetwork({ if (!is.null(values$mvTabSub)) { if (nrow(values$mvTabSub) > 0) { ## Change width of edges mEdge <- values$mvTabSub[, c("node", "Child", "width")] colnames(mEdge) <- c("from", "to", "width") edgeFram <- merge(vNetOut$x$edges, mEdge, all.x=TRUE, sort=FALSE) edgeFram$width[is.na(edgeFram$width)] <- 1 edgeFram$color.inherit <- 'to' vNetOut$x$edges <- edgeFram ## Change color of edges mNode <- values$mvTabSub[, c("Child", "color")] colnames(mNode) <- c("id", "color.border") nodeFram <- merge(vNetOut$x$nodes, mNode, all.x=TRUE, sort=FALSE) nodeFram$color.border[is.na(nodeFram$color.border)] <- brewer.pal(6, "Greens")[1] nodeFram$color.background <- nodeFram$color.border nodeFram$color.highlight <- 'red' vNetOut$x$nodes <- nodeFram } } values$reset values$gp <- TRUE vNetOut %>% visOptions(autoResize=TRUE, height="100%", nodesIdSelection=list(enabled=TRUE, main="Node ID", style='width: 100px; height: 25px;', selected=values$pathSel), 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) })
## Show dendrogram output visNetworkOutput("dendro")
## Selections of dendrogram observeEvent({ input$dendro_selected }, { node=input$dendro_selected if (node %in% names(K2res) & node != values$nodeSel) { values$nodeSel <- node values$nodeSelDGE <- node values$nodeSelHE <- node values$geneList <- values$groupDGE <- values$dgeHits <- values$Hits <- values$nodeSelDGE <- values$groupDGE <- NULL } }, ignoreNULL=TRUE, ignoreInit=TRUE )
Subgroup Information (↑=Edge:1; ↓=Edge:2)
## Create input selector for cluster info output$AddVariable <- renderUI({ selectInput("selCov", NULL, varOptions) })
## 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(K2res)){ ## Get matrix and sort samp_stab <- as.matrix(K2res[[values$nodeSel]]$stability$samples) ord <- order(match(colnames(samp_stab), labs)) samp_stab <- as.matrix(samp_stab)[ord, ord] ## Get sample groups modList <- K2res[[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(K2res)){ bootProb <- K2res[[values$nodeSel]]$bootP nodeStab <- K2res[[values$nodeSel]]$stability$node sampStab <- K2res[[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("") } })
## Generate table of phenotypic variable tests if (!is.null(K2res[[1]]$modTests)) { K2modTestFram <- modTestsTable[,c("node", "edge", "value", "pval", "fdr")] ## Get child K2modTestFram$Child <- apply(K2modTestFram[, c("node", "edge")], 1, function(x){ vSub <- vNetOut$x$edges[vNetOut$x$edges$from == x[1],] vSub$to[as.numeric(x[2])] }) ## Get node K2modTestFram$Subgroup <- paste0(K2modTestFram$node, K2modTestFram$edge) ## Format p-values K2modTestFram <- K2modTestFram[!is.na(K2modTestFram$pval),] K2modTestFram <- K2modTestFram[order(K2modTestFram$pval),] output$metaVarTab <- renderDataTable({ values$mvTab <- K2modTestFram K2modTestFram <- K2modTestFram[, c("Subgroup", "Child", "value", "pval", "fdr")] colnames(K2modTestFram) <- c("Subgroup", "Child", "Variable", "P Value", "Q Value") K2modTestFram$`P Value` <- signif(K2modTestFram$`P Value`, 2) K2modTestFram$`Q Value` <- signif(K2modTestFram$`Q Value`, 2) datatable(K2modTestFram, rownames=FALSE, extensions='Buttons', escape=FALSE, filter=list(position='top', clear=FALSE), options=list(dom='Brt', search=list(regex=TRUE, caseInsensitive=FALSE), scrollX=TRUE, scrollY="400px", paging=FALSE, pageLength=nrow(K2modTestFram), buttons=list(list(extend="collection", text="Help", action=DT::JS("function ( e, dt, node, config ) { Shiny.setInputValue('phenoHelp', true, {priority: 'event'}); }")), list(extend="collection", text="Download All Results", action=DT::JS("function ( e, dt, node, config ) { Shiny.setInputValue('phenoDL', true, {priority: 'event'}); }"))), columnDefs=list(list(className='dt-center', targets="_all"))), selection="single") }) } else { output$metaVarTab <- renderDataTable({ ## Set null data table values$mvTab <- NULL K2modTestFramNULL <- data.frame("No phenotypic variable results.") colnames(K2modTestFramNULL) <- NULL datatable(K2modTestFramNULL, rownames=FALSE, extensions='Buttons', escape=FALSE, options=list(dom='Brt', search=list(regex=TRUE, caseInsensitive=FALSE), scrollX=TRUE, scrollY="400px", paging=FALSE, pageLength=nrow(K2modTestFramNULL), columnDefs=list(list(className='dt-center', targets="_all"))), selection="single") }) }
## Functions for help and download the data if (!is.null(K2res[[1]]$modTests)) { phenoHelpShow <- function() { div(id="phenoHelp", modalDialog("1) Select row to visualize results in dendrogram.", br(), tags$div("2) Download table to view full set of statistical values. For description of this table go", tags$a(href= 'https://montilab.github.io/K2Taxonomer/reference/getTestsModTable.html', 'here'), "."), br(), easyClose=TRUE, title="Help") ) } ## Functions to download the data phenoTabDL <- function() { div(id="phenoDL", modalDialog(downloadButton("downloadPhenoCSV", "Download Table as CSV file"), br(), br(), easyClose=TRUE, title="Download Table") ) } }
if (!is.null(K2res[[1]]$modTests)) { ## Pop-up for help observeEvent(input$phenoHelp, { showModal(phenoHelpShow()) }) ## Download CSV File output$downloadPhenoCSV <- downloadHandler( filename=function() { paste("phenoresults-", Sys.Date(), ".csv", sep="") }, content=function(file) { write.csv(modTestsTable, file, row.names=FALSE) } ) ## Pop-up for CSV file observeEvent(input$phenoDL, { showModal(phenoTabDL()) }) }
## MetaVariable Clicks will change dendrogram observeEvent({ input$metaVarTab_cell_clicked }, { if (!is.null(values$mvTab)) { cat <- values$mvTab[input$metaVarTab_cell_clicked$row, "value"] mvTabSub <- values$mvTab[values$mvTab$value == cat,] ## Color breaks breaks <- c(1, 0.25, 0.1, 0.05, 0.01, 0.001, 0) breakColors <- brewer.pal(7, "Greens") mvTabSub$color <- vapply(mvTabSub$pval, function(pval) { breakColors[which.min(breaks >= pval)] }, FUN.VALUE=character(1)) ## Size breaks breaks <- c(1, 0.1, 0.05, 0.01, 0.001, 0.0001, 0) breakSize <- seq(length(breaks)) * 7 mvTabSub$width <- vapply(mvTabSub$pval, function(pval) { breakSize[which.min(breaks >= pval)] }, FUN.VALUE=double(1)) ## Add 2 values values$mvTabSub <- mvTabSub } } ) ## Selections of dendrogram observeEvent({ input$dendro_selected }, { node=input$dendro_selected if (node %in% names(K2res)) { values$nodeSel <- node values$nodeSelDGE <- node values$nodeSelHE <- node values$geneList <- values$groupDGE <- values$dgeHits <- NULL } }, ignoreNULL=TRUE, ignoreInit=TRUE )
## Render table of information for each node output$infoTab <- renderDataTable({ if (values$nodeSel != "No Selection"){ ## Get observations obs1 <- K2res[[values$nodeSel]]$obs[[1]] obs2 <- K2res[[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") } })
## Show tabset of node information div( tabsetPanel(type="tabs", tabPanel("Stability", fillCol( fluidRow( column(width=10, uiOutput("AddVariable"), offset=1), plotlyOutput("heatmapPlot"), column(width=10, htmlOutput("stabStats"), offset=1) ))), tabPanel("Node members", fillCol( DT::dataTableOutput("infoTab") )), tabPanel("Phenotypic variable results", fillCol( DT::dataTableOutput("metaVarTab") )) ), style='height: 600px' )
Row {data-height=550}
Differential 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 hyperenrichment 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 plotGenePathway(eSet, values$Genep, K2res[[values$nodeSelDGEp]]$obs[[1]], K2res[[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 hyperenrichment table output DT::dataTableOutput("HE")
## Render hyperenrichment table output$HE <- renderDataTable({ values$heHeld genesetTable(enrTable, values$nodeSelDGE, 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 hyperHelpShow <- function() { div(id="hyperHelp", modalDialog( "1) Use ^SEARCHTERM$ to filter for exact matches in columns", br(), HTML( "2) Select '📊' to plot single-sample enrichment 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 hyperTabDL <- function() { div(id="hyperDL", modalDialog(downloadButton("downloadHyperCSV", "Download Table as CSV file"), br(), br(), easyClose=TRUE, title="Download Table") ) }
## Pop-up for help observeEvent(input$hyperHelp, { showModal(hyperHelpShow()) }) ## Download CSV File output$downloadHyperCSV <- 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$hyperDL, { showModal(hyperTabDL()) }) ## Reactive row selection observeEvent({input$HE_cell_clicked}, { if (!is.null(input$HE_cell_clicked$value)) { ## Get Value hyperVal <- gsub( "<label for='|'>✈</label>|'>📊</label>", "", as.character(input$HE_cell_clicked$value)) ## If PlotRow then set nodeSelHE if (grepl("PlotRow|SendRow", hyperVal)) { rowNum <- as.numeric(sub("PlotRow|SendRow", "", hyperVal)) HYPERRow <- enrTable[rowNum, , drop=FALSE] ## If plotting send the node to plot, otherwise global if (grepl("PlotRow", hyperVal)) { 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}
Single-Sample Enrichment
## Render pathwayPlot output$pathwayPlot <- renderPlotly({ if (!is.null(values$nodeSelHEp)){ values$gp <- TRUE plotGenePathway(gSet, values$GeneSetp, K2res[[values$nodeSelHEp]]$obs[[1]], K2res[[values$nodeSelHEp]]$obs[[2]], meta$cohorts, meta$vehicle, "Enrichment Score") } 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(K2res)) { obs <- unlist(K2res[[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 <- .signatureWrapper(eSet, cohorts=meta$cohorts, mods, vehicle=meta$vehicle, covariates=meta$covariates, logCounts=meta$logCounts) ## Add Subgroup and gene column clusterRes$Subgroup <- names(values$groupListClicked)[ as.numeric(clusterRes$edge)] clusterRes$gene <- rownames(clusterRes) ## Generete hyperenrichment results incProgress(1/4, detail="Pathway Hyperenrichment") hyperEnrRes <- hyperenrichmentClusters(clusterRes, values$groupListClicked, genesets, meta$qthresh, meta$cthresh, meta$ntotal) ## Add Subgroup ID hyperEnrRes <- do.call(rbind, lapply(names(hyperEnrRes), function(x) { ## Get GSE tables HYPERtab <- hyperEnrRes[[x]] if (nrow(HYPERtab) > 0) { HYPERtab$Subgroup <- x } return(HYPERtab) })) ## Add type of test colnames(hyperEnrRes)[colnames(hyperEnrRes) %in% c("pval", "fdr")] <- paste(colnames(hyperEnrRes)[colnames(hyperEnrRes) %in% c("pval", "fdr")], "hyper", sep="_") ## Generete hyperenrichment results incProgress(1/4, detail="Pathway Differential Enrichment") ssEnrRes <- .signatureWrapper(gSet, cohorts=meta$cohorts, mods, vehicle=NULL, covariates=meta$covariates) ## Add Subgroup and category ssEnrRes$Subgroup <- names(values$groupListClicked)[ as.numeric(ssEnrRes$edge)] ssEnrRes$category <- rownames(ssEnrRes) ## Add type of test colnames(ssEnrRes)[colnames(ssEnrRes) %in% c("pval", "fdr")] <- paste(colnames(ssEnrRes)[colnames(ssEnrRes) %in% c("pval", "fdr")], "limma", sep="_") ## Format hyperenrichment table incProgress(1/3, detail="Formatting Results") ## Merge the two and sort by hyper p-value EnrRes <- merge(hyperEnrRes, ssEnrRes, all=TRUE) ### Order by pvalue EnrRes <- EnrRes[order(EnrRes$pval_hyper),] ## Sort columns EnrRes <- EnrRes[, c("category", "Subgroup", "pval_hyper", "fdr_hyper", "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_hyper", "fdr_hyper", "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_Hyper", "FDR_Hyper", "N_Overlap", "N_Sig. Genes", "N_Gene Set", "P Value_ssGSEA", "FDR_ssGSEA", "Diff_ssGSEA", "Mean_ssGSEA", "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 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 hyperenrichment 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 plotGenePathwayClusters(eSet, 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}
Hyperenrichment Results
## Show table of hyperenrichment DT::dataTableOutput("HEmulti")
## Render table of hyperenrichment 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]) } } })
## Functions for help and download the data hyperHelpShowMulti <- function() { div(id="hyperHelpMulti", modalDialog( "1) Use ^SEARCHTERM$ to filter for exact matches in columns", br(), HTML("2) Select '📊' to plot single-sample enrichment 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 hyperTabDLMulti <- function() { div(id="hyperDLMulti", modalDialog(downloadButton("downloadHyperCSVMulti", "Download Table as CSV file"), br(), br(), easyClose=TRUE, title="Download Table") ) }
## Pop-up for help observeEvent(input$hyperHelpMulti, { showModal(hyperHelpShowMulti()) }) output$downloadHyperCSVMulti <- 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$hyperDLMulti, { showModal(hyperTabDLMulti()) }) ## Reactive row selection observeEvent({input$HEmulti_cell_clicked}, { if (!is.null(input$HEmulti_cell_clicked$value)) { ## Get Value hyperVal <- gsub( "<label for='|'>✈</label>|'>📊</label>", "", as.character(input$HEmulti_cell_clicked$value)) ## If PlotRow then set nodeSelHE if (grepl("PlotRow|SendRow", hyperVal)) { rowNum <- as.numeric(sub("PlotRow|SendRow", "", hyperVal)) HYPERRowMulti <- values$EnrRes[rowNum, , drop=FALSE] ## If plotting send the node to plot, otherwise global if (grepl("PlotRow", hyperVal)) { 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}
Single-sample Enrichment
## Show plot of hyperenrichment of multiple clusters plotly::plotlyOutput("hePlotCluster")
## Render plot of hyperenrichment of multiple clusters output$hePlotCluster <- renderPlotly({ if (!is.null(values$GeneSetMultip)) { values$gp <- TRUE plotGenePathwayClusters(gSet, values$GeneSetMultip, values$groupListClicked, cohorts=meta$cohorts, vehicle=meta$vehicle, "Enrichment Score") } 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.