# Construct UI for the methods editor. methods_ui <- function(id) { verticalLayout( h3("Methods"), selectInput( NS(id, "optimization_genes"), "Genes to optimize for", choices = list( "Reference genes" = "reference", "Comparison genes" = "comparison" ) ), selectInput( NS(id, "optimization_target"), "Optimization target", choices = list( "Mean squared error" = "mse", "Mean percentile" = "mean", "Median percentile" = "median", "Worst percentile" = "worst", "Best percentile" = "best", "Customize weights" = "custom" ) ), uiOutput(NS(id, "method_sliders")) ) } # Construct server for the methods editor. # # @param analysis The reactive containing the results to be weighted. # # @return A reactive containing the weighted results. methods_server <- function(id, analysis, comparison_gene_ids) { moduleServer(id, function(input, output, session) { output$method_sliders <- renderUI({ lapply(analysis()$preset$methods, function(method) { verticalLayout( checkboxInput( session$ns(method$id), span( method$description, class = "control-label" ), value = TRUE ), sliderInput( session$ns(sprintf("%s_weight", method$id)), NULL, min = -1.0, max = 1.0, step = 0.01, value = 1.0 ) ) }) }) method_observers <- list() method_listeners <- list() observe({ for (method_observer in method_observers) { destroy(method_observer) } for (method_listener in method_listeners) { shinyjs::removeEvent(method_listener) } method_observers <- lapply(analysis()$preset$methods, function(method) { observeEvent(input[[method$id]], { shinyjs::toggleState( sprintf("%s_weight", method$id), condition = input[[method$id]] ) }) }) method_listeners <- lapply(analysis()$preset$methods, function(method) { shinyjs::onclick(sprintf("%s_weight", method$id), { updateSelectInput( session, "optimization_target", selected = "custom" ) }) }) for (method in analysis()$preset$methods) { method_observer <- method_observers <- c(method_observers, method_observer) method_listener <- shinyjs::onclick(sprintf("%s_weight", method$id), { updateSelectInput( session, "optimization_target", selected = "custom" ) }) method_listeners <- c(method_listeners, method_listener) } }) |> bindEvent(analysis()) # 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 analysis()$preset$methods) { if (!is.null(input[[method$id]])) { 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(analysis()$preset$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 analysis()$preset$methods) { if (!is.null(input[[method$id]])) { 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) }) }) }