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 })
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")
## 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 )
## 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' )
## 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." } } } } })
## 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")
## 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="|") } } } })
## 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")
## 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)
## Show dendroselect output visNetworkOutput("dendroSelect")
## 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 }) })
## 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." } } } } })
## 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) } })
## 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="|") } } } })
## 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) } })
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.