Allow filtering by rank

R/filters.R

@@ -0,0 +1,90 @@
+# Construct UI for the filter editor.
+filters_ui <- function(id) {
+    verticalLayout(
+        h3("Filter criteria"),
+        uiOutput(NS(id, "n_species_slider")),
+        checkboxInput(
+            NS(id, "filter_score"),
+            span(
+                "Cut-off score",
+                style = "font-weight: bold"
+            ),
+            value = TRUE
+        ),
+        sliderInput(
+            NS(id, "cut_off_score"),
+            label = NULL,
+            post = "%",
+            min = 0,
+            max = 100,
+            step = 1,
+            value = 50
+        ),
+        checkboxInput(
+            NS(id, "filter_rank"),
+            span(
+                "Maximum number of genes",
+                style = "font-weight: bold"
+            ),
+            value = FALSE
+        ),
+        sliderInput(
+            NS(id, "max_rank"),
+            label = NULL,
+            min = 0,
+            max = 5000,
+            step = 50,
+            value = 2000
+        )
+    )
+}
+
+# Construct server for the filter editor.
+#
+# @param preset A reactive containing the preset to apply.
+#
+# @return A reactive containing the filter values `n_species`, `cut_off_score`
+#   and `max_rank` as well as the name of the filter to apply (`filter`).
+filters_server <- function(id, preset) {
+    moduleServer(id, function(input, output, session) {
+        output$n_species_slider <- renderUI({
+            sliderInput(
+                session$ns("n_species"),
+                "Required number of species per gene",
+                min = 0,
+                max = length(preset()$species_ids),
+                step = 1,
+                value = 10
+            )
+        })
+
+        filter <- reactiveVal("score")
+
+        observeEvent(input$filter_score, {
+            if (input$filter_score) {
+                updateCheckboxInput(session, "filter_rank", value = FALSE)
+                shinyjs::enable("cut_off_score")
+                shinyjs::disable("max_rank")
+                filter("score")
+            }
+        })
+
+        observeEvent(input$filter_rank, {
+            if (input$filter_rank) {
+                updateCheckboxInput(session, "filter_score", value = FALSE)
+                shinyjs::enable("max_rank")
+                shinyjs::disable("cut_off_score")
+                filter("rank")
+            }
+        })
+
+        reactive({
+            list(
+                n_species = input$n_species,
+                filter = filter(),
+                cut_off_score = input$cut_off_score,
+                max_rank = input$max_rank
+            )
+        })
+    })
+}

R/rank_plot.R

@@ -9,11 +9,8 @@
 #
 # @param results Results to display.
 # @param reference_gene_ids IDs of reference genes.
-# @param cutoff Cut-off score.
+# @param max_rank Last rank of the included genes.
-rank_plot <- function(results, reference_gene_ids, cutoff) {
+rank_plot <- function(results, reference_gene_ids, max_rank) {
-    first_not_included_rank <- results[score < cutoff, min(rank)]
-    last_rank <- results[, .N]
-
     plot <- plotly::plot_ly() |> plotly::add_trace(
         data = results,
         x = ~rank,
@@ -35,6 +32,9 @@ rank_plot <- function(results, reference_gene_ids, cutoff) {
         yaxis = list(title = "Score")
     )
 
+    first_not_included_rank <- max_rank + 1
+    last_rank <- results[, .N]
+
     if (first_not_included_rank <= last_rank) {
         plot <- plot |> plotly::layout(
             shapes = list(

R/server.R

@@ -9,18 +9,7 @@ js_link <- DT::JS("function(row, data) {
 
 server <- function(input, output, session) {
     preset <- preset_editor_server("preset_editor")
-
+    filters <- filters_server("filters", preset)
-    # Show the customized slider for setting the required number of species.
-    output$n_species_slider <- renderUI({
-        sliderInput(
-            "n_species",
-            "Required number of species per gene",
-            min = 0,
-            max = length(preset()$species_ids),
-            step = 1,
-            value = 10
-        )
-    })
 
     # Compute the results according to the preset.
     analysis <- reactive({
@@ -54,15 +43,21 @@ server <- function(input, output, session) {
         setkey(genes_n_species, gene)
 
         # Exclude genes with too few species.
-        results[genes_n_species[gene, n_species] >= input$n_species]
+        results[genes_n_species[gene, n_species] >= filters()$n_species]
     })
 
     # Rank the results.
     results <- methods_server("methods", analysis)
 
-    # Apply the cut-off score to the ranked results.
+    # Apply the filters.
     results_filtered <- reactive({
-        results()[score >= input$cutoff / 100]
+        filters <- filters()
+
+        if (filters$filter == "score") {
+            results()[score >= filters$cut_off_score / 100]
+        } else {
+            results()[rank <= filters$max_rank]
+        }
     })
 
     output$genes <- DT::renderDT({
@@ -168,7 +163,7 @@ server <- function(input, output, session) {
         rank_plot(
             results(),
             preset()$reference_gene_ids,
-            input$cutoff / 100
+            results_filtered()[, max(rank)]
         )
     })
 

R/ui.R

@@ -6,17 +6,7 @@ ui <- fluidPage(
         sidebarPanel(
             width = 3,
             preset_editor_ui("preset_editor"),
-            h3("Filter criteria"),
+            filters_ui("filters"),
-            uiOutput("n_species_slider"),
-            sliderInput(
-                "cutoff",
-                "Cut-off score",
-                post = "%",
-                min = 0,
-                max = 100,
-                step = 1,
-                value = 50
-            ),
             methods_ui("methods")
         ),
         mainPanel(