Merge pull request #12 from Core-Bioinformatics/display_improvements

Display improvements

Author: emouts

R/DEsummaryFuns.R

@@ -3,6 +3,8 @@
 #' @inheritParams generateShinyApp
 #' @param top.annotation.ids a vector of column indices denoting which columns
 #' of the metadata should become heatmap annotations
+#' @param show.columns.names whether to show the column names below the heatmap;
+#' default is TRUE
 #' @return The heatmap as detailed in the ComplexHeatmap package.
 #' @export
 #' @examples
@@ -20,12 +22,14 @@ expression_heatmap <- function(
   expression.matrix.subset,
   top.annotation.ids = NULL,
   metadata,
-  type = c('Z-score', 'Log2 Expression', 'Expression')
+  type = c('Z-score', 'Log2 Expression', 'Expression'),
+  show.column.names = TRUE
 ){
   heatmat <- as.matrix(expression.matrix.subset)
 
   type <- type[1]
   heatmat <- rescale_matrix(heatmat, type)
+  if(!show.column.names){colnames(heatmat <- NULL)}
 
   if(!is.null(top.annotation.ids)){
     qual.col.pals = dplyr::filter(RColorBrewer::brewer.pal.info, .data$category == 'qual')
@@ -53,16 +57,13 @@ expression_heatmap <- function(
     top.annotation <- NULL
   }
   if (type != 'Z-score'){
-    breaks <- seq(min(heatmat), 
-                  max(heatmat),
-                  (max(heatmat) - min(heatmat))/9)
-    colours = c("#FFFFFF",RColorBrewer::brewer.pal(n = 9, name = "YlOrRd"))
-  }
-  else {
-    breaks <- seq(-3,3,6/9)
+    breaks <- seq(min(heatmat), max(heatmat), (max(heatmat) - min(heatmat)) / 9)
+    colours = c("#FFFFFF", RColorBrewer::brewer.pal(n = 9, name = "YlOrRd"))
+  }else{
+    breaks <- seq(-3, 3, 6 / 9)
     colours = rev(RColorBrewer::brewer.pal(n = 10, name = "RdBu"))
-    heatmat[heatmat>3]<-3
-    heatmat[heatmat<(-3)]<- (-3)
+    heatmat[heatmat > 3] <- 3
+    heatmat[heatmat < (-3)] <- (-3)
   }
   ComplexHeatmap::Heatmap(
     matrix = heatmat,

R/DEsummaryPanel.R

@@ -28,8 +28,8 @@ DEsummaryPanelUI <- function(id, metadata){
         onStatus = FALSE
       ),
       checkboxInput(ns("pca.show.labels"), label = "Show sample labels", value = FALSE),
-      checkboxInput(ns('pca.show.ellipses'),label = "Show ellipses around groups",value=TRUE),
-      textInput(ns('plotPCAFileName'), 'File name for PCA plot download', value ='PCAPlotDE.png'),
+      checkboxInput(ns('pca.show.ellipses'), label = "Show ellipses around groups", value = TRUE),
+      textInput(ns('plotPCAFileName'), 'File name for PCA plot download', value = 'PCAPlotDE.png'),
       downloadButton(ns('downloadPCAPlot'), 'Download PCA Plot'),
 
       status = "info",
@@ -42,12 +42,10 @@ DEsummaryPanelUI <- function(id, metadata){
       radioButtons(ns('heatmap.processing'), label = "Heatmap values",
                    choices = c('Expression','Log2 Expression','Z-score'), 
                    selected = 'Z-score'),
-      shinyjqui::orderInput(ns('heatmap.annotations'), label = "Show annotations",
-                            items = colnames(metadata)[c(ncol(metadata), seq_len(ncol(metadata) - 1))][-2]),
+      shinyjqui::orderInput(ns('heatmap.annotations'), label = "Show annotations", items = colnames(metadata)),
       selectInput(ns("geneName"), "Additional genes to include:", multiple = TRUE, choices = character(0)),
       div("\nIf no genes are selected in the DE panel or here then the top 50 DE genes are chosen.\n"),
       div(style="margin-bottom:10px"),
-      actionButton(ns('goHeatmap'), label = 'Create heatmap'),
       textInput(ns('plotHeatmapFileName'), 'File name for heatmap plot download', value ='HeatmapPlot.png'),
       downloadButton(ns('downloadHeatmapPlot'), 'Download Heatmap Plot'),
 
@@ -99,6 +97,16 @@ DEsummaryPanelServer <- function(id, expression.matrix, metadata, DEresults, ann
     })
     output[['pca']] <- renderPlot(pca.plot())
 
+    observe({
+      items <- colnames(metadata())
+      include.exclude <- apply(metadata(), 2, function(x){
+        l <- length(unique(x))
+        (l > 1) & (l < length(x))
+      })
+      items <- colnames(metadata())[include.exclude]
+      items <- items[c(length(items), seq_len(length(items) - 1))]
+      shinyjqui::updateOrderInput(session, "heatmap.annotations", items = items)
+    })
     heatmap.plot <- reactive({
         selectedGenes = DEresults()$selectedGenes()
         if(length(selectedGenes)){
@@ -119,14 +127,14 @@ DEsummaryPanelServer <- function(id, expression.matrix, metadata, DEresults, ann
           dplyr::arrange(dplyr::across(input[['heatmap.annotations']]))
 
         myplot <- expression_heatmap(
-          expression.matrix = subsetExpression[, meta[, 1]],
+          expression.matrix = subsetExpression[, meta[, 1], drop = FALSE],
           top.annotation.ids = match(input[['heatmap.annotations']], colnames(meta)),
           metadata = meta,
-          type = input[["heatmap.processing"]]
+          type = input[["heatmap.processing"]],
+          show.column.names = (nrow(meta) <= 20)
         )
         return(myplot)
-      }) %>%
-      bindEvent(DEresults(), input[['goHeatmap']])
+      }) 
     output[['heatmap']] <- renderPlot(heatmap.plot(), height = 800)
 
     output[['downloadHeatmapPlot']] <- downloadHandler(

R/QCpanel.R

@@ -15,8 +15,7 @@ QCpanelUI <- function(id, metadata){
     'Quality checks',
     tags$h1("Jaccard Similarity Index Heatmap"),
     shinyWidgets::dropdownButton(
-      shinyjqui::orderInput(ns('jaccard.annotations'), label = "Show annotations",
-                            items = colnames(metadata)[c(ncol(metadata), seq_len(ncol(metadata) - 1))][-2]),
+      shinyjqui::orderInput(ns('jaccard.annotations'), label = "Show annotations", items = colnames(metadata)),
       sliderInput(ns('jaccard.n.abundant'), label = '# of (most abundant) genes',
                   min = 50, value = 500, max = 5000, step = 50, ticks = FALSE),
       checkboxInput(ns("jaccard.show.values"), label = "Show JSI values", value = FALSE),
@@ -73,6 +72,16 @@ QCpanelServer <- function(id, expression.matrix, metadata, anno){
   })
 
   moduleServer(id, function(input, output, session){
+    observe({
+      items <- colnames(metadata())
+      include.exclude <- apply(metadata(), 2, function(x){
+        l <- length(unique(x))
+        (l > 1) & (l < length(x))
+      })
+      items <- colnames(metadata())[include.exclude]
+      items <- items[c(length(items), seq_len(length(items) - 1))]
+      shinyjqui::updateOrderInput(session, "jaccard.annotations", items = items)
+    })
     jaccard.plot <- reactive({
       meta <- lapply(metadata(), function(x) factor(x, levels = unique(x))) %>% 
         as.data.frame() %>%
@@ -83,7 +92,8 @@ QCpanelServer <- function(id, expression.matrix, metadata, anno){
         metadata = meta,
         top.annotation.ids = match(input[['jaccard.annotations']], colnames(meta)),
         n.abundant = input[['jaccard.n.abundant']], 
-        show.values = input[["jaccard.show.values"]]
+        show.values = input[["jaccard.show.values"]],
+        show.row.columns.names = (nrow(meta) <= 20)
       )
       myplot 
     })

R/QCplotFuns.R

@@ -24,6 +24,8 @@ jaccard_index <- function(a, b){
 #' of the metadata should become heatmap annotations
 #' @param n.abundant number of most abundant genes to use for the JSI calculation
 #' @param show.values whether to show the JSI values within the heatmap squares
+#' @param show.row.columns.names whether to show the row and column names below 
+#' the heatmap; default is TRUE
 #' @return The JSI heatmap as detailed in the ComplexHeatmap package.
 #' @export
 #' @examples
@@ -42,7 +44,8 @@ jaccard_heatmap <- function(
   metadata,
   top.annotation.ids = NULL, 
   n.abundant = NULL, 
-  show.values = TRUE
+  show.values = TRUE,
+  show.row.columns.names = TRUE
 ){
   n.abundant <- min(n.abundant, nrow(expression.matrix))
   n.samples <- ncol(expression.matrix)
@@ -54,7 +57,9 @@ jaccard_heatmap <- function(
       heatmat[i, j] <- heatmat[j, i] <- jaccard_index(i.gene.indices, j.gene.indices)
     }
   }
-  rownames(heatmat) <- colnames(heatmat) <- colnames(expression.matrix)
+  if(show.row.columns.names){
+    rownames(heatmat) <- colnames(heatmat) <- colnames(expression.matrix)
+  }
 
   if(!is.null(top.annotation.ids)){
     qual.col.pals = dplyr::filter(RColorBrewer::brewer.pal.info, .data$category == 'qual')
@@ -71,6 +76,7 @@ jaccard_heatmap <- function(
         vec <- c(vec, col.vector[colind])
         names(vec)[i] <- values[i]
         colind <- colind + 1
+        if(colind > length(col.vector)){colind <- colind %% length(col.vector)}
       }
       top.annotation.colour.list[[colnames(metadata)[top.annotation.ids[annos]]]] <- vec
     }