R/sampleSelectPanel.R

In bulkAnalyseR: Interactive Shiny App for Bulk Sequencing Data

#' Generate the sample select panel of the shiny app
#' @description These are the UI and server components of the sample selection
#' panel of the shiny app. It is generated by including 'SampleSelect' in the 
#' panels.default argument of \code{\link{generateShinyApp}}.
#' @inheritParams DEpanel
#' @param modality the modality, needs to be passed when used within another
#' shiny module for namespacing reasons
#' @return The UI and Server components of the shiny module, that can be used
#' within the UI and Server definitions of a shiny app.
#' @name sampleSelectPanel
NULL

#' @rdname sampleSelectPanel
#' @export
sampleSelectPanelUI <- function(id, metadata, show = TRUE){
  ns <- NS(id)
  
  if(show){
    tabPanel(
      'Sample select',
      actionButton(ns('goSamples'), label = 'Use the selected samples!', 
                   width = "100%", class = "btn-primary btn-lg"),
      fluidRow(
        column(2, checkboxInput(ns("selectAll"), label = "Select all", value = TRUE)),
        column(2, checkboxInput(ns("deselectAll"), label = "Deselect all", value = FALSE)),
        column(2, style = "padding-top: 10px;", 'Select using metadata column:'),
        column(2, style = "padding-top: 5px;",
               selectInput(ns('condition'), NULL, colnames(metadata), 
                           selected = colnames(metadata)[ncol(metadata)])),
        column(4, style = "padding-top: 10px;",
               checkboxGroupInput(ns("selectMeta"), label = NULL, inline = TRUE,
                                  choices = unique(metadata[[ncol(metadata)]]),
                                  selected = unique(metadata[[ncol(metadata)]]))),
      ),
      DT::dataTableOutput(ns('tbl'))
    )
  }else{
    NULL
  }
}

#' @rdname sampleSelectPanel
#' @export
sampleSelectPanelServer <- function(id, expression.matrix, metadata, modality = "RNA"){
  ns <- NS(c(modality, id))
  # check whether inputs (other than id) are reactive or not
  stopifnot({
    !is.reactive(expression.matrix)
    !is.reactive(metadata)
  })
  
  moduleServer(id, function(input, output, session){
    
    # create a character vector of shiny inputs
    shinyInput = function(FUN, len, ID, value, ...) {
      if (length(value) == 1) value <- rep(value, len)
      inputs = character(len)
      for (i in seq_len(len)) {
        inputs[i] = as.character(FUN(ns(paste0(ID, i)), label = NULL, value = value[i]))
      }
      inputs
    }
    # obtain the values of inputs
    shinyValue = function(ID, len) {
      unlist(lapply(seq_len(len), function(i) {
        value = input[[paste0(ID, i)]]
        if (is.null(value)) TRUE else value
      }))
    }
    
    observe({
      updateCheckboxInput(
        session = session,
        inputId = "selectAll",
        value = FALSE
      )
    }) %>%
      bindEvent(shinyValue('cb_', n), input[["condition"]], 
                input[["deselectAll"]], input[["selectMeta"]])
    observe({
      updateCheckboxInput(
        session = session,
        inputId = "deselectAll",
        value = FALSE
      )
    }) %>%
      bindEvent(shinyValue('cb_', n), input[["condition"]], input[["selectMeta"]])
    observe({
      updateCheckboxGroupInput(
        session = session, 
        inputId = "selectMeta", 
        choices = unique(metadata[[input[["condition"]]]]), 
        selected = NULL,
        inline = TRUE
      )
    }) %>%
      bindEvent(shinyValue('cb_', n), input[["condition"]])
    
    observe({
      if (input[['goSamples']] != 0){
        if (!identical(colnames(expression.matrix[,shinyValue('cb_', n)]), colnames(filteredInputs()$expression.matrix))){
          shinyjs::enable("goSamples")
        }
      } else {
        if (!all(shinyValue('cb_', n))){
          shinyjs::enable("goSamples")
        }
      }
    }) %>%
      bindEvent(shinyValue('cb_', n))
    
    n <- nrow(metadata)
    df = cbind(
      data.frame(selected = shinyInput(checkboxInput, n, 'cb_', value = TRUE, width='1px')),
      metadata
    )
    
    loopData = reactive({
      if(input[["selectAll"]]){
        df$selected <<- shinyInput(checkboxInput, n, 'cb_', value = TRUE, width='1px')
      }else if(input[["deselectAll"]]){
        df$selected <<- shinyInput(checkboxInput, n, 'cb_', value = FALSE, width='1px')
      }else if(length(input[["selectMeta"]]) > 0){
        df$selected <<- shinyInput(
          checkboxInput, n, 'cb_', width='1px',
          value = shinyValue('cb_', n) | metadata[[input[["condition"]]]] %in% input[["selectMeta"]]
        )
      }else{
        df$selected <<- shinyInput(checkboxInput, n, 'cb_', value = shinyValue('cb_', n), width='1px')
      }
      df
    })
    tbl <- DT::renderDataTable(
      isolate(loopData()),
      escape = FALSE, 
      selection = 'none',
      options = list(
        dom = 't', paging = FALSE, ordering = FALSE,
        preDrawCallback = DT::JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
        drawCallback = DT::JS('function() { Shiny.bindAll(this.api().table().node()); } ')
      ))
    output[["tbl"]] = tbl
    
    proxy = DT::dataTableProxy('tbl')
    
    observe({
      DT::replaceData(proxy, loopData(), resetPaging = FALSE)
    })
    
    filteredInputs <- reactive({
      shinyjs::disable("goSamples")
      list("expression.matrix" = expression.matrix[, shinyValue('cb_', n)],
           "metadata" = metadata[shinyValue('cb_', n), ])
    }) %>%
      bindEvent(input[["goSamples"]], ignoreNULL = FALSE)
    
    return(filteredInputs)
    
  })
}

sampleSelectPanelApp <- function(){
  expression.matrix.preproc <- as.matrix(utils::read.csv(
    system.file("extdata", "expression_matrix_preprocessed.csv", package = "bulkAnalyseR"), 
    row.names = 1
  ))
  metadata <- data.frame(
    srr = colnames(expression.matrix.preproc), 
    timepoint = rep(c("0h", "12h", "36h"), each = 2)
  )
  shinyApp(
    ui = fluidPage(sampleSelectPanelUI('SampleSelect')),
    server = function(input, output, session){
      sampleSelectPanelServer('SampleSelect', expression.matrix.preproc, metadata)
    }
  )
}