R/d3heatmap.R
In rstudio/d3heatmap: Interactive Heat Maps Using 'htmlwidgets' and 'D3.js'
Defines functions
renderD3heatmap
d3heatmapOutput
encodeAsPNG
d3heatmap
Documented in
d3heatmap
d3heatmapOutput
renderD3heatmap
#' @import htmlwidgets
#' @importFrom grDevices col2rgb rgb colorRampPalette
#' @importFrom stats as.dendrogram dendrapply dist hclust is.leaf order.dendrogram reorder sd
#' @importFrom utils capture.output str
NULL
#' D3 Heatmap widget
#'
#' Creates a D3.js-based heatmap widget.
#'
#' @param x A numeric matrix or data.frame with numeric columns. All non-numeric columns
#' will be filtered out
#'
#' @param main \emph{string} Plot title. Defaults to \code{NULL}.
#'
#' @param theme A custom CSS theme to use. Currently the only valid values are
#' \code{""} and \code{"dark"}. \code{"dark"} is primarily intended for
#' standalone visualizations, not R Markdown or Shiny.
#'
#' @param col Either a colorbrewer2.org palette name (e.g. \code{"YlOrRd"}
#' or \code{"Blues"}), or a vector of colors to interpolate in hexadecimal
#' \code{"#RRGGBB"} format, or a color interpolation function like
#' \code{\link[grDevices]{colorRamp}}.
#'
#' @param breaks \emph{integer} Either a numeric vector indicating the splitting
#' points for binning x into colors, or a integer number of break points
#' to be used, in which case the break points will be spaced equally
#' between min(x) and max(x).
#'
#' @param symbreaks \emph{logical} Arrange color bins symmetrically around zero?
#'
#' @param Rowv determines if and how the row dendrogram
#' should be reordered. By default, it is TRUE, which implies
#' dendrogram is computed and reordered based on row means.
#' If NULL or FALSE, then no dendrogram is computed and no reordering
#' is done. If a dendrogram, then it is used "as-is", i.e. without any
#' reordering. If a vector of integers, then a dendrogram is computed
#' and reordered based on the order of the vector.
#'
#' @param Colv determines if and how the column dendrogram should be
#' reordered. Has the options as the Rowv argument above and additionally
#' when x is a square matrix, Colv = "Rowv" means that columns should be
#' treated identically to the rows.
#'
#' @param distfun function used to compute the distance (dissimilarity)
#' between both rows and columns. Defaults to dist.
#'
#' @param hclustfun function used to compute the hierarchical clustering
#' when Rowv or Colv are not dendrograms. Defaults to hclust.
#'
#' @param dendrogram character string indicating whether to draw 'none',
#' 'row', 'column' or 'both' dendrograms. Defaults to 'both'. However, if
#' Rowv (or Colv) is FALSE or NULL and dendrogram is 'both', then a warning
#' is issued and Rowv (or Colv) arguments are honored.
#'
#' @param reorderfun function(d, w) of dendrogram and weights for reordering
#' the row and column dendrograms. The default uses stats{reorder.dendrogram}
#'
#' @param k_row,kr an integer scalar with the desired number of groups by which
#' to color the dendrogram's branches in the rows
#' (uses \link[dendextend]{color_branches})
#'
#' @param k_col,kc an integer scalar with the desired number of groups by which
#' to color the dendrogram's branches in the columns
#' (uses \link[dendextend]{color_branches})
#'
#' @param print.values \emph{logical} Show the values inside the cells. Defaults to \code{FALSE}.
#'
#' @param key Show color key and density
#' information? \code{TRUE/FALSE}. Defaults to \code{FALSE}
#'
#' @param keysize \emph{numeric} value indicating the relative size of the key. Will multiple the labRowSize and labColSize.
#' Defaults to 1
#'
#' @param key.title Separate title for color key. Defaults to \code{NULL}.
#'
#' @param key.location \emph{Required, character} Location for color key, either \code{"fl", "br", "tr"
#' "tl", or "bl"} for "float", "bottom right", "top right", "top left", and "bottom left".
#' Defaults to \code{"fl"}, which follows the location of the axis labels.
#'
#' @param density.info \emph{Optional, character} indicating whether to superimpose
#' a 'histogram' or no plot ('none') on the color-key (legend).
#'
#' @param denscol \emph{Optional, character} giving the color for the density
#' display specified by 'density.info', defaults to \code{NULL} which will fill the
#' bars with the same color as the bin
#'
#' @param width Width in pixels (optional, defaults to automatic sizing).
#'
#' @param height Height in pixels (optional, defaults to automatic sizing).
#'
#' @param labColSize Size of axes, in pixels.
#'
#' @param labRowSize Size of axes, in pixels.
#'
#' @param cexCol Font size of column labels, as a scalar to '12px' font. Default to
#' 0.2 + 1/log10(ncol(x)).
#'
#' @param cexRow Font size of row labels, as a scalar to '12px' font size. Defaults to
#' 0.2 + 1/log10(nrow(x)).
#'
#' @param srtCol Angle of axis labels. Defaults to 60. Maximum of 90 (vertical), minimum of 25.
#'
#' @param sideCol,xaxis.location 3 or 1, for "bottom" or "top", which side column labels
#' display. Defaults to 3 ("bottom"). For \code{xaxis.location} use "bottom"
#' or "top".
#'
#' @param sideRow,yaxis.location 2 or 4, for "left" or "right", which side row labels
#' display. Defaults to 4 ("right"). For \code{yaxis.location} use "left" or "right".
#'
#' @param xlab Title text of x axis
#'
#' @param ylab Title text of y axis
#'
#' @param xaxis_title_font_size Font size of x axis title in pixels. Defaults to 14.
#'
#' @param yaxis_title_font_size Font size of y axis title in pixels. Defaults to 14.
#'
#' @param brush_color The base color to be used for the brush. The brush will be
#' filled with a low-opacity version of this color. \code{"#RRGGBB"} format
#' expected.
#'
#' @param show_grid \code{TRUE} to show gridlines, \code{FALSE} to hide them, or
#' a numeric value to specify the gridline thickness in pixels (can be a non-integer).
#'
#' @param anim_duration Number of milliseconds to animate zooming in and out.
#' For large \code{x} it may help performance to set this value to \code{0}.
#'
#' @param symm logical indicating if x should be treated symmetrically; can only be true when x is a square matrix.
#'
#' @param revC logical indicating if the column order should be reversed for plotting.
#' Default (when missing) - is FALSE, unless symm is TRUE.
#' This is useful for cor matrix.
#'
#' @param scale character indicating if the values should be centered and scaled in either
#' the row direction or the column direction, or none. The default is "none".
#'
#' @param scale.by.range logical indicating whether to scale rows or columns by
#' the range of each row and column. Setting this parameter to \code{TRUE}
#' automatically sets \code{na.rm} to \code{TRUE}
#'
#' @param na.rm logical indicating whether NA's should be removed.
#'
#' @param na.value numeric indicating where NA's should be substituted to trigger the NA color.
#'
#' @param na.color Color of NA values in heatmap. Defaults to neutral gray.
#'
#' @param rng A vector of two numbers, namely the minimum and maximum value
#' to use when determining the mapping from values to colors. This is useful
#' when the range of values changes between heatmaps, but colors should be the
#' same (optional, defaults to the minimum and maximum of \code{x}).
#'
#' @param digits \emph{integer} indicating the number of decimal places to be used by \link{round} for 'label'.
#'
#' @param notecol \emph{character} name or hex specifying the color of the values printed
#' inside the cells
#'
#' @param notecex,cex.note \emph{numeric} scalar of 12 to determine pixel size of printed cell values.
#' inside the cells. If not specified, the minimum font size between the x and y axes.
#'
#' @param cellnote_row \emph{character} Label to display next to the row value when the user hovers over the cell.
#' If not specified, tries to match the \code{xlab}; if no axis title, defaults to "Row".
#'
#' @param cellnote_col \emph{character} Label to display next to the column value when the user hovers over the cell.
#' If not specified, tries to match the \code{ylab}; if no axis title, defaults to "Col".
#'
#' @param cellnote_val \emph{character} Label to display next to the cell value when the user hovers over the cell.
#' Defaults to "Value".
#'
#' @param cellnote \emph{numeric} (optional) matrix of the same dimensions as \code{x} that has the human-readable version of each value, for displaying to the user on hover. If \code{NULL}, then \code{x} will be coerced using \code{\link{as.character}}.
#' If missing, it will use \code{x}, after rounding it based on the \code{digits} parameter.
#'
#' @param cellnote_scale \emph{logical} (default is FALSE). IF cellnote is missing and x is used, should cellnote be scaled if x is also scaled?
#'
#' @param labRow character vectors with row labels to use (from top to bottom); default to rownames(x).
#'
#' @param labCol character vectors with column labels to use (from left to right); default to colnames(x).
#'
#' @param ColSideColors (optional) character vector of length ncol(x), or matrix with
#' columns equal to ncol(x), containing the color names for a horizontal side bar that may
#' be used to annotate the columns of x. \code{ColIndividualColors}, from heatmap.2, can
#' also be used
#'
#' @param RowSideColors (optional) character vector of length nrow(x), or matrix with rows
#' equal to nrow(x), containing the color names for a vertical side bar that may be used to
#' annotate the rows of x. \code{RowIndividualColors}, from heatmap.3, can also be used
#'
#' @param RowColorsPalette a palette of colors to use for RowSideColors if passing a non-color matrix
#'
#' @param ColColorsPalette a palette of colors to use for ColSideColors if passing a non-color matrix
#'
#' @param RowColorsNames the names of the variables for RowSideColors. Overrides colnames(RowSideColors)
#'
#' @param ColColorsNames the names of the variables for ColSideColors. Overrides rownames(ColSideColors)
#' with rows equal to nrow(x), containing the color names for a vertical side bar that may be used to annotate the
#' rows of x.
#'
#' @param ... a catch for undocumented features or unused arguments from heatmap.2
#' or heatmap.3, to enable direct use of those formulations in d3heatmap
#'
#' @import htmlwidgets
#'
#' @source
#' The interface was designed based on \link{heatmap} and \link[gplots]{heatmap.2}
#'
#' @seealso
#' \link{heatmap}, \link[gplots]{heatmap.2}
#'
#' @examples
#' \dontrun{
#'
#' d3heatmap(mtcars, scale = "column", col = "Blues")
#'
#' }
#'
#' @export
d3heatmap <- function(x
, main = NULL
, width = NULL
, height = NULL
, show_grid = TRUE
, anim_duration = 500
, rng = NULL
## dendrogram control
, symm = FALSE
, Rowv = TRUE
, Colv = if (symm) "Rowv" else TRUE
, distfun = dist
, hclustfun = hclust
, dendrogram = c("both", "row", "column", "none")
, reorderfun = function(d, w) reorder(d, w)
, k_row = NULL
, k_col = NULL
, kr
, kc
, revC = NULL
## data scaling
, scale = c("none", "row", "column")
, scale.by.range = FALSE
, na.rm = TRUE
, na.color = "#777777"
, na.value = NA
## legend (color key)
, key = FALSE
, keysize = 1
, key.title = NULL
, key.location = c("fl", "br", "tr", "tl", "bl")
, density.info = c('histogram', 'none')
, denscol = NULL
## cellnote formatting
, digits = 3L
, cellnote = NULL
, cellnote_scale = FALSE
, cellnote_row = NULL
, cellnote_col = NULL
, cellnote_val = "Value"
, brush_color = "#0000FF"
, print.values = FALSE
, notecol = '#222222'
, notecex = 1
, cex.note
## color controls
, theme = NULL
, col = "RdYlBu"
, breaks = NULL
, symbreaks = FALSE
## axis controls
, labRow = rownames(x)
, labCol = colnames(x)
, labColSize = 80
, labRowSize = 120
, cexCol = NULL
, cexRow = NULL
, srtCol = 60
, sideCol = 3
, sideRow = 4
, xaxis.location
, yaxis.location
, xlab = NULL
, ylab = NULL
, xaxis_title_font_size = 14
, yaxis_title_font_size = 14
# side colors
, ColSideColors = NULL
, RowSideColors = NULL
, RowColorsPalette = NULL
, ColColorsPalette = NULL
, RowColorsNames = NULL
, ColColorsNames = NULL
, ...
) {
if(length(dim(x)) != 2) {
stop(paste("x is not a 2-dimensional object. Here is the str output of x:", capture.output(str(x)), collapse = "\n"))
}
if(is.matrix(x) && !is.numeric(x)) {
warning(paste(capture.output(str(x)), collapse = "\n"))
stop("d3heatmap data must be a numeric
matrix or a data.frame with numeric columns")
}
# we'll modify this to take any matrix or data.frame, but filter out all
# non-numeric columns
if (is.data.frame(x) | is.table(x))
x <- x[, sapply(x, is.numeric)]
opts <- list(...)
axis.locations <- c("top", "left", "bottom", "right")
## pre-process paraemters
##===========================================================
## process the overlap of parameters between the old d3heatmap,
## heatmap.2, and heatmap.3 APIs
if (!missing(kr)) k_row <- kr
if (!missing(kc)) k_col <- kc
if (!missing(cex.note)) notecex <- cex.note
if(!is.null(ColSideColors))
ColSideColors <- matrix(ColSideColors, ncol = ncol(x))
if(!is.null(RowSideColors))
RowSideColors <- matrix(RowSideColors, nrow = nrow(x))
if (!is.null(opts$ColIndividualColors))
ColSideColors <- matrix(opts$ColIndividualColors, ncol = ncol(x))
if (!is.null(opts$RowIndividualColors))
RowSideColors <- matrix(opts$RowIndividualColors, nrow = nrow(x))
if (is.null(RowColorsPalette))
RowColorsPalette <- c('blue', 'orange', 'black')
if (is.null(ColColorsPalette))
ColColorsPalette <- c('cyan', 'maroon', 'grey')
if (is.null(RowColorsNames)) RowColorsNames <- colnames(RowSideColors)
if (is.null(ColColorsNames)) ColColorsNames <- rownames(ColSideColors)
## additional controls for working with the gadget (shiny inputs)
##===========================================================
if (!is.null(k_row)) if (is.na(k_row)) k_row <- NULL
if (!is.null(k_col)) if (is.na(k_col)) k_col <- NULL
if (!is.null(cexCol)) if (is.na(cexCol)) cexCol <- NULL
if (!is.null(cexRow)) if (is.na(cexRow)) cexRow <- NULL
if(!missing(xaxis.location)) {
xaxis.location <- tolower(xaxis.location)
if (xaxis.location %in% c('top', 'bottom'))
sideCol <- which(axis.locations == xaxis.location)
}
if(!missing(yaxis.location)) {
yaxis.location <- tolower(yaxis.location)
if (yaxis.location %in% c('left', 'right'))
sideRow <- which(axis.locations == yaxis.location)
}
## Save the parameters for later API calls
##===========================================================
## For the updated API, we need to be able to access stuff passed into
## the original call to d3heatmap before everything is processed (and there
## is a lot of processing going on here). Primarily we need those items
## passed into the internal heatmap() function, which does the lion's share
## of the generating
params <- list(
x = x
, Rowv = Rowv
, Colv = Colv
, distfun = distfun
, hclustfun = hclustfun
, dendrogram = match.arg(dendrogram)
, reorderfun = reorderfun
, k_row = k_row
, k_col = k_col
, symm = symm
, revC = revC
, scale = match.arg(scale)
, scale.by.range = scale.by.range
, na.rm = na.rm
, na.value = na.value
, digits = digits
, cellnote = cellnote
, cellnote_scale = cellnote_scale
, labRow = labRow
, labCol = labCol
, col = col
, symbreaks = symbreaks
, na.color = na.color
, rng = rng
, breaks = breaks
, RowSideColors = RowSideColors
, ColSideColors = ColSideColors
, RowColorsPalette = RowColorsPalette
, ColColorsPalette = ColColorsPalette
)
## the big call to create the heatmap
##==============================
## inserting new call to the refactored heatmap function, which does everything up to
## this point that the old d3heatmap procedure did
hm <- do.call(heatmap, args = params)
x <- hm$x
## Colors for the heatmap and the color key (legend)
##===========================================
hm_colors <- heatmapColors(x
, params$col
, params$na.color
, params$na.rm
, params$rng
, params$scale
, params$breaks
, params$symbreaks
)
## axis and cellnote labels sync
##==============================
if (is.null(cellnote_row)) cellnote_row <- ylab
if (is.null(cellnote_col)) cellnote_col <- xlab
## font sizes
##==============================
if (is.null(cexCol)) cexCol <- 0.2 + 1 / log10(ncol(x))
if (is.null(cexRow)) cexRow <- 0.2 + 1 / log10(nrow(x))
## bundling the options
##==============================================
srtCol <- min(90, max(srtCol, 25))
key.location <- match.arg(key.location)
axis.locations <- c("top", "left", "bottom", "right")
if (!sideCol %in% c(1, 3)) sideCol <- 3
if (!sideRow %in% c(2, 4)) sideRow <- 4
options <- list(
hm_width = width
, hm_height = height
, xaxis_height = labColSize
, yaxis_width = labRowSize
, xaxis_font_size = cexCol * 12
, yaxis_font_size = cexRow * 12
, xaxis_angle = srtCol
, xaxis_location = axis.locations[sideCol]
, yaxis_location = axis.locations[sideRow]
, xaxis_title = xlab
, yaxis_title = ylab
, xaxis_title_font_size = xaxis_title_font_size
, yaxis_title_font_size = yaxis_title_font_size
, bins = hm_colors$breaks
, manual_breaks = (length(breaks) > 1)
, symbreaks = symbreaks
, print_values = print.values
, show_legend = key
, legend_scaler = as.numeric(keysize[1])
, legend_title = key.title
, legend_location = key.location
, legend_colors = hm_colors$legend_colors
, legend_bins = hm_colors$legend_bins
, legend_breaks = hm_colors$legend_breaks
, legend_type = match.arg(density.info)
, legend_fill = denscol
, brush_color = brush_color
, na_color = na.color
, show_grid = show_grid
, cellnote_row = cellnote_row
, cellnote_col = cellnote_col
, cellnote_val = cellnote_val
, cellnote_fontsize = notecex * 12
, cellnote_color = notecol
, anim_duration = anim_duration
, rsc_labs = hm$rsclabs
, csc_labs = hm$csclabs
, rsc_cols = hm$rsccols
, csc_cols = hm$csccols
, rsc_colnames = RowColorsNames
, csc_colnames = ColColorsNames
)
if (is.null(hm$rowDend)) c(options, list(yclust_width = 0))
if (is.null(hm$colDend)) c(options, list(xclust_height = 0))
# transpose will cause error if row colors is null
if (!is.null(hm$rowcolors)) hm$rowcolors <- t(hm$rowcolors)
## proceed to the widget
## NOTE: when loading the side colors, we transpose the
## rowSideColors
##=======================================
imgUri <- encodeAsPNG(t(x), hm_colors$col)
payload <- list(
rows = hm$rowDend
, cols = hm$colDend
, matrix = hm$mtx
, title = main
, image = imgUri
, rowcolors = hm$rowcolors
, colcolors = hm$colcolors
, theme = theme
, options = options
, params = params
)
# create widget
htmlwidgets::createWidget(
name = 'd3heatmap'
, payload # the x param
, width = width
, height = height
, package = 'd3heatmap'
, sizingPolicy = htmlwidgets::sizingPolicy(browser.fill = TRUE)
)
}
#' @import png base64enc
encodeAsPNG <- function(x, colors) {
colorData <- as.raw(col2rgb(colors(x), alpha = TRUE))
dim(colorData) <- c(4, ncol(x), nrow(x))
pngData <- png::writePNG(colorData)
encoded <- base64enc::base64encode(pngData)
paste0("data:image/png;base64,", encoded)
}
#' Wrapper functions for using d3heatmap in shiny
#'
#' Use \code{d3heatmapOutput} to create a UI element, and \code{renderD3heatmap}
#' to render the heatmap.
#'
#' @param outputId Output variable to read from
#' @param width,height The width and height of the map (see
#' \link[htmlwidgets]{shinyWidgetOutput})
#' @param expr An expression that generates a \code{\link{d3heatmap}} object
#' @param env The environment in which to evaluate \code{expr}
#' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
#' is useful if you want to save an expression in a variable.
#'
#' @examples
#' \dontrun{
#' library(d3heatmap)
#' library(shiny)
#'
#' ui <- fluidPage(
#' h1("A heatmap demo"),
#' selectInput("palette", "Palette", c("YlOrRd", "RdYlBu", "Greens", "Blues")),
#' checkboxInput("cluster", "Apply clustering"),
#' d3heatmapOutput("heatmap")
#' )
#'
#' server <- function(input, output, session) {
#' output$heatmap <- renderD3heatmap({
#' d3heatmap(
#' scale(mtcars),
#' col = input$palette,
#' dendrogram = if (input$cluster) "both" else "none"
#' )
#' })
#' }
#'
#' shinyApp(ui, server)
#' }
#'
#' @export
d3heatmapOutput <- function(outputId, width = '100%', height = '400px'){
shinyWidgetOutput(outputId, 'd3heatmap', width, height, package = 'd3heatmap')
}
#' @rdname d3heatmapOutput
#' @export
renderD3heatmap <- function(expr, env = parent.frame(), quoted = FALSE) {
if (!quoted) { expr <- substitute(expr) } # force quoted
shinyRenderWidget(expr, d3heatmapOutput, env, quoted = TRUE)
}
rstudio/d3heatmap documentation built on May 26, 2021, 10:16 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions renderD3heatmap d3heatmapOutput encodeAsPNG d3heatmap
Documented in d3heatmap d3heatmapOutput renderD3heatmap
#' @import htmlwidgets
#' @importFrom grDevices col2rgb rgb colorRampPalette
#' @importFrom stats as.dendrogram dendrapply dist hclust is.leaf order.dendrogram reorder sd
#' @importFrom utils capture.output str
NULL
#' D3 Heatmap widget
#'
#' Creates a D3.js-based heatmap widget.
#'
#' @param x A numeric matrix or data.frame with numeric columns. All non-numeric columns
#' will be filtered out
#'
#' @param main \emph{string} Plot title. Defaults to \code{NULL}.
#'
#' @param theme A custom CSS theme to use. Currently the only valid values are
#' \code{""} and \code{"dark"}. \code{"dark"} is primarily intended for
#' standalone visualizations, not R Markdown or Shiny.
#'
#' @param col Either a colorbrewer2.org palette name (e.g. \code{"YlOrRd"}
#' or \code{"Blues"}), or a vector of colors to interpolate in hexadecimal
#' \code{"#RRGGBB"} format, or a color interpolation function like
#' \code{\link[grDevices]{colorRamp}}.
#'
#' @param breaks \emph{integer} Either a numeric vector indicating the splitting
#' points for binning x into colors, or a integer number of break points
#' to be used, in which case the break points will be spaced equally
#' between min(x) and max(x).
#'
#' @param symbreaks \emph{logical} Arrange color bins symmetrically around zero?
#'
#' @param Rowv determines if and how the row dendrogram
#' should be reordered. By default, it is TRUE, which implies
#' dendrogram is computed and reordered based on row means.
#' If NULL or FALSE, then no dendrogram is computed and no reordering
#' is done. If a dendrogram, then it is used "as-is", i.e. without any
#' reordering. If a vector of integers, then a dendrogram is computed
#' and reordered based on the order of the vector.
#'
#' @param Colv determines if and how the column dendrogram should be
#' reordered. Has the options as the Rowv argument above and additionally
#' when x is a square matrix, Colv = "Rowv" means that columns should be
#' treated identically to the rows.
#'
#' @param distfun function used to compute the distance (dissimilarity)
#' between both rows and columns. Defaults to dist.
#'
#' @param hclustfun function used to compute the hierarchical clustering
#' when Rowv or Colv are not dendrograms. Defaults to hclust.
#'
#' @param dendrogram character string indicating whether to draw 'none',
#' 'row', 'column' or 'both' dendrograms. Defaults to 'both'. However, if
#' Rowv (or Colv) is FALSE or NULL and dendrogram is 'both', then a warning
#' is issued and Rowv (or Colv) arguments are honored.
#'
#' @param reorderfun function(d, w) of dendrogram and weights for reordering
#' the row and column dendrograms. The default uses stats{reorder.dendrogram}
#'
#' @param k_row,kr an integer scalar with the desired number of groups by which
#' to color the dendrogram's branches in the rows
#' (uses \link[dendextend]{color_branches})
#'
#' @param k_col,kc an integer scalar with the desired number of groups by which
#' to color the dendrogram's branches in the columns
#' (uses \link[dendextend]{color_branches})
#'
#' @param print.values \emph{logical} Show the values inside the cells. Defaults to \code{FALSE}.
#'
#' @param key Show color key and density
#' information? \code{TRUE/FALSE}. Defaults to \code{FALSE}
#'
#' @param keysize \emph{numeric} value indicating the relative size of the key. Will multiple the labRowSize and labColSize.
#' Defaults to 1
#'
#' @param key.title Separate title for color key. Defaults to \code{NULL}.
#'
#' @param key.location \emph{Required, character} Location for color key, either \code{"fl", "br", "tr"
#' "tl", or "bl"} for "float", "bottom right", "top right", "top left", and "bottom left".
#' Defaults to \code{"fl"}, which follows the location of the axis labels.
#'
#' @param density.info \emph{Optional, character} indicating whether to superimpose
#' a 'histogram' or no plot ('none') on the color-key (legend).
#'
#' @param denscol \emph{Optional, character} giving the color for the density
#' display specified by 'density.info', defaults to \code{NULL} which will fill the
#' bars with the same color as the bin
#'
#' @param width Width in pixels (optional, defaults to automatic sizing).
#'
#' @param height Height in pixels (optional, defaults to automatic sizing).
#'
#' @param labColSize Size of axes, in pixels.
#'
#' @param labRowSize Size of axes, in pixels.
#'
#' @param cexCol Font size of column labels, as a scalar to '12px' font. Default to
#' 0.2 + 1/log10(ncol(x)).
#'
#' @param cexRow Font size of row labels, as a scalar to '12px' font size. Defaults to
#' 0.2 + 1/log10(nrow(x)).
#'
#' @param srtCol Angle of axis labels. Defaults to 60. Maximum of 90 (vertical), minimum of 25.
#'
#' @param sideCol,xaxis.location 3 or 1, for "bottom" or "top", which side column labels
#' display. Defaults to 3 ("bottom"). For \code{xaxis.location} use "bottom"
#' or "top".
#'
#' @param sideRow,yaxis.location 2 or 4, for "left" or "right", which side row labels
#' display. Defaults to 4 ("right"). For \code{yaxis.location} use "left" or "right".
#'
#' @param xlab Title text of x axis
#'
#' @param ylab Title text of y axis
#'
#' @param xaxis_title_font_size Font size of x axis title in pixels. Defaults to 14.
#'
#' @param yaxis_title_font_size Font size of y axis title in pixels. Defaults to 14.
#'
#' @param brush_color The base color to be used for the brush. The brush will be
#' filled with a low-opacity version of this color. \code{"#RRGGBB"} format
#' expected.
#'
#' @param show_grid \code{TRUE} to show gridlines, \code{FALSE} to hide them, or
#' a numeric value to specify the gridline thickness in pixels (can be a non-integer).
#'
#' @param anim_duration Number of milliseconds to animate zooming in and out.
#' For large \code{x} it may help performance to set this value to \code{0}.
#'
#' @param symm logical indicating if x should be treated symmetrically; can only be true when x is a square matrix.
#'
#' @param revC logical indicating if the column order should be reversed for plotting.
#' Default (when missing) - is FALSE, unless symm is TRUE.
#' This is useful for cor matrix.
#'
#' @param scale character indicating if the values should be centered and scaled in either
#' the row direction or the column direction, or none. The default is "none".
#'
#' @param scale.by.range logical indicating whether to scale rows or columns by
#' the range of each row and column. Setting this parameter to \code{TRUE}
#' automatically sets \code{na.rm} to \code{TRUE}
#'
#' @param na.rm logical indicating whether NA's should be removed.
#'
#' @param na.value numeric indicating where NA's should be substituted to trigger the NA color.
#'
#' @param na.color Color of NA values in heatmap. Defaults to neutral gray.
#'
#' @param rng A vector of two numbers, namely the minimum and maximum value
#' to use when determining the mapping from values to colors. This is useful
#' when the range of values changes between heatmaps, but colors should be the
#' same (optional, defaults to the minimum and maximum of \code{x}).
#'
#' @param digits \emph{integer} indicating the number of decimal places to be used by \link{round} for 'label'.
#'
#' @param notecol \emph{character} name or hex specifying the color of the values printed
#' inside the cells
#'
#' @param notecex,cex.note \emph{numeric} scalar of 12 to determine pixel size of printed cell values.
#' inside the cells. If not specified, the minimum font size between the x and y axes.
#'
#' @param cellnote_row \emph{character} Label to display next to the row value when the user hovers over the cell.
#' If not specified, tries to match the \code{xlab}; if no axis title, defaults to "Row".
#'
#' @param cellnote_col \emph{character} Label to display next to the column value when the user hovers over the cell.
#' If not specified, tries to match the \code{ylab}; if no axis title, defaults to "Col".
#'
#' @param cellnote_val \emph{character} Label to display next to the cell value when the user hovers over the cell.
#' Defaults to "Value".
#'
#' @param cellnote \emph{numeric} (optional) matrix of the same dimensions as \code{x} that has the human-readable version of each value, for displaying to the user on hover. If \code{NULL}, then \code{x} will be coerced using \code{\link{as.character}}.
#' If missing, it will use \code{x}, after rounding it based on the \code{digits} parameter.
#'
#' @param cellnote_scale \emph{logical} (default is FALSE). IF cellnote is missing and x is used, should cellnote be scaled if x is also scaled?
#'
#' @param labRow character vectors with row labels to use (from top to bottom); default to rownames(x).
#'
#' @param labCol character vectors with column labels to use (from left to right); default to colnames(x).
#'
#' @param ColSideColors (optional) character vector of length ncol(x), or matrix with
#' columns equal to ncol(x), containing the color names for a horizontal side bar that may
#' be used to annotate the columns of x. \code{ColIndividualColors}, from heatmap.2, can
#' also be used
#'
#' @param RowSideColors (optional) character vector of length nrow(x), or matrix with rows
#' equal to nrow(x), containing the color names for a vertical side bar that may be used to
#' annotate the rows of x. \code{RowIndividualColors}, from heatmap.3, can also be used
#'
#' @param RowColorsPalette a palette of colors to use for RowSideColors if passing a non-color matrix
#'
#' @param ColColorsPalette a palette of colors to use for ColSideColors if passing a non-color matrix
#'
#' @param RowColorsNames the names of the variables for RowSideColors. Overrides colnames(RowSideColors)
#'
#' @param ColColorsNames the names of the variables for ColSideColors. Overrides rownames(ColSideColors)
#' with rows equal to nrow(x), containing the color names for a vertical side bar that may be used to annotate the
#' rows of x.
#'
#' @param ... a catch for undocumented features or unused arguments from heatmap.2
#' or heatmap.3, to enable direct use of those formulations in d3heatmap
#'
#' @import htmlwidgets
#'
#' @source
#' The interface was designed based on \link{heatmap} and \link[gplots]{heatmap.2}
#'
#' @seealso
#' \link{heatmap}, \link[gplots]{heatmap.2}
#'
#' @examples
#' \dontrun{
#'
#' d3heatmap(mtcars, scale = "column", col = "Blues")
#'
#' }
#'
#' @export
d3heatmap <- function(x
, main = NULL
, width = NULL
, height = NULL
, show_grid = TRUE
, anim_duration = 500
, rng = NULL
## dendrogram control
, symm = FALSE
, Rowv = TRUE
, Colv = if (symm) "Rowv" else TRUE
, distfun = dist
, hclustfun = hclust
, dendrogram = c("both", "row", "column", "none")
, reorderfun = function(d, w) reorder(d, w)
, k_row = NULL
, k_col = NULL
, kr
, kc
, revC = NULL
## data scaling
, scale = c("none", "row", "column")
, scale.by.range = FALSE
, na.rm = TRUE
, na.color = "#777777"
, na.value = NA
## legend (color key)
, key = FALSE
, keysize = 1
, key.title = NULL
, key.location = c("fl", "br", "tr", "tl", "bl")
, density.info = c('histogram', 'none')
, denscol = NULL
## cellnote formatting
, digits = 3L
, cellnote = NULL
, cellnote_scale = FALSE
, cellnote_row = NULL
, cellnote_col = NULL
, cellnote_val = "Value"
, brush_color = "#0000FF"
, print.values = FALSE
, notecol = '#222222'
, notecex = 1
, cex.note
## color controls
, theme = NULL
, col = "RdYlBu"
, breaks = NULL
, symbreaks = FALSE
## axis controls
, labRow = rownames(x)
, labCol = colnames(x)
, labColSize = 80
, labRowSize = 120
, cexCol = NULL
, cexRow = NULL
, srtCol = 60
, sideCol = 3
, sideRow = 4
, xaxis.location
, yaxis.location
, xlab = NULL
, ylab = NULL
, xaxis_title_font_size = 14
, yaxis_title_font_size = 14
# side colors
, ColSideColors = NULL
, RowSideColors = NULL
, RowColorsPalette = NULL
, ColColorsPalette = NULL
, RowColorsNames = NULL
, ColColorsNames = NULL
, ...
) {
if(length(dim(x)) != 2) {
stop(paste("x is not a 2-dimensional object. Here is the str output of x:", capture.output(str(x)), collapse = "\n"))
}
if(is.matrix(x) && !is.numeric(x)) {
warning(paste(capture.output(str(x)), collapse = "\n"))
stop("d3heatmap data must be a numeric
matrix or a data.frame with numeric columns")
}
# we'll modify this to take any matrix or data.frame, but filter out all
# non-numeric columns
if (is.data.frame(x) | is.table(x))
x <- x[, sapply(x, is.numeric)]
opts <- list(...)
axis.locations <- c("top", "left", "bottom", "right")
## pre-process paraemters
##===========================================================
## process the overlap of parameters between the old d3heatmap,
## heatmap.2, and heatmap.3 APIs
if (!missing(kr)) k_row <- kr
if (!missing(kc)) k_col <- kc
if (!missing(cex.note)) notecex <- cex.note
if(!is.null(ColSideColors))
ColSideColors <- matrix(ColSideColors, ncol = ncol(x))
if(!is.null(RowSideColors))
RowSideColors <- matrix(RowSideColors, nrow = nrow(x))
if (!is.null(opts$ColIndividualColors))
ColSideColors <- matrix(opts$ColIndividualColors, ncol = ncol(x))
if (!is.null(opts$RowIndividualColors))
RowSideColors <- matrix(opts$RowIndividualColors, nrow = nrow(x))
if (is.null(RowColorsPalette))
RowColorsPalette <- c('blue', 'orange', 'black')
if (is.null(ColColorsPalette))
ColColorsPalette <- c('cyan', 'maroon', 'grey')
if (is.null(RowColorsNames)) RowColorsNames <- colnames(RowSideColors)
if (is.null(ColColorsNames)) ColColorsNames <- rownames(ColSideColors)
## additional controls for working with the gadget (shiny inputs)
##===========================================================
if (!is.null(k_row)) if (is.na(k_row)) k_row <- NULL
if (!is.null(k_col)) if (is.na(k_col)) k_col <- NULL
if (!is.null(cexCol)) if (is.na(cexCol)) cexCol <- NULL
if (!is.null(cexRow)) if (is.na(cexRow)) cexRow <- NULL
if(!missing(xaxis.location)) {
xaxis.location <- tolower(xaxis.location)
if (xaxis.location %in% c('top', 'bottom'))
sideCol <- which(axis.locations == xaxis.location)
}
if(!missing(yaxis.location)) {
yaxis.location <- tolower(yaxis.location)
if (yaxis.location %in% c('left', 'right'))
sideRow <- which(axis.locations == yaxis.location)
}
## Save the parameters for later API calls
##===========================================================
## For the updated API, we need to be able to access stuff passed into
## the original call to d3heatmap before everything is processed (and there
## is a lot of processing going on here). Primarily we need those items
## passed into the internal heatmap() function, which does the lion's share
## of the generating
params <- list(
x = x
, Rowv = Rowv
, Colv = Colv
, distfun = distfun
, hclustfun = hclustfun
, dendrogram = match.arg(dendrogram)
, reorderfun = reorderfun
, k_row = k_row
, k_col = k_col
, symm = symm
, revC = revC
, scale = match.arg(scale)
, scale.by.range = scale.by.range
, na.rm = na.rm
, na.value = na.value
, digits = digits
, cellnote = cellnote
, cellnote_scale = cellnote_scale
, labRow = labRow
, labCol = labCol
, col = col
, symbreaks = symbreaks
, na.color = na.color
, rng = rng
, breaks = breaks
, RowSideColors = RowSideColors
, ColSideColors = ColSideColors
, RowColorsPalette = RowColorsPalette
, ColColorsPalette = ColColorsPalette
)
## the big call to create the heatmap
##==============================
## inserting new call to the refactored heatmap function, which does everything up to
## this point that the old d3heatmap procedure did
hm <- do.call(heatmap, args = params)
x <- hm$x
## Colors for the heatmap and the color key (legend)
##===========================================
hm_colors <- heatmapColors(x
, params$col
, params$na.color
, params$na.rm
, params$rng
, params$scale
, params$breaks
, params$symbreaks
)
## axis and cellnote labels sync
##==============================
if (is.null(cellnote_row)) cellnote_row <- ylab
if (is.null(cellnote_col)) cellnote_col <- xlab
## font sizes
##==============================
if (is.null(cexCol)) cexCol <- 0.2 + 1 / log10(ncol(x))
if (is.null(cexRow)) cexRow <- 0.2 + 1 / log10(nrow(x))
## bundling the options
##==============================================
srtCol <- min(90, max(srtCol, 25))
key.location <- match.arg(key.location)
axis.locations <- c("top", "left", "bottom", "right")
if (!sideCol %in% c(1, 3)) sideCol <- 3
if (!sideRow %in% c(2, 4)) sideRow <- 4
options <- list(
hm_width = width
, hm_height = height
, xaxis_height = labColSize
, yaxis_width = labRowSize
, xaxis_font_size = cexCol * 12
, yaxis_font_size = cexRow * 12
, xaxis_angle = srtCol
, xaxis_location = axis.locations[sideCol]
, yaxis_location = axis.locations[sideRow]
, xaxis_title = xlab
, yaxis_title = ylab
, xaxis_title_font_size = xaxis_title_font_size
, yaxis_title_font_size = yaxis_title_font_size
, bins = hm_colors$breaks
, manual_breaks = (length(breaks) > 1)
, symbreaks = symbreaks
, print_values = print.values
, show_legend = key
, legend_scaler = as.numeric(keysize[1])
, legend_title = key.title
, legend_location = key.location
, legend_colors = hm_colors$legend_colors
, legend_bins = hm_colors$legend_bins
, legend_breaks = hm_colors$legend_breaks
, legend_type = match.arg(density.info)
, legend_fill = denscol
, brush_color = brush_color
, na_color = na.color
, show_grid = show_grid
, cellnote_row = cellnote_row
, cellnote_col = cellnote_col
, cellnote_val = cellnote_val
, cellnote_fontsize = notecex * 12
, cellnote_color = notecol
, anim_duration = anim_duration
, rsc_labs = hm$rsclabs
, csc_labs = hm$csclabs
, rsc_cols = hm$rsccols
, csc_cols = hm$csccols
, rsc_colnames = RowColorsNames
, csc_colnames = ColColorsNames
)
if (is.null(hm$rowDend)) c(options, list(yclust_width = 0))
if (is.null(hm$colDend)) c(options, list(xclust_height = 0))
# transpose will cause error if row colors is null
if (!is.null(hm$rowcolors)) hm$rowcolors <- t(hm$rowcolors)
## proceed to the widget
## NOTE: when loading the side colors, we transpose the
## rowSideColors
##=======================================
imgUri <- encodeAsPNG(t(x), hm_colors$col)
payload <- list(
rows = hm$rowDend
, cols = hm$colDend
, matrix = hm$mtx
, title = main
, image = imgUri
, rowcolors = hm$rowcolors
, colcolors = hm$colcolors
, theme = theme
, options = options
, params = params
)
# create widget
htmlwidgets::createWidget(
name = 'd3heatmap'
, payload # the x param
, width = width
, height = height
, package = 'd3heatmap'
, sizingPolicy = htmlwidgets::sizingPolicy(browser.fill = TRUE)
)
}
#' @import png base64enc
encodeAsPNG <- function(x, colors) {
colorData <- as.raw(col2rgb(colors(x), alpha = TRUE))
dim(colorData) <- c(4, ncol(x), nrow(x))
pngData <- png::writePNG(colorData)
encoded <- base64enc::base64encode(pngData)
paste0("data:image/png;base64,", encoded)
}
#' Wrapper functions for using d3heatmap in shiny
#'
#' Use \code{d3heatmapOutput} to create a UI element, and \code{renderD3heatmap}
#' to render the heatmap.
#'
#' @param outputId Output variable to read from
#' @param width,height The width and height of the map (see
#' \link[htmlwidgets]{shinyWidgetOutput})
#' @param expr An expression that generates a \code{\link{d3heatmap}} object
#' @param env The environment in which to evaluate \code{expr}
#' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
#' is useful if you want to save an expression in a variable.
#'
#' @examples
#' \dontrun{
#' library(d3heatmap)
#' library(shiny)
#'
#' ui <- fluidPage(
#' h1("A heatmap demo"),
#' selectInput("palette", "Palette", c("YlOrRd", "RdYlBu", "Greens", "Blues")),
#' checkboxInput("cluster", "Apply clustering"),
#' d3heatmapOutput("heatmap")
#' )
#'
#' server <- function(input, output, session) {
#' output$heatmap <- renderD3heatmap({
#' d3heatmap(
#' scale(mtcars),
#' col = input$palette,
#' dendrogram = if (input$cluster) "both" else "none"
#' )
#' })
#' }
#'
#' shinyApp(ui, server)
#' }
#'
#' @export
d3heatmapOutput <- function(outputId, width = '100%', height = '400px'){
shinyWidgetOutput(outputId, 'd3heatmap', width, height, package = 'd3heatmap')
}
#' @rdname d3heatmapOutput
#' @export
renderD3heatmap <- function(expr, env = parent.frame(), quoted = FALSE) {
if (!quoted) { expr <- substitute(expr) } # force quoted
shinyRenderWidget(expr, d3heatmapOutput, env, quoted = TRUE)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.