Nothing
R/exploreGSAres.R
In piano: Platform for integrative analysis of omics data
Defines functions
exploreGSAres
Documented in
exploreGSAres
#' Explore GSA results
#'
#' Explore GSA results interactively in a web browser using \code{shiny}.
#'
#' Additional gene-level information, e.g. alternative names or description,
#' can be supplied via the \code{geneAnnot} argument. This information will
#' show up in the gene table and the gene summary tabs.
#'
#' @param gsaRes an object of class \code{GSAres}, as returned from
#' \code{runGSA()} or an object returned from \code{runGSAhyper()}.
#' @param browser a logical, whether or not to open the Shiny app in a browser
#' window. Set to \code{FALSE} to open an interactive window directly in
#' RStudio.
#' @param geneAnnot a \code{data.frame}, containing gene annotation. The first
#' column should be gene IDs matching those in \code{gsares}.
#' @param genesets a character vector or list (named or un-named) of character vectors
#' containing subsets of gene-set names that can be selected and displayed in the
#' network plot.
#' @return Does not return any object.
#' @author Leif Varemo \email{piano.rpkg@@gmail.com}
#' @seealso \pkg{\link{piano}}, \code{\link{runGSA}}, \code{\link{GSAheatmap}}, \code{\link{networkPlot2}}
#' @examples
#'
#' # Load example input data to GSA:
#' data("gsa_input")
#'
#' # Load gene set collection:
#' gsc <- loadGSC(gsa_input$gsc)
#'
#' # Run gene set analysis:
#' gsares <- runGSA(geneLevelStats=gsa_input$pvals , directions=gsa_input$directions,
#' gsc=gsc, nPerm=500)
#'
#' # Explore results:
#' \dontrun{exploreGSAres(gsares)}
#'
exploreGSAres <- function(gsaRes, browser=TRUE, geneAnnot=NULL, genesets) {
gsares <- gsaRes
# Argument checking:
if(!is(gsares, "GSAres")) stop("argument gsares is not of class GSAres")
if(!is.logical(browser)) stop("argument browser is not a logical")
if(!is.null(geneAnnot)) {
if(sum(duplicated(geneAnnot[,1]))>0) stop("geneAnnot may not contain duplicated gene IDs")
if(sum(geneAnnot[,1]%in%rownames(gsares$geneLevelStats)) == 0) stop("no overlap between genes in geneAnnot and gsares")
}
if(missing(genesets)) genesets <- list("No available gene-sets" = "No available gene-sets")
if(is(genesets, "list")) {
if(unique(unlist(lapply(genesets, class)))[1] != "character" | length(unique(unlist(lapply(genesets, class))))>1) stop("genesets has to be a character vector or a list of character vectors")
} else {
if(!is(genesets, "character")) stop("genesets has to be a character vector or a list of character vectors")
genesets <- list(genesets)
}
if(is.null(names(genesets))) names(genesets) <- paste("Gene-set list", seq(from=1, to=length(genesets)))
if(any(names(genesets) == "")) names(genesets)[names(genesets)==""] <- paste("Gene-set list", seq(from=1, to=sum(names(genesets)=="")))
# Check packages now, otherwise delayed error during app browsing, if missing:
if(!"shiny"%in%installed.packages()[,"Package"]) stop("missing package shiny")
if(!"shinyjs"%in%installed.packages()[,"Package"]) stop("missing package shinyjs")
if(!"DT"%in%installed.packages()[,"Package"]) stop("missing package DT")
# Set needed variables for network plot:
selectable_classes_network <- list()
if(!all(is.na(gsares$pDistinctDirUp)) | !all(is.na(gsares$pDistinctDirDn))) {
selectable_classes_network$"Distinct directional" <- "distinct_both"
}
if(!all(is.na(gsares$pNonDirectional))) {
selectable_classes_network$"Non directional" <- "non_NULL"
}
if(!all(is.na(gsares$pMixedDirUp)) | !all(is.na(gsares$pMixedDirDn))) {
selectable_classes_network$"Mixed directional up" <- "mixed_up"
selectable_classes_network$"Mixed directional down" <- "mixed_down"
}
selected_class_network <- selectable_classes_network[[1]]
if(selected_class_network == "distinct_both") {
cutoff_network <- signif(sort(c(gsares$pAdjDistinctDirUp,gsares$pAdjDistinctDirDn), decreasing=FALSE)[20],2)
} else if(selected_class_network == "non_NULL") {
cutoff_network <- signif(sort(gsares$pAdjNonDirectional, decreasing=FALSE)[20],2)
} else if(selected_class_network == "mixed_up") {
cutoff_network <- signif(sort(c(gsares$pAdjMixedDirUp), decreasing=FALSE)[20],2)
}
if(cutoff_network==0) cutoff_network <- 1e-6
# App object with ui and server
app <- shinyApp(
# ===================================================================================
# ui
# ui <- fluidPage(
ui <- dashboardPage(
dashboardHeader(disable=TRUE),
dashboardSidebar(disable=TRUE),
dashboardBody(navbarPage("Explore your GSA results",id="navbarpage",selected="tab_gsainfo", collapsible=TRUE,
# fluidRow(
# column(8,
# h2(HTML("Explore gene-set analysis results"))
# )#,
# #column(4,
# # div(imageOutput(system.file("shiny", "loggo.png", package="piano"), height="70px"), style="text-align: right;")
# #)
# ),
#HTML("<br>"),
#fluidRow(
#column(12,
#tabsetPanel(id="tabset1",
#type = "tabs",
tabPanel(title="Run info", value="tab_gsainfo",
useShinyjs(),
#includeCSS("css/cosmo.css"),
#includeCSS("css/toggle_switch.css"),
#includeCSS("css/style.css"),
includeCSS(system.file("shiny", "css", "cosmo.css", package="piano")),
includeCSS(system.file("shiny", "css", "toggle_switch.css", package="piano")),
includeCSS(system.file("shiny", "css", "style.css", package="piano")),
tags$head(
tags$style(
HTML(".shiny-notification {
position:fixed;
top: calc(25%);
left: calc(25%);
width: 300px;
}"
)
)
),
div(id="loading_tab_gsainfo",
HTML("<br><br><center><h3>",c("Just hold on a sec","Please wait","Just a moment")[sample(1:3,1)],"</h3><h4>Loading your results...</h4></center>")
),
hidden(div(id="tab_gsainfo",
HTML("<br>"),
column(5,
box(title="Gene/gene-set info", status="primary", width="100%",
htmlOutput("text_runinfo1")
),
box(title="Analysis details", status="primary", width="100%",
htmlOutput("text_runinfo2")
),
wellPanel(style="background-color: #E2F3FF;",
htmlOutput("text_runinfo3")
)
),
column(7,
tabBox(width="100%",
tabPanel("Gene-set size", value="gene_set_size_hist",
plotOutput("gsc_boxplot1", height="340px", width="100%"),
HTML("<div style='max-width: 600px'><b>Number of <font color='#009900'>genes</font> per <font color='#9966ff'>gene-set</font>.</b>
Gives you an idea about sizes of the gene-sets used in the analysis.
Are you looking at small specific gene-sets with few genes, or large
general gene-sets? Note that these stats are <em>after</em> filtering the
input GSC according to available gene-level statistics and the gsSizeLim parameter.
<br><br></div>")
),
tabPanel("Gene-set redundency", value="gene_set_redundency_hist",
plotOutput("gsc_boxplot2", height="340px", width="100%"),
HTML("<div style='max-width: 600px'><b>Number of <font color='#9966ff'>gene-sets</font> per <font color='#009900'>gene</font>.</b>
Gives you a general overview of how many gene-sets each gene belongs to.
Do you have many genes contributing to a lot of overlap between gene-sets,
or do you have very uniquely defined gene-sets where genes only appear in one
or a few gene-sets?</div>")
)
)
)
))),
tabPanel(title="Gene-set table", value="tab_gsares",
div(id="loading_tab_gsares",
HTML("<br><br><center><h3>",c("Just hold on a sec","Please wait","Just a moment")[sample(1:3,1)],"</h3><h4>Loading your results...</h4></center>")
),
hidden(div(id="tab_gsares",
HTML("<table style='border-collapse:separate; border-spacing:10px;'><tr><td>"),
h4(textOutput("gsaresTableText")),
HTML("</td><td>"),
uiOutput("gsaresTableText2"),
HTML("</td></tr></table>"),
DT::dataTableOutput('gsaresTable',height="100%"),
absolutePanel(id="controls", class="panel panel-default", fixed=FALSE,
draggable=FALSE, top=110, left=20, right="auto", bottom="auto",
width = "auto", height=70, style="border: 0px; box-shadow: 0px 0px; background-color: rgba(255, 255, 255, 0);",
downloadButton("download_gs_table", "Download table", class="btn btn-primary btn-xs"),
HTML("<span style='display:inline-block; width: 100px;'></span><b>Toggle columns:</b><span style='display:inline-block; width: 30px;'></span>"),
HTML('Gene count<label class="switch"><input type="checkbox" onclick="Shiny.onInputChange(\'toggle_genes\', Math.random())" checked><span class="slider round"></span></label>'),
HTML('Adjusted p-value<label class="switch"><input type="checkbox" onclick="Shiny.onInputChange(\'toggle_padj\', Math.random())" checked><span class="slider round"></span></label>'),
HTML('p-value<label class="switch"><input type="checkbox" onclick="Shiny.onInputChange(\'toggle_p\', Math.random())"><span class="slider round"></span></label>'),
HTML('Gene-set statistic<label class="switch"><input type="checkbox" onclick="Shiny.onInputChange(\'toggle_stats\', Math.random())"><span class="slider round"></span></label>')
)
))
),
tabPanel(title="Gene-set summary", value="tab_gssum",
div(id="loading_tab_gssum",
HTML("<br><br><center><h3>",c("Just hold on a sec","Please wait","Just a moment")[sample(1:3,1)],"</h3><h4>Loading your results...</h4></center>")
),
hidden(div(id="tab_gssum",
fluidRow(column(12,
HTML("<table style='border-collapse:separate; border-spacing:10px;'><tr><td>"),
h4(textOutput("text_selected_gs")),
HTML("</td><td>"),
actionLink("link_tab_gsares", "Select another gene-set"),
HTML("</td></tr></table>")
)),
fluidRow(column(5,
fluidRow(column(12,
box(title="Gene-set stats", status="primary", width="100%",
tableOutput('gsTable2')
),
box(title="Genes", status="primary", width="100%",
htmlOutput('gsNgenes'),
htmlOutput('link_view_gene'),
uiOutput("links_gsGenes")
),
box(title="Gene-set neighbors", status="primary", width="100%",
HTML("Number of overlapping genes:"),
uiOutput('gsNeighborsSlider'),
actionLink("filter_gs2", "View gene-sets in table"),
HTML("(also makes gene-sets available in network plot)"),
uiOutput('gsNeighbors')
)
)
)
),
column(7,
tabBox(width="100%",
#wellPanel(style="background-color: #ffffff; overflow-y:scroll; max-height: 1200px",
# tabsetPanel(id="tabset_2", type="tabs",
tabPanel(title="Histogram", value="tab_histogram",
HTML("<center><b>Histogram of all gene-level statistics,<br>"),
HTML("and indiviual values for genes in selected gene-set.</b></center>"),
plotOutput("gsHist", click=clickOpts(id="gsHist_click")),
htmlOutput("geneStatType"), # just needed so that output.geneStatType is set... hacky
conditionalPanel(condition="output.geneStatType == '<em></em>'", plotOutput("gsHist2", click=clickOpts(id="gsHist_click2")))
),
tabPanel(title="Boxplot", value="tab_boxplots",
HTML("<center><b>Boxplots of gene-level statistics</b></center>"),
plotOutput("gsBoxplots", click=clickOpts(id="gsBoxplots_click"))
#plotOutput("gsRunningSum")
# )
)
)
))
))
),
tabPanel(title="Gene table", value="tab_genetable",
div(id="loading_tab_genetable",
HTML("<br><br><center><h3>",c("Just hold on a sec","Please wait","Just a moment")[sample(1:3,1)],"</h3><h4>Loading your results...</h4></center>")
),
hidden(div(id="tab_genetable",
HTML("<table style='border-collapse:separate; border-spacing:10px;'><tr><td>"),
h4(textOutput("geneTableText")),
HTML("</td><td>"),
uiOutput("geneTableText2"),
HTML("</td></tr></table>"),
DT::dataTableOutput('geneTable', height="100%"),
absolutePanel(id="controls", class="panel panel-default", fixed=FALSE,
draggable=FALSE, top=110, left=20, right="auto", bottom="auto",
width = "auto", height=70, style="border: 0px; box-shadow: 0px 0px; background-color: rgba(255, 255, 255, 0);",
downloadButton("download_gene_table", "Download table", class="btn btn-primary btn-xs"),
HTML("<span style='display:inline-block; width: 100px;'></span>"),
HTML('<b>Truncate long: </b><label class="switch"><input type="checkbox" onclick="Shiny.onInputChange(\'truncate_gene_table\', Math.random())" checked><span class="slider round"></span></label>'),
HTML("<span style='display:inline-block; width: 5px;'></span>"),
HTML("(Hold pointer over a cell to see full content)")
)
))
),
tabPanel(title="Gene summary", value="tab_geneinfo",
div(id="loading_tab_geneinfo",
HTML("<br><br><center><h3>",c("Just hold on a sec","Please wait","Just a moment")[sample(1:3,1)],"</h3><h4>Loading your results...</h4></center>")
),
hidden(div(id="tab_geneinfo",
fluidRow(column(12,
HTML("<table style='border-collapse:separate; border-spacing:10px;'><tr><td>"),
h4(textOutput("text_selected_gene")),
HTML("</td><td>"),
actionLink("link_tab_genetable", "Select another gene"),
HTML("</td></tr></table>")
)),
fluidRow(column(6,
box(title="Gene stats", status="primary", width="100%",
htmlOutput("info_selected_gene")
),
box(title="Gene-set info", status="primary", width="100%",
htmlOutput("text_gene_gene_sets1"),
actionLink("filter_gs", "View gene-sets in table"),
HTML("(also makes gene-sets available in network plot)"),
htmlOutput("text_gene_gene_sets2")
)
),
column(6,
box(title="Additional annotation", status="primary", width="100%",
htmlOutput("anno_selected_gene")
)
))
))
),
tabPanel(title="Network plot", value="tab_nwplot",
div(id="loading_tab_nwplot",
HTML("<br><br><center><h3>",c("Just hold on a sec","Please wait","Just a moment")[sample(1:3,1)],"</h3><h4>Loading your results...</h4></center>")
),
hidden(div(id="tab_nwplot",
HTML("<br>"),
fluidRow(column(8,
box(title=NULL, status="primary", height="85vh", width="100%", solidHeader =TRUE,
visNetworkOutput("network", width = "100%", height = "80vh")
),
absolutePanel(id="nw_geneset_table", class="panel panel-default", fixed=FALSE,
draggable=FALSE, top=10, left=30, right="auto", bottom="auto",
width=200, height=80, style="border: 0px; box-shadow: 0px 0px; background-color: rgba(255, 255, 255, 0);",
actionLink("filter_gs3", "View gene-sets in table")
),
absolutePanel(id="nw_color_legend", class="panel panel-default", fixed=FALSE,
draggable=FALSE, top=10, left="auto", right=25, bottom="auto",
width=200, height=80, style="border: 0px; box-shadow: 0px 0px; background-color: rgba(255, 255, 255, 0);",
plotOutput("network_color_legend", width="200px", height="70px")
)
),
column(4,
#wellPanel(style="background-color: #ffffff",
box(title="Gene-set p-value to display", status="primary", collapsible=TRUE, width="100%",
#fluidRow(column(12,HTML("<h4>Gene-set p-value to display</h4>"))),
fluidRow(column(6,
selectInput("network_class", HTML("<b>P-value class</b>"),
choices = selectable_classes_network,
selected = selected_class_network)
),
column(6,
selectInput("network_adjusted", HTML("<b>P-value adjustment</b>"),
choices = list("Adjusted p-value" = TRUE,
"Non-adjusted p-value" = FALSE),
selected = TRUE)
)
)
),
#wellPanel(style="background-color: #ffffff",
box(title="Gene-set selection", status="primary", collapsible=TRUE, width="100%",
#fluidRow(column(12,HTML("<h4>Gene-set selection</h4>"))),
fluidRow(column(6,
selectInput("geneset_selection","Select gene-set by",
choices=list("Significance cutoff"="significance",
"Predefined list"="list"),
selected="significance")
),
column(6,
conditionalPanel('input.geneset_selection=="significance"',
numericInput("network_significance", "Significance cutoff", cutoff_network,
min=0, max=1, step=0.001)),
conditionalPanel('input.geneset_selection=="list"',
selectInput("network_genesetlist", label="Select gene-sets from list",
choices=setNames(as.list(names(genesets)),names(genesets))))
)
),
fluidRow(column(12,HTML("<b>Maximum allowed nodes</b>"),
numericInput("maxAllowedNodes", NULL, 50,
min=0, max=Inf, step=1, width="100px")
)
)
),
#wellPanel(style="background-color: #ffffff",
box(title="Network layout", status="primary", collapsible=TRUE, width="100%",
#fluidRow(column(12,HTML("<h4>Network layout</h4>"))),
fluidRow(column(8,
selectInput("layout", label=NULL,
choices=list("Default (visNetwork)"="visNetwork",
"Nicely (igraph)"="layout_nicely",
"Fruchterman-Reingold (igraph)"="layout_with_fr",
"Kamada-Kawai (igraph)"="layout_with_kk",
"Sugiyama (igraph)"="layout_with_sugiyama",
"Star (igraph)"="layout_as_star",
"Circle (igraph)"="layout_in_circle",
"Grid (igraph)"="layout_on_grid"
),
selected="visNetwork")
),
column(4,
conditionalPanel("input.layout == 'visNetwork' | input.layout == 'layout_nicely' | input.layout == 'layout_with_fr'",
actionButton("layout_seed",label="Generate new layout", class="btn btn-primary btn-xs")
)
)
),
fluidRow(column(12,
HTML('<b>Physics simulation: </b><label class="switch"><input type="checkbox" onclick="Shiny.onInputChange(\'physics\', Math.random())" checked><span class="slider round"></span></label>')
)
)
),
#wellPanel(style="background-color: #ffffff",
box(title="Node properties", status="primary", collapsible=TRUE, width="100%", collapsed=TRUE,
#fluidRow(column(12,HTML("<h4>Node properties</h4>"))),
fluidRow(column(12,
sliderInput("nodeSize", label="Size range", min=1, max=100, value=c(10,40), ticks=FALSE)
)
),
fluidRow(column(3,
selectInput("labelSize", label="Label size",
choices=list("Off"=0,
"8"=8,
"10"=10,
"14"=14,
"18"=18,
"22"=22,
"30"=30,
"40"=40),
selected=22)
),
column(9,HTML("<br>"),
checkboxInput("truncate_labels", label="Truncate long labels", FALSE)
)
)
),
#wellPanel(style="background-color: #ffffff",
box(title="Edge properties", status="primary", collapsible=TRUE, width="100%", collapsed=TRUE,
#fluidRow(column(12,HTML("<h4>Edge properties</h4>"))),
fluidRow(column(12,
sliderInput("edgeWidth", label="Width range", min=1, max=50, value=c(1,15), ticks=FALSE)
)
),
fluidRow(column(12,HTML("<b>Required node overlap to draw edge</b>"))),
fluidRow(column(3,
numericInput("edge_overlap", label=NULL, value=30, min=0, max=Inf)
),
column(9,
selectInput("genes_or_percent", label=NULL,
choices=list("genes"="genes",
"% of smallest gene-set in pair"="percent"),
selected="percent")
)
)
)
)
)
))
),
tabPanel(title="Heatmap", value="tab_heatmap",
HTML("<br><br>This feature is currently unavailable but will be added soon! For now, use the <tt>GSAheatmap</tt> funtion in R.")
)#,
#tabPanel(title="Help", value="tab_help",
# HTML("<br><br>This feature is currently unavailable but will be added soon! For now, use the <tt>GSAheatmap</tt> funtion in R.")
#)
#)
#)
#),
))),
# ===================================================================================
# server
server <- function(input, output, session) {
session$onSessionEnded(stopApp)
# Output values used as parameters:
output$geneStatType <- renderText(ifelse(gsares$geneStatType=="p-signed",'<em></em>','')) # super hacky...
# Initialize parameters / static objects:
gs_per_gene_list <- unstack(stack(gsares$gsc)[,2:1])
gsares_directions <- switch(as.numeric(length(gsares$directions)==1)+1, gsares$directions, gsares$geneLevelStats*NA)
colnames(gsares_directions) <- "directions"
genetable_all <- stack(lapply(gs_per_gene_list,length))[,2:1]
genetable_all <- merge(cbind(gsares$geneLevelStats, gsares_directions), genetable_all, by.x=0, by.y=1)
rownames(genetable_all) <- genetable_all[,1]
colnames(genetable_all) <- c("Gene ID","Gene-level statistic","Sign (FC direction)","In gene-sets")
if(!is.null(geneAnnot)) {
genetable_all <- merge(genetable_all, geneAnnot, by=1, all.x=TRUE)
colnames(genetable_all) <- c("Gene ID","Gene-level statistic","Sign (FC direction)","In gene-sets", colnames(geneAnnot)[-1])
rownames(genetable_all) <- genetable_all[,1]
}
if(all(is.na(genetable_all[,"Sign (FC direction)"]))) genetable_all <- genetable_all[,!colnames(genetable_all)%in%"Sign (FC direction)"]
gsatab_colnames <- c("Name", "Genes (tot)", "Stat (dist.dir)", "Stat (dist.dir.up)", "p (dist.dir.up)", "p adj (dist.dir.up)",
"Stat (dist.dir.dn)", "p (dist.dir.dn)", "p adj (dist.dir.dn)", "Stat (non-dir.)", "p (non-dir.)", "p adj (non-dir.)",
"Genes (up)", "Stat (mix.dir.up)", "p (mix.dir.up)", "p adj (mix.dir.up)", "Genes (down)",
"Stat (mix.dir.dn)", "p (mix.dir.dn)", "p adj (mix.dir.dn)")
gsatab_colnames <- gsatab_colnames[c(1,2,13,17,9,20,12,16,6,8,19,11,15,5,10,3,7,4,18,14)]
gsatab_colnames <- gsatab_colnames[gsatab_colnames%in%colnames(GSAsummaryTable(gsares))]
if(all(gsares$nGenesUp==0) & all(gsares$nGenesDn==0)) gsatab_colnames <- gsatab_colnames[!gsatab_colnames%in%c("Genes (up)","Genes (down)")]
# Initialize reactive values:
rval <- reactiveValues(sel_gs=names(gsares$gsc)[1],
sel_gene=gsares$gsc[[1]][1],
gs_table=GSAsummaryTable(gsares),
sel_gene_for_filtering=NULL,
sel_geneset_for_filtering=NULL,
red_gene="",
gene_table=genetable_all,
log_gs_plots=FALSE,
visible_columns=gsatab_colnames[!gsatab_colnames%in%c(grep("p \\(",gsatab_colnames, value=TRUE),grep("Stat",gsatab_colnames, value=TRUE))],
physics=TRUE,
colorLegendInfo=NULL,
nwGeneSets=NULL,
genesets=genesets,
maxNcharGenetable=TRUE)
# -----------------------------------------------------------------------------
#output$loggo <- renderImage({
# filename <- "loggo.png"
# list(src = filename,
# alt = "PIANO")
#}, deleteFile = FALSE)
# Run info --------------------------------------------------------------------
output$text_runinfo1 <- renderUI({
tmp <- gsares$info
info <- c(
paste("<b>Input:</b>",tmp$removedGSnoGenes + tmp$removedGSsizeLimit + tmp$nGeneSets,"gene-sets,",tmp$nGenesStatistics,"genes<br>"),
paste("- Removed",tmp$removedGSsizeLimit,"gene-sets not matching the size limits<br>"),
paste("- Removed",tmp$removedGenesGSC,"genes from GSC due to lack of matching gene-level statistics<br>"),
paste("- Removed",tmp$removedGSnoGenes,"gene-sets containing no genes after gene removal<br>"),
paste("- Out of the",tmp$nGenesStatistics,"genes,",tmp$nGenesGSC,"are associated with gene-sets<br>"),
paste("<b>Final gene/gene-set association:</b>",tmp$nGeneSets,"gene-sets,",tmp$nGenesGSC,"genes*")
)
HTML(info)
})
output$text_runinfo2 <- renderUI({
tmp <- gsares$info
info <- c(
paste("<b>Total run time:</b>",round(gsares$runtime[3]/60,2),"min<br>"),
paste("<b>GSA method:</b>",gsares$geneSetStat,"<br>"),
paste("<b>Gene-set statistic name:</b>",gsares$gsStatName,"<br>"),
paste("<b>Gene-set size limits:</b> min",paste(gsares$gsSizeLim,collapse=", max "),"genes<br>"),
paste("<b>Significance calculation:</b>",gsares$signifMethod,"<br>"),
paste("<b>Permutations:</b> ",gsares$nPerm,"*<br>",sep=""),
paste("<b>P-value adjustment:</b>",gsares$adjMethod)
)
HTML(info)
})
output$text_runinfo3 <- renderUI({
HTML("<em>*) In case premuted gene-level statistics are used for significance estimation, all input gene-level
statistics are used. Permutations are also used by the reporter features method to calculate gene-set statistics,
i.e. regardless of significance estimation method.</em>")
})
output$gsc_boxplot1 <- renderPlot({
par(mfcol=c(2,1))
layout(mat = matrix(c(1,2),2,1, byrow=TRUE), heights= c(3,2))
tmp <- unlist(lapply(gsares$gsc,length))
par(mar=c(0, 4.1, 1.1, 2.1))
h <- hist(tmp, n=50, xlim=c(0,max(tmp)), xaxt="n", xlab=NULL, main=NULL, col="forestgreen")
par(mar=c(5, 4.1, 0, 2.1))
boxplot(tmp, horizontal=TRUE, ylim=c(0,max(tmp)), col="forestgreen", axes=FALSE, xlab="Number of genes")
axis(1, las=2)
})
output$gsc_boxplot2 <- renderPlot({
layout(mat = matrix(c(1,2),2,1, byrow=TRUE), heights = c(3,2))
tmp <- unlist(lapply(gs_per_gene_list,length))
par(mar=c(0, 4.1, 1.1, 2.1))
h <- hist(tmp, n=50, xlim=c(0,max(tmp)), xaxt="n", xlab=NULL, main=NULL, col="mediumpurple2")
par(mar=c(5, 4.1, 0, 2.1))
boxplot(tmp, horizontal=TRUE, ylim=c(0,max(tmp)), col="mediumpurple2", axes=FALSE, xlab="Number of gene-sets")
axis(1, las=2)
})
# GSAres table ----------------------------------------------------------------
output$gsaresTableText <- renderText({
if(nrow(rval$gs_table)<length(gsares$gsc)) {
rval$geneset_filtering_text
} else {
"Showing all gene-sets"
}
})
output$gsaresTableText2 <- renderUI({
if(nrow(rval$gs_table)<length(gsares$gsc)) {
actionLink("filter_all_gs","(Show all gene-sets)")
}
})
observeEvent(input$filter_all_gs, {
rval$sel_gene_for_filtering <- NULL
rval$gs_table <- GSAsummaryTable(gsares)
})
# Toggle columns events:
observeEvent(input$toggle_genes, {
tmp <- grep("Genes",gsatab_colnames, value=TRUE)
if(all(tmp%in%rval$visible_columns)) {
rval$visible_columns <- rval$visible_columns[!rval$visible_columns %in% tmp]
} else {
rval$visible_columns <- c(rval$visible_columns,tmp)
}
})
observeEvent(input$toggle_padj, {
tmp <- grep("p adj",gsatab_colnames, value=TRUE)
if(all(tmp%in%rval$visible_columns)) {
rval$visible_columns <- rval$visible_columns[!rval$visible_columns %in% tmp]
} else {
rval$visible_columns <- c(rval$visible_columns,tmp)
}
})
observeEvent(input$toggle_p, {
tmp <- grep("p \\(",gsatab_colnames, value=TRUE)
if(all(tmp%in%rval$visible_columns)) {
rval$visible_columns <- rval$visible_columns[!rval$visible_columns %in% tmp]
} else {
rval$visible_columns <- c(rval$visible_columns,tmp)
}
})
observeEvent(input$toggle_stats, {
tmp <- grep("Stat",gsatab_colnames, value=TRUE)
if(all(tmp%in%rval$visible_columns)) {
rval$visible_columns <- rval$visible_columns[!rval$visible_columns %in% tmp]
} else {
rval$visible_columns <- c(rval$visible_columns,tmp)
}
})
output$gsaresTable <- DT::renderDataTable({tmp <- rval$gs_table[gsatab_colnames[gsatab_colnames%in%rval$visible_columns]]},
server=TRUE, escape=FALSE,
selection=list(mode='single', target='row'),
filter="none",
rownames=FALSE,
fillContainer=TRUE,
extensions=c("Scroller"),
options = list(initComplete=JS(
# this is to set color format of first row
"function(settings, json) {",
"$(this.api().table().header()).css({'background-color': '#E2F3FF', 'color': '#000'});",
"}"),
dom = 'frtip',
deferRender=TRUE,
scrollY="calc(100vh - 250px)",
scrollX=TRUE,
scroller=TRUE
))
observeEvent(input$gsaresTable_rows_selected, {
rval$sel_gs <- rval$gs_table$Name[input$gsaresTable_rows_selected]
rval$red_gene <- ""
updateNavbarPage(session,"navbarpage",selected="tab_gssum")
selectRows(dataTableProxy("gsaresTable", session), list())
})
output$download_gs_table <- downloadHandler(
filename = function() {
paste("gene-set_table", ".csv", sep = "")
},
content = function(file) {
write.csv(rval$gs_table[gsatab_colnames[gsatab_colnames%in%rval$visible_columns]], file, row.names=FALSE)
}
)
# Gene-set summary ------------------------------------------------------------
output$text_selected_gs <- renderText({
rval$sel_gs
})
observeEvent(input$link_tab_gsares, {
updateNavbarPage(session,"navbarpage",selected="tab_gsares")
})
# Tables with info:
output$gsTable2 <- renderTable({
tmp <- geneSetSummary(gsares,rval$sel_gs)
tmp <- tmp$stats
rownames(tmp) <- tmp[,1]
tmp <- rbind(
format(rev(c(tmp["p (dist.dir.dn)",2],tmp["p (mix.dir.dn)",2],tmp["p (non-dir)",2],tmp["p (mix.dir.up)",2],tmp["p (dist.dir.up)",2])), digits=3, scientific=TRUE),
format(rev(c(tmp["p adj (dist.dir.dn)",2],tmp["p adj (mix.dir.dn)",2],tmp["p adj (non-dir)",2],tmp["p adj (mix.dir.up)",2],tmp["p adj (dist.dir.up)",2])), digits=3, scientific=TRUE)
)
rownames(tmp) <- c("p-value","Adjusted p-value")
colnames(tmp) <- rev(c("Distinct directional (down)","Mixed directional (down)","Non-directional","Mixed directional (up)", "Distinct directional (up)"))
t(tmp)
}, rownames=TRUE,colnames=TRUE)
output$gsNgenes <- renderUI({
tmp <- geneSetSummary(gsares,rval$sel_gs)
tmp_tot <- tmp$stats[tmp$stats$Name=="Genes (tot)",2]
tmp_up <- tmp$stats[tmp$stats$Name=="Genes (up)",2]
tmp_dn <- tmp$stats[tmp$stats$Name=="Genes (dn)",2]
if(tmp_up>0) {
tmp_up <- paste("up:",tmp_up)
} else {
tmp_up <- NULL
}
if(tmp_dn>0) {
tmp_dn <- paste("down:",tmp_dn)
} else {
tmp_dn <- NULL
}
tmp <- ""
if(!is.null(tmp_up) | !is.null(tmp_dn)) tmp <- paste("(",paste(tmp_up, tmp_dn, collapse=", )"),")",sep="")
tmp <- paste("<b>The gene-set contains ",tmp_tot,
" genes </b>", tmp, "<br>",
sep=""
)
HTML(tmp)
})
# Genes in gene-set info:
output$link_view_gene <- renderUI({
if(rval$red_gene!="") {
list(
HTML(paste("Selected:",rval$red_gene)),
actionLink("view_gene","(view details)"),
HTML("<br><br>"),
actionLink("view_genes_table",paste("View genes in table"))
)
} else if(rval$red_gene=="") {
list(
HTML("<em><font color='#ff0000'>You can click genes below, or in the plots to the right...</font></em><br><br>"),
actionLink("view_genes_table",paste("View genes in table"))
)
}
})
observeEvent(input$view_gene, {
rval$sel_gene <- rval$red_gene
updateNavbarPage(session,"navbarpage",selected="tab_geneinfo")
})
observeEvent(input$view_genes_table, {
rval$gene_table <- genetable_all[genetable_all$`Gene ID` %in% names(geneSetSummary(gsares,rval$sel_gs)$geneLevelStats),]
rval$sel_geneset_for_filtering <- rval$sel_gs
updateNavbarPage(session,"navbarpage",selected="tab_genetable")
})
# Genes in gene-set list:
output$links_gsGenes <- renderUI({
tmp <- geneSetSummary(gsares,rval$sel_gs)$geneLevelStats
tmp <- sort(tmp)
tmp <- names(tmp)
tmp1 <- ifelse(tmp == rval$red_gene,"<b><font color='#ff0000'>","<font color='#000000'>")
tmp2 <- ifelse(tmp == rval$red_gene,"</font></b>","</font>")
HTML(paste(paste("<a href='#'"," onclick='Shiny.onInputChange(",'"links_gsGenes_click", "',tmp,'"',");'",">",tmp1,tmp,tmp2,"</a>",sep=""), collapse=", "))
})
observeEvent(input$links_gsGenes_click, {
rval$red_gene <- input$links_gsGenes_click
})
# Neighbor gene-sets:
output$gsNeighborsSlider <- renderUI({
tmp <- length(geneSetSummary(gsares,rval$sel_gs)$geneLevelStats)
sliderInput("nNeighborGenesets", NULL, 1, tmp, min(c(5,tmp)), round=TRUE, step=1, ticks=FALSE, width="300px")
})
output$gsNeighbors <- renderUI({
tmp <- names(geneSetSummary(gsares,rval$sel_gs)$geneLevelStats)
tmp <- setdiff(names(gsares$gsc)[unlist(lapply(gsares$gsc, function(x) sum(tmp%in%x)>=input$nNeighborGenesets))], rval$sel_gs)
HTML(paste("<b>",rval$sel_gs,"</b>,",sep=""),paste(paste("<a href='#'"," onclick='Shiny.onInputChange(",'"links_genesets_click", "',tmp,'"',");'","><font color='#000000'>",tmp,"</font></a>",sep=""),collapse=", "))
})
observeEvent(input$filter_gs2, { # action link in ui
tmp1 <- names(geneSetSummary(gsares,rval$sel_gs)$geneLevelStats)
tmp1 <- setdiff(names(gsares$gsc)[unlist(lapply(gsares$gsc, function(x) sum(tmp1%in%x)>=input$nNeighborGenesets))], rval$sel_gs)
tmp2 <- GSAsummaryTable(gsares)
rval$gs_table <- tmp2[tmp2$Name %in% c(tmp1,rval$sel_gs),]
rval$geneset_filtering_text <- paste("Gene-sets neighboring",rval$sel_gs)
rval$genesets <- setNames(append(rval$genesets,list(rval$gs_table$Name)),c(names(rval$genesets),rval$geneset_filtering_text))
if(any(names(rval$genesets) == "No available gene-sets")) {
rval$genesets <- rval$genesets[rval$genesets != "No available gene-sets"]
}
updateSelectInput(session, "network_genesetlist",
choices=setNames(names(rval$genesets),names(rval$genesets)))
updateNavbarPage(session,"navbarpage",selected="tab_gsares")
})
# Plots:
# Histogram:
output$gsHist <- renderPlot({
par(mar=c(5,10,1,5))
tmp2 <- gsares$geneLevelStats
if(gsares$geneStatType=="p-signed") tmp2 <- tmp2[gsares$directions>0]
hist(tmp2,100,col="white", xlab=paste("Gene-level statistics",ifelse(gsares$geneStatType=="p-signed"," (direction: up)",""),sep=""), main="")
tmp <- geneSetSummary(gsares,rval$sel_gs)
if(gsares$geneStatType=="p-signed") {
tmp <- tmp$geneLevelStats[tmp$directions>0]
} else {
tmp <- tmp$geneLevelStats
}
abline(v=tmp, lty=2)
hist(tmp2,100,col=ifelse(gsares$geneStatType=="p-signed","indianred2","grey"), add=TRUE)
# Highlight selected gene:
observeEvent(input$gsHist_click, {
rval$red_gene <- names(tmp)[which.min(abs(tmp - input$gsHist_click$x))]
})
abline(v=tmp[rval$red_gene], col="red", lwd=2)
})
output$gsHist2 <- renderPlot({
par(mar=c(5,10,1,5))
tmp2 <- gsares$geneLevelStats[gsares$directions<=0]
hist(tmp2,100,col="white", xlab="Gene-level statistics (direction: down)", main="")
tmp <- geneSetSummary(gsares,rval$sel_gs)
tmp <- tmp$geneLevelStats[tmp$directions<=0]
abline(v=tmp, lty=2)
hist(tmp2,100,col="skyblue2", add=TRUE)
# Highlight selected gene:
observeEvent(input$gsHist_click2, {
rval$red_gene <- names(tmp)[which.min(abs(tmp - input$gsHist_click2$x))]
})
abline(v=tmp[rval$red_gene], col="dodgerblue3", lwd=2)
})
# Boxplots:
output$gsBoxplots <- renderPlot({
par(mar=c(5,10,1,5))
tmp <- geneSetSummary(gsares,rval$sel_gs)
gls_gs <- tmp$geneLevelStats
gls_gs_up <- gls_gs[tmp$directions>0]
gls_gs_dn <- gls_gs[tmp$directions<=0]
gls_all <- gsares$geneLevelStats
gls_all_up <- gls_all[gsares$directions>0]
gls_all_dn <- gls_all[gsares$directions<=0]
if(gsares$geneStatType=="p-signed") {
bp <- boxplot(list(gls_all_dn, gls_all_up, gls_gs_dn, gls_gs_up),
horizontal=TRUE,
names=c(paste("All genes down (",length(gls_all_dn),")",sep=""),
paste("All genes up (",length(gls_all_up),")",sep=""),
"Gene-set genes (down)","Gene-set genes (up)"),
las=1,
col=c("skyblue2","indianred2","white","white"),
border=c("black","black","dodgerblue3","red"),
main="", xlab="Gene-level statistics",
outline=TRUE, outcol="white")
# Add outliers:
tmp <- cbind(bp$out,bp$group)
tmp <- tmp[tmp[,2] %in% 1:2,]
points(tmp)
# Add jitter:
set.seed(1)
y_dn <- jitter(rep(3,length(gls_gs_dn)), amount=0.3)
names(y_dn) <- names(gls_gs_dn)
points(x=gls_gs_dn, y=y_dn)
y_up <- jitter(rep(4,length(gls_gs_up)), amount=0.3)
names(y_up) <- names(gls_gs_up)
points(x=gls_gs_up, y=y_up)
} else {
bp <- boxplot(list(gls_all, gls_gs),
horizontal=TRUE, names=c(paste("All genes (",length(gls_all),")",sep=""),"Genes in gene-set"), las=1,
col=c("grey","white"),
main="", xlab="Gene-level statistics",
outline=TRUE, outcol="white")
# Add outliers:
tmp <- cbind(bp$out,bp$group)
tmp <- tmp[tmp[,2] == 1,]
points(tmp)
# Add jitter:
set.seed(1)
y <- jitter(rep(2,length(gls_gs)), amount=0.3)
names(y) <- names(gls_gs)
points(x=gls_gs, y=y)
}
# Highlight selected point:
if(gsares$geneStatType=="p-signed") {
x <- c(gls_gs_up, gls_gs_dn)
y <- c(y_up, y_dn)
} else {
x <- gls_gs
}
observeEvent(input$gsBoxplots_click, {
rval$red_gene <- names(y)[which.min(as.matrix(dist(rbind(input$gsBoxplots_click[c("x","y")],cbind(x,y))))[-1,1])]
})
points(x=x[rval$red_gene], y=y[rval$red_gene], pch=16, cex=2, col=ifelse(rval$red_gene%in%names(gls_gs_up),"red","dodgerblue3"))
})
# Running sum plot:
#output$gsRunningSum <- renderPlot({
# par(mar=c(3,10,4.1,5))
# plotRunningSum(gsares, rval$sel_gs, gseaParam=1)
#})
# Gene table ----------------------------------------------------------
output$geneTableText <- renderText({
if(nrow(rval$gene_table) < nrow(genetable_all)) {
paste("Genes in ", rval$sel_geneset_for_filtering)
} else {
"Showing all genes in GSC"
}
})
output$geneTableText2 <- renderUI({
if(nrow(rval$gene_table) < nrow(genetable_all)) {
actionLink("filter_all_genes","(Show all genes)")
}
})
observeEvent(input$filter_all_genes, {
rval$sel_geneset_for_filtering <- NULL
rval$gene_table <- genetable_all
})
output$geneTable <- DT::renderDataTable({apply(cbind(rank(rval$gene_table$`Gene-level statistic`),rval$gene_table),2,function(x) {
if(rval$maxNcharGenetable) {
tmp <- 50
} else {
tmp <- 10000
}
paste("<div title='",ifelse(is.na(x),"",x),
"' class='DT_genetable_cell'><p>",
ifelse(is.na(x),"",substr(x,1,tmp)),
ifelse(is.na(x),"",ifelse(nchar(x)>tmp,"...","")),
"</div>",sep="")
}
)
},
server=TRUE, escape=FALSE,
selection=list(mode='single', target='row'),
filter="none",
rownames=FALSE,
extensions=c("Scroller"),#,"FixedColumns"),
fillContainer=TRUE,
options = list(initComplete=JS(
# this is to set color format of first row
"function(settings, json) {",
"$(this.api().table().header()).css({'background-color': '#E2F3FF', 'color': '#000'});",
"}"),
dom = 'frtip',
deferRender=TRUE,
scrollY="calc(100vh - 250px)",
scrollX=TRUE,
scroller=TRUE,
columnDefs=list(list(orderData=0, targets=2),
list(visible=FALSE, targets=0))
#fixedColumns=list(leftColumns=1))
)
)
observeEvent(input$geneTable_rows_selected, {
rval$sel_gene <- rval$gene_table$`Gene ID`[input$geneTable_rows_selected]
rval$red_gene <- ""
updateNavbarPage(session,"navbarpage",selected="tab_geneinfo")
selectRows(dataTableProxy("geneTable", session), list())
})
observeEvent(input$truncate_gene_table, {
rval$maxNcharGenetable <- ifelse(rval$maxNcharGenetable,FALSE,TRUE)
})
output$download_gene_table <- downloadHandler(
filename = function() {
paste("gene_table", ".csv", sep = "")
},
content = function(file) {
write.csv(rval$gene_table, file, row.names=FALSE)
}
)
# Gene summary --------------------------------------------------------
observeEvent(input$link_tab_genetable, { # action link in ui
updateNavbarPage(session,"navbarpage",selected="tab_genetable")
})
output$text_selected_gene <- renderText({
rval$sel_gene
})
output$info_selected_gene <- renderUI({
HTML(paste("<b>Gene-level statistic:</b>",gsares$geneLevelStats[rval$sel_gene,],"<br>",
"<b>Direction:</b>",ifelse(is.na(gsares_directions[rval$sel_gene,]),"NA",ifelse(gsares_directions[rval$sel_gene,]>0,"Up","Down")))
)
})
output$anno_selected_gene <- renderUI({
HTML(paste(ifelse(ncol(genetable_all)>4,paste("<b>",colnames(genetable_all)[-c(1,2,3,4)], ":</b>",t(genetable_all[rval$sel_gene,-c(1,2,3,4)]), collapse="<br>"),""))
)
})
output$text_gene_gene_sets1 <- renderUI({HTML(paste("<b>The gene is present in",genetable_all[rval$sel_gene,"In gene-sets"],"gene-sets:</b>"))})
output$text_gene_gene_sets2 <- renderUI({
tmp <- gs_per_gene_list[[rval$sel_gene]]
HTML(paste(paste("<a href='#'"," onclick='Shiny.onInputChange(",'"links_genesets_click", "',tmp,'"',");'","><font color='#000000'>",tmp,"</font></a>",sep=""),collapse=", "))
})
observeEvent(input$filter_gs, { # action link in ui
tmp <- GSAsummaryTable(gsares)
rval$sel_gene_for_filtering <- rval$sel_gene
rval$geneset_filtering_text <- paste("Gene-sets containing", rval$sel_gene_for_filtering)
rval$gs_table <- tmp[tmp$Name %in% gs_per_gene_list[[rval$sel_gene]],]
rval$genesets <- setNames(append(rval$genesets,list(rval$gs_table$Name)),c(names(rval$genesets),rval$geneset_filtering_text))
if(any(names(rval$genesets) == "No available gene-sets")) {
rval$genesets <- rval$genesets[rval$genesets != "No available gene-sets"]
}
updateSelectInput(session, "network_genesetlist",
choices=setNames(names(rval$genesets),names(rval$genesets)))
updateNavbarPage(session,"navbarpage",selected="tab_gsares")
})
observeEvent(input$links_genesets_click, {
rval$sel_gs <- input$links_genesets_click
rval$red_gene <- ""
selectRows(dataTableProxy("gsaresTable", session), list())
updateNavbarPage(session,"navbarpage",selected="tab_gssum")
})
# Network plot --------------------------------------------------------------------
output$network <- renderVisNetwork({
if(input$geneset_selection=="significance") {
network_significance <- input$network_significance
network_genesetlist <- NULL
} else if(input$geneset_selection=="list") {
network_significance <- 1
network_genesetlist <- rval$genesets[[input$network_genesetlist]]
}
nwPlot <- try(suppressWarnings(networkPlot2(gsares,
class=unlist(strsplit(input$network_class,"_"))[1],
direction=unlist(strsplit(input$network_class,"_"))[2],
adjusted=as.logical(input$network_adjusted),
significance=network_significance,
geneSets=network_genesetlist,
nodeSize=input$nodeSize,
labelSize=input$labelSize,
ncharLabel=ifelse(input$truncate_labels,10,Inf),
lay=input$layout,
physics=rval$physics,
seed=input$layout_seed,
edgeWidth=input$edgeWidth,
overlap=switch(input$genes_or_percent, genes=input$edge_overlap, percent=input$edge_overlap/100),
maxAllowedNodes=input$maxAllowedNodes,
shiny=TRUE,
main=NULL,
submain=NULL)), silent=TRUE)
if(is(nwPlot, "try-error")) {
nw_notification_text <- gsub(".*: (.*)","\\1",nwPlot[1])
if(grepl("less than two gene sets were selected, can not plot",nwPlot[1])) {
nw_notification_text <- "For the given parameters, less than two gene sets were selected. Try adjusting the significance cutoff."
} else if(grepl("the selected parameters results in a network with more than",nwPlot[1])) {
nw_notification_text <- paste("The selected parameters results in a network with more than",input$maxAllowedNodes,
"nodes (gene-sets). Drawing large networks requires more memory, if you want to continue, increase the value of 'Maximum allowed nodes'",
"or adjust the parameters to generate a smaller network, e.g. by decreasing the 'Significance cutoff'.",
"Tip: Turn off the 'Physics simulation' for faster drawing of large networks.")
} else if(grepl("argument geneSets not matching gene-set names in argument gsaRes",nwPlot[1])) {
nw_notification_text <- "No gene-set lists available. Or all available lists contain incorrect gene-set names."
}
showNotification(nw_notification_text,
id="nw_notification",
duration=NULL,
closeButton=TRUE,
type="error")
rval$colorLegendInfo <- NULL # to fail (= hide) the colorlegend plot
cat() # needed to avoid visNetwork error print in console
} else {
removeNotification("nw_notification")
rval$colorLegendInfo <- nwPlot$colorLegendInfo
rval$nwGeneSets <- nwPlot$x$nodes$geneSetNames
suppressWarnings(nwPlot %>% visExport(type="png", name="gene-set-network",
style="color: #ffffff; background-color: #3F8CBA; border-color: #2780e3; font-size: 13px;"))
}
})
observeEvent(input$navbarpage, {
if(input$navbarpage != "tab_nwplot")
removeNotification("nw_notification")
})
observeEvent(input$physics, {
rval$physics <- ifelse(rval$physics,FALSE,TRUE)
})
output$network_color_legend <- renderPlot({
plotColorLegend <- function() {
par(mar=c(3.5,0,0,0), oma=c(0,0,0,0))
plot(1,1,col="white",cex=0, bty="n", ylab="", xlab="", yaxt="n", ylim=c(0,1), xlim=rval$colorLegendInfo$range)
mtext("-log10(p)", side=1, line=2)
xleft <- seq(from=rval$colorLegendInfo$range[1], to=rval$colorLegendInfo$range[2], length.out=length(rval$colorLegendInfo$colors))
xright <- xleft + abs(xleft[1]-xleft[2])
rect(xleft,0,xright,1, col=rval$colorLegendInfo$colors, border=NA)
}
tmp <- try(plotColorLegend(), silent=TRUE)
if(is(tmp[1], "try-error")) plot(1,1,col="white",cex=0, bty="n", ylab="", xlab="", axes=FALSE)
})
observeEvent(input$filter_gs3, { # action link in ui
tmp <- GSAsummaryTable(gsares)
rval$geneset_filtering_text <- paste("Gene-sets in the network plot")
rval$gs_table <- tmp[tmp$Name %in% rval$nwGeneSets,]
updateNavbarPage(session,"navbarpage",selected="tab_gsares")
})
# Heatmap -------------------------------------------------------------------------
#output$heatmap <- renderPlot({
# GSAheatmap(gsares, ncharLabel=400, cex=2)
#})
hide("loading_tab_gsainfo")
showElement("tab_gsainfo")
hide("loading_tab_gsares")
showElement("tab_gsares")
hide("loading_tab_gssum")
showElement("tab_gssum")
hide("loading_tab_genetable")
showElement("tab_genetable")
hide("loading_tab_geneinfo")
showElement("tab_geneinfo")
hide("loading_tab_nwplot")
showElement("tab_nwplot")
}
)
# launch app
if(!browser) browser <- getOption("shiny.launch.browser", interactive())
runApp(app, launch.browser=browser)
}
Try the piano package in your browser
Any scripts or data that you put into this service are public.
piano documentation built on Nov. 8, 2020, 6:27 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.
Defines functions exploreGSAres
Documented in exploreGSAres
#' Explore GSA results
#'
#' Explore GSA results interactively in a web browser using \code{shiny}.
#'
#' Additional gene-level information, e.g. alternative names or description,
#' can be supplied via the \code{geneAnnot} argument. This information will
#' show up in the gene table and the gene summary tabs.
#'
#' @param gsaRes an object of class \code{GSAres}, as returned from
#' \code{runGSA()} or an object returned from \code{runGSAhyper()}.
#' @param browser a logical, whether or not to open the Shiny app in a browser
#' window. Set to \code{FALSE} to open an interactive window directly in
#' RStudio.
#' @param geneAnnot a \code{data.frame}, containing gene annotation. The first
#' column should be gene IDs matching those in \code{gsares}.
#' @param genesets a character vector or list (named or un-named) of character vectors
#' containing subsets of gene-set names that can be selected and displayed in the
#' network plot.
#' @return Does not return any object.
#' @author Leif Varemo \email{piano.rpkg@@gmail.com}
#' @seealso \pkg{\link{piano}}, \code{\link{runGSA}}, \code{\link{GSAheatmap}}, \code{\link{networkPlot2}}
#' @examples
#'
#' # Load example input data to GSA:
#' data("gsa_input")
#'
#' # Load gene set collection:
#' gsc <- loadGSC(gsa_input$gsc)
#'
#' # Run gene set analysis:
#' gsares <- runGSA(geneLevelStats=gsa_input$pvals , directions=gsa_input$directions,
#' gsc=gsc, nPerm=500)
#'
#' # Explore results:
#' \dontrun{exploreGSAres(gsares)}
#'
exploreGSAres <- function(gsaRes, browser=TRUE, geneAnnot=NULL, genesets) {
gsares <- gsaRes
# Argument checking:
if(!is(gsares, "GSAres")) stop("argument gsares is not of class GSAres")
if(!is.logical(browser)) stop("argument browser is not a logical")
if(!is.null(geneAnnot)) {
if(sum(duplicated(geneAnnot[,1]))>0) stop("geneAnnot may not contain duplicated gene IDs")
if(sum(geneAnnot[,1]%in%rownames(gsares$geneLevelStats)) == 0) stop("no overlap between genes in geneAnnot and gsares")
}
if(missing(genesets)) genesets <- list("No available gene-sets" = "No available gene-sets")
if(is(genesets, "list")) {
if(unique(unlist(lapply(genesets, class)))[1] != "character" | length(unique(unlist(lapply(genesets, class))))>1) stop("genesets has to be a character vector or a list of character vectors")
} else {
if(!is(genesets, "character")) stop("genesets has to be a character vector or a list of character vectors")
genesets <- list(genesets)
}
if(is.null(names(genesets))) names(genesets) <- paste("Gene-set list", seq(from=1, to=length(genesets)))
if(any(names(genesets) == "")) names(genesets)[names(genesets)==""] <- paste("Gene-set list", seq(from=1, to=sum(names(genesets)=="")))
# Check packages now, otherwise delayed error during app browsing, if missing:
if(!"shiny"%in%installed.packages()[,"Package"]) stop("missing package shiny")
if(!"shinyjs"%in%installed.packages()[,"Package"]) stop("missing package shinyjs")
if(!"DT"%in%installed.packages()[,"Package"]) stop("missing package DT")
# Set needed variables for network plot:
selectable_classes_network <- list()
if(!all(is.na(gsares$pDistinctDirUp)) | !all(is.na(gsares$pDistinctDirDn))) {
selectable_classes_network$"Distinct directional" <- "distinct_both"
}
if(!all(is.na(gsares$pNonDirectional))) {
selectable_classes_network$"Non directional" <- "non_NULL"
}
if(!all(is.na(gsares$pMixedDirUp)) | !all(is.na(gsares$pMixedDirDn))) {
selectable_classes_network$"Mixed directional up" <- "mixed_up"
selectable_classes_network$"Mixed directional down" <- "mixed_down"
}
selected_class_network <- selectable_classes_network[[1]]
if(selected_class_network == "distinct_both") {
cutoff_network <- signif(sort(c(gsares$pAdjDistinctDirUp,gsares$pAdjDistinctDirDn), decreasing=FALSE)[20],2)
} else if(selected_class_network == "non_NULL") {
cutoff_network <- signif(sort(gsares$pAdjNonDirectional, decreasing=FALSE)[20],2)
} else if(selected_class_network == "mixed_up") {
cutoff_network <- signif(sort(c(gsares$pAdjMixedDirUp), decreasing=FALSE)[20],2)
}
if(cutoff_network==0) cutoff_network <- 1e-6
# App object with ui and server
app <- shinyApp(
# ===================================================================================
# ui
# ui <- fluidPage(
ui <- dashboardPage(
dashboardHeader(disable=TRUE),
dashboardSidebar(disable=TRUE),
dashboardBody(navbarPage("Explore your GSA results",id="navbarpage",selected="tab_gsainfo", collapsible=TRUE,
# fluidRow(
# column(8,
# h2(HTML("Explore gene-set analysis results"))
# )#,
# #column(4,
# # div(imageOutput(system.file("shiny", "loggo.png", package="piano"), height="70px"), style="text-align: right;")
# #)
# ),
#HTML("<br>"),
#fluidRow(
#column(12,
#tabsetPanel(id="tabset1",
#type = "tabs",
tabPanel(title="Run info", value="tab_gsainfo",
useShinyjs(),
#includeCSS("css/cosmo.css"),
#includeCSS("css/toggle_switch.css"),
#includeCSS("css/style.css"),
includeCSS(system.file("shiny", "css", "cosmo.css", package="piano")),
includeCSS(system.file("shiny", "css", "toggle_switch.css", package="piano")),
includeCSS(system.file("shiny", "css", "style.css", package="piano")),
tags$head(
tags$style(
HTML(".shiny-notification {
position:fixed;
top: calc(25%);
left: calc(25%);
width: 300px;
}"
)
)
),
div(id="loading_tab_gsainfo",
HTML("<br><br><center><h3>",c("Just hold on a sec","Please wait","Just a moment")[sample(1:3,1)],"</h3><h4>Loading your results...</h4></center>")
),
hidden(div(id="tab_gsainfo",
HTML("<br>"),
column(5,
box(title="Gene/gene-set info", status="primary", width="100%",
htmlOutput("text_runinfo1")
),
box(title="Analysis details", status="primary", width="100%",
htmlOutput("text_runinfo2")
),
wellPanel(style="background-color: #E2F3FF;",
htmlOutput("text_runinfo3")
)
),
column(7,
tabBox(width="100%",
tabPanel("Gene-set size", value="gene_set_size_hist",
plotOutput("gsc_boxplot1", height="340px", width="100%"),
HTML("<div style='max-width: 600px'><b>Number of <font color='#009900'>genes</font> per <font color='#9966ff'>gene-set</font>.</b>
Gives you an idea about sizes of the gene-sets used in the analysis.
Are you looking at small specific gene-sets with few genes, or large
general gene-sets? Note that these stats are <em>after</em> filtering the
input GSC according to available gene-level statistics and the gsSizeLim parameter.
<br><br></div>")
),
tabPanel("Gene-set redundency", value="gene_set_redundency_hist",
plotOutput("gsc_boxplot2", height="340px", width="100%"),
HTML("<div style='max-width: 600px'><b>Number of <font color='#9966ff'>gene-sets</font> per <font color='#009900'>gene</font>.</b>
Gives you a general overview of how many gene-sets each gene belongs to.
Do you have many genes contributing to a lot of overlap between gene-sets,
or do you have very uniquely defined gene-sets where genes only appear in one
or a few gene-sets?</div>")
)
)
)
))),
tabPanel(title="Gene-set table", value="tab_gsares",
div(id="loading_tab_gsares",
HTML("<br><br><center><h3>",c("Just hold on a sec","Please wait","Just a moment")[sample(1:3,1)],"</h3><h4>Loading your results...</h4></center>")
),
hidden(div(id="tab_gsares",
HTML("<table style='border-collapse:separate; border-spacing:10px;'><tr><td>"),
h4(textOutput("gsaresTableText")),
HTML("</td><td>"),
uiOutput("gsaresTableText2"),
HTML("</td></tr></table>"),
DT::dataTableOutput('gsaresTable',height="100%"),
absolutePanel(id="controls", class="panel panel-default", fixed=FALSE,
draggable=FALSE, top=110, left=20, right="auto", bottom="auto",
width = "auto", height=70, style="border: 0px; box-shadow: 0px 0px; background-color: rgba(255, 255, 255, 0);",
downloadButton("download_gs_table", "Download table", class="btn btn-primary btn-xs"),
HTML("<span style='display:inline-block; width: 100px;'></span><b>Toggle columns:</b><span style='display:inline-block; width: 30px;'></span>"),
HTML('Gene count<label class="switch"><input type="checkbox" onclick="Shiny.onInputChange(\'toggle_genes\', Math.random())" checked><span class="slider round"></span></label>'),
HTML('Adjusted p-value<label class="switch"><input type="checkbox" onclick="Shiny.onInputChange(\'toggle_padj\', Math.random())" checked><span class="slider round"></span></label>'),
HTML('p-value<label class="switch"><input type="checkbox" onclick="Shiny.onInputChange(\'toggle_p\', Math.random())"><span class="slider round"></span></label>'),
HTML('Gene-set statistic<label class="switch"><input type="checkbox" onclick="Shiny.onInputChange(\'toggle_stats\', Math.random())"><span class="slider round"></span></label>')
)
))
),
tabPanel(title="Gene-set summary", value="tab_gssum",
div(id="loading_tab_gssum",
HTML("<br><br><center><h3>",c("Just hold on a sec","Please wait","Just a moment")[sample(1:3,1)],"</h3><h4>Loading your results...</h4></center>")
),
hidden(div(id="tab_gssum",
fluidRow(column(12,
HTML("<table style='border-collapse:separate; border-spacing:10px;'><tr><td>"),
h4(textOutput("text_selected_gs")),
HTML("</td><td>"),
actionLink("link_tab_gsares", "Select another gene-set"),
HTML("</td></tr></table>")
)),
fluidRow(column(5,
fluidRow(column(12,
box(title="Gene-set stats", status="primary", width="100%",
tableOutput('gsTable2')
),
box(title="Genes", status="primary", width="100%",
htmlOutput('gsNgenes'),
htmlOutput('link_view_gene'),
uiOutput("links_gsGenes")
),
box(title="Gene-set neighbors", status="primary", width="100%",
HTML("Number of overlapping genes:"),
uiOutput('gsNeighborsSlider'),
actionLink("filter_gs2", "View gene-sets in table"),
HTML("(also makes gene-sets available in network plot)"),
uiOutput('gsNeighbors')
)
)
)
),
column(7,
tabBox(width="100%",
#wellPanel(style="background-color: #ffffff; overflow-y:scroll; max-height: 1200px",
# tabsetPanel(id="tabset_2", type="tabs",
tabPanel(title="Histogram", value="tab_histogram",
HTML("<center><b>Histogram of all gene-level statistics,<br>"),
HTML("and indiviual values for genes in selected gene-set.</b></center>"),
plotOutput("gsHist", click=clickOpts(id="gsHist_click")),
htmlOutput("geneStatType"), # just needed so that output.geneStatType is set... hacky
conditionalPanel(condition="output.geneStatType == '<em></em>'", plotOutput("gsHist2", click=clickOpts(id="gsHist_click2")))
),
tabPanel(title="Boxplot", value="tab_boxplots",
HTML("<center><b>Boxplots of gene-level statistics</b></center>"),
plotOutput("gsBoxplots", click=clickOpts(id="gsBoxplots_click"))
#plotOutput("gsRunningSum")
# )
)
)
))
))
),
tabPanel(title="Gene table", value="tab_genetable",
div(id="loading_tab_genetable",
HTML("<br><br><center><h3>",c("Just hold on a sec","Please wait","Just a moment")[sample(1:3,1)],"</h3><h4>Loading your results...</h4></center>")
),
hidden(div(id="tab_genetable",
HTML("<table style='border-collapse:separate; border-spacing:10px;'><tr><td>"),
h4(textOutput("geneTableText")),
HTML("</td><td>"),
uiOutput("geneTableText2"),
HTML("</td></tr></table>"),
DT::dataTableOutput('geneTable', height="100%"),
absolutePanel(id="controls", class="panel panel-default", fixed=FALSE,
draggable=FALSE, top=110, left=20, right="auto", bottom="auto",
width = "auto", height=70, style="border: 0px; box-shadow: 0px 0px; background-color: rgba(255, 255, 255, 0);",
downloadButton("download_gene_table", "Download table", class="btn btn-primary btn-xs"),
HTML("<span style='display:inline-block; width: 100px;'></span>"),
HTML('<b>Truncate long: </b><label class="switch"><input type="checkbox" onclick="Shiny.onInputChange(\'truncate_gene_table\', Math.random())" checked><span class="slider round"></span></label>'),
HTML("<span style='display:inline-block; width: 5px;'></span>"),
HTML("(Hold pointer over a cell to see full content)")
)
))
),
tabPanel(title="Gene summary", value="tab_geneinfo",
div(id="loading_tab_geneinfo",
HTML("<br><br><center><h3>",c("Just hold on a sec","Please wait","Just a moment")[sample(1:3,1)],"</h3><h4>Loading your results...</h4></center>")
),
hidden(div(id="tab_geneinfo",
fluidRow(column(12,
HTML("<table style='border-collapse:separate; border-spacing:10px;'><tr><td>"),
h4(textOutput("text_selected_gene")),
HTML("</td><td>"),
actionLink("link_tab_genetable", "Select another gene"),
HTML("</td></tr></table>")
)),
fluidRow(column(6,
box(title="Gene stats", status="primary", width="100%",
htmlOutput("info_selected_gene")
),
box(title="Gene-set info", status="primary", width="100%",
htmlOutput("text_gene_gene_sets1"),
actionLink("filter_gs", "View gene-sets in table"),
HTML("(also makes gene-sets available in network plot)"),
htmlOutput("text_gene_gene_sets2")
)
),
column(6,
box(title="Additional annotation", status="primary", width="100%",
htmlOutput("anno_selected_gene")
)
))
))
),
tabPanel(title="Network plot", value="tab_nwplot",
div(id="loading_tab_nwplot",
HTML("<br><br><center><h3>",c("Just hold on a sec","Please wait","Just a moment")[sample(1:3,1)],"</h3><h4>Loading your results...</h4></center>")
),
hidden(div(id="tab_nwplot",
HTML("<br>"),
fluidRow(column(8,
box(title=NULL, status="primary", height="85vh", width="100%", solidHeader =TRUE,
visNetworkOutput("network", width = "100%", height = "80vh")
),
absolutePanel(id="nw_geneset_table", class="panel panel-default", fixed=FALSE,
draggable=FALSE, top=10, left=30, right="auto", bottom="auto",
width=200, height=80, style="border: 0px; box-shadow: 0px 0px; background-color: rgba(255, 255, 255, 0);",
actionLink("filter_gs3", "View gene-sets in table")
),
absolutePanel(id="nw_color_legend", class="panel panel-default", fixed=FALSE,
draggable=FALSE, top=10, left="auto", right=25, bottom="auto",
width=200, height=80, style="border: 0px; box-shadow: 0px 0px; background-color: rgba(255, 255, 255, 0);",
plotOutput("network_color_legend", width="200px", height="70px")
)
),
column(4,
#wellPanel(style="background-color: #ffffff",
box(title="Gene-set p-value to display", status="primary", collapsible=TRUE, width="100%",
#fluidRow(column(12,HTML("<h4>Gene-set p-value to display</h4>"))),
fluidRow(column(6,
selectInput("network_class", HTML("<b>P-value class</b>"),
choices = selectable_classes_network,
selected = selected_class_network)
),
column(6,
selectInput("network_adjusted", HTML("<b>P-value adjustment</b>"),
choices = list("Adjusted p-value" = TRUE,
"Non-adjusted p-value" = FALSE),
selected = TRUE)
)
)
),
#wellPanel(style="background-color: #ffffff",
box(title="Gene-set selection", status="primary", collapsible=TRUE, width="100%",
#fluidRow(column(12,HTML("<h4>Gene-set selection</h4>"))),
fluidRow(column(6,
selectInput("geneset_selection","Select gene-set by",
choices=list("Significance cutoff"="significance",
"Predefined list"="list"),
selected="significance")
),
column(6,
conditionalPanel('input.geneset_selection=="significance"',
numericInput("network_significance", "Significance cutoff", cutoff_network,
min=0, max=1, step=0.001)),
conditionalPanel('input.geneset_selection=="list"',
selectInput("network_genesetlist", label="Select gene-sets from list",
choices=setNames(as.list(names(genesets)),names(genesets))))
)
),
fluidRow(column(12,HTML("<b>Maximum allowed nodes</b>"),
numericInput("maxAllowedNodes", NULL, 50,
min=0, max=Inf, step=1, width="100px")
)
)
),
#wellPanel(style="background-color: #ffffff",
box(title="Network layout", status="primary", collapsible=TRUE, width="100%",
#fluidRow(column(12,HTML("<h4>Network layout</h4>"))),
fluidRow(column(8,
selectInput("layout", label=NULL,
choices=list("Default (visNetwork)"="visNetwork",
"Nicely (igraph)"="layout_nicely",
"Fruchterman-Reingold (igraph)"="layout_with_fr",
"Kamada-Kawai (igraph)"="layout_with_kk",
"Sugiyama (igraph)"="layout_with_sugiyama",
"Star (igraph)"="layout_as_star",
"Circle (igraph)"="layout_in_circle",
"Grid (igraph)"="layout_on_grid"
),
selected="visNetwork")
),
column(4,
conditionalPanel("input.layout == 'visNetwork' | input.layout == 'layout_nicely' | input.layout == 'layout_with_fr'",
actionButton("layout_seed",label="Generate new layout", class="btn btn-primary btn-xs")
)
)
),
fluidRow(column(12,
HTML('<b>Physics simulation: </b><label class="switch"><input type="checkbox" onclick="Shiny.onInputChange(\'physics\', Math.random())" checked><span class="slider round"></span></label>')
)
)
),
#wellPanel(style="background-color: #ffffff",
box(title="Node properties", status="primary", collapsible=TRUE, width="100%", collapsed=TRUE,
#fluidRow(column(12,HTML("<h4>Node properties</h4>"))),
fluidRow(column(12,
sliderInput("nodeSize", label="Size range", min=1, max=100, value=c(10,40), ticks=FALSE)
)
),
fluidRow(column(3,
selectInput("labelSize", label="Label size",
choices=list("Off"=0,
"8"=8,
"10"=10,
"14"=14,
"18"=18,
"22"=22,
"30"=30,
"40"=40),
selected=22)
),
column(9,HTML("<br>"),
checkboxInput("truncate_labels", label="Truncate long labels", FALSE)
)
)
),
#wellPanel(style="background-color: #ffffff",
box(title="Edge properties", status="primary", collapsible=TRUE, width="100%", collapsed=TRUE,
#fluidRow(column(12,HTML("<h4>Edge properties</h4>"))),
fluidRow(column(12,
sliderInput("edgeWidth", label="Width range", min=1, max=50, value=c(1,15), ticks=FALSE)
)
),
fluidRow(column(12,HTML("<b>Required node overlap to draw edge</b>"))),
fluidRow(column(3,
numericInput("edge_overlap", label=NULL, value=30, min=0, max=Inf)
),
column(9,
selectInput("genes_or_percent", label=NULL,
choices=list("genes"="genes",
"% of smallest gene-set in pair"="percent"),
selected="percent")
)
)
)
)
)
))
),
tabPanel(title="Heatmap", value="tab_heatmap",
HTML("<br><br>This feature is currently unavailable but will be added soon! For now, use the <tt>GSAheatmap</tt> funtion in R.")
)#,
#tabPanel(title="Help", value="tab_help",
# HTML("<br><br>This feature is currently unavailable but will be added soon! For now, use the <tt>GSAheatmap</tt> funtion in R.")
#)
#)
#)
#),
))),
# ===================================================================================
# server
server <- function(input, output, session) {
session$onSessionEnded(stopApp)
# Output values used as parameters:
output$geneStatType <- renderText(ifelse(gsares$geneStatType=="p-signed",'<em></em>','')) # super hacky...
# Initialize parameters / static objects:
gs_per_gene_list <- unstack(stack(gsares$gsc)[,2:1])
gsares_directions <- switch(as.numeric(length(gsares$directions)==1)+1, gsares$directions, gsares$geneLevelStats*NA)
colnames(gsares_directions) <- "directions"
genetable_all <- stack(lapply(gs_per_gene_list,length))[,2:1]
genetable_all <- merge(cbind(gsares$geneLevelStats, gsares_directions), genetable_all, by.x=0, by.y=1)
rownames(genetable_all) <- genetable_all[,1]
colnames(genetable_all) <- c("Gene ID","Gene-level statistic","Sign (FC direction)","In gene-sets")
if(!is.null(geneAnnot)) {
genetable_all <- merge(genetable_all, geneAnnot, by=1, all.x=TRUE)
colnames(genetable_all) <- c("Gene ID","Gene-level statistic","Sign (FC direction)","In gene-sets", colnames(geneAnnot)[-1])
rownames(genetable_all) <- genetable_all[,1]
}
if(all(is.na(genetable_all[,"Sign (FC direction)"]))) genetable_all <- genetable_all[,!colnames(genetable_all)%in%"Sign (FC direction)"]
gsatab_colnames <- c("Name", "Genes (tot)", "Stat (dist.dir)", "Stat (dist.dir.up)", "p (dist.dir.up)", "p adj (dist.dir.up)",
"Stat (dist.dir.dn)", "p (dist.dir.dn)", "p adj (dist.dir.dn)", "Stat (non-dir.)", "p (non-dir.)", "p adj (non-dir.)",
"Genes (up)", "Stat (mix.dir.up)", "p (mix.dir.up)", "p adj (mix.dir.up)", "Genes (down)",
"Stat (mix.dir.dn)", "p (mix.dir.dn)", "p adj (mix.dir.dn)")
gsatab_colnames <- gsatab_colnames[c(1,2,13,17,9,20,12,16,6,8,19,11,15,5,10,3,7,4,18,14)]
gsatab_colnames <- gsatab_colnames[gsatab_colnames%in%colnames(GSAsummaryTable(gsares))]
if(all(gsares$nGenesUp==0) & all(gsares$nGenesDn==0)) gsatab_colnames <- gsatab_colnames[!gsatab_colnames%in%c("Genes (up)","Genes (down)")]
# Initialize reactive values:
rval <- reactiveValues(sel_gs=names(gsares$gsc)[1],
sel_gene=gsares$gsc[[1]][1],
gs_table=GSAsummaryTable(gsares),
sel_gene_for_filtering=NULL,
sel_geneset_for_filtering=NULL,
red_gene="",
gene_table=genetable_all,
log_gs_plots=FALSE,
visible_columns=gsatab_colnames[!gsatab_colnames%in%c(grep("p \\(",gsatab_colnames, value=TRUE),grep("Stat",gsatab_colnames, value=TRUE))],
physics=TRUE,
colorLegendInfo=NULL,
nwGeneSets=NULL,
genesets=genesets,
maxNcharGenetable=TRUE)
# -----------------------------------------------------------------------------
#output$loggo <- renderImage({
# filename <- "loggo.png"
# list(src = filename,
# alt = "PIANO")
#}, deleteFile = FALSE)
# Run info --------------------------------------------------------------------
output$text_runinfo1 <- renderUI({
tmp <- gsares$info
info <- c(
paste("<b>Input:</b>",tmp$removedGSnoGenes + tmp$removedGSsizeLimit + tmp$nGeneSets,"gene-sets,",tmp$nGenesStatistics,"genes<br>"),
paste("- Removed",tmp$removedGSsizeLimit,"gene-sets not matching the size limits<br>"),
paste("- Removed",tmp$removedGenesGSC,"genes from GSC due to lack of matching gene-level statistics<br>"),
paste("- Removed",tmp$removedGSnoGenes,"gene-sets containing no genes after gene removal<br>"),
paste("- Out of the",tmp$nGenesStatistics,"genes,",tmp$nGenesGSC,"are associated with gene-sets<br>"),
paste("<b>Final gene/gene-set association:</b>",tmp$nGeneSets,"gene-sets,",tmp$nGenesGSC,"genes*")
)
HTML(info)
})
output$text_runinfo2 <- renderUI({
tmp <- gsares$info
info <- c(
paste("<b>Total run time:</b>",round(gsares$runtime[3]/60,2),"min<br>"),
paste("<b>GSA method:</b>",gsares$geneSetStat,"<br>"),
paste("<b>Gene-set statistic name:</b>",gsares$gsStatName,"<br>"),
paste("<b>Gene-set size limits:</b> min",paste(gsares$gsSizeLim,collapse=", max "),"genes<br>"),
paste("<b>Significance calculation:</b>",gsares$signifMethod,"<br>"),
paste("<b>Permutations:</b> ",gsares$nPerm,"*<br>",sep=""),
paste("<b>P-value adjustment:</b>",gsares$adjMethod)
)
HTML(info)
})
output$text_runinfo3 <- renderUI({
HTML("<em>*) In case premuted gene-level statistics are used for significance estimation, all input gene-level
statistics are used. Permutations are also used by the reporter features method to calculate gene-set statistics,
i.e. regardless of significance estimation method.</em>")
})
output$gsc_boxplot1 <- renderPlot({
par(mfcol=c(2,1))
layout(mat = matrix(c(1,2),2,1, byrow=TRUE), heights= c(3,2))
tmp <- unlist(lapply(gsares$gsc,length))
par(mar=c(0, 4.1, 1.1, 2.1))
h <- hist(tmp, n=50, xlim=c(0,max(tmp)), xaxt="n", xlab=NULL, main=NULL, col="forestgreen")
par(mar=c(5, 4.1, 0, 2.1))
boxplot(tmp, horizontal=TRUE, ylim=c(0,max(tmp)), col="forestgreen", axes=FALSE, xlab="Number of genes")
axis(1, las=2)
})
output$gsc_boxplot2 <- renderPlot({
layout(mat = matrix(c(1,2),2,1, byrow=TRUE), heights = c(3,2))
tmp <- unlist(lapply(gs_per_gene_list,length))
par(mar=c(0, 4.1, 1.1, 2.1))
h <- hist(tmp, n=50, xlim=c(0,max(tmp)), xaxt="n", xlab=NULL, main=NULL, col="mediumpurple2")
par(mar=c(5, 4.1, 0, 2.1))
boxplot(tmp, horizontal=TRUE, ylim=c(0,max(tmp)), col="mediumpurple2", axes=FALSE, xlab="Number of gene-sets")
axis(1, las=2)
})
# GSAres table ----------------------------------------------------------------
output$gsaresTableText <- renderText({
if(nrow(rval$gs_table)<length(gsares$gsc)) {
rval$geneset_filtering_text
} else {
"Showing all gene-sets"
}
})
output$gsaresTableText2 <- renderUI({
if(nrow(rval$gs_table)<length(gsares$gsc)) {
actionLink("filter_all_gs","(Show all gene-sets)")
}
})
observeEvent(input$filter_all_gs, {
rval$sel_gene_for_filtering <- NULL
rval$gs_table <- GSAsummaryTable(gsares)
})
# Toggle columns events:
observeEvent(input$toggle_genes, {
tmp <- grep("Genes",gsatab_colnames, value=TRUE)
if(all(tmp%in%rval$visible_columns)) {
rval$visible_columns <- rval$visible_columns[!rval$visible_columns %in% tmp]
} else {
rval$visible_columns <- c(rval$visible_columns,tmp)
}
})
observeEvent(input$toggle_padj, {
tmp <- grep("p adj",gsatab_colnames, value=TRUE)
if(all(tmp%in%rval$visible_columns)) {
rval$visible_columns <- rval$visible_columns[!rval$visible_columns %in% tmp]
} else {
rval$visible_columns <- c(rval$visible_columns,tmp)
}
})
observeEvent(input$toggle_p, {
tmp <- grep("p \\(",gsatab_colnames, value=TRUE)
if(all(tmp%in%rval$visible_columns)) {
rval$visible_columns <- rval$visible_columns[!rval$visible_columns %in% tmp]
} else {
rval$visible_columns <- c(rval$visible_columns,tmp)
}
})
observeEvent(input$toggle_stats, {
tmp <- grep("Stat",gsatab_colnames, value=TRUE)
if(all(tmp%in%rval$visible_columns)) {
rval$visible_columns <- rval$visible_columns[!rval$visible_columns %in% tmp]
} else {
rval$visible_columns <- c(rval$visible_columns,tmp)
}
})
output$gsaresTable <- DT::renderDataTable({tmp <- rval$gs_table[gsatab_colnames[gsatab_colnames%in%rval$visible_columns]]},
server=TRUE, escape=FALSE,
selection=list(mode='single', target='row'),
filter="none",
rownames=FALSE,
fillContainer=TRUE,
extensions=c("Scroller"),
options = list(initComplete=JS(
# this is to set color format of first row
"function(settings, json) {",
"$(this.api().table().header()).css({'background-color': '#E2F3FF', 'color': '#000'});",
"}"),
dom = 'frtip',
deferRender=TRUE,
scrollY="calc(100vh - 250px)",
scrollX=TRUE,
scroller=TRUE
))
observeEvent(input$gsaresTable_rows_selected, {
rval$sel_gs <- rval$gs_table$Name[input$gsaresTable_rows_selected]
rval$red_gene <- ""
updateNavbarPage(session,"navbarpage",selected="tab_gssum")
selectRows(dataTableProxy("gsaresTable", session), list())
})
output$download_gs_table <- downloadHandler(
filename = function() {
paste("gene-set_table", ".csv", sep = "")
},
content = function(file) {
write.csv(rval$gs_table[gsatab_colnames[gsatab_colnames%in%rval$visible_columns]], file, row.names=FALSE)
}
)
# Gene-set summary ------------------------------------------------------------
output$text_selected_gs <- renderText({
rval$sel_gs
})
observeEvent(input$link_tab_gsares, {
updateNavbarPage(session,"navbarpage",selected="tab_gsares")
})
# Tables with info:
output$gsTable2 <- renderTable({
tmp <- geneSetSummary(gsares,rval$sel_gs)
tmp <- tmp$stats
rownames(tmp) <- tmp[,1]
tmp <- rbind(
format(rev(c(tmp["p (dist.dir.dn)",2],tmp["p (mix.dir.dn)",2],tmp["p (non-dir)",2],tmp["p (mix.dir.up)",2],tmp["p (dist.dir.up)",2])), digits=3, scientific=TRUE),
format(rev(c(tmp["p adj (dist.dir.dn)",2],tmp["p adj (mix.dir.dn)",2],tmp["p adj (non-dir)",2],tmp["p adj (mix.dir.up)",2],tmp["p adj (dist.dir.up)",2])), digits=3, scientific=TRUE)
)
rownames(tmp) <- c("p-value","Adjusted p-value")
colnames(tmp) <- rev(c("Distinct directional (down)","Mixed directional (down)","Non-directional","Mixed directional (up)", "Distinct directional (up)"))
t(tmp)
}, rownames=TRUE,colnames=TRUE)
output$gsNgenes <- renderUI({
tmp <- geneSetSummary(gsares,rval$sel_gs)
tmp_tot <- tmp$stats[tmp$stats$Name=="Genes (tot)",2]
tmp_up <- tmp$stats[tmp$stats$Name=="Genes (up)",2]
tmp_dn <- tmp$stats[tmp$stats$Name=="Genes (dn)",2]
if(tmp_up>0) {
tmp_up <- paste("up:",tmp_up)
} else {
tmp_up <- NULL
}
if(tmp_dn>0) {
tmp_dn <- paste("down:",tmp_dn)
} else {
tmp_dn <- NULL
}
tmp <- ""
if(!is.null(tmp_up) | !is.null(tmp_dn)) tmp <- paste("(",paste(tmp_up, tmp_dn, collapse=", )"),")",sep="")
tmp <- paste("<b>The gene-set contains ",tmp_tot,
" genes </b>", tmp, "<br>",
sep=""
)
HTML(tmp)
})
# Genes in gene-set info:
output$link_view_gene <- renderUI({
if(rval$red_gene!="") {
list(
HTML(paste("Selected:",rval$red_gene)),
actionLink("view_gene","(view details)"),
HTML("<br><br>"),
actionLink("view_genes_table",paste("View genes in table"))
)
} else if(rval$red_gene=="") {
list(
HTML("<em><font color='#ff0000'>You can click genes below, or in the plots to the right...</font></em><br><br>"),
actionLink("view_genes_table",paste("View genes in table"))
)
}
})
observeEvent(input$view_gene, {
rval$sel_gene <- rval$red_gene
updateNavbarPage(session,"navbarpage",selected="tab_geneinfo")
})
observeEvent(input$view_genes_table, {
rval$gene_table <- genetable_all[genetable_all$`Gene ID` %in% names(geneSetSummary(gsares,rval$sel_gs)$geneLevelStats),]
rval$sel_geneset_for_filtering <- rval$sel_gs
updateNavbarPage(session,"navbarpage",selected="tab_genetable")
})
# Genes in gene-set list:
output$links_gsGenes <- renderUI({
tmp <- geneSetSummary(gsares,rval$sel_gs)$geneLevelStats
tmp <- sort(tmp)
tmp <- names(tmp)
tmp1 <- ifelse(tmp == rval$red_gene,"<b><font color='#ff0000'>","<font color='#000000'>")
tmp2 <- ifelse(tmp == rval$red_gene,"</font></b>","</font>")
HTML(paste(paste("<a href='#'"," onclick='Shiny.onInputChange(",'"links_gsGenes_click", "',tmp,'"',");'",">",tmp1,tmp,tmp2,"</a>",sep=""), collapse=", "))
})
observeEvent(input$links_gsGenes_click, {
rval$red_gene <- input$links_gsGenes_click
})
# Neighbor gene-sets:
output$gsNeighborsSlider <- renderUI({
tmp <- length(geneSetSummary(gsares,rval$sel_gs)$geneLevelStats)
sliderInput("nNeighborGenesets", NULL, 1, tmp, min(c(5,tmp)), round=TRUE, step=1, ticks=FALSE, width="300px")
})
output$gsNeighbors <- renderUI({
tmp <- names(geneSetSummary(gsares,rval$sel_gs)$geneLevelStats)
tmp <- setdiff(names(gsares$gsc)[unlist(lapply(gsares$gsc, function(x) sum(tmp%in%x)>=input$nNeighborGenesets))], rval$sel_gs)
HTML(paste("<b>",rval$sel_gs,"</b>,",sep=""),paste(paste("<a href='#'"," onclick='Shiny.onInputChange(",'"links_genesets_click", "',tmp,'"',");'","><font color='#000000'>",tmp,"</font></a>",sep=""),collapse=", "))
})
observeEvent(input$filter_gs2, { # action link in ui
tmp1 <- names(geneSetSummary(gsares,rval$sel_gs)$geneLevelStats)
tmp1 <- setdiff(names(gsares$gsc)[unlist(lapply(gsares$gsc, function(x) sum(tmp1%in%x)>=input$nNeighborGenesets))], rval$sel_gs)
tmp2 <- GSAsummaryTable(gsares)
rval$gs_table <- tmp2[tmp2$Name %in% c(tmp1,rval$sel_gs),]
rval$geneset_filtering_text <- paste("Gene-sets neighboring",rval$sel_gs)
rval$genesets <- setNames(append(rval$genesets,list(rval$gs_table$Name)),c(names(rval$genesets),rval$geneset_filtering_text))
if(any(names(rval$genesets) == "No available gene-sets")) {
rval$genesets <- rval$genesets[rval$genesets != "No available gene-sets"]
}
updateSelectInput(session, "network_genesetlist",
choices=setNames(names(rval$genesets),names(rval$genesets)))
updateNavbarPage(session,"navbarpage",selected="tab_gsares")
})
# Plots:
# Histogram:
output$gsHist <- renderPlot({
par(mar=c(5,10,1,5))
tmp2 <- gsares$geneLevelStats
if(gsares$geneStatType=="p-signed") tmp2 <- tmp2[gsares$directions>0]
hist(tmp2,100,col="white", xlab=paste("Gene-level statistics",ifelse(gsares$geneStatType=="p-signed"," (direction: up)",""),sep=""), main="")
tmp <- geneSetSummary(gsares,rval$sel_gs)
if(gsares$geneStatType=="p-signed") {
tmp <- tmp$geneLevelStats[tmp$directions>0]
} else {
tmp <- tmp$geneLevelStats
}
abline(v=tmp, lty=2)
hist(tmp2,100,col=ifelse(gsares$geneStatType=="p-signed","indianred2","grey"), add=TRUE)
# Highlight selected gene:
observeEvent(input$gsHist_click, {
rval$red_gene <- names(tmp)[which.min(abs(tmp - input$gsHist_click$x))]
})
abline(v=tmp[rval$red_gene], col="red", lwd=2)
})
output$gsHist2 <- renderPlot({
par(mar=c(5,10,1,5))
tmp2 <- gsares$geneLevelStats[gsares$directions<=0]
hist(tmp2,100,col="white", xlab="Gene-level statistics (direction: down)", main="")
tmp <- geneSetSummary(gsares,rval$sel_gs)
tmp <- tmp$geneLevelStats[tmp$directions<=0]
abline(v=tmp, lty=2)
hist(tmp2,100,col="skyblue2", add=TRUE)
# Highlight selected gene:
observeEvent(input$gsHist_click2, {
rval$red_gene <- names(tmp)[which.min(abs(tmp - input$gsHist_click2$x))]
})
abline(v=tmp[rval$red_gene], col="dodgerblue3", lwd=2)
})
# Boxplots:
output$gsBoxplots <- renderPlot({
par(mar=c(5,10,1,5))
tmp <- geneSetSummary(gsares,rval$sel_gs)
gls_gs <- tmp$geneLevelStats
gls_gs_up <- gls_gs[tmp$directions>0]
gls_gs_dn <- gls_gs[tmp$directions<=0]
gls_all <- gsares$geneLevelStats
gls_all_up <- gls_all[gsares$directions>0]
gls_all_dn <- gls_all[gsares$directions<=0]
if(gsares$geneStatType=="p-signed") {
bp <- boxplot(list(gls_all_dn, gls_all_up, gls_gs_dn, gls_gs_up),
horizontal=TRUE,
names=c(paste("All genes down (",length(gls_all_dn),")",sep=""),
paste("All genes up (",length(gls_all_up),")",sep=""),
"Gene-set genes (down)","Gene-set genes (up)"),
las=1,
col=c("skyblue2","indianred2","white","white"),
border=c("black","black","dodgerblue3","red"),
main="", xlab="Gene-level statistics",
outline=TRUE, outcol="white")
# Add outliers:
tmp <- cbind(bp$out,bp$group)
tmp <- tmp[tmp[,2] %in% 1:2,]
points(tmp)
# Add jitter:
set.seed(1)
y_dn <- jitter(rep(3,length(gls_gs_dn)), amount=0.3)
names(y_dn) <- names(gls_gs_dn)
points(x=gls_gs_dn, y=y_dn)
y_up <- jitter(rep(4,length(gls_gs_up)), amount=0.3)
names(y_up) <- names(gls_gs_up)
points(x=gls_gs_up, y=y_up)
} else {
bp <- boxplot(list(gls_all, gls_gs),
horizontal=TRUE, names=c(paste("All genes (",length(gls_all),")",sep=""),"Genes in gene-set"), las=1,
col=c("grey","white"),
main="", xlab="Gene-level statistics",
outline=TRUE, outcol="white")
# Add outliers:
tmp <- cbind(bp$out,bp$group)
tmp <- tmp[tmp[,2] == 1,]
points(tmp)
# Add jitter:
set.seed(1)
y <- jitter(rep(2,length(gls_gs)), amount=0.3)
names(y) <- names(gls_gs)
points(x=gls_gs, y=y)
}
# Highlight selected point:
if(gsares$geneStatType=="p-signed") {
x <- c(gls_gs_up, gls_gs_dn)
y <- c(y_up, y_dn)
} else {
x <- gls_gs
}
observeEvent(input$gsBoxplots_click, {
rval$red_gene <- names(y)[which.min(as.matrix(dist(rbind(input$gsBoxplots_click[c("x","y")],cbind(x,y))))[-1,1])]
})
points(x=x[rval$red_gene], y=y[rval$red_gene], pch=16, cex=2, col=ifelse(rval$red_gene%in%names(gls_gs_up),"red","dodgerblue3"))
})
# Running sum plot:
#output$gsRunningSum <- renderPlot({
# par(mar=c(3,10,4.1,5))
# plotRunningSum(gsares, rval$sel_gs, gseaParam=1)
#})
# Gene table ----------------------------------------------------------
output$geneTableText <- renderText({
if(nrow(rval$gene_table) < nrow(genetable_all)) {
paste("Genes in ", rval$sel_geneset_for_filtering)
} else {
"Showing all genes in GSC"
}
})
output$geneTableText2 <- renderUI({
if(nrow(rval$gene_table) < nrow(genetable_all)) {
actionLink("filter_all_genes","(Show all genes)")
}
})
observeEvent(input$filter_all_genes, {
rval$sel_geneset_for_filtering <- NULL
rval$gene_table <- genetable_all
})
output$geneTable <- DT::renderDataTable({apply(cbind(rank(rval$gene_table$`Gene-level statistic`),rval$gene_table),2,function(x) {
if(rval$maxNcharGenetable) {
tmp <- 50
} else {
tmp <- 10000
}
paste("<div title='",ifelse(is.na(x),"",x),
"' class='DT_genetable_cell'><p>",
ifelse(is.na(x),"",substr(x,1,tmp)),
ifelse(is.na(x),"",ifelse(nchar(x)>tmp,"...","")),
"</div>",sep="")
}
)
},
server=TRUE, escape=FALSE,
selection=list(mode='single', target='row'),
filter="none",
rownames=FALSE,
extensions=c("Scroller"),#,"FixedColumns"),
fillContainer=TRUE,
options = list(initComplete=JS(
# this is to set color format of first row
"function(settings, json) {",
"$(this.api().table().header()).css({'background-color': '#E2F3FF', 'color': '#000'});",
"}"),
dom = 'frtip',
deferRender=TRUE,
scrollY="calc(100vh - 250px)",
scrollX=TRUE,
scroller=TRUE,
columnDefs=list(list(orderData=0, targets=2),
list(visible=FALSE, targets=0))
#fixedColumns=list(leftColumns=1))
)
)
observeEvent(input$geneTable_rows_selected, {
rval$sel_gene <- rval$gene_table$`Gene ID`[input$geneTable_rows_selected]
rval$red_gene <- ""
updateNavbarPage(session,"navbarpage",selected="tab_geneinfo")
selectRows(dataTableProxy("geneTable", session), list())
})
observeEvent(input$truncate_gene_table, {
rval$maxNcharGenetable <- ifelse(rval$maxNcharGenetable,FALSE,TRUE)
})
output$download_gene_table <- downloadHandler(
filename = function() {
paste("gene_table", ".csv", sep = "")
},
content = function(file) {
write.csv(rval$gene_table, file, row.names=FALSE)
}
)
# Gene summary --------------------------------------------------------
observeEvent(input$link_tab_genetable, { # action link in ui
updateNavbarPage(session,"navbarpage",selected="tab_genetable")
})
output$text_selected_gene <- renderText({
rval$sel_gene
})
output$info_selected_gene <- renderUI({
HTML(paste("<b>Gene-level statistic:</b>",gsares$geneLevelStats[rval$sel_gene,],"<br>",
"<b>Direction:</b>",ifelse(is.na(gsares_directions[rval$sel_gene,]),"NA",ifelse(gsares_directions[rval$sel_gene,]>0,"Up","Down")))
)
})
output$anno_selected_gene <- renderUI({
HTML(paste(ifelse(ncol(genetable_all)>4,paste("<b>",colnames(genetable_all)[-c(1,2,3,4)], ":</b>",t(genetable_all[rval$sel_gene,-c(1,2,3,4)]), collapse="<br>"),""))
)
})
output$text_gene_gene_sets1 <- renderUI({HTML(paste("<b>The gene is present in",genetable_all[rval$sel_gene,"In gene-sets"],"gene-sets:</b>"))})
output$text_gene_gene_sets2 <- renderUI({
tmp <- gs_per_gene_list[[rval$sel_gene]]
HTML(paste(paste("<a href='#'"," onclick='Shiny.onInputChange(",'"links_genesets_click", "',tmp,'"',");'","><font color='#000000'>",tmp,"</font></a>",sep=""),collapse=", "))
})
observeEvent(input$filter_gs, { # action link in ui
tmp <- GSAsummaryTable(gsares)
rval$sel_gene_for_filtering <- rval$sel_gene
rval$geneset_filtering_text <- paste("Gene-sets containing", rval$sel_gene_for_filtering)
rval$gs_table <- tmp[tmp$Name %in% gs_per_gene_list[[rval$sel_gene]],]
rval$genesets <- setNames(append(rval$genesets,list(rval$gs_table$Name)),c(names(rval$genesets),rval$geneset_filtering_text))
if(any(names(rval$genesets) == "No available gene-sets")) {
rval$genesets <- rval$genesets[rval$genesets != "No available gene-sets"]
}
updateSelectInput(session, "network_genesetlist",
choices=setNames(names(rval$genesets),names(rval$genesets)))
updateNavbarPage(session,"navbarpage",selected="tab_gsares")
})
observeEvent(input$links_genesets_click, {
rval$sel_gs <- input$links_genesets_click
rval$red_gene <- ""
selectRows(dataTableProxy("gsaresTable", session), list())
updateNavbarPage(session,"navbarpage",selected="tab_gssum")
})
# Network plot --------------------------------------------------------------------
output$network <- renderVisNetwork({
if(input$geneset_selection=="significance") {
network_significance <- input$network_significance
network_genesetlist <- NULL
} else if(input$geneset_selection=="list") {
network_significance <- 1
network_genesetlist <- rval$genesets[[input$network_genesetlist]]
}
nwPlot <- try(suppressWarnings(networkPlot2(gsares,
class=unlist(strsplit(input$network_class,"_"))[1],
direction=unlist(strsplit(input$network_class,"_"))[2],
adjusted=as.logical(input$network_adjusted),
significance=network_significance,
geneSets=network_genesetlist,
nodeSize=input$nodeSize,
labelSize=input$labelSize,
ncharLabel=ifelse(input$truncate_labels,10,Inf),
lay=input$layout,
physics=rval$physics,
seed=input$layout_seed,
edgeWidth=input$edgeWidth,
overlap=switch(input$genes_or_percent, genes=input$edge_overlap, percent=input$edge_overlap/100),
maxAllowedNodes=input$maxAllowedNodes,
shiny=TRUE,
main=NULL,
submain=NULL)), silent=TRUE)
if(is(nwPlot, "try-error")) {
nw_notification_text <- gsub(".*: (.*)","\\1",nwPlot[1])
if(grepl("less than two gene sets were selected, can not plot",nwPlot[1])) {
nw_notification_text <- "For the given parameters, less than two gene sets were selected. Try adjusting the significance cutoff."
} else if(grepl("the selected parameters results in a network with more than",nwPlot[1])) {
nw_notification_text <- paste("The selected parameters results in a network with more than",input$maxAllowedNodes,
"nodes (gene-sets). Drawing large networks requires more memory, if you want to continue, increase the value of 'Maximum allowed nodes'",
"or adjust the parameters to generate a smaller network, e.g. by decreasing the 'Significance cutoff'.",
"Tip: Turn off the 'Physics simulation' for faster drawing of large networks.")
} else if(grepl("argument geneSets not matching gene-set names in argument gsaRes",nwPlot[1])) {
nw_notification_text <- "No gene-set lists available. Or all available lists contain incorrect gene-set names."
}
showNotification(nw_notification_text,
id="nw_notification",
duration=NULL,
closeButton=TRUE,
type="error")
rval$colorLegendInfo <- NULL # to fail (= hide) the colorlegend plot
cat() # needed to avoid visNetwork error print in console
} else {
removeNotification("nw_notification")
rval$colorLegendInfo <- nwPlot$colorLegendInfo
rval$nwGeneSets <- nwPlot$x$nodes$geneSetNames
suppressWarnings(nwPlot %>% visExport(type="png", name="gene-set-network",
style="color: #ffffff; background-color: #3F8CBA; border-color: #2780e3; font-size: 13px;"))
}
})
observeEvent(input$navbarpage, {
if(input$navbarpage != "tab_nwplot")
removeNotification("nw_notification")
})
observeEvent(input$physics, {
rval$physics <- ifelse(rval$physics,FALSE,TRUE)
})
output$network_color_legend <- renderPlot({
plotColorLegend <- function() {
par(mar=c(3.5,0,0,0), oma=c(0,0,0,0))
plot(1,1,col="white",cex=0, bty="n", ylab="", xlab="", yaxt="n", ylim=c(0,1), xlim=rval$colorLegendInfo$range)
mtext("-log10(p)", side=1, line=2)
xleft <- seq(from=rval$colorLegendInfo$range[1], to=rval$colorLegendInfo$range[2], length.out=length(rval$colorLegendInfo$colors))
xright <- xleft + abs(xleft[1]-xleft[2])
rect(xleft,0,xright,1, col=rval$colorLegendInfo$colors, border=NA)
}
tmp <- try(plotColorLegend(), silent=TRUE)
if(is(tmp[1], "try-error")) plot(1,1,col="white",cex=0, bty="n", ylab="", xlab="", axes=FALSE)
})
observeEvent(input$filter_gs3, { # action link in ui
tmp <- GSAsummaryTable(gsares)
rval$geneset_filtering_text <- paste("Gene-sets in the network plot")
rval$gs_table <- tmp[tmp$Name %in% rval$nwGeneSets,]
updateNavbarPage(session,"navbarpage",selected="tab_gsares")
})
# Heatmap -------------------------------------------------------------------------
#output$heatmap <- renderPlot({
# GSAheatmap(gsares, ncharLabel=400, cex=2)
#})
hide("loading_tab_gsainfo")
showElement("tab_gsainfo")
hide("loading_tab_gsares")
showElement("tab_gsares")
hide("loading_tab_gssum")
showElement("tab_gssum")
hide("loading_tab_genetable")
showElement("tab_genetable")
hide("loading_tab_geneinfo")
showElement("tab_geneinfo")
hide("loading_tab_nwplot")
showElement("tab_nwplot")
}
)
# launch app
if(!browser) browser <- getOption("shiny.launch.browser", interactive())
runApp(app, launch.browser=browser)
}
Try the piano package in your browser
Any scripts or data that you put into this service are public.
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.