R/crossPanel.R

In bulkAnalyseR: Interactive Shiny App for Bulk Sequencing Data

#' Generate the cross plot panel of the shiny app
#' @description These are the UI and server components of the cross plot panel of the 
#' shiny app. It is generated by including 'Cross' in the panels.default argument
#' of \code{\link{generateShinyApp}}.
#' @inheritParams DEpanel
#' @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 crossPanel
NULL

#' @rdname crossPanel
#' @export
crossPanelUI <- function(id, metadata, show = TRUE){
  ns <- NS(id)
  
  if(show){
    tabPanel(
      'Cross plot',
      shinyjs::useShinyjs(),
      sidebarLayout(
        
        sidebarPanel(
          selectInput(ns('condition1'), 'Metadata column to use for comparison #1:', colnames(metadata)[-1], 
                      selected = colnames(metadata)[ncol(metadata)]),
          
          selectInput(ns('DE1var1'), 'DE comparison #1 Condition 1:', unique(metadata[[ncol(metadata)]])),
          selectInput(ns('DE1var2'), 'DE comparison #1 Condition 2:', unique(metadata[[ncol(metadata)]]),
                      selected = unique(metadata[[ncol(metadata)]])[2]),
          
          selectInput(ns('pipeline1'), 'DE pipeline for comparison #1:', c("edgeR", "DESeq2")),
          
          selectInput(ns('condition2'), 'Metadata column to use for comparison #2:', colnames(metadata)[-1], 
                      selected = colnames(metadata)[ncol(metadata)]),
          
          selectInput(ns('DE2var1'), 'DE comparison #2 Condition 1:', unique(metadata[[ncol(metadata)]])),
          selectInput(ns('DE2var2'), 'DE comparison #2 Condition 2:', unique(metadata[[ncol(metadata)]]),
                      selected = unique(metadata[[ncol(metadata)]])[2]),
          
          selectInput(ns('pipeline2'), 'DE pipeline for comparison #2:', c("edgeR", "DESeq2")),
          
          sliderInput(ns('lfcThreshold'), label = 'logFC threshold',
                      min = 0, value = 1, max = 5, step = 0.05),
          sliderInput(ns('pvalThreshold'), label = 'Adjusted p-value threshold',
                      min = 0, value = 0.05, max = 0.2, step = 0.005),
          
          actionButton(ns('goDE'), label = 'Start DE'),
          textInput(ns('dataFileName'),'File name for download', value ='crossPlot.csv', placeholder = 'crossPlot.csv'),
          downloadButton(ns('download_data'), 'Download Table')
        ),
        
        #Main panel for displaying plots table of DE genes
        mainPanel(
          shinyWidgets::dropdownButton(
            shinyWidgets::switchInput(
              inputId = ns('autoLabel'),
              label = "Auto labels", 
              labelWidth = "80px",
              onLabel = 'On',
              offLabel = 'Off',
              value = FALSE,
              onStatus = FALSE
            ),
            shinyWidgets::switchInput(
              inputId = ns('allGenes'),
              label = "Showing on click:", 
              labelWidth = "80px",
              onLabel = 'All genes',
              offLabel = 'Only DE genes',
              value = FALSE,
              onStatus = FALSE
            ),
            
            selectInput(ns("geneName"), "Genes to highlight:", multiple = TRUE, choices = character(0)),
            
            textInput(ns('plotFileName'), 'File name for plot download', value ='crossPlot.png'),
            downloadButton(ns('download'), 'Download Plot'),
            
            status = "info",
            icon = icon("gear", verify_fa = FALSE), 
            tooltip = shinyWidgets::tooltipOptions(title = "Click to see inputs!")
          ),
          
          plotOutput(ns('plot'), click = ns('plot_click')),
          plotOutput(ns('venn')),
          tableOutput(ns('data')) 
        )
      )
    )
  }else{
    NULL
  }
}

#' @rdname crossPanel
#' @export
crossPanelServer <- function(id, expression.matrix, metadata, anno){
  # check whether inputs (other than id) are reactive or not
  stopifnot({
    is.reactive(expression.matrix)
    is.reactive(metadata)
    !is.reactive(anno)
  })
  
  moduleServer(id, function(input, output, session){
    
    updateSelectizeInput(session, "geneName", choices = anno$NAME, server = TRUE)
    
    observe({
      updateSelectInput(session, 'DE1var1', choices = unique(metadata()[[input[["condition1"]]]]))
      updateSelectInput(session, 'DE1var2', choices = unique(metadata()[[input[["condition1"]]]]),
                        selected = unique(metadata()[[input[["condition1"]]]])[2])
      updateSelectInput(session, 'DE2var1', choices = unique(metadata()[[input[["condition2"]]]]))
      updateSelectInput(session, 'DE2var2', choices = unique(metadata()[[input[["condition2"]]]]),
                        selected = unique(metadata()[[input[["condition2"]]]])[2])
    })
    
    observe({
      condition.indices <- metadata()[[input[["condition1"]]]] %in% c(input[['DE1var1']], input[['DE1var2']])
      if(any(summary(as.factor(metadata()[[input[["condition1"]]]][condition.indices])) < 2)){
        choices <- "edgeR"
      }else{
        choices <- c("edgeR", "DESeq2")
      }
      updateSelectInput(session, 'pipeline1', choices = choices)
    })
    
    observe({
      condition.indices <- metadata()[[input[["condition2"]]]] %in% c(input[['DE2var1']], input[['DE2var2']])
      if(any(summary(as.factor(metadata()[[input[["condition2"]]]][condition.indices])) < 2)){
        choices <- "edgeR"
      }else{
        choices <- c("edgeR", "DESeq2")
      }
      updateSelectInput(session, 'pipeline2', choices = choices)
    })
    
    DEresults <- reactive({
      shinyjs::disable("goDE")
      condition.indices <- metadata()[[input[["condition1"]]]] %in% c(input[['DE1var1']], input[['DE1var2']])
      if(input[["pipeline1"]] == "edgeR"){
        DEtable1 <- DEanalysis_edger(
          expression.matrix = expression.matrix()[, condition.indices],
          condition = metadata()[[input[["condition1"]]]][condition.indices],
          var1 = input[['DE1var1']],
          var2 = input[['DE1var2']],
          anno = anno
        )
      }else if(input[["pipeline1"]] == "DESeq2"){
        DEtable1 <- DEanalysis_deseq2(
          expression.matrix = expression.matrix()[, condition.indices],
          condition = metadata()[[input[["condition1"]]]][condition.indices],
          var1 = input[['DE1var1']],
          var2 = input[['DE1var2']],
          anno = anno
        )
      }
      
      condition.indices <- metadata()[[input[["condition2"]]]] %in% c(input[['DE2var1']], input[['DE2var2']])
      if(input[["pipeline2"]] == "edgeR"){
        DEtable2 <- DEanalysis_edger(
          expression.matrix = expression.matrix()[, condition.indices],
          condition = metadata()[[input[["condition2"]]]][condition.indices],
          var1 = input[['DE2var1']],
          var2 = input[['DE2var2']],
          anno = anno
        )
      }else if(input[["pipeline2"]] == "DESeq2"){
        DEtable2 <- DEanalysis_deseq2(
          expression.matrix = expression.matrix()[, condition.indices],
          condition = metadata()[[input[["condition2"]]]][condition.indices],
          var1 = input[['DE2var1']],
          var2 = input[['DE2var2']],
          anno = anno
        )
      }
      
      DEtable1Subset <- DEtable1 %>%
        dplyr::filter(abs(.data$log2FC) > input[["lfcThreshold"]] & .data$pvalAdj < input[["pvalThreshold"]])
      DEtable2Subset <- DEtable2 %>%
        dplyr::filter(abs(.data$log2FC) > input[["lfcThreshold"]] & .data$pvalAdj < input[["pvalThreshold"]])
      
      # the thresholds are returned here so that the plot display 
      # doesn't use new thresholds without the button being used
      shinyjs::enable("goDE")
      return(list('DEtable1' = DEtable1,
                  'DEtable2' = DEtable2,
                  "DEtable1Subset" = DEtable1Subset,
                  "DEtable2Subset" = DEtable2Subset,
                  'lfcThreshold' = input[["lfcThreshold"]], 
                  'pvalThreshold' = input[["pvalThreshold"]]))
    }) %>%
      bindCache(utils::head(expression.matrix()),metadata(), input[["condition1"]], 
                input[['DE1var1']], input[['DE1var2']], input[["pipeline1"]], 
                input[["condition2"]], input[['DE2var1']], input[['DE2var2']],
                input[["pipeline2"]], input[["lfcThreshold"]], input[["pvalThreshold"]]) %>%
      bindEvent(input[["goDE"]])
    
    cp_table <- reactive({
      results <- DEresults()
      cross_plot_prep(
        DEtable1 = results$DEtable1,
        DEtable2 = results$DEtable2,
        DEtable1Subset = results$DEtable1Subset,
        DEtable2Subset = results$DEtable2Subset,
        lfc.threshold = results$lfcThreshold
      )
    })
    
    cp <- reactive({
      cp_table <- cp_table()
      cross_plot(
        df = cp_table,
        lfc.threshold = input[["lfcThreshold"]],
        raster = TRUE,
        labels.per.region = ifelse(input[["autoLabel"]], 5, 0),
        add.labels.custom = length(input[["geneName"]]) > 0,
        genes.to.label = input[["geneName"]]
      )
    })
    
    venn <- reactive({
      results <- DEresults()
      ggVennDiagram::ggVennDiagram(
        list(
          "DE comparison 1" = results$DEtable1Subset$gene_id, 
          "DE comparison 2" = results$DEtable2Subset$gene_id
        ),
        color = "white"
      )
    })
    
    output[['plot']] <- renderPlot(cp())
    output[['venn']] <- renderPlot(venn())
    
    output[['data']] <- renderTable({
      req(input[['plot_click']])
      results = DEresults()
      tbl1 <- results$DEtable1
      tbl2 <- results$DEtable2
      if (input[['allGenes']]){
        all.genes <- unique(c(tbl1$gene_id, tbl2$gene_id))
      }else{
        all.genes <- unique(c(results$DEtable1Subset$gene_id, results$DEtable1Subset$gene_id))
      }
      data <- data.frame(
        gene_id = all.genes,
        gene_name = c(tbl1$gene_name, tbl2$gene_name)[match(all.genes, c(tbl1$gene_id, tbl2$gene_id))],
        lfc1 = tbl1$log2FC[match(all.genes, tbl1$gene_id)], 
        lfc2 = tbl2$log2FC[match(all.genes, tbl2$gene_id)]
      )
      
      nearPoints(df = data, coordinfo = input[['plot_click']], threshold = 20, maxpoints = 10)
    }, digits = 4)
    
    output[['download']] <- downloadHandler(
      filename = function() input[['plotFileName']],
      content = function(file) {
        ggsave(file, plot = cp(), dpi = 300)
      }
    )
    
    #DE data download
    output[['download_data']] <- downloadHandler(
      filename = function() {
        paste(input[['dataFileName']])
      },
      content = function(file) {
        utils::write.csv(x = cp_table(), file = file, row.names = FALSE)
      }
    )
  })
}