R/mod_project_selection.R

In teofiln/gene.editing.dash: VOR Gene Editing Dashboard

#' project_selection UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd
#'
#' @importFrom shiny NS tagList selectInput
#' @importFrom DT DTOutput
#' @importFrom grDevices col2rgb
#' @importFrom stats quantile setNames
mod_project_selection_ui <- function(id) {
  ns <- NS(id)

  tagList(
    column(width = 12, shiny::uiOutput(ns(
      "all_the_dropdowns"
    ))),
    shiny::tags$hr(),
    column(
      width = 12,
      shiny::h5("Experiments matching your filter criteria"),
      shiny::helpText("Click on a row to select the experiment"),
      DTOutput(ns("project_table"))
    )
  )
}

#' project_selection Server Functions
#' @param app_data the AppData R6 instance storing data for module communication
#' @importFrom shiny moduleServer
#' @importFrom DT renderDT
#' @noRd
mod_project_selection_server <- function(id, app_data) {
  moduleServer(id, function(input, output, session) {
    ns <- session$ns
    RV <- shiny::reactiveValues(
      search_data = app_data$metadata,
      filter_data = app_data$metadata,
      PROJECT = NULL,
      selected_row = NULL
    )

    ##### --- dynamic dropdowns for filters --- #####
    ui_for_filters <- shiny::reactive({

      if (shiny::isTruthy(RV$PROJECT)) {
        column(
          width = 6,
          shiny::div(
            style = "background: #706699; color: #EEE; border-radius: 5px; padding: 2px; font-weight: bold;",
            glue::glue(
              "Project {RV$PROJECT[[1]]} selected. Please continue to the next pages in the navigation bar on the left."
            )
          )
        )
      } else {
        shiny::tagList(
        shiny::div(
          class = "row g-3",
          lapply(c(
            project_dropdown_options()$DefaultDropdownFields,
            input$additional_fields
          ), function(x) {
            shiny::div(
              class = "col-md-2 compact-dropdown",
              shiny::selectizeInput(
                inputId = ns(x),
                label = janitor::make_clean_names(x, case = "title"),
                choices = app_data$metadata[[x]],
                selected = NULL,
                multiple = TRUE,
                width = "100%",
                options = list(placeholder = janitor::make_clean_names(x, case = "title"))
              )
            )
          })),
          shiny::div(
            class = "row align-items-end",
            shiny::div(
              class = "col-md-3",
              shiny::checkboxInput(
                inputId = ns("toggle_more_dropdowns"),
                label = "Additional filters",
                value = FALSE
              ),
              shiny::conditionalPanel(
                condition = paste0("input[['", id, "-toggle_more_dropdowns']] === true"),
                selectInput(
                  inputId = ns("additional_fields"),
                  label = "Additional filters",
                  choices = project_dropdown_options()$AdditionalDropdownFields,
                  selected = NULL,
                  multiple = TRUE,
                  width = "100%"
                )
              )
            )
          )
        )
      }
    })

    output$all_the_dropdowns <- shiny::renderUI({
      ui_for_filters()
    })
    ##### --- end dynamic dropdowns for filters --- #####

    ##### --- dropdown buttons filter logic --- ####
    filter_list <- shiny::reactive({
      lapply(names(RV$search_data), \(x) input[[x]]) %>%
        setNames(names(RV$search_data)) %>%
        purrr::discard(is.null)
    })

    shiny::observe({
      shiny::req(filter_list())
      filter_result <-
        dyn_filter(.data = RV$search_data, .filter_list = filter_list())
      RV$filter_data <- filter_result
    }) %>% shiny::bindEvent(filter_list())

    shiny::observe({
      shiny::req(filter_list())

      input_to_update <-
        RV$filter_data %>% dplyr::select(-dplyr::all_of(names(filter_list()))) %>% names()
      lapply(X = input_to_update, \(x) {
        shiny::updateSelectInput(
          session = session,
          inputId = x,
          label = janitor::make_clean_names(x, case = "title"),
          choices = unique(RV$filter_data[[x]]),
          selected = NULL
        )
      })

    }) %>% shiny::bindEvent(RV$filter_data)

    ##### --- end dropdown buttons filter logic --- ####

    ##### --- table with selectable row --- ####
    output$project_table <-
      renderDT(server = TRUE,
        expr = RV$filter_data %>% janitor::clean_names(case = "sentence") %>%
          DT::datatable(
            data = .,
            options = list(dom = "t", scrollX = T),
            class = "compact nowrap",
            selection = list(
              mode = "single",
              target = "row",
              selectable = TRUE
            ),
            rownames = FALSE
          )
      )

    project_table_proxy <- DT::dataTableProxy("project_table")

    shiny::observe({
      RV$selected_row <- input[["project_table_rows_selected"]]
    })

    shiny::observe({
      shiny::req(RV$selected_row)
      X <- RV$filter_data[RV$selected_row, ] %>%
        janitor::clean_names(case = "sentence")
      RV$PROJECT <- X
    })

    # shiny::observe({
    #   if (is.null(RV$selected_row)) {
    #     RV$PROJECT <- NULL
    #     app_data$project <- NULL
    #     gargoyle::trigger("no_project_selected")
    #   }
    # }) %>% shiny::bindEvent(RV$selected_row, ignoreNULL = FALSE)

    #update app data project slot
    shiny::observe({
      shiny::req(RV$PROJECT)

      shiny::withProgress(message = "Loading project data. Please wait.",
                          expr = {
                            app_data$project <- RV$PROJECT[[1]]
                            active_data <- etl(.project = RV$PROJECT[[1]])
                            app_data$data_list <- active_data$data
                            app_data$app_list <- active_data$app
                          })

      gargoyle::trigger("new_project_selected")
    }) %>% shiny::bindEvent(RV$PROJECT)

    ##### --- table with selectable row --- ####

    # Bookmark the project reactive val manually
    shiny::onBookmark(function(state) {
      state$values$PROJECT <- RV$PROJECT
    })

    # Read values from state$values when we restore
    shiny::onRestore(function(state) {
      shiny::withProgress(message = "Restoring session. Please wait",
                          expr = {
                            RV$PROJECT <- state$values$PROJECT
                            RV$selected_row <-
                              state$input$project_table_rows_selected
                            DT::selectRows(
                              proxy = project_table_proxy,
                              selected = state$input$project_table_rows_selected,
                              ignore.selectable = FALSE
                            )
                          })
    })

  #   shiny::onRestored(function(state) {
  #     shiny::withProgress(message = "Restoring session. Please wait",
  #                         expr = {
  #                           RV$PROJECT <- state$values$PROJECT
  #                           app_data$project <- RV$PROJECT[[1]]
  #                           active_data <- etl(.project = RV$PROJECT[[1]])
  #                           app_data$data_list <- active_data$data
  #                           app_data$app_list <- active_data$app
  #                         })
  #   })

  })
}