R/AnnotationFunction-function.R
In zhongmicai/complexHeatmap: Make Complex Heatmaps
# == title
# Empty Annotation
#
# == param
# -which Whether it is a column annotation or a row annotation?
# -border Whether draw borders of the annotation region?
# -zoom If it is true and when the heatmap is split, the empty annotation slices will have
# equal height or width, and you can see the correspondance between the annotation slices
# and the original heatmap slices.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
#
# == details
# It creates an empty annotation and holds space, later users can add graphics
# by `decorate_annotation`. This function is useful when users have difficulty to
# implement `AnnotationFunction` object.
#
# In following example, an empty annotation is first created and later points are added:
#
# m = matrix(rnorm(100), 10)
# ht = Heatmap(m, top_annotation = HeatmapAnnotation(pt = anno_empty()))
# ht = draw(ht)
# co = column_order(ht)[[1]]
# pt_value = 1:10
# decorate_annotation("pt", {
# pushViewport(viewport(xscale = c(0.5, ncol(mat)+0.5), yscale = range(pt_value)))
# grid.points(seq_len(ncol(mat)), pt_value[co], pch = 16, default.units = "native")
# grid.yaxis()
# popViewport()
# })
#
# And it is similar as using `anno_points`:
#
# Heatmap(m, top_annotation = HeatmapAnnotation(pt = anno_points(pt_value)))
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#empty-annotation
#
# == examples
# anno = anno_empty()
# draw(anno, test = "anno_empty")
# anno = anno_empty(border = FALSE)
# draw(anno, test = "anno_empty without border")
anno_empty = function(which = c("column", "row"), border = TRUE, zoom = FALSE,
width = NULL, height = NULL) {
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
} else {
which = .ENV$current_annotation_which
}
anno_size = anno_width_and_height(which, width, height, unit(1, "cm"))
fun = function(index) {
if(border) grid.rect()
}
anno = AnnotationFunction(
fun = fun,
n = NA,
fun_name = "anno_empty",
which = which,
var_import = list(border, zoom),
subset_rule = list(),
subsetable = TRUE,
height = anno_size$height,
width = anno_size$width,
show_name = FALSE
)
return(anno)
}
# == title
# Subset the Matrix by Rows
#
# == param
# -x A matrix.
# -i The row indices.
#
# == details
# Mainly used for constructing the `AnnotationFunction-class` object.
#
subset_matrix_by_row = function(x, i) x[i, , drop = FALSE]
# == title
# Subset the vector
#
# == param
# -x A vector.
# -i The indices.
#
# == details
# Mainly used for constructing the `AnnotationFunction-class` object.
#
subset_vector = function(x, i) x[i]
# == title
# Simple Annotation
#
# == param
# -x The value vector. The value can be a vector or a matrix. The length of the vector
# or the nrow of the matrix is taken as the number of the observations of the annotation.
# The value can be numeric or character and NA value is allowed.
# -col Color that maps to ``x``. If ``x`` is numeric and needs a continuous mapping, ``col``
# should be a color mapping function which accepts a vector of values and returns a
# vector of colors. Normally it is generated by `circlize::colorRamp2`. If ``x`` is discrete
# (numeric or character) and needs a discrete color mapping, ``col`` should be a vector of
# colors with levels in ``x`` as vector names. If ``col`` is not specified, the color mapping
# is randomly generated by ``ComplexHeatmap:::default_col``.
# -na_col Color for NA value.
# -which Whether it is a column annotation or a row annotation?
# -border Wether draw borders of the annotation region?
# -gp Graphic parameters for grid borders. The ``fill`` parameter is disabled.
# -pch Points/symbols that are added on top of the annotation grids. The value can be numeric
# or single letters. It can be a vector if ``x`` is a vector and a matrix if ``x`` is a matrix.
# No points are drawn if the corresponding values are NA.
# -pt_size Size of the points/symbols. It should be a `grid::unit` object. If ``x`` is a vector,
# the value of ``pt_size`` can be a vector, while if ``x`` is a matrix, ``pt_size`` can
# only be a single value.
# -pt_gp Graphic parameters for points/symbols. The length setting is same as ``pt_size``.
# If ``pch`` is set as letters, the fontsize should be set as ``pt_gp = gpar(fontsize = ...)``.
# -simple_anno_size size of the simple annotation.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
#
# == details
# The "simple annotation" is the most widely used annotation type which is heatmap-like, where
# the grid colors correspond to the values. `anno_simple` also supports to add points/symbols
# on top of the grids where the it can be normal point (when ``pch`` is set as numbers) or letters (when
# ``pch`` is set as single letters).
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#simple-annotation-as-an-annotation-function
#
# == example
# anno = anno_simple(1:10)
# draw(anno, test = "a numeric vector")
#
# anno = anno_simple(cbind(1:10, 10:1))
# draw(anno, test = "a matrix")
#
# anno = anno_simple(1:10, pch = c(1:4, NA, 6:8, NA, 10))
# draw(anno, test = "pch has NA values")
#
# anno = anno_simple(1:10, pch = c(rep("A", 5), rep(NA, 5)))
# draw(anno, test = "pch has NA values")
#
# pch = matrix(1:20, nc = 2)
# pch[sample(length(pch), 10)] = NA
# anno = anno_simple(cbind(1:10, 10:1), pch = pch)
# draw(anno, test = "matrix, pch is a matrix with NA values")
anno_simple = function(x, col, na_col = "grey",
which = c("column", "row"), border = FALSE, gp = gpar(col = NA),
pch = NULL, pt_size = unit(1, "snpc")*0.8, pt_gp = gpar(),
simple_anno_size = ht_opt$simple_anno_size,
width = NULL, height = NULL) {
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
} else {
which = .ENV$current_annotation_which
}
if(is.data.frame(x)) x = as.matrix(x)
if(is.matrix(x)) {
if(ncol(x) == 1) {
x = x[, 1]
}
}
input_is_matrix = is.matrix(x)
anno_size = anno_width_and_height(which, width, height,
simple_anno_size*ifelse(input_is_matrix, ncol(x), 1))
if(missing(col)) {
col = default_col(x)
}
if(is.atomic(col)) {
color_mapping = ColorMapping(name = "foo", colors = col, na_col = na_col)
} else if(is.function(col)) {
color_mapping = ColorMapping(name = "foo", col_fun = col, na_col = na_col)
} else if(inherits(col, "ColorMapping")) {
color_mapping = col
} else {
stop_wrap("`col` should be a named vector/a color mapping function/a ColorMapping object.")
}
value = x
gp = subset_gp(gp, 1) # gp controls border
if(is.matrix(value)) {
n = nrow(value)
nr = n
nc = ncol(value)
} else {
n = length(value)
nr = n
nc = 1
}
if(!is.null(pch)) {
if(input_is_matrix) {
pch = normalize_graphic_param_to_mat(pch, ifelse(is.matrix(x), ncol(x), 1), n, "pch")
pt_size = pt_size[1]*(1/nc)
pt_gp = subset_gp(pt_gp, 1)
} else {
if(length(pch) == 1) pch = rep(pch, n)
if(length(pt_size) == 1) pt_size = rep(pt_size, n)
pt_gp = recycle_gp(pt_gp, n)
}
}
row_fun = function(index) {
n = length(index)
y = (n - seq_len(n) + 0.5) / n
if(is.matrix(value)) {
nc = ncol(value)
for(i in seq_len(nc)) {
fill = map_to_colors(color_mapping, value[index, i])
grid.rect(x = (i-0.5)/nc, y, height = 1/n, width = 1/nc,
gp = do.call("gpar", c(list(fill = fill), gp)))
if(!is.null(pch)) {
l = !is.na(pch[, i])
grid.points(x = rep((i-0.5)/nc, sum(l)), y = y[l], pch = pch[l, i],
size = {if(length(pt_size) == 1) pt_size else pt_size[i]},
gp = subset_gp(pt_gp, i))
}
}
} else {
fill = map_to_colors(color_mapping, value[index])
grid.rect(x = 0.5, y, height = 1/n, width = 1, gp = do.call("gpar", c(list(fill = fill), gp)))
if(!is.null(pch)) {
pch = pch[index]
pt_size = pt_size[index]
pt_gp = subset_gp(pt_gp, index)
l = !is.na(pch)
grid.points(x = rep(0.5, sum(l)), y = y[l], pch = pch[l], size = pt_size[l],
gp = subset_gp(pt_gp, which(l)))
}
}
if(border) grid.rect(gp = gpar(fill = "transparent"))
}
column_fun = function(index) {
n = length(index)
x = (seq_len(n) - 0.5) / n
if(is.matrix(value)) {
nc = ncol(value)
for(i in seq_len(nc)) {
fill = map_to_colors(color_mapping, value[index, i])
grid.rect(x, y = (nc-i +0.5)/nc, width = 1/n, height = 1/nc, gp = do.call("gpar", c(list(fill = fill), gp)))
if(!is.null(pch)) {
pch = pch[index, , drop = FALSE]
l = !is.na(pch[, i])
grid.points(x[l], y = rep((nc-i +0.5)/nc, sum(l)), pch = pch[l, i],
size = {if(length(pt_size) == 1) pt_size else pt_size[i]},
gp = subset_gp(pt_gp, i))
}
}
} else {
fill = map_to_colors(color_mapping, value[index])
grid.rect(x, y = 0.5, width = 1/n, height = 1, gp = do.call("gpar", c(list(fill = fill), gp)))
if(!is.null(pch)) {
pch = pch[index]
pt_size = pt_size[index]
pt_gp = subset_gp(pt_gp, index)
l = !is.na(pch)
grid.points(x[l], y = rep(0.5, sum(l)), pch = pch[l], size = pt_size[l],
gp = subset_gp(pt_gp, which(l)))
}
}
if(border) grid.rect(gp = gpar(fill = "transparent"))
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_simple",
which = which,
width = anno_size$width,
height = anno_size$height,
n = n,
data_scale = c(0.5, nc + 0.5),
var_import = list(value, gp, border, color_mapping, pt_gp, pt_size, pch)
)
anno@subset_rule = list()
if(input_is_matrix) {
anno@subset_rule$value = subset_matrix_by_row
if(!is.null(pch)) {
anno@subset_rule$pch = subset_matrix_by_row
}
} else {
anno@subset_rule$value = subset_vector
if(!is.null(pch)) {
anno@subset_rule$pch = subset_vector
anno@subset_rule$pt_size = subset_vector
anno@subset_rule$pt_gp = subset_gp
}
}
anno@subsetable = TRUE
return(anno)
}
# == title
# Image Annotation
#
# == param
# -image A vector of file paths of images. The format of the image is inferred from the suffix name of the image file.
# NA values or empty strings in the vector means no image to drawn.
# -which Whether it is a column annotation or a row annotation?
# -border Wether draw borders of the annotation region?
# -gp Graphic parameters for annotation grids. If the image has transparent background, the ``fill`` parameter
# can be used to control the background color in the annotation grids.
# -space The space around the image to the annotation grid borders. The value should be a `grid::unit` object.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
#
# == details
# This function supports image formats in ``png``, ``svg``, ``pdf``, ``eps``, ``jpeg/jpg``, ``tiff``.
# ``png``, ``jpeg/jpg`` and ``tiff`` images are imported by `png::readPNG`, `jpeg::readJPEG` and
# `tiff::readTIFF`, and drawn by `grid::grid.raster`. ``svg`` images are firstly reformatted by ``rsvg::rsvg_svg``
# and then imported by `grImport2::readPicture` and drawn by `grImport2::grid.picture`. ``pdf`` and ``eps``
# images are imported by `grImport::PostScriptTrace` and `grImport::readPicture`, later drawn by `grImport::grid.picture`.
#
# Different image formats can be mixed in the ``image`` vector.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#image-annotation
#
# == example
# # download the free icons from https://github.com/Keyamoon/IcoMoon-Free
# \dontrun{
# image = sample(dir("~/Downloads/IcoMoon-Free-master/PNG/64px", full.names = TRUE), 10)
# anno = anno_image(image)
# draw(anno, test = "png")
# image[1:5] = ""
# anno = anno_image(image)
# draw(anno, test = "some of png")
# }
anno_image = function(image, which = c("column", "row"), border = TRUE,
gp = gpar(fill = NA, col = NA), space = unit(1, "mm"),
width = NULL, height = NULL) {
image[is.na(image)] = ""
l = grepl("^\\s*$", image)
image[l] = ""
allowed_image_type = c("png", "svg", "pdf", "eps", "jpeg", "jpg", "tiff")
if(inherits(image, "character")) { ## they are file path
image_type = tolower(gsub("^.*\\.(\\w+)$", "\\1", image))
if(! all(image_type[image_type != ""] %in% allowed_image_type)) {
stop_wrap("image file should be of png/svg/pdf/eps/jpeg/jpg/tiff.")
}
} else {
stop_wrap("`image` should be a vector of path.")
}
n_image = length(image)
image_list = vector("list", n_image)
image_class = vector("character", n_image)
for(i in seq_along(image)) {
if(image[i] == "") {
image_list[[i]] = NA
image_class[i] = NA
} else if(image_type[i] == "png") {
if(!requireNamespace("png")) {
stop_wrap("Need png package to read png images.")
}
image_list[[i]] = png::readPNG(image[i])
image_class[i] = "raster"
} else if(image_type[i] %in% c("jpeg", "jpg")) {
if(!requireNamespace("jpeg")) {
stop_wrap("Need jpeg package to read jpeg/jpg images.")
}
image_list[[i]] = jpeg::readJPEG(image[i])
image_class[i] = "raster"
} else if(image_type[i] == "tiff") {
if(!requireNamespace("tiff")) {
stop_wrap("Need tiff package to read tiff images.")
}
image_list[[i]] = tiff::readTIFF(image[i])
image_class[i] = "raster"
} else if(image_type[i] %in% c("pdf", "eps")) {
if(!requireNamespace("grImport")) {
stop_wrap("Need grImport package to read pdf/eps images.")
}
temp_file = tempfile()
getFromNamespace("PostScriptTrace", ns = "grImport")(image[[i]], temp_file)
image_list[[i]] = grImport::readPicture(temp_file)
file.remove(temp_file)
image_class[i] = "grImport::Picture"
} else if(image_type[i] == "svg") {
if(!requireNamespace("grImport2")) {
stop_wrap("Need grImport2 package to read svg images.")
}
# if(!requireNamespace("rsvg")) {
# stop_wrap("Need rsvg package to convert svg images.")
# }
temp_file = tempfile()
# get it work on bioconductor build server
oe = try(getFromNamespace("rsvg_svg", ns = "rsvg")(image[i], temp_file))
if(inherits(oe, "try-error")) {
stop_wrap("Need rsvg package to convert svg images.")
}
image_list[[i]] = grImport2::readPicture(temp_file)
file.remove(temp_file)
image_class[i] = "grImport2::Picture"
}
}
yx_asp = sapply(image_list, function(x) {
if(inherits(x, "array")) {
nrow(x)/ncol(x)
} else if(inherits(x, "Picture")) {
max(x@summary@yscale)/max(x@summary@xscale)
} else {
1
}
})
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
} else {
which = .ENV$current_annotation_which
}
space = space[1]
anno_size = anno_width_and_height(which, width, height, unit(1, "cm"))
gp = recycle_gp(gp, n_image)
column_fun = function(index) {
n = length(index)
pushViewport(viewport())
asp = convertHeight(unit(1, "npc") - space*2, "mm", valueOnly = TRUE)/convertWidth(unit(1/n, "npc") - space*2, "mm", valueOnly = TRUE)
grid.rect(x = (1:n - 0.5)/n, width = 1/n, gp = subset_gp(gp, index))
for(i in seq_len(n)) {
if(identical(image_list[[i]], NA)) next
if(yx_asp[ index[i] ] > asp) {
height = unit(1, "npc") - space*2
width = convertHeight(height, "mm")*yx_asp[ index[i] ]
} else {
width = unit(1/n, "npc") - space*2
height = yx_asp[ index[i] ]*convertWidth(width, "mm")
}
if(image_class[ index[i] ] == "raster") {
grid.raster(image_list[[i]], x = (i-0.5)/n, width = width, height = height)
} else if(image_class[ index[i] ] == "grImport::Picture") {
grid.picture = getFromNamespace("grid.picture", ns = "grImport")
grid.picture(image_list[[i]], x = (i-0.5)/n, width = width, height = height)
} else if(image_class[ index[i] ] == "grImport2::Picture") {
grid.picture = getFromNamespace("grid.picture", ns = "grImport2")
grid.picture(image_list[[i]], x = (i-0.5)/n, width = width, height = height)
}
}
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
row_fun = function(index) {
n = length(index)
pushViewport(viewport())
asp = convertHeight(unit(1/n, "npc") - space*2, "mm", valueOnly = TRUE)/convertWidth(unit(1, "npc") - space*2, "mm", valueOnly = TRUE)
grid.rect(y = (n - 1:n + 0.5)/n, height = 1/n, gp = subset_gp(gp, index))
for(i in seq_len(n)) {
if(identical(image_list[[i]], NA)) next
if(yx_asp[ index[i] ] > asp) {
height = unit(1/n, "npc") - space*2
width = convertHeight(height, "mm")*(1/yx_asp[ index[i] ])
} else {
width = unit(1, "npc") - space*2
height = yx_asp[ index[i] ]*convertWidth(width, "mm")
}
if(image_class[ index[i] ] == "raster") {
grid.raster(image_list[[i]], y = (n - i + 0.5)/n, width = width, height = height)
} else if(image_class[ index[i] ] == "grImport::Picture") {
grid.picture = getFromNamespace("grid.picture", ns = "grImport")
grid.picture(image_list[[i]], y = (n - i + 0.5)/n, width = width, height = height)
} else if(image_class[ index[i] ] == "grImport2::Picture") {
grid.picture = getFromNamespace("grid.picture", ns = "grImport2")
grid.picture(image_list[[i]], y = (n - i + 0.5)/n, width = width, height = height)
}
}
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_image",
which = which,
width = anno_size$width,
height = anno_size$height,
n = n_image,
data_scale = c(0.5, 1.5),
var_import = list(gp, border, space, yx_asp, image_list, image_class)
)
anno@subset_rule$gp = subset_vector
anno@subset_rule$image_list = subset_vector
anno@subset_rule$image_class = subset_vector
anno@subsetable = TRUE
return(anno)
}
# == title
# The Default Parameters for Annotation Axis
#
# == param
# -which Whether it is for column annotation or row annotation?
#
# == details
# There are following parameters for the annotation axis:
#
# -at The breaks of axis. By default it is automatically inferred.
# -labels The corresponding axis labels.
# -labels_rot The rotation of the axis labels.
# -gp Graphc parameters of axis labels. The value should be a `grid::unit` object.
# -side If it is for column annotation, the value should only be one of ``left`` and ``right``. If
# it is for row annotation, the value should only be one of ``top`` and ``bottom``.
# -facing Whether the axis faces to the outside of the annotation region or inside. Sometimes when
# appending more than one heatmaps, the axes of column annotations of one heatmap might
# overlap to the neighbouring heatmap, setting ``facing`` to ``inside`` may invoild it.
#
# == example
# default_axis_param("column")
# default_axis_param("row")
default_axis_param = function(which) {
list(
at = NULL,
labels = NULL,
labels_rot = ifelse(which == "column", 0, 90),
gp = gpar(fontsize = 8),
side = ifelse(which == "column", "left", "bottom"),
facing = "outside"
)
}
validate_axis_param = function(axis_param, which) {
dft = default_axis_param(which)
for(nm in names(axis_param)) {
dft[[nm]] = axis_param[[nm]]
}
if(which == "row") {
if(dft$side %in% c("left", "right")) {
stop_wrap("axis side can only be set to 'top' or 'bottom' for row annotations.")
}
}
if(which == "column") {
if(dft$side %in% c("top", "bottom")) {
stop_wrap("axis side can only be set to 'left' or 'right' for row annotations.")
}
}
return(dft)
}
construct_axis_grob = function(axis_param, which, data_scale) {
axis_param_default = default_axis_param(which)
for(nm in setdiff(names(axis_param_default), names(axis_param))) {
axis_param[[nm]] = axis_param_default[[nm]]
}
if(is.null(axis_param$at)) {
at = pretty_breaks(data_scale)
axis_param$at = at
axis_param$labels = at
}
if(is.null(axis_param$labels)) {
axis_param$labels = axis_param$at
}
axis_grob = do.call(annotation_axis_grob, axis_param)
return(axis_grob)
}
# == title
# Points Annotation
#
# == param
# -x The value vector. The value can be a vector or a matrix. The length of the vector
# or the number of rows of the matrix is taken as the number of the observations of the annotation.
# -which Whether it is a column annotation or a row annotation?
# -border Wether draw borders of the annotation region?
# -gp Graphic parameters for points. The length of each graphic parameter can be 1, length of ``x`` if ``x``
# is a vector, or number of columns of ``x`` is ``x`` is a matrix.
# -pch Point type. The length setting is the same as ``gp``.
# -size Point size, the value should be a `grid::unit` object. The length setting is the same as ``gp``.
# -ylim Data ranges. By default it is ``range(x)``.
# -extend The extension to both side of ``ylim``. The value is a percent value corresponding to ``ylim[2] - ylim[1]``.
# -axis Whether to add axis?
# -axis_param parameters for controlling axis. See `default_axis_param` for all possible settings and default parameters.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
# -... Other arguments.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#points-annotation
#
# == example
# anno = anno_points(runif(10))
# draw(anno, test = "anno_points")
# anno = anno_points(matrix(runif(20), nc = 2), pch = 1:2)
# draw(anno, test = "matrix")
anno_points = function(x, which = c("column", "row"), border = TRUE, gp = gpar(), pch = 16,
size = unit(2, "mm"), ylim = NULL, extend = 0.05, axis = TRUE,
axis_param = default_axis_param(which), width = NULL, height = NULL, ...) {
other_args = list(...)
if(length(other_args)) {
if("axis_gp" %in% names(other_args)) {
stop_wrap("`axis_gp` is removed from the arguments. Use `axis_param = list(gp = ...)` instead.")
}
if("axis_direction" %in% names(other_args)) {
stop_wrap("`axis_direction` is not supported any more.")
}
}
ef = function() NULL
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
dev.null()
ef = dev.off2
} else {
which = .ENV$current_annotation_which
}
on.exit(ef())
if(is.data.frame(x)) x = as.matrix(x)
if(is.matrix(x)) {
if(ncol(x) == 1) {
x = x[, 1]
}
}
input_is_matrix = is.matrix(x)
anno_size = anno_width_and_height(which, width, height, unit(1, "cm"))
if(is.matrix(x)) {
n = nrow(x)
nr = n
nc = ncol(x)
} else {
n = length(x)
nr = n
nc = 1
}
if(input_is_matrix) {
gp = recycle_gp(gp, nc)
if(length(pch) == 1) pch = rep(pch, nc)
if(length(size) == 1) size = rep(size, nc)
} else if(is.atomic(x)) {
gp = recycle_gp(gp, n)
if(length(pch) == 1) pch = rep(pch, n)
if(length(size) == 1) size = rep(size, n)
}
if(is.null(ylim)) {
data_scale = range(x, na.rm = TRUE)
} else {
data_scale = ylim
}
data_scale = data_scale + c(-extend, extend)*(data_scale[2] - data_scale[1])
value = x
axis_param = validate_axis_param(axis_param, which)
axis_grob = if(axis) construct_axis_grob(axis_param, which, data_scale) else NULL
row_fun = function(index, k = 1, N = 1) {
n = length(index)
pushViewport(viewport(xscale = data_scale, yscale = c(0.5, n+0.5)))
if(is.matrix(value)) {
for(i in seq_len(ncol(value))) {
grid.points(value[index, i], n - seq_along(index) + 1, gp = subset_gp(gp, i),
default.units = "native", pch = pch[i], size = size[i])
}
} else {
grid.points(value[index], n - seq_along(index) + 1, gp = subset_gp(gp, index), default.units = "native",
pch = pch[index], size = size[index])
}
if(axis_param$side == "top") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "bottom") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
column_fun = function(index, k = 1, N = 1) {
n = length(index)
pushViewport(viewport(yscale = data_scale, xscale = c(0.5, n+0.5)))
if(is.matrix(value)) {
for(i in seq_len(ncol(value))) {
grid.points(seq_along(index), value[index, i], gp = subset_gp(gp, i), default.units = "native", pch = pch[i], size = size[i])
}
} else {
grid.points(seq_along(index), value[index], gp = subset_gp(gp, index), default.units = "native", pch = pch[index], size = size[index])
}
if(axis_param$side == "left") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "right") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_points",
which = which,
width = anno_size$width,
height = anno_size$height,
n = n,
data_scale = data_scale,
var_import = list(value, gp, border, pch, size, axis, axis_param, axis_grob, data_scale)
)
anno@subset_rule$gp = subset_vector
if(input_is_matrix) {
anno@subset_rule$value = subset_matrix_by_row
} else {
anno@subset_rule$value = subset_vector
anno@subset_rule$gp = subset_gp
anno@subset_rule$size = subset_vector
anno@subset_rule$pch = subset_vector
}
anno@subsetable = TRUE
anno@extended = update_anno_extend(anno, axis_grob, axis_param)
return(anno)
}
update_anno_extend = function(anno, axis_grob, axis_param) {
extended = anno@extended
if(is.null(axis_grob)) {
return(extended)
}
if(axis_param$facing == "outside") {
if(axis_param$side == "left") {
extended[[2]] = convertWidth(grobWidth(axis_grob), "mm", valueOnly = TRUE)
} else if(axis_param$side == "right") {
extended[[4]] = convertWidth(grobWidth(axis_grob), "mm", valueOnly = TRUE)
} else if(axis_param$side == "top") {
extended[[3]] = convertHeight(grobHeight(axis_grob), "mm", valueOnly = TRUE)
} else if(axis_param$side == "bottom") {
extended[[1]] = convertHeight(grobHeight(axis_grob), "mm", valueOnly = TRUE)
}
}
return(extended)
}
# == title
# Lines Annotation
#
# == param
# -x The value vector. The value can be a vector or a matrix. The length of the vector
# or the number of rows of the matrix is taken as the number of the observations of the annotation.
# -which Whether it is a column annotation or a row annotation?
# -border Wether draw borders of the annotation region?
# -gp Graphic parameters for lines. The length of each graphic parameter can be 1, or number of columns of ``x`` is ``x`` is a matrix.
# -add_points Whether to add points on the lines?
# -smooth If it is ``TRUE``, smoothing by `stats::loess` is performed. If it is ``TRUE``, ``add_points`` is set to ``TRUE`` by default.
# -pch Point type. The length setting is the same as ``gp``.
# -size Point size, the value should be a `grid::unit` object. The length setting is the same as ``gp``.
# -pt_gp Graphic parameters for points. The length setting is the same as ``gp``.
# -ylim Data ranges. By default it is ``range(x)``.
# -extend The extension to both side of ``ylim``. The value is a percent value corresponding to ``ylim[2] - ylim[1]``.
# -axis Whether to add axis?
# -axis_param parameters for controlling axis. See `default_axis_param` for all possible settings and default parameters.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#lines-annotation
#
# == example
# anno = anno_lines(runif(10))
# draw(anno, test = "anno_lines")
# anno = anno_lines(cbind(c(1:5, 1:5), c(5:1, 5:1)), gp = gpar(col = 2:3))
# draw(anno, test = "matrix")
# anno = anno_lines(cbind(c(1:5, 1:5), c(5:1, 5:1)), gp = gpar(col = 2:3),
# add_points = TRUE, pt_gp = gpar(col = 5:6), pch = c(1, 16))
# draw(anno, test = "matrix")
anno_lines = function(x, which = c("column", "row"), border = TRUE, gp = gpar(),
add_points = smooth, smooth = FALSE, pch = 16, size = unit(2, "mm"), pt_gp = gpar(), ylim = NULL,
extend = 0.05, axis = TRUE, axis_param = default_axis_param(which),
width = NULL, height = NULL) {
ef = function() NULL
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
dev.null()
ef = dev.off2
} else {
which = .ENV$current_annotation_which
}
on.exit(ef())
if(is.data.frame(x)) x = as.matrix(x)
if(is.matrix(x)) {
if(ncol(x) == 1) {
x = x[, 1]
}
}
input_is_matrix = is.matrix(x)
anno_size = anno_width_and_height(which, width, height, unit(1, "cm"))
if(is.matrix(x)) {
n = nrow(x)
nr = n
nc = ncol(x)
} else {
n = length(x)
nr = n
nc = 1
}
if(input_is_matrix) {
gp = recycle_gp(gp, nc)
pt_gp = recycle_gp(pt_gp, nc)
if(length(pch) == 1) pch = rep(pch, nc)
if(length(size) == 1) size = rep(size, nc)
} else if(is.atomic(x)) {
gp = recycle_gp(gp, 1)
pt_gp = recycle_gp(pt_gp, n)
if(length(pch) == 1) pch = rep(pch, n)
if(length(size) == 1) size = rep(size, n)
}
if(is.null(ylim)) {
data_scale = range(x, na.rm = TRUE)
} else {
data_scale = ylim
}
data_scale = data_scale + c(-extend, extend)*(data_scale[2] - data_scale[1])
value = x
axis_param = validate_axis_param(axis_param, which)
axis_grob = if(axis) construct_axis_grob(axis_param, which, data_scale) else NULL
row_fun = function(index, k = 1, N = 1) {
n = length(index)
pushViewport(viewport(xscale = data_scale, yscale = c(0.5, n+0.5)))
if(is.matrix(value)) {
for(i in seq_len(ncol(value))) {
x = n - seq_along(index) + 1
y = value[index, i]
if(smooth) {
fit = loess(y ~ x)
x2 = seq(x[1], x[length(x)], length = 100)
y2 = predict(fit, x2)
grid.lines(y2, x2, gp = subset_gp(gp, i), default.units = "native")
} else {
grid.lines(y, x, gp = subset_gp(gp, i), default.units = "native")
}
if(add_points) {
grid.points(y, x, gp = subset_gp(pt_gp, i),
default.units = "native", pch = pch[i], size = size[i])
}
}
} else {
x = n - seq_along(index) + 1
y = value[index]
if(smooth) {
fit = loess(y ~ x)
x2 = seq(x[1], x[length(x)], length = 100)
y2 = predict(fit, x2)
grid.lines(y2, x2, gp = gp, default.units = "native")
} else {
grid.lines(y, x, gp = gp, default.units = "native")
}
if(add_points) {
grid.points(y, x, gp = subset_gp(pt_gp, index), default.units = "native",
pch = pch[index], size = size[index])
}
}
if(axis_param$side == "top") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "bottom") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
column_fun = function(index, k = 1, N = 1) {
n = length(index)
pushViewport(viewport(yscale = data_scale, xscale = c(0.5, n+0.5)))
if(is.matrix(value)) {
for(i in seq_len(ncol(value))) {
x = seq_along(index)
y = value[index, i]
if(smooth) {
fit = loess(y ~ x)
x2 = seq(x[1], x[length(x)], length = 100)
y2 = predict(fit, x2)
grid.lines(x2, y2, gp = subset_gp(gp, i), default.units = "native")
} else {
grid.lines(x, y, gp = subset_gp(gp, i), default.units = "native")
}
if(add_points) {
grid.points(x, y, gp = subset_gp(pt_gp, i),
default.units = "native", pch = pch[i], size = size[i])
}
}
} else {
x = seq_along(index)
y = value[index]
if(smooth) {
fit = loess(y ~ x)
x2 = seq(x[1], x[length(x)], length = 100)
y2 = predict(fit, x2)
grid.lines(x2, y2, gp = gp, default.units = "native")
} else {
grid.lines(x, y, gp = gp, default.units = "native")
}
if(add_points) {
grid.points(seq_along(index), value[index], gp = subset_gp(pt_gp, index), default.units = "native",
pch = pch[index], size = size[index])
}
}
if(axis_param$side == "left") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "right") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_points",
which = which,
width = anno_size$width,
height = anno_size$height,
n = n,
data_scale = data_scale,
var_import = list(value, gp, border, pch, size, pt_gp, axis, axis_param,
axis_grob, data_scale, add_points, smooth)
)
anno@subset_rule$gp = subset_vector
if(input_is_matrix) {
anno@subset_rule$value = subset_matrix_by_row
} else {
anno@subset_rule$value = subset_vector
anno@subset_rule$gp = subset_gp
anno@subset_rule$pt_gp = subset_gp
anno@subset_rule$size = subset_vector
anno@subset_rule$pch = subset_vector
}
anno@subsetable = TRUE
anno@extended = update_anno_extend(anno, axis_grob, axis_param)
return(anno)
}
# == title
# Barplot Annotation
#
# == param
# -x The value vector. The value can be a vector or a matrix. The length of the vector
# or the number of rows of the matrix is taken as the number of the observations of the annotation.
# If ``x`` is a vector, the barplots will be represented as stacked barplots.
# -baseline baseline of bars. The value should be "min" or "max", or a numeric value. It is enforced to be zero
# for stacked barplots.
# -which Whether it is a column annotation or a row annotation?
# -border Wether draw borders of the annotation region?
# -bar_width Relative width of the bars. The value should be smaller than one.
# -gp Graphic parameters for points. The length of each graphic parameter can be 1, length of ``x`` if ``x``
# is a vector, or number of columns of ``x`` is ``x`` is a matrix.
# -ylim Data ranges. By default it is ``range(x)`` if ``x`` is a vector, or ``range(rowSums(x))`` if ``x`` is a matrix.
# -extend The extension to both side of ``ylim``. The value is a percent value corresponding to ``ylim[2] - ylim[1]``.
# -axis Whether to add axis?
# -axis_param parameters for controlling axis. See `default_axis_param` for all possible settings and default parameters.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
# -... Other arguments.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#barplot_annotation
#
# == example
# anno = anno_barplot(1:10)
# draw(anno, test = "a vector")
#
# m = matrix(runif(4*10), nc = 4)
# m = t(apply(m, 1, function(x) x/sum(x)))
# anno = anno_barplot(m, gp = gpar(fill = 2:5), bar_width = 1, height = unit(6, "cm"))
# draw(anno, test = "proportion matrix")
anno_barplot = function(x, baseline = 0, which = c("column", "row"), border = TRUE, bar_width = 0.6,
gp = gpar(fill = "#CCCCCC"), ylim = NULL, extend = 0.05, axis = TRUE,
axis_param = default_axis_param(which),
width = NULL, height = NULL, ...) {
other_args = list(...)
if(length(other_args)) {
if("axis_gp" %in% names(other_args)) {
stop_wrap("`axis_gp` is removed from the arguments. Use `axis_param = list(gp = ...)` instead.")
}
if("axis_side" %in% names(other_args)) {
stop_wrap("`axis_side` is removed from the arguments. Use `axis_param = list(side = ...)` instead.")
}
if("axis_direction" %in% names(other_args)) {
stop_wrap("`axis_direction` is not supported any more.")
}
}
if(inherits(x, "list")) x = do.call("cbind", x)
if(inherits(x, "data.frame")) x = as.matrix(x)
if(inherits(x, "matrix")) {
sg = apply(x, 1, function(xx) all(sign(xx) %in% c(1, 0)) || all(sign(xx) %in% c(-1, 0)))
if(!all(sg)) {
stop_wrap("Since `x` is a matrix, the sign of each row should be either all positive or all negative.")
}
}
# convert everything to matrix
if(is.null(dim(x))) x = matrix(x, ncol = 1)
nc = ncol(x)
if(missing(gp)) {
gp = gpar(fill = grey(seq(0, 1, length = nc+2))[-c(1, nc+2)])
}
data_scale = range(rowSums(x, na.rm = TRUE), na.rm = TRUE)
if(!is.null(ylim)) data_scale = ylim
if(baseline == "min") {
data_scale = data_scale + c(0, extend)*(data_scale[2] - data_scale[1])
baseline = min(x)
} else if(baseline == "max") {
data_scale = data_scale + c(-extend, 0)*(data_scale[2] - data_scale[1])
baseline = max(x)
} else {
if(is.numeric(baseline)) {
if(baseline == 0 && all(abs(rowSums(x) - 1) < 1e-6)) {
data_scale = c(0, 1)
} else if(baseline <= data_scale[1]) {
data_scale = c(baseline, extend*(data_scale[2] - baseline) + data_scale[2])
} else if(baseline >= data_scale[2]) {
data_scale = c(-extend*(baseline - data_scale[1]) + data_scale[1], baseline)
} else {
data_scale = data_scale + c(-extend, extend)*(data_scale[2] - data_scale[1])
}
}
}
ef = function() NULL
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
dev.null()
ef = dev.off2
} else {
which = .ENV$current_annotation_which
}
on.exit(ef())
anno_size = anno_width_and_height(which, width, height, unit(1, "cm"))
if(nc == 1) {
gp = recycle_gp(gp, nrow(x))
} else {
gp = recycle_gp(gp, nc)
}
value = x
axis_param = validate_axis_param(axis_param, which)
axis_grob = if(axis) construct_axis_grob(axis_param, which, data_scale) else NULL
row_fun = function(index, k = 1, N = 1) {
n = length(index)
pushViewport(viewport(xscale = data_scale, yscale = c(0.5, n+0.5)))
if(ncol(value) == 1) {
width = value[index] - baseline
x_coor = width/2+baseline
grid.rect(x = x_coor, y = n - seq_along(index) + 1, width = abs(width), height = 1*bar_width, default.units = "native", gp = subset_gp(gp, index))
} else {
for(i in seq_len(ncol(value))) {
width = value[index, i]
x_coor = rowSums(value[index, seq_len(i-1), drop = FALSE]) + width/2
grid.rect(x = x_coor, y = n - seq_along(index) + 1, width = abs(width), height = 1*bar_width, default.units = "native", gp = subset_gp(gp, i))
}
}
if(axis_param$side == "top") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "bottom") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
column_fun = function(index, k = 1, N = 1) {
n = length(index)
pushViewport(viewport(yscale = data_scale, xscale = c(0.5, n+0.5)))
if(ncol(value) == 1) {
height = value[index] - baseline
y_coor = height/2+baseline
grid.rect(y = y_coor, x = seq_along(index), height = abs(height), width = 1*bar_width, default.units = "native", gp = subset_gp(gp, index))
} else {
for(i in seq_len(ncol(value))) {
height = value[index, i]
y_coor = rowSums(value[index, seq_len(i-1), drop = FALSE]) + height/2
grid.rect(y = y_coor, x = seq_along(index), height = abs(height), width = 1*bar_width, default.units = "native", gp = subset_gp(gp, i))
}
}
if(axis_param$side == "left") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "right") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
n = nrow(value)
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_barplot",
which = which,
width = anno_size$width,
height = anno_size$height,
n = n,
data_scale = data_scale,
var_import = list(value, gp, border, bar_width, baseline, axis, axis_param, axis_grob, data_scale)
)
anno@subset_rule$value = subset_matrix_by_row
if(ncol(value) == 1) {
anno@subset_rule$gp = subset_gp
}
anno@subsetable = TRUE
anno@extended = update_anno_extend(anno, axis_grob, axis_param)
return(anno)
}
# == title
# Boxplot Annotation
#
# == param
# -x A matrix or a list. If ``x`` is a matrix and if ``which`` is ``column``, statistics for boxplots
# are calculated by columns, if ``which`` is ``row``, the calculation is done by rows.
# -which Whether it is a column annotation or a row annotation?
# -border Wether draw borders of the annotation region?
# -gp Graphic parameters for the boxes. The length of the graphic parameters should be one or the number of observations.
# -ylim Data ranges.
# -extend The extension to both side of ``ylim``. The value is a percent value corresponding to ``ylim[2] - ylim[1]``.
# -outline Whether draw outline of boxplots?
# -box_width Relative width of boxes. The value should be smaller than one.
# -pch Point style.
# -size Point size.
# -axis Whether to add axis?
# -axis_param parameters for controlling axis. See `default_axis_param` for all possible settings and default parameters.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
# -... Other arguments.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#box-annotation
#
# == example
# set.seed(123)
# m = matrix(rnorm(100), 10)
# anno = anno_boxplot(m, height = unit(4, "cm"))
# draw(anno, test = "anno_boxplot")
# anno = anno_boxplot(m, height = unit(4, "cm"), gp = gpar(fill = 1:10))
# draw(anno, test = "anno_boxplot with gp")
anno_boxplot = function(x, which = c("column", "row"), border = TRUE,
gp = gpar(fill = "#CCCCCC"), ylim = NULL, extend = 0.05, outline = TRUE, box_width = 0.6,
pch = 1, size = unit(2, "mm"), axis = TRUE, axis_param = default_axis_param(which),
width = NULL, height = NULL, ...) {
other_args = list(...)
if(length(other_args)) {
if("axis_gp" %in% names(other_args)) {
stop_wrap("`axis_gp` is removed from the arguments. Use `axis_param = list(gp = ...)` instead.")
}
if("axis_side" %in% names(other_args)) {
stop_wrap("`axis_side` is removed from the arguments. Use `axis_param = list(side = ...)` instead.")
}
if("axis_direction" %in% names(other_args)) {
stop_wrap("`axis_direction` is not supported any more.")
}
}
ef = function() NULL
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
dev.null()
ef = dev.off2
} else {
which = .ENV$current_annotation_which
}
on.exit(ef())
anno_size = anno_width_and_height(which, width, height, unit(2, "cm"))
## convert matrix all to list (or data frame)
if(is.matrix(x)) {
if(which == "column") {
value = as.data.frame(x)
} else if(which == "row") {
value = as.data.frame(t(x))
}
} else {
value = x
}
if(is.null(ylim)) {
if(!outline) {
boxplot_stats = boxplot(value, plot = FALSE)$stats
data_scale = range(boxplot_stats)
} else {
data_scale = range(value, na.rm = TRUE)
}
} else {
data_scale = ylim
}
data_scale = data_scale + c(-extend, extend)*(data_scale[2] - data_scale[1])
n = length(value)
gp = recycle_gp(gp, n)
if(length(pch) == 1) pch = rep(pch, n)
if(length(size) == 1) size = rep(size, n)
axis_param = validate_axis_param(axis_param, which)
axis_grob = if(axis) construct_axis_grob(axis_param, which, data_scale) else NULL
row_fun = function(index, k = 1, N = 1) {
n_all = length(value)
value = value[index]
boxplot_stats = boxplot(value, plot = FALSE)$stats
n = length(index)
gp = subset_gp(gp, index)
pch = pch[index]
size = size[index]
pushViewport(viewport(xscale = data_scale, yscale = c(0.5, n+0.5)))
grid.rect(x = boxplot_stats[2, ], y = n - seq_along(index) + 1,
height = 1*box_width, width = boxplot_stats[4, ] - boxplot_stats[2, ], just = "left",
default.units = "native", gp = gp)
grid.segments(boxplot_stats[5, ], n - seq_along(index) + 1 - 0.5*box_width,
boxplot_stats[5, ], n - seq_along(index) + 1 + 0.5*box_width,
default.units = "native", gp = gp)
grid.segments(boxplot_stats[5, ], n - seq_along(index) + 1,
boxplot_stats[4, ], n - seq_along(index) + 1,
default.units = "native", gp = gp)
grid.segments(boxplot_stats[1, ], n - seq_along(index) + 1,
boxplot_stats[2, ], n - seq_along(index) + 1,
default.units = "native", gp = gp)
grid.segments(boxplot_stats[1, ], n - seq_along(index) + 1 - 0.5*box_width,
boxplot_stats[1, ], n - seq_along(index) + 1 + 0.5*box_width,
default.units = "native", gp = gp)
grid.segments(boxplot_stats[3, ], n - seq_along(index) + 1 - 0.5*box_width,
boxplot_stats[3, ], n - seq_along(index) + 1 + 0.5*box_width,
default.units = "native", gp = gp)
if(outline) {
for(i in seq_along(value)) {
l1 = value[[i]] > boxplot_stats[5,i]
l1[is.na(l1)] = FALSE
if(sum(l1)) grid.points(y = rep(n - i + 1, sum(l1)), x = value[[i]][l1],
default.units = "native", gp = subset_gp(gp, i), pch = pch[i], size = size[i])
l2 = value[[i]] < boxplot_stats[1,i]
l2[is.na(l2)] = FALSE
if(sum(l2)) grid.points(y = rep(n - i + 1, sum(l2)), x = value[[i]][l2],
default.units = "native", gp = subset_gp(gp, i), pch = pch[i], size = size[i])
}
}
if(axis_param$side == "top") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "bottom") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
column_fun = function(index, k = 1, N = 1) {
value = value[index]
boxplot_stats = boxplot(value, plot = FALSE)$stats
n = length(index)
gp = subset_gp(gp, index)
pch = pch[index]
size = size[index]
pushViewport(viewport(xscale = c(0.5, n+0.5), yscale = data_scale))
grid.rect(x = seq_along(index), y = boxplot_stats[2, ],
height = boxplot_stats[4, ] - boxplot_stats[2, ], width = 1*box_width, just = "bottom",
default.units = "native", gp = gp)
grid.segments(seq_along(index) - 0.5*box_width, boxplot_stats[5, ],
seq_along(index) + 0.5*box_width, boxplot_stats[5, ],
default.units = "native", gp = gp)
grid.segments(seq_along(index), boxplot_stats[5, ],
seq_along(index), boxplot_stats[4, ],
default.units = "native", gp = gp)
grid.segments(seq_along(index), boxplot_stats[1, ],
seq_along(index), boxplot_stats[2, ],
default.units = "native", gp = gp)
grid.segments(seq_along(index) - 0.5*box_width, boxplot_stats[1, ],
seq_along(index) + 0.5*box_width, boxplot_stats[1, ],
default.units = "native", gp = gp)
grid.segments(seq_along(index) - 0.5*box_width, boxplot_stats[3, ],
seq_along(index) + 0.5*box_width, boxplot_stats[3, ],
default.units = "native", gp = gp)
if(outline) {
for(i in seq_along(value)) {
l1 = value[[i]] > boxplot_stats[5,i]
l1[is.na(l1)] = FALSE
if(sum(l1)) grid.points(x = rep(i, sum(l1)), y = value[[i]][l1],
default.units = "native", gp = subset_gp(gp, i), pch = pch[i], size = size[i])
l2 = value[[i]] < boxplot_stats[1,i]
l2[is.na(l2)] = FALSE
if(sum(l2)) grid.points(x = rep(i, sum(l2)), y = value[[i]][l2],
default.units = "native", gp = subset_gp(gp, i), pch = pch[i], size = size[i])
}
}
if(axis_param$side == "left") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "right") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_boxplot",
which = which,
n = n,
width = anno_size$width,
height = anno_size$height,
data_scale = data_scale,
var_import = list(value, gp, border, box_width, axis, axis_param, axis_grob, data_scale, pch, size, outline)
)
anno@subset_rule$value = subset_vector
anno@subset_rule$gp = subset_gp
anno@subset_rule$pch = subset_vector
anno@subset_rule$size = subset_vector
anno@subsetable = TRUE
anno@extended = update_anno_extend(anno, axis_grob, axis_param)
return(anno)
}
# == title
# Histogram Annotation
#
# == param
# -x A matrix or a list. If ``x`` is a matrix and if ``which`` is ``column``, statistics for boxplots
# are calculated by columns, if ``which`` is ``row``, the calculation is done by rows.
# -which Whether it is a column annotation or a row annotation?
# -n_breaks Number of breaks for calculating histogram.
# -border Wether draw borders of the annotation region?
# -gp Graphic parameters for the boxes. The length of the graphic parameters should be one or the number of observations.
# -axis Whether to add axis?
# -axis_param parameters for controlling axis. See `default_axis_param` for all possible settings and default parameters.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#histogram-annotation
#
# == example
# m = matrix(rnorm(1000), nc = 10)
# anno = anno_histogram(t(m), which = "row")
# draw(anno, test = "row histogram")
# anno = anno_histogram(t(m), which = "row", gp = gpar(fill = 1:10))
# draw(anno, test = "row histogram with color")
# anno = anno_histogram(t(m), which = "row", n_breaks = 20)
# draw(anno, test = "row histogram with color")
anno_histogram = function(x, which = c("column", "row"), n_breaks = 11,
border = FALSE, gp = gpar(fill = "#CCCCCC"),
axis = TRUE, axis_param = default_axis_param(which),
width = NULL, height = NULL) {
ef = function() NULL
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
dev.null()
ef = dev.off2
} else {
which = .ENV$current_annotation_which
}
on.exit(ef())
anno_size = anno_width_and_height(which, width, height, unit(4, "cm"))
## convert matrix all to list (or data frame)
if(is.matrix(x)) {
if(which == "column") {
value = as.data.frame(x)
} else if(which == "row") {
value = as.data.frame(t(x))
}
} else {
value = x
}
n = length(value)
x_range =range(unlist(value), na.rm = TRUE)
histogram_stats = lapply(value, hist, plot = FALSE, breaks = seq(x_range[1], x_range[2], length = n_breaks))
histogram_breaks = lapply(histogram_stats, function(x) x$breaks)
histogram_counts = lapply(histogram_stats, function(x) x$counts)
xscale = range(unlist(histogram_breaks), na.rm = TRUE)
xscale = xscale + c(0, 0.05)*(xscale[2] - xscale[1])
yscale = c(0, max(unlist(histogram_counts)))
yscale[2] = yscale[2]*1.05
gp = recycle_gp(gp, n)
axis_param = validate_axis_param(axis_param, which)
axis_grob = if(axis) construct_axis_grob(axis_param, which, xscale) else NULL
row_fun = function(index, k = 1, N = 1) {
n_all = length(value)
value = value[index]
n = length(index)
histogram_breaks = histogram_breaks[index]
histogram_counts = histogram_counts[index]
gp = subset_gp(gp, index)
for(i in seq_len(n)) {
n_breaks = length(histogram_breaks[[i]])
pushViewport(viewport(x = unit(0, "npc"), y = unit((n-i)/n, "npc"), height = unit(1/n, "npc"), just = c("left", "bottom"), xscale = xscale, yscale = yscale))
grid.rect(x = histogram_breaks[[i]][-1], y = 0, width = histogram_breaks[[i]][-1] - histogram_breaks[[i]][-n_breaks], height = histogram_counts[[i]], just = c("right", "bottom"), default.units = "native", gp = subset_gp(gp, i))
popViewport()
}
pushViewport(viewport(xscale = xscale))
if(axis_param$side == "top") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "bottom") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
column_fun = function(index, k = 1, N = 1) {
n_all = length(value)
value = value[index]
foo = yscale
yscale = xscale
xscale = foo
histogram_breaks = histogram_breaks[index]
histogram_counts = histogram_counts[index]
n = length(index)
gp = subset_gp(gp, index)
for(i in seq_len(n)) {
n_breaks = length(histogram_breaks[[i]])
pushViewport(viewport(y = unit(0, "npc"), x = unit(i/n, "npc"), width = unit(1/n, "npc"),
just = c("right", "bottom"), xscale = xscale, yscale = yscale))
grid.rect(y = histogram_breaks[[i]][-1], x = 0, height = histogram_breaks[[i]][-1] - histogram_breaks[[i]][-n_breaks],
width = histogram_counts[[i]], just = c("left", "top"), default.units = "native", gp = subset_gp(gp, i))
popViewport()
}
pushViewport(viewport(yscale = yscale))
if(axis_param$side == "left") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "right") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_histogram",
which = which,
width = anno_size$width,
height = anno_size$height,
n = n,
data_scale = xscale,
var_import = list(value, gp, border, axis, axis_param, axis_grob, xscale, yscale,
histogram_breaks, histogram_counts)
)
anno@subset_rule$value = subset_vector
anno@subset_rule$gp = subset_gp
anno@subset_rule$histogram_breaks = subset_vector
anno@subset_rule$histogram_counts = subset_vector
anno@subsetable = TRUE
anno@extended = update_anno_extend(anno, axis_grob, axis_param)
return(anno)
}
# == title
# Density Annotation
#
# == param
# -x A matrix or a list. If ``x`` is a matrix and if ``which`` is ``column``, statistics for boxplots
# are calculated by columns, if ``which`` is ``row``, the calculation is done by rows.
# -which Whether it is a column annotation or a row annotation?
# -type Type of graphics to represent density distribution. "lines" for normal density plot; "violine" for violin plot
# and "heatmap" for heatmap visualization of density distribution.
# -heatmap_colors A vector of colors for interpolating density values.
# -joyplot_scale Relative height of density distribution. A value higher than 1 increases the height of the density
# distribution and the plot will represented as so-called "joyplot".
# -border Wether draw borders of the annotation region?
# -gp Graphic parameters for the boxes. The length of the graphic parameters should be one or the number of observations.
# -axis Whether to add axis?
# -axis_param parameters for controlling axis. See `default_axis_param` for all possible settings and default parameters.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#density-annotation
#
# == example
# m = matrix(rnorm(100), 10)
# anno = anno_density(m, which = "row")
# draw(anno, test = "normal density")
# anno = anno_density(m, which = "row", type = "violin")
# draw(anno, test = "violin")
# anno = anno_density(m, which = "row", type = "heatmap")
# draw(anno, test = "heatmap")
# anno = anno_density(m, which = "row", type = "heatmap",
# heatmap_colors = c("white", "orange"))
# draw(anno, test = "heatmap, colors")
anno_density = function(x, which = c("column", "row"),
type = c("lines", "violin", "heatmap"),
heatmap_colors = rev(brewer.pal(name = "RdYlBu", n = 11)),
joyplot_scale = 1, border = TRUE, gp = gpar(fill = "#CCCCCC"),
axis = TRUE, axis_param = default_axis_param(which),
width = NULL, height = NULL) {
ef = function() NULL
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
dev.null()
ef = dev.off2
} else {
which = .ENV$current_annotation_which
}
on.exit(ef())
anno_size = anno_width_and_height(which, width, height, unit(4, "cm"))
## convert matrix all to list (or data frame)
if(is.matrix(x)) {
if(which == "column") {
value = as.data.frame(x)
} else if(which == "row") {
value = as.data.frame(t(x))
}
} else {
value = x
}
n = length(value)
gp = recycle_gp(gp, n)
type = match.arg(type)[1]
n_all = length(value)
density_stats = lapply(value, density, na.rm = TRUE)
density_x = lapply(density_stats, function(x) x$x)
density_y = lapply(density_stats, function(x) x$y)
min_density_x = min(unlist(density_x))
max_density_x = max(unlist(density_x))
xscale = range(unlist(density_x), na.rm = TRUE)
xscale = xscale + c(0, 0.05)*(xscale[2] - xscale[1])
if(type == "lines") {
yscale = c(0, max(unlist(density_y)))
yscale[2] = yscale[2]*1.05
} else if(type == "violin") {
yscale = max(unlist(density_y))
yscale = c(-yscale*1.05, yscale*1.05)
} else if(type == "heatmap") {
xscale = range(unlist(density_x), na.rm = TRUE)
yscale = c(0, 1)
min_y = min(unlist(density_y))
max_y = max(unlist(density_y))
col_fun = colorRamp2(seq(min_y, max_y,
length = length(heatmap_colors)), heatmap_colors)
}
axis_param = validate_axis_param(axis_param, which)
axis_grob = if(axis) construct_axis_grob(axis_param, which, xscale) else NULL
row_fun = function(index, k = 1, N = 1) {
n = length(index)
value = value[index]
gp = subset_gp(gp, index)
density_x = density_x[index]
density_y = density_y[index]
for(i in seq_len(n)) {
pushViewport(viewport(x = unit(0, "npc"), y = unit((n-i)/n, "npc"),
just = c("left", "bottom"), height = unit(1/n, "npc"), xscale = xscale,
yscale = yscale))
if(type == "lines") {
grid.polygon(x = density_x[[i]], y = density_y[[i]]*joyplot_scale,
default.units = "native", gp = subset_gp(gp, i))
} else if(type == "violin") {
grid.polygon(x = c(density_x[[i]], rev(density_x[[i]])),
y = c(density_y[[i]], -rev(density_y[[i]])), default.units = "native",
gp = subset_gp(gp, i))
box_stat = boxplot(value[[i]], plot = FALSE)$stat
grid.lines(box_stat[1:2, 1], c(0, 0), default.units = "native",
gp = subset_gp(gp, i))
grid.lines(box_stat[4:5, 1], c(0, 0), default.units = "native",
gp = subset_gp(gp, i))
grid.points(box_stat[3, 1], 0, default.units = "native", pch = 3,
size = unit(1, "mm"), gp = subset_gp(gp, i))
} else if(type == "heatmap") {
n_breaks = length(density_x[[i]])
grid.rect(x = density_x[[i]][-1], y = 0,
width = density_x[[i]][-1] - density_x[[i]][-n_breaks], height = 1,
just = c("right", "bottom"), default.units = "native",
gp = gpar(fill = col_fun((density_y[[i]][-1] + density_y[[i]][-n_breaks])/2),
col = NA))
grid.rect(x = density_x[[i]][1], y = 0, width = density_x[[i]][1] - min_density_x,
height = 1, just = c("right", "bottom"), default.units = "native",
gp = gpar(fill = col_fun(0), col = NA))
grid.rect(x = density_x[[i]][n_breaks], y = 0,
width = max_density_x - density_x[[i]][n_breaks], height = 1,
just = c("left", "bottom"), default.units = "native",
gp = gpar(fill = col_fun(0), col = NA))
}
popViewport()
}
pushViewport(viewport(xscale = xscale))
if(axis_param$side == "top") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "bottom") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
column_fun = function(index, k = 1, N = 1) {
n_all = length(value)
value = value[index]
foo = yscale
yscale = xscale
xscale = foo
density_x = density_x[index]
density_y = density_y[index]
yscale = range(unlist(density_x), na.rm = TRUE)
yscale = yscale + c(0, 0.05)*(yscale[2] - yscale[1])
if(type == "lines") {
xscale = c(0, max(unlist(density_y)))
xscale[2] = xscale[2]*1.05
} else if(type == "violin") {
xscale = max(unlist(density_y))
xscale = c(-xscale*1.05, xscale*1.05)
} else if(type == "heatmap") {
yscale = range(unlist(density_x), na.rm = TRUE)
xscale = c(0, 1)
min_y = min(unlist(density_y))
max_y = max(unlist(density_y))
col_fun = colorRamp2(seq(min_y, max_y,
length = length(heatmap_colors)), heatmap_colors)
}
n = length(index)
gp = subset_gp(gp, index)
for(i in rev(seq_len(n))) {
pushViewport(viewport(y = unit(0, "npc"), x = unit(i/n, "npc"), width = unit(1/n, "npc"),
just = c("right", "bottom"), xscale = xscale, yscale = yscale))
if(type == "lines") {
grid.polygon(y = density_x[[i]], x = density_y[[i]]*joyplot_scale,
default.units = "native", gp = subset_gp(gp, i))
} else if(type == "violin") {
grid.polygon(y = c(density_x[[i]], rev(density_x[[i]])),
x = c(density_y[[i]], -rev(density_y[[i]])), default.units = "native",
gp = subset_gp(gp, i))
box_stat = boxplot(value[[i]], plot = FALSE)$stat
grid.lines(y = box_stat[1:2, 1], x = c(0, 0), default.units = "native",
gp = subset_gp(gp, i))
grid.lines(y = box_stat[4:5, 1], x = c(0, 0), default.units = "native",
gp = subset_gp(gp, i))
grid.points(y = box_stat[3, 1], x = 0, default.units = "native", pch = 3,
size = unit(1, "mm"), gp = subset_gp(gp, i))
} else if(type == "heatmap") {
n_breaks = length(density_x[[i]])
grid.rect(y = density_x[[i]][-1], x = 0,
height = density_x[[i]][-1] - density_x[[i]][-n_breaks], width = 1,
just = c("left", "top"), default.units = "native",
gp = gpar(fill = col_fun((density_y[[i]][-1] + density_y[[i]][-n_breaks])/2),
col = NA))
grid.rect(y = density_x[[i]][1], x = 0, height = density_x[[i]][1] - min_density_x,
width = 1, just = c("left", "top"), default.units = "native",
gp = gpar(fill = col_fun(0), col = NA))
grid.rect(y = density_x[[i]][n_breaks], x = 0,
height = max_density_x - density_x[[i]][n_breaks], width = 1,
just = c("left", "bottom"), default.units = "native",
gp = gpar(fill = col_fun(0), col = NA))
}
popViewport()
}
pushViewport(viewport(yscale = yscale))
if(axis_param$side == "left") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "right") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_density",
which = which,
width = anno_size$width,
height = anno_size$height,
n = n,
data_scale = xscale,
var_import = list(value, gp, border, type, axis, axis_param, axis_grob, xscale, yscale, density_x,
density_y, min_density_x, max_density_x, joyplot_scale, heatmap_colors)
)
if(type == "heatmap") {
anno@var_env$col_fun = col_fun
}
anno@subset_rule$value = subset_vector
anno@subset_rule$gp = subset_gp
anno@subset_rule$density_x = subset_vector
anno@subset_rule$density_y = subset_vector
anno@subsetable = TRUE
anno@extended = update_anno_extend(anno, axis_grob, axis_param)
return(anno)
}
# == title
# Text Annotation
#
# == param
# -x A vector of text.
# -which Whether it is a column annotation or a row annotation?
# -gp Graphic parameters.
# -rot Rotation of the text, pass to `grid::grid.text`.
# -just Justification of text, pass to `grid::grid.text`.
# -offset Depracated, use ``location`` instead.
# -location Position of the text. By default ``rot``, ``just`` and ``location`` are automatically
# inferred according to whether it is a row annotation or column annotation. The value
# of ``location`` should be a `grid::unit` object, normally in ``npc`` unit. E.g. ``unit(0, 'npc')``
# means the most left of the annotation region and ``unit(1, 'npc')`` means the most right of
# the annotation region.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#text-annotation
#
# == example
# anno = anno_text(month.name)
# draw(anno, test = "month names")
# anno = anno_text(month.name, gp = gpar(fontsize = 16))
# draw(anno, test = "month names with fontsize")
# anno = anno_text(month.name, gp = gpar(fontsize = 1:12+4))
# draw(anno, test = "month names with changing fontsize")
# anno = anno_text(month.name, which = "row")
# draw(anno, test = "month names on rows")
# anno = anno_text(month.name, location = 0, rot = 45,
# just = "left", gp = gpar(col = 1:12))
# draw(anno, test = "with rotations")
# anno = anno_text(month.name, location = 1,
# rot = 45, just = "right", gp = gpar(fontsize = 1:12+4))
# draw(anno, test = "with rotations")
anno_text = function(x, which = c("column", "row"), gp = gpar(),
rot = guess_rot(), just = guess_just(),
offset = guess_location(), location = guess_location(),
width = NULL, height = NULL) {
ef = function() NULL
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
dev.null()
ef = dev.off2
} else {
which = .ENV$current_annotation_which
}
on.exit(ef())
n = length(x)
gp = recycle_gp(gp, n)
guess_rot = function() {
ifelse(which == "column", 90, 0)
}
guess_just = function() {
ifelse(which == "column", "right", "left")
}
guess_location = function() {
unit(ifelse(which == "column", 1, 0), "npc")
}
rot = rot[1] %% 360
just = just[1]
if(!missing(offset)) {
warning_wrap("`offset` is deprecated, use `location` instead.")
if(missing(location)) {
location = offset
}
}
location = location[1]
if(!inherits(location, "unit")) {
location = unit(location, "npc")
}
if(which == "column") {
if("right" %in% just) {
if(rot < 180) {
location = location - 0.5*grobHeight(textGrob("A", gp = gp))*abs(cos(rot/180*pi))
} else {
location = location + 0.5*grobHeight(textGrob("A", gp = gp))*abs(cos(rot/180*pi))
}
} else if("left" %in% just) {
if(rot < 180) {
location = location + 0.5*grobHeight(textGrob("A", gp = gp))*abs(cos(rot/180*pi))
} else {
location = location - 0.5*grobHeight(textGrob("A", gp = gp))*abs(cos(rot/180*pi))
}
}
}
if(which == "column") {
if(missing(height)) {
height = max_text_width(x, gp = gp)*abs(sin(rot/180*pi)) + grobHeight(textGrob("A", gp = gp))*abs(cos(rot/180*pi))
height = convertHeight(height, "mm")
}
if(missing(width)) {
width = unit(1, "npc")
}
}
if(which == "row") {
if(missing(width)) {
width = max_text_width(x, gp = gp)*abs(cos(rot/180*pi)) + grobHeight(textGrob("A", gp = gp))*abs(sin(rot/180*pi))
width = convertWidth(width, "mm")
}
if(missing(height)) {
height = unit(1, "npc")
}
}
anno_size = list(width = width, height = height)
value = x
row_fun = function(index) {
n = length(index)
gp = subset_gp(gp, index)
gp2 = gp
if("border" %in% names(gp2)) gp2$col = gp2$border
if("fill" %in% names(gp2)) {
if(!"border" %in% names(gp2)) gp2$col = gp2$fill
}
if(any(c("border", "fill") %in% names(gp2))) {
grid.rect(y = (n - seq_along(index) + 0.5)/n, height = 1/n, gp = gp2)
}
grid.text(value[index], location, (n - seq_along(index) + 0.5)/n, gp = gp, just = just, rot = rot)
}
column_fun = function(index, k = NULL, N = NULL, vp_name = NULL) {
n = length(index)
gp = subset_gp(gp, index)
gp2 = gp
if("border" %in% names(gp2)) gp2$col = gp2$border
if("fill" %in% names(gp2)) {
if(!"border" %in% names(gp2)) gp2$col = gp2$fill
}
if(any(c("border", "fill") %in% names(gp2))) {
grid.rect(x = (seq_along(index) - 0.5)/n, width = 1/n, gp = gp2)
}
grid.text(value[index], (seq_along(index) - 0.5)/n, location, gp = gp, just = just, rot = rot)
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_text",
which = which,
width = width,
height = height,
n = n,
var_import = list(value, gp, just, rot, location),
show_name = FALSE
)
anno@subset_rule$value = subset_vector
anno@subset_rule$gp = subset_gp
anno@subsetable = TRUE
return(anno)
}
# == title
# Joyplot Annotation
#
# == param
# -x A matrix or a list. If ``x`` is a matrix or a data frame, columns correspond to observations.
# -which Whether it is a column annotation or a row annotation?
# -gp Graphic parameters for the boxes. The length of the graphic parameters should be one or the number of observations.
# -scale Relative height of the curve. A value higher than 1 increases the height of the curve.
# -transparency Transparency of the filled colors. Value should be between 0 and 1.
# -axis Whether to add axis?
# -axis_param parameters for controlling axis. See `default_axis_param` for all possible settings and default parameters.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#joyplot-annotation
#
# == example
# m = matrix(rnorm(1000), nc = 10)
# lt = apply(m, 2, function(x) data.frame(density(x)[c("x", "y")]))
# anno = anno_joyplot(lt, width = unit(4, "cm"), which = "row")
# draw(anno, test = "joyplot")
# anno = anno_joyplot(lt, width = unit(4, "cm"), which = "row", gp = gpar(fill = 1:10))
# draw(anno, test = "joyplot + col")
# anno = anno_joyplot(lt, width = unit(4, "cm"), which = "row", scale = 1)
# draw(anno, test = "joyplot + scale")
#
# m = matrix(rnorm(5000), nc = 50)
# lt = apply(m, 2, function(x) data.frame(density(x)[c("x", "y")]))
# anno = anno_joyplot(lt, width = unit(4, "cm"), which = "row", gp = gpar(fill = NA), scale = 4)
# draw(anno, test = "joyplot")
anno_joyplot = function(x, which = c("column", "row"), gp = gpar(fill = "#000000"),
scale = 2, transparency = 0.6,
axis = TRUE, axis_param = default_axis_param(which),
width = NULL, height = NULL) {
ef = function() NULL
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
dev.null()
ef = dev.off2
} else {
which = .ENV$current_annotation_which
}
on.exit(ef())
anno_size = anno_width_and_height(which, width, height, unit(4, "cm"))
## convert matrix all to list (or data frame)
if(is.matrix(x) || is.data.frame(x)) {
value = vector("list", ncol(x))
for(i in seq_len(ncol(x))) {
value[[i]] = cbind(seq_len(nrow(x)), x[, i])
}
} else if(inherits(x, "list")){
if(all(sapply(x, is.atomic))) {
if(length(unique(sapply(x, length))) == 1) {
value = vector("list", length(x))
for(i in seq_len(length(x))) {
value[[i]] = cbind(seq_along(x[[i]]), x[[i]])
}
} else {
stop_wrap("Since x is a list, x need to be a list of two-column matrices.")
}
} else {
value = x
}
} else {
stop_wrap("The input should be a list of two-column matrices or a matrix/data frame.")
}
xscale = range(lapply(value, function(x) x[, 1]), na.rm = TRUE)
xscale = xscale + c(-0.05, 0.05)*(xscale[2] - xscale[1])
yscale = range(lapply(value, function(x) x[, 2]), na.rm = TRUE)
yscale[1] = 0
yscale[2] = yscale[2]*1.05
n = length(value)
if(!"fill" %in% names(gp)) {
gp$fill = "#000000"
}
gp = recycle_gp(gp, n)
gp$fill = add_transparency(gp$fill, transparency)
axis_param = validate_axis_param(axis_param, which)
axis_grob = if(axis) construct_axis_grob(axis_param, which, xscale) else NULL
row_fun = function(index, k = 1, N = 1) {
n_all = length(value)
value = value[index]
n = length(index)
gp = subset_gp(gp, index)
for(i in seq_len(n)) {
pushViewport(viewport(x = unit(0, "npc"), y = unit((n-i)/n, "npc"),
just = c("left", "bottom"), height = unit(1/n, "npc"), xscale = xscale,
yscale = yscale))
x0 = value[[i]][, 1]
y0 = value[[i]][, 2]*scale
x0 = c(x0[1], x0, x0[length(x0)])
y0 = c(0, y0, 0)
gppp = subset_gp(gp, i); gppp$col = NA
grid.polygon(x = x0, y = y0, default.units = "native", gp = gppp)
grid.lines(x = x0, y = y0, default.units = "native",
gp = subset_gp(gp, i))
popViewport()
}
pushViewport(viewport(xscale = xscale))
if(axis_param$side == "top") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "bottom") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
popViewport()
}
column_fun = function(index, k = 1, N = 1) {
n_all = length(value)
value = value[index]
foo = yscale
yscale = xscale
xscale = foo
n = length(index)
gp = subset_gp(gp, index)
for(i in seq_len(n)) {
pushViewport(viewport(y = unit(0, "npc"), x = unit(i/n, "npc"),
width = unit(1/n, "npc"), just = c("right", "bottom"), xscale = xscale,
yscale = yscale))
x0 = value[[i]][, 2]*scale
y0 = value[[i]][ ,1]
x0 = c(0, x0, 0)
y0 = c(y0[1], y0, y0[length(y0)])
gppp = subset_gp(gp, i); gppp$col = NA
grid.polygon(y = y0, x = x0, default.units = "native", gp = gppp)
grid.lines(y = y0, x = x0, default.units = "native",
gp = subset_gp(gp, i))
popViewport()
}
pushViewport(viewport(yscale = yscale))
if(axis_param$side == "left") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "right") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
popViewport()
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_joyplot",
which = which,
width = anno_size$width,
height = anno_size$height,
n = n,
data_scale = xscale,
var_import = list(value, gp, axis, axis_param, axis_grob, scale, yscale, xscale)
)
anno@subset_rule$value = subset_vector
anno@subset_rule$gp = subset_gp
anno@subsetable = TRUE
anno@extended = update_anno_extend(anno, axis_grob, axis_param)
return(anno)
}
# == title
# Horizon chart Annotation
#
# == param
# -x A matrix or a list. If ``x`` is a matrix or a data frame, columns correspond to observations.
# -which Whether it is a column annotation or a row annotation?
# -gp Graphic parameters for the boxes. The length of the graphic parameters should be one or the number of observations.
# There are two unstandard parameters specificly for horizon chart: ``pos_fill`` and ``neg_fill`` controls the filled
# color for positive values and negative values.
# -n_slice Number of slices on y-axis.
# -slice_size Height of the slice. If the value is not ``NULL``, ``n_slice`` will be recalculated.
# -negative_from_top Whether the areas for negative values start from the top or the bottom of the plotting region?
# -normalize Whether normalize ``x`` by max(abs(x)).
# -gap Gap size of neighbouring horizon chart.
# -axis Whether to add axis?
# -axis_param parameters for controlling axis. See `default_axis_param` for all possible settings and default parameters.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
#
# == detail
# Horizon chart as row annotation is only supported.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#horizon-chart-annotation
#
# == example
# lt = lapply(1:20, function(x) cumprod(1 + runif(1000, -x/100, x/100)) - 1)
# anno = anno_horizon(lt, which = "row")
# draw(anno, test = "horizon chart")
# anno = anno_horizon(lt, which = "row",
# gp = gpar(pos_fill = "orange", neg_fill = "darkgreen"))
# draw(anno, test = "horizon chart, col")
# anno = anno_horizon(lt, which = "row", negative_from_top = TRUE)
# draw(anno, test = "horizon chart + negative_from_top")
# anno = anno_horizon(lt, which = "row", gap = unit(1, "mm"))
# draw(anno, test = "horizon chart + gap")
# anno = anno_horizon(lt, which = "row",
# gp = gpar(pos_fill = rep(c("orange", "red"), each = 10),
# neg_fill = rep(c("darkgreen", "blue"), each = 10)))
# draw(anno, test = "horizon chart, col")
anno_horizon = function(x, which = c("column", "row"),
gp = gpar(pos_fill = "#D73027", neg_fill = "#313695"),
n_slice = 4, slice_size = NULL, negative_from_top = FALSE,
normalize = TRUE, gap = unit(0, "mm"),
axis = TRUE, axis_param = default_axis_param(which),
width = NULL, height = NULL) {
ef = function() NULL
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
dev.null()
ef = dev.off2
} else {
which = .ENV$current_annotation_which
}
on.exit(ef())
anno_size = anno_width_and_height(which, width, height, unit(4, "cm"))
## convert matrix all to list (or data frame)
if(is.matrix(x) || is.data.frame(x)) {
value = vector("list", ncol(x))
for(i in seq_len(ncol(x))) {
value[[i]] = cbind(seq_len(nrow(x)), x[, i])
}
} else if(inherits(x, "list")){
if(all(sapply(x, is.atomic))) {
if(length(unique(sapply(x, length))) == 1) {
value = vector("list", length(x))
for(i in seq_len(length(x))) {
value[[i]] = cbind(seq_along(x[[i]]), x[[i]])
}
} else {
stop_wrap("Since x is a list, x need to be a list of two-column matrices.")
}
} else {
value = x
}
} else {
stop_wrap("The input should be a list of two-column matrices or a matrix/data frame.")
}
if(is.null(gp$pos_fill)) gp$pos_fill = "#D73027"
if(is.null(gp$neg_fill)) gp$neg_fill = "#313695"
if("fill" %in% names(gp)) {
foo = unlist(lapply(value, function(x) x[, 2]))
if(all(foo >= 0)) {
gp$pos_fill = gp$fill
} else if(all(foo <= 0)) {
gp$neg_fill = gp$fill
} else {
gp = gpar(pos_fill = "#D73027", neg_fill = "#313695")
}
}
if(which == "column") {
stop_wrap("anno_horizon() does not support column annotation.")
}
if(normalize) {
value = lapply(value, function(m) {
m[, 2] = m[, 2]/max(abs(m[, 2]))
m
})
}
n = length(value)
xscale = range(lapply(value, function(x) x[, 1]), na.rm = TRUE)
yscale = range(lapply(value, function(x) abs(x[, 2])), na.rm = TRUE)
axis_param = validate_axis_param(axis_param, which)
axis_grob = if(axis) construct_axis_grob(axis_param, which, xscale) else NULL
row_fun = function(index, k = 1, N = 1) {
n_all = length(value)
value = value[index]
if(is.null(slice_size)) {
slice_size = yscale[2]/n_slice
}
n_slice = ceiling(yscale[2]/slice_size)
n = length(index)
gp = subset_gp(gp, index)
for(i in seq_len(n)) {
pushViewport(viewport(x = unit(0, "npc"), y = unit((n-i)/n, "npc"), just = c("left", "bottom"),
height = unit(1/n, "npc") - gap))
sgp = subset_gp(gp, i)
horizon_chart(value[[i]][, 1], value[[i]][, 2], n_slice = n_slice, slice_size = slice_size,
negative_from_top = negative_from_top, pos_fill = sgp$pos_fill, neg_fill = sgp$neg_fill)
grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
pushViewport(viewport(xscale = xscale))
if(axis_param$side == "top") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "bottom") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
popViewport()
}
column_fun = function(index) {
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_horizon",
which = which,
width = anno_size$width,
height = anno_size$height,
n = n,
data_scale = xscale,
var_import = list(value, gp, axis, axis_param, axis_grob, n_slice, slice_size,
negative_from_top, xscale, yscale, gap)
)
anno@subset_rule$value = subset_vector
anno@subset_rule$gp = subset_gp
anno@subsetable = TRUE
anno@extended = update_anno_extend(anno, axis_grob, axis_param)
return(anno)
}
horizon_chart = function(x, y, n_slice = 4, slice_size, pos_fill = "#D73027", neg_fill = "#313695",
negative_from_top = FALSE) {
if(missing(slice_size)) {
slice_size = max(abs(y))/n_slice
}
n_slice = ceiling(max(abs(y))/slice_size)
if(n_slice == 0) {
return(invisible(NULL))
}
pos_col_fun = colorRamp2(c(0, n_slice), c("white", pos_fill))
neg_col_fun = colorRamp2(c(0, n_slice), c("white", neg_fill))
pushViewport(viewport(xscale = range(x), yscale = c(0, slice_size)))
for(i in seq_len(n_slice)) {
l1 = y >= (i-1)*slice_size & y < i*slice_size
l2 = y < (i-1)*slice_size
l3 = y >= i*slice_size
if(any(l1)) {
x2 = x
y2 = y
y2[l1] = y2[l1] - slice_size*(i-1)
y2[l3] = slice_size
x2[l2] = NA
y2[l2] = NA
add_horizon_polygon(x2, y2, gp = gpar(fill = pos_col_fun(i), col = NA),
default.units = "native")
}
}
y = -y
for(i in seq_len(n_slice)) {
l1 = y >= (i-1)*slice_size & y < i*slice_size
l2 = y < (i-1)*slice_size
l3 = y >= i*slice_size
if(any(l1)) {
x2 = x
y2 = y
y2[l1] = y2[l1] - slice_size*(i-1)
y2[l3] = slice_size
x2[l2] = NA
y2[l2] = NA
add_horizon_polygon(x2, y2, slice_size = slice_size, from_top = negative_from_top,
gp = gpar(fill = neg_col_fun(i), col = NA), default.units = "native")
}
}
popViewport()
}
# x and y may contain NA, split x and y by NA gaps, align the bottom to y = 0
add_horizon_polygon = function(x, y, slice_size = NULL, from_top = FALSE, ...) {
ltx = split_vec_by_NA(x)
lty = split_vec_by_NA(y)
for(i in seq_along(ltx)) {
x0 = ltx[[i]]
y0 = lty[[i]]
if(from_top) {
x0 = c(x0[1], x0, x0[length(x0)])
y0 = c(slice_size, slice_size - y0, slice_size)
} else {
x0 = c(x0[1], x0, x0[length(x0)])
y0 = c(0, y0, 0)
}
grid.polygon(x0, y0, ...)
}
}
# https://stat.ethz.ch/pipermail/r-help/2010-April/237031.html
split_vec_by_NA = function(x) {
idx = 1 + cumsum(is.na(x))
not.na = !is.na(x)
split(x[not.na], idx[not.na])
}
# == title
# Points as Row Annotation
#
# == param
# -... pass to `anno_points`.
#
# == details
# A wrapper of `anno_points` with pre-defined ``which`` to ``row``.
#
# You can directly use `anno_points` for row annotation if you call it in `rowAnnotation`.
#
# == value
# See help page of `anno_points`.
#
row_anno_points = function(...) {
if(exists(".__under_SingleAnnotation__", envir = parent.frame())) {
message_wrap("From version 1.99.0, you can directly use `anno_points()` for row annotation if you call it in `rowAnnotation()`.")
}
anno_points(..., which = "row")
}
# == title
# Barplots as Row Annotation
#
# == param
# -... pass to `anno_barplot`.
#
# == details
# A wrapper of `anno_barplot` with pre-defined ``which`` to ``row``.
#
# You can directly use `anno_barplot` for row annotation if you call it in `rowAnnotation`.
#
# == value
# See help page of `anno_barplot`.
#
row_anno_barplot = function(...) {
if(exists(".__under_SingleAnnotation__", envir = parent.frame())) {
message_wrap("From version 1.99.0, you can directly use `anno_barplot()` for row annotation if you call it in `rowAnnotation()`.")
}
anno_barplot(..., which = "row")
}
# == title
# Boxplots as Row Annotation
#
# == param
# -... pass to `anno_boxplot`.
#
# == details
# A wrapper of `anno_boxplot` with pre-defined ``which`` to ``row``.
#
# You can directly use `anno_boxplot` for row annotation if you call it in `rowAnnotation`.
#
# == value
# See help page of `anno_boxplot`.
#
row_anno_boxplot = function(...) {
if(exists(".__under_SingleAnnotation__", envir = parent.frame())) {
message_wrap("From version 1.99.0, you can directly use `anno_boxplot()` for row annotation if you call it in `rowAnnotation()`.")
}
anno_boxplot(..., which = "row")
}
# == title
# Histograms as Row Annotation
#
# == param
# -... pass to `anno_histogram`.
#
# == details
# A wrapper of `anno_histogram` with pre-defined ``which`` to ``row``.
#
# You can directly use `anno_histogram` for row annotation if you call it in `rowAnnotation`.
#
# == value
# See help page of `anno_histogram`.
#
row_anno_histogram = function(...) {
if(exists(".__under_SingleAnnotation__", envir = parent.frame())) {
message_wrap("From version 1.99.0, you can directly use `anno_histogram()` for row annotation if you call it in `rowAnnotation()`.")
}
anno_histogram(..., which = "row")
}
# == title
# Density as Row Annotation
#
# == param
# -... pass to `anno_density`.
#
# == details
# A wrapper of `anno_density` with pre-defined ``which`` to ``row``.
#
# You can directly use `anno_density` for row annotation if you call it in `rowAnnotation`.
#
# == value
# See help page of `anno_density`.
#
row_anno_density = function(...) {
if(exists(".__under_SingleAnnotation__", envir = parent.frame())) {
message_wrap("From version 1.99.0, you can directly use `anno_density()` for row annotation if you call it in `rowAnnotation()`.")
}
anno_density(..., which = "row")
}
# == title
# Text as Row Annotation
#
# == param
# -... pass to `anno_text`.
#
# == details
# A wrapper of `anno_text` with pre-defined ``which`` to ``row``.
#
# You can directly use `anno_text` for row annotation if you call it in `rowAnnotation`.
#
# == value
# See help page of `anno_text`.
#
row_anno_text = function(...) {
if(exists(".__under_SingleAnnotation__", envir = parent.frame())) {
message_wrap("From version 1.99.0, you can directly use `anno_text()` for row annotation if you call it in `rowAnnotation()`.")
}
anno_text(..., which = "row")
}
# == title
# Link annotation with labels
#
# == param
# -at Numeric index from the original matrix.
# -labels Corresponding labels.
# -which Whether it is a column annotation or a row annotation?
# -side Side of the labels. If it is a column annotation, valid values are "top" and "bottom";
# If it is a row annotation, valid values are "left" and "right".
# -lines_gp Please use ``link_gp`` instead.
# -link_gp Graphic settings for the segments.
# -labels_gp Graphic settings for the labels.
# -padding Padding between neighbouring labels in the plot.
# -link_width Width of the segments.
# -link_height Similar as ``link_width``, used for column annotation.
# -extend By default, the region for the labels has the same width (if it is a column annotation) or
# same height (if it is a row annotation) as the heatmap. The size can be extended by this options.
# The value can be a proportion number or a `grid::unit` object. The length can be either one or two.
#
# == details
# Sometimes there are many rows or columns in the heatmap and we want to mark some of the rows.
# This annotation function is used to mark these rows and connect labels and corresponding rows
# with links.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#mark-annotation
#
# == example
# anno = anno_mark(at = c(1:4, 20, 60, 97:100), labels = month.name[1:10], which = "row")
# draw(anno, index = 1:100, test = "anno_mark")
#
# m = matrix(1:1000, byrow = TRUE, nr = 100)
# anno = anno_mark(at = c(1:4, 20, 60, 97:100), labels = month.name[1:10], which = "row")
# Heatmap(m, cluster_rows = FALSE, cluster_columns = FALSE) + rowAnnotation(mark = anno)
# Heatmap(m) + rowAnnotation(mark = anno)
anno_mark = function(at, labels, which = c("column", "row"),
side = ifelse(which == "column", "top", "right"),
lines_gp = gpar(), labels_gp = gpar(), padding = 0.5,
link_width = unit(5, "mm"), link_height = link_width,
link_gp = lines_gp,
extend = unit(0, "mm")) {
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
} else {
which = .ENV$current_annotation_which
}
if(!is.numeric(at)) {
stop_wrap(paste0("`at` should be numeric ", which, " index corresponding to the matrix."))
}
n = length(at)
link_gp = recycle_gp(link_gp, n)
labels_gp = recycle_gp(labels_gp, n)
labels2index = structure(seq_along(at), names = labels)
at2labels = structure(labels, names = at)
if(length(extend) == 1) extend = rep(extend, 2)
if(length(extend) > 2) extend = extend[1:2]
if(!inherits(extend, "unit")) extend = unit(extend, "npc")
if(which == "row") {
height = unit(1, "npc")
width = link_width + max_text_width(labels, gp = labels_gp)
} else {
height = link_width + max_text_width(labels, gp = labels_gp)
width = unit(1, "npc")
}
.pos = NULL
.scale = NULL
# a map between row index and positions
# pos_map =
row_fun = function(index) {
n = length(index)
# adjust at and labels
at = intersect(index, at)
if(length(at) == 0) {
return(NULL)
}
labels = rev(at2labels[as.character(at)])
labels_gp = subset_gp(labels_gp, labels2index[labels])
link_gp = subset_gp(link_gp, labels2index[labels])
if(is.null(.scale)) {
.scale = c(0.5, n+0.5)
}
pushViewport(viewport(xscale = c(0, 1), yscale = .scale))
if(inherits(extend, "unit")) extend = convertHeight(extend, "native", valueOnly = TRUE)
text_height = convertHeight(grobHeight(textGrob(labels, gp = labels_gp))*(1+padding), "native", valueOnly = TRUE)
if(is.null(.pos)) {
i2 = rev(which(index %in% at))
pos = n-i2+1 # position of rows
} else {
pos = .pos[rev(which(index %in% at))]
}
h1 = pos - text_height*0.5
h2 = pos + text_height*0.5
pos_adjusted = smartAlign(h1, h2, c(.scale[1] - extend[1], .scale[2] + extend[2]))
h = (pos_adjusted[, 1] + pos_adjusted[, 2])/2
n2 = length(labels)
if(side == "right") {
grid.text(labels, rep(link_width, n2), h, default.units = "native", gp = labels_gp, just = "left")
link_width = link_width - unit(1, "mm")
grid.segments(unit(rep(0, n2), "npc"), pos, rep(link_width*(1/3), n2), pos, default.units = "native", gp = link_gp)
grid.segments(rep(link_width*(1/3), n2), pos, rep(link_width*(2/3), n2), h, default.units = "native", gp = link_gp)
grid.segments(rep(link_width*(2/3), n2), h, rep(link_width, n2), h, default.units = "native", gp = link_gp)
} else {
grid.text(labels, unit(1, "npc")-rep(link_width, n2), h, default.units = "native", gp = labels_gp, just = "right")
link_width = link_width - unit(1, "mm")
grid.segments(unit(rep(1, n2), "npc"), pos, unit(1, "npc")-rep(link_width*(1/3), n2), pos, default.units = "native", gp = link_gp)
grid.segments(unit(1, "npc")-rep(link_width*(1/3), n2), pos, unit(1, "npc")-rep(link_width*(2/3), n2), h, default.units = "native", gp = link_gp)
grid.segments(unit(1, "npc")-rep(link_width*(2/3), n2), h, unit(1, "npc")-rep(link_width, n2), h, default.units = "native", gp = link_gp)
}
upViewport()
}
column_fun = function(index) {
n = length(index)
# adjust at and labels
at = intersect(index, at)
if(length(at) == 0) {
return(NULL)
}
labels = at2labels[as.character(at)]
labels_gp = subset_gp(labels_gp, labels2index[labels])
link_gp = subset_gp(link_gp, labels2index[labels])
if(is.null(.scale)) {
.scale = c(0.5, n+0.5)
}
pushViewport(viewport(yscale = c(0, 1), xscale = .scale))
if(inherits(extend, "unit")) extend = convertWidth(extend, "native", valueOnly = TRUE)
text_height = convertWidth(grobHeight(textGrob(labels, gp = labels_gp))*(1+padding), "native", valueOnly = TRUE)
if(is.null(.pos)) {
i2 = which(index %in% at)
pos = i2 # position of rows
} else {
pos = .pos[which(index %in% at)]
}
h1 = pos - text_height*0.5
h2 = pos + text_height*0.5
pos_adjusted = smartAlign(h1, h2, c(.scale[1] - extend[1], .scale[2] + extend[2]))
h = (pos_adjusted[, 1] + pos_adjusted[, 2])/2
n2 = length(labels)
if(side == "top") {
grid.text(labels, h, rep(link_height, n2), default.units = "native", gp = labels_gp, rot = 90, just = "left")
link_height = link_height - unit(1, "mm")
grid.segments(pos, unit(rep(0, n2), "npc"), pos, rep(link_height*(1/3), n2), default.units = "native", gp = link_gp)
grid.segments(pos, rep(link_height*(1/3), n2), h, rep(link_height*(2/3), n2), default.units = "native", gp = link_gp)
grid.segments(h, rep(link_height*(2/3), n2), h, rep(link_height, n), default.units = "native", gp = link_gp)
} else {
grid.text(labels, h, rep(max_text_width(labels, gp = labels_gp), n2), default.units = "native", gp = labels_gp, rot = 90, just = "right")
link_height = link_height - unit(1, "mm")
grid.segments(pos, unit(rep(1, n2), "npc"), pos, unit(1, "npc")-rep(link_height*(1/3), n2), default.units = "native", gp = link_gp)
grid.segments(pos, unit(1, "npc")-rep(link_height*(1/3), n2), h, unit(1, "npc")-rep(link_height*(2/3), n2), default.units = "native", gp = link_gp)
grid.segments(h, unit(1, "npc")-rep(link_height*(2/3), n2), h, unit(1, "npc")-rep(link_height, n2), default.units = "native", gp = link_gp)
}
upViewport()
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_mark",
which = which,
width = width,
height = height,
n = -1,
var_import = list(at, labels2index, at2labels, link_gp, labels_gp, padding, .pos, .scale,
side, link_width, link_height, extend),
show_name = FALSE
)
anno@subset_rule$at = subset_by_intersect
anno@subsetable = TRUE
return(anno)
}
subset_by_intersect = function(x, i) {
intersect(x, i)
}
# == title
# Label Markers Annotation
#
# == param
# -... Pass to `anno_mark`.
#
# == details
# `anno_link` is deprecated, please use `anno_mark` instead.
#
anno_link = function(...) {
warning_wrap("anno_link() is deprecated, please use anno_mark() instead.")
anno_mark(...)
}
# == title
# Label Markers as Row Annotation
#
# == param
# -... pass to `anno_link`.
#
# == details
# A wrapper of `anno_link` with pre-defined ``which`` to ``row``.
#
# You can directly use `anno_link` for row annotation if you call it in `rowAnnotation`.
#
# == value
# See help page of `anno_link`.
#
row_anno_link = function(...) {
if(exists(".__under_SingleAnnotation__", envir = parent.frame())) {
message_wrap("From version 1.99.0, you can directly use `anno_mark()` for row annotation if you call it in `rowAnnotation()`.")
}
anno_link(..., which = "row")
}
# == title
# Summary Annotation
#
# == param
# -which Whether it is a column annotation or a row annotation?
# -border Wether draw borders of the annotation region?
# -bar_width Relative width of the bars. The value should be smaller than one.
# -axis Whether to add axis?
# -axis_param parameters for controlling axis. See `default_axis_param` for all possible settings and default parameters.
# -ylim Data ranges. ``ylim`` for barplot is enforced to be ``c(0, 1)``.
# -extend The extension to both side of ``ylim``. The value is a percent value corresponding to ``ylim[2] - ylim[1]``. This argument is only for boxplot.
# -outline Whether draw outline of boxplots?
# -box_width Relative width of boxes. The value should be smaller than one.
# -pch Point style.
# -size Point size.
# -gp Graphic parameters.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
#
# == detail
# ``anno_summary`` is a special annotation function that it only works for one-column or one-row heatmap.
# It shows the summary of the values in the heatmap. If the values in the heatmap is discrete,
# the proportion of each level (the sum is normalized to 1) is visualized as stacked barplot. If the heatmap
# is split into multiple slices, multiple bars are put in the annotation. If the value is continuous, boxplot is used.
#
# In the barplot, the color schema is used as the same as the heatmap, while for the boxplot, the color needs
# to be controlled by ``gp``.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#summary-annotation
#
# == example
# ha = HeatmapAnnotation(summary = anno_summary(height = unit(4, "cm")))
# v = sample(letters[1:2], 50, replace = TRUE)
# split = sample(letters[1:2], 50, replace = TRUE)
# Heatmap(v, top_annotation = ha, width = unit(1, "cm"), split = split)
#
# ha = HeatmapAnnotation(summary = anno_summary(gp = gpar(fill = 2:3), height = unit(4, "cm")))
# v = rnorm(50)
# Heatmap(v, top_annotation = ha, width = unit(1, "cm"), split = split)
#
anno_summary = function(which = c("column", "row"), border = TRUE, bar_width = 0.8,
axis = TRUE, axis_param = default_axis_param(which),
ylim = NULL, extend = 0.05, outline = TRUE, box_width = 0.6,
pch = 1, size = unit(2, "mm"), gp = gpar(),
width = NULL, height = NULL) {
ef = function() NULL
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
dev.null()
ef = dev.off2
} else {
which = .ENV$current_annotation_which
}
on.exit(ef())
anno_size = anno_width_and_height(which, width, height, unit(2, "cm"))
axis_param = validate_axis_param(axis_param, which)
if(is.null(ylim)) {
axis_grob = if(axis) construct_axis_grob(axis_param, which, c(0, 1)) else NULL
} else {
axis_grob = if(axis) construct_axis_grob(axis_param, which, ylim) else NULL
}
row_fun = function(index) {
ht = get("object", envir = parent.frame(7))
mat = ht@matrix
cm = ht@matrix_color_mapping
order_list = ht@column_order_list
ng = length(order_list)
if(cm@type == "discrete") {
tl = lapply(order_list, function(od) table(mat[1, od]))
tl = lapply(tl, function(x) x/sum(x))
pushViewport(viewport(yscale = c(0.5, ng+0.5), xscale = c(0, 1)))
for(i in 1:ng) {
x = i
y = cumsum(tl[[i]])
grid.rect(y, x, height = bar_width, width = tl[[i]], just = "right", gp = gpar(fill = map_to_colors(cm, names(y))), default.units = "native")
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
} else {
}
}
column_fun = function(index) {
ht = get("object", envir = parent.frame(7))
mat = ht@matrix
cm = ht@matrix_color_mapping
order_list = ht@row_order_list
ng = length(order_list)
if(cm@type == "discrete") {
if(!is.null(ylim)) {
stop_wrap("For discrete matrix, `ylim` is not allowed to set. It is always c(0, 1).")
}
tl = lapply(order_list, function(od) table(mat[od, 1]))
tl = lapply(tl, function(x) x/sum(x))
pushViewport(viewport(xscale = c(0.5, ng+0.5), yscale = c(0, 1)))
for(i in 1:ng) {
x = i
y = cumsum(tl[[i]])
grid.rect(x, y, width = bar_width, height = tl[[i]], just = "top", gp = gpar(fill = map_to_colors(cm, names(y))), default.units = "native")
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
} else {
vl = lapply(order_list, function(od) mat[od, 1])
nv = length(vl)
if(is.null(ylim)) {
if(!outline) {
boxplot_stats = boxplot(vl, plot = FALSE)$stats
data_scale = range(boxplot_stats)
} else {
data_scale = range(vl, na.rm = TRUE)
}
} else {
data_scale = ylim
}
data_scale = data_scale + c(-extend, extend)*(data_scale[2] - data_scale[1])
if(is.null(ylim)) {
axis_param = validate_axis_param(axis_param, which)
axis_grob = if(axis) construct_axis_grob(axis_param, which, data_scale) else NULL
}
gp = recycle_gp(gp, nv)
if(length(pch) == 1) pch = rep(pch, nv)
if(length(size) == 1) size = rep(size, nv)
pushViewport(viewport(xscale = c(0.5, ng+0.5), yscale = data_scale))
for(i in 1:ng) {
x = i
v = vl[[i]]
grid.boxplot(v, pos = x, box_width = box_width, gp = subset_gp(gp, i),
pch = pch, size = size, outline = outline)
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_summary",
which = which,
width = width,
height = height,
var_import = list(bar_width, border, axis, axis_grob, axis_param, which, ylim, extend,
outline, box_width, pch, size, gp),
n = 1,
show_name = FALSE
)
anno@subsetable = FALSE
anno@extended = update_anno_extend(anno, axis_grob, axis_param)
return(anno)
}
# == title
# Block annotation
#
# == param
# -gp Graphic parameters.
# -labels Labels put on blocks.
# -labels_gp Graphic parameters for labels.
# -labels_rot Rotation for labels.
# -which Is it a row annotation or a column annotation?
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
#
# == details
# The block annotation is used for representing slices. The length of all arguments should be 1 or the number of slices.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#block-annotation
#
# == example
# Heatmap(matrix(rnorm(100), 10),
# top_annotation = HeatmapAnnotation(foo = anno_block(gp = gpar(fill = 2:4),
# labels = c("group1", "group2", "group3"), labels_gp = gpar(col = "white"))),
# column_km = 3,
# left_annotation = rowAnnotation(foo = anno_block(gp = gpar(fill = 2:4),
# labels = c("group1", "group2", "group3"), labels_gp = gpar(col = "white"))),
# row_km = 3)
anno_block = function(gp = gpar(), labels = NULL, labels_gp = gpar(), labels_rot = ifelse(which == "row", 90, 0),
which = c("column", "row"), width = NULL, height = NULL) {
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
} else {
which = .ENV$current_annotation_which
}
if(length(labels)) {
if(which == "column") {
height = grobHeight(textGrob(labels, rot = labels_rot, gp = labels_gp))
height = height + unit(5, "mm")
} else {
width = grobWidth(textGrob(labels, rot = labels_rot, gp = labels_gp))
width = width + unit(5, "mm")
}
}
anno_size = anno_width_and_height(which, width, height, unit(5, "mm"))
fun = function(index, k, n) {
gp = subset_gp(recycle_gp(gp, n), k)
grid.rect(gp = gp)
if(length(labels)) {
if(length(labels) != n) {
stop_wrap("Length of `labels` should be as same as number of slices.")
}
label = labels[k]
labels_gp = subset_gp(recycle_gp(labels_gp, n), k)
grid.text(label, gp = labels_gp, rot = labels_rot)
}
}
anno = AnnotationFunction(
fun = fun,
n = NA,
fun_name = "anno_block",
which = which,
var_import = list(gp, labels, labels_gp, labels_rot),
subset_rule = list(),
subsetable = TRUE,
height = anno_size$height,
width = anno_size$width,
show_name = FALSE
)
return(anno)
}
# == title
# Zoom annotation
#
# == param
# -align_to It defines how the boxes correspond to the rows or the columns in the heatmap.
# If the value is a list of indices, each box corresponds to the rows or columns with indices
# in one vector in the list. If the value is a categorical variable (e.g. a factor or a character vector)
# that has the same length as the rows or columns in the heatmap, each box corresponds to the rows/columns
# in each level in the categorical variable.
# -panel_fun A self-defined function that defines how to draw graphics in the box. The function must have
# a ``index`` argument which is the indices for the rows/columns that the box corresponds to. It can
# have second argument ``nm`` which is the "name" of the selected part in the heatmap. The corresponding
# value for ``nm`` comes from ``align_to`` if it is specified as a categorical variable or a list with names.
# -which Whether it is a column annotation or a row annotation?
# -side Side of the boxes If it is a column annotation, valid values are "top" and "bottom";
# If it is a row annotation, valid values are "left" and "right".
# -size The size of boxes. It can be pure numeric that they are treated as relative fractions of the total
# height/width of the heatmap. The value of ``size`` can also be absolute units.
# -gap Gaps between boxes.
# -link_gp Graphic settings for the segments.
# -link_width Width of the segments.
# -link_height Similar as ``link_width``, used for column annotation.
# -extend By default, the region for the labels has the same width (if it is a column annotation) or
# same height (if it is a row annotation) as the heatmap. The size can be extended by this options.
# The value can be a proportion number or a `grid::unit` object. The length can be either one or two.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
#
# == details
# `anno_zoom` creates several plotting regions (boxes) which can be corresponded to subsets of rows/columns in the
# heatmap.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#zoom-annotation
#
# == example
# set.seed(123)
# m = matrix(rnorm(100*10), nrow = 100)
# subgroup = sample(letters[1:3], 100, replace = TRUE, prob = c(1, 5, 10))
# rg = range(m)
# panel_fun = function(index, nm) {
# pushViewport(viewport(xscale = rg, yscale = c(0, 2)))
# grid.rect()
# grid.xaxis(gp = gpar(fontsize = 8))
# grid.boxplot(m[index, ], pos = 1, direction = "horizontal")
# grid.text(paste("distribution of group", nm), mean(rg), y = 1.9,
# just = "top", default.units = "native", gp = gpar(fontsize = 10))
# popViewport()
# }
# anno = anno_zoom(align_to = subgroup, which = "row", panel_fun = panel_fun,
# size = unit(2, "cm"), gap = unit(1, "cm"), width = unit(4, "cm"))
# Heatmap(m, right_annotation = rowAnnotation(foo = anno), row_split = subgroup)
#
anno_zoom = function(align_to, panel_fun = function(index, nm = NULL) { grid.rect() },
which = c("column", "row"), side = ifelse(which == "column", "top", "right"),
size = NULL, gap = unit(1, "mm"),
link_width = unit(5, "mm"), link_height = link_width, link_gp = gpar(),
extend = unit(0, "mm"), width = NULL, height = NULL) {
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
} else {
which = .ENV$current_annotation_which
}
anno_size = anno_width_and_height(which, width, height, unit(2, "cm") + link_width)
# align_to should be
# 1. a vector of class labels that the length should be same as the nrow of the matrix
# 2. a list of numeric indices
if(is.list(align_to)) {
if(!any(sapply(align_to, is.numeric))) {
stop_wrap(paste0("`at` should be numeric ", which, " index corresponding to the matrix."))
}
}
.pos = NULL # position of the rows
if(length(as.list(formals(panel_fun))) == 1) {
formals(panel_fun) = alist(index = , nm = NULL)
}
if(length(extend) == 1) extend = rep(extend, 2)
if(length(extend) > 2) extend = extend[1:2]
if(!inherits(extend, "unit")) extend = unit(extend, "npc")
# anno_zoom is always executed in one-slice mode (which means mulitple slices
# are treated as one big slilce)
row_fun = function(index) {
n = length(index)
if(is.atomic(align_to)) {
if(length(setdiff(align_to, index)) == 0 && !any(duplicated(align_to))) {
align_to = list(align_to)
} else {
if(length(align_to) != n) {
stop_wrap("If `align_to` is a vector with group labels, the length should be the same as the number of rows in the heatmap.")
}
lnm = as.character(unique(align_to[index]))
align_to = as.list(tapply(seq_along(align_to), align_to, function(x) x))
align_to = align_to[lnm]
}
}
nrl = sapply(align_to, length)
align_to_df = lapply(align_to, function(x) {
ind = which(index %in% x)
n = length(ind)
s = NULL
e = NULL
s[1] = ind[1]
if(n > 1) {
ind2 = which(ind[2:n] - ind[1:(n-1)] > 1)
if(length(ind2)) s = c(s, ind[ ind2 + 1 ])
k = length(s)
e[k] = ind[length(ind)]
if(length(ind2)) e[1:(k-1)] = ind[1:(n-1)][ ind2 ]
} else {
e = ind[1]
}
data.frame(s = s, e = e)
})
# pos is from top to bottom
if(is.null(.pos)) {
pos = (n:1 - 0.5)/n # position of rows
} else {
pos = .pos
}
.scale = c(0, 1)
pushViewport(viewport(xscale = c(0, 1), yscale = .scale))
if(inherits(extend, "unit")) extend = convertHeight(extend, "native", valueOnly = TRUE)
# the position of boxes initially are put evenly
# add the gap
n_boxes = length(align_to)
if(length(gap) == 1) gap = rep(gap, n_boxes)
if(is.null(size)) size = nrl
if(length(size) == 1) size = rep(size, length(align_to))
if(length(size) != length(align_to)) {
stop_wrap("Length of `size` should be the same as the number of groups of indices.")
}
if(!inherits(size, "unit")) {
size_is_unit = FALSE
if(n_boxes == 1) {
h = data.frame(bottom = .scale[1] - extend[1], top = .scale[2] + extend[2])
} else {
gap = convertHeight(gap, "native", valueOnly = TRUE)
box_height = size/sum(size) * (1 + sum(extend) - sum(gap[1:(n_boxes-1)]))
h = data.frame(
top = cumsum(box_height) + cumsum(gap) - gap[length(gap)] - extend[1]
)
h$bottom = h$top - box_height
h = 1 - h[, 2:1]
colnames(h) = c("top", "bottom")
}
} else {
size_is_unit = TRUE
box_height = size
box_height2 = box_height # box_height2 adds the gap
for(i in 1:n_boxes) {
if(i == 1 || i == n_boxes) {
if(n_boxes > 1) {
box_height2[i] = box_height2[i] + gap[i]*0.5
}
} else {
box_height2[i] = box_height2[i] + gap[i]
}
}
box_height2 = convertHeight(box_height2, "native", valueOnly = TRUE)
# the original positions of boxes
mean_pos = sapply(align_to_df, function(df) mean((pos[df[, 1]] + pos[df[, 2]])/2))
h1 = mean_pos - box_height2*0.5
h2 = mean_pos + box_height2*0.5
h = smartAlign2(rev(h1), rev(h2), c(.scale[1] - extend[1], .scale[2] + extend[2]))
colnames(h) = c("bottom", "top")
h = h[nrow(h):1, , drop = FALSE]
# recalcualte h to remove gaps
gap_height = convertHeight(gap, "native", valueOnly = TRUE)
if(n_boxes > 1) {
for(i in 1:n_boxes) {
if(i == 1) {
h[i, "bottom"] = h[i, "bottom"] + gap_height[i]/2
} else if(i == n_boxes) {
h[i, "top"] = h[i, "top"] - gap_height[i]/2
} else {
h[i, "bottom"] = h[i, "bottom"] + gap_height[i]/2
h[i, "top"] = h[i, "top"] - gap_height[i]/2
}
}
}
}
popViewport()
# draw boxes
if(side == "right") {
pushViewport(viewport(x = link_width, just = "left", width = anno_size$width - link_width))
} else {
pushViewport(viewport(x = 0, just = "left", width = anno_size$width - link_width))
}
for(i in 1:n_boxes) {
current_vp_name = current.viewport()$name
pushViewport(viewport(y = (h[i, "top"] + h[i, "bottom"])/2, height = h[i, "top"] - h[i, "bottom"],
default.units = "native"))
if(is.function(panel_fun)) panel_fun(align_to[[i]], names(align_to)[i])
popViewport()
if(current.viewport()$name != current_vp_name) {
stop_wrap("If you push viewports `panel_fun`, you need to pop all them out.")
}
}
popViewport()
# draw the links
link_gp = recycle_gp(link_gp, n_boxes)
if(side == "right") {
pushViewport(viewport(x = unit(0, "npc"), just = "left", width = link_width))
} else {
pushViewport(viewport(x = unit(1, "npc"), just = "right", width = link_width))
}
for(i in 1:n_boxes) {
df = align_to_df[[i]]
for(j in 1:nrow(df)) {
# draw each polygon
if(side == "right") {
grid.polygon(unit.c(unit(c(0, 0), "npc"), rep(link_width, 2)),
c(pos[df[j, 2]] - 0.5/n, pos[df[j, 1]] + 0.5/n, h[i, "top"], h[i, "bottom"]),
default.units = "native", gp = subset_gp(link_gp, i))
} else {
grid.polygon(unit.c(rep(link_width, 2), unit(c(0, 0), "npc")),
c(pos[df[j, 2]] - 0.5/n, pos[df[j, 1]] + 0.5/n, h[i, "top"], h[i, "bottom"]),
default.units = "native", gp = subset_gp(link_gp, i))
}
}
}
popViewport()
}
column_fun = function(index) {
n = length(index)
if(is.atomic(align_to)) {
if(length(setdiff(align_to, index)) == 0 && !any(duplicated(align_to))) {
align_to = list(align_to)
} else {
if(length(align_to) != n) {
stop_wrap("If `align_to` is a vector with group labels, the length should be the same as the number of columns in the heatmap.")
}
lnm = as.character(unique(align_to[index]))
align_to = as.list(tapply(seq_along(align_to), align_to, function(x) x))
align_to = align_to[lnm]
}
}
nrl = sapply(align_to, length)
align_to_df = lapply(align_to, function(x) {
ind = which(index %in% x)
n = length(ind)
s = NULL
e = NULL
s[1] = ind[1]
if(n > 1) {
ind2 = which(ind[2:n] - ind[1:(n-1)] > 1)
if(length(ind2)) s = c(s, ind[ ind2 + 1 ])
k = length(s)
e[k] = ind[length(ind)]
if(length(ind2)) e[1:(k-1)] = ind[1:(n-1)][ ind2 ]
} else {
e = ind[1]
}
data.frame(s = s, e = e)
})
if(is.null(.pos)) {
pos = (1:n - 0.5)/n
} else {
pos = .pos
}
.scale = c(0, 1)
pushViewport(viewport(yscale = c(0, 1), xscale = .scale))
if(inherits(extend, "unit")) extend = convertWidth(extend, "native", valueOnly = TRUE)
# the position of boxes initially are put evenly
# add the gap
n_boxes = length(align_to)
if(length(gap) == 1) gap = rep(gap, n_boxes)
if(is.null(size)) size = nrl
if(length(size) == 1) size = rep(size, length(align_to))
if(length(size) != length(align_to)) {
stop_wrap("Length of `size` should be the same as the number of groups of indices.")
}
if(!inherits(size, "unit")) {
size_is_unit = FALSE
if(n_boxes == 1) {
h = data.frame(left = .scale[1] - extend[1], right = .scale[2] + extend[2])
} else {
gap = convertWidth(gap, "native", valueOnly = TRUE)
box_width = size/sum(size) * (1 + sum(extend) - sum(gap[1:(n_boxes-1)]))
h = data.frame(
right = cumsum(box_width) + cumsum(gap) - gap[length(gap)] - extend[1]
)
h$left = h$right - box_width
}
} else {
size_is_unit = TRUE
box_width = size
box_width2 = box_width
for(i in 1:n_boxes) {
if(i == 1 || i == n_boxes) {
if(n_boxes > 1) {
box_width2[i] = box_width2[i] + gap[i]*0.5
}
} else {
box_width2[i] = box_width2[i] + gap[i]
}
}
box_width2 = convertWidth(box_width2, "native", valueOnly = TRUE)
# the original positions of boxes
mean_pos = sapply(align_to_df, function(df) mean((pos[df[, 1]] + pos[df[, 2]])/2))
h1 = mean_pos - box_width2*0.5
h2 = mean_pos + box_width2*0.5
h = smartAlign2(h1, h2, c(.scale[1] - extend[1], .scale[2] + extend[2]))
colnames(h) = c("left", "right")
# recalcualte h to remove gaps
gap_width = convertWidth(gap, "native", valueOnly = TRUE)
if(n_boxes > 1) {
for(i in 1:n_boxes) {
if(i == 1) {
h[i, "left"] = h[i, "left"] + gap_width[i]/2
} else if(i == n_boxes) {
h[i, "right"] = h[i, "right"] - gap_width[i]/2
} else {
h[i, "left"] = h[i, "left"] + gap_width[i]/2
h[i, "right"] = h[i, "right"] - gap_width[i]/2
}
}
}
}
popViewport()
# draw boxes
if(side == "top") {
pushViewport(viewport(y = link_height, just = "bottom", height = anno_size$height - link_height))
} else {
pushViewport(viewport(y = 0, just = "bottom", height = anno_size$height - link_height))
}
for(i in 1:n_boxes) {
current_vp_name = current.viewport()$name
pushViewport(viewport(x = (h[i, "right"] + h[i, "left"])/2, width = h[i, "right"] - h[i, "left"],
default.units = "native"))
if(is.function(panel_fun)) panel_fun(align_to[[i]], names(align_to)[i])
popViewport()
if(current.viewport()$name != current_vp_name) {
stop_wrap("If you push viewports `panel_fun`, you need to pop all them out.")
}
}
popViewport()
# draw the links
link_gp = recycle_gp(link_gp, n_boxes)
if(side == "top") {
pushViewport(viewport(y = unit(0, "npc"), just = "bottom", height = link_height))
} else {
pushViewport(viewport(y = unit(1, "npc"), just = "top", height = link_height))
}
for(i in 1:n_boxes) {
df = align_to_df[[i]]
for(j in 1:nrow(df)) {
# draw each polygon
if(side == "top") {
grid.polygon(
c(pos[df[j, 2]] + 0.5/n, pos[df[j, 1]] - 0.5/n, h[i, "left"], h[i, "right"]),
unit.c(unit(c(0, 0), "npc"), rep(link_width, 2)),
default.units = "native", gp = subset_gp(link_gp, i))
} else {
grid.polygon(
c(pos[df[j, 2]] + 0.5/n, pos[df[j, 1]] - 0.5/n, h[i, "left"], h[i, "right"]),
unit.c(rep(link_width, 2), unit(c(0, 0), "npc")),
default.units = "native", gp = subset_gp(link_gp, i))
}
}
}
popViewport()
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_zoom",
which = which,
height = anno_size$height,
width = anno_size$width,
n = -1,
var_import = list(align_to, .pos, gap, size, panel_fun, side, anno_size, extend,
link_width, link_height, link_gp),
show_name = FALSE
)
anno@subset_rule$align_to = function(x, i) {
if(is.atomic(x)) {
x[i]
} else {
x = lapply(x, function(x) intersect(x, i))
x = x[sapply(x, length) > 0]
}
}
anno@subsetable = TRUE
return(anno)
}
zhongmicai/complexHeatmap documentation built on May 7, 2019, 6:11 a.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.
# == title
# Empty Annotation
#
# == param
# -which Whether it is a column annotation or a row annotation?
# -border Whether draw borders of the annotation region?
# -zoom If it is true and when the heatmap is split, the empty annotation slices will have
# equal height or width, and you can see the correspondance between the annotation slices
# and the original heatmap slices.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
#
# == details
# It creates an empty annotation and holds space, later users can add graphics
# by `decorate_annotation`. This function is useful when users have difficulty to
# implement `AnnotationFunction` object.
#
# In following example, an empty annotation is first created and later points are added:
#
# m = matrix(rnorm(100), 10)
# ht = Heatmap(m, top_annotation = HeatmapAnnotation(pt = anno_empty()))
# ht = draw(ht)
# co = column_order(ht)[[1]]
# pt_value = 1:10
# decorate_annotation("pt", {
# pushViewport(viewport(xscale = c(0.5, ncol(mat)+0.5), yscale = range(pt_value)))
# grid.points(seq_len(ncol(mat)), pt_value[co], pch = 16, default.units = "native")
# grid.yaxis()
# popViewport()
# })
#
# And it is similar as using `anno_points`:
#
# Heatmap(m, top_annotation = HeatmapAnnotation(pt = anno_points(pt_value)))
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#empty-annotation
#
# == examples
# anno = anno_empty()
# draw(anno, test = "anno_empty")
# anno = anno_empty(border = FALSE)
# draw(anno, test = "anno_empty without border")
anno_empty = function(which = c("column", "row"), border = TRUE, zoom = FALSE,
width = NULL, height = NULL) {
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
} else {
which = .ENV$current_annotation_which
}
anno_size = anno_width_and_height(which, width, height, unit(1, "cm"))
fun = function(index) {
if(border) grid.rect()
}
anno = AnnotationFunction(
fun = fun,
n = NA,
fun_name = "anno_empty",
which = which,
var_import = list(border, zoom),
subset_rule = list(),
subsetable = TRUE,
height = anno_size$height,
width = anno_size$width,
show_name = FALSE
)
return(anno)
}
# == title
# Subset the Matrix by Rows
#
# == param
# -x A matrix.
# -i The row indices.
#
# == details
# Mainly used for constructing the `AnnotationFunction-class` object.
#
subset_matrix_by_row = function(x, i) x[i, , drop = FALSE]
# == title
# Subset the vector
#
# == param
# -x A vector.
# -i The indices.
#
# == details
# Mainly used for constructing the `AnnotationFunction-class` object.
#
subset_vector = function(x, i) x[i]
# == title
# Simple Annotation
#
# == param
# -x The value vector. The value can be a vector or a matrix. The length of the vector
# or the nrow of the matrix is taken as the number of the observations of the annotation.
# The value can be numeric or character and NA value is allowed.
# -col Color that maps to ``x``. If ``x`` is numeric and needs a continuous mapping, ``col``
# should be a color mapping function which accepts a vector of values and returns a
# vector of colors. Normally it is generated by `circlize::colorRamp2`. If ``x`` is discrete
# (numeric or character) and needs a discrete color mapping, ``col`` should be a vector of
# colors with levels in ``x`` as vector names. If ``col`` is not specified, the color mapping
# is randomly generated by ``ComplexHeatmap:::default_col``.
# -na_col Color for NA value.
# -which Whether it is a column annotation or a row annotation?
# -border Wether draw borders of the annotation region?
# -gp Graphic parameters for grid borders. The ``fill`` parameter is disabled.
# -pch Points/symbols that are added on top of the annotation grids. The value can be numeric
# or single letters. It can be a vector if ``x`` is a vector and a matrix if ``x`` is a matrix.
# No points are drawn if the corresponding values are NA.
# -pt_size Size of the points/symbols. It should be a `grid::unit` object. If ``x`` is a vector,
# the value of ``pt_size`` can be a vector, while if ``x`` is a matrix, ``pt_size`` can
# only be a single value.
# -pt_gp Graphic parameters for points/symbols. The length setting is same as ``pt_size``.
# If ``pch`` is set as letters, the fontsize should be set as ``pt_gp = gpar(fontsize = ...)``.
# -simple_anno_size size of the simple annotation.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
#
# == details
# The "simple annotation" is the most widely used annotation type which is heatmap-like, where
# the grid colors correspond to the values. `anno_simple` also supports to add points/symbols
# on top of the grids where the it can be normal point (when ``pch`` is set as numbers) or letters (when
# ``pch`` is set as single letters).
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#simple-annotation-as-an-annotation-function
#
# == example
# anno = anno_simple(1:10)
# draw(anno, test = "a numeric vector")
#
# anno = anno_simple(cbind(1:10, 10:1))
# draw(anno, test = "a matrix")
#
# anno = anno_simple(1:10, pch = c(1:4, NA, 6:8, NA, 10))
# draw(anno, test = "pch has NA values")
#
# anno = anno_simple(1:10, pch = c(rep("A", 5), rep(NA, 5)))
# draw(anno, test = "pch has NA values")
#
# pch = matrix(1:20, nc = 2)
# pch[sample(length(pch), 10)] = NA
# anno = anno_simple(cbind(1:10, 10:1), pch = pch)
# draw(anno, test = "matrix, pch is a matrix with NA values")
anno_simple = function(x, col, na_col = "grey",
which = c("column", "row"), border = FALSE, gp = gpar(col = NA),
pch = NULL, pt_size = unit(1, "snpc")*0.8, pt_gp = gpar(),
simple_anno_size = ht_opt$simple_anno_size,
width = NULL, height = NULL) {
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
} else {
which = .ENV$current_annotation_which
}
if(is.data.frame(x)) x = as.matrix(x)
if(is.matrix(x)) {
if(ncol(x) == 1) {
x = x[, 1]
}
}
input_is_matrix = is.matrix(x)
anno_size = anno_width_and_height(which, width, height,
simple_anno_size*ifelse(input_is_matrix, ncol(x), 1))
if(missing(col)) {
col = default_col(x)
}
if(is.atomic(col)) {
color_mapping = ColorMapping(name = "foo", colors = col, na_col = na_col)
} else if(is.function(col)) {
color_mapping = ColorMapping(name = "foo", col_fun = col, na_col = na_col)
} else if(inherits(col, "ColorMapping")) {
color_mapping = col
} else {
stop_wrap("`col` should be a named vector/a color mapping function/a ColorMapping object.")
}
value = x
gp = subset_gp(gp, 1) # gp controls border
if(is.matrix(value)) {
n = nrow(value)
nr = n
nc = ncol(value)
} else {
n = length(value)
nr = n
nc = 1
}
if(!is.null(pch)) {
if(input_is_matrix) {
pch = normalize_graphic_param_to_mat(pch, ifelse(is.matrix(x), ncol(x), 1), n, "pch")
pt_size = pt_size[1]*(1/nc)
pt_gp = subset_gp(pt_gp, 1)
} else {
if(length(pch) == 1) pch = rep(pch, n)
if(length(pt_size) == 1) pt_size = rep(pt_size, n)
pt_gp = recycle_gp(pt_gp, n)
}
}
row_fun = function(index) {
n = length(index)
y = (n - seq_len(n) + 0.5) / n
if(is.matrix(value)) {
nc = ncol(value)
for(i in seq_len(nc)) {
fill = map_to_colors(color_mapping, value[index, i])
grid.rect(x = (i-0.5)/nc, y, height = 1/n, width = 1/nc,
gp = do.call("gpar", c(list(fill = fill), gp)))
if(!is.null(pch)) {
l = !is.na(pch[, i])
grid.points(x = rep((i-0.5)/nc, sum(l)), y = y[l], pch = pch[l, i],
size = {if(length(pt_size) == 1) pt_size else pt_size[i]},
gp = subset_gp(pt_gp, i))
}
}
} else {
fill = map_to_colors(color_mapping, value[index])
grid.rect(x = 0.5, y, height = 1/n, width = 1, gp = do.call("gpar", c(list(fill = fill), gp)))
if(!is.null(pch)) {
pch = pch[index]
pt_size = pt_size[index]
pt_gp = subset_gp(pt_gp, index)
l = !is.na(pch)
grid.points(x = rep(0.5, sum(l)), y = y[l], pch = pch[l], size = pt_size[l],
gp = subset_gp(pt_gp, which(l)))
}
}
if(border) grid.rect(gp = gpar(fill = "transparent"))
}
column_fun = function(index) {
n = length(index)
x = (seq_len(n) - 0.5) / n
if(is.matrix(value)) {
nc = ncol(value)
for(i in seq_len(nc)) {
fill = map_to_colors(color_mapping, value[index, i])
grid.rect(x, y = (nc-i +0.5)/nc, width = 1/n, height = 1/nc, gp = do.call("gpar", c(list(fill = fill), gp)))
if(!is.null(pch)) {
pch = pch[index, , drop = FALSE]
l = !is.na(pch[, i])
grid.points(x[l], y = rep((nc-i +0.5)/nc, sum(l)), pch = pch[l, i],
size = {if(length(pt_size) == 1) pt_size else pt_size[i]},
gp = subset_gp(pt_gp, i))
}
}
} else {
fill = map_to_colors(color_mapping, value[index])
grid.rect(x, y = 0.5, width = 1/n, height = 1, gp = do.call("gpar", c(list(fill = fill), gp)))
if(!is.null(pch)) {
pch = pch[index]
pt_size = pt_size[index]
pt_gp = subset_gp(pt_gp, index)
l = !is.na(pch)
grid.points(x[l], y = rep(0.5, sum(l)), pch = pch[l], size = pt_size[l],
gp = subset_gp(pt_gp, which(l)))
}
}
if(border) grid.rect(gp = gpar(fill = "transparent"))
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_simple",
which = which,
width = anno_size$width,
height = anno_size$height,
n = n,
data_scale = c(0.5, nc + 0.5),
var_import = list(value, gp, border, color_mapping, pt_gp, pt_size, pch)
)
anno@subset_rule = list()
if(input_is_matrix) {
anno@subset_rule$value = subset_matrix_by_row
if(!is.null(pch)) {
anno@subset_rule$pch = subset_matrix_by_row
}
} else {
anno@subset_rule$value = subset_vector
if(!is.null(pch)) {
anno@subset_rule$pch = subset_vector
anno@subset_rule$pt_size = subset_vector
anno@subset_rule$pt_gp = subset_gp
}
}
anno@subsetable = TRUE
return(anno)
}
# == title
# Image Annotation
#
# == param
# -image A vector of file paths of images. The format of the image is inferred from the suffix name of the image file.
# NA values or empty strings in the vector means no image to drawn.
# -which Whether it is a column annotation or a row annotation?
# -border Wether draw borders of the annotation region?
# -gp Graphic parameters for annotation grids. If the image has transparent background, the ``fill`` parameter
# can be used to control the background color in the annotation grids.
# -space The space around the image to the annotation grid borders. The value should be a `grid::unit` object.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
#
# == details
# This function supports image formats in ``png``, ``svg``, ``pdf``, ``eps``, ``jpeg/jpg``, ``tiff``.
# ``png``, ``jpeg/jpg`` and ``tiff`` images are imported by `png::readPNG`, `jpeg::readJPEG` and
# `tiff::readTIFF`, and drawn by `grid::grid.raster`. ``svg`` images are firstly reformatted by ``rsvg::rsvg_svg``
# and then imported by `grImport2::readPicture` and drawn by `grImport2::grid.picture`. ``pdf`` and ``eps``
# images are imported by `grImport::PostScriptTrace` and `grImport::readPicture`, later drawn by `grImport::grid.picture`.
#
# Different image formats can be mixed in the ``image`` vector.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#image-annotation
#
# == example
# # download the free icons from https://github.com/Keyamoon/IcoMoon-Free
# \dontrun{
# image = sample(dir("~/Downloads/IcoMoon-Free-master/PNG/64px", full.names = TRUE), 10)
# anno = anno_image(image)
# draw(anno, test = "png")
# image[1:5] = ""
# anno = anno_image(image)
# draw(anno, test = "some of png")
# }
anno_image = function(image, which = c("column", "row"), border = TRUE,
gp = gpar(fill = NA, col = NA), space = unit(1, "mm"),
width = NULL, height = NULL) {
image[is.na(image)] = ""
l = grepl("^\\s*$", image)
image[l] = ""
allowed_image_type = c("png", "svg", "pdf", "eps", "jpeg", "jpg", "tiff")
if(inherits(image, "character")) { ## they are file path
image_type = tolower(gsub("^.*\\.(\\w+)$", "\\1", image))
if(! all(image_type[image_type != ""] %in% allowed_image_type)) {
stop_wrap("image file should be of png/svg/pdf/eps/jpeg/jpg/tiff.")
}
} else {
stop_wrap("`image` should be a vector of path.")
}
n_image = length(image)
image_list = vector("list", n_image)
image_class = vector("character", n_image)
for(i in seq_along(image)) {
if(image[i] == "") {
image_list[[i]] = NA
image_class[i] = NA
} else if(image_type[i] == "png") {
if(!requireNamespace("png")) {
stop_wrap("Need png package to read png images.")
}
image_list[[i]] = png::readPNG(image[i])
image_class[i] = "raster"
} else if(image_type[i] %in% c("jpeg", "jpg")) {
if(!requireNamespace("jpeg")) {
stop_wrap("Need jpeg package to read jpeg/jpg images.")
}
image_list[[i]] = jpeg::readJPEG(image[i])
image_class[i] = "raster"
} else if(image_type[i] == "tiff") {
if(!requireNamespace("tiff")) {
stop_wrap("Need tiff package to read tiff images.")
}
image_list[[i]] = tiff::readTIFF(image[i])
image_class[i] = "raster"
} else if(image_type[i] %in% c("pdf", "eps")) {
if(!requireNamespace("grImport")) {
stop_wrap("Need grImport package to read pdf/eps images.")
}
temp_file = tempfile()
getFromNamespace("PostScriptTrace", ns = "grImport")(image[[i]], temp_file)
image_list[[i]] = grImport::readPicture(temp_file)
file.remove(temp_file)
image_class[i] = "grImport::Picture"
} else if(image_type[i] == "svg") {
if(!requireNamespace("grImport2")) {
stop_wrap("Need grImport2 package to read svg images.")
}
# if(!requireNamespace("rsvg")) {
# stop_wrap("Need rsvg package to convert svg images.")
# }
temp_file = tempfile()
# get it work on bioconductor build server
oe = try(getFromNamespace("rsvg_svg", ns = "rsvg")(image[i], temp_file))
if(inherits(oe, "try-error")) {
stop_wrap("Need rsvg package to convert svg images.")
}
image_list[[i]] = grImport2::readPicture(temp_file)
file.remove(temp_file)
image_class[i] = "grImport2::Picture"
}
}
yx_asp = sapply(image_list, function(x) {
if(inherits(x, "array")) {
nrow(x)/ncol(x)
} else if(inherits(x, "Picture")) {
max(x@summary@yscale)/max(x@summary@xscale)
} else {
1
}
})
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
} else {
which = .ENV$current_annotation_which
}
space = space[1]
anno_size = anno_width_and_height(which, width, height, unit(1, "cm"))
gp = recycle_gp(gp, n_image)
column_fun = function(index) {
n = length(index)
pushViewport(viewport())
asp = convertHeight(unit(1, "npc") - space*2, "mm", valueOnly = TRUE)/convertWidth(unit(1/n, "npc") - space*2, "mm", valueOnly = TRUE)
grid.rect(x = (1:n - 0.5)/n, width = 1/n, gp = subset_gp(gp, index))
for(i in seq_len(n)) {
if(identical(image_list[[i]], NA)) next
if(yx_asp[ index[i] ] > asp) {
height = unit(1, "npc") - space*2
width = convertHeight(height, "mm")*yx_asp[ index[i] ]
} else {
width = unit(1/n, "npc") - space*2
height = yx_asp[ index[i] ]*convertWidth(width, "mm")
}
if(image_class[ index[i] ] == "raster") {
grid.raster(image_list[[i]], x = (i-0.5)/n, width = width, height = height)
} else if(image_class[ index[i] ] == "grImport::Picture") {
grid.picture = getFromNamespace("grid.picture", ns = "grImport")
grid.picture(image_list[[i]], x = (i-0.5)/n, width = width, height = height)
} else if(image_class[ index[i] ] == "grImport2::Picture") {
grid.picture = getFromNamespace("grid.picture", ns = "grImport2")
grid.picture(image_list[[i]], x = (i-0.5)/n, width = width, height = height)
}
}
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
row_fun = function(index) {
n = length(index)
pushViewport(viewport())
asp = convertHeight(unit(1/n, "npc") - space*2, "mm", valueOnly = TRUE)/convertWidth(unit(1, "npc") - space*2, "mm", valueOnly = TRUE)
grid.rect(y = (n - 1:n + 0.5)/n, height = 1/n, gp = subset_gp(gp, index))
for(i in seq_len(n)) {
if(identical(image_list[[i]], NA)) next
if(yx_asp[ index[i] ] > asp) {
height = unit(1/n, "npc") - space*2
width = convertHeight(height, "mm")*(1/yx_asp[ index[i] ])
} else {
width = unit(1, "npc") - space*2
height = yx_asp[ index[i] ]*convertWidth(width, "mm")
}
if(image_class[ index[i] ] == "raster") {
grid.raster(image_list[[i]], y = (n - i + 0.5)/n, width = width, height = height)
} else if(image_class[ index[i] ] == "grImport::Picture") {
grid.picture = getFromNamespace("grid.picture", ns = "grImport")
grid.picture(image_list[[i]], y = (n - i + 0.5)/n, width = width, height = height)
} else if(image_class[ index[i] ] == "grImport2::Picture") {
grid.picture = getFromNamespace("grid.picture", ns = "grImport2")
grid.picture(image_list[[i]], y = (n - i + 0.5)/n, width = width, height = height)
}
}
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_image",
which = which,
width = anno_size$width,
height = anno_size$height,
n = n_image,
data_scale = c(0.5, 1.5),
var_import = list(gp, border, space, yx_asp, image_list, image_class)
)
anno@subset_rule$gp = subset_vector
anno@subset_rule$image_list = subset_vector
anno@subset_rule$image_class = subset_vector
anno@subsetable = TRUE
return(anno)
}
# == title
# The Default Parameters for Annotation Axis
#
# == param
# -which Whether it is for column annotation or row annotation?
#
# == details
# There are following parameters for the annotation axis:
#
# -at The breaks of axis. By default it is automatically inferred.
# -labels The corresponding axis labels.
# -labels_rot The rotation of the axis labels.
# -gp Graphc parameters of axis labels. The value should be a `grid::unit` object.
# -side If it is for column annotation, the value should only be one of ``left`` and ``right``. If
# it is for row annotation, the value should only be one of ``top`` and ``bottom``.
# -facing Whether the axis faces to the outside of the annotation region or inside. Sometimes when
# appending more than one heatmaps, the axes of column annotations of one heatmap might
# overlap to the neighbouring heatmap, setting ``facing`` to ``inside`` may invoild it.
#
# == example
# default_axis_param("column")
# default_axis_param("row")
default_axis_param = function(which) {
list(
at = NULL,
labels = NULL,
labels_rot = ifelse(which == "column", 0, 90),
gp = gpar(fontsize = 8),
side = ifelse(which == "column", "left", "bottom"),
facing = "outside"
)
}
validate_axis_param = function(axis_param, which) {
dft = default_axis_param(which)
for(nm in names(axis_param)) {
dft[[nm]] = axis_param[[nm]]
}
if(which == "row") {
if(dft$side %in% c("left", "right")) {
stop_wrap("axis side can only be set to 'top' or 'bottom' for row annotations.")
}
}
if(which == "column") {
if(dft$side %in% c("top", "bottom")) {
stop_wrap("axis side can only be set to 'left' or 'right' for row annotations.")
}
}
return(dft)
}
construct_axis_grob = function(axis_param, which, data_scale) {
axis_param_default = default_axis_param(which)
for(nm in setdiff(names(axis_param_default), names(axis_param))) {
axis_param[[nm]] = axis_param_default[[nm]]
}
if(is.null(axis_param$at)) {
at = pretty_breaks(data_scale)
axis_param$at = at
axis_param$labels = at
}
if(is.null(axis_param$labels)) {
axis_param$labels = axis_param$at
}
axis_grob = do.call(annotation_axis_grob, axis_param)
return(axis_grob)
}
# == title
# Points Annotation
#
# == param
# -x The value vector. The value can be a vector or a matrix. The length of the vector
# or the number of rows of the matrix is taken as the number of the observations of the annotation.
# -which Whether it is a column annotation or a row annotation?
# -border Wether draw borders of the annotation region?
# -gp Graphic parameters for points. The length of each graphic parameter can be 1, length of ``x`` if ``x``
# is a vector, or number of columns of ``x`` is ``x`` is a matrix.
# -pch Point type. The length setting is the same as ``gp``.
# -size Point size, the value should be a `grid::unit` object. The length setting is the same as ``gp``.
# -ylim Data ranges. By default it is ``range(x)``.
# -extend The extension to both side of ``ylim``. The value is a percent value corresponding to ``ylim[2] - ylim[1]``.
# -axis Whether to add axis?
# -axis_param parameters for controlling axis. See `default_axis_param` for all possible settings and default parameters.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
# -... Other arguments.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#points-annotation
#
# == example
# anno = anno_points(runif(10))
# draw(anno, test = "anno_points")
# anno = anno_points(matrix(runif(20), nc = 2), pch = 1:2)
# draw(anno, test = "matrix")
anno_points = function(x, which = c("column", "row"), border = TRUE, gp = gpar(), pch = 16,
size = unit(2, "mm"), ylim = NULL, extend = 0.05, axis = TRUE,
axis_param = default_axis_param(which), width = NULL, height = NULL, ...) {
other_args = list(...)
if(length(other_args)) {
if("axis_gp" %in% names(other_args)) {
stop_wrap("`axis_gp` is removed from the arguments. Use `axis_param = list(gp = ...)` instead.")
}
if("axis_direction" %in% names(other_args)) {
stop_wrap("`axis_direction` is not supported any more.")
}
}
ef = function() NULL
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
dev.null()
ef = dev.off2
} else {
which = .ENV$current_annotation_which
}
on.exit(ef())
if(is.data.frame(x)) x = as.matrix(x)
if(is.matrix(x)) {
if(ncol(x) == 1) {
x = x[, 1]
}
}
input_is_matrix = is.matrix(x)
anno_size = anno_width_and_height(which, width, height, unit(1, "cm"))
if(is.matrix(x)) {
n = nrow(x)
nr = n
nc = ncol(x)
} else {
n = length(x)
nr = n
nc = 1
}
if(input_is_matrix) {
gp = recycle_gp(gp, nc)
if(length(pch) == 1) pch = rep(pch, nc)
if(length(size) == 1) size = rep(size, nc)
} else if(is.atomic(x)) {
gp = recycle_gp(gp, n)
if(length(pch) == 1) pch = rep(pch, n)
if(length(size) == 1) size = rep(size, n)
}
if(is.null(ylim)) {
data_scale = range(x, na.rm = TRUE)
} else {
data_scale = ylim
}
data_scale = data_scale + c(-extend, extend)*(data_scale[2] - data_scale[1])
value = x
axis_param = validate_axis_param(axis_param, which)
axis_grob = if(axis) construct_axis_grob(axis_param, which, data_scale) else NULL
row_fun = function(index, k = 1, N = 1) {
n = length(index)
pushViewport(viewport(xscale = data_scale, yscale = c(0.5, n+0.5)))
if(is.matrix(value)) {
for(i in seq_len(ncol(value))) {
grid.points(value[index, i], n - seq_along(index) + 1, gp = subset_gp(gp, i),
default.units = "native", pch = pch[i], size = size[i])
}
} else {
grid.points(value[index], n - seq_along(index) + 1, gp = subset_gp(gp, index), default.units = "native",
pch = pch[index], size = size[index])
}
if(axis_param$side == "top") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "bottom") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
column_fun = function(index, k = 1, N = 1) {
n = length(index)
pushViewport(viewport(yscale = data_scale, xscale = c(0.5, n+0.5)))
if(is.matrix(value)) {
for(i in seq_len(ncol(value))) {
grid.points(seq_along(index), value[index, i], gp = subset_gp(gp, i), default.units = "native", pch = pch[i], size = size[i])
}
} else {
grid.points(seq_along(index), value[index], gp = subset_gp(gp, index), default.units = "native", pch = pch[index], size = size[index])
}
if(axis_param$side == "left") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "right") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_points",
which = which,
width = anno_size$width,
height = anno_size$height,
n = n,
data_scale = data_scale,
var_import = list(value, gp, border, pch, size, axis, axis_param, axis_grob, data_scale)
)
anno@subset_rule$gp = subset_vector
if(input_is_matrix) {
anno@subset_rule$value = subset_matrix_by_row
} else {
anno@subset_rule$value = subset_vector
anno@subset_rule$gp = subset_gp
anno@subset_rule$size = subset_vector
anno@subset_rule$pch = subset_vector
}
anno@subsetable = TRUE
anno@extended = update_anno_extend(anno, axis_grob, axis_param)
return(anno)
}
update_anno_extend = function(anno, axis_grob, axis_param) {
extended = anno@extended
if(is.null(axis_grob)) {
return(extended)
}
if(axis_param$facing == "outside") {
if(axis_param$side == "left") {
extended[[2]] = convertWidth(grobWidth(axis_grob), "mm", valueOnly = TRUE)
} else if(axis_param$side == "right") {
extended[[4]] = convertWidth(grobWidth(axis_grob), "mm", valueOnly = TRUE)
} else if(axis_param$side == "top") {
extended[[3]] = convertHeight(grobHeight(axis_grob), "mm", valueOnly = TRUE)
} else if(axis_param$side == "bottom") {
extended[[1]] = convertHeight(grobHeight(axis_grob), "mm", valueOnly = TRUE)
}
}
return(extended)
}
# == title
# Lines Annotation
#
# == param
# -x The value vector. The value can be a vector or a matrix. The length of the vector
# or the number of rows of the matrix is taken as the number of the observations of the annotation.
# -which Whether it is a column annotation or a row annotation?
# -border Wether draw borders of the annotation region?
# -gp Graphic parameters for lines. The length of each graphic parameter can be 1, or number of columns of ``x`` is ``x`` is a matrix.
# -add_points Whether to add points on the lines?
# -smooth If it is ``TRUE``, smoothing by `stats::loess` is performed. If it is ``TRUE``, ``add_points`` is set to ``TRUE`` by default.
# -pch Point type. The length setting is the same as ``gp``.
# -size Point size, the value should be a `grid::unit` object. The length setting is the same as ``gp``.
# -pt_gp Graphic parameters for points. The length setting is the same as ``gp``.
# -ylim Data ranges. By default it is ``range(x)``.
# -extend The extension to both side of ``ylim``. The value is a percent value corresponding to ``ylim[2] - ylim[1]``.
# -axis Whether to add axis?
# -axis_param parameters for controlling axis. See `default_axis_param` for all possible settings and default parameters.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#lines-annotation
#
# == example
# anno = anno_lines(runif(10))
# draw(anno, test = "anno_lines")
# anno = anno_lines(cbind(c(1:5, 1:5), c(5:1, 5:1)), gp = gpar(col = 2:3))
# draw(anno, test = "matrix")
# anno = anno_lines(cbind(c(1:5, 1:5), c(5:1, 5:1)), gp = gpar(col = 2:3),
# add_points = TRUE, pt_gp = gpar(col = 5:6), pch = c(1, 16))
# draw(anno, test = "matrix")
anno_lines = function(x, which = c("column", "row"), border = TRUE, gp = gpar(),
add_points = smooth, smooth = FALSE, pch = 16, size = unit(2, "mm"), pt_gp = gpar(), ylim = NULL,
extend = 0.05, axis = TRUE, axis_param = default_axis_param(which),
width = NULL, height = NULL) {
ef = function() NULL
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
dev.null()
ef = dev.off2
} else {
which = .ENV$current_annotation_which
}
on.exit(ef())
if(is.data.frame(x)) x = as.matrix(x)
if(is.matrix(x)) {
if(ncol(x) == 1) {
x = x[, 1]
}
}
input_is_matrix = is.matrix(x)
anno_size = anno_width_and_height(which, width, height, unit(1, "cm"))
if(is.matrix(x)) {
n = nrow(x)
nr = n
nc = ncol(x)
} else {
n = length(x)
nr = n
nc = 1
}
if(input_is_matrix) {
gp = recycle_gp(gp, nc)
pt_gp = recycle_gp(pt_gp, nc)
if(length(pch) == 1) pch = rep(pch, nc)
if(length(size) == 1) size = rep(size, nc)
} else if(is.atomic(x)) {
gp = recycle_gp(gp, 1)
pt_gp = recycle_gp(pt_gp, n)
if(length(pch) == 1) pch = rep(pch, n)
if(length(size) == 1) size = rep(size, n)
}
if(is.null(ylim)) {
data_scale = range(x, na.rm = TRUE)
} else {
data_scale = ylim
}
data_scale = data_scale + c(-extend, extend)*(data_scale[2] - data_scale[1])
value = x
axis_param = validate_axis_param(axis_param, which)
axis_grob = if(axis) construct_axis_grob(axis_param, which, data_scale) else NULL
row_fun = function(index, k = 1, N = 1) {
n = length(index)
pushViewport(viewport(xscale = data_scale, yscale = c(0.5, n+0.5)))
if(is.matrix(value)) {
for(i in seq_len(ncol(value))) {
x = n - seq_along(index) + 1
y = value[index, i]
if(smooth) {
fit = loess(y ~ x)
x2 = seq(x[1], x[length(x)], length = 100)
y2 = predict(fit, x2)
grid.lines(y2, x2, gp = subset_gp(gp, i), default.units = "native")
} else {
grid.lines(y, x, gp = subset_gp(gp, i), default.units = "native")
}
if(add_points) {
grid.points(y, x, gp = subset_gp(pt_gp, i),
default.units = "native", pch = pch[i], size = size[i])
}
}
} else {
x = n - seq_along(index) + 1
y = value[index]
if(smooth) {
fit = loess(y ~ x)
x2 = seq(x[1], x[length(x)], length = 100)
y2 = predict(fit, x2)
grid.lines(y2, x2, gp = gp, default.units = "native")
} else {
grid.lines(y, x, gp = gp, default.units = "native")
}
if(add_points) {
grid.points(y, x, gp = subset_gp(pt_gp, index), default.units = "native",
pch = pch[index], size = size[index])
}
}
if(axis_param$side == "top") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "bottom") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
column_fun = function(index, k = 1, N = 1) {
n = length(index)
pushViewport(viewport(yscale = data_scale, xscale = c(0.5, n+0.5)))
if(is.matrix(value)) {
for(i in seq_len(ncol(value))) {
x = seq_along(index)
y = value[index, i]
if(smooth) {
fit = loess(y ~ x)
x2 = seq(x[1], x[length(x)], length = 100)
y2 = predict(fit, x2)
grid.lines(x2, y2, gp = subset_gp(gp, i), default.units = "native")
} else {
grid.lines(x, y, gp = subset_gp(gp, i), default.units = "native")
}
if(add_points) {
grid.points(x, y, gp = subset_gp(pt_gp, i),
default.units = "native", pch = pch[i], size = size[i])
}
}
} else {
x = seq_along(index)
y = value[index]
if(smooth) {
fit = loess(y ~ x)
x2 = seq(x[1], x[length(x)], length = 100)
y2 = predict(fit, x2)
grid.lines(x2, y2, gp = gp, default.units = "native")
} else {
grid.lines(x, y, gp = gp, default.units = "native")
}
if(add_points) {
grid.points(seq_along(index), value[index], gp = subset_gp(pt_gp, index), default.units = "native",
pch = pch[index], size = size[index])
}
}
if(axis_param$side == "left") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "right") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_points",
which = which,
width = anno_size$width,
height = anno_size$height,
n = n,
data_scale = data_scale,
var_import = list(value, gp, border, pch, size, pt_gp, axis, axis_param,
axis_grob, data_scale, add_points, smooth)
)
anno@subset_rule$gp = subset_vector
if(input_is_matrix) {
anno@subset_rule$value = subset_matrix_by_row
} else {
anno@subset_rule$value = subset_vector
anno@subset_rule$gp = subset_gp
anno@subset_rule$pt_gp = subset_gp
anno@subset_rule$size = subset_vector
anno@subset_rule$pch = subset_vector
}
anno@subsetable = TRUE
anno@extended = update_anno_extend(anno, axis_grob, axis_param)
return(anno)
}
# == title
# Barplot Annotation
#
# == param
# -x The value vector. The value can be a vector or a matrix. The length of the vector
# or the number of rows of the matrix is taken as the number of the observations of the annotation.
# If ``x`` is a vector, the barplots will be represented as stacked barplots.
# -baseline baseline of bars. The value should be "min" or "max", or a numeric value. It is enforced to be zero
# for stacked barplots.
# -which Whether it is a column annotation or a row annotation?
# -border Wether draw borders of the annotation region?
# -bar_width Relative width of the bars. The value should be smaller than one.
# -gp Graphic parameters for points. The length of each graphic parameter can be 1, length of ``x`` if ``x``
# is a vector, or number of columns of ``x`` is ``x`` is a matrix.
# -ylim Data ranges. By default it is ``range(x)`` if ``x`` is a vector, or ``range(rowSums(x))`` if ``x`` is a matrix.
# -extend The extension to both side of ``ylim``. The value is a percent value corresponding to ``ylim[2] - ylim[1]``.
# -axis Whether to add axis?
# -axis_param parameters for controlling axis. See `default_axis_param` for all possible settings and default parameters.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
# -... Other arguments.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#barplot_annotation
#
# == example
# anno = anno_barplot(1:10)
# draw(anno, test = "a vector")
#
# m = matrix(runif(4*10), nc = 4)
# m = t(apply(m, 1, function(x) x/sum(x)))
# anno = anno_barplot(m, gp = gpar(fill = 2:5), bar_width = 1, height = unit(6, "cm"))
# draw(anno, test = "proportion matrix")
anno_barplot = function(x, baseline = 0, which = c("column", "row"), border = TRUE, bar_width = 0.6,
gp = gpar(fill = "#CCCCCC"), ylim = NULL, extend = 0.05, axis = TRUE,
axis_param = default_axis_param(which),
width = NULL, height = NULL, ...) {
other_args = list(...)
if(length(other_args)) {
if("axis_gp" %in% names(other_args)) {
stop_wrap("`axis_gp` is removed from the arguments. Use `axis_param = list(gp = ...)` instead.")
}
if("axis_side" %in% names(other_args)) {
stop_wrap("`axis_side` is removed from the arguments. Use `axis_param = list(side = ...)` instead.")
}
if("axis_direction" %in% names(other_args)) {
stop_wrap("`axis_direction` is not supported any more.")
}
}
if(inherits(x, "list")) x = do.call("cbind", x)
if(inherits(x, "data.frame")) x = as.matrix(x)
if(inherits(x, "matrix")) {
sg = apply(x, 1, function(xx) all(sign(xx) %in% c(1, 0)) || all(sign(xx) %in% c(-1, 0)))
if(!all(sg)) {
stop_wrap("Since `x` is a matrix, the sign of each row should be either all positive or all negative.")
}
}
# convert everything to matrix
if(is.null(dim(x))) x = matrix(x, ncol = 1)
nc = ncol(x)
if(missing(gp)) {
gp = gpar(fill = grey(seq(0, 1, length = nc+2))[-c(1, nc+2)])
}
data_scale = range(rowSums(x, na.rm = TRUE), na.rm = TRUE)
if(!is.null(ylim)) data_scale = ylim
if(baseline == "min") {
data_scale = data_scale + c(0, extend)*(data_scale[2] - data_scale[1])
baseline = min(x)
} else if(baseline == "max") {
data_scale = data_scale + c(-extend, 0)*(data_scale[2] - data_scale[1])
baseline = max(x)
} else {
if(is.numeric(baseline)) {
if(baseline == 0 && all(abs(rowSums(x) - 1) < 1e-6)) {
data_scale = c(0, 1)
} else if(baseline <= data_scale[1]) {
data_scale = c(baseline, extend*(data_scale[2] - baseline) + data_scale[2])
} else if(baseline >= data_scale[2]) {
data_scale = c(-extend*(baseline - data_scale[1]) + data_scale[1], baseline)
} else {
data_scale = data_scale + c(-extend, extend)*(data_scale[2] - data_scale[1])
}
}
}
ef = function() NULL
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
dev.null()
ef = dev.off2
} else {
which = .ENV$current_annotation_which
}
on.exit(ef())
anno_size = anno_width_and_height(which, width, height, unit(1, "cm"))
if(nc == 1) {
gp = recycle_gp(gp, nrow(x))
} else {
gp = recycle_gp(gp, nc)
}
value = x
axis_param = validate_axis_param(axis_param, which)
axis_grob = if(axis) construct_axis_grob(axis_param, which, data_scale) else NULL
row_fun = function(index, k = 1, N = 1) {
n = length(index)
pushViewport(viewport(xscale = data_scale, yscale = c(0.5, n+0.5)))
if(ncol(value) == 1) {
width = value[index] - baseline
x_coor = width/2+baseline
grid.rect(x = x_coor, y = n - seq_along(index) + 1, width = abs(width), height = 1*bar_width, default.units = "native", gp = subset_gp(gp, index))
} else {
for(i in seq_len(ncol(value))) {
width = value[index, i]
x_coor = rowSums(value[index, seq_len(i-1), drop = FALSE]) + width/2
grid.rect(x = x_coor, y = n - seq_along(index) + 1, width = abs(width), height = 1*bar_width, default.units = "native", gp = subset_gp(gp, i))
}
}
if(axis_param$side == "top") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "bottom") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
column_fun = function(index, k = 1, N = 1) {
n = length(index)
pushViewport(viewport(yscale = data_scale, xscale = c(0.5, n+0.5)))
if(ncol(value) == 1) {
height = value[index] - baseline
y_coor = height/2+baseline
grid.rect(y = y_coor, x = seq_along(index), height = abs(height), width = 1*bar_width, default.units = "native", gp = subset_gp(gp, index))
} else {
for(i in seq_len(ncol(value))) {
height = value[index, i]
y_coor = rowSums(value[index, seq_len(i-1), drop = FALSE]) + height/2
grid.rect(y = y_coor, x = seq_along(index), height = abs(height), width = 1*bar_width, default.units = "native", gp = subset_gp(gp, i))
}
}
if(axis_param$side == "left") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "right") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
n = nrow(value)
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_barplot",
which = which,
width = anno_size$width,
height = anno_size$height,
n = n,
data_scale = data_scale,
var_import = list(value, gp, border, bar_width, baseline, axis, axis_param, axis_grob, data_scale)
)
anno@subset_rule$value = subset_matrix_by_row
if(ncol(value) == 1) {
anno@subset_rule$gp = subset_gp
}
anno@subsetable = TRUE
anno@extended = update_anno_extend(anno, axis_grob, axis_param)
return(anno)
}
# == title
# Boxplot Annotation
#
# == param
# -x A matrix or a list. If ``x`` is a matrix and if ``which`` is ``column``, statistics for boxplots
# are calculated by columns, if ``which`` is ``row``, the calculation is done by rows.
# -which Whether it is a column annotation or a row annotation?
# -border Wether draw borders of the annotation region?
# -gp Graphic parameters for the boxes. The length of the graphic parameters should be one or the number of observations.
# -ylim Data ranges.
# -extend The extension to both side of ``ylim``. The value is a percent value corresponding to ``ylim[2] - ylim[1]``.
# -outline Whether draw outline of boxplots?
# -box_width Relative width of boxes. The value should be smaller than one.
# -pch Point style.
# -size Point size.
# -axis Whether to add axis?
# -axis_param parameters for controlling axis. See `default_axis_param` for all possible settings and default parameters.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
# -... Other arguments.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#box-annotation
#
# == example
# set.seed(123)
# m = matrix(rnorm(100), 10)
# anno = anno_boxplot(m, height = unit(4, "cm"))
# draw(anno, test = "anno_boxplot")
# anno = anno_boxplot(m, height = unit(4, "cm"), gp = gpar(fill = 1:10))
# draw(anno, test = "anno_boxplot with gp")
anno_boxplot = function(x, which = c("column", "row"), border = TRUE,
gp = gpar(fill = "#CCCCCC"), ylim = NULL, extend = 0.05, outline = TRUE, box_width = 0.6,
pch = 1, size = unit(2, "mm"), axis = TRUE, axis_param = default_axis_param(which),
width = NULL, height = NULL, ...) {
other_args = list(...)
if(length(other_args)) {
if("axis_gp" %in% names(other_args)) {
stop_wrap("`axis_gp` is removed from the arguments. Use `axis_param = list(gp = ...)` instead.")
}
if("axis_side" %in% names(other_args)) {
stop_wrap("`axis_side` is removed from the arguments. Use `axis_param = list(side = ...)` instead.")
}
if("axis_direction" %in% names(other_args)) {
stop_wrap("`axis_direction` is not supported any more.")
}
}
ef = function() NULL
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
dev.null()
ef = dev.off2
} else {
which = .ENV$current_annotation_which
}
on.exit(ef())
anno_size = anno_width_and_height(which, width, height, unit(2, "cm"))
## convert matrix all to list (or data frame)
if(is.matrix(x)) {
if(which == "column") {
value = as.data.frame(x)
} else if(which == "row") {
value = as.data.frame(t(x))
}
} else {
value = x
}
if(is.null(ylim)) {
if(!outline) {
boxplot_stats = boxplot(value, plot = FALSE)$stats
data_scale = range(boxplot_stats)
} else {
data_scale = range(value, na.rm = TRUE)
}
} else {
data_scale = ylim
}
data_scale = data_scale + c(-extend, extend)*(data_scale[2] - data_scale[1])
n = length(value)
gp = recycle_gp(gp, n)
if(length(pch) == 1) pch = rep(pch, n)
if(length(size) == 1) size = rep(size, n)
axis_param = validate_axis_param(axis_param, which)
axis_grob = if(axis) construct_axis_grob(axis_param, which, data_scale) else NULL
row_fun = function(index, k = 1, N = 1) {
n_all = length(value)
value = value[index]
boxplot_stats = boxplot(value, plot = FALSE)$stats
n = length(index)
gp = subset_gp(gp, index)
pch = pch[index]
size = size[index]
pushViewport(viewport(xscale = data_scale, yscale = c(0.5, n+0.5)))
grid.rect(x = boxplot_stats[2, ], y = n - seq_along(index) + 1,
height = 1*box_width, width = boxplot_stats[4, ] - boxplot_stats[2, ], just = "left",
default.units = "native", gp = gp)
grid.segments(boxplot_stats[5, ], n - seq_along(index) + 1 - 0.5*box_width,
boxplot_stats[5, ], n - seq_along(index) + 1 + 0.5*box_width,
default.units = "native", gp = gp)
grid.segments(boxplot_stats[5, ], n - seq_along(index) + 1,
boxplot_stats[4, ], n - seq_along(index) + 1,
default.units = "native", gp = gp)
grid.segments(boxplot_stats[1, ], n - seq_along(index) + 1,
boxplot_stats[2, ], n - seq_along(index) + 1,
default.units = "native", gp = gp)
grid.segments(boxplot_stats[1, ], n - seq_along(index) + 1 - 0.5*box_width,
boxplot_stats[1, ], n - seq_along(index) + 1 + 0.5*box_width,
default.units = "native", gp = gp)
grid.segments(boxplot_stats[3, ], n - seq_along(index) + 1 - 0.5*box_width,
boxplot_stats[3, ], n - seq_along(index) + 1 + 0.5*box_width,
default.units = "native", gp = gp)
if(outline) {
for(i in seq_along(value)) {
l1 = value[[i]] > boxplot_stats[5,i]
l1[is.na(l1)] = FALSE
if(sum(l1)) grid.points(y = rep(n - i + 1, sum(l1)), x = value[[i]][l1],
default.units = "native", gp = subset_gp(gp, i), pch = pch[i], size = size[i])
l2 = value[[i]] < boxplot_stats[1,i]
l2[is.na(l2)] = FALSE
if(sum(l2)) grid.points(y = rep(n - i + 1, sum(l2)), x = value[[i]][l2],
default.units = "native", gp = subset_gp(gp, i), pch = pch[i], size = size[i])
}
}
if(axis_param$side == "top") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "bottom") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
column_fun = function(index, k = 1, N = 1) {
value = value[index]
boxplot_stats = boxplot(value, plot = FALSE)$stats
n = length(index)
gp = subset_gp(gp, index)
pch = pch[index]
size = size[index]
pushViewport(viewport(xscale = c(0.5, n+0.5), yscale = data_scale))
grid.rect(x = seq_along(index), y = boxplot_stats[2, ],
height = boxplot_stats[4, ] - boxplot_stats[2, ], width = 1*box_width, just = "bottom",
default.units = "native", gp = gp)
grid.segments(seq_along(index) - 0.5*box_width, boxplot_stats[5, ],
seq_along(index) + 0.5*box_width, boxplot_stats[5, ],
default.units = "native", gp = gp)
grid.segments(seq_along(index), boxplot_stats[5, ],
seq_along(index), boxplot_stats[4, ],
default.units = "native", gp = gp)
grid.segments(seq_along(index), boxplot_stats[1, ],
seq_along(index), boxplot_stats[2, ],
default.units = "native", gp = gp)
grid.segments(seq_along(index) - 0.5*box_width, boxplot_stats[1, ],
seq_along(index) + 0.5*box_width, boxplot_stats[1, ],
default.units = "native", gp = gp)
grid.segments(seq_along(index) - 0.5*box_width, boxplot_stats[3, ],
seq_along(index) + 0.5*box_width, boxplot_stats[3, ],
default.units = "native", gp = gp)
if(outline) {
for(i in seq_along(value)) {
l1 = value[[i]] > boxplot_stats[5,i]
l1[is.na(l1)] = FALSE
if(sum(l1)) grid.points(x = rep(i, sum(l1)), y = value[[i]][l1],
default.units = "native", gp = subset_gp(gp, i), pch = pch[i], size = size[i])
l2 = value[[i]] < boxplot_stats[1,i]
l2[is.na(l2)] = FALSE
if(sum(l2)) grid.points(x = rep(i, sum(l2)), y = value[[i]][l2],
default.units = "native", gp = subset_gp(gp, i), pch = pch[i], size = size[i])
}
}
if(axis_param$side == "left") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "right") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_boxplot",
which = which,
n = n,
width = anno_size$width,
height = anno_size$height,
data_scale = data_scale,
var_import = list(value, gp, border, box_width, axis, axis_param, axis_grob, data_scale, pch, size, outline)
)
anno@subset_rule$value = subset_vector
anno@subset_rule$gp = subset_gp
anno@subset_rule$pch = subset_vector
anno@subset_rule$size = subset_vector
anno@subsetable = TRUE
anno@extended = update_anno_extend(anno, axis_grob, axis_param)
return(anno)
}
# == title
# Histogram Annotation
#
# == param
# -x A matrix or a list. If ``x`` is a matrix and if ``which`` is ``column``, statistics for boxplots
# are calculated by columns, if ``which`` is ``row``, the calculation is done by rows.
# -which Whether it is a column annotation or a row annotation?
# -n_breaks Number of breaks for calculating histogram.
# -border Wether draw borders of the annotation region?
# -gp Graphic parameters for the boxes. The length of the graphic parameters should be one or the number of observations.
# -axis Whether to add axis?
# -axis_param parameters for controlling axis. See `default_axis_param` for all possible settings and default parameters.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#histogram-annotation
#
# == example
# m = matrix(rnorm(1000), nc = 10)
# anno = anno_histogram(t(m), which = "row")
# draw(anno, test = "row histogram")
# anno = anno_histogram(t(m), which = "row", gp = gpar(fill = 1:10))
# draw(anno, test = "row histogram with color")
# anno = anno_histogram(t(m), which = "row", n_breaks = 20)
# draw(anno, test = "row histogram with color")
anno_histogram = function(x, which = c("column", "row"), n_breaks = 11,
border = FALSE, gp = gpar(fill = "#CCCCCC"),
axis = TRUE, axis_param = default_axis_param(which),
width = NULL, height = NULL) {
ef = function() NULL
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
dev.null()
ef = dev.off2
} else {
which = .ENV$current_annotation_which
}
on.exit(ef())
anno_size = anno_width_and_height(which, width, height, unit(4, "cm"))
## convert matrix all to list (or data frame)
if(is.matrix(x)) {
if(which == "column") {
value = as.data.frame(x)
} else if(which == "row") {
value = as.data.frame(t(x))
}
} else {
value = x
}
n = length(value)
x_range =range(unlist(value), na.rm = TRUE)
histogram_stats = lapply(value, hist, plot = FALSE, breaks = seq(x_range[1], x_range[2], length = n_breaks))
histogram_breaks = lapply(histogram_stats, function(x) x$breaks)
histogram_counts = lapply(histogram_stats, function(x) x$counts)
xscale = range(unlist(histogram_breaks), na.rm = TRUE)
xscale = xscale + c(0, 0.05)*(xscale[2] - xscale[1])
yscale = c(0, max(unlist(histogram_counts)))
yscale[2] = yscale[2]*1.05
gp = recycle_gp(gp, n)
axis_param = validate_axis_param(axis_param, which)
axis_grob = if(axis) construct_axis_grob(axis_param, which, xscale) else NULL
row_fun = function(index, k = 1, N = 1) {
n_all = length(value)
value = value[index]
n = length(index)
histogram_breaks = histogram_breaks[index]
histogram_counts = histogram_counts[index]
gp = subset_gp(gp, index)
for(i in seq_len(n)) {
n_breaks = length(histogram_breaks[[i]])
pushViewport(viewport(x = unit(0, "npc"), y = unit((n-i)/n, "npc"), height = unit(1/n, "npc"), just = c("left", "bottom"), xscale = xscale, yscale = yscale))
grid.rect(x = histogram_breaks[[i]][-1], y = 0, width = histogram_breaks[[i]][-1] - histogram_breaks[[i]][-n_breaks], height = histogram_counts[[i]], just = c("right", "bottom"), default.units = "native", gp = subset_gp(gp, i))
popViewport()
}
pushViewport(viewport(xscale = xscale))
if(axis_param$side == "top") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "bottom") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
column_fun = function(index, k = 1, N = 1) {
n_all = length(value)
value = value[index]
foo = yscale
yscale = xscale
xscale = foo
histogram_breaks = histogram_breaks[index]
histogram_counts = histogram_counts[index]
n = length(index)
gp = subset_gp(gp, index)
for(i in seq_len(n)) {
n_breaks = length(histogram_breaks[[i]])
pushViewport(viewport(y = unit(0, "npc"), x = unit(i/n, "npc"), width = unit(1/n, "npc"),
just = c("right", "bottom"), xscale = xscale, yscale = yscale))
grid.rect(y = histogram_breaks[[i]][-1], x = 0, height = histogram_breaks[[i]][-1] - histogram_breaks[[i]][-n_breaks],
width = histogram_counts[[i]], just = c("left", "top"), default.units = "native", gp = subset_gp(gp, i))
popViewport()
}
pushViewport(viewport(yscale = yscale))
if(axis_param$side == "left") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "right") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_histogram",
which = which,
width = anno_size$width,
height = anno_size$height,
n = n,
data_scale = xscale,
var_import = list(value, gp, border, axis, axis_param, axis_grob, xscale, yscale,
histogram_breaks, histogram_counts)
)
anno@subset_rule$value = subset_vector
anno@subset_rule$gp = subset_gp
anno@subset_rule$histogram_breaks = subset_vector
anno@subset_rule$histogram_counts = subset_vector
anno@subsetable = TRUE
anno@extended = update_anno_extend(anno, axis_grob, axis_param)
return(anno)
}
# == title
# Density Annotation
#
# == param
# -x A matrix or a list. If ``x`` is a matrix and if ``which`` is ``column``, statistics for boxplots
# are calculated by columns, if ``which`` is ``row``, the calculation is done by rows.
# -which Whether it is a column annotation or a row annotation?
# -type Type of graphics to represent density distribution. "lines" for normal density plot; "violine" for violin plot
# and "heatmap" for heatmap visualization of density distribution.
# -heatmap_colors A vector of colors for interpolating density values.
# -joyplot_scale Relative height of density distribution. A value higher than 1 increases the height of the density
# distribution and the plot will represented as so-called "joyplot".
# -border Wether draw borders of the annotation region?
# -gp Graphic parameters for the boxes. The length of the graphic parameters should be one or the number of observations.
# -axis Whether to add axis?
# -axis_param parameters for controlling axis. See `default_axis_param` for all possible settings and default parameters.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#density-annotation
#
# == example
# m = matrix(rnorm(100), 10)
# anno = anno_density(m, which = "row")
# draw(anno, test = "normal density")
# anno = anno_density(m, which = "row", type = "violin")
# draw(anno, test = "violin")
# anno = anno_density(m, which = "row", type = "heatmap")
# draw(anno, test = "heatmap")
# anno = anno_density(m, which = "row", type = "heatmap",
# heatmap_colors = c("white", "orange"))
# draw(anno, test = "heatmap, colors")
anno_density = function(x, which = c("column", "row"),
type = c("lines", "violin", "heatmap"),
heatmap_colors = rev(brewer.pal(name = "RdYlBu", n = 11)),
joyplot_scale = 1, border = TRUE, gp = gpar(fill = "#CCCCCC"),
axis = TRUE, axis_param = default_axis_param(which),
width = NULL, height = NULL) {
ef = function() NULL
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
dev.null()
ef = dev.off2
} else {
which = .ENV$current_annotation_which
}
on.exit(ef())
anno_size = anno_width_and_height(which, width, height, unit(4, "cm"))
## convert matrix all to list (or data frame)
if(is.matrix(x)) {
if(which == "column") {
value = as.data.frame(x)
} else if(which == "row") {
value = as.data.frame(t(x))
}
} else {
value = x
}
n = length(value)
gp = recycle_gp(gp, n)
type = match.arg(type)[1]
n_all = length(value)
density_stats = lapply(value, density, na.rm = TRUE)
density_x = lapply(density_stats, function(x) x$x)
density_y = lapply(density_stats, function(x) x$y)
min_density_x = min(unlist(density_x))
max_density_x = max(unlist(density_x))
xscale = range(unlist(density_x), na.rm = TRUE)
xscale = xscale + c(0, 0.05)*(xscale[2] - xscale[1])
if(type == "lines") {
yscale = c(0, max(unlist(density_y)))
yscale[2] = yscale[2]*1.05
} else if(type == "violin") {
yscale = max(unlist(density_y))
yscale = c(-yscale*1.05, yscale*1.05)
} else if(type == "heatmap") {
xscale = range(unlist(density_x), na.rm = TRUE)
yscale = c(0, 1)
min_y = min(unlist(density_y))
max_y = max(unlist(density_y))
col_fun = colorRamp2(seq(min_y, max_y,
length = length(heatmap_colors)), heatmap_colors)
}
axis_param = validate_axis_param(axis_param, which)
axis_grob = if(axis) construct_axis_grob(axis_param, which, xscale) else NULL
row_fun = function(index, k = 1, N = 1) {
n = length(index)
value = value[index]
gp = subset_gp(gp, index)
density_x = density_x[index]
density_y = density_y[index]
for(i in seq_len(n)) {
pushViewport(viewport(x = unit(0, "npc"), y = unit((n-i)/n, "npc"),
just = c("left", "bottom"), height = unit(1/n, "npc"), xscale = xscale,
yscale = yscale))
if(type == "lines") {
grid.polygon(x = density_x[[i]], y = density_y[[i]]*joyplot_scale,
default.units = "native", gp = subset_gp(gp, i))
} else if(type == "violin") {
grid.polygon(x = c(density_x[[i]], rev(density_x[[i]])),
y = c(density_y[[i]], -rev(density_y[[i]])), default.units = "native",
gp = subset_gp(gp, i))
box_stat = boxplot(value[[i]], plot = FALSE)$stat
grid.lines(box_stat[1:2, 1], c(0, 0), default.units = "native",
gp = subset_gp(gp, i))
grid.lines(box_stat[4:5, 1], c(0, 0), default.units = "native",
gp = subset_gp(gp, i))
grid.points(box_stat[3, 1], 0, default.units = "native", pch = 3,
size = unit(1, "mm"), gp = subset_gp(gp, i))
} else if(type == "heatmap") {
n_breaks = length(density_x[[i]])
grid.rect(x = density_x[[i]][-1], y = 0,
width = density_x[[i]][-1] - density_x[[i]][-n_breaks], height = 1,
just = c("right", "bottom"), default.units = "native",
gp = gpar(fill = col_fun((density_y[[i]][-1] + density_y[[i]][-n_breaks])/2),
col = NA))
grid.rect(x = density_x[[i]][1], y = 0, width = density_x[[i]][1] - min_density_x,
height = 1, just = c("right", "bottom"), default.units = "native",
gp = gpar(fill = col_fun(0), col = NA))
grid.rect(x = density_x[[i]][n_breaks], y = 0,
width = max_density_x - density_x[[i]][n_breaks], height = 1,
just = c("left", "bottom"), default.units = "native",
gp = gpar(fill = col_fun(0), col = NA))
}
popViewport()
}
pushViewport(viewport(xscale = xscale))
if(axis_param$side == "top") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "bottom") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
column_fun = function(index, k = 1, N = 1) {
n_all = length(value)
value = value[index]
foo = yscale
yscale = xscale
xscale = foo
density_x = density_x[index]
density_y = density_y[index]
yscale = range(unlist(density_x), na.rm = TRUE)
yscale = yscale + c(0, 0.05)*(yscale[2] - yscale[1])
if(type == "lines") {
xscale = c(0, max(unlist(density_y)))
xscale[2] = xscale[2]*1.05
} else if(type == "violin") {
xscale = max(unlist(density_y))
xscale = c(-xscale*1.05, xscale*1.05)
} else if(type == "heatmap") {
yscale = range(unlist(density_x), na.rm = TRUE)
xscale = c(0, 1)
min_y = min(unlist(density_y))
max_y = max(unlist(density_y))
col_fun = colorRamp2(seq(min_y, max_y,
length = length(heatmap_colors)), heatmap_colors)
}
n = length(index)
gp = subset_gp(gp, index)
for(i in rev(seq_len(n))) {
pushViewport(viewport(y = unit(0, "npc"), x = unit(i/n, "npc"), width = unit(1/n, "npc"),
just = c("right", "bottom"), xscale = xscale, yscale = yscale))
if(type == "lines") {
grid.polygon(y = density_x[[i]], x = density_y[[i]]*joyplot_scale,
default.units = "native", gp = subset_gp(gp, i))
} else if(type == "violin") {
grid.polygon(y = c(density_x[[i]], rev(density_x[[i]])),
x = c(density_y[[i]], -rev(density_y[[i]])), default.units = "native",
gp = subset_gp(gp, i))
box_stat = boxplot(value[[i]], plot = FALSE)$stat
grid.lines(y = box_stat[1:2, 1], x = c(0, 0), default.units = "native",
gp = subset_gp(gp, i))
grid.lines(y = box_stat[4:5, 1], x = c(0, 0), default.units = "native",
gp = subset_gp(gp, i))
grid.points(y = box_stat[3, 1], x = 0, default.units = "native", pch = 3,
size = unit(1, "mm"), gp = subset_gp(gp, i))
} else if(type == "heatmap") {
n_breaks = length(density_x[[i]])
grid.rect(y = density_x[[i]][-1], x = 0,
height = density_x[[i]][-1] - density_x[[i]][-n_breaks], width = 1,
just = c("left", "top"), default.units = "native",
gp = gpar(fill = col_fun((density_y[[i]][-1] + density_y[[i]][-n_breaks])/2),
col = NA))
grid.rect(y = density_x[[i]][1], x = 0, height = density_x[[i]][1] - min_density_x,
width = 1, just = c("left", "top"), default.units = "native",
gp = gpar(fill = col_fun(0), col = NA))
grid.rect(y = density_x[[i]][n_breaks], x = 0,
height = max_density_x - density_x[[i]][n_breaks], width = 1,
just = c("left", "bottom"), default.units = "native",
gp = gpar(fill = col_fun(0), col = NA))
}
popViewport()
}
pushViewport(viewport(yscale = yscale))
if(axis_param$side == "left") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "right") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_density",
which = which,
width = anno_size$width,
height = anno_size$height,
n = n,
data_scale = xscale,
var_import = list(value, gp, border, type, axis, axis_param, axis_grob, xscale, yscale, density_x,
density_y, min_density_x, max_density_x, joyplot_scale, heatmap_colors)
)
if(type == "heatmap") {
anno@var_env$col_fun = col_fun
}
anno@subset_rule$value = subset_vector
anno@subset_rule$gp = subset_gp
anno@subset_rule$density_x = subset_vector
anno@subset_rule$density_y = subset_vector
anno@subsetable = TRUE
anno@extended = update_anno_extend(anno, axis_grob, axis_param)
return(anno)
}
# == title
# Text Annotation
#
# == param
# -x A vector of text.
# -which Whether it is a column annotation or a row annotation?
# -gp Graphic parameters.
# -rot Rotation of the text, pass to `grid::grid.text`.
# -just Justification of text, pass to `grid::grid.text`.
# -offset Depracated, use ``location`` instead.
# -location Position of the text. By default ``rot``, ``just`` and ``location`` are automatically
# inferred according to whether it is a row annotation or column annotation. The value
# of ``location`` should be a `grid::unit` object, normally in ``npc`` unit. E.g. ``unit(0, 'npc')``
# means the most left of the annotation region and ``unit(1, 'npc')`` means the most right of
# the annotation region.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#text-annotation
#
# == example
# anno = anno_text(month.name)
# draw(anno, test = "month names")
# anno = anno_text(month.name, gp = gpar(fontsize = 16))
# draw(anno, test = "month names with fontsize")
# anno = anno_text(month.name, gp = gpar(fontsize = 1:12+4))
# draw(anno, test = "month names with changing fontsize")
# anno = anno_text(month.name, which = "row")
# draw(anno, test = "month names on rows")
# anno = anno_text(month.name, location = 0, rot = 45,
# just = "left", gp = gpar(col = 1:12))
# draw(anno, test = "with rotations")
# anno = anno_text(month.name, location = 1,
# rot = 45, just = "right", gp = gpar(fontsize = 1:12+4))
# draw(anno, test = "with rotations")
anno_text = function(x, which = c("column", "row"), gp = gpar(),
rot = guess_rot(), just = guess_just(),
offset = guess_location(), location = guess_location(),
width = NULL, height = NULL) {
ef = function() NULL
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
dev.null()
ef = dev.off2
} else {
which = .ENV$current_annotation_which
}
on.exit(ef())
n = length(x)
gp = recycle_gp(gp, n)
guess_rot = function() {
ifelse(which == "column", 90, 0)
}
guess_just = function() {
ifelse(which == "column", "right", "left")
}
guess_location = function() {
unit(ifelse(which == "column", 1, 0), "npc")
}
rot = rot[1] %% 360
just = just[1]
if(!missing(offset)) {
warning_wrap("`offset` is deprecated, use `location` instead.")
if(missing(location)) {
location = offset
}
}
location = location[1]
if(!inherits(location, "unit")) {
location = unit(location, "npc")
}
if(which == "column") {
if("right" %in% just) {
if(rot < 180) {
location = location - 0.5*grobHeight(textGrob("A", gp = gp))*abs(cos(rot/180*pi))
} else {
location = location + 0.5*grobHeight(textGrob("A", gp = gp))*abs(cos(rot/180*pi))
}
} else if("left" %in% just) {
if(rot < 180) {
location = location + 0.5*grobHeight(textGrob("A", gp = gp))*abs(cos(rot/180*pi))
} else {
location = location - 0.5*grobHeight(textGrob("A", gp = gp))*abs(cos(rot/180*pi))
}
}
}
if(which == "column") {
if(missing(height)) {
height = max_text_width(x, gp = gp)*abs(sin(rot/180*pi)) + grobHeight(textGrob("A", gp = gp))*abs(cos(rot/180*pi))
height = convertHeight(height, "mm")
}
if(missing(width)) {
width = unit(1, "npc")
}
}
if(which == "row") {
if(missing(width)) {
width = max_text_width(x, gp = gp)*abs(cos(rot/180*pi)) + grobHeight(textGrob("A", gp = gp))*abs(sin(rot/180*pi))
width = convertWidth(width, "mm")
}
if(missing(height)) {
height = unit(1, "npc")
}
}
anno_size = list(width = width, height = height)
value = x
row_fun = function(index) {
n = length(index)
gp = subset_gp(gp, index)
gp2 = gp
if("border" %in% names(gp2)) gp2$col = gp2$border
if("fill" %in% names(gp2)) {
if(!"border" %in% names(gp2)) gp2$col = gp2$fill
}
if(any(c("border", "fill") %in% names(gp2))) {
grid.rect(y = (n - seq_along(index) + 0.5)/n, height = 1/n, gp = gp2)
}
grid.text(value[index], location, (n - seq_along(index) + 0.5)/n, gp = gp, just = just, rot = rot)
}
column_fun = function(index, k = NULL, N = NULL, vp_name = NULL) {
n = length(index)
gp = subset_gp(gp, index)
gp2 = gp
if("border" %in% names(gp2)) gp2$col = gp2$border
if("fill" %in% names(gp2)) {
if(!"border" %in% names(gp2)) gp2$col = gp2$fill
}
if(any(c("border", "fill") %in% names(gp2))) {
grid.rect(x = (seq_along(index) - 0.5)/n, width = 1/n, gp = gp2)
}
grid.text(value[index], (seq_along(index) - 0.5)/n, location, gp = gp, just = just, rot = rot)
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_text",
which = which,
width = width,
height = height,
n = n,
var_import = list(value, gp, just, rot, location),
show_name = FALSE
)
anno@subset_rule$value = subset_vector
anno@subset_rule$gp = subset_gp
anno@subsetable = TRUE
return(anno)
}
# == title
# Joyplot Annotation
#
# == param
# -x A matrix or a list. If ``x`` is a matrix or a data frame, columns correspond to observations.
# -which Whether it is a column annotation or a row annotation?
# -gp Graphic parameters for the boxes. The length of the graphic parameters should be one or the number of observations.
# -scale Relative height of the curve. A value higher than 1 increases the height of the curve.
# -transparency Transparency of the filled colors. Value should be between 0 and 1.
# -axis Whether to add axis?
# -axis_param parameters for controlling axis. See `default_axis_param` for all possible settings and default parameters.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#joyplot-annotation
#
# == example
# m = matrix(rnorm(1000), nc = 10)
# lt = apply(m, 2, function(x) data.frame(density(x)[c("x", "y")]))
# anno = anno_joyplot(lt, width = unit(4, "cm"), which = "row")
# draw(anno, test = "joyplot")
# anno = anno_joyplot(lt, width = unit(4, "cm"), which = "row", gp = gpar(fill = 1:10))
# draw(anno, test = "joyplot + col")
# anno = anno_joyplot(lt, width = unit(4, "cm"), which = "row", scale = 1)
# draw(anno, test = "joyplot + scale")
#
# m = matrix(rnorm(5000), nc = 50)
# lt = apply(m, 2, function(x) data.frame(density(x)[c("x", "y")]))
# anno = anno_joyplot(lt, width = unit(4, "cm"), which = "row", gp = gpar(fill = NA), scale = 4)
# draw(anno, test = "joyplot")
anno_joyplot = function(x, which = c("column", "row"), gp = gpar(fill = "#000000"),
scale = 2, transparency = 0.6,
axis = TRUE, axis_param = default_axis_param(which),
width = NULL, height = NULL) {
ef = function() NULL
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
dev.null()
ef = dev.off2
} else {
which = .ENV$current_annotation_which
}
on.exit(ef())
anno_size = anno_width_and_height(which, width, height, unit(4, "cm"))
## convert matrix all to list (or data frame)
if(is.matrix(x) || is.data.frame(x)) {
value = vector("list", ncol(x))
for(i in seq_len(ncol(x))) {
value[[i]] = cbind(seq_len(nrow(x)), x[, i])
}
} else if(inherits(x, "list")){
if(all(sapply(x, is.atomic))) {
if(length(unique(sapply(x, length))) == 1) {
value = vector("list", length(x))
for(i in seq_len(length(x))) {
value[[i]] = cbind(seq_along(x[[i]]), x[[i]])
}
} else {
stop_wrap("Since x is a list, x need to be a list of two-column matrices.")
}
} else {
value = x
}
} else {
stop_wrap("The input should be a list of two-column matrices or a matrix/data frame.")
}
xscale = range(lapply(value, function(x) x[, 1]), na.rm = TRUE)
xscale = xscale + c(-0.05, 0.05)*(xscale[2] - xscale[1])
yscale = range(lapply(value, function(x) x[, 2]), na.rm = TRUE)
yscale[1] = 0
yscale[2] = yscale[2]*1.05
n = length(value)
if(!"fill" %in% names(gp)) {
gp$fill = "#000000"
}
gp = recycle_gp(gp, n)
gp$fill = add_transparency(gp$fill, transparency)
axis_param = validate_axis_param(axis_param, which)
axis_grob = if(axis) construct_axis_grob(axis_param, which, xscale) else NULL
row_fun = function(index, k = 1, N = 1) {
n_all = length(value)
value = value[index]
n = length(index)
gp = subset_gp(gp, index)
for(i in seq_len(n)) {
pushViewport(viewport(x = unit(0, "npc"), y = unit((n-i)/n, "npc"),
just = c("left", "bottom"), height = unit(1/n, "npc"), xscale = xscale,
yscale = yscale))
x0 = value[[i]][, 1]
y0 = value[[i]][, 2]*scale
x0 = c(x0[1], x0, x0[length(x0)])
y0 = c(0, y0, 0)
gppp = subset_gp(gp, i); gppp$col = NA
grid.polygon(x = x0, y = y0, default.units = "native", gp = gppp)
grid.lines(x = x0, y = y0, default.units = "native",
gp = subset_gp(gp, i))
popViewport()
}
pushViewport(viewport(xscale = xscale))
if(axis_param$side == "top") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "bottom") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
popViewport()
}
column_fun = function(index, k = 1, N = 1) {
n_all = length(value)
value = value[index]
foo = yscale
yscale = xscale
xscale = foo
n = length(index)
gp = subset_gp(gp, index)
for(i in seq_len(n)) {
pushViewport(viewport(y = unit(0, "npc"), x = unit(i/n, "npc"),
width = unit(1/n, "npc"), just = c("right", "bottom"), xscale = xscale,
yscale = yscale))
x0 = value[[i]][, 2]*scale
y0 = value[[i]][ ,1]
x0 = c(0, x0, 0)
y0 = c(y0[1], y0, y0[length(y0)])
gppp = subset_gp(gp, i); gppp$col = NA
grid.polygon(y = y0, x = x0, default.units = "native", gp = gppp)
grid.lines(y = y0, x = x0, default.units = "native",
gp = subset_gp(gp, i))
popViewport()
}
pushViewport(viewport(yscale = yscale))
if(axis_param$side == "left") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "right") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
popViewport()
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_joyplot",
which = which,
width = anno_size$width,
height = anno_size$height,
n = n,
data_scale = xscale,
var_import = list(value, gp, axis, axis_param, axis_grob, scale, yscale, xscale)
)
anno@subset_rule$value = subset_vector
anno@subset_rule$gp = subset_gp
anno@subsetable = TRUE
anno@extended = update_anno_extend(anno, axis_grob, axis_param)
return(anno)
}
# == title
# Horizon chart Annotation
#
# == param
# -x A matrix or a list. If ``x`` is a matrix or a data frame, columns correspond to observations.
# -which Whether it is a column annotation or a row annotation?
# -gp Graphic parameters for the boxes. The length of the graphic parameters should be one or the number of observations.
# There are two unstandard parameters specificly for horizon chart: ``pos_fill`` and ``neg_fill`` controls the filled
# color for positive values and negative values.
# -n_slice Number of slices on y-axis.
# -slice_size Height of the slice. If the value is not ``NULL``, ``n_slice`` will be recalculated.
# -negative_from_top Whether the areas for negative values start from the top or the bottom of the plotting region?
# -normalize Whether normalize ``x`` by max(abs(x)).
# -gap Gap size of neighbouring horizon chart.
# -axis Whether to add axis?
# -axis_param parameters for controlling axis. See `default_axis_param` for all possible settings and default parameters.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
#
# == detail
# Horizon chart as row annotation is only supported.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#horizon-chart-annotation
#
# == example
# lt = lapply(1:20, function(x) cumprod(1 + runif(1000, -x/100, x/100)) - 1)
# anno = anno_horizon(lt, which = "row")
# draw(anno, test = "horizon chart")
# anno = anno_horizon(lt, which = "row",
# gp = gpar(pos_fill = "orange", neg_fill = "darkgreen"))
# draw(anno, test = "horizon chart, col")
# anno = anno_horizon(lt, which = "row", negative_from_top = TRUE)
# draw(anno, test = "horizon chart + negative_from_top")
# anno = anno_horizon(lt, which = "row", gap = unit(1, "mm"))
# draw(anno, test = "horizon chart + gap")
# anno = anno_horizon(lt, which = "row",
# gp = gpar(pos_fill = rep(c("orange", "red"), each = 10),
# neg_fill = rep(c("darkgreen", "blue"), each = 10)))
# draw(anno, test = "horizon chart, col")
anno_horizon = function(x, which = c("column", "row"),
gp = gpar(pos_fill = "#D73027", neg_fill = "#313695"),
n_slice = 4, slice_size = NULL, negative_from_top = FALSE,
normalize = TRUE, gap = unit(0, "mm"),
axis = TRUE, axis_param = default_axis_param(which),
width = NULL, height = NULL) {
ef = function() NULL
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
dev.null()
ef = dev.off2
} else {
which = .ENV$current_annotation_which
}
on.exit(ef())
anno_size = anno_width_and_height(which, width, height, unit(4, "cm"))
## convert matrix all to list (or data frame)
if(is.matrix(x) || is.data.frame(x)) {
value = vector("list", ncol(x))
for(i in seq_len(ncol(x))) {
value[[i]] = cbind(seq_len(nrow(x)), x[, i])
}
} else if(inherits(x, "list")){
if(all(sapply(x, is.atomic))) {
if(length(unique(sapply(x, length))) == 1) {
value = vector("list", length(x))
for(i in seq_len(length(x))) {
value[[i]] = cbind(seq_along(x[[i]]), x[[i]])
}
} else {
stop_wrap("Since x is a list, x need to be a list of two-column matrices.")
}
} else {
value = x
}
} else {
stop_wrap("The input should be a list of two-column matrices or a matrix/data frame.")
}
if(is.null(gp$pos_fill)) gp$pos_fill = "#D73027"
if(is.null(gp$neg_fill)) gp$neg_fill = "#313695"
if("fill" %in% names(gp)) {
foo = unlist(lapply(value, function(x) x[, 2]))
if(all(foo >= 0)) {
gp$pos_fill = gp$fill
} else if(all(foo <= 0)) {
gp$neg_fill = gp$fill
} else {
gp = gpar(pos_fill = "#D73027", neg_fill = "#313695")
}
}
if(which == "column") {
stop_wrap("anno_horizon() does not support column annotation.")
}
if(normalize) {
value = lapply(value, function(m) {
m[, 2] = m[, 2]/max(abs(m[, 2]))
m
})
}
n = length(value)
xscale = range(lapply(value, function(x) x[, 1]), na.rm = TRUE)
yscale = range(lapply(value, function(x) abs(x[, 2])), na.rm = TRUE)
axis_param = validate_axis_param(axis_param, which)
axis_grob = if(axis) construct_axis_grob(axis_param, which, xscale) else NULL
row_fun = function(index, k = 1, N = 1) {
n_all = length(value)
value = value[index]
if(is.null(slice_size)) {
slice_size = yscale[2]/n_slice
}
n_slice = ceiling(yscale[2]/slice_size)
n = length(index)
gp = subset_gp(gp, index)
for(i in seq_len(n)) {
pushViewport(viewport(x = unit(0, "npc"), y = unit((n-i)/n, "npc"), just = c("left", "bottom"),
height = unit(1/n, "npc") - gap))
sgp = subset_gp(gp, i)
horizon_chart(value[[i]][, 1], value[[i]][, 2], n_slice = n_slice, slice_size = slice_size,
negative_from_top = negative_from_top, pos_fill = sgp$pos_fill, neg_fill = sgp$neg_fill)
grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
pushViewport(viewport(xscale = xscale))
if(axis_param$side == "top") {
if(k > 1) axis = FALSE
} else if(axis_param$side == "bottom") {
if(k < N) axis = FALSE
}
if(axis) grid.draw(axis_grob)
popViewport()
}
column_fun = function(index) {
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_horizon",
which = which,
width = anno_size$width,
height = anno_size$height,
n = n,
data_scale = xscale,
var_import = list(value, gp, axis, axis_param, axis_grob, n_slice, slice_size,
negative_from_top, xscale, yscale, gap)
)
anno@subset_rule$value = subset_vector
anno@subset_rule$gp = subset_gp
anno@subsetable = TRUE
anno@extended = update_anno_extend(anno, axis_grob, axis_param)
return(anno)
}
horizon_chart = function(x, y, n_slice = 4, slice_size, pos_fill = "#D73027", neg_fill = "#313695",
negative_from_top = FALSE) {
if(missing(slice_size)) {
slice_size = max(abs(y))/n_slice
}
n_slice = ceiling(max(abs(y))/slice_size)
if(n_slice == 0) {
return(invisible(NULL))
}
pos_col_fun = colorRamp2(c(0, n_slice), c("white", pos_fill))
neg_col_fun = colorRamp2(c(0, n_slice), c("white", neg_fill))
pushViewport(viewport(xscale = range(x), yscale = c(0, slice_size)))
for(i in seq_len(n_slice)) {
l1 = y >= (i-1)*slice_size & y < i*slice_size
l2 = y < (i-1)*slice_size
l3 = y >= i*slice_size
if(any(l1)) {
x2 = x
y2 = y
y2[l1] = y2[l1] - slice_size*(i-1)
y2[l3] = slice_size
x2[l2] = NA
y2[l2] = NA
add_horizon_polygon(x2, y2, gp = gpar(fill = pos_col_fun(i), col = NA),
default.units = "native")
}
}
y = -y
for(i in seq_len(n_slice)) {
l1 = y >= (i-1)*slice_size & y < i*slice_size
l2 = y < (i-1)*slice_size
l3 = y >= i*slice_size
if(any(l1)) {
x2 = x
y2 = y
y2[l1] = y2[l1] - slice_size*(i-1)
y2[l3] = slice_size
x2[l2] = NA
y2[l2] = NA
add_horizon_polygon(x2, y2, slice_size = slice_size, from_top = negative_from_top,
gp = gpar(fill = neg_col_fun(i), col = NA), default.units = "native")
}
}
popViewport()
}
# x and y may contain NA, split x and y by NA gaps, align the bottom to y = 0
add_horizon_polygon = function(x, y, slice_size = NULL, from_top = FALSE, ...) {
ltx = split_vec_by_NA(x)
lty = split_vec_by_NA(y)
for(i in seq_along(ltx)) {
x0 = ltx[[i]]
y0 = lty[[i]]
if(from_top) {
x0 = c(x0[1], x0, x0[length(x0)])
y0 = c(slice_size, slice_size - y0, slice_size)
} else {
x0 = c(x0[1], x0, x0[length(x0)])
y0 = c(0, y0, 0)
}
grid.polygon(x0, y0, ...)
}
}
# https://stat.ethz.ch/pipermail/r-help/2010-April/237031.html
split_vec_by_NA = function(x) {
idx = 1 + cumsum(is.na(x))
not.na = !is.na(x)
split(x[not.na], idx[not.na])
}
# == title
# Points as Row Annotation
#
# == param
# -... pass to `anno_points`.
#
# == details
# A wrapper of `anno_points` with pre-defined ``which`` to ``row``.
#
# You can directly use `anno_points` for row annotation if you call it in `rowAnnotation`.
#
# == value
# See help page of `anno_points`.
#
row_anno_points = function(...) {
if(exists(".__under_SingleAnnotation__", envir = parent.frame())) {
message_wrap("From version 1.99.0, you can directly use `anno_points()` for row annotation if you call it in `rowAnnotation()`.")
}
anno_points(..., which = "row")
}
# == title
# Barplots as Row Annotation
#
# == param
# -... pass to `anno_barplot`.
#
# == details
# A wrapper of `anno_barplot` with pre-defined ``which`` to ``row``.
#
# You can directly use `anno_barplot` for row annotation if you call it in `rowAnnotation`.
#
# == value
# See help page of `anno_barplot`.
#
row_anno_barplot = function(...) {
if(exists(".__under_SingleAnnotation__", envir = parent.frame())) {
message_wrap("From version 1.99.0, you can directly use `anno_barplot()` for row annotation if you call it in `rowAnnotation()`.")
}
anno_barplot(..., which = "row")
}
# == title
# Boxplots as Row Annotation
#
# == param
# -... pass to `anno_boxplot`.
#
# == details
# A wrapper of `anno_boxplot` with pre-defined ``which`` to ``row``.
#
# You can directly use `anno_boxplot` for row annotation if you call it in `rowAnnotation`.
#
# == value
# See help page of `anno_boxplot`.
#
row_anno_boxplot = function(...) {
if(exists(".__under_SingleAnnotation__", envir = parent.frame())) {
message_wrap("From version 1.99.0, you can directly use `anno_boxplot()` for row annotation if you call it in `rowAnnotation()`.")
}
anno_boxplot(..., which = "row")
}
# == title
# Histograms as Row Annotation
#
# == param
# -... pass to `anno_histogram`.
#
# == details
# A wrapper of `anno_histogram` with pre-defined ``which`` to ``row``.
#
# You can directly use `anno_histogram` for row annotation if you call it in `rowAnnotation`.
#
# == value
# See help page of `anno_histogram`.
#
row_anno_histogram = function(...) {
if(exists(".__under_SingleAnnotation__", envir = parent.frame())) {
message_wrap("From version 1.99.0, you can directly use `anno_histogram()` for row annotation if you call it in `rowAnnotation()`.")
}
anno_histogram(..., which = "row")
}
# == title
# Density as Row Annotation
#
# == param
# -... pass to `anno_density`.
#
# == details
# A wrapper of `anno_density` with pre-defined ``which`` to ``row``.
#
# You can directly use `anno_density` for row annotation if you call it in `rowAnnotation`.
#
# == value
# See help page of `anno_density`.
#
row_anno_density = function(...) {
if(exists(".__under_SingleAnnotation__", envir = parent.frame())) {
message_wrap("From version 1.99.0, you can directly use `anno_density()` for row annotation if you call it in `rowAnnotation()`.")
}
anno_density(..., which = "row")
}
# == title
# Text as Row Annotation
#
# == param
# -... pass to `anno_text`.
#
# == details
# A wrapper of `anno_text` with pre-defined ``which`` to ``row``.
#
# You can directly use `anno_text` for row annotation if you call it in `rowAnnotation`.
#
# == value
# See help page of `anno_text`.
#
row_anno_text = function(...) {
if(exists(".__under_SingleAnnotation__", envir = parent.frame())) {
message_wrap("From version 1.99.0, you can directly use `anno_text()` for row annotation if you call it in `rowAnnotation()`.")
}
anno_text(..., which = "row")
}
# == title
# Link annotation with labels
#
# == param
# -at Numeric index from the original matrix.
# -labels Corresponding labels.
# -which Whether it is a column annotation or a row annotation?
# -side Side of the labels. If it is a column annotation, valid values are "top" and "bottom";
# If it is a row annotation, valid values are "left" and "right".
# -lines_gp Please use ``link_gp`` instead.
# -link_gp Graphic settings for the segments.
# -labels_gp Graphic settings for the labels.
# -padding Padding between neighbouring labels in the plot.
# -link_width Width of the segments.
# -link_height Similar as ``link_width``, used for column annotation.
# -extend By default, the region for the labels has the same width (if it is a column annotation) or
# same height (if it is a row annotation) as the heatmap. The size can be extended by this options.
# The value can be a proportion number or a `grid::unit` object. The length can be either one or two.
#
# == details
# Sometimes there are many rows or columns in the heatmap and we want to mark some of the rows.
# This annotation function is used to mark these rows and connect labels and corresponding rows
# with links.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#mark-annotation
#
# == example
# anno = anno_mark(at = c(1:4, 20, 60, 97:100), labels = month.name[1:10], which = "row")
# draw(anno, index = 1:100, test = "anno_mark")
#
# m = matrix(1:1000, byrow = TRUE, nr = 100)
# anno = anno_mark(at = c(1:4, 20, 60, 97:100), labels = month.name[1:10], which = "row")
# Heatmap(m, cluster_rows = FALSE, cluster_columns = FALSE) + rowAnnotation(mark = anno)
# Heatmap(m) + rowAnnotation(mark = anno)
anno_mark = function(at, labels, which = c("column", "row"),
side = ifelse(which == "column", "top", "right"),
lines_gp = gpar(), labels_gp = gpar(), padding = 0.5,
link_width = unit(5, "mm"), link_height = link_width,
link_gp = lines_gp,
extend = unit(0, "mm")) {
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
} else {
which = .ENV$current_annotation_which
}
if(!is.numeric(at)) {
stop_wrap(paste0("`at` should be numeric ", which, " index corresponding to the matrix."))
}
n = length(at)
link_gp = recycle_gp(link_gp, n)
labels_gp = recycle_gp(labels_gp, n)
labels2index = structure(seq_along(at), names = labels)
at2labels = structure(labels, names = at)
if(length(extend) == 1) extend = rep(extend, 2)
if(length(extend) > 2) extend = extend[1:2]
if(!inherits(extend, "unit")) extend = unit(extend, "npc")
if(which == "row") {
height = unit(1, "npc")
width = link_width + max_text_width(labels, gp = labels_gp)
} else {
height = link_width + max_text_width(labels, gp = labels_gp)
width = unit(1, "npc")
}
.pos = NULL
.scale = NULL
# a map between row index and positions
# pos_map =
row_fun = function(index) {
n = length(index)
# adjust at and labels
at = intersect(index, at)
if(length(at) == 0) {
return(NULL)
}
labels = rev(at2labels[as.character(at)])
labels_gp = subset_gp(labels_gp, labels2index[labels])
link_gp = subset_gp(link_gp, labels2index[labels])
if(is.null(.scale)) {
.scale = c(0.5, n+0.5)
}
pushViewport(viewport(xscale = c(0, 1), yscale = .scale))
if(inherits(extend, "unit")) extend = convertHeight(extend, "native", valueOnly = TRUE)
text_height = convertHeight(grobHeight(textGrob(labels, gp = labels_gp))*(1+padding), "native", valueOnly = TRUE)
if(is.null(.pos)) {
i2 = rev(which(index %in% at))
pos = n-i2+1 # position of rows
} else {
pos = .pos[rev(which(index %in% at))]
}
h1 = pos - text_height*0.5
h2 = pos + text_height*0.5
pos_adjusted = smartAlign(h1, h2, c(.scale[1] - extend[1], .scale[2] + extend[2]))
h = (pos_adjusted[, 1] + pos_adjusted[, 2])/2
n2 = length(labels)
if(side == "right") {
grid.text(labels, rep(link_width, n2), h, default.units = "native", gp = labels_gp, just = "left")
link_width = link_width - unit(1, "mm")
grid.segments(unit(rep(0, n2), "npc"), pos, rep(link_width*(1/3), n2), pos, default.units = "native", gp = link_gp)
grid.segments(rep(link_width*(1/3), n2), pos, rep(link_width*(2/3), n2), h, default.units = "native", gp = link_gp)
grid.segments(rep(link_width*(2/3), n2), h, rep(link_width, n2), h, default.units = "native", gp = link_gp)
} else {
grid.text(labels, unit(1, "npc")-rep(link_width, n2), h, default.units = "native", gp = labels_gp, just = "right")
link_width = link_width - unit(1, "mm")
grid.segments(unit(rep(1, n2), "npc"), pos, unit(1, "npc")-rep(link_width*(1/3), n2), pos, default.units = "native", gp = link_gp)
grid.segments(unit(1, "npc")-rep(link_width*(1/3), n2), pos, unit(1, "npc")-rep(link_width*(2/3), n2), h, default.units = "native", gp = link_gp)
grid.segments(unit(1, "npc")-rep(link_width*(2/3), n2), h, unit(1, "npc")-rep(link_width, n2), h, default.units = "native", gp = link_gp)
}
upViewport()
}
column_fun = function(index) {
n = length(index)
# adjust at and labels
at = intersect(index, at)
if(length(at) == 0) {
return(NULL)
}
labels = at2labels[as.character(at)]
labels_gp = subset_gp(labels_gp, labels2index[labels])
link_gp = subset_gp(link_gp, labels2index[labels])
if(is.null(.scale)) {
.scale = c(0.5, n+0.5)
}
pushViewport(viewport(yscale = c(0, 1), xscale = .scale))
if(inherits(extend, "unit")) extend = convertWidth(extend, "native", valueOnly = TRUE)
text_height = convertWidth(grobHeight(textGrob(labels, gp = labels_gp))*(1+padding), "native", valueOnly = TRUE)
if(is.null(.pos)) {
i2 = which(index %in% at)
pos = i2 # position of rows
} else {
pos = .pos[which(index %in% at)]
}
h1 = pos - text_height*0.5
h2 = pos + text_height*0.5
pos_adjusted = smartAlign(h1, h2, c(.scale[1] - extend[1], .scale[2] + extend[2]))
h = (pos_adjusted[, 1] + pos_adjusted[, 2])/2
n2 = length(labels)
if(side == "top") {
grid.text(labels, h, rep(link_height, n2), default.units = "native", gp = labels_gp, rot = 90, just = "left")
link_height = link_height - unit(1, "mm")
grid.segments(pos, unit(rep(0, n2), "npc"), pos, rep(link_height*(1/3), n2), default.units = "native", gp = link_gp)
grid.segments(pos, rep(link_height*(1/3), n2), h, rep(link_height*(2/3), n2), default.units = "native", gp = link_gp)
grid.segments(h, rep(link_height*(2/3), n2), h, rep(link_height, n), default.units = "native", gp = link_gp)
} else {
grid.text(labels, h, rep(max_text_width(labels, gp = labels_gp), n2), default.units = "native", gp = labels_gp, rot = 90, just = "right")
link_height = link_height - unit(1, "mm")
grid.segments(pos, unit(rep(1, n2), "npc"), pos, unit(1, "npc")-rep(link_height*(1/3), n2), default.units = "native", gp = link_gp)
grid.segments(pos, unit(1, "npc")-rep(link_height*(1/3), n2), h, unit(1, "npc")-rep(link_height*(2/3), n2), default.units = "native", gp = link_gp)
grid.segments(h, unit(1, "npc")-rep(link_height*(2/3), n2), h, unit(1, "npc")-rep(link_height, n2), default.units = "native", gp = link_gp)
}
upViewport()
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_mark",
which = which,
width = width,
height = height,
n = -1,
var_import = list(at, labels2index, at2labels, link_gp, labels_gp, padding, .pos, .scale,
side, link_width, link_height, extend),
show_name = FALSE
)
anno@subset_rule$at = subset_by_intersect
anno@subsetable = TRUE
return(anno)
}
subset_by_intersect = function(x, i) {
intersect(x, i)
}
# == title
# Label Markers Annotation
#
# == param
# -... Pass to `anno_mark`.
#
# == details
# `anno_link` is deprecated, please use `anno_mark` instead.
#
anno_link = function(...) {
warning_wrap("anno_link() is deprecated, please use anno_mark() instead.")
anno_mark(...)
}
# == title
# Label Markers as Row Annotation
#
# == param
# -... pass to `anno_link`.
#
# == details
# A wrapper of `anno_link` with pre-defined ``which`` to ``row``.
#
# You can directly use `anno_link` for row annotation if you call it in `rowAnnotation`.
#
# == value
# See help page of `anno_link`.
#
row_anno_link = function(...) {
if(exists(".__under_SingleAnnotation__", envir = parent.frame())) {
message_wrap("From version 1.99.0, you can directly use `anno_mark()` for row annotation if you call it in `rowAnnotation()`.")
}
anno_link(..., which = "row")
}
# == title
# Summary Annotation
#
# == param
# -which Whether it is a column annotation or a row annotation?
# -border Wether draw borders of the annotation region?
# -bar_width Relative width of the bars. The value should be smaller than one.
# -axis Whether to add axis?
# -axis_param parameters for controlling axis. See `default_axis_param` for all possible settings and default parameters.
# -ylim Data ranges. ``ylim`` for barplot is enforced to be ``c(0, 1)``.
# -extend The extension to both side of ``ylim``. The value is a percent value corresponding to ``ylim[2] - ylim[1]``. This argument is only for boxplot.
# -outline Whether draw outline of boxplots?
# -box_width Relative width of boxes. The value should be smaller than one.
# -pch Point style.
# -size Point size.
# -gp Graphic parameters.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
#
# == detail
# ``anno_summary`` is a special annotation function that it only works for one-column or one-row heatmap.
# It shows the summary of the values in the heatmap. If the values in the heatmap is discrete,
# the proportion of each level (the sum is normalized to 1) is visualized as stacked barplot. If the heatmap
# is split into multiple slices, multiple bars are put in the annotation. If the value is continuous, boxplot is used.
#
# In the barplot, the color schema is used as the same as the heatmap, while for the boxplot, the color needs
# to be controlled by ``gp``.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#summary-annotation
#
# == example
# ha = HeatmapAnnotation(summary = anno_summary(height = unit(4, "cm")))
# v = sample(letters[1:2], 50, replace = TRUE)
# split = sample(letters[1:2], 50, replace = TRUE)
# Heatmap(v, top_annotation = ha, width = unit(1, "cm"), split = split)
#
# ha = HeatmapAnnotation(summary = anno_summary(gp = gpar(fill = 2:3), height = unit(4, "cm")))
# v = rnorm(50)
# Heatmap(v, top_annotation = ha, width = unit(1, "cm"), split = split)
#
anno_summary = function(which = c("column", "row"), border = TRUE, bar_width = 0.8,
axis = TRUE, axis_param = default_axis_param(which),
ylim = NULL, extend = 0.05, outline = TRUE, box_width = 0.6,
pch = 1, size = unit(2, "mm"), gp = gpar(),
width = NULL, height = NULL) {
ef = function() NULL
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
dev.null()
ef = dev.off2
} else {
which = .ENV$current_annotation_which
}
on.exit(ef())
anno_size = anno_width_and_height(which, width, height, unit(2, "cm"))
axis_param = validate_axis_param(axis_param, which)
if(is.null(ylim)) {
axis_grob = if(axis) construct_axis_grob(axis_param, which, c(0, 1)) else NULL
} else {
axis_grob = if(axis) construct_axis_grob(axis_param, which, ylim) else NULL
}
row_fun = function(index) {
ht = get("object", envir = parent.frame(7))
mat = ht@matrix
cm = ht@matrix_color_mapping
order_list = ht@column_order_list
ng = length(order_list)
if(cm@type == "discrete") {
tl = lapply(order_list, function(od) table(mat[1, od]))
tl = lapply(tl, function(x) x/sum(x))
pushViewport(viewport(yscale = c(0.5, ng+0.5), xscale = c(0, 1)))
for(i in 1:ng) {
x = i
y = cumsum(tl[[i]])
grid.rect(y, x, height = bar_width, width = tl[[i]], just = "right", gp = gpar(fill = map_to_colors(cm, names(y))), default.units = "native")
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
} else {
}
}
column_fun = function(index) {
ht = get("object", envir = parent.frame(7))
mat = ht@matrix
cm = ht@matrix_color_mapping
order_list = ht@row_order_list
ng = length(order_list)
if(cm@type == "discrete") {
if(!is.null(ylim)) {
stop_wrap("For discrete matrix, `ylim` is not allowed to set. It is always c(0, 1).")
}
tl = lapply(order_list, function(od) table(mat[od, 1]))
tl = lapply(tl, function(x) x/sum(x))
pushViewport(viewport(xscale = c(0.5, ng+0.5), yscale = c(0, 1)))
for(i in 1:ng) {
x = i
y = cumsum(tl[[i]])
grid.rect(x, y, width = bar_width, height = tl[[i]], just = "top", gp = gpar(fill = map_to_colors(cm, names(y))), default.units = "native")
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
} else {
vl = lapply(order_list, function(od) mat[od, 1])
nv = length(vl)
if(is.null(ylim)) {
if(!outline) {
boxplot_stats = boxplot(vl, plot = FALSE)$stats
data_scale = range(boxplot_stats)
} else {
data_scale = range(vl, na.rm = TRUE)
}
} else {
data_scale = ylim
}
data_scale = data_scale + c(-extend, extend)*(data_scale[2] - data_scale[1])
if(is.null(ylim)) {
axis_param = validate_axis_param(axis_param, which)
axis_grob = if(axis) construct_axis_grob(axis_param, which, data_scale) else NULL
}
gp = recycle_gp(gp, nv)
if(length(pch) == 1) pch = rep(pch, nv)
if(length(size) == 1) size = rep(size, nv)
pushViewport(viewport(xscale = c(0.5, ng+0.5), yscale = data_scale))
for(i in 1:ng) {
x = i
v = vl[[i]]
grid.boxplot(v, pos = x, box_width = box_width, gp = subset_gp(gp, i),
pch = pch, size = size, outline = outline)
}
if(axis) grid.draw(axis_grob)
if(border) grid.rect(gp = gpar(fill = "transparent"))
popViewport()
}
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_summary",
which = which,
width = width,
height = height,
var_import = list(bar_width, border, axis, axis_grob, axis_param, which, ylim, extend,
outline, box_width, pch, size, gp),
n = 1,
show_name = FALSE
)
anno@subsetable = FALSE
anno@extended = update_anno_extend(anno, axis_grob, axis_param)
return(anno)
}
# == title
# Block annotation
#
# == param
# -gp Graphic parameters.
# -labels Labels put on blocks.
# -labels_gp Graphic parameters for labels.
# -labels_rot Rotation for labels.
# -which Is it a row annotation or a column annotation?
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
#
# == details
# The block annotation is used for representing slices. The length of all arguments should be 1 or the number of slices.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#block-annotation
#
# == example
# Heatmap(matrix(rnorm(100), 10),
# top_annotation = HeatmapAnnotation(foo = anno_block(gp = gpar(fill = 2:4),
# labels = c("group1", "group2", "group3"), labels_gp = gpar(col = "white"))),
# column_km = 3,
# left_annotation = rowAnnotation(foo = anno_block(gp = gpar(fill = 2:4),
# labels = c("group1", "group2", "group3"), labels_gp = gpar(col = "white"))),
# row_km = 3)
anno_block = function(gp = gpar(), labels = NULL, labels_gp = gpar(), labels_rot = ifelse(which == "row", 90, 0),
which = c("column", "row"), width = NULL, height = NULL) {
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
} else {
which = .ENV$current_annotation_which
}
if(length(labels)) {
if(which == "column") {
height = grobHeight(textGrob(labels, rot = labels_rot, gp = labels_gp))
height = height + unit(5, "mm")
} else {
width = grobWidth(textGrob(labels, rot = labels_rot, gp = labels_gp))
width = width + unit(5, "mm")
}
}
anno_size = anno_width_and_height(which, width, height, unit(5, "mm"))
fun = function(index, k, n) {
gp = subset_gp(recycle_gp(gp, n), k)
grid.rect(gp = gp)
if(length(labels)) {
if(length(labels) != n) {
stop_wrap("Length of `labels` should be as same as number of slices.")
}
label = labels[k]
labels_gp = subset_gp(recycle_gp(labels_gp, n), k)
grid.text(label, gp = labels_gp, rot = labels_rot)
}
}
anno = AnnotationFunction(
fun = fun,
n = NA,
fun_name = "anno_block",
which = which,
var_import = list(gp, labels, labels_gp, labels_rot),
subset_rule = list(),
subsetable = TRUE,
height = anno_size$height,
width = anno_size$width,
show_name = FALSE
)
return(anno)
}
# == title
# Zoom annotation
#
# == param
# -align_to It defines how the boxes correspond to the rows or the columns in the heatmap.
# If the value is a list of indices, each box corresponds to the rows or columns with indices
# in one vector in the list. If the value is a categorical variable (e.g. a factor or a character vector)
# that has the same length as the rows or columns in the heatmap, each box corresponds to the rows/columns
# in each level in the categorical variable.
# -panel_fun A self-defined function that defines how to draw graphics in the box. The function must have
# a ``index`` argument which is the indices for the rows/columns that the box corresponds to. It can
# have second argument ``nm`` which is the "name" of the selected part in the heatmap. The corresponding
# value for ``nm`` comes from ``align_to`` if it is specified as a categorical variable or a list with names.
# -which Whether it is a column annotation or a row annotation?
# -side Side of the boxes If it is a column annotation, valid values are "top" and "bottom";
# If it is a row annotation, valid values are "left" and "right".
# -size The size of boxes. It can be pure numeric that they are treated as relative fractions of the total
# height/width of the heatmap. The value of ``size`` can also be absolute units.
# -gap Gaps between boxes.
# -link_gp Graphic settings for the segments.
# -link_width Width of the segments.
# -link_height Similar as ``link_width``, used for column annotation.
# -extend By default, the region for the labels has the same width (if it is a column annotation) or
# same height (if it is a row annotation) as the heatmap. The size can be extended by this options.
# The value can be a proportion number or a `grid::unit` object. The length can be either one or two.
# -width Width of the annotation. The value should be an absolute unit. Width is not allowed to be set for column annotation.
# -height Height of the annotation. The value should be an absolute unit. Height is not allowed to be set for row annotation.
#
# == details
# `anno_zoom` creates several plotting regions (boxes) which can be corresponded to subsets of rows/columns in the
# heatmap.
#
# == value
# An annotation function which can be used in `HeatmapAnnotation`.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/heatmap-annotations.html#zoom-annotation
#
# == example
# set.seed(123)
# m = matrix(rnorm(100*10), nrow = 100)
# subgroup = sample(letters[1:3], 100, replace = TRUE, prob = c(1, 5, 10))
# rg = range(m)
# panel_fun = function(index, nm) {
# pushViewport(viewport(xscale = rg, yscale = c(0, 2)))
# grid.rect()
# grid.xaxis(gp = gpar(fontsize = 8))
# grid.boxplot(m[index, ], pos = 1, direction = "horizontal")
# grid.text(paste("distribution of group", nm), mean(rg), y = 1.9,
# just = "top", default.units = "native", gp = gpar(fontsize = 10))
# popViewport()
# }
# anno = anno_zoom(align_to = subgroup, which = "row", panel_fun = panel_fun,
# size = unit(2, "cm"), gap = unit(1, "cm"), width = unit(4, "cm"))
# Heatmap(m, right_annotation = rowAnnotation(foo = anno), row_split = subgroup)
#
anno_zoom = function(align_to, panel_fun = function(index, nm = NULL) { grid.rect() },
which = c("column", "row"), side = ifelse(which == "column", "top", "right"),
size = NULL, gap = unit(1, "mm"),
link_width = unit(5, "mm"), link_height = link_width, link_gp = gpar(),
extend = unit(0, "mm"), width = NULL, height = NULL) {
if(is.null(.ENV$current_annotation_which)) {
which = match.arg(which)[1]
} else {
which = .ENV$current_annotation_which
}
anno_size = anno_width_and_height(which, width, height, unit(2, "cm") + link_width)
# align_to should be
# 1. a vector of class labels that the length should be same as the nrow of the matrix
# 2. a list of numeric indices
if(is.list(align_to)) {
if(!any(sapply(align_to, is.numeric))) {
stop_wrap(paste0("`at` should be numeric ", which, " index corresponding to the matrix."))
}
}
.pos = NULL # position of the rows
if(length(as.list(formals(panel_fun))) == 1) {
formals(panel_fun) = alist(index = , nm = NULL)
}
if(length(extend) == 1) extend = rep(extend, 2)
if(length(extend) > 2) extend = extend[1:2]
if(!inherits(extend, "unit")) extend = unit(extend, "npc")
# anno_zoom is always executed in one-slice mode (which means mulitple slices
# are treated as one big slilce)
row_fun = function(index) {
n = length(index)
if(is.atomic(align_to)) {
if(length(setdiff(align_to, index)) == 0 && !any(duplicated(align_to))) {
align_to = list(align_to)
} else {
if(length(align_to) != n) {
stop_wrap("If `align_to` is a vector with group labels, the length should be the same as the number of rows in the heatmap.")
}
lnm = as.character(unique(align_to[index]))
align_to = as.list(tapply(seq_along(align_to), align_to, function(x) x))
align_to = align_to[lnm]
}
}
nrl = sapply(align_to, length)
align_to_df = lapply(align_to, function(x) {
ind = which(index %in% x)
n = length(ind)
s = NULL
e = NULL
s[1] = ind[1]
if(n > 1) {
ind2 = which(ind[2:n] - ind[1:(n-1)] > 1)
if(length(ind2)) s = c(s, ind[ ind2 + 1 ])
k = length(s)
e[k] = ind[length(ind)]
if(length(ind2)) e[1:(k-1)] = ind[1:(n-1)][ ind2 ]
} else {
e = ind[1]
}
data.frame(s = s, e = e)
})
# pos is from top to bottom
if(is.null(.pos)) {
pos = (n:1 - 0.5)/n # position of rows
} else {
pos = .pos
}
.scale = c(0, 1)
pushViewport(viewport(xscale = c(0, 1), yscale = .scale))
if(inherits(extend, "unit")) extend = convertHeight(extend, "native", valueOnly = TRUE)
# the position of boxes initially are put evenly
# add the gap
n_boxes = length(align_to)
if(length(gap) == 1) gap = rep(gap, n_boxes)
if(is.null(size)) size = nrl
if(length(size) == 1) size = rep(size, length(align_to))
if(length(size) != length(align_to)) {
stop_wrap("Length of `size` should be the same as the number of groups of indices.")
}
if(!inherits(size, "unit")) {
size_is_unit = FALSE
if(n_boxes == 1) {
h = data.frame(bottom = .scale[1] - extend[1], top = .scale[2] + extend[2])
} else {
gap = convertHeight(gap, "native", valueOnly = TRUE)
box_height = size/sum(size) * (1 + sum(extend) - sum(gap[1:(n_boxes-1)]))
h = data.frame(
top = cumsum(box_height) + cumsum(gap) - gap[length(gap)] - extend[1]
)
h$bottom = h$top - box_height
h = 1 - h[, 2:1]
colnames(h) = c("top", "bottom")
}
} else {
size_is_unit = TRUE
box_height = size
box_height2 = box_height # box_height2 adds the gap
for(i in 1:n_boxes) {
if(i == 1 || i == n_boxes) {
if(n_boxes > 1) {
box_height2[i] = box_height2[i] + gap[i]*0.5
}
} else {
box_height2[i] = box_height2[i] + gap[i]
}
}
box_height2 = convertHeight(box_height2, "native", valueOnly = TRUE)
# the original positions of boxes
mean_pos = sapply(align_to_df, function(df) mean((pos[df[, 1]] + pos[df[, 2]])/2))
h1 = mean_pos - box_height2*0.5
h2 = mean_pos + box_height2*0.5
h = smartAlign2(rev(h1), rev(h2), c(.scale[1] - extend[1], .scale[2] + extend[2]))
colnames(h) = c("bottom", "top")
h = h[nrow(h):1, , drop = FALSE]
# recalcualte h to remove gaps
gap_height = convertHeight(gap, "native", valueOnly = TRUE)
if(n_boxes > 1) {
for(i in 1:n_boxes) {
if(i == 1) {
h[i, "bottom"] = h[i, "bottom"] + gap_height[i]/2
} else if(i == n_boxes) {
h[i, "top"] = h[i, "top"] - gap_height[i]/2
} else {
h[i, "bottom"] = h[i, "bottom"] + gap_height[i]/2
h[i, "top"] = h[i, "top"] - gap_height[i]/2
}
}
}
}
popViewport()
# draw boxes
if(side == "right") {
pushViewport(viewport(x = link_width, just = "left", width = anno_size$width - link_width))
} else {
pushViewport(viewport(x = 0, just = "left", width = anno_size$width - link_width))
}
for(i in 1:n_boxes) {
current_vp_name = current.viewport()$name
pushViewport(viewport(y = (h[i, "top"] + h[i, "bottom"])/2, height = h[i, "top"] - h[i, "bottom"],
default.units = "native"))
if(is.function(panel_fun)) panel_fun(align_to[[i]], names(align_to)[i])
popViewport()
if(current.viewport()$name != current_vp_name) {
stop_wrap("If you push viewports `panel_fun`, you need to pop all them out.")
}
}
popViewport()
# draw the links
link_gp = recycle_gp(link_gp, n_boxes)
if(side == "right") {
pushViewport(viewport(x = unit(0, "npc"), just = "left", width = link_width))
} else {
pushViewport(viewport(x = unit(1, "npc"), just = "right", width = link_width))
}
for(i in 1:n_boxes) {
df = align_to_df[[i]]
for(j in 1:nrow(df)) {
# draw each polygon
if(side == "right") {
grid.polygon(unit.c(unit(c(0, 0), "npc"), rep(link_width, 2)),
c(pos[df[j, 2]] - 0.5/n, pos[df[j, 1]] + 0.5/n, h[i, "top"], h[i, "bottom"]),
default.units = "native", gp = subset_gp(link_gp, i))
} else {
grid.polygon(unit.c(rep(link_width, 2), unit(c(0, 0), "npc")),
c(pos[df[j, 2]] - 0.5/n, pos[df[j, 1]] + 0.5/n, h[i, "top"], h[i, "bottom"]),
default.units = "native", gp = subset_gp(link_gp, i))
}
}
}
popViewport()
}
column_fun = function(index) {
n = length(index)
if(is.atomic(align_to)) {
if(length(setdiff(align_to, index)) == 0 && !any(duplicated(align_to))) {
align_to = list(align_to)
} else {
if(length(align_to) != n) {
stop_wrap("If `align_to` is a vector with group labels, the length should be the same as the number of columns in the heatmap.")
}
lnm = as.character(unique(align_to[index]))
align_to = as.list(tapply(seq_along(align_to), align_to, function(x) x))
align_to = align_to[lnm]
}
}
nrl = sapply(align_to, length)
align_to_df = lapply(align_to, function(x) {
ind = which(index %in% x)
n = length(ind)
s = NULL
e = NULL
s[1] = ind[1]
if(n > 1) {
ind2 = which(ind[2:n] - ind[1:(n-1)] > 1)
if(length(ind2)) s = c(s, ind[ ind2 + 1 ])
k = length(s)
e[k] = ind[length(ind)]
if(length(ind2)) e[1:(k-1)] = ind[1:(n-1)][ ind2 ]
} else {
e = ind[1]
}
data.frame(s = s, e = e)
})
if(is.null(.pos)) {
pos = (1:n - 0.5)/n
} else {
pos = .pos
}
.scale = c(0, 1)
pushViewport(viewport(yscale = c(0, 1), xscale = .scale))
if(inherits(extend, "unit")) extend = convertWidth(extend, "native", valueOnly = TRUE)
# the position of boxes initially are put evenly
# add the gap
n_boxes = length(align_to)
if(length(gap) == 1) gap = rep(gap, n_boxes)
if(is.null(size)) size = nrl
if(length(size) == 1) size = rep(size, length(align_to))
if(length(size) != length(align_to)) {
stop_wrap("Length of `size` should be the same as the number of groups of indices.")
}
if(!inherits(size, "unit")) {
size_is_unit = FALSE
if(n_boxes == 1) {
h = data.frame(left = .scale[1] - extend[1], right = .scale[2] + extend[2])
} else {
gap = convertWidth(gap, "native", valueOnly = TRUE)
box_width = size/sum(size) * (1 + sum(extend) - sum(gap[1:(n_boxes-1)]))
h = data.frame(
right = cumsum(box_width) + cumsum(gap) - gap[length(gap)] - extend[1]
)
h$left = h$right - box_width
}
} else {
size_is_unit = TRUE
box_width = size
box_width2 = box_width
for(i in 1:n_boxes) {
if(i == 1 || i == n_boxes) {
if(n_boxes > 1) {
box_width2[i] = box_width2[i] + gap[i]*0.5
}
} else {
box_width2[i] = box_width2[i] + gap[i]
}
}
box_width2 = convertWidth(box_width2, "native", valueOnly = TRUE)
# the original positions of boxes
mean_pos = sapply(align_to_df, function(df) mean((pos[df[, 1]] + pos[df[, 2]])/2))
h1 = mean_pos - box_width2*0.5
h2 = mean_pos + box_width2*0.5
h = smartAlign2(h1, h2, c(.scale[1] - extend[1], .scale[2] + extend[2]))
colnames(h) = c("left", "right")
# recalcualte h to remove gaps
gap_width = convertWidth(gap, "native", valueOnly = TRUE)
if(n_boxes > 1) {
for(i in 1:n_boxes) {
if(i == 1) {
h[i, "left"] = h[i, "left"] + gap_width[i]/2
} else if(i == n_boxes) {
h[i, "right"] = h[i, "right"] - gap_width[i]/2
} else {
h[i, "left"] = h[i, "left"] + gap_width[i]/2
h[i, "right"] = h[i, "right"] - gap_width[i]/2
}
}
}
}
popViewport()
# draw boxes
if(side == "top") {
pushViewport(viewport(y = link_height, just = "bottom", height = anno_size$height - link_height))
} else {
pushViewport(viewport(y = 0, just = "bottom", height = anno_size$height - link_height))
}
for(i in 1:n_boxes) {
current_vp_name = current.viewport()$name
pushViewport(viewport(x = (h[i, "right"] + h[i, "left"])/2, width = h[i, "right"] - h[i, "left"],
default.units = "native"))
if(is.function(panel_fun)) panel_fun(align_to[[i]], names(align_to)[i])
popViewport()
if(current.viewport()$name != current_vp_name) {
stop_wrap("If you push viewports `panel_fun`, you need to pop all them out.")
}
}
popViewport()
# draw the links
link_gp = recycle_gp(link_gp, n_boxes)
if(side == "top") {
pushViewport(viewport(y = unit(0, "npc"), just = "bottom", height = link_height))
} else {
pushViewport(viewport(y = unit(1, "npc"), just = "top", height = link_height))
}
for(i in 1:n_boxes) {
df = align_to_df[[i]]
for(j in 1:nrow(df)) {
# draw each polygon
if(side == "top") {
grid.polygon(
c(pos[df[j, 2]] + 0.5/n, pos[df[j, 1]] - 0.5/n, h[i, "left"], h[i, "right"]),
unit.c(unit(c(0, 0), "npc"), rep(link_width, 2)),
default.units = "native", gp = subset_gp(link_gp, i))
} else {
grid.polygon(
c(pos[df[j, 2]] + 0.5/n, pos[df[j, 1]] - 0.5/n, h[i, "left"], h[i, "right"]),
unit.c(rep(link_width, 2), unit(c(0, 0), "npc")),
default.units = "native", gp = subset_gp(link_gp, i))
}
}
}
popViewport()
}
if(which == "row") {
fun = row_fun
} else if(which == "column") {
fun = column_fun
}
anno = AnnotationFunction(
fun = fun,
fun_name = "anno_zoom",
which = which,
height = anno_size$height,
width = anno_size$width,
n = -1,
var_import = list(align_to, .pos, gap, size, panel_fun, side, anno_size, extend,
link_width, link_height, link_gp),
show_name = FALSE
)
anno@subset_rule$align_to = function(x, i) {
if(is.atomic(x)) {
x[i]
} else {
x = lapply(x, function(x) intersect(x, i))
x = x[sapply(x, length) > 0]
}
}
anno@subsetable = TRUE
return(anno)
}
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.