johrpan/geposanui
1
0
Fork 0
mirror of https://github.com/johrpan/geposanui.git synced 2025-10-26 11:17:24 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

Reindent code to use just two spaces

Browse source
This commit is contained in:
Elias Projahn 2022-05-26 12:44:09 +02:00
parent 47b8d7a1f0
commit 13b5efc1e3
10 changed files with 1000 additions and 999 deletions
Download patch file Download diff file Expand all files Collapse all files

32
R/app.R
View file

@ -21,23 +21,23 @@ run_app <- function(gene_sets,
locked = FALSE, locked = FALSE,
title = "Gene Position Analysis", title = "Gene Position Analysis",
port = 3464) { port = 3464) {
stopifnot(!is.null(gene_sets) & !is.null(gene_sets[[1]])) stopifnot(!is.null(gene_sets) & !is.null(gene_sets[[1]]))
# These function calls make the required java scripts available. # These function calls make the required java scripts available.
shinyjs::useShinyjs() shinyjs::useShinyjs()
rclipboard::rclipboardSetup() rclipboard::rclipboardSetup()
# Bundle of global options to redue broilerplate. # Bundle of global options to redue broilerplate.
options <- list( options <- list(
gene_sets = gene_sets, gene_sets = gene_sets,
species_sets = species_sets, species_sets = species_sets,
locked = locked, locked = locked,
title = title title = title
) )
# Actually run the app. # Actually run the app.
shiny::runApp( shiny::runApp(
shiny::shinyApp(ui(options), server(options)), shiny::shinyApp(ui(options), server(options)),
port = port port = port
) )
} }

72
R/comparison_editor.R
View file

@ -3,26 +3,26 @@
#' @param options Global application options #' @param options Global application options
#' @noRd #' @noRd
comparison_editor_ui <- function(id, options) { comparison_editor_ui <- function(id, options) {
verticalLayout( verticalLayout(
h3("Comparison"), h3("Comparison"),
selectInput( selectInput(
NS(id, "comparison_genes"), NS(id, "comparison_genes"),
"Comparison genes", "Comparison genes",
choices = c( choices = c(
"None", "None",
"Random genes", "Random genes",
names(options$gene_sets), names(options$gene_sets),
"Customize" "Customize"
) )
), ),
conditionalPanel( conditionalPanel(
condition = sprintf( condition = sprintf(
"input['%s'] == 'Customize'", "input['%s'] == 'Customize'",
NS(id, "comparison_genes") NS(id, "comparison_genes")
), ),
gene_selector_ui(NS(id, "custom_genes")) gene_selector_ui(NS(id, "custom_genes"))
)
) )
)
} }
#' Create a server for the comparison editor. #' Create a server for the comparison editor.
@ -35,23 +35,23 @@ comparison_editor_ui <- function(id, options) {
#' #'
#' @noRd #' @noRd
comparison_editor_server <- function(id, preset, options) { comparison_editor_server <- function(id, preset, options) {
moduleServer(id, function(input, output, session) { moduleServer(id, function(input, output, session) {
custom_gene_ids <- gene_selector_server("custom_genes") custom_gene_ids <- gene_selector_server("custom_genes")
reactive({ reactive({
if (input$comparison_genes == "None") { if (input$comparison_genes == "None") {
NULL NULL
} else if (input$comparison_genes == "Random genes") { } else if (input$comparison_genes == "Random genes") {
preset <- preset() preset <- preset()
gene_pool <- preset$gene_ids gene_pool <- preset$gene_ids
reference_gene_ids <- preset$reference_gene_ids reference_gene_ids <- preset$reference_gene_ids
gene_pool <- gene_pool[!gene_pool %chin% reference_gene_ids] gene_pool <- gene_pool[!gene_pool %chin% reference_gene_ids]
gene_pool[sample(length(gene_pool), length(reference_gene_ids))] gene_pool[sample(length(gene_pool), length(reference_gene_ids))]
} else if (input$comparison_genes == "Customize") { } else if (input$comparison_genes == "Customize") {
custom_gene_ids() custom_gene_ids()
} else { } else {
options$gene_sets[[input$comparison_genes]] options$gene_sets[[input$comparison_genes]]
} }
})
}) })
})
} }

168
R/filters.R
View file

@ -1,68 +1,68 @@
# Construct UI for the filter editor. # Construct UI for the filter editor.
filters_ui <- function(id) { filters_ui <- function(id) {
verticalLayout( verticalLayout(
h3("Filter criteria"), h3("Filter criteria"),
selectInput( selectInput(
NS(id, "method"), NS(id, "method"),
"Filter method", "Filter method",
choices = list( choices = list(
"Percentile" = "percentile", "Percentile" = "percentile",
"Cut-off score" = "score", "Cut-off score" = "score",
"Maximum number of genes" = "rank", "Maximum number of genes" = "rank",
"None" = "none" "None" = "none"
) )
), ),
tabsetPanel( tabsetPanel(
id = NS(id, "sliders"), id = NS(id, "sliders"),
type = "hidden", type = "hidden",
tabPanelBody( tabPanelBody(
value = "percentile", value = "percentile",
sliderInput(
NS(id, "percentile"),
label = "Minimum percentile",
post = "%",
min = 0,
max = 100,
step = 1,
value = 95
)
),
tabPanelBody(
value = "score",
sliderInput(
NS(id, "score"),
label = "Cut-off score",
post = "%",
min = 0,
max = 100,
step = 1,
value = 75
)
),
tabPanelBody(
value = "rank",
sliderInput(
NS(id, "rank"),
label = "Maximum rank",
min = 0,
max = 2000,
step = 10,
value = 1000
)
),
tabPanelBody(
value = "none"
)
),
sliderInput( sliderInput(
NS(id, "distance"), NS(id, "percentile"),
label = "Distance to telomeres", label = "Minimum percentile",
post = " Mbp", post = "%",
min = 0, min = 0,
max = 150, max = 100,
value = c(0, 150) step = 1,
value = 95
) )
),
tabPanelBody(
value = "score",
sliderInput(
NS(id, "score"),
label = "Cut-off score",
post = "%",
min = 0,
max = 100,
step = 1,
value = 75
)
),
tabPanelBody(
value = "rank",
sliderInput(
NS(id, "rank"),
label = "Maximum rank",
min = 0,
max = 2000,
step = 10,
value = 1000
)
),
tabPanelBody(
value = "none"
)
),
sliderInput(
NS(id, "distance"),
label = "Distance to telomeres",
post = " Mbp",
min = 0,
max = 150,
value = c(0, 150)
) )
)
} }
# Construct server for the filter editor. # Construct server for the filter editor.
@ -71,29 +71,29 @@ filters_ui <- function(id) {
# #
# @return A reactive containing the filtered results. # @return A reactive containing the filtered results.
filters_server <- function(id, results) { filters_server <- function(id, results) {
moduleServer(id, function(input, output, session) { moduleServer(id, function(input, output, session) {
observeEvent(input$method, { observeEvent(input$method, {
updateTabsetPanel(session, "sliders", selected = input$method) updateTabsetPanel(session, "sliders", selected = input$method)
})
reactive({
results <- results()
results_prefiltered <- if (input$method == "percentile") {
n_ranks <- nrow(results)
results[rank <= (1 - (input$percentile / 100)) * n_ranks]
} else if (input$method == "score") {
results[score >= input$score / 100]
} else if (input$method == "rank") {
results[rank <= input$rank]
} else {
results
}
results_prefiltered[
distance >= 1000000 * input$distance[1] &
distance <= 1000000 * input$distance[2]
]
})
}) })
reactive({
results <- results()
results_prefiltered <- if (input$method == "percentile") {
n_ranks <- nrow(results)
results[rank <= (1 - (input$percentile / 100)) * n_ranks]
} else if (input$method == "score") {
results[score >= input$score / 100]
} else if (input$method == "rank") {
results[rank <= input$rank]
} else {
results
}
results_prefiltered[
distance >= 1000000 * input$distance[1] &
distance <= 1000000 * input$distance[2]
]
})
})
} }

158
R/gene_selector.R
View file

@ -7,61 +7,61 @@
#' #'
#' @noRd #' @noRd
gene_selector_ui <- function(id, default_gene_ids = NULL) { gene_selector_ui <- function(id, default_gene_ids = NULL) {
named_genes <- geposan::genes[name != ""] named_genes <- geposan::genes[name != ""]
named_genes <- unique(named_genes, by = "name") named_genes <- unique(named_genes, by = "name")
gene_choices <- named_genes$id gene_choices <- named_genes$id
names(gene_choices) <- named_genes$name names(gene_choices) <- named_genes$name
verticalLayout( verticalLayout(
selectInput( selectInput(
NS(id, "identifier_type"), NS(id, "identifier_type"),
"Gene identifiers", "Gene identifiers",
choices = list( choices = list(
"Select from list" = "list", "Select from list" = "list",
"HGNC symbols" = "hgnc", "HGNC symbols" = "hgnc",
"Ensembl gene IDs" = "ensembl" "Ensembl gene IDs" = "ensembl"
) )
),
tabsetPanel(
id = NS(id, "custom_input"),
type = "hidden",
tabPanelBody(
"list",
shinyvs::virtualSelectInput(
NS(id, "selected_genes"),
label = "Select genes",
choices = gene_choices,
multiple = TRUE,
search = TRUE,
selectAllOnlyVisible = TRUE
), ),
tabsetPanel( ),
id = NS(id, "custom_input"), tabPanelBody(
type = "hidden", "hgnc",
tabPanelBody( textAreaInput(
"list", NS(id, "hgnc_names_raw"),
shinyvs::virtualSelectInput( "Enter HGNC symbols",
NS(id, "selected_genes"), value = paste(
label = "Select genes", geposan::genes[
choices = gene_choices, id %chin% default_gene_ids & name != "",
multiple = TRUE, name
search = TRUE, ],
selectAllOnlyVisible = TRUE collapse = "\n"
), ),
), height = "250px"
tabPanelBody(
"hgnc",
textAreaInput(
NS(id, "hgnc_names_raw"),
"Enter HGNC symbols",
value = paste(
geposan::genes[
id %chin% default_gene_ids & name != "",
name
],
collapse = "\n"
),
height = "250px"
)
),
tabPanelBody(
"ensembl",
textAreaInput(
NS(id, "gene_ids_raw"),
"Enter Ensembl gene IDs",
value = paste(default_gene_ids, collapse = "\n"),
height = "250px"
)
)
) )
),
tabPanelBody(
"ensembl",
textAreaInput(
NS(id, "gene_ids_raw"),
"Enter Ensembl gene IDs",
value = paste(default_gene_ids, collapse = "\n"),
height = "250px"
)
)
) )
)
} }
#' Application logic for the gene selector. #' Application logic for the gene selector.
@ -72,33 +72,33 @@ gene_selector_ui <- function(id, default_gene_ids = NULL) {
#' #'
#' @noRd #' @noRd
gene_selector_server <- function(id) { gene_selector_server <- function(id) {
moduleServer(id, function(input, output, session) { moduleServer(id, function(input, output, session) {
observe({ observe({
updateTabsetPanel( updateTabsetPanel(
session, session,
"custom_input", "custom_input",
selected = input$identifier_type selected = input$identifier_type
) )
})
reactive({
gene_ids <- if (input$identifier_type == "list") {
input$selected_genes
} else if (input$identifier_type == "hgnc") {
inputs <- unique(strsplit(input$hgnc_names_raw, "\\s+")[[1]])
inputs <- inputs[inputs != ""]
geposan::genes[name %chin% inputs, id]
} else {
inputs <- unique(strsplit(input$gene_ids_raw, "\\s+")[[1]])
inputs <- inputs[inputs != ""]
geposan::genes[id %chin% inputs, id]
}
if (length(gene_ids > 100)) {
gene_ids[seq_len(100)]
} else {
gene_ids
}
})
}) })
reactive({
gene_ids <- if (input$identifier_type == "list") {
input$selected_genes
} else if (input$identifier_type == "hgnc") {
inputs <- unique(strsplit(input$hgnc_names_raw, "\\s+")[[1]])
inputs <- inputs[inputs != ""]
geposan::genes[name %chin% inputs, id]
} else {
inputs <- unique(strsplit(input$gene_ids_raw, "\\s+")[[1]])
inputs <- inputs[inputs != ""]
geposan::genes[id %chin% inputs, id]
}
if (length(gene_ids > 100)) {
gene_ids[seq_len(100)]
} else {
gene_ids
}
})
})
} }

156
R/input_page.R
View file

@ -4,35 +4,35 @@
#' #'
#' @noRd #' @noRd
input_page_ui <- function(id, options) { input_page_ui <- function(id, options) {
sidebarLayout( sidebarLayout(
sidebarPanel( sidebarPanel(
width = 3, width = 3,
preset_editor_ui(NS(id, "preset_editor"), options), preset_editor_ui(NS(id, "preset_editor"), options),
tabsetPanel( tabsetPanel(
id = NS(id, "apply_panel"), id = NS(id, "apply_panel"),
type = "hidden", type = "hidden",
tabPanelBody(value = "hide"), tabPanelBody(value = "hide"),
tabPanelBody( tabPanelBody(
value = "show", value = "show",
actionButton( actionButton(
NS(id, "apply_button"), NS(id, "apply_button"),
"Perform analysis", "Perform analysis",
class = "btn-primary", class = "btn-primary",
style = "margin-top: 16px; margin-bottom: 16px" style = "margin-top: 16px; margin-bottom: 16px"
) )
)
),
comparison_editor_ui(NS(id, "comparison_editor"), options)
),
mainPanel(
width = 9,
plotly::plotlyOutput(
NS(id, "positions_plot"),
width = "100%",
height = "600px"
)
) )
),
comparison_editor_ui(NS(id, "comparison_editor"), options)
),
mainPanel(
width = 9,
plotly::plotlyOutput(
NS(id, "positions_plot"),
width = "100%",
height = "600px"
)
) )
)
} }
#' Application logic for the input page. #' Application logic for the input page.
@ -45,61 +45,61 @@ input_page_ui <- function(id, options) {
#' #'
#' @noRd #' @noRd
input_page_server <- function(id, options) { input_page_server <- function(id, options) {
moduleServer(id, function(input, output, session) { moduleServer(id, function(input, output, session) {
current_preset <- reactiveVal(geposan::preset(options$gene_sets[[1]])) current_preset <- reactiveVal(geposan::preset(options$gene_sets[[1]]))
potential_preset <- preset_editor_server("preset_editor", options) potential_preset <- preset_editor_server("preset_editor", options)
comparison_gene_ids <- comparison_editor_server( comparison_gene_ids <- comparison_editor_server(
"comparison_editor", "comparison_editor",
current_preset, current_preset,
options options
) )
output$positions_plot <- plotly::renderPlotly({ output$positions_plot <- plotly::renderPlotly({
preset <- potential_preset() preset <- potential_preset()
if (is.null(preset)) { if (is.null(preset)) {
NULL NULL
} else { } else {
gene_sets <- list("Reference genes" = preset$reference_gene_ids) gene_sets <- list("Reference genes" = preset$reference_gene_ids)
comparison_gene_ids <- comparison_gene_ids() comparison_gene_ids <- comparison_gene_ids()
if (length(comparison_gene_ids) >= 1) { if (length(comparison_gene_ids) >= 1) {
gene_sets <- c( gene_sets <- c(
gene_sets, gene_sets,
list("Comparison genes" = comparison_gene_ids) list("Comparison genes" = comparison_gene_ids)
) )
} }
geposan::plot_positions(preset$species_ids, gene_sets) geposan::plot_positions(preset$species_ids, gene_sets)
} }
})
observe({
if (is.null(potential_preset()) |
rlang::hash(potential_preset()) ==
rlang::hash(current_preset())) {
updateTabsetPanel(
session,
"apply_panel",
selected = "hide"
)
} else {
updateTabsetPanel(
session,
"apply_panel",
selected = "show"
)
}
})
observe({
current_preset(potential_preset())
}) |> bindEvent(input$apply_button)
list(
preset = current_preset,
comparison_gene_ids = comparison_gene_ids
)
}) })
observe({
if (is.null(potential_preset()) |
rlang::hash(potential_preset()) ==
rlang::hash(current_preset())) {
updateTabsetPanel(
session,
"apply_panel",
selected = "hide"
)
} else {
updateTabsetPanel(
session,
"apply_panel",
selected = "show"
)
}
})
observe({
current_preset(potential_preset())
}) |> bindEvent(input$apply_button)
list(
preset = current_preset,
comparison_gene_ids = comparison_gene_ids
)
})
} }

246
R/methods.R
View file

@ -1,47 +1,47 @@
# Construct UI for the methods editor. # Construct UI for the methods editor.
methods_ui <- function(id) { methods_ui <- function(id) {
verticalLayout( verticalLayout(
h3("Methods"), h3("Methods"),
selectInput( selectInput(
NS(id, "optimization_genes"), NS(id, "optimization_genes"),
"Genes to optimize for", "Genes to optimize for",
choices = list( choices = list(
"Reference genes" = "reference", "Reference genes" = "reference",
"Comparison genes" = "comparison" "Comparison genes" = "comparison"
) )
),
selectInput(
NS(id, "optimization_target"),
"Optimization target",
choices = list(
"Mean rank" = "mean",
"Median rank" = "median",
"First rank" = "min",
"Last rank" = "max",
"Customize weights" = "custom"
)
),
lapply(methods, function(method) {
verticalLayout(
checkboxInput(
NS(id, method$id),
span(
method$description,
class = "control-label"
),
value = TRUE
), ),
selectInput( sliderInput(
NS(id, "optimization_target"), NS(id, sprintf("%s_weight", method$id)),
"Optimization target", NULL,
choices = list( min = -1.0,
"Mean rank" = "mean", max = 1.0,
"Median rank" = "median", step = 0.01,
"First rank" = "min", value = 1.0
"Last rank" = "max", )
"Customize weights" = "custom" )
) })
), )
lapply(methods, function(method) {
verticalLayout(
checkboxInput(
NS(id, method$id),
span(
method$description,
class = "control-label"
),
value = TRUE
),
sliderInput(
NS(id, sprintf("%s_weight", method$id)),
NULL,
min = -1.0,
max = 1.0,
step = 0.01,
value = 1.0
)
)
})
)
} }
# Construct server for the methods editor. # Construct server for the methods editor.
@ -50,89 +50,89 @@ methods_ui <- function(id) {
# #
# @return A reactive containing the weighted results. # @return A reactive containing the weighted results.
methods_server <- function(id, analysis, comparison_gene_ids) { methods_server <- function(id, analysis, comparison_gene_ids) {
moduleServer(id, function(input, output, session) { moduleServer(id, function(input, output, session) {
# Observe each method's enable button and synchronise the slider state. # Observe each method's enable button and synchronise the slider state.
lapply(methods, function(method) { lapply(methods, function(method) {
observeEvent(input[[method$id]], { observeEvent(input[[method$id]], {
shinyjs::toggleState( shinyjs::toggleState(
sprintf("%s_weight", method$id), sprintf("%s_weight", method$id),
condition = input[[method$id]] condition = input[[method$id]]
)
})
shinyjs::onclick(sprintf("%s_weight", method$id), {
updateSelectInput(
session,
"optimization_target",
selected = "custom"
)
})
})
# This reactive will always contain the currently selected optimization
# gene IDs in a normalized form.
optimization_gene_ids <- reactive({
gene_ids <- if (input$optimization_genes == "comparison") {
comparison_gene_ids()
} else {
analysis()$preset$reference_gene_ids
}
sort(unique(gene_ids))
})
# This reactive will always contain the optimal weights according to
# the selected parameters.
optimal_weights <- reactive({
withProgress(message = "Optimizing weights", {
setProgress(0.2)
included_methods <- NULL
for (method in methods) {
if (input[[method$id]]) {
included_methods <- c(included_methods, method$id)
}
}
geposan::optimal_weights(
analysis(),
included_methods,
optimization_gene_ids(),
target = input$optimization_target
)
})
}) |> bindCache(
analysis(),
optimization_gene_ids(),
sapply(methods, function(method) input[[method$id]]),
input$optimization_target
) )
})
reactive({ shinyjs::onclick(sprintf("%s_weight", method$id), {
weights <- NULL updateSelectInput(
session,
if (length(optimization_gene_ids()) < 1 | "optimization_target",
input$optimization_target == "custom") { selected = "custom"
for (method in methods) { )
if (input[[method$id]]) { })
weight <- input[[sprintf("%s_weight", method$id)]]
weights[[method$id]] <- weight
}
}
} else {
weights <- optimal_weights()
for (method_id in names(weights)) {
updateSliderInput(
session,
sprintf("%s_weight", method_id),
value = weights[[method_id]]
)
}
}
geposan::ranking(analysis(), weights)
})
}) })
# This reactive will always contain the currently selected optimization
# gene IDs in a normalized form.
optimization_gene_ids <- reactive({
gene_ids <- if (input$optimization_genes == "comparison") {
comparison_gene_ids()
} else {
analysis()$preset$reference_gene_ids
}
sort(unique(gene_ids))
})
# This reactive will always contain the optimal weights according to
# the selected parameters.
optimal_weights <- reactive({
withProgress(message = "Optimizing weights", {
setProgress(0.2)
included_methods <- NULL
for (method in methods) {
if (input[[method$id]]) {
included_methods <- c(included_methods, method$id)
}
}
geposan::optimal_weights(
analysis(),
included_methods,
optimization_gene_ids(),
target = input$optimization_target
)
})
}) |> bindCache(
analysis(),
optimization_gene_ids(),
sapply(methods, function(method) input[[method$id]]),
input$optimization_target
)
reactive({
weights <- NULL
if (length(optimization_gene_ids()) < 1 |
input$optimization_target == "custom") {
for (method in methods) {
if (input[[method$id]]) {
weight <- input[[sprintf("%s_weight", method$id)]]
weights[[method$id]] <- weight
}
}
} else {
weights <- optimal_weights()
for (method_id in names(weights)) {
updateSliderInput(
session,
sprintf("%s_weight", method_id),
value = weights[[method_id]]
)
}
}
geposan::ranking(analysis(), weights)
})
})
} }

178
R/preset_editor.R
View file

@ -7,63 +7,63 @@
#' #'
#' @noRd #' @noRd
preset_editor_ui <- function(id, options) { preset_editor_ui <- function(id, options) {
species_choices <- c("All species", names(options$species_sets)) species_choices <- c("All species", names(options$species_sets))
gene_choices <- names(options$gene_sets) gene_choices <- names(options$gene_sets)
if (!options$locked) {
species_choices <- c(species_choices, "Customize")
gene_choices <- c(gene_choices, "Customize")
}
verticalLayout(
h3("Inputs"),
selectInput(
NS(id, "species"),
"Species to include",
choices = species_choices
),
if (!options$locked) { if (!options$locked) {
species_choices <- c(species_choices, "Customize") conditionalPanel(
gene_choices <- c(gene_choices, "Customize") condition = sprintf(
"input['%s'] == 'Customize'",
NS(id, "species")
),
selectizeInput(
inputId = NS(id, "custom_species"),
label = "Select input species",
choices = NULL,
multiple = TRUE
),
)
},
selectInput(
NS(id, "reference_genes"),
"Reference genes",
choices = gene_choices
),
if (!options$locked) {
conditionalPanel(
condition = sprintf(
"input['%s'] == 'Customize'",
NS(id, "reference_genes")
),
gene_selector_ui(NS(id, "custom_genes"))
)
},
if (options$locked) {
HTML(paste0(
"This instance prohibits performing custom analyses ",
"to reduce resource usage. Normally, it is possible ",
"to use this web application for analyzing any set of ",
"reference genes to find patterns in their ",
"chromosomal positions. If you would like to apply ",
"this method for your own research, see ",
"<a href=\"https://code.johrpan.de/johrpan/geposanui/src/",
"branch/main/README.md\" target=\"_blank\">this page</a> for ",
"more information."
))
} }
)
verticalLayout(
h3("Inputs"),
selectInput(
NS(id, "species"),
"Species to include",
choices = species_choices
),
if (!options$locked) {
conditionalPanel(
condition = sprintf(
"input['%s'] == 'Customize'",
NS(id, "species")
),
selectizeInput(
inputId = NS(id, "custom_species"),
label = "Select input species",
choices = NULL,
multiple = TRUE
),
)
},
selectInput(
NS(id, "reference_genes"),
"Reference genes",
choices = gene_choices
),
if (!options$locked) {
conditionalPanel(
condition = sprintf(
"input['%s'] == 'Customize'",
NS(id, "reference_genes")
),
gene_selector_ui(NS(id, "custom_genes"))
)
},
if (options$locked) {
HTML(paste0(
"This instance prohibits performing custom analyses ",
"to reduce resource usage. Normally, it is possible ",
"to use this web application for analyzing any set of ",
"reference genes to find patterns in their ",
"chromosomal positions. If you would like to apply ",
"this method for your own research, see ",
"<a href=\"https://code.johrpan.de/johrpan/geposanui/src/",
"branch/main/README.md\" target=\"_blank\">this page</a> for ",
"more information."
))
}
)
} }
#' Application logic for the preset editor. #' Application logic for the preset editor.
@ -76,45 +76,45 @@ preset_editor_ui <- function(id, options) {
#' #'
#' @noRd #' @noRd
preset_editor_server <- function(id, options) { preset_editor_server <- function(id, options) {
moduleServer(id, function(input, output, session) { moduleServer(id, function(input, output, session) {
custom_gene_ids <- if (!options$locked) { custom_gene_ids <- if (!options$locked) {
species_choices <- geposan::species$id species_choices <- geposan::species$id
names(species_choices) <- geposan::species$name names(species_choices) <- geposan::species$name
updateSelectizeInput( updateSelectizeInput(
session, session,
"custom_species", "custom_species",
choices = species_choices, choices = species_choices,
server = TRUE server = TRUE
) )
gene_selector_server("custom_genes") gene_selector_server("custom_genes")
} else { } else {
NULL NULL
} }
reactive({ reactive({
reference_gene_ids <- if (input$reference_genes == "Customize") { reference_gene_ids <- if (input$reference_genes == "Customize") {
custom_gene_ids() custom_gene_ids()
} else { } else {
options$gene_sets[[input$reference_genes]] options$gene_sets[[input$reference_genes]]
} }
species_ids <- if (input$species == "All species") { species_ids <- if (input$species == "All species") {
geposan::species$id geposan::species$id
} else if (input$species == "Customize") { } else if (input$species == "Customize") {
input$custom_species input$custom_species
} else { } else {
options$species_sets[[input$species]] options$species_sets[[input$species]]
} }
tryCatch( tryCatch(
geposan::preset( geposan::preset(
reference_gene_ids, reference_gene_ids,
species_ids = species_ids species_ids = species_ids
), ),
error = function(err) NULL error = function(err) NULL
) )
})
}) })
})
} }

193
R/results.R
View file

@ -1,20 +1,20 @@
#' Construct UI for the detailed results panel. #' Construct UI for the detailed results panel.
#' @noRd #' @noRd
results_ui <- function(id) { results_ui <- function(id) {
verticalLayout( verticalLayout(
div( div(
style = "margin-top: 16px", style = "margin-top: 16px",
splitLayout( splitLayout(
cellWidths = "auto", cellWidths = "auto",
uiOutput(NS(id, "copy")), uiOutput(NS(id, "copy")),
downloadButton(NS(id, "download"), "Download CSV") downloadButton(NS(id, "download"), "Download CSV")
) )
), ),
div( div(
style = "margin-top: 16px", style = "margin-top: 16px",
DT::DTOutput(NS(id, "genes")) DT::DTOutput(NS(id, "genes"))
)
) )
)
} }
#' Server for the detailed results panel. #' Server for the detailed results panel.
@ -24,92 +24,93 @@ results_ui <- function(id) {
#' #'
#' @noRd #' @noRd
results_server <- function(id, filtered_results) { results_server <- function(id, filtered_results) {
moduleServer(id, function(input, output, session) { moduleServer(id, function(input, output, session) {
output$copy <- renderUI({ output$copy <- renderUI({
results <- filtered_results() results <- filtered_results()
gene_ids <- results[, gene] gene_ids <- results[, gene]
names <- results[name != "", name] names <- results[name != "", name]
genes_text <- paste(gene_ids, collapse = "\n") genes_text <- paste(gene_ids, collapse = "\n")
names_text <- paste(names, collapse = "\n") names_text <- paste(names, collapse = "\n")
splitLayout( splitLayout(
cellWidths = "auto", cellWidths = "auto",
rclipboard::rclipButton( rclipboard::rclipButton(
"copy_ids_button", "copy_ids_button",
"Copy gene IDs", "Copy gene IDs",
genes_text, genes_text,
icon = icon("clipboard") icon = icon("clipboard")
), ),
rclipboard::rclipButton( rclipboard::rclipButton(
"copy_names_button", "copy_names_button",
"Copy gene names", "Copy gene names",
names_text, names_text,
icon = icon("clipboard") icon = icon("clipboard")
)
)
})
columns <- c(
"rank",
"gene",
"name",
"chromosome",
"distance",
method_ids,
"score",
"percentile"
) )
)
column_names <- c(
"",
"Gene",
"",
"Chromosome",
"Distance",
method_names,
"Score",
"Percentile"
)
output_data <- reactive({
filtered_results()[, ..columns][,
distance := paste0(
format(
round(distance / 1000000, digits = 2),
nsmall = 2,
),
" Mbp"
)
]
})
output$download <- downloadHandler(
filename = "geposan_filtered_results.csv",
content = function(file) {
fwrite(output_data(), file = file)
},
contentType = "text/csv"
)
output$genes <- DT::renderDT({
dt <- DT::datatable(
output_data(),
rownames = FALSE,
colnames = column_names,
options = list(
rowCallback = js_link,
columnDefs = list(list(visible = FALSE, targets = 2)),
pageLength = 25
)
)
DT::formatPercentage(
dt,
c(method_ids, "score", "percentile"),
digits = 2
)
})
}) })
columns <- c(
"rank",
"gene",
"name",
"chromosome",
"distance",
method_ids,
"score",
"percentile"
)
column_names <- c(
"",
"Gene",
"",
"Chromosome",
"Distance",
method_names,
"Score",
"Percentile"
)
output_data <- reactive({
filtered_results()[, ..columns][
,
distance := paste0(
format(
round(distance / 1000000, digits = 2),
nsmall = 2,
),
" Mbp"
)
]
})
output$download <- downloadHandler(
filename = "geposan_filtered_results.csv",
content = function(file) {
fwrite(output_data(), file = file)
},
contentType = "text/csv"
)
output$genes <- DT::renderDT({
dt <- DT::datatable(
output_data(),
rownames = FALSE,
colnames = column_names,
options = list(
rowCallback = js_link,
columnDefs = list(list(visible = FALSE, targets = 2)),
pageLength = 25
)
)
DT::formatPercentage(
dt,
c(method_ids, "score", "percentile"),
digits = 2
)
})
})
} }

556
R/server.R
View file

@ -12,291 +12,291 @@ js_link <- DT::JS("function(row, data) {
#' @param options Global application options. #' @param options Global application options.
#' @noRd #' @noRd
server <- function(options) { server <- function(options) {
function(input, output, session) { function(input, output, session) {
input_reactives <- input_page_server("input_page", options) input_reactives <- input_page_server("input_page", options)
preset <- input_reactives$preset preset <- input_reactives$preset
comparison_gene_ids <- input_reactives$comparison_gene_ids comparison_gene_ids <- input_reactives$comparison_gene_ids
observe({ observe({
updateNavbarPage( updateNavbarPage(
session, session,
"main_page", "main_page",
selected = "Results" selected = "Results"
) )
}) |> bindEvent(preset(), ignoreInit = TRUE) }) |> bindEvent(preset(), ignoreInit = TRUE)
# Compute the results according to the preset. # Compute the results according to the preset.
analysis <- reactive({ analysis <- reactive({
withProgress( withProgress(
message = "Analyzing genes", message = "Analyzing genes",
value = 0.0, value = 0.0,
{ # nolint { # nolint
geposan::analyze( geposan::analyze(
preset(), preset(),
progress = function(progress) { progress = function(progress) {
setProgress(progress) setProgress(progress)
}, },
include_results = FALSE include_results = FALSE
) )
} }
) )
}) |> bindCache(preset()) }) |> bindCache(preset())
# Rank the results. # Rank the results.
ranking <- methods_server("methods", analysis, comparison_gene_ids) ranking <- methods_server("methods", analysis, comparison_gene_ids)
genes_with_distances <- merge( genes_with_distances <- merge(
geposan::genes, geposan::genes,
geposan::distances[species == "hsapiens"], geposan::distances[species == "hsapiens"],
by.x = "id", by.x = "id",
by.y = "gene" by.y = "gene"
)
# Add gene information to the results.
results <- reactive({
merge(
ranking(),
genes_with_distances,
by.x = "gene",
by.y = "id",
sort = FALSE
)
})
# Apply the filters.
results_filtered <- filters_server("filters", results)
# Server for the detailed results panel.
results_server("results", results_filtered)
output$rank_plot <- plotly::renderPlotly({
preset <- preset()
gene_sets <- list("Reference genes" = preset$reference_gene_ids)
comparison_gene_ids <- comparison_gene_ids()
if (length(comparison_gene_ids) >= 1) {
gene_sets <- c(
gene_sets,
list("Comparison genes" = comparison_gene_ids)
) )
}
# Add gene information to the results. geposan::plot_scores(
results <- reactive({ ranking(),
merge( gene_sets = gene_sets,
ranking(), max_rank = results_filtered()[, max(rank)]
genes_with_distances, )
by.x = "gene", })
by.y = "id",
sort = FALSE output$rankings_plot <- plotly::renderPlotly({
preset <- preset()
rankings <- list()
methods <- preset$methods
all <- ranking()
for (method in methods) {
weights <- list()
weights[[method$id]] <- 1.0
rankings[[method$name]] <- geposan::ranking(all, weights)
}
rankings[["Combined"]] <- all
gene_sets <- list("Reference genes" = preset$reference_gene_ids)
comparison_gene_ids <- comparison_gene_ids()
if (length(comparison_gene_ids) >= 1) {
gene_sets <- c(
gene_sets,
list("Comparison genes" = comparison_gene_ids)
)
}
geposan::plot_rankings(rankings, gene_sets)
})
output$comparison_text <- renderUI({
reference <- geposan::compare(
ranking(),
preset()$reference_gene_ids
)
comparison <- if (!is.null(comparison_gene_ids())) {
geposan::compare(ranking(), comparison_gene_ids())
}
num <- function(x, digits) {
format(
round(x, digits = digits),
nsmall = digits,
scientific = FALSE
)
}
comparison_text <- function(name, comparison) {
glue::glue(
"The {name} have a mean score of ",
"<b>{num(comparison$mean_score, 4)}</b> ",
"resulting in a mean rank of ",
"<b>{num(comparison$mean_rank, 1)}</b>. ",
"This corresponds to a percent rank of ",
"<b>{num(100 * comparison$mean_percentile, 2)}%</b>. ",
"A Wilcoxon rank sum test with the hypothesis of higher ",
"than usual scores gives a p-value of ",
"<b>{num(comparison$p_value, 4)}</b>."
)
}
reference_div <- div(HTML(
comparison_text("reference genes", reference)
))
if (!is.null(comparison)) {
div(
reference_div,
div(HTML(comparison_text("comparison genes", comparison)))
)
} else {
reference_div
}
})
output$boxplot <- plotly::renderPlotly({
preset <- preset()
gene_sets <- list("Reference genes" = preset$reference_gene_ids)
comparison_gene_ids <- comparison_gene_ids()
if (length(comparison_gene_ids) >= 1) {
gene_sets <- c(
gene_sets,
list("Comparison genes" = comparison_gene_ids)
)
}
geposan::plot_boxplot(ranking(), gene_sets)
})
output$positions_plot <- plotly::renderPlotly({
preset <- preset()
gene_sets <- list("Reference genes" = preset$reference_gene_ids)
comparison_gene_ids <- comparison_gene_ids()
if (length(comparison_gene_ids) >= 1) {
gene_sets <- c(
gene_sets,
list("Comparison genes" = comparison_gene_ids)
)
}
chromosome <- if (input$positions_plot_chromosome_name == "all") {
NULL
} else {
input$positions_plot_chromosome_name
}
geposan::plot_scores_by_position(
ranking(),
chromosome_name = chromosome,
gene_sets = gene_sets
)
})
gost <- reactive({
withProgress(
message = "Querying g:Profiler",
value = 0.0,
{ # nolint
setProgress(0.2)
gprofiler2::gost(results_filtered()[, gene])
}
)
})
output$gost_plot <- plotly::renderPlotly({
gprofiler2::gostplot(
gost(),
capped = FALSE,
interactive = TRUE
)
})
output$gost_details <- DT::renderDT({
data <- data.table(gost()$result)
setorder(data, p_value)
data[, total_ratio := term_size / effective_domain_size]
data[, query_ratio := intersection_size / query_size]
data <- data[, .(
source,
term_name,
total_ratio,
query_ratio,
p_value
)]
dt <- DT::datatable(
data,
rownames = FALSE,
colnames = c(
"Source",
"Term",
"Total ratio",
"Query ratio",
"p-value"
),
options = list(
pageLength = 25
)
)
dt <- DT::formatRound(dt, "p_value", digits = 4)
dt <- DT::formatPercentage(
dt,
c("total_ratio", "query_ratio"),
digits = 1
)
})
output$disgenet <- DT::renderDT({
withProgress(
message = "Querying DisGeNET",
value = 0.0,
{ # nolint
setProgress(0.2)
gene_names <- results_filtered()[, name]
gene_names <- unique(gene_names[gene_names != ""])
diseases <- suppressMessages(
disgenet2r::disease_enrichment(gene_names)
)
data <- data.table(diseases@qresult)
data <- data[, .(Description, Ratio, BgRatio, pvalue)]
setorder(data, pvalue)
dt <- DT::datatable(
data,
rownames = FALSE,
colnames = c(
"Disease",
"Query ratio",
"Total ratio",
"p-value"
),
options = list(
pageLength = 25
) )
}) )
# Apply the filters. dt <- DT::formatRound(dt, "pvalue", digits = 4)
results_filtered <- filters_server("filters", results)
# Server for the detailed results panel. dt
results_server("results", results_filtered) }
)
output$rank_plot <- plotly::renderPlotly({ })
preset <- preset() }
gene_sets <- list("Reference genes" = preset$reference_gene_ids)
comparison_gene_ids <- comparison_gene_ids()
if (length(comparison_gene_ids) >= 1) {
gene_sets <- c(
gene_sets,
list("Comparison genes" = comparison_gene_ids)
)
}
geposan::plot_scores(
ranking(),
gene_sets = gene_sets,
max_rank = results_filtered()[, max(rank)]
)
})
output$rankings_plot <- plotly::renderPlotly({
preset <- preset()
rankings <- list()
methods <- preset$methods
all <- ranking()
for (method in methods) {
weights <- list()
weights[[method$id]] <- 1.0
rankings[[method$name]] <- geposan::ranking(all, weights)
}
rankings[["Combined"]] <- all
gene_sets <- list("Reference genes" = preset$reference_gene_ids)
comparison_gene_ids <- comparison_gene_ids()
if (length(comparison_gene_ids) >= 1) {
gene_sets <- c(
gene_sets,
list("Comparison genes" = comparison_gene_ids)
)
}
geposan::plot_rankings(rankings, gene_sets)
})
output$comparison_text <- renderUI({
reference <- geposan::compare(
ranking(),
preset()$reference_gene_ids
)
comparison <- if (!is.null(comparison_gene_ids())) {
geposan::compare(ranking(), comparison_gene_ids())
}
num <- function(x, digits) {
format(
round(x, digits = digits),
nsmall = digits,
scientific = FALSE
)
}
comparison_text <- function(name, comparison) {
glue::glue(
"The {name} have a mean score of ",
"<b>{num(comparison$mean_score, 4)}</b> ",
"resulting in a mean rank of ",
"<b>{num(comparison$mean_rank, 1)}</b>. ",
"This corresponds to a percent rank of ",
"<b>{num(100 * comparison$mean_percentile, 2)}%</b>. ",
"A Wilcoxon rank sum test with the hypothesis of higher ",
"than usual scores gives a p-value of ",
"<b>{num(comparison$p_value, 4)}</b>."
)
}
reference_div <- div(HTML(
comparison_text("reference genes", reference)
))
if (!is.null(comparison)) {
div(
reference_div,
div(HTML(comparison_text("comparison genes", comparison)))
)
} else {
reference_div
}
})
output$boxplot <- plotly::renderPlotly({
preset <- preset()
gene_sets <- list("Reference genes" = preset$reference_gene_ids)
comparison_gene_ids <- comparison_gene_ids()
if (length(comparison_gene_ids) >= 1) {
gene_sets <- c(
gene_sets,
list("Comparison genes" = comparison_gene_ids)
)
}
geposan::plot_boxplot(ranking(), gene_sets)
})
output$positions_plot <- plotly::renderPlotly({
preset <- preset()
gene_sets <- list("Reference genes" = preset$reference_gene_ids)
comparison_gene_ids <- comparison_gene_ids()
if (length(comparison_gene_ids) >= 1) {
gene_sets <- c(
gene_sets,
list("Comparison genes" = comparison_gene_ids)
)
}
chromosome <- if (input$positions_plot_chromosome_name == "all") {
NULL
} else {
input$positions_plot_chromosome_name
}
geposan::plot_scores_by_position(
ranking(),
chromosome_name = chromosome,
gene_sets = gene_sets
)
})
gost <- reactive({
withProgress(
message = "Querying g:Profiler",
value = 0.0,
{ # nolint
setProgress(0.2)
gprofiler2::gost(results_filtered()[, gene])
}
)
})
output$gost_plot <- plotly::renderPlotly({
gprofiler2::gostplot(
gost(),
capped = FALSE,
interactive = TRUE
)
})
output$gost_details <- DT::renderDT({
data <- data.table(gost()$result)
setorder(data, p_value)
data[, total_ratio := term_size / effective_domain_size]
data[, query_ratio := intersection_size / query_size]
data <- data[, .(
source,
term_name,
total_ratio,
query_ratio,
p_value
)]
dt <- DT::datatable(
data,
rownames = FALSE,
colnames = c(
"Source",
"Term",
"Total ratio",
"Query ratio",
"p-value"
),
options = list(
pageLength = 25
)
)
dt <- DT::formatRound(dt, "p_value", digits = 4)
dt <- DT::formatPercentage(
dt,
c("total_ratio", "query_ratio"),
digits = 1
)
})
output$disgenet <- DT::renderDT({
withProgress(
message = "Querying DisGeNET",
value = 0.0,
{ # nolint
setProgress(0.2)
gene_names <- results_filtered()[, name]
gene_names <- unique(gene_names[gene_names != ""])
diseases <- suppressMessages(
disgenet2r::disease_enrichment(gene_names)
)
data <- data.table(diseases@qresult)
data <- data[, .(Description, Ratio, BgRatio, pvalue)]
setorder(data, pvalue)
dt <- DT::datatable(
data,
rownames = FALSE,
colnames = c(
"Disease",
"Query ratio",
"Total ratio",
"p-value"
),
options = list(
pageLength = 25
)
)
dt <- DT::formatRound(dt, "pvalue", digits = 4)
dt
}
)
})
}
} }

240
R/ui.R
View file

@ -4,136 +4,136 @@
#' #'
#' @noRd #' @noRd
ui <- function(options) { ui <- function(options) {
div( div(
shinyjs::useShinyjs(), shinyjs::useShinyjs(),
rclipboard::rclipboardSetup(), rclipboard::rclipboardSetup(),
navbarPage( navbarPage(
id = "main_page", id = "main_page",
theme = bslib::bs_theme( theme = bslib::bs_theme(
version = 5, version = 5,
bootswatch = "united", bootswatch = "united",
primary = "#1964bf" primary = "#1964bf"
), ),
title = options$title, title = options$title,
selected = "Results", selected = "Results",
tabPanel( tabPanel(
"Input data", "Input data",
input_page_ui("input_page", options) input_page_ui("input_page", options)
), ),
tabPanel( tabPanel(
"Results", "Results",
sidebarLayout( sidebarLayout(
sidebarPanel( sidebarPanel(
width = 3, width = 3,
methods_ui("methods"), methods_ui("methods"),
filters_ui("filters") filters_ui("filters")
), ),
mainPanel( mainPanel(
width = 9, width = 9,
tabsetPanel( tabsetPanel(
type = "pills", type = "pills",
tabPanel( tabPanel(
title = "Overview", title = "Overview",
div( div(
style = "margin-top: 16px", style = "margin-top: 16px",
plotly::plotlyOutput( plotly::plotlyOutput(
"rank_plot", "rank_plot",
width = "100%", width = "100%",
height = "600px" height = "600px"
) )
)
),
tabPanel(
title = "Methods & Distribution",
div(
style = "margin-top: 16px",
plotly::plotlyOutput(
"rankings_plot",
width = "100%",
height = "600px"
)
)
),
tabPanel(
title = "Comparison",
div(
style = "margin-top: 16px",
htmlOutput("comparison_text"),
plotly::plotlyOutput(
"boxplot",
width = "100%",
height = "600px"
)
)
),
tabPanel(
title = "Scores by position",
div(
style = "margin-top: 16px",
selectInput(
"positions_plot_chromosome_name",
label = NULL,
choices = c(
list("All chromosomes" = "all"),
chromosome_choices()
)
),
plotly::plotlyOutput(
"positions_plot",
width = "100%",
height = "600px"
)
)
),
tabPanel(
title = "Detailed results",
results_ui("results")
),
tabPanel(
title = "g:Profiler",
div(
style = "margin-top: 16px",
plotly::plotlyOutput("gost_plot"),
),
div(
style = "margin-top: 16px",
DT::DTOutput("gost_details")
)
),
tabPanel(
title = "DisGeNET",
div(
style = "margin-top: 16px",
DT::DTOutput("disgenet")
)
)
)
)
) )
), ),
tabPanel( tabPanel(
title = "Publication" title = "Methods & Distribution",
div(
style = "margin-top: 16px",
plotly::plotlyOutput(
"rankings_plot",
width = "100%",
height = "600px"
)
)
),
tabPanel(
title = "Comparison",
div(
style = "margin-top: 16px",
htmlOutput("comparison_text"),
plotly::plotlyOutput(
"boxplot",
width = "100%",
height = "600px"
)
)
),
tabPanel(
title = "Scores by position",
div(
style = "margin-top: 16px",
selectInput(
"positions_plot_chromosome_name",
label = NULL,
choices = c(
list("All chromosomes" = "all"),
chromosome_choices()
)
),
plotly::plotlyOutput(
"positions_plot",
width = "100%",
height = "600px"
)
)
),
tabPanel(
title = "Detailed results",
results_ui("results")
),
tabPanel(
title = "g:Profiler",
div(
style = "margin-top: 16px",
plotly::plotlyOutput("gost_plot"),
),
div(
style = "margin-top: 16px",
DT::DTOutput("gost_details")
)
),
tabPanel(
title = "DisGeNET",
div(
style = "margin-top: 16px",
DT::DTOutput("disgenet")
)
)
) )
)
) )
),
tabPanel(
title = "Publication"
)
) )
)
} }
#' Generate a named list for choosing chromosomes. #' Generate a named list for choosing chromosomes.
#' @noRd #' @noRd
chromosome_choices <- function() { chromosome_choices <- function() {
choices <- purrr::lmap( choices <- purrr::lmap(
unique(geposan::genes$chromosome), unique(geposan::genes$chromosome),
function(name) { function(name) {
choice <- list(name) choice <- list(name)
names(choice) <- paste0( names(choice) <- paste0(
"Chromosome ", "Chromosome ",
name name
) )
choice choice
} }
) )
choices[order(suppressWarnings(sapply(choices, as.integer)))] choices[order(suppressWarnings(sapply(choices, as.integer)))]
} }