CanvasXpress FlexDashboard Example

examples/19_canvasxpress-gene-explorer/dashboard.Rmd

@@ -0,0 +1,104 @@
+---
+title: "IPF Fibroblast data"
+output: 
+  flexdashboard::flex_dashboard:
+    orientation: rows
+    social: menu
+    source_code: embed
+    css: styles.css
+runtime: shiny
+---
+
+```{r setup, include=FALSE}
+library(knitr)
+library(flexdashboard)
+library(htmlwidgets)
+library(canvasXpress)
+library(dplyr)
+
+source("supporting_plots.R")
+
+loadData <- function(filename) {
+    exData <- readRDS(filename)
+
+    # format gene names: remove first underscore and all characters after that
+    gsub_expression <- "_.*"
+    rownames(exData$Log2CPM) <- gsub(gsub_expression, "", rownames(exData$Log2CPM))
+    exData$contrasts <- lapply(exData$contrasts, FUN = function(x) {
+        rownames(x) <- gsub(gsub_expression, "", rownames(x))
+        return(x)
+    })
+    exData
+}
+
+# load and prep the data
+exData    <- loadData("data.rds")
+gene_list <- rownames(exData$contrasts[[1]])
+```
+
+
+Sidebar {.sidebar}
+=======================================================================
+
+```{r}
+selectizeInput("contrast", "Select Contrast", names(exData$contrasts))
+
+selectizeInput("genes", "Select Gene(s)", gene_list, multiple = TRUE, selected = gene_list[1:2], 
+               options  = list(placeholder = "Type/Click then Select", 
+                               searchField = "value", 
+                               plugins = list('remove_button')))
+ds1 <- reactive({
+    exData$contrasts[[input$contrast]]
+})
+```
+
+
+Dashboard
+=======================================================================
+
+Row {data-height=500}
+-----------------------------------------------------------------------
+
+### Profile plot
+
+```{r}
+renderCanvasXpress({
+     pp <- ds1()
+     if (!is.null(pp)) {
+        profilePlot(pp, title = paste(input$contrast, sep = ""))
+     }  else {
+        canvasXpress(destroy = TRUE)
+    }
+})
+```
+
+### Volcano plot
+
+```{r}
+renderCanvasXpress({
+    vp <- ds1()
+    if (!is.null(vp)) {
+        volcanoPlot(vp, title = paste(input$contrast, sep = ""))
+     }  else {
+        canvasXpress(destroy = TRUE)
+    }
+  })
+```
+
+Row {data-height=500}
+-----------------------------------------------------------------------
+
+### Explore Genes
+```{r}
+renderCanvasXpress({
+    sel = input$genes
+    if (!is.null(sel)) {
+      dat <- exData$Log2CPM
+      dat <- dat[rownames(dat) %in% sel,,drop = FALSE]
+      des <- exData$smpAnnot$ReplicateGroup
+      genePlot(dat, des, title = "Expression Plot")
+    } else {
+        canvasXpress(destroy = TRUE)
+    }
+})
+```

examples/19_canvasxpress-gene-explorer/styles.css

@@ -0,0 +1,3 @@
+body {
+    background-color: white;
+}

examples/19_canvasxpress-gene-explorer/supporting_plots.R

@@ -0,0 +1,170 @@
+# ----------------------
+# Plot Related Functions
+#-----------------------
+
+# shared variables
+logRatioCol          <- "logFC"
+logIntCol            <- "AveExpr"
+axisAlgorithm        <- "wilkinsonExtended"
+backgroundType       <- "window"
+sizes                <- c(10, 10, 4, 10, 12, 14, 16, 18, 20, 22, 24, 26)
+plot_colors          <- c("rgba(0,104,139,0.5)", "rgba(205,0,0,0.5)", "rgba(64,64,64,0.5)")
+backgroundColor      <- "lightgrey"
+tickColor            <- "white"
+legendBoxColor       <- "black"
+fontName             <- "Arial"
+sizeByShowLegend     <- FALSE
+titleScaleFontFactor <- 0.5
+axisScaleFontFactor  <- 1.8
+
+profilePlot <- function(df, title = NULL) {
+
+    ## create CanvasXpress data
+    cx <- data.frame(a = round(df[colnames(df) == logIntCol], digits = 2),
+                     b = round(df[colnames(df) == logRatioCol], digits = 2))
+    va <- data.frame(Group      = df$Group,
+                     nLog10pVal = df$NegativeLogP)
+    rownames(va) <- rownames(cx)
+
+    ## CanvasXpress Plot
+    canvasXpress(
+        data                     = cx,
+        varAnnot                 = va,
+        graphType                = "Scatter2D",
+        axisAlgorithm            = axisAlgorithm,
+        backgroundType           = backgroundType,
+        backgroundWindow         = backgroundColor,
+        colorBy                  = "Group",
+        colors                   = plot_colors,
+        legendBackgroundColor    = backgroundColor,
+        legendBoxColor           = legendBoxColor,
+        legendInside             = TRUE,
+        legendPosition           = "bottomRight",
+        showLoessFit             = TRUE,
+        loessColor               = "darkgoldenrod1",
+        sizeBy                   = "Group",
+        sizes                    = sizes,
+        sizeByShowLegend         = sizeByShowLegend,
+        title                    = title,
+        titleScaleFontFactor     = titleScaleFontFactor,
+        fontName                 = fontName,
+        xAxis                    = list(logIntCol),
+        xAxisTickColor           = tickColor,
+        xAxisTitle               = logIntCol,
+        yAxis                    = list(logRatioCol),
+        yAxisTickColor           = tickColor,
+        yAxisTitle               = logRatioCol,
+        axisTitleScaleFontFactor = axisScaleFontFactor
+    )
+}
+
+volcanoPlot <- function(df, title = NULL) {
+
+    ## create CanvasXpress data
+    cx <- data.frame(a = round(df[colnames(df) == logRatioCol], digits = 2),
+                     b = round(df$NegativeLogP, digits = 2))
+    colnames(cx) = c(logRatioCol, "NegativeLogP")
+    va <- data.frame(Group  = df$Group,
+                     LogInt = round(df[[logIntCol]], digits = 2))
+    rownames(va) <- rownames(cx)
+
+    ## CanvasXpress Plot
+    canvasXpress(
+        data                     = cx,
+        varAnnot                 = va,
+        graphType                = "Scatter2D",
+        axisAlgorithm            = axisAlgorithm,
+        backgroundType           = backgroundType,
+        backgroundWindow         = backgroundColor,
+        colorBy                  = "Group",
+        colors                   = plot_colors,
+        legendBackgroundColor    = backgroundColor,
+        legendBoxColor           = legendBoxColor,
+        legendInside             = FALSE,
+        legendPosition           = "right",
+        sizeBy                   = "Group",
+        sizes                    = sizes,
+        sizeByShowLegend         = sizeByShowLegend,
+        title                    = title,
+        titleScaleFontFactor     = titleScaleFontFactor,
+        fontName                 = fontName,
+        xAxis                    = c(logRatioCol, ""),
+        xAxisTickColor           = tickColor,
+        xAxisTitle               = logRatioCol,
+        yAxis                    = c("NegativeLogP", ""),
+        yAxisTickColor           = tickColor,
+        yAxisTitle               = "-log10(P.Value)",
+        axisTitleScaleFontFactor = axisScaleFontFactor
+    )
+}
+
+heatmapPlot <- function(df, smpAnnot = FALSE, title = NULL) {
+    canvasXpress(
+        data                     = df,
+        smpAnnot                 = smpAnnot,
+        graphType                = "Heatmap",
+        smpOverlays              = list("Group"),
+        smpOverlayProperties     = list(Group = list(thickness = 60, color = "Set1")),
+        overlayScaleFontFactor   = 1.4,
+        showSampleNames          = FALSE,
+        sortSampleByCategory     = list("Group"),
+        heatmapSmpSeparateBy     = "Group",
+        variablesClustered       = TRUE,
+        axisAlgorithm            = axisAlgorithm,
+        showVarDendrogram        = FALSE,
+        heatmapIndicatorPosition = "right",
+        colorSpectrum            = c("navy", "white", "firebrick3"),
+        title                    = title,
+        broadcast                = FALSE,
+        fontName                 = fontName
+    )
+}
+
+genePlot <- function(df, block, title = NULL) {
+    smpAnnot           <- data.frame(Group = block)
+    rownames(smpAnnot) <- rownames(t(df))
+    varAnnot           <- data.frame(Gene = rownames(df))
+    rownames(varAnnot) <- rownames(df)
+
+    if (length(rownames(varAnnot)) > 4) {
+        heatmapPlot(df, smpAnnot, title = title)
+    } else {
+        canvasXpress(
+            data                     = df,
+            smpAnnot                 = smpAnnot,
+            varAnnot                 = varAnnot,
+            graphType                = "Boxplot",
+            graphOrientation         = "vertical",
+            backgroundWindow         = "lightgrey",
+            backgroundType           = backgroundType,
+            legendBoxColor           = legendBoxColor,
+            legendBackgroundColor    = backgroundColor,
+            groupingFactors          = c("Group"),
+            segregateVariablesBy     = list("Gene"),
+            colors                   = rep("deepskyblue3", 4),
+            title                    = "Top Fold Changes Genes",
+            titleScaleFontFactor     = 0.4,
+            xAxisTitle               = "Log2CPM",
+            axisTitleScaleFontFactor = 1.8,
+            smpHairline              = TRUE,
+            smpHairlineColor         = "white",
+            smpHairlineWidth         = 1,
+            xAxisTickColor           = tickColor,
+            smpTitle                 = "Group",
+            smpTitleScaleFontFactor  = 0.5,
+            xAxis2Show               = FALSE,
+            axisAlgorithm            = axisAlgorithm,
+            showLegend               = FALSE,
+            layoutBoxShow            = FALSE,
+            smpLabelRotate           = 50,
+            smpLabelScaleFontFactor  = 0.5,
+            xAxisMinorTicks          = FALSE,
+            fontName                 = fontName,
+            boxplotMedianWidth       = 2,
+            boxplotMedianColor       = "dodgerblue4",
+            boxplotMean              = TRUE,
+            marginLeft               = 30,
+            broadcast                = FALSE
+        )
+    }
+}