inst/examples/10.example-shinydashboard.R

In jokergoo/InteractiveComplexHeatmap: Make Interactive Complex Heatmaps

# Work with shinydashboard

##########################################
# title: Separate the three UI components into three boxes.

library(shinydashboard)
m = matrix(rnorm(100), 10)
ht = Heatmap(m)

# The three components are separately specified and put with different box().
body = dashboardBody(
	fluidRow(
		box(title = "Original heatmap", width = 4, solidHeader = TRUE, status = "primary",
			originalHeatmapOutput("ht")
		),
		box(title = "Sub-heatmap", width = 4, solidHeader = TRUE, status = "primary",
			subHeatmapOutput("ht")
		),
		box(title = "Output", width = 4, solidHeader = TRUE, status = "primary",
			HeatmapInfoOutput("ht")
		),
        tags$style("
            .content-wrapper, .right-side {
                overflow-x: auto;
            }
            .content {
                min-width:1500px;
            }
        ")
	)
)

ui = dashboardPage(
	dashboardHeader(),
	dashboardSidebar(),
	body
)

server = function(input, output, session) {
    makeInteractiveComplexHeatmap(input, output, session, ht, "ht")
}

shinyApp(ui, server)

##########################################
# title: The three UI components are draggable.

library(shinydashboard)
m = matrix(rnorm(100), 10)
ht = Heatmap(m)

# The three components are separately specified and put with different box().
body = dashboardBody(
    box(title = "Original heatmap", width = 4, solidHeader = TRUE, status = "primary",
        originalHeatmapOutput("ht")
    ),
    box(title = "Sub-heatmap", width = 4, solidHeader = TRUE, status = "primary",
        subHeatmapOutput("ht")
    ),
    box(title = "Output", width = 4, solidHeader = TRUE, status = "primary",
        HeatmapInfoOutput("ht")
    ),
    # use JQuery UI draggable tool
    tags$script("
        $('.box').parent().draggable({handle:'.box-header'});
    "),
    tags$style("
        .content-wrapper, .right-side {
            overflow-x: auto;
        }
        .content {
            min-width:1500px;
        }
    ")
)

ui = dashboardPage(
    dashboardHeader(),
    dashboardSidebar(),
    body
)

server = function(input, output, session) {
    makeInteractiveComplexHeatmap(input, output, session, ht, "ht")
}

shinyApp(ui, server)


##########################################
# title: A Shiny dashboard with two tabs.

library(shinydashboard)
m1 = matrix(rnorm(100), 10)
ht1 = Heatmap(m1)

m2 = matrix(sample(letters[1:10], 100, replace = TRUE), 10)
ht2 = Heatmap(m2)

side_bar = dashboardSidebar(
	sidebarMenu(
		menuItem("A numeric heatmap", tabName = "numeric"),
		menuItem("A character heatmap", tabName = "character")
	)
)

single_heatmap_ui = function(heatmap_id) {
	fluidRow(
		box(title = "Original heatmap", width = 4, solidHeader = TRUE, status = "primary",
			originalHeatmapOutput(heatmap_id)
		),
		box(title = "Sub-heatmap", width = 4, solidHeader = TRUE, status = "primary",
			subHeatmapOutput(heatmap_id)
		),
		box(title = "Output", width = 4, solidHeader = TRUE, status = "primary",
			HeatmapInfoOutput(heatmap_id)
		),
        tags$style("
            .content-wrapper, .right-side {
                overflow-x: auto;
            }
            .content {
                min-width:1500px;
            }
        ")
	)
}

# UI of the interactive heatmap widget is generated by single_heatmap_ui().
body = dashboardBody(
	tabItems(
		tabItem(tabName = "numeric", single_heatmap_ui("ht1")),
		tabItem(tabName = "character", single_heatmap_ui("ht2"))
	)
)

ui = dashboardPage(
	dashboardHeader(title = "InteractiveComplexHeatmap"),
	side_bar,
	body
)

server = function(input, output, session) {
    makeInteractiveComplexHeatmap(input, output, session, ht1, "ht1")
    makeInteractiveComplexHeatmap(input, output, session, ht2, "ht2")
}

shinyApp(ui, server)


########################################################
# title: Only contain the original heatmap where output floats.

library(shinydashboard)
m = matrix(rnorm(100), 10)
ht = Heatmap(m)

body = dashboardBody(
	fluidRow(
		box(title = "Original heatmap", width = 4, solidHeader = TRUE, status = "primary",
			originalHeatmapOutput("ht", response = c("click", "brush-output"), width = 400),
			HeatmapInfoOutput("ht", output_ui_float = TRUE) # this line can be put anywhere
		)
	)
)

ui = dashboardPage(
	dashboardHeader(title = "InteractiveComplexHeatmap"),
	dashboardSidebar(),
	body
)

server = function(input, output, session) {
    makeInteractiveComplexHeatmap(input, output, session, ht, "ht")
}

shinyApp(ui, server)


#########################################################
# title: A complex dashboard that visualizes a DESeq2 results.

# First we perform DESeq2 analysis on the airway dataset.
library(airway)
data(airway)
se <- airway
library(DESeq2)
dds <- DESeqDataSet(se, design = ~ dex)
keep <- rowSums(counts(dds)) >= 10
dds <- dds[keep, ]

dds$dex <- relevel(dds$dex, ref = "untrt")

dds <- DESeq(dds)
res <- results(dds)
res = as.data.frame(res)

library(ComplexHeatmap)
library(circlize)

env = new.env()

# Make the heatmap for differentially expressed genes under certain cutoffs.
make_heatmap = function(fdr = 0.01, base_mean = 0, log2fc = 0) {
	l = res$padj <= fdr & res$baseMean >= base_mean & abs(res$log2FoldChange) >= log2fc; l[is.na(l)] = FALSE

	if(sum(l) == 0) return(NULL)

	m = counts(dds, normalized = TRUE)
	m = m[l, ]

	env$row_index = which(l)

	ht = Heatmap(t(scale(t(m))), name = "z-score",
	    top_annotation = HeatmapAnnotation(
	        dex = colData(dds)$dex,
	        sizeFactor = anno_points(colData(dds)$sizeFactor)
	    ),
	    show_row_names = FALSE, show_column_names = FALSE, row_km = 2,
	    column_title = paste0(sum(l), " significant genes with FDR < ", fdr),
	    show_row_dend = FALSE) + 
	    Heatmap(log10(res$baseMean[l]+1), show_row_names = FALSE, width = unit(5, "mm"),
	        name = "log10(baseMean+1)", show_column_names = FALSE) +
	    Heatmap(res$log2FoldChange[l], show_row_names = FALSE, width = unit(5, "mm"),
	        name = "log2FoldChange", show_column_names = FALSE,
	        col = colorRamp2(c(-2, 0, 2), c("green", "white", "red")))
	ht = draw(ht, merge_legend = TRUE)
}

# make the MA-plot with some genes highlighted
make_maplot = function(res, highlight = NULL) {
    col = rep("#00000020", nrow(res))
    cex = rep(0.5, nrow(res))
    names(col) = rownames(res)
    names(cex) = rownames(res)
    if(!is.null(highlight)) {
        col[highlight] = "red"
        cex[highlight] = 1
    }
    x = res$baseMean
    y = res$log2FoldChange
    y[y > 2] = 2
    y[y < -2] = -2
    col[col == "red" & y < 0] = "darkgreen"
    par(mar = c(4, 4, 1, 1))

    suppressWarnings(
        plot(x, y, col = col, 
            pch = ifelse(res$log2FoldChange > 2 | res$log2FoldChange < -2, 1, 16), 
            cex = cex, log = "x",
            xlab = "baseMean", ylab = "log2 fold change")
    )
}

# make the volcano plot with some genes highlited
make_volcano = function(res, highlight = NULL) {
    col = rep("#00000020", nrow(res))
    cex = rep(0.5, nrow(res))
    names(col) = rownames(res)
    names(cex) = rownames(res)
    if(!is.null(highlight)) {
        col[highlight] = "red"
        cex[highlight] = 1
    }
    x = res$log2FoldChange
    y = -log10(res$padj)
    col[col == "red" & x < 0] = "darkgreen"
    par(mar = c(4, 4, 1, 1))

    suppressWarnings(
        plot(x, y, col = col, 
            pch = 16, 
            cex = cex,
            xlab = "log2 fold change", ylab = "-log10(FDR)")
    )
}

# A self-defined action to respond brush event. It updates the MA-plot, the volcano plot
# and a table which contains DESeq2 results for the selected genes.
library(DT)
library(GetoptLong)
brush_action = function(df, input, output, session) {
    
    row_index = unique(unlist(df$row_index))
    selected = env$row_index[row_index]
        
    output[["ma_plot"]] = renderPlot({
        make_maplot(res, selected)
    })

    output[["volcano_plot"]] = renderPlot({
        make_volcano(res, selected)
    })

    output[["res_table"]] = renderDT(
        formatRound(datatable(res[selected, c("baseMean", "log2FoldChange", "padj")], rownames = TRUE), columns = 1:3, digits = 3)
    )

    output[["note"]] = renderUI({
    	if(!is.null(df)) {
    		HTML(qq("<p>Row indices captured in <b>Output</b> only correspond to the matrix of the differential genes. To get the row indices in the original matrix,  you need to perform:</p>
<pre>
l = res$padj <= @{input$fdr} & 
    res$baseMean >= @{input$base_mean} & 
    abs(res$log2FoldChange) >= @{input$log2fc}
l[is.na(l)] = FALSE
which(l)[row_index]
</pre>
<p>where <code>res</code> is the complete data frame (by function <code>results()</code>) from DESeq2 analysis and <code>row_index</code> is the <code>row_index</code> column captured from the code in <b>Output</b>.</p>"))
    	}
    })
}

# The dashboard body contains three columns:
# 1. the original heatmap
# 2. the sub-heatmap and the default output
# 3. the self-defined output
library(shiny)
library(shinydashboard)
body = dashboardBody(
    fluidRow(
        column(width = 4,
            box(title = "Differential heatmap", width = NULL, solidHeader = TRUE, status = "primary",
                originalHeatmapOutput("ht", height = 800, containment = TRUE)
            )
        ),
        column(width = 4,
        	id = "column2",
            box(title = "Sub-heatmap", width = NULL, solidHeader = TRUE, status = "primary",
                subHeatmapOutput("ht", title = NULL, containment = TRUE)
            ),
            box(title = "Output", width = NULL, solidHeader = TRUE, status = "primary",
                HeatmapInfoOutput("ht", title = NULL)
            ),
            box(title = "Note", width = NULL, solidHeader = TRUE, status = "primary",
                htmlOutput("note")
            ),
        ),
        column(width = 4,
            box(title = "MA-plot", width = NULL, solidHeader = TRUE, status = "primary",
                plotOutput("ma_plot")
            ),
            box(title = "Volcano plot", width = NULL, solidHeader = TRUE, status = "primary",
                plotOutput("volcano_plot")
            ),
            box(title = "Result table of the selected genes", width = NULL, solidHeader = TRUE, status = "primary",
                DTOutput("res_table")
            )
        ),
        tags$style("
            .content-wrapper, .right-side {
                overflow-x: auto;
            }
            .content {
                min-width:1500px;
            }
        ")
    )
)

# Side bar contains settings for certain cutoffs to select significant genes.
ui = dashboardPage(
    dashboardHeader(title = "DESeq2 results"),
    dashboardSidebar(
    	selectInput("fdr", label = "Cutoff for FDRs:", c("0.001" = 0.001, "0.01" = 0.01, "0.05" = 0.05)),
    	numericInput("base_mean", label = "Minimal base mean:", value = 0),
    	numericInput("log2fc", label = "Minimal abs(log2 fold change):", value = 0),
    	actionButton("filter", label = "Generate heatmap")
    ),
    body
)

# makeInteractiveComplexHeatmap() is put inside observeEvent() so that changes on the cutoffs can regenerate the heatmap.
server = function(input, output, session) {
	observeEvent(input$filter, {
		ht = make_heatmap(fdr = as.numeric(input$fdr), base_mean = input$base_mean, log2fc = input$log2fc)
		if(!is.null(ht)) {
		    makeInteractiveComplexHeatmap(input, output, session, ht, "ht",
		        brush_action = brush_action)
		} else {
            # The ID for the heatmap plot is encoded as @{heatmap_id}_heatmap, thus, it is ht_heatmap here.
			output$ht_heatmap = renderPlot({
				grid.newpage()
				grid.text("No row exists after filtering.")
			})
		}
	}, ignoreNULL = FALSE)
}

shinyApp(ui, server)