R/patternPanel.R

In bulkAnalyseR: Interactive Shiny App for Bulk Sequencing Data

#' Generate the expression patterns panel of the shiny app
#' @description These are the UI and server components of the expression patterns
#' panel of the shiny app. It is generated by including 'Patterns' 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 patternPanel
NULL

#' @rdname patternPanel
#' @export
patternPanelUI <- function(id, metadata, show = TRUE){
  ns <- NS(id)
  
  if(show){
    tabPanel(
      'Expression patterns',
      shinyjs::useShinyjs(),
      sidebarLayout(
        sidebarPanel(
          selectInput(ns('condition'), 'Metadata column to use:', colnames(metadata)[-1], 
                      selected = colnames(metadata)[ncol(metadata)]),
          shinyjqui::orderInput(ns('series'), label = "Series of states to use",
                                items = NULL, placeholder = "Drag states here...",
                                connect = ns("states")),
          shinyjqui::orderInput(ns('states'), label = "Unused states",
                                items = unique(metadata[[ncol(metadata)]]), 
                                connect = ns("series")),
          
          selectInput(ns("nSD"), "Number of standard deviations from the mean to use for interval overlap:",
                      c(1:10), selected = 2),
          div(style="margin-bottom:20px"),
          shinyjs::disabled(actionButton(ns('goPatterns'), label = 'Calculate expression patterns')),
          div(style="margin-bottom:20px"),
          
          selectInput(ns('pattern'), 'Pattern to plot', choices = NULL),
          
          textInput(ns('tableFileName'), 'File name for download', 
                    value ='patternExpression.csv', placeholder = 'patternExpression.csv'),
          downloadButton(ns('downloadTable'), 'Download grouped expression table'),
          radioButtons(ns('downloadValues'), label = "Download values",
                       choices = c('Expression', 'Log2 Expression', 'Mean Scaled', 'Z-score'), 
                       selected = 'Expression'),
        ),
        mainPanel(
          shinyWidgets::dropdownButton(
            radioButtons(ns('line.processing'), label = "Heatmap values",
                         choices = c('Expression', 'Log2 Expression', 'Mean Scaled'), 
                         selected = 'Mean Scaled'),
            textInput(ns('plotLineFileName'), 'File name for line plot download', value ='LinePlot.png'),
            downloadButton(ns('downloadLinePlot'), 'Download Line Plot'),
            
            status = "info",
            icon = icon("gear", verify_fa = FALSE), 
            tooltip = shinyWidgets::tooltipOptions(title = "Click to see inputs!")
          ),
          plotOutput(ns('plot_line')),
          shinyWidgets::dropdownButton(
            radioButtons(ns('heatmap.processing'), label = "Heatmap values",
                         choices = c('Expression', 'Log2 Expression', 'Z-score'), 
                         selected = 'Z-score'),
            textInput(ns('plotHeatmapFileName'), 'File name for heatmap plot download', value ='HeatmapPlot.png'),
            downloadButton(ns('downloadHeatmapPlot'), 'Download Heatmap Plot'),
            
            status = "info",
            icon = icon("gear", verify_fa = FALSE), 
            tooltip = shinyWidgets::tooltipOptions(title = "Click to see inputs!")
          ),
          plotOutput(ns('plot_heatmap')),
        )
      )
    )
  }else{
    NULL
  }
}

#' @rdname patternPanel
#' @export
patternPanelServer <- 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){
    
    observe({
      shinyjqui::updateOrderInput(session, "series", items = character(0))
      shinyjqui::updateOrderInput(session, "states", 
                                  items = as.character(unique(metadata()[[input[["condition"]]]])))
    })
    
    observe({
      if(length(input[["series"]]) >= 2){
        shinyjs::enable("goPatterns")
      }else{
        shinyjs::disable("goPatterns")
      }
    }) %>%
      bindEvent(input[["series"]])
    
    patterns.list <- reactive({
      shinyjs::disable("goPatterns")
      subset.idxs <- metadata()[[input[["condition"]]]] %in% input[["series"]]
      mat <- expression.matrix()[, subset.idxs]
      condition <- metadata()[subset.idxs, input[["condition"]]]
      condition <- factor(condition, levels = input[["series"]])
      tbl <- calculate_condition_mean_sd_per_gene(mat, condition)
      patterns <- make_pattern_matrix(tbl, n_sd = as.numeric(input[["nSD"]]))[, "pattern"]
      shinyjs::enable("goPatterns")
      list("tbl" = tbl, "patterns" = patterns)
    }) %>%
      bindCache(utils::head(expression.matrix()), metadata(), input[["condition"]], 
                input[["series"]], input[["nSD"]]) %>%
      bindEvent(input[["goPatterns"]])
    
    observe({
      pats <- unique(patterns.list()$patterns)
      updateSelectInput(
        session, "pattern", 
        choices = setdiff(pats, paste0(rep("S", nchar(pats[1])), collapse = ""))
      )
    })
    
    output[['downloadTable']] <- downloadHandler(
      filename = function() {
        paste(input[['tableFileName']])
      },
      content = function(file) {
        mat <- make_heatmap_matrix(patterns.list()$tbl) %>%
          rescale_matrix(type = input[["downloadValues"]])
        gene_id <- NULL
        df <- cbind(
          tibble::tibble(gene_id = names(patterns.list()$patterns),
                         gene_name = anno$NAME[match(gene_id, anno$ENSEMBL)],
                         pattern = patterns.list()$patterns),
          tibble::as_tibble(mat)
        )
        utils::write.csv(x = df, file = file, row.names = FALSE)
      }
    )
    
    line.plot <- reactive({
      genes <- names(patterns.list()$patterns)[patterns.list()$patterns == input[["pattern"]]]
      genes <- anno$NAME[match(genes, anno$ENSEMBL)]
      tbl <- patterns.list()$tbl
      tbl$gene <- anno$NAME[match(tbl$gene, anno$ENSEMBL)]
      myplot <- plot_line_pattern(
        tbl = tbl,
        genes = genes, 
        type = input[['line.processing']],
        show.legend = ifelse(length(genes) <= 10, TRUE, FALSE)
      ) 
      return(myplot)
    })
    
    heatmap.plot <- reactive({
      genes <- names(patterns.list()$patterns)[patterns.list()$patterns == input[["pattern"]]]
      heatmat <- make_heatmap_matrix(patterns.list()$tbl, genes)
      rownames(heatmat) <- anno$NAME[match(rownames(heatmat), anno$ENSEMBL)]
      if(nrow(heatmat) > 50) rownames(heatmat) <- NULL
      
      myplot <- expression_heatmap(
        expression.matrix.subset = heatmat,
        top.annotation.ids = NULL,
        metadata = metadata(),
        type = input[["heatmap.processing"]]
      )
      return(myplot)
    })
    
    output[['plot_line']] <- renderPlot(line.plot()) 
    output[['downloadLinePlot']] <- downloadHandler(
      filename = function() { input[['plotLineFileName']] },
      content = function(file) {
        ggsave(file, plot = line.plot(), dpi = 300)
      }
    )
    
    output[['plot_heatmap']] <- renderPlot(heatmap.plot(), height = 800) 
    output[['downloadHeatmapPlot']] <- downloadHandler(
      filename = function() { input[['plotHeatmapFileName']] },
      content = function(file) {
        if (base::strsplit(input[['plotHeatmapFileName']], split="\\.")[[1]][-1] == 'pdf'){
          grDevices::pdf(file, width = 10, height = 20, pointsize = 12)
          print(heatmap.plot())
          grDevices::dev.off()
        } else if (base::strsplit(input[['plotHeatmapFileName']], split="\\.")[[1]][-1] == 'svg'){
          grDevices::svg(file, width = 10, height = 20, pointsize = 12)
          print(heatmap.plot())
          grDevices::dev.off()
        } else {
          grDevices::png(file, width = 480, height = 1000,
                         units = "px", pointsize = 12)
          print(heatmap.plot())
          grDevices::dev.off()
        }
      }
    )
    
  })
}

# patternPanelApp <- function(){
#   shinyApp(
#     ui = navbarPage("Expression patterns", 
#                     tabPanel("", tabsetPanel(patternPanelUI('Patterns', metadata)))),
#     server = function(input, output, session){
#       patternPanelServer("Patterns", reactiveVal(expression.matrix), reactiveVal(metadata), NULL) ###
#     }
#   )
# }