Add optimizer and buttons to disable methods

optimize.R

@@ -0,0 +1,34 @@
+#' Find the best weights to rank the data.
+#'
+#' This function ranks the provided data table based on a weighted score
+#' computed from the specified `columns`. It tries to find the optimal weights
+#' that result in a ranking, where the mean rank of the given reference genes
+#' is as high as possible.
+#'
+#' @param data Input data including the columns.
+#' @param colums Columns containing the separate scores between 0.0 and 1.0.
+#' @param reference_gene_ids IDs of the reference genes within the input data.
+#'
+#' @returns Vector of optimal column weights adding up to 1.0.
+optimize_weights <- function(data, columns, reference_gene_ids) {
+    #' Compute the mean rank of the reference genes when applying the weights.
+    mean_rank <- function(weights) {
+        data <- copy(data)
+        data[, score := 0.0]
+
+        for (i in seq_along(columns)) {
+            column <- columns[i]
+            weighted <- weights[i] * data[, ..column]
+            data[, score := score + weighted]
+        }
+
+        setorder(data, -score)
+        data[, rank := .I]
+
+        data[gene %chin% reference_gene_ids, mean(rank)]
+    }
+
+    weights <- optim(rep(1.0, length(columns)), mean_rank)$par
+    total_weight <- sum(weights)
+    weights / total_weight
+}

server.R

@@ -6,6 +6,7 @@ library(rclipboard)
 library(shiny)
 
 source("init.R")
+source("optimize.R")
 source("rank_plot.R")
 source("scatter_plot.R")
 
@@ -18,7 +19,7 @@ js_link <- JS("function(row, data) {
     $('td:eq(1)', row).html(`<a href=\"${url}\" target=\"_blank\">${name}</a>`);
 }")
 
-server <- function(input, output) {
+server <- function(input, output, session) {
     #' Show the customized slider for setting the required number of species.
     output$n_species_slider <- renderUI({
         sliderInput(
@@ -35,6 +36,35 @@ server <- function(input, output) {
         )
     })
 
+    observeEvent(input$optimize_button, {
+        results <- isolate(results())
+        method_ids <- NULL
+
+        for (method in methods) {
+            if (isolate(input[[method$id]])) {
+                method_ids <- c(method_ids, method$id)
+            }
+        }
+
+        reference_gene_ids <- genes[suggested | verified == TRUE, id]
+        weights <- optimize_weights(results, method_ids, reference_gene_ids)
+
+        mapply(function(method_id, weight) {
+            updateSliderInput(
+                session,
+                sprintf("%s_weight", method_id),
+                value = weight * 100
+            )
+        }, method_ids, weights)
+    })
+
+    # Observe each method's enable button.
+    lapply(methods, function(method) {
+        observeEvent(input[[method$id]], {
+            shinyjs::toggleState(sprintf("%s_weight", method$id))
+        }, ignoreInit = TRUE)
+    })
+
     #' Rank the results based on the specified weights. Filter out genes with
     #' too few species but don't apply the cut-off score.
     results <- reactive({
@@ -52,12 +82,14 @@ server <- function(input, output) {
         results[, score := 0.0]
 
         for (method in methods) {
-            weight <- input[[method$id]]
+            if (input[[method$id]]) {
+                weight <- input[[sprintf("%s_weight", method$id)]]
                 total_weight <- total_weight + weight
                 column <- method$id
                 weighted <- weight * results[, ..column]
                 results[, score := score + weighted]
             }
+        }
 
         results[, score := score / total_weight]
 

ui.R

@@ -6,6 +6,7 @@ library(shiny)
 source("methods.R")
 
 ui <- fluidPage(
+    shinyjs::useShinyjs(),
     rclipboardSetup(),
     titlePanel("TPE-OLD candidates"),
     sidebarLayout(
@@ -30,17 +31,33 @@ ui <- fluidPage(
                 step = 1,
                 value = 50
             ),
-            h3("Ranking"),
+            h3("Methods"),
+            actionButton(
+                "optimize_button",
+                "Find optimal weights",
+                icon = icon("check-double")
+            ),
+            div(style = "margin-top: 16px"),
             lapply(methods, function(method) {
-                sliderInput(
+                verticalLayout(
+                    checkboxInput(
                         method$id,
+                        span(
                             method$description,
+                            style = "font-weight: bold"
+                        ),
+                        value = TRUE
+                    ),
+                    sliderInput(
+                        sprintf("%s_weight", method$id),
+                        NULL,
                         post = "%",
                         min = 0,
                         max = 100,
                         step = 1,
                         value = 100
                     )
+                )
             }),
             checkboxInput(
                 "penalize",