Add comparison genes

R/comparison_editor.R

@@ -0,0 +1,85 @@
+# Create a comparison editor.
+comparison_editor_ui <- function(id) {
+    known_genes <- genes[name != ""]
+    gene_choices <- known_genes$id
+    names(gene_choices) <- known_genes$name
+
+    verticalLayout(
+        h3("Comparison"),
+        selectInput(
+            NS(id, "comparison_genes"),
+            "Comparison genes",
+            choices = list(
+                "None" = "none",
+                "Random genes" = "random",
+                "Verified or suggested TPE-OLD genes" = "tpeold",
+                "Only verified TPE-OLD genes" = "verified",
+                "Only suggested TPE-OLD genes" = "suggested",
+                "Customize" = "custom"
+            )
+        ),
+        tabsetPanel(
+            id = NS(id, "custom_comparison_genes_panel"),
+            type = "hidden",
+            tabPanelBody(value = "hide"),
+            tabPanelBody(
+                value = "show",
+                shinyWidgets::pickerInput(
+                    inputId = NS(id, "custom_comparison_genes"),
+                    choices = gene_choices,
+                    options = list(
+                        "actions-box" = TRUE,
+                        "live-search" = TRUE
+                    ),
+                    multiple = TRUE
+                )
+            )
+        )
+    )
+}
+
+# Create a server for the comparison editor.
+#
+# @param id ID for namespacing the inputs and outputs.
+# @param preset A reactive containing the current preset.
+#
+# @return A reactive containing the comparison gene IDs.
+comparison_editor_server <- function(id, preset) {
+    moduleServer(id, function(input, output, session) {
+        observeEvent(input$comparison_genes, {
+            if (input$comparison_genes == "custom") {
+                updateTabsetPanel(
+                    session,
+                    "custom_comparison_genes_panel",
+                    selected = "show"
+                )
+            } else {
+                updateTabsetPanel(
+                    session,
+                    "custom_comparison_genes_panel",
+                    selected = "hide"
+                )
+            }
+        })
+
+        reactive({
+            if (input$comparison_genes == "none") {
+                NULL
+            } else if (input$comparison_genes == "random") {
+                preset <- preset()
+                gene_pool <- preset$gene_ids
+                reference_gene_ids <- preset$reference_gene_ids
+                gene_pool <- gene_pool[!gene_pool %chin% reference_gene_ids]
+                gene_pool[sample(length(gene_pool), length(reference_gene_ids))]
+            } else if (input$comparison_genes == "tpeold") {
+                genes[verified | suggested == TRUE, id]
+            } else if (input$comparison_genes == "verified") {
+                genes[verified == TRUE, id]
+            } else if (input$comparison_genes == "suggested") {
+                genes[suggested == TRUE, id]
+            } else {
+                input$custom_comparison_genes
+            }
+        })
+    })
+}

R/server.R

@@ -45,6 +45,8 @@ server <- function(input, output, session) {
     # Apply the filters.
     results_filtered <- filters_server("filters", results)
 
+    comparison_gene_ids <- comparison_editor_server("comparison_editor", preset)
+
     output$genes <- DT::renderDT({
         columns <- c("rank", "gene", "name", "chromosome", method_ids, "score")
         column_names <- c("", "Gene", "", "Chromosome", method_names, "Score")

R/ui.R

@@ -6,6 +6,7 @@ ui <- fluidPage(
         sidebarPanel(
             width = 3,
             preset_editor_ui("preset_editor"),
+            comparison_editor_ui("comparison_editor"),
             filters_ui("filters"),
             methods_ui("methods")
         ),