1. ComplexHeatmap
  2. Commit d1da987e487ffc262f890b70822a9bfb9fa0ca0e
Browse code

add package to repository

ComplexHeatmap/ podkat/ RBM/


git-svn-id: https://hedgehog.fhcrc.org/bioconductor/trunk/madman/Rpacks/ComplexHeatmap@101658 bc3139a8-67e5-0310-9ffc-ced21a209358

s.arora authored on 31/03/2015 18:31:58
Showing 91 changed files
DESCRIPTION
History View file @ d1da987
1 1 
new file mode 100644
... ... 
@@ -0,0 +1,22 @@
1 
+Package: ComplexHeatmap
2 
+Type: Package
3 
+Title: Making Complex Heatmaps
4 
+Version: 0.99.1
5 
+Date: 2015-3-26
6 
+Author: Zuguang Gu
7 
+Maintainer: Zuguang Gu <z.gu@dkfz.de>
8 
+Depends: R (>= 3.1.0), grid
9 
+Imports: methods, circlize (>= 0.2.3), GetoptLong, colorspace,
10 
+        RColorBrewer
11 
+Suggests: testthat (>= 0.3), knitr, markdown, cluster, dendextend
12 
+VignetteBuilder: knitr
13 
+Description: Complex heatmaps are efficient to visualize associations
14 
+        between different sources of data sets and reveal potential
15 
+        features. Here the ComplexHeatmap package provides a highly
16 
+        flexible way to arrange multiple heatmaps and supports
17 
+        self-defined annotation graphics.
18 
+biocViews: Software, Visualization, Sequencing
19 
+URL: https://github.com/jokergoo/ComplexHeatmap
20 
+License: GPL (>= 2)
21 
+Repository: Bioconductor
22 
+Date/Publication: 2015-3-26 00:00:00
NAMESPACE
History View file @ d1da987
0 23 
new file mode 100644
... ... 
@@ -0,0 +1,62 @@
1 
+export(anno_boxplot)
2 
+export(ColorMapping)
3 
+exportMethods(make_layout)
4 
+export(anno_histogram)
5 
+export(HeatmapAnnotation)
6 
+exportMethods(draw_dimnames)
7 
+export(+.AdditiveUnit)
8 
+exportClasses(ColorMapping)
9 
+export(ColorMapping)
10 
+exportClasses(HeatmapAnnotation)
11 
+export(HeatmapAnnotation)
12 
+export(Heatmap)
13 
+export(anno_points)
14 
+exportMethods(draw_title)
15 
+exportMethods(draw)
16 
+exportMethods(draw_heatmap_body)
17 
+exportMethods(color_mapping_legend)
18 
+exportMethods(prepare)
19 
+exportMethods(heatmap_legend_size)
20 
+exportClasses(HeatmapList)
21 
+export(HeatmapList)
22 
+exportMethods(map_to_colors)
23 
+exportClasses(Heatmap)
24 
+export(Heatmap)
25 
+exportMethods(component_height)
26 
+exportMethods(draw_annotation_legend)
27 
+exportClasses(SingleAnnotation)
28 
+export(SingleAnnotation)
29 
+exportMethods(draw_hclust)
30 
+exportClasses(AdditiveUnit)
31 
+export(AdditiveUnit)
32 
+exportMethods(set_component_height)
33 
+exportMethods(make_column_cluster)
34 
+export(HeatmapList)
35 
+exportMethods(draw_annotation)
36 
+export(SingleAnnotation)
37 
+exportMethods(annotation_legend_size)
38 
+exportMethods(get_color_mapping_list)
39 
+exportMethods(make_row_cluster)
40 
+export(AdditiveUnit)
41 
+exportMethods(component_width)
42 
+exportMethods(draw_heatmap_list)
43 
+export(grid.dendrogram)
44 
+export(dist2)
45 
+exportMethods(draw_heatmap_legend)
46 
+exportMethods(add_heatmap)
47 
+export(anno_barplot)
48 
+export(anno_density)
49 
+
50 
+import(grid)
51 
+importFrom("methods", setClass)
52 
+importFrom("methods", setMethod)
53 
+importFrom("methods", setGeneric)
54 
+importFrom("circlize", colorRamp2)
55 
+importFrom("circlize", rand_color)
56 
+importFrom("GetoptLong", qq)
57 
+importFrom("GetoptLong", qqcat)
58 
+importFrom("GetoptLong", qq.options)
59 
+importFrom("colorspace", rainbow_hcl)
60 
+importFrom("colorspace", diverge_hcl)
61 
+importFrom("RColorBrewer", brewer.pal)
62 
+
NEWS
History View file @ d1da987
0 63 
new file mode 100644
... ... 
@@ -0,0 +1,14 @@
1 
+CHANGES IN VERSION 0.99.2
2 
+
3 
+* add chunk labels in the vignette
4 
+
5 
+=================================================
6 
+
7 
+CHANGES IN VERSION 0.99.1
8 
+
9 
+* x and y in `cell_fun` are now `unit` objects.
10 
+
11 
+=================================================
12 
+CHANGES IN VERSION 0.99.0
13 
+
14 
+* First release
R/00_S4_generic_methods.R
History View file @ d1da987
0 15 
new file mode 100644
... ... 
@@ -0,0 +1,44 @@
1 
+
2 
+setGeneric('add_heatmap', function(object, ...) standardGeneric('add_heatmap'))
3 
+
4 
+setGeneric('map_to_colors', function(object, ...) standardGeneric('map_to_colors'))
5 
+
6 
+setGeneric('set_component_height', function(object, ...) standardGeneric('set_component_height'))
7 
+
8 
+setGeneric('draw_heatmap_body', function(object, ...) standardGeneric('draw_heatmap_body'))
9 
+
10 
+setGeneric('draw_hclust', function(object, ...) standardGeneric('draw_hclust'))
11 
+
12 
+setGeneric('draw_annotation_legend', function(object, ...) standardGeneric('draw_annotation_legend'))
13 
+
14 
+setGeneric('component_height', function(object, ...) standardGeneric('component_height'))
15 
+
16 
+setGeneric('make_layout', function(object, ...) standardGeneric('make_layout'))
17 
+
18 
+setGeneric('draw_heatmap_legend', function(object, ...) standardGeneric('draw_heatmap_legend'))
19 
+
20 
+setGeneric('heatmap_legend_size', function(object, ...) standardGeneric('heatmap_legend_size'))
21 
+
22 
+setGeneric('annotation_legend_size', function(object, ...) standardGeneric('annotation_legend_size'))
23 
+
24 
+setGeneric('prepare', function(object, ...) standardGeneric('prepare'))
25 
+
26 
+setGeneric('draw_annotation', function(object, ...) standardGeneric('draw_annotation'))
27 
+
28 
+setGeneric('draw_dimnames', function(object, ...) standardGeneric('draw_dimnames'))
29 
+
30 
+setGeneric('color_mapping_legend', function(object, ...) standardGeneric('color_mapping_legend'))
31 
+
32 
+setGeneric('draw', function(object, ...) standardGeneric('draw'))
33 
+
34 
+setGeneric('make_row_cluster', function(object, ...) standardGeneric('make_row_cluster'))
35 
+
36 
+setGeneric('draw_title', function(object, ...) standardGeneric('draw_title'))
37 
+
38 
+setGeneric('make_column_cluster', function(object, ...) standardGeneric('make_column_cluster'))
39 
+
40 
+setGeneric('component_width', function(object, ...) standardGeneric('component_width'))
41 
+
42 
+setGeneric('get_color_mapping_list', function(object, ...) standardGeneric('get_color_mapping_list'))
43 
+
44 
+setGeneric('draw_heatmap_list', function(object, ...) standardGeneric('draw_heatmap_list'))
R/AdditiveUnit-class.R
History View file @ d1da987
0 45 
new file mode 100644
... ... 
@@ -0,0 +1,62 @@
1 
+
2 
+# == title
3 
+# An internal class
4 
+#
5 
+# == detail
6 
+# This class is a super class for `Heatmap-class`, `HeatmapList-class` and `HeatmapAnnotation-class` classes.
7 
+# It is only designed for ``+`` generic method.
8 
+#
9 
+AdditiveUnit = setClass("AdditiveUnit")
10 
+
11 
+# == title
12 
+# Constructor method for AdditiveUnit class
13 
+#
14 
+# == param
15 
+# -... arguments.
16 
+#
17 
+# == details
18 
+# This method is not used in the package.
19 
+#
20 
+# == value
21 
+# No value is returned.
22 
+#
23 
+# == author
24 
+# Zuguang Gu <z.gu@dkfz.de>
25 
+#
26 
+AdditiveUnit = function(...) {
27 
+    new("AdditiveUnit", ...)
28 
+}
29 
+
30 
+
31 
+# == title
32 
+# Add heatmaps or row annotations to a heatmap list
33 
+#
34 
+# == param
35 
+# -x a `Heatmap-class` object, a `HeatmapAnnotation-class` object or a `HeatmapList-class` object.
36 
+# -y a `Heatmap-class` object, a `HeatmapAnnotation-class` object or a `HeatmapList-class` object.
37 
+#
38 
+# == detail
39 
+# It is only a shortcut function. It actually calls `add_heatmap,Heatmap-method`, `add_heatmap,HeatmapList-method`
40 
+# or `add_heatmap,HeatmapAnnotation-method` depending on the class of the input objects.
41 
+#
42 
+# The `HeatmapAnnotation-class` object to be added should only be row annotation.
43 
+#
44 
+# == value
45 
+# A `HeatmapList-class` object.
46 
+#
47 
+# == author
48 
+# Zuguang Gu <z.gu@dkfz.de>
49 
+#
50 
+"+.AdditiveUnit" = function(x, y) {
51 
+    if(inherits(x, "HeatmapAnnotation")) {
52 
+    	if(x@which != "row") {
53 
+    		stop("You should specify `which` to `row` if you add a HeatmapAnnotation which shows row annotations.")
54 
+    	}
55 
+    }
56 
+    if(inherits(y, "HeatmapAnnotation")) {
57 
+    	if(y@which != "row") {
58 
+    		stop("You should specify `which` to `row` if you add a HeatmapAnnotation which shows row annotations.")
59 
+    	}
60 
+    }
61 
+    add_heatmap(x, y)
62 
+}
R/ColorMapping-class.R
History View file @ d1da987
0 63 
new file mode 100644
... ... 
@@ -0,0 +1,247 @@
1 
+
2 
+#####################################
3 
+# class and methods to map values to colors
4 
+#
5 
+
6 
+# == title
7 
+# Class to map values to colors
8 
+#
9 
+# == details
10 
+# The `ColorMapping-class` handles color mapping with both discrete values and continuous values.
11 
+# Discrete values are mapped by setting a vector of colors and continuous values are mapped by setting
12 
+# a color mapping function.
13 
+#
14 
+# == methods
15 
+# The `ColorMapping-class` provides following methods:
16 
+#
17 
+# - `ColorMapping`: contructor methods.
18 
+# - `map_to_colors,ColorMapping-method`: mapping values to colors.
19 
+# - `color_mapping_legend,ColorMapping-method`: draw legend or get the size of the legend.
20 
+#
21 
+# == author
22 
+# Zuguang Gu <z.gu@dkfz.de>
23 
+#
24 
+ColorMapping = setClass("ColorMapping",
25 
+	slots = list(
26 
+		colors  = "character", # a list of colors
27 
+		levels  = "character", # levels which colors correspond to
28 
+		col_fun = "function", # function to map values to colors
29 
+		type    = "character",  # continuous or discrete
30 
+		name    = "character"  # used to map to the dataset and taken as the title of the legend
31 
+	)
32 
+)
33 
+
34 
+# == title
35 
+# Constructor methods for ColorMapping class
36 
+#
37 
+# == param
38 
+# -name name for this color mapping. It is used for drawing the title of the legend.
39 
+# -colors discrete colors.
40 
+# -levels levels that correspond to ``colors``. If ``colors`` is name indexed,
41 
+#         ``levels`` can be ignored.
42 
+# -col_fun color mapping function that maps continuous values to colors.
43 
+# -breaks breaks for the continuous color mapping. If ``col_fun`` is
44 
+#         generated by `circlize::colorRamp2`, ``breaks`` can be ignored.
45 
+#
46 
+# == detail
47 
+# ``colors`` and ``levels`` are used for discrete color mapping, ``col_fun`` and
48 
+# ``breaks`` are used for continuous color mapping.
49 
+#
50 
+# == value
51 
+# A `ColorMapping-class` object.
52 
+#
53 
+# == author
54 
+# Zuguang Gu <z.gu@dkfz.de>
55 
+#
56 
+ColorMapping = function(name, colors = NULL, levels = NULL,
57 
+	col_fun = NULL, breaks = NULL) {
58 
+
59 
+	.Object = new("ColorMapping")
60 
+
61 
+	if(is.null(name)) {
62 
+		stop("You should provide name.")
63 
+	}
64 
+	if(!is.null(colors)) {
65 
+		if(is.null(levels)) {
66 
+			if(is.null(names(colors))) {
67 
+				stop("either provide `levels` or provide named `colors`.\n")
68 
+			}
69 
+			levels = names(colors)
70 
+		}
71 
+		if(length(colors) != length(levels)) {
72 
+			stop("length of colors and length of levels should be the same.\n")
73 
+		}
74 
+		.Object@colors = colors
75 
+		if(is.numeric(levels)) {
76 
+			.Object@levels = as.character(levels)
77 
+			#attr(.Object@levels, "numeric") = TRUE
78 
+		} else {
79 
+			.Object@levels = levels
80 
+		}
81 
+		names(.Object@colors) = levels
82 
+		.Object@type = "discrete"
83 
+	} else if(!is.null(col_fun)) {
84 
+		if(is.null(breaks)) {
85 
+			breaks = attr(col_fun, "breaks")
86 
+			if(is.null(breaks)) {
87 
+				stop("You should provide breaks.\n")
88 
+			}
89 
+		}
90 
+		le1 = grid.pretty(range(breaks))
91 
+		le2 = pretty(breaks, n = 3)
92 
+		if(abs(length(le1) - 5) < abs(length(le2) - 5)) {
93 
+			le = le1
94 
+		} else {
95 
+			le = le2
96 
+		}
97 
+		.Object@colors = col_fun(le)
98 
+		.Object@levels = as.character(le)
99 
+		.Object@col_fun = col_fun
100 
+		.Object@type = "continuous"
101 
+	} else {
102 
+		stop("initialization failed. Either specify `colors` + `levels` or `col_fun` + `breaks`\n")
103 
+	}
104 
+
105 
+	.Object@name = name
106 
+
107 
+	return(.Object)
108 
+}
109 
+
110 
+# == title
111 
+# Print ColorMapping object
112 
+#
113 
+# == param
114 
+# -object a `ColorMapping-class` object.
115 
+#
116 
+# == value
117 
+# This function returns no value.
118 
+#
119 
+# == author
120 
+# Zuguang Gu <z.gu@dkfz.de>
121 
+#
122 
+setMethod(f = "show",
123 
+	signature = "ColorMapping",
124 
+	definition = function(object) {
125 
+	if(object@type == "discrete") {
126 
+		cat("Discrete color mapping:\n")
127 
+		cat("name:", object@name, "\n")
128 
+		cat("levels:\n")
129 
+		print(object@levels)
130 
+		cat("\n")
131 
+		cat("colors:\n")
132 
+		col = object@colors; names(col) = NULL
133 
+		print(col)
134 
+		cat("\n")
135 
+	} else if(object@type == "continuous") {
136 
+		cat("Continuous color mapping:\n")
137 
+		cat("name:", object@name, "\n")
138 
+		cat("breaks:\n")
139 
+		print(object@levels)
140 
+		cat("\n")
141 
+		cat("colors:\n")
142 
+		col = object@colors; names(col) = NULL
143 
+		print(col)
144 
+		cat("\n")
145 
+	}
146 
+})
147 
+
148 
+# == title
149 
+# Map values to colors
150 
+#
151 
+# == param
152 
+# -object a `ColorMapping-class` object.
153 
+# -x input values.
154 
+#
155 
+# == details
156 
+# It maps a vector of values to a vector of colors.
157 
+#
158 
+# == value
159 
+# A vector of colors.
160 
+#
161 
+# == author
162 
+# Zuguang Gu <z.gu@dkfz.de>
163 
+#
164 
+setMethod(f = "map_to_colors",
165 
+	signature = "ColorMapping",
166 
+	definition = function(object, x) {
167 
+
168 
+	if(is.factor(x)) x = as.vector(x)
169 
+	original_attr = attributes(x)
170 
+	if(object@type == "discrete") {
171 
+		if(is.numeric(x)) x = as.character(x)
172 
+		if(any(! x %in% object@levels)) {
173 
+			msg = paste0("Cannot map some of the levels:\n", paste(setdiff(x, object@levels), sep = ", ", collapse = ", "))
174 
+			stop(msg)
175 
+		}
176 
+		x = object@colors[x]
177 
+	} else {
178 
+		x = object@col_fun(x)
179 
+	}
180 
+
181 
+	# keep original attributes, such as dimension
182 
+	attributes(x) = original_attr
183 
+	return(x)
184 
+})
185 
+
186 
+
187 
+# == title
188 
+# Draw legend based on color mapping
189 
+#
190 
+# == param
191 
+# -object a `ColorMapping-class` object.
192 
+# -... pass to `grid::viewport`.
193 
+# -plot whether to plot or just return the size of the legend viewport.
194 
+# -legend_grid_height height of each legend grid.
195 
+# -legend_grid_width width of each legend grid.
196 
+# -legend_title_gp graphic parameter for legend title.
197 
+# -legend_label_gp graphic parameter for legend label.
198 
+#
199 
+# == details
200 
+# A viewport is created which contains a legend title, legend grids and corresponding labels.
201 
+#
202 
+# == value
203 
+# A `grid::unit` object which corresponds to the width and height of the legend viewport.
204 
+#
205 
+# == author
206 
+# Zuguang Gu <z.gu@dkfz.de>
207 
+#
208 
+setMethod(f = "color_mapping_legend",
209 
+	signature = "ColorMapping",
210 
+	definition = function(object, ..., plot = TRUE, legend_grid_height = unit(3, "mm"),
211 
+	legend_grid_width = unit(3, "mm"),
212 
+	legend_title_gp = gpar(fontsize = 10, fontface = "bold"),
213 
+	legend_label_gp = gpar(fontsize = 10)) {
214 
+
215 
+	legend_title_gp = check_gp(legend_title_gp)
216 
+	legend_label_gp = check_gp(legend_label_gp)
217 
+
218 
+	# add title
219 
+	legend_title_grob = textGrob(object@name, just = c("left", "top"), gp = legend_title_gp)
220 
+	legend_title_height = grobHeight(legend_title_grob)
221 
+	legend_title_width = grobWidth(legend_title_grob)
222 
+
223 
+	nlevel = length(object@levels)
224 
+	x = unit(rep(0, nlevel), "npc")
225 
+	y = 1.5*legend_title_height + (0:(nlevel-1))*(legend_grid_height + unit(1, "mm"))
226 
+	y = unit(1, "npc") - y
227 
+	legend_label_max_width = max(do.call("unit.c", lapply(object@levels, function(x) {
228 
+			grobWidth(textGrob(x, gp = legend_label_gp))
229 
+		})))
230 
+	vp_width = max(unit.c(legend_title_width,
231 
+				   legend_grid_width + unit(1, "mm") + legend_label_max_width ))
232 
+	vp_height = legend_title_height*1.5 + nlevel*(legend_grid_height + unit(1, "mm"))
233 
+
234 
+	if(plot) {
235 
+		pushViewport(viewport(..., width = vp_width, height = vp_height, name = paste0("legend_", object@name)))
236 
+		grid.text(object@name, unit(0, "npc"), unit(1, "npc"), just = c("left", "top"),
237 
+			gp = legend_title_gp)
238 
+		grid.rect(x, rev(y), width = legend_grid_width, height = rev(legend_grid_height), just = c("left", "top"),
239 
+			gp = gpar(col = NA, fill = object@colors))
240 
+		grid.text(rev(object@levels), x + legend_grid_width + unit(1, "mm"), y - legend_grid_height*0.5,
241 
+			just = c("left", "center"), gp = legend_label_gp)
242 
+		upViewport()
243 
+	}
244 
+
245 
+	size = unit.c(vp_width, vp_height)
246 
+	return(invisible(size))
247 
+})
R/Heatmap-class.R
History View file @ d1da987
0 248 
new file mode 100644
... ... 
@@ -0,0 +1,1392 @@
1 
+
2 
+###############################
3 
+# class for single heatmap
4 
+#
5 
+
6 
+
7 
+# the layout of the heatmap is 7 x 9
8 
+
9 
+# == title
10 
+# Class for a single heatmap
11 
+#
12 
+# == details
13 
+# The components for a single heamtap are placed into a 9 x 7 layout:
14 
+#
15 
+#          +------+ (1)
16 
+#          +------+ (2)
17 
+#          +------+ (3)
18 
+#          +------+ (4)
19 
+#    +-+-+-+------+-+-+-+
20 
+#    |1|2|3| 4(5) |5|6|7|
21 
+#    +-+-+-+------+-+-+-+
22 
+#          +------+ (6)
23 
+#          +------+ (7)
24 
+#          +------+ (8)
25 
+#          +------+ (9)
26 
+#
27 
+# From top to bottom in column 4, the regions are:
28 
+#
29 
+# - title which is put on the top of the heatmap, graphics are drawn by `draw_title,Heatmap-method`.
30 
+# - column cluster on the top, graphics are drawn by `draw_hclust,Heatmap-method`.
31 
+# - column annotation on the top, graphics are drawn by `draw_annotation,Heatmap-method`.
32 
+# - column names on the top, graphics are drawn by `draw_dimnames,Heatmap-method`.
33 
+# - heatmap body, graphics are drawn by `draw_heatmap_body,Heatmap-method`.
34 
+# - column names on the bottom, graphics are drawn by `draw_dimnames,Heatmap-method`.
35 
+# - column annotation on the bottom, graphics are drawn by `draw_annotation,Heatmap-method`.
36 
+# - column cluster on the bottom, graphics are drawn by `draw_hclust,Heatmap-method`.
37 
+# - title on the bottom, graphics are drawn by `draw_title,Heatmap-method`.
38 
+#
39 
+# From left to right in row 5, the regions are:
40 
+#
41 
+# - title which is put in the left of the heatmap, graphics are drawn by `draw_title,Heatmap-method`.
42 
+# - row cluster on the left, graphics are drawn by `draw_hclust,Heatmap-method`.
43 
+# - row names on the left, graphics are drawn by `draw_dimnames,Heatmap-method`.
44 
+# - heatmap body
45 
+# - row names on the right, graphics are drawn by `draw_dimnames,Heatmap-method`.
46 
+# - row cluster on the right, graphics are drawn by `draw_hclust,Heatmap-method`.
47 
+# - title on the right, graphics are drawn by `draw_title,Heatmap-method`.
48 
+#
49 
+# The `Heatmap-class` is not responsible for heatmap legend and annotation legends. The `draw,Heatmap-method` method
50 
+# will construct a `HeatmapList-class` object which only contains one single heatmap
51 
+# and call `draw,HeatmapList-method` to make a complete heatmap.
52 
+#
53 
+# == methods
54 
+# The `Heatmap-class` provides following methods:
55 
+#
56 
+# - `Heatmap`: constructor method.
57 
+# - `draw,Heatmap-method`: draw a single heatmap.
58 
+# - `add_heatmap,Heatmap-method` append heatmaps and row annotations to a list of heatmaps.
59 
+#
60 
+# == author
61 
+# Zuguang Gu <z.gu@dkfz.de>
62 
+#
63 
+Heatmap = setClass("Heatmap",
64 
+    slots = list(
65 
+        name = "character",
66 
+
67 
+        matrix = "matrix",  # one or more matrix which are spliced by rows
68 
+        matrix_param = "list",
69 
+        matrix_color_mapping = "ANY",
70 
+
71 
+        row_title = "character",
72 
+        row_title_param = "list",
73 
+        column_title = "character",
74 
+        column_title_param = "list",
75 
+
76 
+        row_hclust_list = "list", # one or more row clusters
77 
+        row_hclust_param = "list", # parameters for row cluster
78 
+        row_order_list = "list",
79 
+
80 
+        column_hclust = "ANY",
81 
+        column_hclust_param = "list", # parameters for column cluster
82 
+        column_order = "numeric",
83 
+
84 
+        row_names_param = "list",
85 
+        column_names_param = "list",
86 
+
87 
+        top_annotation = "ANY", # NULL or a `HeatmapAnnotation` object
88 
+        top_annotation_param = "list",
89 
+
90 
+        bottom_annotation = "ANY",
91 
+        bottom_annotation_param = "list",
92 
+
93 
+        heatmap_param = "list",
94 
+
95 
+        layout = "list"
96 
+    ),
97 
+    contains = "AdditiveUnit"
98 
+)
99 
+
100 
+
101 
+
102 
+# == title
103 
+# Constructor method for Heatmap class
104 
+#
105 
+# == param
106 
+# -matrix a matrix. Either numeric or character. If it is a simple vector, it will be
107 
+#         converted to a one-column matrix.
108 
+# -col a vector of colors if the color mapping is discrete or a color mapping
109 
+#      function if the matrix is continuous numbers. Pass to `ColorMapping`.
110 
+# -name name of the heatmap. The name is used as the title of the heatmap legend.
111 
+# -rect_gp graphic parameters for drawing rectangles (for heatmap body).
112 
+# -cell_fun self-defined function to add graphics on each cell. Six parameters will be passed into
113 
+#           this function: ``i``, ``j``, ``x``, ``y``, ``width``, ``height`` which are row index,
114 
+#           column index in ``matrix``, coordinate of the middle points in the heatmap body viewport,
115 
+#           and the width and height of the cell.
116 
+# -row_title title on row.
117 
+# -row_title_side will the title be put on the left or right of the heatmap?
118 
+# -row_title_gp graphic parameters for drawing text.
119 
+# -column_title title on column.
120 
+# -column_title_side will the title be put on the top or bottom of the heatmap?
121 
+# -column_title_gp graphic parameters for drawing text.
122 
+# -cluster_rows If the value is a logical, it means whether make cluster on rows. The value can also
123 
+#               be a `stats::hclust` or a `stats::dendrogram` that already contains clustering information.
124 
+#               This means you can use any type of clustering methods and render the `stats::dendrogram`
125 
+#               object with self-defined graphic settings.
126 
+# -clustering_distance_rows it can be a pre-defined character which is in
127 
+#                ("euclidean", "maximum", "manhattan", "canberra", "binary",
128 
+#                "minkowski", "pearson", "spearman", "kendall"). It can also be a function.
129 
+#                If the function has one argument, the input argument should be a matrix and
130 
+#                the returned value should be a `stats::dist` object. If the function has two arguments,
131 
+#                the input arguments are two vectors and the function calculates distance between these
132 
+#                two vectors.
133 
+# -clustering_method_rows method to make cluster, pass to `stats::hclust`.
134 
+# -row_hclust_side should the row cluster be put on the left or right of the heatmap?
135 
+# -row_hclust_width width of the row cluster, should be a `grid::unit` object.
136 
+# -show_row_hclust whether show row clusters.
137 
+# -row_hclust_gp graphics parameters for drawing lines. If users already provide a `stats::dendrogram`
138 
+#                object with edges rendered, this argument will be ignored.
139 
+# -cluster_columns whether make cluster on columns. Same settings as ``cluster_rows``.
140 
+# -clustering_distance_columns same setting as ``clustering_distance_rows``.
141 
+# -clustering_method_columns method to make cluster, pass to `stats::hclust`.
142 
+# -column_hclust_side should the column cluster be put on the top or bottom of the heatmap?
143 
+# -column_hclust_height height of the column cluster, should be a `grid::unit` object.
144 
+# -show_column_hclust whether show column clusters.
145 
+# -column_hclust_gp graphic parameters for drawling lines. Same settings as ``row_hclust_gp``.
146 
+# -row_names_side should the row names be put on the left or right of the heatmap?
147 
+# -show_row_names whether show row names.
148 
+# -row_names_max_width maximum width of row names viewport. Because some times row names can be very long, it is not reasonable
149 
+#                      to show them all.
150 
+# -row_names_gp graphic parameters for drawing text.
151 
+# -column_names_side should the column names be put on the top or bottom of the heatmap?
152 
+# -column_names_max_height maximum height of column names viewport.
153 
+# -show_column_names whether show column names.
154 
+# -column_names_gp graphic parameters for drawing text.
155 
+# -top_annotation a `HeatmapAnnotation` object which contains a list of annotations.
156 
+# -top_annotation_height total height of the column annotations on the top.
157 
+# -bottom_annotation a `HeatmapAnnotation` object.
158 
+# -bottom_annotation_height total height of the column annotations on the bottom.
159 
+# -km do 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.
160 
+#     For each row-clusters, hierarchical clustering is still applied with parameters above.
161 
+# -split a vector or a data frame by which the rows are split.
162 
+# -gap gap between row-slices if the heatmap is split by rows, should be `grid::unit` object.
163 
+# -combined_name_fun if the heatmap is split by rows, how to make a combined row title for each slice?
164 
+#                 The input parameter for this function is a vector which contains level names under each column in ``split``.
165 
+# -width the width of the single heatmap, should be a fixed `grid::unit` object. It is used for the layout when the heatmap
166 
+#        is appended to a list of heatmaps.
167 
+# -show_heatmap_legend whether show heatmap legend?
168 
+#
169 
+# == details
170 
+# The initialization function only applies parameter checking and fill values to each slot with proper ones.
171 
+# Then it will be ready for clustering and layout.
172 
+#
173 
+# Following methods can be applied on the `Heatmap-class` object:
174 
+#
175 
+# - `show,Heatmap-method`: draw a single heatmap with default parameters
176 
+# - `draw,Heatmap-method`: draw a single heatmap.
177 
+# - `add_heatmap,Heatmap-method` append heatmaps and row annotations to a list of heatmaps.
178 
+#
179 
+# The constructor function pretends to be a high-level graphic function because the ``show`` method
180 
+# of the `Heatmap-class` object actually plots the graphics.
181 
+#
182 
+# == value
183 
+# A `Heatmap-class` object.
184 
+#
185 
+# == author
186 
+# Zuguang Gu <z.gu@dkfz.de>
187 
+#
188 
+Heatmap = function(matrix, col, name, rect_gp = gpar(col = NA),
189 
+    cell_fun = function(j, i, x, y, width, height, fill) NULL,
190 
+    row_title = character(0), row_title_side = c("left", "right"),
191 
+    row_title_gp = gpar(fontsize = 14), column_title = character(0),
192 
+    column_title_side = c("top", "bottom"), column_title_gp = gpar(fontsize = 14),
193 
+    cluster_rows = TRUE, clustering_distance_rows = "euclidean",
194 
+    clustering_method_rows = "complete", row_hclust_side = c("left", "right"),
195 
+    row_hclust_width = unit(10, "mm"), show_row_hclust = TRUE,
196 
+    row_hclust_gp = gpar(), cluster_columns = TRUE,
197 
+    clustering_distance_columns = "euclidean", clustering_method_columns = "complete",
198 
+    column_hclust_side = c("top", "bottom"), column_hclust_height = unit(10, "mm"),
199 
+    show_column_hclust = TRUE, column_hclust_gp = gpar(),
200 
+    row_names_side = c("right", "left"), show_row_names = TRUE,
201 
+    row_names_max_width = unit(4, "cm"), row_names_gp = gpar(fontsize = 12),
202 
+    column_names_side = c("bottom", "top"),
203 
+    show_column_names = TRUE, column_names_max_height = unit(4, "cm"),
204 
+    column_names_gp = gpar(fontsize = 12),
205 
+    top_annotation = new("HeatmapAnnotation"),
206 
+    top_annotation_height = unit(5*length(top_annotation@anno_list), "mm"),
207 
+    bottom_annotation = new("HeatmapAnnotation"),
208 
+    bottom_annotation_height = unit(5*length(bottom_annotation@anno_list), "mm"),
209 
+    km = 1, split = NULL, gap = unit(1, "mm"),
210 
+    combined_name_fun = function(x) paste(x, collapse = "/"),
211 
+    width = NULL, show_heatmap_legend = TRUE) {
212 
+
213 
+    .Object = new("Heatmap")
214 
+
215 
+    .Object@heatmap_param$width = width
216 
+    .Object@heatmap_param$show_heatmap_legend = show_heatmap_legend
217 
+
218 
+    if(is.data.frame(matrix)) {
219 
+        matrix = as.matrix(matrix)
220 
+    }
221 
+    if(!is.matrix(matrix)) {
222 
+        if(is.atomic(matrix)) {
223 
+           matrix = matrix(matrix, ncol = 1)
224 
+        } else {
225 
+            stop("If data is not a matrix, it should be a simple vector.")
226 
+        }
227 
+    }
228 
+
229 
+    if(ncol(matrix) == 0) {
230 
+        .Object@heatmap_param$show_heatmap_legend = FALSE
231 
+    }
232 
+
233 
+    if(is.character(matrix) || ncol(matrix) <= 1) {
234 
+        cluster_rows = FALSE
235 
+        cluster_columns = FALSE
236 
+        show_row_hclust = FALSE
237 
+        show_column_hclust = FALSE
238 
+        km = 1
239 
+    }
240 
+    .Object@matrix = matrix
241 
+    .Object@matrix_param$km = km
242 
+    .Object@matrix_param$gap = gap
243 
+    if(!is.null(split)) {
244 
+        if(!is.data.frame(split)) split = data.frame(split)
245 
+        if(nrow(split) != nrow(matrix)) {
246 
+            stop("Length or number of rows of `split` should be same as rows in `matrix`.")
247 
+        }
248 
+    }
249 
+    .Object@matrix_param$split = split
250 
+    .Object@matrix_param$gp =check_gp(rect_gp)
251 
+    .Object@matrix_param$cell_fun = cell_fun
252 
+
253 
+    if(missing(name)) {
254 
+        name = paste0("matrix_", get_heatmap_index() + 1)
255 
+        increase_heatmap_index()
256 
+    }
257 
+    .Object@name = name
258 
+
259 
+    if(ncol(matrix) == 1 && is.null(colnames(matrix))) {
260 
+        colnames(matrix) = name
261 
+        .Object@matrix = matrix
262 
+    }
263 
+
264 
+    # color for main matrix
265 
+    if(ncol(matrix) > 0) {
266 
+        if(missing(col)) {
267 
+            col = default_col(matrix, main_matrix = TRUE)
268 
+        }
269 
+        if(is.function(col)) {
270 
+            .Object@matrix_color_mapping = ColorMapping(col_fun = col, name = name)
271 
+        } else {
272 
+            if(is.null(names(col))) {
273 
+                if(length(col) == length(unique(matrix))) {
274 
+                    names(col) = unique(matrix)
275 
+                } else {
276 
+                    stop("`col` should have names to map to values in `mat`.")
277 
+                }
278 
+            }
279 
+            .Object@matrix_color_mapping = ColorMapping(colors = col, name = name)
280 
+        }
281 
+    }
282 
+
283 
+    if(length(row_title) == 0) {
284 
+        row_title = character(0)
285 
+    } else if(is.na(row_title)) {
286 
+        row_title = character(0)
287 
+    } else if(row_title == "") {
288 
+        row_title = character(0)
289 
+    }
290 
+    .Object@row_title = row_title
291 
+    .Object@row_title_param$side = match.arg(row_title_side)[1]
292 
+    .Object@row_title_param$gp = check_gp(row_title_gp)
293 
+    .Object@row_title_param$combined_name_fun = combined_name_fun
294 
+
295 
+    if(length(column_title) == 0) {
296 
+        column_title = character(0)
297 
+    } else if(is.na(column_title)) {
298 
+        column_title = character(0)
299 
+    } else if(column_title == "") {
300 
+        column_title = character(0)
301 
+    }
302 
+    .Object@column_title = column_title
303 
+    .Object@column_title_param$side = match.arg(column_title_side)[1]
304 
+    .Object@column_title_param$gp = check_gp(column_title_gp)
305 
+
306 
+    if(is.null(rownames(matrix))) {
307 
+        show_row_names = FALSE
308 
+    }
309 
+    .Object@row_names_param$side = match.arg(row_names_side)[1]
310 
+    .Object@row_names_param$show = show_row_names
311 
+    .Object@row_names_param$gp = recycle_gp(check_gp(row_names_gp), nrow(matrix))
312 
+    .Object@row_names_param$max_width = row_names_max_width + unit(2, "mm")
313 
+
314 
+    if(is.null(colnames(matrix))) {
315 
+        show_column_names = FALSE
316 
+    }
317 
+    .Object@column_names_param$side = match.arg(column_names_side)[1]
318 
+    .Object@column_names_param$show = show_column_names
319 
+    .Object@column_names_param$gp = recycle_gp(check_gp(column_names_gp), ncol(matrix))
320 
+    .Object@column_names_param$max_height = column_names_max_height + unit(2, "mm")
321 
+
322 
+    if(inherits(cluster_rows, "dendrogram") || inherits(cluster_rows, "hclust")) {
323 
+        .Object@row_hclust_param$obj = cluster_rows
324 
+        .Object@row_hclust_param$cluster = TRUE
325 
+    } else if(inherits(cluster_rows, "function")) {
326 
+        .Object@row_hclust_param$fun = cluster_rows
327 
+        .Object@row_hclust_param$cluster = TRUE
328 
+    } else {
329 
+        .Object@row_hclust_param$cluster = cluster_rows
330 
+        if(!cluster_rows) {
331 
+            row_hclust_width = unit(0, "null")
332 
+            show_row_hclust = FALSE
333 
+        }
334 
+    }
335 
+    if(!show_row_hclust) {
336 
+        row_hclust_width = unit(0, "null")
337 
+    }
338 
+    .Object@row_hclust_list = list()
339 
+    .Object@row_hclust_param$distance = clustering_distance_rows
340 
+    .Object@row_hclust_param$method = clustering_method_rows
341 
+    .Object@row_hclust_param$side = match.arg(row_hclust_side)[1]
342 
+    .Object@row_hclust_param$width = row_hclust_width
343 
+    .Object@row_hclust_param$show = show_row_hclust
344 
+    .Object@row_hclust_param$gp = check_gp(row_hclust_gp)
345 
+    .Object@row_order_list = list(seq_len(nrow(matrix))) # default order
346 
+
347 
+    if(inherits(cluster_columns, "dendrogram") || inherits(cluster_columns, "hclust")) {
348 
+        .Object@column_hclust_param$obj = cluster_columns
349 
+        .Object@column_hclust_param$cluster = TRUE
350 
+    } else if(inherits(cluster_columns, "function")) {
351 
+        .Object@column_hclust_param$fun = cluster_columns
352 
+        .Object@column_hclust_param$cluster = TRUE
353 
+    } else {
354 
+        .Object@column_hclust_param$cluster = cluster_columns
355 
+        if(!cluster_columns) {
356 
+            column_hclust_height = unit(0, "null")
357 
+            show_column_hclust = FALSE
358 
+        }
359 
+    }
360 
+    if(!show_column_hclust) {
361 
+        column_hclust_height = unit(0, "null")
362 
+    }
363 
+    .Object@column_hclust = NULL
364 
+    .Object@column_hclust_param$distance = clustering_distance_columns
365 
+    .Object@column_hclust_param$method = clustering_method_columns
366 
+    .Object@column_hclust_param$side = match.arg(column_hclust_side)[1]
367 
+    .Object@column_hclust_param$height = column_hclust_height
368 
+    .Object@column_hclust_param$show = show_column_hclust
369 
+    .Object@column_hclust_param$gp = check_gp(column_hclust_gp)
370 
+    .Object@column_order = seq_len(ncol(matrix))
371 
+
372 
+    .Object@top_annotation = top_annotation # a `HeatmapAnnotation` object
373 
+    if(is.null(top_annotation)) {
374 
+        .Object@top_annotation_param$height = unit(0, "null")
375 
+    } else {
376 
+        .Object@top_annotation_param$height = top_annotation_height
377 
+    }
378 
+    if(!is.null(top_annotation)) {
379 
+        if(length(top_annotation@anno_list) > 0) {
380 
+            if(!.Object@top_annotation@which == "column") {
381 
+                stop("`which` in `top_annotation` should only be `column`.")
382 
+            }
383 
+        }
384 
+    }
385 
+
386 
+    .Object@bottom_annotation = bottom_annotation # a `HeatmapAnnotation` object
387 
+    if(is.null(bottom_annotation)) {
388 
+        .Object@bottom_annotation_param$height = unit(0, "null")
389 
+    } else {
390 
+        .Object@bottom_annotation_param$height = bottom_annotation_height
391 
+    }
392 
+    if(!is.null(bottom_annotation)) {
393 
+        if(length(bottom_annotation@anno_list) > 0) {
394 
+            if(!.Object@bottom_annotation@which == "column") {
395 
+                stop("`which` in `bottom_annotation` should only be `column`.")
396 
+            }
397 
+        }
398 
+    }
399 
+
400 
+    .Object@layout = list(
401 
+        layout_column_title_top_height = unit(0, "null"),
402 
+        layout_column_hclust_top_height = unit(0, "null"),
403 
+        layout_column_anno_top_height = unit(0, "null"),
404 
+        layout_column_names_top_height = unit(0, "null"),
405 
+        layout_column_title_bottom_height = unit(0, "null"),
406 
+        layout_column_hclust_bottom_height = unit(0, "null"),
407 
+        layout_column_anno_bottom_height = unit(0, "null"),
408 
+        layout_column_names_bottom_height = unit(0, "null"),
409 
+
410 
+        layout_row_title_left_width = unit(0, "null"),
411 
+        layout_row_hclust_left_width = unit(0, "null"),
412 
+        layout_row_names_left_width = unit(0, "null"),
413 
+        layout_row_hclust_right_width = unit(0, "null"),
414 
+        layout_row_names_right_width = unit(0, "null"),
415 
+        layout_row_title_right_width = unit(0, "null"),
416 
+
417 
+        layout_heatmap_width = width, # for the layout of heatmap list
418 
+
419 
+        layout_index = matrix(nrow = 0, ncol = 2),
420 
+        graphic_fun_list = list()
421 
+    )
422 
+
423 
+    return(.Object)
424 
+
425 
+}
426 
+
427 
+# == title
428 
+# Make cluster on columns
429 
+#
430 
+# == param
431 
+# -object a `Heatmap-class` object.
432 
+# -order a pre-defined order.
433 
+#
434 
+# == details
435 
+# The function will fill or adjust ``column_hclust`` and ``column_order`` slots.
436 
+#
437 
+# This function is only for internal use.
438 
+#
439 
+# == value
440 
+# A `Heatmap-class` object.
441 
+#
442 
+# == author
443 
+# Zuguang Gu <z.gu@dkfz.de>
444 
+#
445 
+setMethod(f = "make_column_cluster",
446 
+    signature = "Heatmap",
447 
+    definition = function(object, order = NULL) {
448 
+
449 
+    mat = object@matrix
450 
+    distance = object@column_hclust_param$distance
451 
+    method = object@column_hclust_param$method
452 
+
453 
+    if(is.null(order)) {
454 
+        if(!is.null(object@column_hclust_param$obj)) {
455 
+            object@column_hclust = object@column_hclust_param$obj
456 
+        } else if(!is.null(object@column_hclust_param$fun)) {
457 
+            object@column_hclust = object@column_hclust_param$fun(t(mat))
458 
+        } else {
459 
+            object@column_hclust = hclust(get_dist(t(mat), distance), method = method)
460 
+        }
461 
+        column_order = get_hclust_order(object@column_hclust)
462 
+    } else {
463 
+        column_order = order
464 
+    }
465 
+
466 
+    object@column_order = column_order
467 
+
468 
+    return(object)
469 
+})
470 
+
471 
+
472 
+# == title
473 
+# Make cluster on rows
474 
+#
475 
+# == param
476 
+# -object a `Heatmap-class` object.
477 
+# -order a pre-defined order.
478 
+# -km if apply k-means clustering on rows, number of clusters.
479 
+# -split a vector or a data frame by which the rows are be split.
480 
+#
481 
+# == details
482 
+# The function will fill or adjust ``row_hclust_list``, ``row_order_list``, ``row_title`` and ``matrix_param`` slots.
483 
+#
484 
+# If ``order`` is defined, no clustering will be applied.
485 
+#
486 
+# This function is only for internal use.
487 
+#
488 
+# == value
489 
+# A `Heatmap-class` object.
490 
+#
491 
+# == author
492 
+# Zuguang Gu <z.gu@dkfz.de>
493 
+#
494 
+setMethod(f = "make_row_cluster",
495 
+    signature = "Heatmap",
496 
+    definition = function(object, order = NULL, km = object@matrix_param$km,
497 
+    split = object@matrix_param$split) {
498 
+
499 
+    mat = object@matrix
500 
+    distance = object@row_hclust_param$distance
501 
+    method = object@row_hclust_param$method
502 
+
503 
+    if(is.null(order)) {
504 
+
505 
+        if(!is.null(object@row_hclust_param$obj)) {
506 
+            if(km > 1) {
507 
+                stop("You can not make k-means clustering since you have already specified a clustering object.")
508 
+            }
509 
+            if(!is.null(split)) {
510 
+                stop("You can not split by rows since you have already specified a clustering object.")
511 
+            }
512 
+            object@row_hclust_list = list(object@row_hclust_param$obj)
513 
+            object@row_order_list = list(get_hclust_order(object@row_hclust_param$obj))
514 
+            return(object)
515 
+        }
516 
+
517 
+        row_order = seq_len(nrow(mat))  # default row order
518 
+    } else {
519 
+        row_order = order
520 
+    }
521 
+
522 
+    # make k-means clustering to add a split column
523 
+    if(km > 1 && is.numeric(mat)) {
524 
+        km.fit = kmeans(mat, centers = km)
525 
+        cluster = km.fit$cluster
526 
+        meanmat = lapply(unique(cluster), function(i) {
527 
+            colMeans(mat[cluster == i, , drop = FALSE])
528 
+        })
529 
+        meanmat = as.matrix(as.data.frame(meanmat))
530 
+        hc = hclust(dist(t(meanmat)))
531 
+        cluster2 = numeric(length(cluster))
532 
+        for(i in seq_along(hc$order)) {
533 
+            cluster2[cluster == hc$order[i]] = i
534 
+        }
535 
+        cluster2 = paste0("cluster", cluster2)
536 
+        split = cbind(split, cluster2)
537 
+    }
538 
+
539 
+    # split the original order into a list according to split
540 
+    row_order_list = list()
541 
+    if(is.null(split)) {
542 
+        row_order_list[[1]] = row_order
543 
+    } else {
544 
+        if(is.null(ncol(split))) split = data.frame(split)
545 
+        for(i in seq_len(ncol(split))) split[[i]] = as.character(split[[i]])
546 
+        # convert the data frame into a vector
547 
+        if(ncol(split) == 1) {
548 
+            split = split[, 1]
549 
+            split_name = split
550 
+        } else {
551 
+            combined_name_fun = object@row_title_param$combined_name_fun
552 
+            if(!is.null(combined_name_fun)) {
553 
+                split_name = apply(as.matrix(split), 1, combined_name_fun)
554 
+            }
555 
+            split = apply(as.matrix(split), 1, paste, collapse = "/")
556 
+        }
557 
+
558 
+        row_levels = unique(split)
559 
+        for(i in seq_along(row_levels)) {
560 
+            l = split == row_levels[i]
561 
+            row_order_list[[i]] = row_order[l]
562 
+        }
563 
+
564 
+        if(!is.null(object@row_title_param$combined_name_fun)) {
565 
+            object@row_title = unique(split_name)
566 
+        }
567 
+    }
568 
+
569 
+    # make hclust in each slice
570 
+    if(is.null(order)) {
571 
+        row_hclust_list = rep(list(NULL), length(row_order_list))
572 
+        for(i in seq_along(row_order_list)) {
573 
+            submat = mat[ row_order_list[[i]], , drop = FALSE]
574 
+            if(nrow(submat) > 1) {
575 
+                if(!is.null(object@row_hclust_param$fun)) {
576 
+                    row_hclust_list[[i]] = object@row_hclust_param$fun(mat)
577 
+                    row_order_list[[i]] = row_order_list[[i]][ get_hclust_order(row_hclust_list[[i]]) ]
578 
+                } else {
579 
+                    if(is.numeric(mat)) {
580 
+                        row_hclust_list[[i]] = hclust(get_dist(submat, distance), method = method)
581 
+                        row_order_list[[i]] = row_order_list[[i]][ get_hclust_order(row_hclust_list[[i]]) ]
582 
+                    }
583 
+                }
584 
+            }
585 
+        }
586 
+        object@row_hclust_list = row_hclust_list
587 
+    }
588 
+    object@row_order_list = row_order_list
589 
+    object@matrix_param$split = split
590 
+
591 
+    return(object)
592 
+
593 
+})
594 
+
595 
+# == title
596 
+# Make the layout of a single heatmap
597 
+#
598 
+# == param
599 
+# -object a `Heatmap-class` object.
600 
+#
601 
+# == detail
602 
+# The layout of the single heatmap will be established by setting the size of each heatmap components.
603 
+# Also functions that make graphics for heatmap components will be recorded.
604 
+#
605 
+# Whether apply row clustering or column clustering affects the layout, so clustering should be applied
606 
+# first before making the layout.
607 
+#
608 
+# This function is only for internal use.
609 
+#
610 
+# == value
611 
+# A `Heatmap-class` object.
612 
+#
613 
+# == author
614 
+# Zuguang Gu <z.gu@dkfz.de>
615 
+#
616 
+setMethod(f = "make_layout",
617 
+    signature = "Heatmap",
618 
+    definition = function(object) {
619 
+
620 
+    # for components which are placed by rows, they will be splitted into parts
621 
+    # and slice_y controls the y-coordinates of each part
622 
+
623 
+    # position of each row-slice
624 
+    gap = object@matrix_param$gap
625 
+    n_slice = length(object@row_order_list)
626 
+    snr = sapply(object@row_order_list, length)
627 
+    slice_height = (unit(1, "npc") - gap*(n_slice-1))*(snr/sum(snr))
628 
+    for(i in seq_len(n_slice)) {
629 
+        if(i == 1) {
630 
+            slice_y = unit(1, "npc")
631 
+        } else {
632 
+            slice_y = unit.c(slice_y, unit(1, "npc") - sum(slice_height[seq_len(i-1)]) - gap*(i-1))
633 
+        }
634 
+    }
635 
+
636 
+    ###########################################
637 
+    ## heatmap body
638 
+    object@layout$layout_index = rbind(c(5, 4))
639 
+    object@layout$graphic_fun_list = list(function(object) {
640 
+        for(i in seq_len(n_slice)) {
641 
+            draw_heatmap_body(object, k = i, y = slice_y[i], height = slice_height[i], just = c("center", "top"))
642 
+        }
643 
+    })
644 
+
645 
+    ############################################
646 
+    ## title on top or bottom
647 
+    column_title = object@column_title
648 
+    column_title_side = object@column_title_param$side
649 
+    column_title_gp = object@column_title_param$gp
650 
+    if(length(column_title) > 0) {
651 
+        if(column_title_side == "top") {
652 
+            object@layout$layout_column_title_top_height = grobHeight(textGrob(column_title, gp = column_title_gp))*2
653 
+            object@layout$layout_index = rbind(object@layout$layout_index, c(1, 4))
654 
+        } else {
655 
+            object@layout$layout_column_title_bottom_height = grobHeight(textGrob(column_title, gp = column_title_gp))*2
656 
+            object@layout$layout_index = rbind(object@layout$layout_index, c(9, 4))
657 
+        }
658 
+        object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) draw_title(object, which = "column"))
659 
+    }
660 
+
661 
+    ############################################
662 
+    ## title on left or right
663 
+    row_title = object@row_title
664 
+    row_title_side = object@row_title_param$side
665 
+    row_title_gp = object@row_title_param$gp
666 
+    if(length(row_title) > 0) {
667 
+        if(row_title_side == "left") {
668 
+            object@layout$layout_row_title_left_width = max(grobHeight(textGrob(row_title, gp = row_title_gp)))*2
669 
+            object@layout$layout_index = rbind(object@layout$layout_index, c(5, 1))
670 
+        } else {
671 
+            object@layout$layout_row_title_right_width = max(grobHeight(textGrob(row_title, gp = row_title_gp)))*2
672 
+            object@layout$layout_index = rbind(object@layout$layout_index, c(5, 7))
673 
+        }
674 
+        object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) {
675 
+            for(i in seq_len(n_slice)) {
676 
+                draw_title(object, k = i, which = "row", y = slice_y[i], height = slice_height[i], just = c("center", "top"))
677 
+            }
678 
+        })
679 
+    }
680 
+
681 
+    ##########################################
682 
+    ## hclust on left or right
683 
+    show_row_hclust = object@row_hclust_param$show
684 
+    row_hclust_side = object@row_hclust_param$side
685 
+    row_hclust_width = object@row_hclust_param$width
686 
+    if(show_row_hclust) {
687 
+        if(row_hclust_side == "left") {
688 
+            object@layout$layout_row_hclust_left_width = row_hclust_width
689 
+            object@layout$layout_index = rbind(object@layout$layout_index, c(5, 2))
690 
+        } else {
691 
+            object@layout$layout_row_hclust_right_width = row_hclust_width
692 
+            object@layout$layout_index = rbind(object@layout$layout_index, c(5, 6))
693 
+        }
694 
+        #max_hclust_height = max(sapply(object@row_hclust_list, function(hc) attr(as.dendrogram(hc), "height")))
695 
+        object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) {
696 
+            for(i in seq_len(n_slice)) {
697 
+                draw_hclust(object, k = i, which = "row", y = slice_y[i], height = slice_height[i], just = c("center", "top"))
698 
+            }
699 
+        })
700 
+    }
701 
+
702 
+    ##########################################
703 
+    ## hclust on top or bottom
704 
+    show_column_hclust = object@column_hclust_param$show
705 
+    column_hclust_side = object@column_hclust_param$side
706 
+    column_hclust_height = object@column_hclust_param$height
707 
+    if(show_column_hclust) {
708 
+        if(column_hclust_side == "top") {
709 
+            object@layout$layout_column_hclust_top_height = column_hclust_height
710 
+            object@layout$layout_index = rbind(object@layout$layout_index, c(2, 4))
711 
+        } else {
712 
+            object@layout$layout_column_hclust_bottom_height = column_hclust_height
713 
+            object@layout$layout_index = rbind(object@layout$layout_index, c(8, 4))
714 
+        }
715 
+        object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) draw_hclust(object, which = "column"))
716 
+    }
717 
+
718 
+    #######################################
719 
+    ## row_names on left or right
720 
+    row_names_side = object@row_names_param$side
721 
+    show_row_names = object@row_names_param$show
722 
+    row_names = rownames(object@matrix)
723 
+    row_names_gp = object@row_names_param$gp;
724 
+    if(show_row_names) {
725 
+        row_names_width = max(do.call("unit.c", lapply(seq_along(row_names), function(x) {
726 
+            cgp = subset_gp(row_names_gp, x)
727 
+            grobWidth(textGrob(row_names[x], gp = cgp))
728 
+        }))) + unit(2, "mm")
729 
+        row_names_width = min(row_names_width, object@row_names_param$max_width)
730 
+        if(row_names_side == "left") {
731 
+            object@layout$layout_row_names_left_width = row_names_width
732 
+            object@layout$layout_index = rbind(object@layout$layout_index, c(5, 3))
733 
+        } else {
734 
+            object@layout$layout_row_names_right_width = row_names_width
735 
+            object@layout$layout_index = rbind(object@layout$layout_index, c(5, 5))
736 
+        }
737 
+        if(row_names_side == "right") {
738 
+            object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) {
739 
+                for(i in seq_len(n_slice)) {
740 
+                    draw_dimnames(object, k = i, which = "row", x = unit(2, "mm"), y = slice_y[i], height = slice_height[i], just = c("left", "top"))
741 
+                }
742 
+            })
743 
+        } else {
744 
+            object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) {
745 
+                for(i in seq_len(n_slice)) {
746 
+                    draw_dimnames(object, k = i, which = "row", x = unit(0, "npc"), y = slice_y[i], height = slice_height[i], width = unit(1, "npc") - unit(2, "mm"), just = c("left", "top"))
747 
+                }
748 
+            })
749 
+        }
750 
+    }
751 
+
752 
+    #########################################
753 
+    ## column_names on top or bottom
754 
+    column_names_side = object@column_names_param$side
755 
+    show_column_names = object@column_names_param$show
756 
+    column_names = colnames(object@matrix)
757 
+    column_names_gp = object@column_names_param$gp
758 
+    if(show_column_names) {
759 
+        column_names_height = max(do.call("unit.c", lapply(seq_along(column_names), function(x) {
760 
+            cgp = subset_gp(column_names_gp, x)
761 
+            grobWidth(textGrob(column_names[x], gp = cgp))
762 
+        }))) + unit(2, "mm")
763 
+        column_names_height = min(column_names_height, object@column_names_param$max_height)
764 
+        if(column_names_side == "top") {
765 
+            object@layout$layout_column_names_top_height = column_names_height
766 
+            object@layout$layout_index = rbind(object@layout$layout_index, c(4, 4))
767 
+        } else {
768 
+            object@layout$layout_column_names_bottom_height = column_names_height
769 
+            object@layout$layout_index = rbind(object@layout$layout_index, c(6, 4))
770 
+        }
771 
+        if(column_names_side == "top") {
772 
+            object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) draw_dimnames(object, which = "column", y = unit(1, "npc"), height = unit(1, "npc") - unit(2, "mm"), just = c("center", "top")))
773 
+        } else {
774 
+            object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) draw_dimnames(object, which = "column", y = unit(1, "npc") - unit(2, "mm"), just = c("center", "top")))
775 
+        }
776 
+    }
777 
+
778 
+    ##########################################
779 
+    ## annotation on top
780 
+    annotation = object@top_annotation
781 
+    annotation_height = object@top_annotation_param$height
782 
+    if(!is.null(annotation)) {
783 
+        if(length(annotation@anno_list) > 0) {
784 
+            object@layout$layout_column_anno_top_height = annotation_height
785 
+            object@layout$layout_index = rbind(object@layout$layout_index, c(3, 4))
786 
+
787 
+            object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) draw_annotation(object, which = "top"))
788 
+        }
789 
+    }
790 
+
791 
+    ##########################################
792 
+    ## annotation on bottom
793 
+    annotation = object@bottom_annotation
794 
+    annotation_height = object@bottom_annotation_param$height
795 
+    if(!is.null(annotation)) {
796 
+        if(length(annotation@anno_list) > 0) {
797 
+            object@layout$layout_column_anno_bottom_height = annotation_height
798 
+            object@layout$layout_index = rbind(object@layout$layout_index, c(7, 4))
799 
+            object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) draw_annotation(object, which = "bottom"))
800 
+        }
801 
+    }
802 
+
803 
+    return(object)
804 
+})
805 
+
806 
+# == title
807 
+# Draw the single heatmap with default parameters
808 
+#
809 
+# == param
810 
+# -object a `Heatmap-class` object.
811 
+#
812 
+# == details
813 
+# Actually it calls `draw,Heatmap-method`, but only with default parameters. If users want to customize the heatmap,
814 
+# they can pass parameters directly to `draw,Heatmap-method`.
815 
+#
816 
+# == value
817 
+# This function returns no value.
818 
+#
819 
+# == author
820 
+# Zuguang Gu <z.gu@dkfz.de>
821 
+#
822 
+setMethod(f = "show",
823 
+    signature = "Heatmap",
824 
+    definition = function(object) {
825 
+
826 
+    # cat("A Heatmap object:\n")
827 
+    # cat("name:", object@name, "\n")
828 
+    # cat("dim:", nrow(object@matrix), "x", ncol(object@matrix), "\n")
829 
+    draw(object)
830 
+})
831 
+
832 
+# == title
833 
+# Add heatmaps or row annotations as a heatmap list
834 
+#
835 
+# == param
836 
+# -object a `Heatmap-class` object.
837 
+# -x a `Heatmap-class` object, a `HeatmapAnnotation-class` object or a `HeatmapList-class` object.
838 
+#
839 
+# == details
840 
+# There is a shortcut function ``+.AdditiveUnit``.
841 
+#
842 
+# == value
843 
+# A `HeatmapList-class` object.
844 
+#
845 
+# == author
846 
+# Zuguang Gu <z.gu@dkfz.de>
847 
+#
848 
+setMethod(f = "add_heatmap",
849 
+    signature = "Heatmap",
850 
+    definition = function(object, x) {
851 
+
852 
+    ht_list = new("HeatmapList")
853 
+    ht_list = add_heatmap(ht_list, object)
854 
+    ht_list = add_heatmap(ht_list, x)
855 
+    return(ht_list)
856 
+
857 
+})
858 
+
859 
+# == title
860 
+# Draw the heatmap body
861 
+#
862 
+# == param
863 
+# -object a `Heatmap-class` object.
864 
+# -k a matrix may be split by rows, the value identifies which row-slice.
865 
+# -... pass to `grid::viewport`, basically for defining the position of the viewport.
866 
+#
867 
+# == details
868 
+# The matrix can be split into several parts by rows if ``km`` or ``split`` is
869 
+# specified when initializing the `Heatmap` object. If the matrix is split,
870 
+# there will be gaps between rows to identify different row-slice.
871 
+#
872 
+# A viewport is created which contains subset rows of the heatmap.
873 
+#
874 
+# This function is only for internal use.
875 
+#
876 
+# == value
877 
+# This function returns no value.
878 
+#
879 
+# == author
880 
+# Zuguang Gu <z.gu@dkfz.de>
881 
+#
882 
+setMethod(f = "draw_heatmap_body",
883 
+    signature = "Heatmap",
884 
+    definition = function(object, k = 1, ...) {
885 
+
886 
+    if(ncol(object@matrix) == 0) {
887 
+        return(invisible(NULL))
888 
+    }
889 
+
890 
+    row_order = object@row_order_list[[k]]
891 
+    column_order = object@column_order
892 
+
893 
+    gp = object@matrix_param$gp
894 
+
895 
+    pushViewport(viewport(name = paste(object@name, "heatmap_body", k, sep = "_"), ...))
896 
+
897 
+    mat = object@matrix[row_order, column_order, drop = FALSE]
898 
+    col_matrix = map_to_colors(object@matrix_color_mapping, mat)
899 
+
900 
+    nc = ncol(mat)
901 
+    nr = nrow(mat)
902 
+    x = (seq_len(nc) - 0.5) / nc
903 
+    y = (rev(seq_len(nr)) - 0.5) / nr
904 
+    expand_index = expand.grid(seq_len(nr), seq_len(nc))
905 
+    if(any(names(gp) %in% c("type"))) {
906