R/shiny.R
In jokergoo/rGREAT: GREAT Analysis - Functional Enrichment on Genomic Regions
# == title
# Shiny app on the GreatJob object
#
# == param
# -object The ``GreatJob`` object returned by `submitGreatJob`.
#
# == value
# A shiny app object.
#
# == example
# if(FALSE) {
# # pseudo code
# job = submitGreatJob(...)
# shinyReport(job)
# }
setMethod(f = "shinyReport",
signature = "GreatJob",
definition = function(object) {
obj_name = "object"
job = object
all_ontologies = availableOntologies(job)
message(qq("* download @{length(all_ontologies)} enrichment tables from GREAT server (tables will be cached)."))
tbl = getEnrichmentTables(job, ontology = all_ontologies, verbose = FALSE)
ui = fluidPage(
h2("Report for online GREAT analysis"),
h3("Job description"),
verbatimTextOutput(outputId = "job_desc"),
HTML(qq("<h3>Global region-gene associations</h3>")),
HTML(qq("<pre>plotRegionGeneAssociations(@{obj_name})</pre>")),
plotOutput(outputId = "global_plot", width = "1000px", height= "400px"),
hr(),
h3("Global controls"),
div(id = "global_control",
tags$table(tags$tr(
tags$td(textInput("padj_cutoff", label = "Cutoff for adjusted p-values (from Binomial test)", value = "0.05", width = 380)),
tags$td(textInput("observed_hits_cutoff", label = "Cutoff for observed region hits", value = "5", width=400))
))
),
hr(),
htmlOutput(outputId = "error"),
htmlOutput(outputId = "enrichment_table"),
hr(),
HTML("<p>Generated by <a href='https://bioconductor.org/packages/rGREAT/' target='_blank'>rGREAT package</a>.</p>"),
tags$style(
"pre {
width:800px;
padding:20px;
}
#global_control td {padding-right:20px;}
.tooltip-inner {
max-width:600px;
background-color: #f5f5f5;
border: 1px solid #cccccc;
color: black;
font-size:13px;
padding: 6px 15px;
}
.fake_link {
color: #337ab7;
text-decoration: none;
}
.fake_link:hover {
ext-decoration: underline;
cursor: pointer;
}
.container-fluid {
margin-left:20px;
margin-right:20px
}
.error {
color:red;
}
"
)
)
format_table = function(tb, onto) {
tb2 = tb[, c("ID", "name", "Binom_Raw_PValue", "Binom_Adjp_BH", "Binom_Fold_Enrichment", "Binom_Observed_Region_Hits", "Binom_Genome_Fraction",
"Hyper_Raw_PValue", "Hyper_Adjp_BH", "Hyper_Observed_Gene_Hits", "Hyper_Total_Genes")]
BASE_URL = BASE_URL_LIST[job@parameters$version]
tb2[, "name"] = qq("<a href='@{BASE_URL}/showTermDetails.php?termId=@{tb2[, 'ID']}&ontoName=@{job@job_env$ONTOLOGY_KEYS[onto]}&ontoUiName=@{onto}&sessionName=@{job@job_env$id}&species=@{job@parameters$genome}&foreName=@{basename(param(job, 'f_bed'))}&backName=@{basename(param(job, 'f_bed_bg'))}&table=region' target='_blank'>@{tb2[, 'name']}</a>", collapse = FALSE)
colnames(tb2) = c("ID", "Term Name", "Binom Raw P-value", "Binom Adjusted P-value", "Binom Fold Enrichment", "Binom Observed Region Hits", "Genome Fraction",
"Hyper Raw P-value", "Hyper Adjusted P-value", "Hyper Observed Gene Hits", "Hyper Total Genes in Gene Set")
colnames(tb2) = gsub("_", " ", colnames(tb2))
dt = datatable(tb2[, -1], escape = FALSE, rownames = FALSE, selection = 'none', width = "100%", height = "auto",
options = list(searching = FALSE, rowCallback = JS(
'function(row, data) {
$(this.api().cell(row, 1).node()).html(data[1].toExponential(3));
$(this.api().cell(row, 2).node()).html(data[2].toExponential(3));
$(this.api().cell(row, 6).node()).html(data[5].toExponential(3));
$(this.api().cell(row, 7).node()).html(data[6].toExponential(3));
}
')))
dt = formatRound(dt, "Binom Fold Enrichment", 3)
dt = formatPercentage(dt, "Genome Fraction", 3)
dt
}
server = function(input, output, session) {
output$job_desc = renderPrint({
show(job)
cat("Cutoff for adjusted p-values (from Binomial test): ", input$padj_cutoff, "\n", sep = "")
cat("Cutoff for observed region hits: ", input$observed_hits_cutoff, "\n", sep = "")
})
observe({
suppressWarnings(padj_cutoff <- as.numeric(input$padj_cutoff))
suppressWarnings(observed_hits_cutoff <- as.numeric(input$observed_hits_cutoff))
if(is.na(padj_cutoff) || is.na(observed_hits_cutoff)) {
output[["error"]] = renderUI({
HTML("<p class='error message'>Wrong format for cutoffs.</p>")
})
output[["enrichment_table"]] = renderUI({
HTML("")
})
return(NULL)
}
all_ontologies = availableOntologies(job)
for(nm in all_ontologies) {
nm2 = gsub(" ", "_", nm)
code = qq("
output[['volcano_plot_@{nm2}']] = renderPlot({
plotVolcano(job, ontology = '@{nm}', min_region_hits = observed_hits_cutoff, x_values = input[['volcano_x_values_@{nm2}']], y_values = input[['volcano_y_values_@{nm2}']], main='Volcano plot for @{nm}')
})
")
eval(parse(text = code))
}
tbl = getEnrichmentTables(job, ontology = all_ontologies, verbose = FALSE)
tbl = lapply(tbl, function(tb) {
tb = tb[tb[, "Binom_Observed_Region_Hits"] >= observed_hits_cutoff, , drop = FALSE]
tb$Binom_Adjp_BH = p.adjust(tb$Binom_Raw_PValue, "BH")
tb$Hyper_Adjp_BH = p.adjust(tb$Hyper_Raw_PValue, "BH")
tb = tb[tb[, "Binom_Adjp_BH"] <= padj_cutoff, , drop = FALSE]
tb
})
tbl = tbl[sapply(tbl, nrow) > 0]
if(length(tbl) == 0) {
output[["error"]] = renderUI({
HTML("");
})
output[["enrichment_table"]] = renderUI({
HTML("<p class='message'>No significant term under current cutoffs.</p>")
})
} else {
ui_list = list()
for(i in seq_along(tbl)) {
onto_name = names(tbl)[i]
onto_name2 = gsub(" ", "_", onto_name)
ui_list[[i]] = div(
tabsetPanel(type = "tabs",
tabPanel("Enrichment table",
HTML(qq("<h3>@{onto_name} (@{nrow(tbl[[i]])} significant terms)</h3>")),
HTML(qq("<pre>getEnrichmentTable(job, ontology = '@{names(tbl)[i]}')</pre>")),
format_table(tbl[[i]], names(tbl)[i])
),
tabPanel("Volcano plot",
tags$br(),
HTML(qq("<pre>plotVolcano(@{obj_name}, ontology = '@{onto_name}')</pre>")),
radioButtons(qq("volcano_x_values_@{onto_name2}"), "Values on x-axis",
c("Fold enrichment: log2(obs/exp)" = "fold_enrichment",
"z-score: (obs-exp)/sd" = "z-score"),
selected = "fold_enrichment",
inline = TRUE
),
radioButtons(qq("volcano_y_values_@{onto_name2}"), "Values on y-axis",
c("Raw p-values" = "p_value",
"Adjusted p-values" = "p_adjust"),
selected = "p_value",
inline = TRUE
),
plotOutput(outputId = qq("volcano_plot_@{onto_name2}"), width="600px", height = "600px")
)
),
if(i < length(tbl)) hr() else NULL
)
}
ui_list[[i + 1]] = HTML("<script>$('#enrichment_table h3 a').tooltip();</script>")
ui_list$class = "ind_table"
output[["error"]] = renderUI({
HTML("");
})
output[["enrichment_table"]] = renderUI({
do.call("div", ui_list)
})
}
})
output$global_plot = renderPlot({
plotRegionGeneAssociations(job)
}, res = 100)
}
shinyApp(ui, server)
})
# == title
# Shiny app on the GreatObject object
#
# == param
# -object The ``GreatObject`` object returned by `great`.
#
# == value
# A shiny app object.
#
# == example
# if(FALSE) {
# # pseudo code
# obj = great(...)
# shinyReport(obj)
# }
setMethod(f = "shinyReport",
signature = "GreatObject",
definition = function(object) {
obj_name = "object"
object = object
ui = fluidPage(
h2("Report for local GREAT analysis"),
h3("Job description"),
verbatimTextOutput(outputId = "job_desc"),
HTML(qq("<h3>Global region-gene associations</h3>")),
HTML(qq("<pre>plotRegionGeneAssociationGraphs(@{obj_name})</pre>")),
plotOutput(outputId = "global_plot", width = "1000px", height= "400px"),
hr(),
h3("Global controls"),
div(id = "global_control",
tags$table(tags$tr(
tags$td(textInput("padj_cutoff", label = "Cutoff for adjusted p-values (from Binomial test)", value = "0.05", width = 380)),
tags$td(textInput("observed_hits_cutoff", label = "Cutoff for observed region hits", value = "5", width=400))
))
),
hr(),
tabsetPanel(type = "tabs",
tabPanel("Enrichment table",
htmlOutput(outputId = "error"),
htmlOutput(outputId = "enrichment_table")
),
tabPanel("Volcano plot",
tags$br(),
HTML(qq("<pre>plotVolcano(@{obj_name})</pre>")),
radioButtons("volcano_x_values", "Values on x-axis",
c("Fold enrichment: log2(obs/exp)" = "fold_enrichment",
"z-score: (obs-exp)/sd" = "z-score"),
selected = "fold_enrichment",
inline = TRUE
),
radioButtons("volcano_y_values", "Values on y-axis",
c("Raw p-values" = "p_value",
"Adjusted p-values" = "p_adjust"),
selected = "p_value",
inline = TRUE
),
plotOutput(outputId = "volcano_plot", width="600px", height = "600px")
)
),
tags$style(
"pre {
width:800px;
padding:20px;
}
#global_control td {
padding-right:20px;
}
.tooltip-inner {
max-width:400px;
background-color: #f5f5f5;
border: 1px solid #cccccc;
color: black;
font-size:13px;
padding: 6px 15px;
}
.fake_link {
color: #337ab7;
text-decoration: none;
}
.fake_link:hover {
ext-decoration: underline;
cursor: pointer;
}
.container-fluid {
margin-left:20px;
margin-right:20px
}
.error {
color:red;
}
.message{
padding: 20px 20px;
}
.modal-lg {
width:1100px;
}
"
),
hr(),
HTML("<p>Generated by <a href='https://bioconductor.org/packages/rGREAT/' target='_blank'>rGREAT package</a>.</p>")
)
format_table = function(tb) {
tb$id = qq("<a class='fake_link' onclick=\"Shiny.onInputChange('select_term', '');Shiny.onInputChange('select_term', '@{tb$id}');false;\">@{tb$id}</a>", collapse = FALSE)
if("description" %in% colnames(tb)) {
offset = 1
tb = tb[, c("id", "description", "mean_tss_dist", "p_value", "p_adjust", "fold_enrichment", "observed_region_hits", "genome_fraction", "p_value_hyper", "p_adjust_hyper", "fold_enrichment_hyper", "observed_gene_hits", "gene_set_size")]
colnames(tb) = c("Term Name", "Term Description", "Mean Abs Dist to TSS (bp)", "Binom Raw P-value", "Binom Adjusted P-value", "Binom Fold Enrichment", "Binom Observed Region Hits", "Genome Fraction", "Hyper Raw P-value", "Hyper Adjusted P-value", "Hyper Fold Enrichment", "Observed Gene Hits", "Total Genes in Gene Set")
} else {
offset = 0
tb = tb[, c("id", "mean_tss_dist", "p_value", "p_adjust", "fold_enrichment", "observed_region_hits", "genome_fraction", "p_value_hyper", "p_adjust_hyper", "fold_enrichment_hyper", "observed_gene_hits", "gene_set_size")]
colnames(tb) = c("Term Name", "Mean Abs Dist to TSS (bp)", "Binom Raw P-value", "Binom Adjusted P-value", "Binom Fold Enrichment", "Binom Observed Region Hits", "Genome Fraction", "Hyper Raw P-value", "Hyper Adjusted P-value", "Hyper Fold Enrichment", "Observed Gene Hits", "Total Genes in Gene Set")
}
dt = datatable(tb, escape = FALSE, rownames = FALSE, selection = 'none', width = "100%", height = "auto",
options = list(searching = FALSE, rowCallback = JS(qq(
'function(row, data) {
$(this.api().cell(row, @{2+offset}).node()).html(data[@{2+offset}].toExponential(3));
$(this.api().cell(row, @{3+offset}).node()).html(data[@{3+offset}].toExponential(3));
$(this.api().cell(row, @{7+offset}).node()).html(data[@{7+offset}].toExponential(3));
$(this.api().cell(row, @{8+offset}).node()).html(data[@{8+offset}].toExponential(3));
}
'))))
dt = formatRound(dt, "Binom Fold Enrichment", 3)
dt = formatPercentage(dt, "Genome Fraction", 3)
dt = formatPercentage(dt, "Hyper Fold Enrichment", 3)
dt
}
server = function(input, output, session) {
output$job_desc = renderPrint({
show(object)
cat("\n")
cat("Cutoff for adjusted p-values (from Binomial test): ", input$padj_cutoff, "\n", sep = "")
cat("Cutoff for observed region hits: ", input$observed_hits_cutoff, "\n", sep = "")
})
observe({
suppressWarnings(padj_cutoff <- as.numeric(input$padj_cutoff))
suppressWarnings(observed_hits_cutoff <- as.numeric(input$observed_hits_cutoff))
output$volcano_plot = renderPlot({
plotVolcano(object, min_region_hits = observed_hits_cutoff, x_values = input$volcano_x_values, y_values = input$volcano_y_values)
})
if(is.na(padj_cutoff) || is.na(observed_hits_cutoff)) {
output[["error"]] = renderUI({
HTML("<p class='error message'>Wrong format for cutoffs.</p>")
})
output[["enrichment_table"]] = renderUI({
HTML("")
})
return(NULL)
}
tb = getEnrichmentTable(object, min_region_hits = observed_hits_cutoff)
tb = tb[tb$p_adjust <= padj_cutoff, , drop = FALSE]
if(nrow(tb) == 0) {
output[["error"]] = renderUI({
HTML("");
})
output[["enrichment_table"]] = renderUI({
HTML("<p class='message'>No significant term under current cutoffs.</p>")
})
} else {
output[["error"]] = renderUI({
HTML("");
})
output[["enrichment_table"]] = renderUI({
div(
HTML(qq("<h3>Enrichment table (@{nrow(tb)} significant terms)</h3>")),
HTML(qq("<pre>getEnrichmentTable(@{obj_name})</pre>")),
format_table(tb)
)
})
}
})
observeEvent(input$select_term, {
term = input$select_term
tb = getRegionGeneAssociations(object, term_id = term)
tb = as.data.frame(tb)
colnames(tb) = c("Chromosome", "Start", "End", "Width", "Strand", "Annotated Genes", "Distance to TSSs")
tb = tb[, -5]
showModal(modalDialog(
title = qq("Region-gene associations for term: @{term}"),
HTML(qq("<pre>plotRegionGeneAssociations(@{obj_name}, term_id = '@{term}')</pre>")),
plotOutput(outputId = "select_term_plot", width = "1000px", height= "400px"),
hr(),
HTML(qq("<pre>getRegionGeneAssociations(@{obj_name}, term_id = '@{term}')</pre>")),
renderDT(datatable(tb, escape = FALSE, rownames = FALSE, selection = 'none',
options = list(searching = FALSE))),
easyClose = TRUE,
size = "l"
))
})
output$select_term_plot = renderPlot({
term = input$select_term
plotRegionGeneAssociations(object, term_id = term)
})
output$global_plot = renderPlot({
plotRegionGeneAssociations(object)
}, res = 100)
}
shinyApp(ui, server)
})
jokergoo/rGREAT documentation built on March 28, 2024, 5:31 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
# == title
# Shiny app on the GreatJob object
#
# == param
# -object The ``GreatJob`` object returned by `submitGreatJob`.
#
# == value
# A shiny app object.
#
# == example
# if(FALSE) {
# # pseudo code
# job = submitGreatJob(...)
# shinyReport(job)
# }
setMethod(f = "shinyReport",
signature = "GreatJob",
definition = function(object) {
obj_name = "object"
job = object
all_ontologies = availableOntologies(job)
message(qq("* download @{length(all_ontologies)} enrichment tables from GREAT server (tables will be cached)."))
tbl = getEnrichmentTables(job, ontology = all_ontologies, verbose = FALSE)
ui = fluidPage(
h2("Report for online GREAT analysis"),
h3("Job description"),
verbatimTextOutput(outputId = "job_desc"),
HTML(qq("<h3>Global region-gene associations</h3>")),
HTML(qq("<pre>plotRegionGeneAssociations(@{obj_name})</pre>")),
plotOutput(outputId = "global_plot", width = "1000px", height= "400px"),
hr(),
h3("Global controls"),
div(id = "global_control",
tags$table(tags$tr(
tags$td(textInput("padj_cutoff", label = "Cutoff for adjusted p-values (from Binomial test)", value = "0.05", width = 380)),
tags$td(textInput("observed_hits_cutoff", label = "Cutoff for observed region hits", value = "5", width=400))
))
),
hr(),
htmlOutput(outputId = "error"),
htmlOutput(outputId = "enrichment_table"),
hr(),
HTML("<p>Generated by <a href='https://bioconductor.org/packages/rGREAT/' target='_blank'>rGREAT package</a>.</p>"),
tags$style(
"pre {
width:800px;
padding:20px;
}
#global_control td {padding-right:20px;}
.tooltip-inner {
max-width:600px;
background-color: #f5f5f5;
border: 1px solid #cccccc;
color: black;
font-size:13px;
padding: 6px 15px;
}
.fake_link {
color: #337ab7;
text-decoration: none;
}
.fake_link:hover {
ext-decoration: underline;
cursor: pointer;
}
.container-fluid {
margin-left:20px;
margin-right:20px
}
.error {
color:red;
}
"
)
)
format_table = function(tb, onto) {
tb2 = tb[, c("ID", "name", "Binom_Raw_PValue", "Binom_Adjp_BH", "Binom_Fold_Enrichment", "Binom_Observed_Region_Hits", "Binom_Genome_Fraction",
"Hyper_Raw_PValue", "Hyper_Adjp_BH", "Hyper_Observed_Gene_Hits", "Hyper_Total_Genes")]
BASE_URL = BASE_URL_LIST[job@parameters$version]
tb2[, "name"] = qq("<a href='@{BASE_URL}/showTermDetails.php?termId=@{tb2[, 'ID']}&ontoName=@{job@job_env$ONTOLOGY_KEYS[onto]}&ontoUiName=@{onto}&sessionName=@{job@job_env$id}&species=@{job@parameters$genome}&foreName=@{basename(param(job, 'f_bed'))}&backName=@{basename(param(job, 'f_bed_bg'))}&table=region' target='_blank'>@{tb2[, 'name']}</a>", collapse = FALSE)
colnames(tb2) = c("ID", "Term Name", "Binom Raw P-value", "Binom Adjusted P-value", "Binom Fold Enrichment", "Binom Observed Region Hits", "Genome Fraction",
"Hyper Raw P-value", "Hyper Adjusted P-value", "Hyper Observed Gene Hits", "Hyper Total Genes in Gene Set")
colnames(tb2) = gsub("_", " ", colnames(tb2))
dt = datatable(tb2[, -1], escape = FALSE, rownames = FALSE, selection = 'none', width = "100%", height = "auto",
options = list(searching = FALSE, rowCallback = JS(
'function(row, data) {
$(this.api().cell(row, 1).node()).html(data[1].toExponential(3));
$(this.api().cell(row, 2).node()).html(data[2].toExponential(3));
$(this.api().cell(row, 6).node()).html(data[5].toExponential(3));
$(this.api().cell(row, 7).node()).html(data[6].toExponential(3));
}
')))
dt = formatRound(dt, "Binom Fold Enrichment", 3)
dt = formatPercentage(dt, "Genome Fraction", 3)
dt
}
server = function(input, output, session) {
output$job_desc = renderPrint({
show(job)
cat("Cutoff for adjusted p-values (from Binomial test): ", input$padj_cutoff, "\n", sep = "")
cat("Cutoff for observed region hits: ", input$observed_hits_cutoff, "\n", sep = "")
})
observe({
suppressWarnings(padj_cutoff <- as.numeric(input$padj_cutoff))
suppressWarnings(observed_hits_cutoff <- as.numeric(input$observed_hits_cutoff))
if(is.na(padj_cutoff) || is.na(observed_hits_cutoff)) {
output[["error"]] = renderUI({
HTML("<p class='error message'>Wrong format for cutoffs.</p>")
})
output[["enrichment_table"]] = renderUI({
HTML("")
})
return(NULL)
}
all_ontologies = availableOntologies(job)
for(nm in all_ontologies) {
nm2 = gsub(" ", "_", nm)
code = qq("
output[['volcano_plot_@{nm2}']] = renderPlot({
plotVolcano(job, ontology = '@{nm}', min_region_hits = observed_hits_cutoff, x_values = input[['volcano_x_values_@{nm2}']], y_values = input[['volcano_y_values_@{nm2}']], main='Volcano plot for @{nm}')
})
")
eval(parse(text = code))
}
tbl = getEnrichmentTables(job, ontology = all_ontologies, verbose = FALSE)
tbl = lapply(tbl, function(tb) {
tb = tb[tb[, "Binom_Observed_Region_Hits"] >= observed_hits_cutoff, , drop = FALSE]
tb$Binom_Adjp_BH = p.adjust(tb$Binom_Raw_PValue, "BH")
tb$Hyper_Adjp_BH = p.adjust(tb$Hyper_Raw_PValue, "BH")
tb = tb[tb[, "Binom_Adjp_BH"] <= padj_cutoff, , drop = FALSE]
tb
})
tbl = tbl[sapply(tbl, nrow) > 0]
if(length(tbl) == 0) {
output[["error"]] = renderUI({
HTML("");
})
output[["enrichment_table"]] = renderUI({
HTML("<p class='message'>No significant term under current cutoffs.</p>")
})
} else {
ui_list = list()
for(i in seq_along(tbl)) {
onto_name = names(tbl)[i]
onto_name2 = gsub(" ", "_", onto_name)
ui_list[[i]] = div(
tabsetPanel(type = "tabs",
tabPanel("Enrichment table",
HTML(qq("<h3>@{onto_name} (@{nrow(tbl[[i]])} significant terms)</h3>")),
HTML(qq("<pre>getEnrichmentTable(job, ontology = '@{names(tbl)[i]}')</pre>")),
format_table(tbl[[i]], names(tbl)[i])
),
tabPanel("Volcano plot",
tags$br(),
HTML(qq("<pre>plotVolcano(@{obj_name}, ontology = '@{onto_name}')</pre>")),
radioButtons(qq("volcano_x_values_@{onto_name2}"), "Values on x-axis",
c("Fold enrichment: log2(obs/exp)" = "fold_enrichment",
"z-score: (obs-exp)/sd" = "z-score"),
selected = "fold_enrichment",
inline = TRUE
),
radioButtons(qq("volcano_y_values_@{onto_name2}"), "Values on y-axis",
c("Raw p-values" = "p_value",
"Adjusted p-values" = "p_adjust"),
selected = "p_value",
inline = TRUE
),
plotOutput(outputId = qq("volcano_plot_@{onto_name2}"), width="600px", height = "600px")
)
),
if(i < length(tbl)) hr() else NULL
)
}
ui_list[[i + 1]] = HTML("<script>$('#enrichment_table h3 a').tooltip();</script>")
ui_list$class = "ind_table"
output[["error"]] = renderUI({
HTML("");
})
output[["enrichment_table"]] = renderUI({
do.call("div", ui_list)
})
}
})
output$global_plot = renderPlot({
plotRegionGeneAssociations(job)
}, res = 100)
}
shinyApp(ui, server)
})
# == title
# Shiny app on the GreatObject object
#
# == param
# -object The ``GreatObject`` object returned by `great`.
#
# == value
# A shiny app object.
#
# == example
# if(FALSE) {
# # pseudo code
# obj = great(...)
# shinyReport(obj)
# }
setMethod(f = "shinyReport",
signature = "GreatObject",
definition = function(object) {
obj_name = "object"
object = object
ui = fluidPage(
h2("Report for local GREAT analysis"),
h3("Job description"),
verbatimTextOutput(outputId = "job_desc"),
HTML(qq("<h3>Global region-gene associations</h3>")),
HTML(qq("<pre>plotRegionGeneAssociationGraphs(@{obj_name})</pre>")),
plotOutput(outputId = "global_plot", width = "1000px", height= "400px"),
hr(),
h3("Global controls"),
div(id = "global_control",
tags$table(tags$tr(
tags$td(textInput("padj_cutoff", label = "Cutoff for adjusted p-values (from Binomial test)", value = "0.05", width = 380)),
tags$td(textInput("observed_hits_cutoff", label = "Cutoff for observed region hits", value = "5", width=400))
))
),
hr(),
tabsetPanel(type = "tabs",
tabPanel("Enrichment table",
htmlOutput(outputId = "error"),
htmlOutput(outputId = "enrichment_table")
),
tabPanel("Volcano plot",
tags$br(),
HTML(qq("<pre>plotVolcano(@{obj_name})</pre>")),
radioButtons("volcano_x_values", "Values on x-axis",
c("Fold enrichment: log2(obs/exp)" = "fold_enrichment",
"z-score: (obs-exp)/sd" = "z-score"),
selected = "fold_enrichment",
inline = TRUE
),
radioButtons("volcano_y_values", "Values on y-axis",
c("Raw p-values" = "p_value",
"Adjusted p-values" = "p_adjust"),
selected = "p_value",
inline = TRUE
),
plotOutput(outputId = "volcano_plot", width="600px", height = "600px")
)
),
tags$style(
"pre {
width:800px;
padding:20px;
}
#global_control td {
padding-right:20px;
}
.tooltip-inner {
max-width:400px;
background-color: #f5f5f5;
border: 1px solid #cccccc;
color: black;
font-size:13px;
padding: 6px 15px;
}
.fake_link {
color: #337ab7;
text-decoration: none;
}
.fake_link:hover {
ext-decoration: underline;
cursor: pointer;
}
.container-fluid {
margin-left:20px;
margin-right:20px
}
.error {
color:red;
}
.message{
padding: 20px 20px;
}
.modal-lg {
width:1100px;
}
"
),
hr(),
HTML("<p>Generated by <a href='https://bioconductor.org/packages/rGREAT/' target='_blank'>rGREAT package</a>.</p>")
)
format_table = function(tb) {
tb$id = qq("<a class='fake_link' onclick=\"Shiny.onInputChange('select_term', '');Shiny.onInputChange('select_term', '@{tb$id}');false;\">@{tb$id}</a>", collapse = FALSE)
if("description" %in% colnames(tb)) {
offset = 1
tb = tb[, c("id", "description", "mean_tss_dist", "p_value", "p_adjust", "fold_enrichment", "observed_region_hits", "genome_fraction", "p_value_hyper", "p_adjust_hyper", "fold_enrichment_hyper", "observed_gene_hits", "gene_set_size")]
colnames(tb) = c("Term Name", "Term Description", "Mean Abs Dist to TSS (bp)", "Binom Raw P-value", "Binom Adjusted P-value", "Binom Fold Enrichment", "Binom Observed Region Hits", "Genome Fraction", "Hyper Raw P-value", "Hyper Adjusted P-value", "Hyper Fold Enrichment", "Observed Gene Hits", "Total Genes in Gene Set")
} else {
offset = 0
tb = tb[, c("id", "mean_tss_dist", "p_value", "p_adjust", "fold_enrichment", "observed_region_hits", "genome_fraction", "p_value_hyper", "p_adjust_hyper", "fold_enrichment_hyper", "observed_gene_hits", "gene_set_size")]
colnames(tb) = c("Term Name", "Mean Abs Dist to TSS (bp)", "Binom Raw P-value", "Binom Adjusted P-value", "Binom Fold Enrichment", "Binom Observed Region Hits", "Genome Fraction", "Hyper Raw P-value", "Hyper Adjusted P-value", "Hyper Fold Enrichment", "Observed Gene Hits", "Total Genes in Gene Set")
}
dt = datatable(tb, escape = FALSE, rownames = FALSE, selection = 'none', width = "100%", height = "auto",
options = list(searching = FALSE, rowCallback = JS(qq(
'function(row, data) {
$(this.api().cell(row, @{2+offset}).node()).html(data[@{2+offset}].toExponential(3));
$(this.api().cell(row, @{3+offset}).node()).html(data[@{3+offset}].toExponential(3));
$(this.api().cell(row, @{7+offset}).node()).html(data[@{7+offset}].toExponential(3));
$(this.api().cell(row, @{8+offset}).node()).html(data[@{8+offset}].toExponential(3));
}
'))))
dt = formatRound(dt, "Binom Fold Enrichment", 3)
dt = formatPercentage(dt, "Genome Fraction", 3)
dt = formatPercentage(dt, "Hyper Fold Enrichment", 3)
dt
}
server = function(input, output, session) {
output$job_desc = renderPrint({
show(object)
cat("\n")
cat("Cutoff for adjusted p-values (from Binomial test): ", input$padj_cutoff, "\n", sep = "")
cat("Cutoff for observed region hits: ", input$observed_hits_cutoff, "\n", sep = "")
})
observe({
suppressWarnings(padj_cutoff <- as.numeric(input$padj_cutoff))
suppressWarnings(observed_hits_cutoff <- as.numeric(input$observed_hits_cutoff))
output$volcano_plot = renderPlot({
plotVolcano(object, min_region_hits = observed_hits_cutoff, x_values = input$volcano_x_values, y_values = input$volcano_y_values)
})
if(is.na(padj_cutoff) || is.na(observed_hits_cutoff)) {
output[["error"]] = renderUI({
HTML("<p class='error message'>Wrong format for cutoffs.</p>")
})
output[["enrichment_table"]] = renderUI({
HTML("")
})
return(NULL)
}
tb = getEnrichmentTable(object, min_region_hits = observed_hits_cutoff)
tb = tb[tb$p_adjust <= padj_cutoff, , drop = FALSE]
if(nrow(tb) == 0) {
output[["error"]] = renderUI({
HTML("");
})
output[["enrichment_table"]] = renderUI({
HTML("<p class='message'>No significant term under current cutoffs.</p>")
})
} else {
output[["error"]] = renderUI({
HTML("");
})
output[["enrichment_table"]] = renderUI({
div(
HTML(qq("<h3>Enrichment table (@{nrow(tb)} significant terms)</h3>")),
HTML(qq("<pre>getEnrichmentTable(@{obj_name})</pre>")),
format_table(tb)
)
})
}
})
observeEvent(input$select_term, {
term = input$select_term
tb = getRegionGeneAssociations(object, term_id = term)
tb = as.data.frame(tb)
colnames(tb) = c("Chromosome", "Start", "End", "Width", "Strand", "Annotated Genes", "Distance to TSSs")
tb = tb[, -5]
showModal(modalDialog(
title = qq("Region-gene associations for term: @{term}"),
HTML(qq("<pre>plotRegionGeneAssociations(@{obj_name}, term_id = '@{term}')</pre>")),
plotOutput(outputId = "select_term_plot", width = "1000px", height= "400px"),
hr(),
HTML(qq("<pre>getRegionGeneAssociations(@{obj_name}, term_id = '@{term}')</pre>")),
renderDT(datatable(tb, escape = FALSE, rownames = FALSE, selection = 'none',
options = list(searching = FALSE))),
easyClose = TRUE,
size = "l"
))
})
output$select_term_plot = renderPlot({
term = input$select_term
plotRegionGeneAssociations(object, term_id = term)
})
output$global_plot = renderPlot({
plotRegionGeneAssociations(object)
}, res = 100)
}
shinyApp(ui, server)
})
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.