###############################
# class for single heatmap
#
# == title
# Class for a Single Heatmap
#
# == details
# The `Heatmap-class` is not responsible for heatmap legend and annotation legends. The `draw,Heatmap-method` method
# constructs a `HeatmapList-class` object which only contains one single heatmap
# and call `draw,HeatmapList-method` to make the complete heatmap.
#
# == methods
# The `Heatmap-class` provides following methods:
#
# - `Heatmap`: constructor method.
# - `draw,Heatmap-method`: draw a single heatmap.
# - `add_heatmap,Heatmap-method` append heatmaps and annotations to a list of heatmaps.
# - `row_order,HeatmapList-method`: get order of rows
# - `column_order,HeatmapList-method`: get order of columns
# - `row_dend,HeatmapList-method`: get row dendrograms
# - `column_dend,HeatmapList-method`: get column dendrograms
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
Heatmap = setClass("Heatmap",
slots = list(
name = "character",
matrix = "matrix", # one or more matrix which are spliced by rows
matrix_param = "list",
matrix_color_mapping = "ANY",
matrix_legend_param = "ANY",
row_title = "ANY",
row_title_param = "list",
column_title = "ANY",
column_title_param = "list",
row_dend_list = "list", # one or more row clusters
row_dend_slice = "ANY",
row_dend_param = "list", # parameters for row cluster
row_order_list = "list",
row_order = "numeric",
column_dend_list = "list",
column_dend_slice = "ANY",
column_dend_param = "list", # parameters for column cluster
column_order_list = "list",
column_order = "numeric",
row_names_param = "list",
column_names_param = "list",
top_annotation = "ANY", # NULL or a `HeatmapAnnotation` object
top_annotation_param = "list",
bottom_annotation = "ANY",
bottom_annotation_param = "list",
left_annotation = "ANY", # NULL or a `HeatmapAnnotation` object
left_annotation_param = "list",
right_annotation = "ANY",
right_annotation_param = "list",
heatmap_param = "list",
layout = "list"
),
contains = "AdditiveUnit"
)
# == title
# Constructor method for Heatmap class
#
# == param
# -matrix A matrix. Either numeric or character. If it is a simple vector, it will be
# converted to a one-column matrix.
# -col A vector of colors if the color mapping is discrete or a color mapping
# function if the matrix is continuous numbers (should be generated by `circlize::colorRamp2`). If the matrix is continuous,
# the value can also be a vector of colors so that colors can be interpolated. Pass to `ColorMapping`. For more details
# and examples, please refer to https://jokergoo.github.io/ComplexHeatmap-reference/book/a-single-heatmap.html#colors .
# -name Name of the heatmap. By default the heatmap name is used as the title of the heatmap legend.
# -na_col Color for ``NA`` values.
# -rect_gp Graphic parameters for drawing rectangles (for heatmap body). The value should be specified by `grid::gpar` and ``fill`` parameter is ignored.
# -color_space The color space in which colors are interpolated. Only used if ``matrix`` is numeric and
# ``col`` is a vector of colors. Pass to `circlize::colorRamp2`.
# -border Whether draw border. The value can be logical or a string of color.
# -cell_fun Self-defined function to add graphics on each cell. Seven parameters will be passed into
# this function: ``j``, ``i``, ``x``, ``y``, ``width``, ``height``, ``fill`` which are column index,
# row index in ``matrix``, coordinate of the cell,
# the width and height of the cell and the filled color. ``x``, ``y``, ``width`` and ``height`` are all `grid::unit` objects.
# -layer_fun Similar as ``cell_fun``, but is vectorized. Check https://jokergoo.github.io/ComplexHeatmap-reference/book/a-single-heatmap.html#customize-the-heatmap-body .
# -row_title Title on the row.
# -row_title_side Will the title be put on the left or right of the heatmap?
# -row_title_gp Graphic parameters for row title.
# -row_title_rot Rotation of row title. Only 0, 90, 270 are allowed to set.
# -column_title Title on the column.
# -column_title_side Will the title be put on the top or bottom of the heatmap?
# -column_title_gp Graphic parameters for column title.
# -column_title_rot Rotation of column titles. Only 0, 90, 270 are allowed to set.
# -cluster_rows If the value is a logical, it controls whether to make cluster on rows. The value can also
# be a `stats::hclust` or a `stats::dendrogram` which already contains clustering.
# Check https://jokergoo.github.io/ComplexHeatmap-reference/book/a-single-heatmap.html#clustering .
# -cluster_row_slices If rows are split into slices, whether perform clustering on the slice means?
# -clustering_distance_rows It can be a pre-defined character which is in
# ("euclidean", "maximum", "manhattan", "canberra", "binary",
# "minkowski", "pearson", "spearman", "kendall"). It can also be a function.
# If the function has one argument, the input argument should be a matrix and
# the returned value should be a `stats::dist` object. If the function has two arguments,
# the input arguments are two vectors and the function calculates distance between these
# two vectors.
# -clustering_method_rows Method to perform hierarchical clustering, pass to `stats::hclust`.
# -row_dend_side Should the row dendrogram be put on the left or right of the heatmap?
# -row_dend_width Width of the row dendrogram, should be a `grid::unit` object.
# -show_row_dend Whether show row dendrogram?
# -row_dend_gp Graphic parameters for the dendrogram segments. If users already provide a `stats::dendrogram`
# object with edges rendered, this argument will be ignored.
# -row_dend_reorder Apply reordering on row dendrograms. The value can be a logical value or a vector which contains weight
# which is used to reorder rows. The reordering is applied by `stats::reorder.dendrogram`.
# -cluster_columns Whether make cluster on columns? Same settings as ``cluster_rows``.
# -cluster_column_slices If columns are split into slices, whether perform clustering on the slice means?
# -clustering_distance_columns Same setting as ``clustering_distance_rows``.
# -clustering_method_columns Method to perform hierarchical clustering, pass to `stats::hclust`.
# -column_dend_side Should the column dendrogram be put on the top or bottom of the heatmap?
# -column_dend_height height of the column cluster, should be a `grid::unit` object.
# -show_column_dend Whether show column dendrogram?
# -column_dend_gp Graphic parameters for dendrogram segments. Same settings as ``row_dend_gp``.
# -column_dend_reorder Apply reordering on column dendrograms. Same settings as ``row_dend_reorder``.
# -row_order Order of rows. Manually setting row order turns off clustering.
# -column_order Order of column.
# -row_labels Optional row labels which are put as row names in the heatmap.
# -row_names_side Should the row names be put on the left or right of the heatmap?
# -show_row_names Whether show row names.
# -row_names_max_width Maximum width of row names viewport.
# -row_names_gp Graphic parameters for row names.
# -row_names_rot Rotation of row names.
# -column_labels Optional column labels which are put as column names in the heatmap.
# -column_names_side Should the column names be put on the top or bottom of the heatmap?
# -column_names_max_height Maximum height of column names viewport.
# -show_column_names Whether show column names.
# -column_names_gp Graphic parameters for drawing text.
# -column_names_rot Rotation of column names.
# -top_annotation A `HeatmapAnnotation` object.
# -bottom_annotation A `HeatmapAnnotation` object.
# -left_annotation It should be specified by `rowAnnotation`.
# -right_annotation it should be specified by `rowAnnotation`.
# -km Apply k-means clustering on rows. If the value is larger than 1, the heatmap will be split by rows according to the k-means clustering.
# For each row slice, hierarchical clustering is still applied with parameters above.
# -split A vector or a data frame by which the rows are split. But if ``cluster_rows`` is a clustering object, ``split`` can be a single number
# indicating to split the dendrogram by `stats::cutree`.
# -row_km Same as ``km``.
# -row_split Same as ``split``.
# -column_km K-means clustering on columns.
# -column_split Split on columns. For heatmap splitting, please refer to https://jokergoo.github.io/ComplexHeatmap-reference/book/a-single-heatmap.html#heatmap-split .
# -gap Gap between row slices if the heatmap is split by rows. The value should be a `grid::unit` object.
# -row_gap Same as ``gap``.
# -column_gap Gap between column slices.
# -show_parent_dend_line When heatmap is split, whether to add a dashed line to mark parent dendrogram and children dendrograms?
# -width Width of the heatmap body.
# -height Height of the heatmap body.
# -heatmap_width Width of the whole heatmap (including heatmap components)
# -heatmap_height Height of the whole heatmap (including heatmap components). Check https://jokergoo.github.io/ComplexHeatmap-reference/book/a-single-heatmap.html#size-of-the-heatmap .
# -show_heatmap_legend Whether show heatmap legend?
# -heatmap_legend_param A list contains parameters for the heatmap legends. See `color_mapping_legend,ColorMapping-method` for all available parameters.
# -use_raster Whether render the heatmap body as a raster image. It helps to reduce file size when the matrix is huge. Note if ``cell_fun``
# is set, ``use_raster`` is enforced to be ``FALSE``.
# -raster_device Graphic device which is used to generate the raster image.
# -raster_quality A value set to larger than 1 will improve the quality of the raster image.
# -raster_device_param A list of further parameters for the selected graphic device. For raster image support, please check https://jokergoo.github.io/ComplexHeatmap-reference/book/a-single-heatmap.html#heatmap-as-raster-image .
# -raster_resize Whether resize the matrix to let the dimension of the matrix the same as the dimension of the raster image?
# -post_fun A function which will be executed after the heatmap list is drawn.
#
# == details
# The initialization function only applies parameter checking and fill values to the slots with some validation.
#
# Following methods can be applied to the `Heatmap-class` object:
#
# - `show,Heatmap-method`: draw a single heatmap with default parameters
# - `draw,Heatmap-method`: draw a single heatmap.
# - ``+`` or `\%v\%` append heatmaps and annotations to a list of heatmaps.
#
# The constructor function pretends to be a high-level graphic function because the ``show`` method
# of the `Heatmap-class` object actually plots the graphics.
#
# == seealso
# https://jokergoo.github.io/ComplexHeatmap-reference/book/a-single-heatmap.html
#
# == value
# A `Heatmap-class` object.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
Heatmap = function(matrix, col, name,
na_col = "grey",
color_space = "LAB",
rect_gp = gpar(col = NA),
border = NA,
cell_fun = NULL,
layer_fun = NULL,
row_title = character(0),
row_title_side = c("left", "right"),
row_title_gp = gpar(fontsize = 14),
row_title_rot = switch(row_title_side[1], "left" = 90, "right" = 270),
column_title = character(0),
column_title_side = c("top", "bottom"),
column_title_gp = gpar(fontsize = 14),
column_title_rot = 0,
cluster_rows = TRUE,
cluster_row_slices = TRUE,
clustering_distance_rows = "euclidean",
clustering_method_rows = "complete",
row_dend_side = c("left", "right"),
row_dend_width = unit(10, "mm"),
show_row_dend = TRUE,
row_dend_reorder = is.logical(cluster_rows) || is.function(cluster_rows),
row_dend_gp = gpar(),
cluster_columns = TRUE,
cluster_column_slices = TRUE,
clustering_distance_columns = "euclidean",
clustering_method_columns = "complete",
column_dend_side = c("top", "bottom"),
column_dend_height = unit(10, "mm"),
show_column_dend = TRUE,
column_dend_gp = gpar(),
column_dend_reorder = is.logical(cluster_columns) || is.function(cluster_columns),
row_order = NULL,
column_order = NULL,
row_labels = rownames(matrix),
row_names_side = c("right", "left"),
show_row_names = TRUE,
row_names_max_width = unit(6, "cm"),
row_names_gp = gpar(fontsize = 12),
row_names_rot = 0,
column_labels = colnames(matrix),
column_names_side = c("bottom", "top"),
show_column_names = TRUE,
column_names_max_height = unit(6, "cm"),
column_names_gp = gpar(fontsize = 12),
column_names_rot = 90,
top_annotation = NULL,
bottom_annotation = NULL,
left_annotation = NULL,
right_annotation = NULL,
km = 1,
split = NULL,
row_km = km,
row_split = split,
column_km = 1,
column_split = NULL,
gap = unit(1, "mm"),
row_gap = unit(1, "mm"),
column_gap = unit(1, "mm"),
show_parent_dend_line = ht_opt$show_parent_dend_line,
heatmap_width = unit(1, "npc"),
width = NULL,
heatmap_height = unit(1, "npc"),
height = NULL,
show_heatmap_legend = TRUE,
heatmap_legend_param = list(title = name),
use_raster = (nrow(matrix) > 2000 && ncol(matrix) > 1) || (ncol(matrix) > 2000 && nrow(matrix) > 1),
raster_device = c("png", "jpeg", "tiff", "CairoPNG", "CairoJPEG", "CairoTIFF"),
raster_quality = 2,
raster_device_param = list(),
raster_resize = FALSE,
post_fun = NULL) {
dev.null()
on.exit(dev.off2())
verbose = ht_opt("verbose")
.Object = new("Heatmap")
if(missing(name)) {
name = paste0("matrix_", get_heatmap_index() + 1)
increase_heatmap_index()
}
.Object@name = name
# re-define some of the argument values according to global settings
called_args = names(as.list(match.call())[-1])
for(opt_name in c("row_names_gp", "column_names_gp", "row_title_gp", "column_title_gp")) {
opt_name2 = paste0("heatmap_", opt_name)
if(! opt_name %in% called_args) { # if this argument is not called
if(!is.null(ht_opt(opt_name2))) {
if(verbose) qqcat("re-assign @{opt_name} with `ht_opt('@{opt_name2}'')`\n")
assign(opt_name, ht_opt(opt_name2))
}
}
}
if("top_annotation_height" %in% called_args) {
stop_wrap("`top_annotation_height` is removed. Set the height directly in `HeatmapAnnotation()`.")
}
if("bottom_annotation_height" %in% called_args) {
stop_wrap("`bottom_annotation_height` is removed. Set the height directly in `HeatmapAnnotation()`.")
}
if("combined_name_fun" %in% called_args) {
stop_wrap("`combined_name_fun` is removed. Please directly set `row_names_title`. See https://jokergoo.github.io/ComplexHeatmap-reference/book/a-single-heatmap.html#titles-for-splitting")
}
if("heatmap_legend_param" %in% called_args) {
for(opt_name in setdiff(c("title_gp", "title_position", "labels_gp", "grid_width", "grid_height", "border"), names(heatmap_legend_param))) {
opt_name2 = paste0("legend_", opt_name)
if(!is.null(ht_opt(opt_name2)))
if(verbose) qqcat("re-assign heatmap_legend_param$@{opt_name} with `ht_opt('@{opt_name2}'')`\n")
heatmap_legend_param[[opt_name]] = ht_opt(opt_name2)
}
} else {
for(opt_name in c("title_gp", "title_position", "labels_gp", "grid_width", "grid_height", "border")) {
opt_name2 = paste0("legend_", opt_name)
if(!is.null(ht_opt(opt_name2)))
if(verbose) qqcat("re-assign heatmap_legend_param$@{opt_name} with `ht_opt('@{opt_name2}'')`\n")
heatmap_legend_param[[opt_name]] = ht_opt(opt_name2)
}
}
if(is.data.frame(matrix)) {
if(verbose) qqcat("convert data frame to matrix\n")
warning_wrap("The input is a data frame, convert it to the matrix.")
matrix = as.matrix(matrix)
}
if(!is.matrix(matrix)) {
if(is.atomic(matrix)) {
rn = names(matrix)
matrix = matrix(matrix, ncol = 1)
if(!is.null(rn)) rownames(matrix) = rn
if(!missing(name)) colnames(matrix) = name
if(verbose) qqcat("convert simple vector to one-column matrix\n")
} else {
stop_wrap("If input is not a matrix, it should be a simple vector.")
}
}
if(ncol(matrix) == 0) {
.Object@heatmap_param$show_heatmap_legend = FALSE
}
### normalize km/split and row_km/row_split
if(missing(row_km)) row_km = km
if(missing(row_split)) row_split = split
if(missing(row_gap)) row_gap = gap
####### zero and one column matrix ########
if(ncol(matrix) == 0 || nrow(matrix) == 0) {
if(!inherits(cluster_columns, c("dendrogram", "hclust"))) {
cluster_columns = FALSE
show_column_dend = FALSE
}
if(!inherits(cluster_rows, c("dendrogram", "hclust"))) {
cluster_rows = FALSE
show_row_dend = FALSE
}
row_km = 1
column_km = 1
if(verbose) qqcat("zero row/column matrix, set cluster_columns/rows to FALSE\n")
}
if(ncol(matrix) == 1) {
if(!inherits(cluster_columns, c("dendrogram", "hclust"))) {
cluster_columns = FALSE
show_column_dend = FALSE
}
column_km = 1
if(verbose) qqcat("one-column matrix, set cluster_columns to FALSE\n")
}
if(nrow(matrix) == 1) {
if(!inherits(cluster_rows, c("dendrogram", "hclust"))) {
cluster_rows = FALSE
show_row_dend = FALSE
}
row_km = 1
if(verbose) qqcat("one-row matrix, set cluster_rows to FALSE\n")
}
if(is.character(matrix)) {
called_args = names(match.call()[-1])
if("clustering_distance_rows" %in% called_args) {
} else if(inherits(cluster_rows, c("dendrogram", "hclust"))) {
} else {
cluster_rows = FALSE
show_row_dend = FALSE
}
row_dend_reorder = FALSE
if("clustering_distance_columns" %in% called_args) {
} else if(inherits(cluster_columns, c("dendrogram", "hclust"))) {
} else {
cluster_columns = FALSE
show_column_dend = FALSE
}
column_dend_reorder = FALSE
row_km = 1
column_km = 1
if(verbose) qqcat("matrix is character. Do not cluster unless distance method is provided.\n")
}
.Object@matrix = matrix
.Object@matrix_param$row_km = row_km
.Object@matrix_param$row_gap = row_gap
.Object@matrix_param$column_km = column_km
.Object@matrix_param$column_gap = column_gap
### check row_split and column_split ###
if(!is.null(row_split)) {
if(inherits(cluster_rows, c("dendrogram", "hclust"))) {
if(is.numeric(row_split) && length(row_split) == 1) {
.Object@matrix_param$row_split = row_split
} else {
stop_wrap("When `cluster_rows` is a dendrogram, `row_split` can only be a single number.")
}
} else {
if(identical(cluster_rows, TRUE) && is.numeric(row_split) && length(row_split) == 1) {
} else {
if(!is.data.frame(row_split)) row_split = data.frame(row_split)
if(nrow(row_split) != nrow(matrix)) {
stop_wrap("Length or nrow of `row_split` should be same as nrow of `matrix`.")
}
}
}
}
.Object@matrix_param$row_split = row_split
if(!is.null(column_split)) {
if(inherits(cluster_columns, c("dendrogram", "hclust"))) {
if(is.numeric(column_split) && length(column_split) == 1) {
.Object@matrix_param$column_split = column_split
} else {
stop_wrap("When `cluster_columns` is a dendrogram, `column_split` can only be a single number.")
}
} else {
if(identical(cluster_columns, TRUE) && is.numeric(column_split) && length(column_split) == 1) {
} else {
if(!is.data.frame(column_split)) column_split = data.frame(column_split)
if(nrow(column_split) != ncol(matrix)) {
stop_wrap("Length or ncol of `column_split` should be same as ncol of `matrix`.")
}
}
}
}
.Object@matrix_param$column_split = column_split
### parameters for heatmap body ###
.Object@matrix_param$gp = check_gp(rect_gp)
if(missing(border)) {
if(!is.null(ht_opt$heatmap_border)) border = ht_opt$heatmap_border
}
if(identical(border, TRUE)) border = "black"
.Object@matrix_param$border = border
.Object@matrix_param$cell_fun = cell_fun
.Object@matrix_param$layer_fun = layer_fun
### color for main matrix #########
if(ncol(matrix) > 0 && nrow(matrix) > 0) {
if(missing(col)) {
col = default_col(matrix, main_matrix = TRUE)
if(verbose) qqcat("color is not specified, use randomly generated colors\n")
}
if(is.function(col)) {
.Object@matrix_color_mapping = ColorMapping(col_fun = col, name = name, na_col = na_col)
if(verbose) qqcat("input color is a color mapping function\n")
} else {
if(is.null(names(col))) {
if(length(col) == length(unique(as.vector(matrix)))) {
names(col) = sort(unique(as.vector(matrix)))
.Object@matrix_color_mapping = ColorMapping(colors = col, name = name, na_col = na_col)
if(verbose) qqcat("input color is a vector with no names, treat it as discrete color mapping\n")
} else if(is.numeric(matrix)) {
col = colorRamp2(seq(min(matrix, na.rm = TRUE), max(matrix, na.rm = TRUE), length = length(col)),
col, space = color_space)
.Object@matrix_color_mapping = ColorMapping(col_fun = col, name = name, na_col = na_col)
if(verbose) qqcat("input color is a vector with no names, treat it as continuous color mapping\n")
} else {
stop_wrap("`col` should have names to map to values in `mat`.")
}
} else {
col = col[intersect(c(names(col), "_NA_"), as.character(matrix))]
.Object@matrix_color_mapping = ColorMapping(colors = col, name = name, na_col = na_col)
if(verbose) qqcat("input color is a named vector\n")
}
}
.Object@matrix_legend_param = heatmap_legend_param
}
##### titles, should also consider titles after row splitting #####
if(identical(row_title, NA) || identical(row_title, "")) {
row_title = character(0)
}
.Object@row_title = row_title
.Object@row_title_param$rot = row_title_rot %% 360
.Object@row_title_param$side = match.arg(row_title_side)[1]
.Object@row_title_param$gp = check_gp(row_title_gp) # if the number of settings is same as number of row-splits, gp will be adjusted by `make_row_dend`
.Object@row_title_param$just = get_text_just(rot = row_title_rot, side = .Object@row_title_param$side)
if(identical(column_title, NA) || identical(column_title, "")) {
column_title = character(0)
}
.Object@column_title = column_title
.Object@column_title_param$rot = column_title_rot %% 360
.Object@column_title_param$side = match.arg(column_title_side)[1]
.Object@column_title_param$gp = check_gp(column_title_gp)
.Object@column_title_param$just = get_text_just(rot = column_title_rot, side = .Object@column_title_param$side)
### row labels/column labels ###
if(is.null(rownames(matrix))) {
show_row_names = FALSE
}
.Object@row_names_param$labels = row_labels
.Object@row_names_param$side = match.arg(row_names_side)[1]
.Object@row_names_param$show = show_row_names
.Object@row_names_param$gp = check_gp(row_names_gp)
.Object@row_names_param$rot = row_names_rot
.Object@row_names_param$max_width = row_names_max_width + unit(2, "mm")
# we use anno_text to draw row/column names because it already takes care of text rotation
if(show_row_names) {
if(length(row_labels) != nrow(matrix)) {
stop_wrap("Length of `row_labels` should be the same as the nrow of matrix.")
}
row_names_anno = anno_text(row_labels, which = "row", gp = row_names_gp, rot = row_names_rot,
location = ifelse(.Object@row_names_param$side == "left", 1, 0),
just = ifelse(.Object@row_names_param$side == "left", "right", "left"))
.Object@row_names_param$anno = row_names_anno
}
if(is.null(colnames(matrix))) {
show_column_names = FALSE
}
.Object@column_names_param$labels = column_labels
.Object@column_names_param$side = match.arg(column_names_side)[1]
.Object@column_names_param$show = show_column_names
.Object@column_names_param$gp = check_gp(column_names_gp)
.Object@column_names_param$rot = column_names_rot
.Object@column_names_param$max_height = column_names_max_height + unit(2, "mm")
if(show_column_names) {
if(length(column_labels) != ncol(matrix)) {
stop_wrap("Length of `column_labels` should be the same as the ncol of matrix.")
}
column_names_anno = anno_text(column_labels, which = "column", gp = column_names_gp, rot = column_names_rot,
location = ifelse(.Object@column_names_param$side == "top", 0, 1),
just = ifelse(.Object@column_names_param$side == "top",
ifelse(.Object@column_names_param$rot >= 0, "left", "right"),
ifelse(.Object@column_names_param$rot >= 0, "right", "left")
))
.Object@column_names_param$anno = column_names_anno
}
#### dendrograms ########
if(missing(cluster_rows) && !missing(row_order)) {
cluster_rows = FALSE
}
if(is.logical(cluster_rows)) {
if(!cluster_rows) {
row_dend_width = unit(0, "mm")
show_row_dend = FALSE
}
.Object@row_dend_param$cluster = cluster_rows
} else if(inherits(cluster_rows, "dendrogram") || inherits(cluster_rows, "hclust")) {
.Object@row_dend_param$obj = cluster_rows
.Object@row_dend_param$cluster = TRUE
} else if(inherits(cluster_rows, "function")) {
.Object@row_dend_param$fun = cluster_rows
.Object@row_dend_param$cluster = TRUE
} else {
oe = try(cluster_rows <- as.dendrogram(cluster_rows), silent = TRUE)
if(!inherits(oe, "try-error")) {
.Object@row_dend_param$obj = cluster_rows
.Object@row_dend_param$cluster = TRUE
} else {
stop_wrap("`cluster_rows` should be a logical value, a clustering function or a clustering object.")
}
}
if(!show_row_dend) {
row_dend_width = unit(0, "mm")
}
.Object@row_dend_list = list()
.Object@row_dend_param$distance = clustering_distance_rows
.Object@row_dend_param$method = clustering_method_rows
.Object@row_dend_param$side = match.arg(row_dend_side)[1]
.Object@row_dend_param$width = row_dend_width + ht_opt$DENDROGRAM_PADDING # append the gap
.Object@row_dend_param$show = show_row_dend
.Object@row_dend_param$gp = check_gp(row_dend_gp)
.Object@row_dend_param$reorder = row_dend_reorder
.Object@row_order_list = list() # default order
if(is.null(row_order)) {
.Object@row_order = seq_len(nrow(matrix))
} else {
if(is.character(row_order)) {
row_order = structure(seq_len(nrow(matrix)), names = rownames(matrix))[row_order]
}
.Object@row_order = row_order
}
.Object@row_dend_param$cluster_slices = cluster_row_slices
if(missing(cluster_columns) && !missing(column_order)) {
cluster_columns = FALSE
}
if(is.logical(cluster_columns)) {
if(!cluster_columns) {
column_dend_height = unit(0, "mm")
show_column_dend = FALSE
}
.Object@column_dend_param$cluster = cluster_columns
} else if(inherits(cluster_columns, "dendrogram") || inherits(cluster_columns, "hclust")) {
.Object@column_dend_param$obj = cluster_columns
.Object@column_dend_param$cluster = TRUE
} else if(inherits(cluster_columns, "function")) {
.Object@column_dend_param$fun = cluster_columns
.Object@column_dend_param$cluster = TRUE
} else {
oe = try(cluster_columns <- as.dendrogram(cluster_columns), silent = TRUE)
if(!inherits(oe, "try-error")) {
.Object@column_dend_param$obj = cluster_columns
.Object@column_dend_param$cluster = TRUE
} else {
stop_wrap("`cluster_columns` should be a logical value, a clustering function or a clustering object.")
}
}
if(!show_column_dend) {
column_dend_height = unit(0, "mm")
}
.Object@column_dend_list = list()
.Object@column_dend_param$distance = clustering_distance_columns
.Object@column_dend_param$method = clustering_method_columns
.Object@column_dend_param$side = match.arg(column_dend_side)[1]
.Object@column_dend_param$height = column_dend_height + ht_opt$DENDROGRAM_PADDING # append the gap
.Object@column_dend_param$show = show_column_dend
.Object@column_dend_param$gp = check_gp(column_dend_gp)
.Object@column_dend_param$reorder = column_dend_reorder
if(is.null(column_order)) {
.Object@column_order = seq_len(ncol(matrix))
} else {
if(is.character(column_order)) {
column_order = structure(seq_len(ncol(matrix)), names = colnames(matrix))[column_order]
}
.Object@column_order = column_order
}
.Object@column_dend_param$cluster_slices = cluster_column_slices
######### annotations #############
.Object@top_annotation = top_annotation # a `HeatmapAnnotation` object
if(is.null(top_annotation)) {
.Object@top_annotation_param$height = unit(0, "mm")
} else {
.Object@top_annotation_param$height = height(top_annotation) + ht_opt$COLUMN_ANNO_PADDING # append the gap
}
if(!is.null(top_annotation)) {
if(length(top_annotation) > 0) {
if(!.Object@top_annotation@which == "column") {
stop_wrap("`which` in `top_annotation` should only be `column`.")
}
}
nb = nobs(top_annotation)
if(!is.na(nb)) {
if(nb != ncol(.Object@matrix)) {
stop_wrap("number of observations in top annotation should be as same as ncol of the matrix.")
}
}
}
.Object@bottom_annotation = bottom_annotation # a `HeatmapAnnotation` object
if(is.null(bottom_annotation)) {
.Object@bottom_annotation_param$height = unit(0, "mm")
} else {
.Object@bottom_annotation_param$height = height(bottom_annotation) + ht_opt$COLUMN_ANNO_PADDING # append the gap
}
if(!is.null(bottom_annotation)) {
if(length(bottom_annotation) > 0) {
if(!.Object@bottom_annotation@which == "column") {
stop_wrap("`which` in `bottom_annotation` should only be `column`.")
}
}
nb = nobs(bottom_annotation)
if(!is.na(nb)) {
if(nb != ncol(.Object@matrix)) {
stop_wrap("number of observations in bottom anntotion should be as same as ncol of the matrix.")
}
}
}
.Object@left_annotation = left_annotation # a `rowAnnotation` object
if(is.null(left_annotation)) {
.Object@left_annotation_param$width = unit(0, "mm")
} else {
.Object@left_annotation_param$width = width(left_annotation) + ht_opt$ROW_ANNO_PADDING # append the gap
}
if(!is.null(left_annotation)) {
if(length(left_annotation) > 0) {
if(!.Object@left_annotation@which == "row") {
stop_wrap("`which` in `left_annotation` should only be `row`, or consider using `rowAnnotation()`.")
}
}
nb = nobs(left_annotation)
if(!is.na(nb)) {
if(nb != nrow(.Object@matrix)) {
stop_wrap("number of observations in left anntotion should be same as nrow of the matrix.")
}
}
}
.Object@right_annotation = right_annotation # a `rowAnnotation` object
if(is.null(right_annotation)) {
.Object@right_annotation_param$width = unit(0, "mm")
} else {
.Object@right_annotation_param$width = width(right_annotation) + ht_opt$ROW_ANNO_PADDING # append the gap
}
if(!is.null(right_annotation)) {
if(length(right_annotation) > 0) {
if(!.Object@right_annotation@which == "row") {
stop_wrap("`which` in `right_annotation` should only be `row`, or consider using `rowAnnotation()`.")
}
}
nb = nobs(right_annotation)
if(!is.na(nb)) {
if(nb != nrow(.Object@matrix)) {
stop_wrap("number of observations in right anntotion should be same as nrow of the matrix.")
}
}
}
.Object@layout = list(
layout_size = list(
column_title_top_height = unit(0, "mm"),
column_dend_top_height = unit(0, "mm"),
column_anno_top_height = unit(0, "mm"),
column_names_top_height = unit(0, "mm"),
column_title_bottom_height = unit(0, "mm"),
column_dend_bottom_height = unit(0, "mm"),
column_anno_bottom_height = unit(0, "mm"),
column_names_bottom_height = unit(0, "mm"),
row_title_left_width = unit(0, "mm"),
row_dend_left_width = unit(0, "mm"),
row_names_left_width = unit(0, "mm"),
row_dend_right_width = unit(0, "mm"),
row_names_right_width = unit(0, "mm"),
row_title_right_width = unit(0, "mm"),
row_anno_left_width = unit(0, "mm"),
row_anno_right_width = unit(0, "mm")
),
layout_index = NULL,
graphic_fun_list = list(),
initialized = FALSE
)
if(is.null(width)) {
width = unit(ncol(matrix), "null")
} else if(is.numeric(width) && !inherits(width, "unit")) {
width = unit(width, "null")
} else if(!inherits(width, "unit")) {
stop_wrap("`width` should be a `unit` object or a single number.")
}
if(is.null(height)) {
height = unit(nrow(matrix), "null")
} else if(is.numeric(height) && !inherits(height, "unit")) {
height = unit(height, "null")
} else if(!inherits(height, "unit")) {
stop_wrap("`height` should be a `unit` object or a single number.")
}
if(!is.null(width) && !is.null(heatmap_width)) {
if(is_abs_unit(width) && is_abs_unit(heatmap_width)) {
stop_wrap("`heatmap_width` and `width` should not all be the absolute units.")
}
}
if(!is.null(height) && !is.null(heatmap_height)) {
if(is_abs_unit(height) && is_abs_unit(heatmap_height)) {
stop_wrap("`heatmap_height` and `width` should not all be the absolute units.")
}
}
.Object@matrix_param$width = width
.Object@matrix_param$height = height
.Object@heatmap_param$width = heatmap_width
.Object@heatmap_param$height = heatmap_height
.Object@heatmap_param$show_heatmap_legend = show_heatmap_legend
.Object@heatmap_param$use_raster = use_raster
.Object@heatmap_param$raster_device = match.arg(raster_device)[1]
.Object@heatmap_param$raster_quality = raster_quality
.Object@heatmap_param$raster_device_param = raster_device_param
.Object@heatmap_param$raster_resize = raster_resize
.Object@heatmap_param$verbose = verbose
.Object@heatmap_param$post_fun = post_fun
.Object@heatmap_param$calling_env = parent.frame()
.Object@heatmap_param$show_parent_dend_line = show_parent_dend_line
if(nrow(matrix) == 0) {
.Object@matrix_param$height = unit(0, "mm")
}
if(ncol(matrix) == 0) {
.Object@matrix_param$width = unit(0, "mm")
}
return(.Object)
}
# == title
# Make Cluster on Rows
#
# == param
# -object A `Heatmap-class` object.
#
# == details
# The function will fill or adjust ``row_dend_list``, ``row_order_list``, ``row_title`` and ``matrix_param`` slots.
#
# If ``order`` is defined, no clustering will be applied.
#
# This function is only for internal use.
#
# == value
# A `Heatmap-class` object.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
setMethod(f = "make_row_cluster",
signature = "Heatmap",
definition = function(object) {
object = make_cluster(object, "row")
if(length(object@row_title) > 1) {
if(length(object@row_title) != length(object@row_order_list)) {
stop_wrap("If `row_title` is set with length > 1, the length should be as same as the number of row slices.")
}
}
return(object)
})
# == title
# Make Cluster on Columns
#
# == param
# -object A `Heatmap-class` object.
#
# == details
# The function will fill or adjust ``column_dend_list``,
# ``column_order_list``, ``column_title`` and ``matrix_param`` slots.
#
# If ``order`` is defined, no clustering will be applied.
#
# This function is only for internal use.
#
# == value
# A `Heatmap-class` object.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
setMethod(f = "make_column_cluster",
signature = "Heatmap",
definition = function(object) {
object = make_cluster(object, "column")
if(length(object@column_title) > 1) {
if(length(object@column_title) != length(object@column_order_list)) {
stop_wrap("If `column_title` is set with length > 1, the length should be as same as the number of column slices.")
}
}
return(object)
})
make_cluster = function(object, which = c("row", "column")) {
which = match.arg(which)[1]
verbose = object@heatmap_param$verbose
if(ht_opt("fast_hclust")) {
hclust = fastcluster::hclust
if(verbose) qqcat("apply hclust by fastcluster::hclust\n")
} else {
hclust = stats::hclust
}
mat = object@matrix
distance = slot(object, paste0(which, "_dend_param"))$distance
method = slot(object, paste0(which, "_dend_param"))$method
order = slot(object, paste0(which, "_order")) # pre-defined row order
km = getElement(object@matrix_param, paste0(which, "_km"))
split = getElement(object@matrix_param, paste0(which, "_split"))
reorder = slot(object, paste0(which, "_dend_param"))$reorder
cluster = slot(object, paste0(which, "_dend_param"))$cluster
cluster_slices = slot(object, paste0(which, "_dend_param"))$cluster_slices
gap = getElement(object@matrix_param, paste0(which, "_gap"))
dend_param = slot(object, paste0(which, "_dend_param"))
dend_list = slot(object, paste0(which, "_dend_list"))
dend_slice = slot(object, paste0(which, "_dend_slice"))
order_list = slot(object, paste0(which, "_order_list"))
order = slot(object, paste0(which, "_order"))
names_param = slot(object, paste0(which, "_names_param"))
dend_param$split_by_cutree = FALSE
if(cluster) {
if(is.numeric(split) && length(split) == 1) {
if(is.null(dend_param$obj)) {
if(verbose) qqcat("split @{which}s by cutree, apply hclust on the entire @{which}s\n")
if(which == "row") {
dend_param$obj = hclust(get_dist(mat, distance), method = method)
} else {
dend_param$obj = hclust(get_dist(t(mat), distance), method = method)
}
}
}
if(!is.null(dend_param$obj)) {
if(km > 1) {
stop_wrap("You can not perform k-means clustering since you have already specified a clustering object.")
}
if(inherits(dend_param$obj, "hclust")) {
dend_param$obj = as.dendrogram(dend_param$obj)
if(verbose) qqcat("convert hclust object to dendrogram object\n")
}
if(is.null(split)) {
dend_list = list(dend_param$obj)
order_list = list(get_dend_order(dend_param$obj))
if(verbose) qqcat("since you provided a clustering object and @{which}_split is null, the entrie clustering object is taken as an one-element list.\n")
} else {
if(length(split) > 1 || !is.numeric(split)) {
stop_wrap(qq("Since you specified a clustering object, you can only split @{which}s by providing a number (number of @{which} slices)."))
}
if(split < 2) {
stop_wrap(qq("`@{which}_split` should be >= 2."))
}
dend_param$split_by_cutree = TRUE
ct = cut_dendrogram(dend_param$obj, split)
dend_list = ct$lower
dend_slice = ct$upper
sth = tapply(order.dendrogram(dend_param$obj),
rep(seq_along(dend_list), times = sapply(dend_list, nobs)),
function(x) x)
attributes(sth) = NULL
order_list = sth
if(verbose) qqcat("cut @{which} dendrogram into @{split} slices.\n")
}
### do reordering if specified
if(identical(reorder, NULL)) {
if(is.numeric(mat)) {
reorder = TRUE
} else {
reorder = FALSE
}
}
do_reorder = TRUE
if(identical(reorder, NA) || identical(reorder, FALSE)) {
do_reorder = FALSE
}
if(identical(reorder, TRUE)) {
do_reorder = TRUE
if(which == "row") {
reorder = -rowMeans(mat, na.rm = TRUE)
} else {
reorder = -colMeans(mat, na.rm = TRUE)
}
}
if(do_reorder) {
if(which == "row") {
if(length(reorder) != nrow(mat)) {
stop_wrap("weight of reordering should have same length as number of rows.\n")
}
} else {
if(length(reorder) != ncol(mat)) {
stop_wrap("weight of reordering should have same length as number of columns\n")
}
}
for(i in seq_along(dend_list)) {
if(length(order_list[[i]]) > 1) {
sub_ind = sort(order_list[[i]])
dend_list[[i]] = reorder(dend_list[[i]], reorder[sub_ind], mean)
# the order of object@row_dend_list[[i]] is the order corresponding to the big dendrogram
order_list[[i]] = order.dendrogram(dend_list[[i]])
}
}
}
dend_list = lapply(dend_list, adjust_dend_by_x)
slot(object, paste0(which, "_order")) = unlist(order_list)
slot(object, paste0(which, "_order_list")) = order_list
slot(object, paste0(which, "_dend_list")) = dend_list
slot(object, paste0(which, "_dend_param")) = dend_param
slot(object, paste0(which, "_dend_slice")) = dend_slice
if(!is.null(split)) {
split = data.frame(rep(seq_along(order_list), times = sapply(order_list, length)))
object@matrix_param[[ paste0(which, "_split") ]] = split
# adjust row_names_param$gp if the length of some elements is the same as row slices
for(i in seq_along(names_param$gp)) {
if(length(names_param$gp[[i]]) == length(order_list)) {
gp_temp = NULL
for(j in seq_along(order_list)) {
gp_temp[ order_list[[j]] ] = names_param$gp[[i]][j]
}
names_param$gp[[i]] = gp_temp
}
}
if(!is.null(names_param$anno)) {
names_param$anno@var_env$gp = names_param$gp
}
slot(object, paste0(which, "_names_param")) = names_param
n_slice = length(order_list)
if(length(gap) == 1) {
gap = rep(gap, n_slice)
} else if(length(gap) == n_slice - 1) {
gap = unit.c(gap, unit(0, "mm"))
} else if(length(gap) != n_slice) {
stop_wrap(qq("Length of `gap` should be 1 or number of @{which} slices."))
}
object@matrix_param[[ paste0(which, "_gap") ]] = gap # adjust title
title = slot(object, paste0(which, "_title"))
if(!is.null(split)) {
if(length(title) == 0 && !is.null(title)) { ## default title
title = apply(unique(split), 1, paste, collapse = ",")
} else if(length(title) == 1) {
if(grepl("%s", title)) {
title = apply(unique(split), 1, function(x) {
lt = lapply(x, function(x) x)
lt$fmt = title
do.call(sprintf, lt)
})
} else if(grepl("@\\{.+\\}", title)) {
title = apply(unique(split), 1, function(x) {
x = x
envir = environment()
title = get("title")
op = parent.env(envir)
calling_env = object@heatmap_param$calling_env
parent.env(envir) = calling_env
title = GetoptLong::qq(title, envir = envir)
parent.env(envir) = op
return(title)
})
} else if(grepl("\\{.+\\}", title)) {
if(!requireNamespace("glue")) {
stop_wrap("You need to install glue package.")
}
title = apply(unique(split), 1, function(x) {
x = x
envir = environment()
title = get("title")
op = parent.env(envir)
calling_env = object@heatmap_param$calling_env
parent.env(envir) = calling_env
title = glue::glue(title, envir = calling_env)
parent.env(envir) = op
return(title)
})
}
}
}
slot(object, paste0(which, "_title")) = title
}
return(object)
}
} else {
if(verbose) qqcat("no clustering is applied/exists on @{which}s\n")
}
if(verbose) qq("clustering object is not pre-defined, clustering is applied to each @{which} slice\n")
# make k-means clustering to add a split column
if(km > 1 && is.numeric(mat)) {
if(which == "row") {
km.fit = kmeans(mat, centers = km)
cl = km.fit$cluster
meanmat = lapply(sort(unique(cl)), function(i) {
colMeans(mat[cl == i, , drop = FALSE])
})
} else {
km.fit = kmeans(t(mat), centers = km)
cl = km.fit$cluster
meanmat = lapply(sort(unique(cl)), function(i) {
rowMeans(mat[, cl == i, drop = FALSE])
})
}
meanmat = do.call("cbind", meanmat)
hc = hclust(dist(t(meanmat)))
# if `reorder` is a vector, the slice dendrogram is reordered by the mean of reorder in each slice
# or else, weighted by the mean of `meanmat`.
if(length(reorder) > 1) {
weight = tapply(reorder, cl, mean)
} else {
weight = colMeans(meanmat)
}
hc = as.hclust(reorder(as.dendrogram(hc), weight, mean))
cl2 = numeric(length(cl))
for(i in seq_along(hc$order)) {
cl2[cl == hc$order[i]] = i
}
cl2 = factor(cl2, levels = seq_along(hc$order))
if(is.null(split)) {
split = data.frame(cl2)
} else if(is.matrix(split)) {
split = as.data.frame(split)
split = cbind(cl2, split)
} else if(is.null(ncol(split))) {
split = data.frame(cl2, split)
} else {
split = cbind(cl2, split)
}
if(verbose) qqcat("apply k-means (@{km} groups) on @{which}s, append to the `split` data frame\n")
}
# split the original order into a list according to split
order_list = list()
if(is.null(split)) {
order_list[[1]] = order
} else {
if(verbose) cat("process `split` data frame\n")
if(is.null(ncol(split))) split = data.frame(split)
if(is.matrix(split)) split = as.data.frame(split)
for(i in seq_len(ncol(split))) {
if(is.numeric(split[[i]])) {
split[[i]] = factor(as.character(split[[i]]), levels = as.character(sort(unique(split[[i]]))))
} else if(!is.factor(split[[i]])) {
split[[i]] = factor(split[[i]])
} else {
# re-factor
split[[i]] = factor(split[[i]], levels = intersect(levels(split[[i]]), unique(split[[i]])))
}
}
split_name = apply(as.matrix(split), 1, paste, collapse = ",")
order2 = do.call("order", split)
level = unique(split_name[order2])
for(k in seq_along(level)) {
l = split_name == level[k]
order_list[[k]] = intersect(order, which(l))
}
names(order_list) = level
}
# make dend in each slice
if(cluster) {
if(verbose) qqcat("apply clustering on each slice (@{length(order_list)} slices)\n")
dend_list = rep(list(NULL), length(order_list))
for(i in seq_along(order_list)) {
if(which == "row") {
submat = mat[ order_list[[i]], , drop = FALSE]
} else {
submat = mat[, order_list[[i]], drop = FALSE]
}
nd = 0
if(which == "row") nd = nrow(submat) else nd = ncol(submat)
if(nd > 1) {
if(!is.null(dend_param$fun)) {
if(which == "row") {
obj = dend_param$fun(submat)
} else {
obj = dend_param$fun(t(submat))
}
if(inherits(obj, "dendrogram") || inherits(obj, "hclust")) {
dend_list[[i]] = obj
} else {
oe = try(obj <- as.dendrogram(obj), silent = TRUE)
if(inherits(oe, "try-error")) {
stop_wrap("the clustering function must return a `dendrogram` object or a object that can be coerced to `dendrogram` class.")
}
dend_list[[i]] = obj
}
order_list[[i]] = order_list[[i]][ get_dend_order(dend_list[[i]]) ]
} else {
if(which == "row") {
dend_list[[i]] = hclust(get_dist(submat, distance), method = method)
} else {
dend_list[[i]] = hclust(get_dist(t(submat), distance), method = method)
}
order_list[[i]] = order_list[[i]][ get_dend_order(dend_list[[i]]) ]
#}
}
} else {
# a dendrogram with one leaf
dend_list[[i]] = structure(1, members = 1, height = 0, leaf = TRUE, class = "dendrogram")
order_list[[i]] = order_list[[i]][1]
}
}
names(dend_list) = names(order_list)
for(i in seq_along(dend_list)) {
if(inherits(dend_list[[i]], "hclust")) {
dend_list[[i]] = as.dendrogram(dend_list[[i]])
}
}
if(identical(reorder, NULL)) {
if(is.numeric(mat)) {
reorder = TRUE
} else {
reorder = FALSE
}
}
do_reorder = TRUE
if(identical(reorder, NA) || identical(reorder, FALSE)) {
do_reorder = FALSE
}
if(identical(reorder, TRUE)) {
do_reorder = TRUE
if(which == "row") {
reorder = -rowMeans(mat, na.rm = TRUE)
} else {
reorder = -colMeans(mat, na.rm = TRUE)
}
}
if(do_reorder) {
if(which == "row") {
if(length(reorder) != nrow(mat)) {
stop_wrap("weight of reordering should have same length as number of rows\n")
}
} else {
if(length(reorder) != ncol(mat)) {
stop_wrap("weight of reordering should have same length as number of columns\n")
}
}
for(i in seq_along(dend_list)) {
if(length(order_list[[i]]) > 1) {
sub_ind = sort(order_list[[i]])
dend_list[[i]] = reorder(dend_list[[i]], reorder[sub_ind], mean)
order_list[[i]] = sub_ind[ order.dendrogram(dend_list[[i]]) ]
}
}
if(verbose) qqcat("reorder dendrograms in each @{which} slice\n")
}
if(length(order_list) > 1 && cluster_slices) {
if(which == "row") {
slice_mean = sapply(order_list, function(ind) colMeans(mat[ind, , drop = FALSE]))
} else {
slice_mean = sapply(order_list, function(ind) rowMeans(mat[, ind, drop = FALSE]))
}
if(!is.matrix(slice_mean)) {
slice_mean = matrix(slice_mean, nrow = 1)
}
dend_slice = as.dendrogram(hclust(dist(t(slice_mean))))
if(verbose) qqcat("perform clustering on mean of @{which} slices\n")
slice_od = order.dendrogram(dend_slice)
order_list = order_list[slice_od]
dend_list = dend_list[slice_od]
}
}
dend_list = lapply(dend_list, adjust_dend_by_x)
slot(object, paste0(which, "_order")) = unlist(order_list)
slot(object, paste0(which, "_order_list")) = order_list
slot(object, paste0(which, "_dend_list")) = dend_list
slot(object, paste0(which, "_dend_param")) = dend_param
slot(object, paste0(which, "_dend_slice")) = dend_slice
object@matrix_param[[ paste0(which, "_split") ]] = split
if(which == "row") {
if(nrow(mat) != length(order)) {
stop_wrap(qq("Number of rows in the matrix are not the same as the length of the cluster or the @{which} orders."))
}
} else {
if(ncol(mat) != length(order)) {
stop_wrap(qq("Number of columns in the matrix are not the same as the length of the cluster or the @{which} orders."))
}
}
# adjust names_param$gp if the length of some elements is the same as slices
for(i in seq_along(names_param$gp)) {
if(length(names_param$gp[[i]]) == length(order_list)) {
gp_temp = NULL
for(j in seq_along(order_list)) {
gp_temp[ order_list[[j]] ] = names_param$gp[[i]][j]
}
names_param$gp[[i]] = gp_temp
}
}
if(!is.null(names_param$anno)) {
names_param$anno@var_env$gp = names_param$gp
}
slot(object, paste0(which, "_names_param")) = names_param
n_slice = length(order_list)
if(length(gap) == 1) {
gap = rep(gap, n_slice)
} else if(length(gap) == n_slice - 1) {
gap = unit.c(gap, unit(0, "mm"))
} else if(length(gap) != n_slice) {
stop_wrap(qq("Length of `gap` should be 1 or number of @{which} slices."))
}
object@matrix_param[[ paste0(which, "_gap") ]] = gap
# adjust title
title = slot(object, paste0(which, "_title"))
if(!is.null(split)) {
if(length(title) == 0 && !is.null(title)) { ## default title
title = names(order_list)
} else if(length(title) == 1) {
if(grepl("%s", title)) {
title = apply(unique(split[order2, , drop = FALSE]), 1, function(x) {
lt = lapply(x, function(x) x)
lt$fmt = title
do.call(sprintf, lt)
})
} else if(grepl("@\\{.+\\}", title)) {
title = apply(unique(split), 1, function(x) {
x = x
envir = environment()
title = get("title")
op = parent.env(envir)
calling_env = object@heatmap_param$calling_env
parent.env(envir) = calling_env
title = GetoptLong::qq(title, envir = envir)
parent.env(envir) = op
return(title)
})
} else if(grepl("\\{.+\\}", title)) {
if(!requireNamespace("glue")) {
stop_wrap("You need to install glue package.")
}
title = apply(unique(split), 1, function(x) {
x = x
envir = environment()
title = get("title")
op = parent.env(envir)
calling_env = object@heatmap_param$calling_env
parent.env(envir) = calling_env
title = glue::glue(title, envir = calling_env)
parent.env(envir) = op
return(title)
})
}
}
}
slot(object, paste0(which, "_title")) = title
return(object)
}
# == title
# Draw a Single Heatmap
#
# == param
# -object A `Heatmap-class` object.
# -internal If ``TRUE``, it is only used inside the calling of `draw,HeatmapList-method`.
# It only draws the heatmap without legends where the legend will be drawn by `draw,HeatmapList-method`.
# -test Only for testing. If it is ``TRUE``, the heatmap body is directly drawn.
# -... Pass to `draw,HeatmapList-method`.
#
# == detail
# The function creates a `HeatmapList-class` object which only contains a single heatmap
# and call `draw,HeatmapList-method` to make the final heatmap.
#
# There are some arguments which control the some settings of the heatmap such as legends.
# Please go to `draw,HeatmapList-method` for these arguments.
#
# == value
# A `HeatmapList-class` object.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
setMethod(f = "draw",
signature = "Heatmap",
definition = function(object, internal = FALSE, test = FALSE, ...) {
if(test) {
object = prepare(object)
grid.newpage()
if(is_abs_unit(object@heatmap_param$width)) {
width = object@heatmap_param$width
} else {
width = 0.8
}
if(is_abs_unit(object@heatmap_param$height)) {
height = object@heatmap_param$height
} else {
height = 0.8
}
pushViewport(viewport(width = width, height = height))
draw(object, internal = TRUE)
upViewport()
} else {
if(internal) { # a heatmap without legend
if(ncol(object@matrix) == 0 || nrow(object@matrix) == 0) return(invisible(NULL))
layout = grid.layout(nrow = length(HEATMAP_LAYOUT_COLUMN_COMPONENT),
ncol = length(HEATMAP_LAYOUT_ROW_COMPONENT), widths = component_width(object),
heights = component_height(object))
pushViewport(viewport(layout = layout))
ht_layout_index = object@layout$layout_index
ht_graphic_fun_list = object@layout$graphic_fun_list
for(j in seq_len(nrow(ht_layout_index))) {
if(HEATMAP_LAYOUT_COLUMN_COMPONENT["heatmap_body"] %in% ht_layout_index[j, 1] &&
HEATMAP_LAYOUT_ROW_COMPONENT["heatmap_body"] %in% ht_layout_index[j, 2]) {
pushViewport(viewport(layout.pos.row = ht_layout_index[j, 1], layout.pos.col = ht_layout_index[j, 2], name = paste(object@name, "heatmap_body_wrap", sep = "_")))
} else {
pushViewport(viewport(layout.pos.row = ht_layout_index[j, 1], layout.pos.col = ht_layout_index[j, 2]))
}
ht_graphic_fun_list[[j]](object)
upViewport()
}
upViewport()
} else {
if(ncol(object@matrix) == 0) {
stop_wrap("Single heatmap should contains a matrix with at least one column. Zero-column matrix can only be appended to the heatmap list.")
}
ht_list = new("HeatmapList")
ht_list = add_heatmap(ht_list, object)
draw(ht_list, ...)
}
}
})
# == title
# Prepare the Heatmap
#
# == param
# -object A `Heatmap-class` object.
# -process_rows Whether to process rows of the heatmap.
# -process_columns Whether to process columns of the heatmap.
#
# == detail
# The preparation of the heatmap includes following steps:
#
# - making clustering on rows (by calling `make_row_cluster,Heatmap-method`)
# - making clustering on columns (by calling `make_column_cluster,Heatmap-method`)
# - making the layout of the heatmap (by calling `make_layout,Heatmap-method`)
#
# This function is only for internal use.
#
# == value
# The `Heatmap-class` object.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
setMethod(f = "prepare",
signature = "Heatmap",
definition = function(object, process_rows = TRUE, process_columns = TRUE) {
if(object@layout$initialized) {
return(object)
}
if(process_rows) {
object = make_row_cluster(object)
}
if(process_columns) {
object = make_column_cluster(object)
}
object = make_layout(object)
return(object)
})
