R/Heatmap-class.R
d1da987e
 
 ###############################
 # class for single heatmap
 #
 
 # == title
3c40a7c1
 # Class for a Single Heatmap
d1da987e
 #
 # == details
 # The `Heatmap-class` is not responsible for heatmap legend and annotation legends. The `draw,Heatmap-method` method
3c40a7c1
 # constructs a `HeatmapList-class` object which only contains one single heatmap
 # and call `draw,HeatmapList-method` to make the complete heatmap.
d1da987e
 #
 # == methods
 # The `Heatmap-class` provides following methods:
 #
 # - `Heatmap`: constructor method.
 # - `draw,Heatmap-method`: draw a single heatmap.
3c40a7c1
 # - `add_heatmap,Heatmap-method` append heatmaps and annotations to a list of heatmaps.
21ca48b4
 # - `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
d1da987e
 #
 # == 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",
d7a3c7af
         matrix_legend_param = "ANY",
d1da987e
 
07250638
         row_title = "ANY",
d1da987e
         row_title_param = "list",
07250638
         column_title = "ANY",
d1da987e
         column_title_param = "list",
 
12e85497
         row_dend_list = "list", # one or more row clusters
d7a3c7af
         row_dend_slice = "ANY",
12e85497
         row_dend_param = "list", # parameters for row cluster
d1da987e
         row_order_list = "list",
f0eb7a9f
         row_order = "numeric",
d1da987e
 
d7a3c7af
         column_dend_list = "list",
         column_dend_slice = "ANY",
12e85497
         column_dend_param = "list", # parameters for column cluster
d7a3c7af
         column_order_list = "list",
d1da987e
         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",
e27480b9
         left_annotation = "ANY", # NULL or a `HeatmapAnnotation` object
         left_annotation_param = "list",
         right_annotation = "ANY",
         right_annotation_param = "list",
d1da987e
 
         heatmap_param = "list",
 
         layout = "list"
     ),
     contains = "AdditiveUnit"
 )
 
 
 
 # == title
 # Constructor method for Heatmap class
 #
 # == param
3c40a7c1
 # -matrix A matrix. Either numeric or character. If it is a simple vector, it will be
d1da987e
 #         converted to a one-column matrix.
3c40a7c1
 # -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 
451e6d73
 #            ``col`` is a vector of colors. Pass to `circlize::colorRamp2`.
3c40a7c1
 # -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,
c1ecc265
 #           the width and height of the cell and the filled color. ``x``, ``y``, ``width`` and ``height`` are all `grid::unit` objects.
3c40a7c1
 # -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 .
5e6b381e
 # -cluster_row_slices If rows are split into slices, whether perform clustering on the slice means?
3c40a7c1
 # -clustering_distance_rows It can be a pre-defined character which is in 
d1da987e
 #                ("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.
3c40a7c1
 # -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`
d1da987e
 #                object with edges rendered, this argument will be ignored.
3c40a7c1
 # -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``.
5e6b381e
 # -cluster_column_slices If columns are split into slices, whether perform clustering on the slice means?
3c40a7c1
 # -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?
12e85497
 # -column_dend_height height of the column cluster, should be a `grid::unit` object.
3c40a7c1
 # -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.
9c4d56c4
 # -row_names_centered Should row names put centered?
3c40a7c1
 # -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.
9c4d56c4
 # -column_names_centered Should column names put centered?
3c40a7c1
 # -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``.
edfce525
 # -row_km_repeats Number of k-means runs to get a consensus k-means clustering. Note if ``row_km_repeats`` is set to more than one, the final number
 #                of groups might be smaller than ``row_km``, but this might means the original ``row_km`` is not a good choice.
3c40a7c1
 # -row_split Same as ``split``.
 # -column_km K-means clustering on columns.
edfce525
 # -column_km_repeats Number of k-means runs to get a consensus k-means clustering. Similar as ``row_km_repeats``.
3c40a7c1
 # -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.
fcefb322
 # -show_parent_dend_line When heatmap is split, whether to add a dashed line to mark parent dendrogram and children dendrograms?
3c40a7c1
 # -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``
9487d939
 #       is set, ``use_raster`` is enforced to be ``FALSE``.
3c40a7c1
 # -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 .
c959e0e1
 # -raster_resize Whether resize the matrix to let the dimension of the matrix the same as the dimension of the raster image?
3c40a7c1
 # -post_fun A function which will be executed after the heatmap list is drawn.
d1da987e
 #
 # == details
3c40a7c1
 # The initialization function only applies parameter checking and fill values to the slots with some validation.
d1da987e
 # 
3c40a7c1
 # Following methods can be applied to the `Heatmap-class` object:
d1da987e
 #
 # - `show,Heatmap-method`: draw a single heatmap with default parameters
 # - `draw,Heatmap-method`: draw a single heatmap.
3c40a7c1
 # - ``+`` or `\%v\%` append heatmaps and annotations to a list of heatmaps.
d1da987e
 #
 # The constructor function pretends to be a high-level graphic function because the ``show`` method
 # of the `Heatmap-class` object actually plots the graphics.
 #
3c40a7c1
 # == seealso
 # https://jokergoo.github.io/ComplexHeatmap-reference/book/a-single-heatmap.html
 #
d1da987e
 # == value
 # A `Heatmap-class` object.
 #
 # == author
 # Zuguang Gu <z.gu@dkfz.de>
 #
12e85497
 Heatmap = function(matrix, col, name, 
     na_col = "grey", 
     color_space = "LAB",
     rect_gp = gpar(col = NA), 
d7a3c7af
     border = NA,
9487d939
     cell_fun = NULL,
30d2c5b2
     layer_fun = NULL,
d7a3c7af
 
12e85497
     row_title = character(0), 
     row_title_side = c("left", "right"), 
b08d7ba4
     row_title_gp = gpar(fontsize = 14), 
     row_title_rot = switch(row_title_side[1], "left" = 90, "right" = 270),
12e85497
     column_title = character(0), 
     column_title_side = c("top", "bottom"), 
     column_title_gp = gpar(fontsize = 14), 
     column_title_rot = 0,
d7a3c7af
 
12e85497
     cluster_rows = TRUE, 
5e6b381e
     cluster_row_slices = TRUE,
12e85497
     clustering_distance_rows = "euclidean",
     clustering_method_rows = "complete", 
     row_dend_side = c("left", "right"),
     row_dend_width = unit(10, "mm"), 
     show_row_dend = TRUE, 
f0a25823
     row_dend_reorder = is.logical(cluster_rows) || is.function(cluster_rows),
12e85497
     row_dend_gp = gpar(), 
     cluster_columns = TRUE, 
5e6b381e
     cluster_column_slices = TRUE,
12e85497
     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(), 
f0a25823
     column_dend_reorder = is.logical(cluster_columns) || is.function(cluster_columns),
d7a3c7af
 
12e85497
     row_order = NULL, 
     column_order = NULL,
d7a3c7af
 
     row_labels = rownames(matrix),
12e85497
     row_names_side = c("right", "left"), 
     show_row_names = TRUE, 
d7a3c7af
     row_names_max_width = unit(6, "cm"), 
12e85497
     row_names_gp = gpar(fontsize = 12), 
d7a3c7af
     row_names_rot = 0,
9c4d56c4
     row_names_centered = FALSE,
d7a3c7af
     column_labels = colnames(matrix),
d1da987e
     column_names_side = c("bottom", "top"), 
12e85497
     show_column_names = TRUE, 
d7a3c7af
     column_names_max_height = unit(6, "cm"), 
d1da987e
     column_names_gp = gpar(fontsize = 12),
d7a3c7af
     column_names_rot = 90,
9c4d56c4
     column_names_centered = FALSE,
d7a3c7af
 
402ff791
     top_annotation = NULL,
     bottom_annotation = NULL,
e27480b9
     left_annotation = NULL,
     right_annotation = NULL,
d7a3c7af
 
12e85497
     km = 1, 
     split = NULL, 
d7a3c7af
     row_km = km,
9c4d56c4
     row_km_repeats = 1,
d7a3c7af
     row_split = split,
261bfec2
     column_km = 1,
9c4d56c4
     column_km_repeats = 1,
261bfec2
     column_split = NULL,
6849ddae
     gap = unit(1, "mm"),
     row_gap = unit(1, "mm"),
     column_gap = unit(1, "mm"),
f0a25823
     show_parent_dend_line = ht_opt$show_parent_dend_line,
d7a3c7af
 
da78b5d8
     heatmap_width = unit(1, "npc"),
     width = NULL,
     heatmap_height = unit(1, "npc"), 
     height = NULL,
d7a3c7af
 
12e85497
     show_heatmap_legend = TRUE,
0623db7b
     heatmap_legend_param = list(title = name),
d7a3c7af
 
90241921
     use_raster = (nrow(matrix) > 2000 && ncol(matrix) > 1) || (ncol(matrix) > 2000 && nrow(matrix) > 1), 
d43848ac
     raster_device = c("png", "jpeg", "tiff", "CairoPNG", "CairoJPEG", "CairoTIFF"),
e98226a4
     raster_quality = 2,
ad35494a
     raster_device_param = list(),
c959e0e1
     raster_resize = FALSE,
ad35494a
 
     post_fun = NULL) {
5ab2cb81
 
04a1dc38
     dev.null()
     on.exit(dev.off2())
 
1ee53830
     verbose = ht_opt("verbose")
d7a3c7af
 
     .Object = new("Heatmap")
     if(missing(name)) {
         name = paste0("matrix_", get_heatmap_index() + 1)
         increase_heatmap_index()
     }
     .Object@name = name
 
5ab2cb81
     # 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
1ee53830
             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))
5ab2cb81
             }
         }
     }
12e85497
 
41afe8bf
     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")
     }
 
5ab2cb81
     if("heatmap_legend_param" %in% called_args) {
450fb543
         for(opt_name in setdiff(c("title_gp", "title_position", "labels_gp", "grid_width", "grid_height", "border"), names(heatmap_legend_param))) {
1ee53830
             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)
5ab2cb81
         }
     } else {
450fb543
         for(opt_name in c("title_gp", "title_position", "labels_gp", "grid_width", "grid_height", "border")) {
1ee53830
             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)
5ab2cb81
         }
     }
d1da987e
 
     if(is.data.frame(matrix)) {
d7a3c7af
         if(verbose) qqcat("convert data frame to matrix\n")
d1dbdc08
         warning_wrap("The input is a data frame, convert it to the matrix.")
d1da987e
         matrix = as.matrix(matrix)
     }
     if(!is.matrix(matrix)) {
         if(is.atomic(matrix)) {
66256418
             rn = names(matrix)
             matrix = matrix(matrix, ncol = 1)
             if(!is.null(rn)) rownames(matrix) = rn
             if(!missing(name)) colnames(matrix) = name
d7a3c7af
             if(verbose) qqcat("convert simple vector to one-column matrix\n")
d1da987e
         } else {
d1dbdc08
             stop_wrap("If input is not a matrix, it should be a simple vector.")
d1da987e
         }
     }
 
     if(ncol(matrix) == 0) {
e392c692
         show_heatmap_legend = FALSE
d1da987e
         .Object@heatmap_param$show_heatmap_legend = FALSE
     }
e392c692
     if(identical(rect_gp$type, "none")) {
         show_heatmap_legend = FALSE
     }
d1da987e
 
d7a3c7af
     ### normalize km/split and row_km/row_split
     if(missing(row_km)) row_km = km
0006b005
     if(is.null(row_km)) row_km = 1
d7a3c7af
     if(missing(row_split)) row_split = split
     if(missing(row_gap)) row_gap = gap
0006b005
     if(is.null(column_km)) column_km = 1
d7a3c7af
 
     ####### zero and one column matrix ########
076c1ff2
     if(ncol(matrix) == 0 || nrow(matrix) == 0) {
         if(!inherits(cluster_columns, c("dendrogram", "hclust"))) {
             cluster_columns = FALSE
12e85497
             show_column_dend = FALSE
076c1ff2
         }
d3ce90c5
         if(!inherits(cluster_rows, c("dendrogram", "hclust"))) {
             cluster_rows = FALSE
12e85497
             show_row_dend = FALSE
d3ce90c5
         }
d7a3c7af
         row_km = 1
         column_km = 1
         if(verbose) qqcat("zero row/column matrix, set cluster_columns/rows to FALSE\n")
076c1ff2
     }
     if(ncol(matrix) == 1) {
d3ce90c5
         if(!inherits(cluster_columns, c("dendrogram", "hclust"))) {
             cluster_columns = FALSE
12e85497
             show_column_dend = FALSE
d3ce90c5
         }
d7a3c7af
         column_km = 1
         if(verbose) qqcat("one-column matrix, set cluster_columns to FALSE\n")
076c1ff2
     }
     if(nrow(matrix) == 1) {
         if(!inherits(cluster_rows, c("dendrogram", "hclust"))) {
             cluster_rows = FALSE
12e85497
             show_row_dend = FALSE
076c1ff2
         }
d7a3c7af
         row_km = 1
         if(verbose) qqcat("one-row matrix, set cluster_rows to FALSE\n")
d1da987e
     }
d7a3c7af
 
5ab2cb81
     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
12e85497
             show_row_dend = FALSE
5ab2cb81
         }
12e85497
         row_dend_reorder = FALSE
69345c7d
         cluster_row_slices = FALSE
d7a3c7af
 
5ab2cb81
         if("clustering_distance_columns" %in% called_args) {
         } else if(inherits(cluster_columns, c("dendrogram", "hclust"))) {
         } else {
             cluster_columns = FALSE
12e85497
             show_column_dend = FALSE
5ab2cb81
         }
12e85497
         column_dend_reorder = FALSE
69345c7d
         cluster_column_slices = FALSE
d7a3c7af
         row_km = 1
         column_km = 1
         if(verbose) qqcat("matrix is character. Do not cluster unless distance method is provided.\n")
5ab2cb81
     }
d1da987e
     .Object@matrix = matrix
261bfec2
 
d7a3c7af
     .Object@matrix_param$row_km = row_km
de656d42
     .Object@matrix_param$row_km_repeats = row_km_repeats
d7a3c7af
     .Object@matrix_param$row_gap = row_gap
     .Object@matrix_param$column_km = column_km
de656d42
     .Object@matrix_param$column_km_repeats = column_km_repeats
d7a3c7af
     .Object@matrix_param$column_gap = column_gap
 
     ### check row_split and column_split ###
     if(!is.null(row_split)) {
07961c65
         if(inherits(cluster_rows, c("dendrogram", "hclust"))) {
d1dbdc08
             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.")
             }
07961c65
         } else {
d7a3c7af
             if(identical(cluster_rows, TRUE) && is.numeric(row_split) && length(row_split) == 1) {
dc0f5a96
 
             } else {
d7a3c7af
                 if(!is.data.frame(row_split)) row_split = data.frame(row_split)
                 if(nrow(row_split) != nrow(matrix)) {
d1dbdc08
                     stop_wrap("Length or nrow of `row_split` should be same as nrow of `matrix`.")
dc0f5a96
                 }
07961c65
             }
d1da987e
         }
     }
d7a3c7af
     .Object@matrix_param$row_split = row_split
261bfec2
 
     if(!is.null(column_split)) {
         if(inherits(cluster_columns, c("dendrogram", "hclust"))) {
d1dbdc08
             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.")
             }
261bfec2
         } 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)
d7a3c7af
                 if(nrow(column_split) != ncol(matrix)) {
6f036283
                     stop_wrap("Length or ncol of `column_split` should be same as ncol of `matrix`.")
261bfec2
                 }
             }
         }
     }
     .Object@matrix_param$column_split = column_split
 
d7a3c7af
 
     ### parameters for heatmap body ###
     .Object@matrix_param$gp = check_gp(rect_gp)
450fb543
     if(missing(border)) {
         if(!is.null(ht_opt$heatmap_border)) border = ht_opt$heatmap_border
     }
d7a3c7af
     if(identical(border, TRUE)) border = "black"
     .Object@matrix_param$border = border
d1da987e
     .Object@matrix_param$cell_fun = cell_fun
30d2c5b2
     .Object@matrix_param$layer_fun = layer_fun
d1da987e
     
d7a3c7af
     ### color for main matrix #########
076c1ff2
     if(ncol(matrix) > 0 && nrow(matrix) > 0) {
d1da987e
         if(missing(col)) {
             col = default_col(matrix, main_matrix = TRUE)
d7a3c7af
             if(verbose) qqcat("color is not specified, use randomly generated colors\n")
d1da987e
         }
         if(is.function(col)) {
5ab2cb81
             .Object@matrix_color_mapping = ColorMapping(col_fun = col, name = name, na_col = na_col)
d7a3c7af
             if(verbose) qqcat("input color is a color mapping function\n")
d1da987e
         } else {
             if(is.null(names(col))) {
ac4a2fca
                 if(length(col) == length(unique(as.vector(matrix)))) {
8f2031d2
                     names(col) = sort(unique(as.vector(matrix)))
5ab2cb81
                     .Object@matrix_color_mapping = ColorMapping(colors = col, name = name, na_col = na_col)
d7a3c7af
                     if(verbose) qqcat("input color is a vector with no names, treat it as discrete color mapping\n")
442fa1bd
                 } else if(is.numeric(matrix)) {
                     col = colorRamp2(seq(min(matrix, na.rm = TRUE), max(matrix, na.rm = TRUE), length = length(col)),
451e6d73
                                      col, space = color_space)
5ab2cb81
                     .Object@matrix_color_mapping = ColorMapping(col_fun = col, name = name, na_col = na_col)
d7a3c7af
                     if(verbose) qqcat("input color is a vector with no names, treat it as continuous color mapping\n")
d1da987e
                 } else {
c4a66bf9
                     stop_wrap("`col` should have names to map to values in `mat`.")
d1da987e
                 }
442fa1bd
             } else {
729b7f3f
                 col = col[intersect(c(names(col), "_NA_"), as.character(matrix))]
5ab2cb81
                 .Object@matrix_color_mapping = ColorMapping(colors = col, name = name, na_col = na_col)
d7a3c7af
                 if(verbose) qqcat("input color is a named vector\n")
d1da987e
             }
         }
d7a3c7af
         .Object@matrix_legend_param = heatmap_legend_param
d1da987e
     }
     
d7a3c7af
     ##### titles, should also consider titles after row splitting #####
c4a66bf9
     if(identical(row_title, NA) || identical(row_title, "")) {
         row_title = character(0)
d1da987e
     }
     .Object@row_title = row_title
d7a3c7af
     .Object@row_title_param$rot = row_title_rot %% 360
d1da987e
     .Object@row_title_param$side = match.arg(row_title_side)[1]
12e85497
     .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`
d7a3c7af
     .Object@row_title_param$just = get_text_just(rot = row_title_rot, side = .Object@row_title_param$side)
d1da987e
 
c4a66bf9
     if(identical(column_title, NA) || identical(column_title, "")) {
         column_title = character(0)
d1da987e
     }
     .Object@column_title = column_title
d7a3c7af
     .Object@column_title_param$rot = column_title_rot %% 360
d1da987e
     .Object@column_title_param$side = match.arg(column_title_side)[1]
     .Object@column_title_param$gp = check_gp(column_title_gp)
d7a3c7af
     .Object@column_title_param$just = get_text_just(rot = column_title_rot, side = .Object@column_title_param$side)
d1da987e
 
d7a3c7af
     ### row labels/column labels ###
d1da987e
     if(is.null(rownames(matrix))) {
         show_row_names = FALSE
     }
d7a3c7af
     .Object@row_names_param$labels = row_labels
d1da987e
     .Object@row_names_param$side = match.arg(row_names_side)[1]
     .Object@row_names_param$show = show_row_names
acb6c95b
     .Object@row_names_param$gp = check_gp(row_names_gp)
d7a3c7af
     .Object@row_names_param$rot = row_names_rot
9c4d56c4
     .Object@row_names_param$centered = row_names_centered
d1da987e
     .Object@row_names_param$max_width = row_names_max_width + unit(2, "mm")
d7a3c7af
     # we use anno_text to draw row/column names because it already takes care of text rotation
699db0a0
     if(show_row_names) {
c4a66bf9
         if(length(row_labels) != nrow(matrix)) {
             stop_wrap("Length of `row_labels` should be the same as the nrow of matrix.")
         }
9c4d56c4
         if(row_names_centered) {
             row_names_anno = anno_text(row_labels, which = "row", gp = row_names_gp, rot = row_names_rot,
                 location = 0.5, 
                 just = "center")
         } else {
             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"))
         }
d7a3c7af
         .Object@row_names_param$anno = row_names_anno
     }
d1da987e
 
     if(is.null(colnames(matrix))) {
         show_column_names = FALSE
     }
d7a3c7af
     .Object@column_names_param$labels = column_labels
d1da987e
     .Object@column_names_param$side = match.arg(column_names_side)[1]
     .Object@column_names_param$show = show_column_names
acb6c95b
     .Object@column_names_param$gp = check_gp(column_names_gp)
d7a3c7af
     .Object@column_names_param$rot = column_names_rot
9c4d56c4
     .Object@column_names_param$centered = column_names_centered
d1da987e
     .Object@column_names_param$max_height = column_names_max_height + unit(2, "mm")
699db0a0
     if(show_column_names) {
c4a66bf9
         if(length(column_labels) != ncol(matrix)) {
             stop_wrap("Length of `column_labels` should be the same as the ncol of matrix.")
         }
9c4d56c4
         if(column_names_centered) {
             column_names_anno = anno_text(column_labels, which = "column", gp = column_names_gp, rot = column_names_rot,
             location = 0.5, 
             just = "center")
         } else {
             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")
                         ))
         }
d7a3c7af
         .Object@column_names_param$anno = column_names_anno
     }
d1da987e
 
d7a3c7af
     #### dendrograms ########
     if(missing(cluster_rows) && !missing(row_order)) {
         cluster_rows = FALSE
     }
fcefb322
     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")) {
12e85497
         .Object@row_dend_param$obj = cluster_rows
         .Object@row_dend_param$cluster = TRUE
d1da987e
     } else if(inherits(cluster_rows, "function")) {
12e85497
         .Object@row_dend_param$fun = cluster_rows
         .Object@row_dend_param$cluster = TRUE
d1da987e
     } else {
fcefb322
         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.")
d1da987e
         }
     }
12e85497
     if(!show_row_dend) {
         row_dend_width = unit(0, "mm")
d1da987e
     }
12e85497
     .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]
450fb543
     .Object@row_dend_param$width = row_dend_width + ht_opt$DENDROGRAM_PADDING  # append the gap
12e85497
     .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
f0eb7a9f
     .Object@row_order_list = list() # default order
842872cc
     if(is.null(row_order)) {
f0eb7a9f
         .Object@row_order = seq_len(nrow(matrix))
     }  else {
07961c65
         if(is.character(row_order)) {
             row_order = structure(seq_len(nrow(matrix)), names = rownames(matrix))[row_order]
         }
138dc569
         if(any(is.na(row_order))) {
             stop_wrap("`row_order` should not contain NA values.")
         }
         if(length(row_order) != nrow(matrix)) {
             stop_wrap("length of `row_order` should be same as the number of marix rows.")
         }
f0eb7a9f
         .Object@row_order = row_order
842872cc
     }
5e6b381e
     .Object@row_dend_param$cluster_slices = cluster_row_slices
d1da987e
 
d7a3c7af
     if(missing(cluster_columns) && !missing(column_order)) {
         cluster_columns = FALSE
     }
fcefb322
     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")) {
12e85497
         .Object@column_dend_param$obj = cluster_columns
         .Object@column_dend_param$cluster = TRUE
d1da987e
     } else if(inherits(cluster_columns, "function")) {
12e85497
         .Object@column_dend_param$fun = cluster_columns
         .Object@column_dend_param$cluster = TRUE
d1da987e
     } else {
fcefb322
         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.")
d1da987e
         }
     }
12e85497
     if(!show_column_dend) {
         column_dend_height = unit(0, "mm")
d1da987e
     }
d7a3c7af
     .Object@column_dend_list = list()
12e85497
     .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]
450fb543
     .Object@column_dend_param$height = column_dend_height + ht_opt$DENDROGRAM_PADDING  # append the gap
12e85497
     .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
842872cc
     if(is.null(column_order)) {
         .Object@column_order = seq_len(ncol(matrix))
     } else {
07961c65
         if(is.character(column_order)) {
             column_order = structure(seq_len(ncol(matrix)), names = colnames(matrix))[column_order]
         }
138dc569
         if(any(is.na(column_order))) {
             stop_wrap("`column_order` should not contain NA values.")
         }
         if(length(column_order) != ncol(matrix)) {
             stop_wrap("length of `column_order` should be same as the number of marix columns")
         }
842872cc
         .Object@column_order = column_order
     }
5e6b381e
     .Object@column_dend_param$cluster_slices = cluster_column_slices
d1da987e
 
d7a3c7af
     ######### annotations #############
d1da987e
     .Object@top_annotation = top_annotation # a `HeatmapAnnotation` object
     if(is.null(top_annotation)) {
076c1ff2
         .Object@top_annotation_param$height = unit(0, "mm")    
d1da987e
     } else {
450fb543
         .Object@top_annotation_param$height = height(top_annotation) + ht_opt$COLUMN_ANNO_PADDING  # append the gap
d1da987e
     }
     if(!is.null(top_annotation)) {
402ff791
         if(length(top_annotation) > 0) {
d1da987e
             if(!.Object@top_annotation@which == "column") {
c4a66bf9
                 stop_wrap("`which` in `top_annotation` should only be `column`.")
d1da987e
             }
         }
402ff791
         nb = nobs(top_annotation)
         if(!is.na(nb)) {
             if(nb != ncol(.Object@matrix)) {
c4a66bf9
                 stop_wrap("number of observations in top annotation should be as same as ncol of the matrix.")
402ff791
             }
         }
d1da987e
     }
     
     .Object@bottom_annotation = bottom_annotation # a `HeatmapAnnotation` object
     if(is.null(bottom_annotation)) {
076c1ff2
         .Object@bottom_annotation_param$height = unit(0, "mm")
d1da987e
     } else {
450fb543
         .Object@bottom_annotation_param$height = height(bottom_annotation) + ht_opt$COLUMN_ANNO_PADDING  # append the gap
d1da987e
     }
     if(!is.null(bottom_annotation)) {
402ff791
         if(length(bottom_annotation) > 0) {
d1da987e
             if(!.Object@bottom_annotation@which == "column") {
c4a66bf9
                 stop_wrap("`which` in `bottom_annotation` should only be `column`.")
d1da987e
             }
         }
402ff791
         nb = nobs(bottom_annotation)
         if(!is.na(nb)) {
             if(nb != ncol(.Object@matrix)) {
c4a66bf9
                 stop_wrap("number of observations in bottom anntotion should be as same as ncol of the matrix.")
402ff791
             }
         }
d1da987e
     }
 
e27480b9
     .Object@left_annotation = left_annotation # a `rowAnnotation` object
     if(is.null(left_annotation)) {
         .Object@left_annotation_param$width = unit(0, "mm")
     } else {
450fb543
         .Object@left_annotation_param$width = width(left_annotation) + ht_opt$ROW_ANNO_PADDING  # append the gap
e27480b9
     }
     if(!is.null(left_annotation)) {
         if(length(left_annotation) > 0) {
             if(!.Object@left_annotation@which == "row") {
c4a66bf9
                 stop_wrap("`which` in `left_annotation` should only be `row`, or consider using `rowAnnotation()`.")
e27480b9
             }
         }
         nb = nobs(left_annotation)
         if(!is.na(nb)) {
30d2c5b2
             if(nb != nrow(.Object@matrix)) {
c4a66bf9
                 stop_wrap("number of observations in left anntotion should be same as nrow of the matrix.")
e27480b9
             }
         }
     }
 
     .Object@right_annotation = right_annotation # a `rowAnnotation` object
     if(is.null(right_annotation)) {
         .Object@right_annotation_param$width = unit(0, "mm")
     } else {
450fb543
         .Object@right_annotation_param$width = width(right_annotation) + ht_opt$ROW_ANNO_PADDING  # append the gap
e27480b9
     }
     if(!is.null(right_annotation)) {
         if(length(right_annotation) > 0) {
             if(!.Object@right_annotation@which == "row") {
c4a66bf9
                 stop_wrap("`which` in `right_annotation` should only be `row`, or consider using `rowAnnotation()`.")
e27480b9
             }
         }
         nb = nobs(right_annotation)
         if(!is.na(nb)) {
30d2c5b2
             if(nb != nrow(.Object@matrix)) {
c4a66bf9
                 stop_wrap("number of observations in right anntotion should be same as nrow of the matrix.")
e27480b9
             }
         }
     }
 
d1da987e
     .Object@layout = list(
d7a3c7af
         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"),
e27480b9
             row_title_right_width = unit(0, "mm"),
             row_anno_left_width = unit(0, "mm"),
             row_anno_right_width = unit(0, "mm")
d7a3c7af
         ),
 
e27480b9
         layout_index = NULL,
933e808c
         graphic_fun_list = list(),
         initialized = FALSE
d1da987e
     )
 
c4a66bf9
     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
 
da78b5d8
     .Object@heatmap_param$width = heatmap_width
     .Object@heatmap_param$height = heatmap_height
d7a3c7af
     .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
c959e0e1
     .Object@heatmap_param$raster_resize = raster_resize
d7a3c7af
     .Object@heatmap_param$verbose = verbose
ad35494a
     .Object@heatmap_param$post_fun = post_fun
90241921
     .Object@heatmap_param$calling_env = parent.frame()
f0a25823
     .Object@heatmap_param$show_parent_dend_line = show_parent_dend_line
d7a3c7af
 
30d2c5b2
     if(nrow(matrix) == 0) {
         .Object@matrix_param$height = unit(0, "mm")
     }
     if(ncol(matrix) == 0) {
         .Object@matrix_param$width = unit(0, "mm")
     }
 
d1da987e
     return(.Object)
 
 }
 
 
 # == title
e27480b9
 # Make Cluster on Rows
d1da987e
 #
 # == param
e27480b9
 # -object A `Heatmap-class` object.
d1da987e
 #
 # == details
12e85497
 # The function will fill or adjust ``row_dend_list``, ``row_order_list``, ``row_title`` and ``matrix_param`` slots.
d1da987e
 #
 # 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",
f0eb7a9f
     definition = function(object) {
d1da987e
 
c4a66bf9
     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)  
d7a3c7af
 })
 
ad35494a
 # == title
 # Make Cluster on Columns
 #
 # == param
 # -object A `Heatmap-class` object.
 #
 # == details
1a56796e
 # The function will fill or adjust ``column_dend_list``,
 # ``column_order_list``, ``column_title`` and ``matrix_param`` slots.
ad35494a
 #
 # 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>
 #
d7a3c7af
 setMethod(f = "make_column_cluster",
     signature = "Heatmap",
     definition = function(object) {
 
c4a66bf9
     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)
d7a3c7af
 })
 
 make_cluster = function(object, which = c("row", "column")) {
 
     which = match.arg(which)[1]
 
     verbose = object@heatmap_param$verbose
 
1ee53830
     if(ht_opt("fast_hclust")) {
f6325167
         hclust = fastcluster::hclust
d7a3c7af
         if(verbose) qqcat("apply hclust by fastcluster::hclust\n")
f6325167
     } else {
         hclust = stats::hclust
     }
 
d1da987e
     mat = object@matrix
d7a3c7af
     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"))
de656d42
     km_repeats = getElement(object@matrix_param, paste0(which, "_km_repeats"))
d7a3c7af
     split = getElement(object@matrix_param, paste0(which, "_split"))
     reorder = slot(object, paste0(which, "_dend_param"))$reorder
     cluster = slot(object, paste0(which, "_dend_param"))$cluster
5e6b381e
     cluster_slices = slot(object, paste0(which, "_dend_param"))$cluster_slices
d7a3c7af
     gap = getElement(object@matrix_param, paste0(which, "_gap"))
d1da987e
 
d7a3c7af
     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"))
 
6f036283
     dend_param$split_by_cutree = FALSE
 
d7a3c7af
     if(cluster) {
d1da987e
 
dc0f5a96
         if(is.numeric(split) && length(split) == 1) {
d7a3c7af
             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)
                 }
dc0f5a96
             }
         }
 
d7a3c7af
         if(!is.null(dend_param$obj)) {
d1da987e
             if(km > 1) {
c4a66bf9
                 stop_wrap("You can not perform k-means clustering since you have already specified a clustering object.")
d1da987e
             }
1fbe74a6
 
d7a3c7af
             if(inherits(dend_param$obj, "hclust")) {
                 dend_param$obj = as.dendrogram(dend_param$obj)
                 if(verbose) qqcat("convert hclust object to dendrogram object\n")
1fbe74a6
             }
 
07961c65
             if(is.null(split)) {
d7a3c7af
                 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")
07961c65
             } else {
                 if(length(split) > 1 || !is.numeric(split)) {
c4a66bf9
                     stop_wrap(qq("Since you specified a clustering object, you can only split @{which}s by providing a number (number of @{which} slices)."))
07961c65
                 }
                 if(split < 2) {
6f036283
                     stop_wrap(qq("`@{which}_split` should be >= 2."))
07961c65
                 }
6f036283
                 dend_param$split_by_cutree = TRUE
1fbe74a6
                 
d7a3c7af
                 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)), 
07961c65
                     function(x) x)
                 attributes(sth) = NULL
d7a3c7af
                 order_list = sth
                 if(verbose) qqcat("cut @{which} dendrogram into @{split} slices.\n")
d1da987e
             }
1fbe74a6
 
d7a3c7af
             ### do reordering if specified
1fbe74a6
             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
d7a3c7af
                 if(which == "row") {
                     reorder = -rowMeans(mat, na.rm = TRUE)
                 } else {
                     reorder = -colMeans(mat, na.rm = TRUE)
                 }
1fbe74a6
             }
 
             if(do_reorder) {
 
d7a3c7af
                 if(which == "row") {
                     if(length(reorder) != nrow(mat)) {
c4a66bf9
                         stop_wrap("weight of reordering should have same length as number of rows.\n")
d7a3c7af
                     }
                 } else {
                     if(length(reorder) != ncol(mat)) {
c4a66bf9
                         stop_wrap("weight of reordering should have same length as number of columns\n")
d7a3c7af
                     }
                 }
                 
                 for(i in seq_along(dend_list)) {
                     if(length(order_list[[i]]) > 1) {
                         sub_ind = sort(order_list[[i]])
f0a25823
                         dend_list[[i]] = reorder(dend_list[[i]], reorder[sub_ind], mean)
d7a3c7af
                         # the order of object@row_dend_list[[i]] is the order corresponding to the big dendrogram
                         order_list[[i]] = order.dendrogram(dend_list[[i]])
                     }
1fbe74a6
                 }
d7a3c7af
             }
 
             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
402ff791
 
             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
1fbe74a6
                     }
                 }
402ff791
                 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) {
c4a66bf9
                     stop_wrap(qq("Length of `gap` should be 1 or number of @{which} slices."))
402ff791
                 }
c4a66bf9
                 object@matrix_param[[ paste0(which, "_gap") ]] = gap # adjust title
402ff791
                 
                 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)
                             })
e84ad9b4
                         } else if(grepl("@\\{.+\\}", title)) {
                             title = apply(unique(split), 1, function(x) {
                                 x = x
90241921
                                 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)
e84ad9b4
                             })
                         } else if(grepl("\\{.+\\}", title)) {
                             if(!requireNamespace("glue")) {
c4a66bf9
                                 stop_wrap("You need to install glue package.")
e84ad9b4
                             }
                             title = apply(unique(split), 1, function(x) {
                                 x = x
90241921
                                 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)
e84ad9b4
                             })
402ff791
                         }
d7a3c7af
                     }
                 }
402ff791
                 slot(object, paste0(which, "_title")) = title
d7a3c7af
             }
d1da987e
             return(object)
         }
 
     } else {
d7a3c7af
         if(verbose) qqcat("no clustering is applied/exists on @{which}s\n")
d1da987e
     }
a46b9f54
 
d7a3c7af
     if(verbose) qq("clustering object is not pre-defined, clustering is applied to each @{which} slice\n")
d1da987e
     # make k-means clustering to add a split column
de656d42
     consensus_kmeans = function(mat, centers, km_repeats) {
         partition_list = lapply(seq_len(km_repeats), function(i) {
             as.cl_hard_partition(kmeans(mat, centers))
         })
         partition_list = cl_ensemble(list = partition_list)
         partition_consensus = cl_consensus(partition_list)
         as.vector(cl_class_ids(partition_consensus)) 
     }
d1da987e
     if(km > 1 && is.numeric(mat)) {
d7a3c7af
         if(which == "row") {
de656d42
             # km.fit = kmeans(mat, centers = km)
             # cl = km.fit$cluster
             cl = consensus_kmeans(mat, km, km_repeats)
d9a1645d
             meanmat = lapply(sort(unique(cl)), function(i) {
d7a3c7af
                 colMeans(mat[cl == i, , drop = FALSE])
             })
         } else {
de656d42
             # km.fit = kmeans(t(mat), centers = km)
             # cl = km.fit$cluster
             cl = consensus_kmeans(t(mat), km, km_repeats)
d9a1645d
             meanmat = lapply(sort(unique(cl)), function(i) {
d7a3c7af
                 rowMeans(mat[, cl == i, drop = FALSE])
             })
         }
d9a1645d
 
         meanmat = do.call("cbind", meanmat)
a46b9f54
         # 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)
         }
9c4d56c4
         if(cluster_slices) {
             hc = hclust(dist(t(meanmat)))
             hc = as.hclust(reorder(as.dendrogram(hc), weight, mean))
         } else {
             hc = list(order = order(weight))
         }
d9a1645d
 
d7a3c7af
         cl2 = numeric(length(cl))
a2a5b0dc
         for(i in seq_along(hc$order)) {
d7a3c7af
             cl2[cl == hc$order[i]] = i
d1da987e
         }
d7a3c7af
         cl2 = factor(cl2, levels = seq_along(hc$order))
d772a66c
 
         if(is.null(split)) {
d7a3c7af
             split = data.frame(cl2)
d772a66c
         } else if(is.matrix(split)) {
             split = as.data.frame(split)
d7a3c7af
             split = cbind(cl2, split)
d772a66c
         } else if(is.null(ncol(split))) {
d7a3c7af
             split = data.frame(cl2, split)
d772a66c
         } else {
d7a3c7af
             split = cbind(cl2, split)
d772a66c
         }
d7a3c7af
         if(verbose) qqcat("apply k-means (@{km} groups) on @{which}s, append to the `split` data frame\n")
d772a66c
             
d1da987e
     }
 
     # split the original order into a list according to split
d7a3c7af
     order_list = list()
d1da987e
     if(is.null(split)) {
d7a3c7af
         order_list[[1]] = order
d1da987e
     } else {
d7a3c7af
 
c4a66bf9
         if(verbose) cat("process `split` data frame\n")
d1da987e
         if(is.null(ncol(split))) split = data.frame(split)
d772a66c
         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]])))
d1da987e
             }
         }
d772a66c
 
402ff791
         split_name = apply(as.matrix(split), 1, paste, collapse = ",")
d772a66c
 
d7a3c7af
         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))
d1da987e
         }
d7a3c7af
         names(order_list) = level
d1da987e
     }
d7a3c7af
 
12e85497
     # make dend in each slice
d7a3c7af
     if(cluster) {
402ff791
         if(verbose) qqcat("apply clustering on each slice (@{length(order_list)} slices)\n")
d7a3c7af
         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") {
5436f156
                         obj = dend_param$fun(submat)
d7a3c7af
                     } else {
5436f156
                         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")) {
c4a66bf9
                             stop_wrap("the clustering function must return a `dendrogram` object or a object that can be coerced to `dendrogram` class.")
5436f156
                         }
                         dend_list[[i]] = obj
d7a3c7af
                     }
                     order_list[[i]] = order_list[[i]][ get_dend_order(dend_list[[i]]) ]
d1da987e
                 } else {
d7a3c7af
 
                         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]]) ]
5ab2cb81
                     #}
d1da987e
                 }
5ab2cb81
             } else {
d7a3c7af
                 # 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]
d1da987e
             }
         }
d7a3c7af
         names(dend_list) = names(order_list)
dc0f5a96
 
d7a3c7af
         for(i in seq_along(dend_list)) {
             if(inherits(dend_list[[i]], "hclust")) {
                 dend_list[[i]] = as.dendrogram(dend_list[[i]])
dc0f5a96
             }
         }
 
         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
d7a3c7af
             if(which == "row") {
                 reorder = -rowMeans(mat, na.rm = TRUE)
             } else {
                 reorder = -colMeans(mat, na.rm = TRUE)
             }
dc0f5a96
         }
 
         if(do_reorder) {
5ab2cb81
 
d7a3c7af
             if(which == "row") {
                 if(length(reorder) != nrow(mat)) {
c4a66bf9
                     stop_wrap("weight of reordering should have same length as number of rows\n")
d7a3c7af
                 }
             } else {
                 if(length(reorder) != ncol(mat)) {
c4a66bf9
                     stop_wrap("weight of reordering should have same length as number of columns\n")
d7a3c7af
                 }
dc0f5a96
             }
d7a3c7af
             for(i in seq_along(dend_list)) {
                 if(length(order_list[[i]]) > 1) {
                     sub_ind = sort(order_list[[i]])
f0a25823
                     dend_list[[i]] = reorder(dend_list[[i]], reorder[sub_ind], mean)
d7a3c7af
                     order_list[[i]] = sub_ind[ order.dendrogram(dend_list[[i]]) ]
5ab2cb81
                 }
dc0f5a96
             }
d7a3c7af
             if(verbose) qqcat("reorder dendrograms in each @{which} slice\n")
dc0f5a96
         }
 
5e6b381e
         if(length(order_list) > 1 && cluster_slices) {
d7a3c7af
             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]))
             }
bb20f132
             if(!is.matrix(slice_mean)) {
                 slice_mean = matrix(slice_mean, nrow = 1)
             }
d7a3c7af
             dend_slice = as.dendrogram(hclust(dist(t(slice_mean))))
             if(verbose) qqcat("perform clustering on mean of @{which} slices\n")
5e6b381e
 
             slice_od = order.dendrogram(dend_slice)
             order_list = order_list[slice_od]
             dend_list = dend_list[slice_od]
d7a3c7af
         }
     }
dc0f5a96
 
d7a3c7af
     dend_list = lapply(dend_list, adjust_dend_by_x)
d1da987e
 
d7a3c7af
     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
dc0f5a96
 
d7a3c7af
     if(which == "row") {
         if(nrow(mat) != length(order)) {
c4a66bf9
             stop_wrap(qq("Number of rows in the matrix are not the same as the length of the cluster or the @{which} orders."))
d7a3c7af
         }
     } else {
         if(ncol(mat) != length(order)) {
c4a66bf9
             stop_wrap(qq("Number of columns in the matrix are not the same as the length of the cluster or the @{which} orders."))
d7a3c7af
         }
4c3be962
     }
 
d7a3c7af
     # 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)) {
acb6c95b
             gp_temp = NULL
d7a3c7af
             for(j in seq_along(order_list)) {
                 gp_temp[ order_list[[j]] ] = names_param$gp[[i]][j]
acb6c95b
             }
d7a3c7af
             names_param$gp[[i]] = gp_temp   
acb6c95b
         }
     }
d7a3c7af
     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) {
c4a66bf9
         stop_wrap(qq("Length of `gap` should be 1 or number of @{which} slices."))
d7a3c7af
     }
     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
402ff791
             title = names(order_list)
d7a3c7af
         } else if(length(title) == 1) {
             if(grepl("%s", title)) {
402ff791
                 title = apply(unique(split[order2, , drop = FALSE]), 1, function(x) {
d7a3c7af
                     lt = lapply(x, function(x) x)
                     lt$fmt = title
                     do.call(sprintf, lt)
                 })
8c965e28
             } else if(grepl("@\\{.+\\}", title)) {
                 title = apply(unique(split), 1, function(x) {
                     x = x
90241921
                     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)
8c965e28
                 })
             } else if(grepl("\\{.+\\}", title)) {
                 if(!requireNamespace("glue")) {
c4a66bf9
                     stop_wrap("You need to install glue package.")
8c965e28
                 }
                 title = apply(unique(split), 1, function(x) {
                     x = x
90241921
                     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)
8c965e28
                 })
d7a3c7af
             }
         }
     }
     slot(object, paste0(which, "_title")) = title
d1da987e
     return(object)
 
d7a3c7af
 }
d1da987e
 
 # == title
30d2c5b2
 # Draw a Single Heatmap
d1da987e
 #
 # == param
e27480b9
 # -object A `Heatmap-class` object.
30d2c5b2
 # -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`.
d1da987e
 #
30d2c5b2
 # == detail
 # The function creates a `HeatmapList-class` object which only contains a single heatmap
 # and call `draw,HeatmapList-method` to make the final heatmap.
d1da987e
 #
1a56796e
 # There are some arguments which control the some settings of the heatmap such as legends.
30d2c5b2
 # Please go to `draw,HeatmapList-method` for these arguments.
d1da987e
 #
 # == value
30d2c5b2
 # A `HeatmapList-class` object.
d1da987e
 #
 # == author
 # Zuguang Gu <z.gu@dkfz.de>
 #
30d2c5b2
 setMethod(f = "draw",
d1da987e
     signature = "Heatmap",
30d2c5b2
     definition = function(object, internal = FALSE, test = FALSE, ...) {
d1da987e
 
30d2c5b2
     if(test) {
         object = prepare(object)
         grid.newpage()
         if(is_abs_unit(object@heatmap_param$width)) {
             width = object@heatmap_param$width
d1da987e
         } else {
30d2c5b2
             width = 0.8
d1da987e
         }
30d2c5b2
         if(is_abs_unit(object@heatmap_param$height)) {
             height = object@heatmap_param$height
d1da987e
         } else {
30d2c5b2
             height = 0.8
d1da987e
         }
30d2c5b2
         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 = "_")))
1ee53830
                 } else {
30d2c5b2
                     pushViewport(viewport(layout.pos.row = ht_layout_index[j, 1], layout.pos.col = ht_layout_index[j, 2]))
d7a3c7af
                 }
30d2c5b2
                 ht_graphic_fun_list[[j]](object)
                 upViewport()
d7a3c7af
             }
1ee53830
             upViewport()
d1da987e
         } else {
30d2c5b2
             if(ncol(object@matrix) == 0) {
c4a66bf9
                 stop_wrap("Single heatmap should contains a matrix with at least one column. Zero-column matrix can only be appended to the heatmap list.")
d7a3c7af
             }
30d2c5b2
             ht_list = new("HeatmapList")
             ht_list = add_heatmap(ht_list, object)
             draw(ht_list, ...)
d7a3c7af
         }
     }
d1da987e
 })
 
 # == title
30d2c5b2
 # Prepare the Heatmap
d1da987e
 #
 # == param
e27480b9
 # -object A `Heatmap-class` object.
30d2c5b2
 # -process_rows Whether to process rows of the heatmap.
ad35494a
 # -process_columns Whether to process columns of the heatmap.
d1da987e
 #
30d2c5b2
 # == detail
 # The preparation of the heatmap includes following steps:
d1da987e
 #
1a56796e
 # - making clustering on rows (by calling `make_row_cluster,Heatmap-method`)
30d2c5b2
 # - making clustering on columns (by calling `make_column_cluster,Heatmap-method`)
 # - making the layout of the heatmap (by calling `make_layout,Heatmap-method`)
d1da987e
 #
 # This function is only for internal use.
 #
 # == value
30d2c5b2
 # The `Heatmap-class` object.
d1da987e
 #
 # == author
 # Zuguang Gu <z.gu@dkfz.de>
 #
30d2c5b2
 setMethod(f = "prepare",
d1da987e
     signature = "Heatmap",
30d2c5b2
     definition = function(object, process_rows = TRUE, process_columns = TRUE) {
acb6c95b
 
933e808c
     if(object@layout$initialized) {
         return(object)
     }
     
30d2c5b2
     if(process_rows) {
         object = make_row_cluster(object)
d1da987e
     }
30d2c5b2
     if(process_columns) {
         object = make_column_cluster(object)
d7a3c7af
     }
 
30d2c5b2
     object = make_layout(object)
     return(object)
d1da987e
 
 })