#' GeneTonic
#'
#' GeneTonic, main function for the Shiny app
#'
#' @param dds A `DESeqDataSet` object, normally obtained after running your data
#' through the `DESeq2` framework.
#' @param res_de A `DESeqResults` object. As for the `dds` parameter, this is
#' also commonly used in the `DESeq2` framework.
#' @param res_enrich A `data.frame` object, storing the result of the functional
#' enrichment analysis. Required columns for enjoying the full functionality of
#' [GeneTonic()] include:
#' - a gene set identifier (e.g. GeneOntology id, `gs_id`) and its term description
#' (`gs_description`)
#' - a numeric value for the significance of the enrichment (`gs_pvalue`)
#' - a column named `gs_genes` containing a comma separated vector of the gene names
#' associated to the term, one for each term
#' - the number of genes in the geneset of interest detected as differentially
#' expressed (`gs_de_count`), or in the background set of genes (`gs_bg_count`)
#' See [shake_topGOtableResult()] or [shake_enrichResult()] for examples of such
#' formatting helpers
#' @param annotation_obj A `data.frame` object, containing two columns, `gene_id`
#' with a set of unambiguous identifiers (e.g. ENSEMBL ids) and `gene_name`,
#' containing e.g. HGNC-based gene symbols. This object can be constructed via
#' the `org.eg.XX.db` packages, e.g. with convenience functions such as
#' [pcaExplorer::get_annotation_orgdb()].
#' @param project_id A character string, which can be considered as an identifier
#' for the set/session, and will be e.g. used in the title of the report created
#' via [happy_hour()]
#'
#' @return A Shiny app object is returned, for interactive data exploration
#' @export
#'
#' @author Federico Marini
#'
#' @examples
#' library("macrophage")
#' library("DESeq2")
#' library("org.Hs.eg.db")
#' library("AnnotationDbi")
#'
#' # dds object
#' data("gse", package = "macrophage")
#' dds_macrophage <- DESeqDataSet(gse, design = ~line + condition)
#' rownames(dds_macrophage) <- substr(rownames(dds_macrophage), 1, 15)
#' dds_macrophage <- estimateSizeFactors(dds_macrophage)
#'
#' # annotation object
#' anno_df <- data.frame(
#' gene_id = rownames(dds_macrophage),
#' gene_name = mapIds(org.Hs.eg.db,
#' keys = rownames(dds_macrophage),
#' column = "SYMBOL",
#' keytype = "ENSEMBL"),
#' stringsAsFactors = FALSE,
#' row.names = rownames(dds_macrophage)
#' )
#'
#' # res object
#' data(res_de_macrophage, package = "GeneTonic")
#' res_de <- res_macrophage_IFNg_vs_naive
#'
#' # res_enrich object
#' data(res_enrich_macrophage, package = "GeneTonic")
#' res_enrich <- shake_topGOtableResult(topgoDE_macrophage_IFNg_vs_naive)
#' res_enrich <- get_aggrscores(res_enrich, res_de, anno_df)
#'
#' # now everything is in place to launch the app
#' if (interactive())
#' GeneTonic(dds = dds_macrophage,
#' res_de = res_de,
#' res_enrich = res_enrich,
#' annotation_obj = anno_df,
#' project_id = "myexample")
#'
GeneTonic <- function(dds,
res_de,
res_enrich,
annotation_obj,
project_id = "") {
# https://projects.lukehaas.me/css-loaders/
# or even think of https://cran.r-project.org/web/packages/shinycustomloader/README.html
oopt <- options(spinner.type = 6, spinner.color = .biocgreen)
# play nice with other previously chosen options
on.exit(options(oopt))
usage_mode <- "shiny_mode"
# checks on the objects provided
checkup_GeneTonic(dds,
res_de,
res_enrich,
annotation_obj)
# clean up the result object, e.g. removing the NAs in the relevant columns
res_de <- res_de[!is.na(res_de$log2FoldChange), ]
message("Removing ", sum(is.na(res_de$log2FoldChange)), " rows from the result object - logFC detected as NA")
# UI definition -----------------------------------------------------------
# dashpage definition -----------------------------------------------------
genetonic_ui <- bs4Dash::bs4DashPage(
# enable_preloader = TRUE,
title = "GeneTonic",
sidebar_collapsed = TRUE,
controlbar_collapsed = TRUE,
# navbar definition -------------------------------------------------------
navbar = bs4Dash::bs4DashNavbar(
skin = "dark",
controlbarIcon = "gears",
fixed = TRUE,
leftUi = tagList(
tags$code(tags$h3("GeneTonic")),
actionButton("bookmarker", label = "Bookmark", icon = icon("heart"),
style = "color: #ffffff; background-color: #ac0000; border-color: #ffffff", class = "ml-5")
),
rightUi = tagList(
shinyWidgets::dropdownButton(
inputId = "ddbtn_docs",
circle = FALSE,
status = "info",
icon = icon("book"),
width = "300px",
size = "xs",
right = TRUE,
tooltip = shinyWidgets::tooltipOptions(title = "More documentation"),
tags$h5("Documentation"),
actionButton(
inputId = "btn_docs_vignette",
icon = icon("book-open"),
label = "Open GeneTonic Vignette", style = .actionbutton_biocstyle,
onclick = ifelse(system.file("doc", "GeneTonic_manual.html", package = "GeneTonic") != "",
"",
"window.open('https://federicomarini.github.io/GeneTonic/articles/GeneTonic_manual.html', '_blank')")
# sprintf("window.open('http://bioconductor.org/packages/%s/bioc/vignettes/GeneTonic/inst/doc/GeneTonic_manual.html', '_blank')",
# ifelse(unlist(packageVersion("GeneTonic"))[2] %% 2L==0L, "release", "devel")
# )
# )
),
actionButton(
inputId = "btn_first_help",
icon = icon("question-circle"),
label = "First Help", style = .actionbutton_biocstyle
)
),
shinyWidgets::dropdownButton(
inputId = "ddbtn_info",
circle = FALSE,
status = "info",
icon = icon("info"),
width = "300px",
size = "xs",
right = TRUE,
tooltip = shinyWidgets::tooltipOptions(title = "More info!"),
tags$h5("Additional information"),
actionButton(
inputId = "btn_info_session",
icon = icon("info-circle"),
label = "About this session", style = .actionbutton_biocstyle
),
actionButton(
inputId = "btn_info_genetonic",
icon = icon("heart"),
label = "About GeneTonic", style = .actionbutton_biocstyle
)
)
)
),
# sidebar definition ------------------------------------------------------
sidebar = bs4Dash::bs4DashSidebar(
title = HTML("<small>GeneTonic</small>"),
src = "GeneTonic/GeneTonic.png",
skin = "dark",
status = "primary",
brandColor = NULL,
url = "https://bioconductor.org/packages/GeneTonic",
# src = "logos/online-learning.png",
elevation = 1,
opacity = 0.8,
bs4SidebarMenu(
id = "gt_tabs",
bs4SidebarMenuItem(
"Welcome!",
tabName = "tab_welcome",
icon = "home"
),
bs4SidebarMenuItem(
"Gene-Geneset",
tabName = "tab_ggs",
icon = "share-alt-square"
),
bs4SidebarMenuItem(
"Enrichment Map",
tabName = "tab_emap",
icon = "project-diagram" # hubspot? map?
),
bs4SidebarMenuItem(
"Overview",
tabName = "tab_overview",
icon = "eye"
),
bs4SidebarMenuItem(
"GSViz",
tabName = "tab_gsviz",
icon = "images"
),
bs4SidebarMenuItem(
"Bookmarks",
tabName = "tab_bookmarks",
icon = "bookmark"
)
)
),
# body definition ---------------------------------------------------------
body = bs4Dash::bs4DashBody(
rintrojs::introjsUI(),
## Define output size and style of error messages
## plus, define the myscrollbox div to prevent y overflow when page fills up
tags$head(
tags$style(
HTML(
".shiny-output-error-validation {
font-size: 15px;
color: forestgreen;
text-align: center;
}
#myScrollBox{
overflow-y: scroll;
.dataTables_wrapper{
overflow-x: scroll;
}
}
"
)
)
),
tags$head(
tags$style(
".biocdlbutton{background-color:#0092AC;} .biocdlbutton{color: #ffffff;}"
)
),
tags$script(HTML("$(function(){
$(document).keyup(function(e) {
if (e.which == 17) {
$('#bookmarker').click()
}
});
})")),
# 27: esc, works
# 60, <, works NOT1
# 17, ctrl left, works
# see more here:
# https://stackoverflow.com/questions/41675059/keyboard-shortcuts-to-trigger-reactive-flows-in-r-shiny
# https://stackoverflow.com/questions/10655202/detect-multiple-keys-on-single-keypress-event-in-jquery
# http://keycode.info/
bs4TabItems(
# ui panel welcome -----------------------------------------------------------
bs4TabItem(
tabName = "tab_welcome",
fluidRow(
column(
width = 11
),
column(
width = 1,
actionButton(
"tour_firststeps", label = "", icon = icon("question-circle"),
style = .helpbutton_biocstyle
)
)
),
fluidRow(
h2("Overview on the provided input")
),
fluidRow(
bs4Dash::bs4Card(
width = 6,
inputId = "card_em",
title = "Expression Matrix",
status = "danger",
solidHeader = FALSE,
collapsible = TRUE,
collapsed = TRUE,
closable = FALSE,
DT::dataTableOutput("overview_dds")
),
bs4Dash::bs4Card(
width = 6,
inputId = "card_de",
title = "DE results",
status = "warning",
solidHeader = FALSE,
collapsible = TRUE,
collapsed = TRUE,
closable = FALSE,
DT::dataTableOutput("overview_res_de")
),
bs4Dash::bs4Card(
width = 6,
inputId = "card_enrich",
title = "Functional analysis results",
status = "success",
solidHeader = FALSE,
collapsible = TRUE,
collapsed = TRUE,
closable = FALSE,
DT::dataTableOutput("overview_res_enrich")
),
bs4Dash::bs4Card(
width = 6,
inputId = "card_anno",
title = "Annotation info",
status = "info",
solidHeader = FALSE,
collapsible = TRUE,
collapsed = TRUE,
closable = FALSE,
DT::dataTableOutput("overview_annotation")
)
),
uiOutput("ui_infoboxes")
),
# ui panel geneset-gene ---------------------------------------------------
bs4TabItem(
tabName = "tab_ggs",
fluidRow(
column(
width = 11
),
column(
width = 1,
actionButton(
"tour_ggs", label = "", icon = icon("question-circle"),
style = .helpbutton_biocstyle
)
)
),
fluidRow(
column(
width = 8,
withSpinner(
visNetworkOutput("ggsnetwork",
height = "700px",
width = "100%")
)
),
column(
width = 4,
bs4Card(
title = "Geneset Box",
width = 12,
closable = FALSE,
uiOutput("ui_ggs_genesetbox")
),
# box(),
hr(),
bs4Card(
title = "Gene Box",
width = 12,
closable = FALSE,
uiOutput("ui_ggs_genebox")
)
)
)
),
# ui panel enrichment map -------------------------------------------------
bs4TabItem(
tabName = "tab_emap",
fluidRow(
column(
width = 11
),
column(
width = 1,
actionButton(
"tour_emap", label = "", icon = icon("question-circle"),
style = .helpbutton_biocstyle
)
)
),
fluidRow(
column(
width = 8,
withSpinner(
tagList(
selectInput(
inputId = "emap_colorby",
label = "Color emap by",
choices = colnames(res_enrich)[unlist(lapply(res_enrich, is.numeric))],
selected = "gs_pvalue"),
visNetworkOutput("emap_visnet",
height = "700px",
width = "100%")
)
)
),
column(
width = 4,
bs4Card(
title = "Geneset Box",
width = 12,
closable = FALSE,
uiOutput("ui_emap_sidecontent")
)
)
),
fluidRow(
bs4Dash::bs4Card(
width = 12,
inputId = "card_distillery",
title = "Geneset distillery",
status = "info",
solidHeader = FALSE,
collapsible = TRUE,
collapsed = TRUE,
closable = FALSE,
fluidRow(
column(
width = 8,
withSpinner(
DT::dataTableOutput("dt_distill")
),
uiOutput("distill_launch"),
numericInput(
inputId = "n_genesets_distill",
label = "Number of genesets",
value = min(50, nrow(res_enrich)), min = 1, max = nrow(res_enrich)
)
),
column(
width = 4,
bs4Card(
title = "Meta-geneset Box",
width = 12,
closable = FALSE,
uiOutput("ui_metags_sidecontent")
)
)
)
)
)
),
# ui panel overview --------------------------------------------------------
bs4TabItem(
tabName = "tab_overview",
fluidRow(
column(
width = 11
),
column(
width = 1,
actionButton(
"tour_overview", label = "", icon = icon("question-circle"),
style = .helpbutton_biocstyle
)
)
),
fluidRow(
bs4Dash::column(
width = 11,
offset = 0,
bs4Dash::bs4TabCard(
id = "tabcard_deview",
title = "Overview",
side = "right",
elevation = 2,
width = 12,
closable = FALSE,
bs4TabPanel(
tabName = "Geneset Volcano",
active = TRUE,
withSpinner(plotOutput("gs_volcano",
height = "650px"))
),
bs4TabPanel(
tabName = "Geneset Volcano - simplified",
active = FALSE,
numericInput(inputId = "gs_overlap",
label = "Gene Set overlap",
value = 0.6, min = 0, max = 1, step = 0.05),
withSpinner(plotOutput("gs_volcano_simplified",
height = "650px"))
),
bs4TabPanel(
tabName = "Enhanced Table",
active = FALSE,
withSpinner(plotOutput("enriched_funcres",
height = "650px"))
),
bs4TabPanel(
tabName = "Enhanced Table - interactive",
active = FALSE,
withSpinner(plotlyOutput("enriched_funcres_plotly",
height = "650px"))
)
)
)
)
),
# ui panel GSViz ------------------------------------------------------
bs4TabItem(
tabName = "tab_gsviz",
fluidRow(
column(
width = 11
),
column(
width = 1,
actionButton(
"tour_gsviz", label = "", icon = icon("question-circle"),
style = .helpbutton_biocstyle
)
)
),
fluidRow(
bs4Dash::column(
width = 11,
offset = 0,
bs4Dash::bs4TabCard(
id = "tabcard_genesets",
title = "GSViz",
side = "right",
elevation = 2,
width = 12,
closable = FALSE,
bs4TabPanel(
tabName = "Scores Heatmap",
active = TRUE,
withSpinner(plotOutput("gsscores_heatmap",
height = "650px"))
),
bs4TabPanel(
tabName = "Alluvial Plot",
active = FALSE,
withSpinner(plotlyOutput("alluvial_genesets",
height = "650px"))
),
bs4TabPanel(
tabName = "Summary Heatmap",
active = FALSE,
withSpinner(plotOutput("gs_summaryheat",
height = "650px"))
),
bs4TabPanel(
tabName = "Geneset MDS",
active = FALSE,
withSpinner(plotOutput("mds_genesets",
height = "650px"))
),
bs4TabPanel(
tabName = "Summary Overview",
active = FALSE,
withSpinner(plotOutput("gs_summaryoverview",
height = "650px"))
),
bs4TabPanel(
tabName = "Geneset Radar",
active = FALSE,
withSpinner(plotlyOutput("gs_summaryradar",
height = "650px"))
),
bs4TabPanel(
tabName = "Geneset Dendrogram",
active = FALSE,
withSpinner(plotOutput("gs_dendro",
height = "650px"))
)
)
)
)
),
# ui panel bookmark ------------------------------------------------------
bs4TabItem(
tabName = "tab_bookmarks",
fluidRow(
column(
width = 11
),
column(
width = 1,
actionButton(
"tour_bookmarks", label = "", icon = icon("question-circle"),
style = .helpbutton_biocstyle
)
)
),
fluidRow(
column(
width = 12,
uiOutput("ui_bookmarks")
)
),
fluidRow(
bs4Dash::column(
width = 8,
offset = 2,
br(), br(),
gt_downloadButton(
"start_happyhour",
"Start the happy hour!",
class = "biocdlbutton",
icon = "cocktail") # magic?
)
),
hr(),
br(), br(), br(),
fluidRow(
column(
width = 4,
textInput(
"se_export_name",label = "Choose a filename for the serialized .rds object",
value = "se_GeneTonic_toiSEE.rds"
)
),
column(
width = 4,
gt_downloadButton(
"button_iSEEexport",
label = "Export as serialized SummarizedExperiment",
class = "biocdlbutton",
icon = "glasses"
)
)
)
)
)
),
# controlbar definition ---------------------------------------------------
controlbar = bs4Dash::bs4DashControlbar(
numericInput(inputId = "de_fdr",
label = "False Discovery Rate (FDR) for DE",
value = 0.05, min = 0.0001, max = 1, step = 0.01),
numericInput(inputId = "n_genesets",
label = "Number of genesets",
value = 15, min = 1, max = nrow(res_enrich)),
selectInput("exp_condition", label = "Group/color by: ",
choices = c(NULL, names(colData(dds))), selected = NULL, multiple = TRUE)
),
# footer definition -------------------------------------------------------
footer = bs4DashFooter(
GeneTonic_footer,
right_text = NULL
)
)
options(shiny.maxRequestSize = 15 * 1024^2)
#nocov start
genetonic_server <- function(input, output, session) {
# reactive objects and setup commands -------------------------------------
reactive_values <- reactiveValues()
reactive_values$mygenes <- c()
reactive_values$mygenesets <- c()
myvst <- vst(dds)
res_enhanced <- get_aggrscores(res_enrich = res_enrich,
res_de = res_de,
annotation_obj = annotation_obj)
# output$ui_exp_condition <- renderUI({
# selectInput("exp_condition", label = "Group/color by: ",
# choices = c(NULL, poss_covars), selected = NULL, multiple = TRUE)
# })
# panel Welcome -----------------------------------------------------------
output$overview_dds <- DT::renderDataTable({
DT::datatable(
counts(dds),
options = list(scrollX = TRUE, scrollY = "400px")
)
})
output$overview_res_de <- DT::renderDataTable({
DT::datatable(
as.data.frame(res_de),
options = list(
scrollX = TRUE,
scrollY = "400px",
pageLength = 25,
columnDefs = list(
list(className = "dt-center", targets = "_all")
)
)
) %>%
formatRound(columns = c("log2FoldChange"), digits = 3) %>%
formatStyle(
"log2FoldChange",
background = styleColorBar_divergent(as.data.frame(res_de)$log2FoldChange,
scales::alpha("navyblue", 0.4),
scales::alpha("darkred", 0.4)),
backgroundSize = "100% 90%",
backgroundRepeat = "no-repeat",
backgroundPosition = "center"
)
})
output$overview_res_enrich <- DT::renderDataTable({
DT::datatable(
res_enrich,
options = list(scrollX = TRUE, scrollY = "400px")
)
})
output$overview_annotation <- DT::renderDataTable({
DT::datatable(
annotation_obj,
options = list(scrollX = TRUE, scrollY = "400px")
)
})
output$ui_infoboxes <- renderUI({
tagList(
fluidRow(
column(
width = 12,
bs4ValueBoxOutput("infobox_dds"),
bs4ValueBoxOutput("infobox_resde"),
bs4ValueBoxOutput("infobox_resenrich"),
bs4ValueBoxOutput("infobox_annotation")
)
# ,
# column(
# width = 6,
# img(src = "GeneTonic/GeneTonic.png", height = "350px")
# )
)
)
})
output$infobox_dds <- renderbs4ValueBox({
bs4ValueBox(
value = paste0(nrow(dds), " genes x ", ncol(dds), " samples"),
subtitle = "dds object",
icon = "table",
status = "danger",
width = NULL
)
})
output$infobox_resde <- renderbs4ValueBox({
bs4ValueBox(
value = paste0(
nrow(deseqresult2df(res_de, FDR = input$de_fdr)),
" DE genes"
),
subtitle = "res object",
icon = "vial",
status = "warning",
width = NULL
)
})
output$infobox_resenrich <- renderbs4ValueBox({
bs4ValueBox(
value = paste0(
nrow(res_enrich),
" functional categories"
),
subtitle = "func enrich object",
icon = "share-alt",
status = "success",
width = NULL
)
})
output$infobox_annotation <- renderbs4ValueBox({
bs4ValueBox(
value = paste0(ncol(annotation_obj), " feature identifiers for ", nrow(dds), " features"),
subtitle = "annotation object",
icon = "table",
status = "info",
width = NULL
)
})
# panel GeneSet-Gene ------------------------------------------------------
reactive_values$ggs_graph <- reactive({
g <- ggs_graph(
res_enrich = res_enrich,
res_de = res_de,
annotation_obj = annotation_obj,
n_gs = input$n_genesets,
prettify = TRUE,
geneset_graph_color = "gold"
)
# rank_gs <- rank(V(g)$name[V(g)$nodetype == "GeneSet"])
# rank_feats <- rank(V(g)$name[V(g)$nodetype == "Feature"]) +
# length(rank_gs) # to keep the GeneSets first
# g <- permute.vertices(g, c(rank_gs, rank_feats))
# return(g)
})
output$ggsnetwork <- renderVisNetwork({
# minimal example
visNetwork::visIgraph(reactive_values$ggs_graph()) %>%
visOptions(highlightNearest = list(enabled = TRUE,
degree = 1,
hover = TRUE),
nodesIdSelection = TRUE) %>%
visExport(name = "ggs_network",
type = "png",
label = "Save ggs graph")
})
output$netnode <- renderPrint({
g <- reactive_values$ggs_graph()
cur_sel <- input$ggsnetwork_selected
cur_node <- match(cur_sel, V(g)$name)
cur_nodetype <- V(g)$nodetype[cur_node]
cur_gsid <- res_enrich$gs_id[match(cur_sel, res_enrich$gs_description)]
paste0("I'm selecting ", input$ggsnetwork_selected, ", which has index ", cur_node, " and is of type ", cur_nodetype, "this is from set", cur_gsid)
})
output$ui_ggs_genesetbox <- renderUI({
tagList(
# verbatimTextOutput("netnode"),
plotOutput("net_sigheatplot"),
uiOutput("ggs_geneset_info")
)
})
output$net_sigheatplot <- renderPlot({
g <- reactive_values$ggs_graph()
cur_sel <- input$ggsnetwork_selected
cur_node <- match(cur_sel, V(g)$name)
cur_nodetype <- V(g)$nodetype[cur_node]
validate(need(cur_nodetype == "GeneSet",
message = "Please select a gene set from the Gene-Geneset Graph."
))
cur_gsid <- res_enrich$gs_id[match(input$ggsnetwork_selected, res_enrich$gs_description)]
if (!is.null(input$exp_condition)) {
gs_heatmap(
myvst,
res_de,
res_enrich,
annotation_obj = annotation_obj,
geneset_id = cur_gsid,
FDR = input$de_fdr,
de_only = FALSE,
cluster_rows = TRUE,
cluster_columns = TRUE,
center_mean = TRUE,
scale_row = TRUE,
anno_col_info = input$exp_condition
)
} else {
gs_heatmap(
myvst,
res_de,
res_enrich,
annotation_obj = annotation_obj,
geneset_id = cur_gsid,
FDR = input$de_fdr,
de_only = FALSE,
cluster_rows = TRUE,
cluster_columns = TRUE,
center_mean = TRUE,
scale_row = TRUE
)
}
})
output$ggs_geneset_info <- renderUI({
g <- reactive_values$ggs_graph()
cur_sel <- input$ggsnetwork_selected
cur_node <- match(cur_sel, V(g)$name)
cur_nodetype <- V(g)$nodetype[cur_node]
validate(need(cur_nodetype == "GeneSet",
message = "" # "Please select a gene set."
))
cur_gsid <- res_enrich$gs_id[match(input$ggsnetwork_selected, res_enrich$gs_description)]
go_2_html(cur_gsid, res_enrich)
})
output$ui_ggs_genebox <- renderUI({
tagList(
uiOutput("ggs_gene_info"),
plotOutput("ggs_geneplot")
)
})
output$ggs_gene_info <- renderUI({
g <- reactive_values$ggs_graph()
cur_sel <- input$ggsnetwork_selected
cur_node <- match(cur_sel, V(g)$name)
cur_nodetype <- V(g)$nodetype[cur_node]
validate(need(cur_nodetype == "Feature",
message = "Please select a gene/feature."
))
cur_geneid <- annotation_obj$gene_id[match(cur_sel, annotation_obj$gene_name)]
# mycontent <- HTML(paste0(
# cur_geneid, "<br>", "<b>", cur_sel, "</b>"
# ))
geneinfo_2_html(cur_sel, res_de)
})
output$ggs_geneplot <- renderPlot({
g <- reactive_values$ggs_graph()
cur_sel <- input$ggsnetwork_selected
cur_node <- match(cur_sel, V(g)$name)
cur_nodetype <- V(g)$nodetype[cur_node]
validate(need(cur_nodetype == "Feature",
message = "" # "Please select a gene/feature."
))
validate(need(input$exp_condition != "",
message = "Please select a group for the experimental condition."
))
cur_geneid <- annotation_obj$gene_id[match(cur_sel, annotation_obj$gene_name)]
gene_plot(dds,
gene = cur_geneid,
intgroup = input$exp_condition,
annotation_obj = annotation_obj
)
})
# panel EnrichmentMap -----------------------------------------------------
emap_graph <- reactive({
emg <- enrichment_map(
res_enrich = res_enrich,
res_de = res_de,
annotation_obj = annotation_obj,
n_gs = input$n_genesets,
overlap_threshold = 0.1,
scale_edges_width = 200,
color_by = input$emap_colorby
)
# rank_gs <- rank(V(emg)$name)
# emg <- permute.vertices(emg, rank_gs)
return(emg)
})
output$emap_visnet <- renderVisNetwork({
visNetwork::visIgraph(emap_graph()) %>%
visOptions(highlightNearest = list(enabled = TRUE,
degree = 1,
hover = TRUE),
nodesIdSelection = TRUE) %>%
visExport(name = "emap_network",
type = "png",
label = "Save enrichment map")
})
output$ui_emap_sidecontent <- renderUI({
tagList(
plotOutput("emap_sigheatplot"),
uiOutput("emap_geneset_info")
)
})
output$emap_geneset_info <- renderUI({
cur_gsid <- res_enrich$gs_id[match(input$emap_visnet_selected, res_enrich$gs_description)]
validate(need(!is.na(cur_gsid),
message = ""))
# message(cur_gsid)
# GOTERM[[cur_gsid]]
go_2_html(cur_gsid, res_enrich)
})
output$emap_sigheatplot <- renderPlot({
# g <- reactive_values$emap_graph()
# cur_sel <- input$emap_visnet_selected
# cur_node <- match(cur_sel,V(g)$name)
# cur_nodetype <- V(g)$nodetype[cur_node]
# validate(need(cur_nodetype == "GeneSet",
# message = "Please select a gene set."
# ))
cur_gsid <- res_enrich$gs_id[match(input$emap_visnet_selected, res_enrich$gs_description)]
validate(need(!is.na(cur_gsid),
message = "Please select a gene set from the Enrichment Map."
))
if (!is.null(input$exp_condition)) {
# message(cur_gsid)
gs_heatmap(
myvst,
res_de,
res_enrich,
annotation_obj = annotation_obj,
geneset_id = cur_gsid,
FDR = input$de_fdr,
de_only = FALSE,
cluster_rows = TRUE,
cluster_columns = TRUE,
center_mean = TRUE,
scale_row = TRUE,
anno_col_info = input$exp_condition
)
} else {
gs_heatmap(
myvst,
res_de,
res_enrich,
annotation_obj = annotation_obj,
geneset_id = cur_gsid,
FDR = input$de_fdr,
de_only = FALSE,
cluster_rows = TRUE,
cluster_columns = TRUE,
center_mean = TRUE,
scale_row = TRUE
)
}
})
# geneset distillery
reactive_values$distillat <- reactive({
distillat <- distill_enrichment(
res_enrich = res_enrich,
res_de = res_de,
annotation_obj = annotation_obj,
n_gs = input$n_genesets_distill)
return(distillat)
})
output$dt_distill <- DT::renderDataTable({
dist_table <- reactive_values$distillat()$distilled_table
# TODO: reorder the columns from the distilled table
DT::datatable(
dist_table[,1:4],
selection = "single",
rownames = FALSE,
options = list(
pageLength = 50,
scrollX = TRUE,
scrollY = "400px")
)
})
output$ui_metags_sidecontent <- renderUI({
tagList(
plotOutput("distill_heatmap"),
uiOutput("distill_info")
)
})
output$distill_info <- renderUI({
"haha"
# TODO: structure up the content, a la gene2html
})
output$distill_launch <- renderUI({
tagList(
actionButton(
inputId = "btn_show_emap_distilled",
icon = icon("hubspot"),
label = "Distill emap", style = .actionbutton_biocstyle
)
)
})
output$distill_heatmap <- renderPlot({
dist_table <- reactive_values$distillat()$distilled_table
s <- input$dt_distill_rows_selected
validate(need(length(s) > 0,
message = "Please select a meta-geneset from the table"
))
selrow <- dist_table[s,]$metags_msgs
sel_genes <- strsplit(dist_table[s,]$metags_genes, ",")[[1]]
# message(length(sel_genes))
sel_genes_id <- annotation_obj$gene_id[match(sel_genes, annotation_obj$gene_name)]
# message(length(sel_genes_id))
if (!is.null(input$exp_condition)) {
gs_heatmap(
myvst,
res_de,
res_enrich,
annotation_obj = annotation_obj,
genelist = sel_genes_id,
FDR = input$de_fdr,
de_only = FALSE,
cluster_rows = TRUE,
cluster_columns = TRUE,
center_mean = TRUE,
scale_row = TRUE,
anno_col_info = input$exp_condition,
plot_title = selrow
)
} else {
gs_heatmap(
myvst,
res_de,
res_enrich,
annotation_obj = annotation_obj,
genelist = sel_genes_id,
FDR = input$de_fdr,
de_only = FALSE,
cluster_rows = TRUE,
cluster_columns = TRUE,
center_mean = TRUE,
scale_row = TRUE,
plot_title = selrow
)
}
})
# output$distill_graph <- renderPlot({
# plot(reactive_values$distillat()$distilled_em)
# })
output$distill_graph <- renderVisNetwork({
ig <- reactive_values$distillat()$distilled_em
# TODO: define color palette
colpal <- colorspace::rainbow_hcl(length(unique(V(ig)$color)))[V(ig)$color]
V(ig)$color.background <- scales::alpha(colpal, alpha = 0.8)
V(ig)$color.highlight <- scales::alpha(colpal, alpha = 1)
V(ig)$color.hover <- scales::alpha(colpal, alpha = 0.5)
V(ig)$color.border <- "black"
visNetwork::visIgraph(ig) %>%
visOptions(highlightNearest = list(enabled = TRUE,
degree = 1,
hover = TRUE),
nodesIdSelection = TRUE,
selectedBy = "membership")
})
# panel Overview ------------------------------------------------------------
output$enriched_funcres <- renderPlot({
enhance_table(res_enrich, res_de,
annotation_obj = annotation_obj,
n_gs = input$n_genesets)
})
output$gs_volcano <- renderPlot({
gs_volcano(
get_aggrscores(res_enrich,
res_de,
annotation_obj = annotation_obj),
volcano_labels = input$n_genesets
)
})
output$gs_volcano_simplified <- renderPlot({
gs_volcano(
get_aggrscores(gs_simplify(res_enrich, gs_overlap = input$gs_overlap),
res_de,
annotation_obj = annotation_obj),
volcano_labels = input$n_genesets
)
})
output$enriched_funcres_plotly <- renderPlotly({
ggplotly(enhance_table(res_enrich,
res_de,
annotation_obj = annotation_obj,
n_gs = input$n_genesets))
})
# panel GSViz -----------------------------------------------------
gss_mat <- reactive({
gs_scores(se = myvst,
res_de = res_de,
res_enrich = res_enrich,
annotation_obj = annotation_obj)
})
output$gsscores_heatmap <- renderPlot({
gs_scoresheat(
gss_mat(),
n_gs = input$n_genesets)
})
output$alluvial_genesets <- renderPlotly({
gs_alluvial(res_enrich, res_de, annotation_obj, n_gs = input$n_genesets)
})
output$mds_genesets <- renderPlot({
gs_mds(res_enrich, res_de, annotation_obj, mds_colorby = "z_score",
mds_labels = input$n_genesets)
})
output$gs_summaryheat <- renderPlot({
gs_summary_heat(res_enrich, res_de, annotation_obj,
n_gs = input$n_genesets)
})
output$gs_summaryoverview <- renderPlot({
gs_summary_overview(res_enrich = res_enhanced,
n_gs = input$n_genesets)
})
output$gs_summaryoverview_pair <- renderPlot({
gs_summary_overview_pair(res_enrich = res_enhanced,
n_gs = input$n_genesets)
})
output$gs_summaryhorizon <- renderPlot({
gs_horizon(res_enrich = res_enhanced,
n_gs = input$n_genesets)
})
output$gs_summaryradar <- renderPlotly({
gs_radar(res_enrich = res_enhanced,
n_gs = input$n_genesets)
})
output$gs_dendro <- renderPlot({
gs_dendro(res_enrich = res_enhanced,
n_gs = input$n_genesets)
})
# panel Bookmarks ---------------------------------------------------------
output$ui_bookmarks <- renderUI({
tagList(
fluidRow(
column(
width = 6,
bs4InfoBoxOutput("infobox_book_genes"),
h5("Bookmarked genes"),
DT::dataTableOutput("bookmarks_genes"),
downloadButton("btn_export_genes", label = "", class = "biocdlbutton")
# ideally completed by a function/param to upload them
),
column(
width = 6,
bs4InfoBoxOutput("infobox_book_genesets"),
h5("Bookmarked genesets"),
DT::dataTableOutput("bookmarks_genesets"),
downloadButton("btn_export_genesets", label = "", class = "biocdlbutton")
)
)
)
})
output$infobox_book_genes <- renderbs4InfoBox({
bs4InfoBox(
title = "Bookmarked genes",
value = length(reactive_values$mygenes),
icon = "bookmark",
status = "info",
width = 12
)
})
output$infobox_book_genesets <- renderbs4InfoBox({
bs4InfoBox(
title = "Bookmarked genesets",
value = length(reactive_values$mygenesets),
icon = "bookmark",
status = "success",
width = 12
)
})
output$bookmarks_genes <- DT::renderDataTable({
book_df_genes <- annotation_obj[reactive_values$mygenes, ]
datatable(book_df_genes, rownames = FALSE)
})
output$bookmarks_genesets <- DT::renderDataTable({
book_df_genesets <- res_enrich[reactive_values$mygenesets, c("gs_id", "gs_description")]
datatable(book_df_genesets, rownames = FALSE)
})
output$btn_export_genes <- downloadHandler(
filename = function() {
paste0("GeneTonicBookmarks_genes_", project_id, "_", gsub(" ", "_", gsub("-", "", gsub(":", "-", as.character(Sys.time())))), ".txt")
}, content = function(file) {
writeLines(text = reactive_values$mygenes,
con = file)
}
)
output$btn_export_genesets <- downloadHandler(
filename = function() {
paste0("GeneTonicBookmarks_genesets_", project_id, "_", gsub(" ", "_", gsub("-", "", gsub(":", "-", as.character(Sys.time())))), ".txt")
}, content = function(file) {
writeLines(text = reactive_values$mygenesets,
con = file)
}
)
output$start_happyhour <- downloadHandler(
filename = paste0(
Sys.Date(),
"_", round(runif(1) * 100), # for not having all w the same name
"_GeneTonicReport.html"),
content = function(file) {
# temporarily switch to the temp dir, in case you do not have write permission to the current working directory
owd <- setwd(tempdir())
on.exit(setwd(owd))
# cat(tmp_content,file="GeneTonic_tempreport.Rmd",sep="\n")
withProgress(rmarkdown::render(
input = system.file("extdata", "cocktail_recipe.Rmd", package = "GeneTonic"),
output_file = file,
# fragment.only = TRUE,
quiet = TRUE),
message = "Generating the html report",
detail = "This can take some time")
}
)
output$button_iSEEexport <- downloadHandler(
filename = function() {
input$se_export_name
}, content = function(file) {
se <- export_for_iSEE(dds, res_de)
saveRDS(se, file = file)
}
)
output$sessioninfo <- renderPrint({
sessionInfo()
})
# observers ---------------------------------------------------------------
observeEvent(input$tour_firststeps, {
tour <- read.delim(system.file("extdata", "tour_welcome.txt", package = "GeneTonic"),
sep = ";", stringsAsFactors = FALSE,
row.names = NULL, quote = "")
rintrojs::introjs(session, options = list(steps = tour))
})
observeEvent(input$tour_ggs, {
tour <- read.delim(system.file("extdata", "tour_ggs.txt", package = "GeneTonic"),
sep = ";", stringsAsFactors = FALSE,
row.names = NULL, quote = "")
rintrojs::introjs(session, options = list(steps = tour))
})
observeEvent(input$tour_emap, {
tour <- read.delim(system.file("extdata", "tour_emap.txt", package = "GeneTonic"),
sep = ";", stringsAsFactors = FALSE,
row.names = NULL, quote = "")
rintrojs::introjs(session, options = list(steps = tour))
})
observeEvent(input$tour_overview, {
tour <- read.delim(system.file("extdata", "tour_overview.txt", package = "GeneTonic"),
sep = ";", stringsAsFactors = FALSE,
row.names = NULL, quote = "")
rintrojs::introjs(session, options = list(steps = tour))
})
observeEvent(input$tour_gsviz, {
tour <- read.delim(system.file("extdata", "tour_gsviz.txt", package = "GeneTonic"),
sep = ";", stringsAsFactors = FALSE,
row.names = NULL, quote = "")
rintrojs::introjs(session, options = list(steps = tour))
})
observeEvent(input$tour_bookmarks, {
tour <- read.delim(system.file("extdata", "tour_bookmarks.txt", package = "GeneTonic"),
sep = ";", stringsAsFactors = FALSE,
row.names = NULL, quote = "")
rintrojs::introjs(session, options = list(steps = tour))
})
# observe({
# print(input$gt_tabs)
# })
observeEvent(input$btn_first_help, {
showModal(
modalDialog(
title = "First Help Info", size = "l", fade = TRUE,
footer = NULL, easyClose = TRUE,
tagList(
includeMarkdown(system.file("extdata", "GeneTonic101.md", package = "GeneTonic")),
)
)
)
})
observeEvent(input$btn_docs_vignette, {
path <- system.file("doc", "GeneTonic_manual.html", package = "GeneTonic")
if (path == "") {
showNotification("This vignette has not been built on this system - Opening the online documentation. Please note that the versions might not be coincident!", type = "warning")
} else {
browseURL(path)
}
})
observeEvent(input$btn_info_session, {
showModal(
modalDialog(
title = "Session information", size = "l", fade = TRUE,
footer = NULL, easyClose = TRUE,
tagList(
tags$code("> sessionInfo()"),
renderPrint({
sessionInfo()
})
)
)
)
})
observeEvent(input$btn_info_genetonic, {
showModal(
modalDialog(
title = "About GeneTonic", size = "l", fade = TRUE,
footer = NULL, easyClose = TRUE,
tagList(
includeMarkdown(system.file("extdata", "about.md", package = "GeneTonic")),
renderPrint({
citation("GeneTonic")
})
)
)
)
})
observeEvent(input$btn_show_emap_distilled, {
showModal(
modalDialog(
title = "distillery", size = "l", fade = TRUE,
footer = NULL, easyClose = TRUE,
visNetworkOutput("distill_graph")
)
)
})
# bookmarker --------------------------------------------------------------
observeEvent(input$bookmarker, {
if (input$gt_tabs == "tab_welcome")
showNotification("Welcome to GeneTonic!")
else if (input$gt_tabs == "tab_ggs") {
g <- reactive_values$ggs_graph()
cur_sel <- input$ggsnetwork_selected
if (cur_sel == "") {
showNotification("Select a node in the network to bookmark it", type = "warning")
} else {
cur_node <- match(cur_sel, V(g)$name)
cur_nodetype <- V(g)$nodetype[cur_node]
if (cur_nodetype == "Feature") {
cur_sel_id <- annotation_obj$gene_id[match(cur_sel, annotation_obj$gene_name)]
if (cur_sel_id %in% reactive_values$mygenes) {
showNotification(sprintf("The selected gene %s (%s) is already in the set of the bookmarked genes.", cur_sel, cur_sel_id), type = "default")
} else {
reactive_values$mygenes <- unique(c(reactive_values$mygenes, cur_sel_id))
# message("there go your genes... ", reactive_values$mygenes)
showNotification(sprintf("Added %s (%s) to the bookmarked genes. The list contains now %d elements", cur_sel, cur_sel_id, length(reactive_values$mygenes)), type = "message")
}
} else if (cur_nodetype == "GeneSet") {
cur_sel_id <- res_enrich$gs_id[match(cur_sel, res_enrich$gs_description)]
if (cur_sel_id %in% reactive_values$mygenesets) {
showNotification(sprintf("The selected gene set %s (%s) is already in the set of the bookmarked genesets.", cur_sel, cur_sel_id), type = "default")
} else {
reactive_values$mygenesets <- unique(c(reactive_values$mygenesets, cur_sel_id))
# message("here are your genesets... ", reactive_values$mygenesets)
showNotification(sprintf("Added %s (%s) to the bookmarked genesets. The list contains now %d elements", cur_sel, cur_sel_id, length(reactive_values$mygenesets)), type = "message")
}
} else {
message("bleeee")
}
}
}
else if (input$gt_tabs == "tab_emap") {
g <- reactive_values$ggs_graph()
cur_sel <- input$emap_visnet_selected
cur_sel_id <- res_enrich$gs_id[match(cur_sel, res_enrich$gs_description)]
if (cur_sel == "") {
showNotification("Select a node in the network to bookmark it", type = "warning")
} else {
if (cur_sel_id %in% reactive_values$mygenesets) {
showNotification(sprintf("The selected gene set %s (%s) is already in the set of the bookmarked genesets.", cur_sel, cur_sel_id), type = "default")
} else {
reactive_values$mygenesets <- unique(c(reactive_values$mygenesets, cur_sel_id))
message("here are your genesets... ", reactive_values$mygenesets)
showNotification(sprintf("Added %s (%s) to the bookmarked genesets. The list contains now %d elements", cur_sel, cur_sel_id, length(reactive_values$mygenesets)), type = "message")
}
}
}
else if (input$gt_tabs == "tab_bookmarks")
showNotification("You are already in the Bookmarks tab...")
})
# observeEvent(input$start_happyhour, {
# showNotification("The happy hour is on! Please wait for the report to be fully compiled",
# type = "message")
# })
}
#nocov end
shinyApp(ui = genetonic_ui, server = genetonic_server)
}
