Browse code

a backup push

Zuguang Gu authored on 18/09/2018 10:40:29
Showing39 changed files

... ...
@@ -9,7 +9,7 @@
9 9
 AdditiveUnit = setClass("AdditiveUnit")
10 10
 
11 11
 # == title
12
-# Constructor method for AdditiveUnit class
12
+# Constructor Method for AdditiveUnit Class
13 13
 #
14 14
 # == param
15 15
 # -... black hole arguments.
... ...
@@ -23,21 +23,17 @@ AdditiveUnit = setClass("AdditiveUnit")
23 23
 # == author
24 24
 # Zuguang Gu <z.gu@dkfz.de>
25 25
 #
26
-# == example
27
-# # no example for this function
28
-# NULL
29
-#
30 26
 AdditiveUnit = function(...) {
31 27
     new("AdditiveUnit", ...)
32 28
 }
33 29
 
34 30
 
35 31
 # == title
36
-# Add heatmaps or row annotations to a heatmap list
32
+# Horizontally Add Heatmaps or Annotations to a Heatmap List
37 33
 #
38 34
 # == param
39
-# -x a `Heatmap-class` object, a `HeatmapAnnotation-class` object or a `HeatmapList-class` object.
40
-# -y a `Heatmap-class` object, a `HeatmapAnnotation-class` object or a `HeatmapList-class` object.
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.
41 37
 #
42 38
 # == detail
43 39
 # It is only a helper function. It actually calls `add_heatmap,Heatmap-method`, `add_heatmap,HeatmapList-method`
... ...
@@ -48,6 +44,9 @@ AdditiveUnit = function(...) {
48 44
 # == value
49 45
 # A `HeatmapList-class` object.
50 46
 #
47
+# == seealso
48
+# `%v%` operator is used for vertical heatmap list.
49
+#
51 50
 # == author
52 51
 # Zuguang Gu <z.gu@dkfz.de>
53 52
 #
... ...
@@ -64,9 +63,11 @@ AdditiveUnit = function(...) {
64 63
     }
65 64
     if(is.null(x)) {
66 65
         ht_list = new("HeatmapList")
66
+        ht_list@direction = "horizontal"
67 67
         add_heatmap(ht_list, y)
68 68
     } else if(is.null(y)) {
69 69
         ht_list = new("HeatmapList")
70
+        ht_list@direction = "horizontal"
70 71
         add_heatmap(ht_list, x)
71 72
     } else {
72 73
         add_heatmap(x, y)
... ...
@@ -74,6 +75,28 @@ AdditiveUnit = function(...) {
74 75
 }
75 76
 
76 77
 
78
+# == title
79
+# Vertically Add Heatmaps or Annotations to a Heatmap List
80
+#
81
+# == param
82
+# -x A `Heatmap-class` object, a `HeatmapAnnotation-class` object or a `HeatmapList-class` object.
83
+# -y A `Heatmap-class` object, a `HeatmapAnnotation-class` object or a `HeatmapList-class` object.
84
+#
85
+# == detail
86
+# It is only a helper function. It actually calls `add_heatmap,Heatmap-method`, `add_heatmap,HeatmapList-method`
87
+# or `add_heatmap,HeatmapAnnotation-method` depending on the class of the input objects.
88
+#
89
+# The `HeatmapAnnotation-class` object to be added should only be column annotations.
90
+#
91
+# == value
92
+# A `HeatmapList-class` object.
93
+#
94
+# == seealso
95
+# `+.AdditiveUnit` operator is used for vertical heatmap list.
96
+#
97
+# == author
98
+# Zuguang Gu <z.gu@dkfz.de>
99
+#
77 100
 "%v%" = function(x, y) {
78 101
     if(inherits(x, "HeatmapAnnotation")) {
79 102
         if(x@which != "column") {
... ...
@@ -87,9 +110,11 @@ AdditiveUnit = function(...) {
87 110
     }
88 111
     if(is.null(x)) {
89 112
         ht_list = new("HeatmapList")
113
+        ht_list@direction = "vertical"
90 114
         add_heatmap(ht_list, y, direction = "vertical")
91 115
     } else if(is.null(y)) {
92 116
         ht_list = new("HeatmapList")
117
+        ht_list@direction = "vertical"
93 118
         add_heatmap(ht_list, x, direction = "vertical")
94 119
     } else {
95 120
         add_heatmap(x, y, direction = "vertical")
... ...
@@ -91,14 +91,17 @@ ColorMapping = function(name, colors = NULL, levels = NULL,
91 91
 			if(is.null(breaks)) {
92 92
 				stop("You should provide breaks.\n")
93 93
 			}
94
-		}
94
+		
95 95
 
96
-		le1 = grid.pretty(range(breaks))
97
-		le2 = pretty(breaks, n = 3)
98
-		if(abs(length(le1) - 5) < abs(length(le2) - 5)) {
99
-			le = le1
96
+			le1 = grid.pretty(range(breaks))
97
+			le2 = pretty(breaks, n = 3)
98
+			if(abs(length(le1) - 5) < abs(length(le2) - 5)) {
99
+				le = le1
100
+			} else {
101
+				le = le2
102
+			}
100 103
 		} else {
101
-			le = le2
104
+			le = breaks
102 105
 		}
103 106
 
104 107
 		.Object@colors = col_fun(le)
... ...
@@ -245,7 +248,7 @@ setMethod(f = "color_mapping_legend",
245 248
 	plot = TRUE,
246 249
 	title = object@name,
247 250
 	title_gp = gpar(fontsize = 10, fontface = "bold"),
248
-	title_position = c("topleft", "topcenter", "leftcenter", "lefttop"),
251
+	title_position = "topleft",
249 252
 	color_bar = object@type,
250 253
 	grid_height = unit(4, "mm"),
251 254
 	grid_width = unit(4, "mm"),
... ...
@@ -237,6 +237,7 @@ Heatmap = function(matrix, col, name,
237 237
     rect_gp = gpar(col = NA), 
238 238
     border = NA,
239 239
     cell_fun = NULL,
240
+    layer_fun = NULL,
240 241
 
241 242
     row_title = character(0), 
242 243
     row_title_side = c("left", "right"), 
... ...
@@ -291,9 +292,9 @@ Heatmap = function(matrix, col, name,
291 292
     row_split = split,
292 293
     column_km = 1,
293 294
     column_split = NULL,
294
-    gap = unit(1, "mm"),
295
-    row_gap = unit(1, "mm"),
296
-    column_gap = unit(1, "mm"),
295
+    gap = unit(0.5, "mm"),
296
+    row_gap = unit(0.5, "mm"),
297
+    column_gap = unit(0.5, "mm"),
297 298
 
298 299
     width = unit(1, "npc"),
299 300
     heatmap_body_width = NULL,
... ...
@@ -473,6 +474,7 @@ Heatmap = function(matrix, col, name,
473 474
     if(identical(border, TRUE)) border = "black"
474 475
     .Object@matrix_param$border = border
475 476
     .Object@matrix_param$cell_fun = cell_fun
477
+    .Object@matrix_param$layer_fun = layer_fun
476 478
     
477 479
     if(!missing(heatmap_body_width)) {
478 480
         if(is_abs_unit(heatmap_body_width)) {
... ...
@@ -492,7 +494,6 @@ Heatmap = function(matrix, col, name,
492 494
     }
493 495
     .Object@matrix_param$width = heatmap_body_width
494 496
     .Object@matrix_param$height = heatmap_body_height
495
-    
496 497
 
497 498
     ### color for main matrix #########
498 499
     if(ncol(matrix) > 0 && nrow(matrix) > 0) {
... ...
@@ -721,8 +722,8 @@ Heatmap = function(matrix, col, name,
721 722
         }
722 723
         nb = nobs(left_annotation)
723 724
         if(!is.na(nb)) {
724
-            if(nb != ncol(.Object@matrix)) {
725
-                stop("number of items in left anntotion should be same as number of columns of the matrix.")
725
+            if(nb != nrow(.Object@matrix)) {
726
+                stop("number of items in left anntotion should be same as number of rows of the matrix.")
726 727
             }
727 728
         }
728 729
     }
... ...
@@ -741,8 +742,8 @@ Heatmap = function(matrix, col, name,
741 742
         }
742 743
         nb = nobs(right_annotation)
743 744
         if(!is.na(nb)) {
744
-            if(nb != ncol(.Object@matrix)) {
745
-                stop("number of items in left anntotion should be same as number of columns of the matrix.")
745
+            if(nb != nrow(.Object@matrix)) {
746
+                stop("number of items in right anntotion should be same as number of rows of the matrix.")
746 747
             }
747 748
         }
748 749
     }
... ...
@@ -781,6 +782,15 @@ Heatmap = function(matrix, col, name,
781 782
     .Object@heatmap_param$raster_device_param = raster_device_param
782 783
     .Object@heatmap_param$verbose = verbose
783 784
 
785
+    if(nrow(matrix) == 0) {
786
+        .Object@heatmap_param$height = unit(0, "mm")
787
+        .Object@matrix_param$height = unit(0, "mm")
788
+    }
789
+    if(ncol(matrix) == 0) {
790
+        .Object@heatmap_param$width = unit(0, "mm")
791
+        .Object@matrix_param$width = unit(0, "mm")
792
+    }
793
+
784 794
     return(.Object)
785 795
 
786 796
 }
... ...
@@ -1235,1426 +1245,114 @@ make_cluster = function(object, which = c("row", "column")) {
1235 1245
 }
1236 1246
 
1237 1247
 # == title
1238
-# Make the Layout of a Single Heatmap
1248
+# Draw a Single Heatmap
1239 1249
 #
1240 1250
 # == param
1241 1251
 # -object A `Heatmap-class` object.
1242
-# 
1243
-# == detail
1244
-# The layout of the single heatmap will be established by setting the size of each heatmap components.
1245
-# Also functions that make graphics for heatmap components will be recorded by saving as functions.
1252
+# -internal If ``TRUE``, it is only used inside the calling of `draw,HeatmapList-method`. 
1253
+#           It only draws the heatmap without legends where the legend will be drawn by `draw,HeatmapList-method`. 
1254
+# -test Only for testing. If it is ``TRUE``, the heatmap body is directly drawn.
1255
+# -... Pass to `draw,HeatmapList-method`.
1246 1256
 #
1247
-# Whether to apply row clustering or column clustering affects the layout, so clustering should be applied 
1248
-# first before making the layout.
1257
+# == detail
1258
+# The function creates a `HeatmapList-class` object which only contains a single heatmap
1259
+# and call `draw,HeatmapList-method` to make the final heatmap.
1249 1260
 #
1250
-# This function is only for internal use.
1261
+# There are some arguments which control the global setting of the heatmap such as legends.
1262
+# Please go to `draw,HeatmapList-method` for these arguments.
1251 1263
 #
1252 1264
 # == value
1253
-# A `Heatmap-class` object.
1265
+# A `HeatmapList-class` object.
1254 1266
 #
1255 1267
 # == author
1256 1268
 # Zuguang Gu <z.gu@dkfz.de>
1257 1269
 #
1258
-setMethod(f = "make_layout",
1270
+setMethod(f = "draw",
1259 1271
     signature = "Heatmap",
1260
-    definition = function(object) {
1261
-
1262
-    # position of each row-slice
1263
-    row_gap = object@matrix_param$row_gap
1264
-    column_gap = object@matrix_param$column_gap
1265
-    nr_slice = length(object@row_order_list)
1266
-    nc_slice = length(object@column_order_list)
1267
-
1268
-    snr = sapply(object@row_order_list, length)
1269
-    snc = sapply(object@column_order_list, length)
1270
-    if(nr_slice == 1) {
1271
-        slice_height = unit(1, "npc")
1272
-    } else {
1273
-        slice_height = (unit(1, "npc") - sum(row_gap[seq_len(nr_slice-1)]))*(snr/sum(snr))
1274
-    }
1275
-    for(i in seq_len(nr_slice)) {
1276
-        if(i == 1) {
1277
-            slice_y = unit(1, "npc")
1278
-        } else {
1279
-            slice_y = unit.c(slice_y, unit(1, "npc") - sum(slice_height[seq_len(i-1)]) - sum(row_gap[seq_len(i-1)]))
1280
-        }
1281
-    }
1282
-
1283
-    if(nc_slice == 1) {
1284
-        slice_width = unit(1, "npc")
1285
-    } else {
1286
-        slice_width = (unit(1, "npc") - sum(column_gap[seq_len(nc_slice-1)]))*(snc/sum(snc))
1287
-    }
1288
-    for(i in seq_len(nc_slice)) {
1289
-        if(i == 1) {
1290
-            slice_x = unit(0, "npc")
1291
-        } else {
1292
-            slice_x = unit.c(slice_x, sum(slice_width[seq_len(i-1)]) + sum(column_gap[seq_len(i-1)]))
1293
-        }
1294
-    }
1295
-    object@layout$slice = list(
1296
-        x = slice_x, 
1297
-        y = slice_y, 
1298
-        width = slice_width, 
1299
-        height = slice_height,
1300
-        just = c("left", "top")
1301
-    )
1302
-
1303
-    if(length(object@matrix)) {
1304
-        
1305
-        ###########################################
1306
-        ## heatmap body
1307
-        object@layout$layout_index = rbind(heatmapb_body = heatmap_layout_index("heatmap_body"))
1308
-        object@layout$graphic_fun_list = list(function(object) {
1309
-            for(i in seq_len(nr_slice)) {
1310
-                for(j in seq_len(nc_slice)) {
1311
-                    draw_heatmap_body(object, kr = i, kc = j, x = slice_x[j], y = slice_y[i], width = slice_width[j], height = slice_height[i], just = c("left", "top"))
1312
-                }
1313
-            }
1314
-        })
1315
-    }
1316
-
1317
-    ############################################
1318
-    ## title on top or bottom
1319
-    column_title = object@column_title
1320
-    column_title_side = object@column_title_param$side
1321
-    column_title_gp = object@column_title_param$gp
1322
-    column_title_rot = object@column_title_param$rot
1323
-    if(length(column_title) > 0) {
1324
-        if(column_title_side == "top") {
1325
-            if(column_title_rot %in% c(0, 180)) {
1326
-                object@layout$layout_size$column_title_top_height = grobHeight(textGrob(column_title, gp = column_title_gp)) + TITLE_PADDING*2
1327
-            } else {
1328
-                object@layout$layout_size$column_title_top_height = grobWidth(textGrob(column_title, gp = column_title_gp)) + TITLE_PADDING*2
1329
-            }
1330
-            object@layout$layout_index = rbind(object@layout$layout_index, column_title_top = heatmap_layout_index("column_title_top"))
1331
-        } else {
1332
-            if(column_title_rot %in% c(0, 180)) {
1333
-                object@layout$layout_size$column_title_bottom_height = grobHeight(textGrob(column_title, gp = column_title_gp)) + TITLE_PADDING*2
1334
-            } else {
1335
-                object@layout$layout_size$column_title_bottom_height = grobWidth(textGrob(column_title, gp = column_title_gp)) + TITLE_PADDING*2
1336
-            }
1337
-            object@layout$layout_index = rbind(object@layout$layout_index, column_title_bottom = heatmap_layout_index("column_title_bottom"))
1338
-        }
1339
-        object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) {
1340
-            if(length(column_title) == 1 && nc_slice > 1) {
1341
-                draw_title(object, k = 1, which = "column")
1342
-            } else {
1343
-                for(i in seq_len(nc_slice)) {
1344
-                    draw_title(object, k = i, which = "column", x = slice_x[i], width = slice_width[i], just = "left")
1345
-                }
1346
-            }
1347
-        })
1348
-    }
1349
-
1350
-    ############################################
1351
-    ## title on left or right
1352
-    row_title = object@row_title
1353
-    row_title_side = object@row_title_param$side
1354
-    row_title_gp = object@row_title_param$gp
1355
-    row_title_rot = object@row_title_param$rot
1356
-    if(length(row_title) > 0) {
1357
-        if(row_title_side == "left") {
1358
-            if(row_title_rot %in% c(0, 180)) {
1359
-                object@layout$layout_size$row_title_left_width = max_text_width(row_title, gp = row_title_gp) + TITLE_PADDING*2
1360
-            } else {
1361
-                object@layout$layout_size$row_title_left_width = max_text_height(row_title, gp = row_title_gp) + TITLE_PADDING*2
1362
-            }
1363
-            object@layout$layout_index = rbind(object@layout$layout_index, row_title_left = heatmap_layout_index("row_title_left"))
1364
-        } else {
1365
-            if(row_title_rot %in% c(0, 180)) {
1366
-                object@layout$layout_size$row_title_right_width = max_text_width(row_title, gp = row_title_gp) + TITLE_PADDING*2
1367
-            } else {
1368
-                object@layout$layout_size$row_title_right_width = max_text_height(row_title, gp = row_title_gp) + TITLE_PADDING*2
1369
-            }
1370
-            object@layout$layout_index = rbind(object@layout$layout_index, row_title_right = heatmap_layout_index("row_title_right"))
1371
-        }
1372
-        object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) {
1373
-            if(length(row_title) == 1 && nr_slice > 1) {
1374
-                draw_title(object, k = 1, which = "row")
1375
-            } else {
1376
-                for(i in seq_len(nr_slice)) {
1377
-                    draw_title(object, k = i, which = "row", y = slice_y[i], height = slice_height[i], just = "top")
1378
-                }
1379
-            }
1380
-        })
1381
-    }
1272
+    definition = function(object, internal = FALSE, test = FALSE, ...) {
1382 1273
 
1383
-    ##########################################
1384
-    ## dend on left or right
1385
-    show_row_dend = object@row_dend_param$show
1386
-    row_dend_side = object@row_dend_param$side
1387
-    row_dend_width = object@row_dend_param$width
1388
-    row_dend_slice = object@row_dend_slice
1389
-    if(show_row_dend) {
1390
-        if(row_dend_side == "left") {
1391
-            object@layout$layout_size$row_dend_left_width = row_dend_width
1392
-            object@layout$layout_index = rbind(object@layout$layout_index, row_dend_left = heatmap_layout_index("row_dend_left"))
1274
+    if(test) {
1275
+        object = prepare(object)
1276
+        grid.newpage()
1277
+        if(is_abs_unit(object@heatmap_param$width)) {
1278
+            width = object@heatmap_param$width
1393 1279
         } else {
1394
-            object@layout$layout_size$row_dend_right_width = row_dend_width
1395
-            object@layout$layout_index = rbind(object@layout$layout_index, row_dend_right = heatmap_layout_index("row_dend_right"))
1280
+            width = 0.8
1396 1281
         }
1397
-        row_dend_max_height = dend_heights(row_dend_slice) + max(dend_heights(object@row_dend_list))
1398
-        object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) {
1399
-            
1400
-            if(row_dend_side == "left") {
1401
-                pushViewport(viewport(x = unit(0, "npc"), width = unit(1, "npc") - DENDROGRAM_PADDING, just = "left"))
1402
-            } else {
1403
-                pushViewport(viewport(x = DENDROGRAM_PADDING, width = unit(1, "npc") - DENDROGRAM_PADDING, just = "left"))
1404
-            }
1405
-            for(i in seq_len(nr_slice)) {
1406
-                draw_dend(object, k = i, which = "row", y = slice_y[i], height = slice_height[i], just = "top",
1407
-                    max_height = row_dend_max_height)
1408
-            }
1409
-
1410
-            if(nr_slice > 1) {
1411
-                if(row_dend_side == "left") {
1412
-                    pushViewport(viewport(xscale = c(0, row_dend_max_height)))
1413
-                } else {
1414
-                    pushViewport(viewport(xscale = c(0, row_dend_max_height)))
1415
-                }
1416
-                p = sapply(object@row_dend_list, function(x) {
1417
-                    attr(x, "x")/nobs(x)
1418
-                })
1419
-
1420
-                nb = sapply(object@row_dend_list, nobs)
1421
-
1422
-                slice_leaf_pos = slice_y
1423
-                for(i in seq_len(nr_slice)) {
1424
-                    slice_leaf_pos[i] = slice_leaf_pos[i] - slice_height[i]*p[i]
1425
-                }
1426
-                row_dend_slice = merge(row_dend_slice, object@row_dend_list, only_parent = TRUE)
1427
-                row_dend_slice = adjust_dend_by_x(row_dend_slice, slice_leaf_pos)
1428
-                grid.dendrogram(row_dend_slice, facing = ifelse(row_dend_side == "left", "right", "left"))
1429
-                popViewport()
1430
-            }
1431
-            upViewport()
1432
-        })
1433
-    }
1434
-
1435
-    ##########################################
1436
-    ## dend on top or bottom
1437
-    show_column_dend = object@column_dend_param$show
1438
-    column_dend_side = object@column_dend_param$side
1439
-    column_dend_height = object@column_dend_param$height
1440
-    column_dend_slice = object@column_dend_slice
1441
-    if(show_column_dend) {
1442
-        if(column_dend_side == "top") {
1443
-            object@layout$layout_size$column_dend_top_height = column_dend_height
1444
-            object@layout$layout_index = rbind(object@layout$layout_index, column_dend_top = heatmap_layout_index("column_dend_top"))
1282
+        if(is_abs_unit(object@heatmap_param$height)) {
1283
+            height = object@heatmap_param$height
1445 1284
         } else {
1446
-            object@layout$layout_size$column_dend_bottom_height = column_dend_height
1447
-            object@layout$layout_index = rbind(object@layout$layout_index, column_dend_bottom = heatmap_layout_index("column_dend_bottom"))
1285
+            height = 0.8
1448 1286
         }
1449
-        column_dend_max_height = dend_heights(column_dend_slice) + max(dend_heights(object@column_dend_list))
1450
-        object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) {
1451
-            if(column_dend_side == "top") {
1452
-                pushViewport(viewport(y = DENDROGRAM_PADDING, height = unit(1, "npc") - DENDROGRAM_PADDING, just = "bottom"))
1453
-            } else {
1454
-                pushViewport(viewport(y = unit(0, "npc"), height = unit(1, "npc") - DENDROGRAM_PADDING, just = "bottom"))
1455
-            }
1456
-            for(i in seq_len(nc_slice)) {
1457
-                draw_dend(object, k = i, which = "column", x = slice_x[i], width = slice_width[i], just = "left",
1458
-                    max_height = column_dend_max_height)
1459
-            }
1460
-
1461
-            if(nc_slice > 1) {
1462
-                if(column_dend_side == "top") {
1463
-                    pushViewport(viewport(yscale = c(0, column_dend_max_height)))
1287
+        pushViewport(viewport(width = width, height = height))
1288
+        draw(object, internal = TRUE)
1289
+        upViewport()
1290
+    } else {
1291
+        if(internal) {  # a heatmap without legend
1292
+            if(ncol(object@matrix) == 0 || nrow(object@matrix) == 0) return(invisible(NULL))
1293
+            layout = grid.layout(nrow = length(HEATMAP_LAYOUT_COLUMN_COMPONENT), 
1294
+                ncol = length(HEATMAP_LAYOUT_ROW_COMPONENT), widths = component_width(object), 
1295
+                heights = component_height(object))
1296
+            pushViewport(viewport(layout = layout))
1297
+            ht_layout_index = object@layout$layout_index
1298
+            ht_graphic_fun_list = object@layout$graphic_fun_list
1299
+            for(j in seq_len(nrow(ht_layout_index))) {
1300
+                if(HEATMAP_LAYOUT_COLUMN_COMPONENT["heatmap_body"] %in% ht_layout_index[j, 1] && 
1301
+                   HEATMAP_LAYOUT_ROW_COMPONENT["heatmap_body"] %in% ht_layout_index[j, 2]) {
1302
+                    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 = "_")))
1464 1303
                 } else {
1465
-                    pushViewport(viewport(yscale = c(0, column_dend_max_height)))
1466
-                }
1467
-                p = sapply(object@column_dend_list, function(x) {
1468
-                    attr(x, "x")/nobs(x)
1469
-                })
1470
-
1471
-                nb = sapply(object@column_dend_list, nobs)
1472
-
1473
-                slice_leaf_pos = slice_x
1474
-                for(i in seq_len(nc_slice)) {
1475
-                    slice_leaf_pos[i] = slice_leaf_pos[i] + slice_width[i]*p[i]
1304
+                    pushViewport(viewport(layout.pos.row = ht_layout_index[j, 1], layout.pos.col = ht_layout_index[j, 2]))
1476 1305
                 }
1477
-                column_dend_slice = merge(column_dend_slice, object@column_dend_list, only_parent = TRUE)
1478
-                column_dend_slice = adjust_dend_by_x(column_dend_slice, slice_leaf_pos)
1479
-                grid.dendrogram(column_dend_slice, facing = ifelse(column_dend_side == "top", "bottom", "top"))
1480
-                popViewport()
1306
+                ht_graphic_fun_list[[j]](object)
1307
+                upViewport()
1481 1308
             }
1482 1309
             upViewport()
1483
-        })
1484
-    }
1485
-
1486
-    #######################################
1487
-    ## row_names on left or right
1488
-    row_names_side = object@row_names_param$side
1489
-    show_row_names = object@row_names_param$show
1490
-    row_names_anno = object@row_names_param$anno
1491
-    if(show_row_names) {
1492
-        row_names_width = row_names_anno@width + DIMNAME_PADDING*2
1493
-        row_names_width = min(row_names_width, object@row_names_param$max_width)
1494
-        if(row_names_side == "left") {
1495
-            object@layout$layout_size$row_names_left_width = row_names_width
1496
-            object@layout$layout_index = rbind(object@layout$layout_index, row_names_left = heatmap_layout_index("row_names_left"))
1497
-        } else {
1498
-            object@layout$layout_size$row_names_right_width = row_names_width
1499
-            object@layout$layout_index = rbind(object@layout$layout_index, row_names_right = heatmap_layout_index("row_names_right"))
1500
-        }
1501
-        object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) {
1502
-            for(i in seq_len(nr_slice)) {
1503
-                draw_dimnames(object, k = i, which = "row", y = slice_y[i], 
1504
-                    height = slice_height[i], width = unit(1, "npc") - DIMNAME_PADDING*2, just = "top")
1505
-            }
1506
-        })
1507
-    }
1508
-
1509
-    #########################################
1510
-    ## column_names on top or bottom
1511
-    column_names_side = object@column_names_param$side
1512
-    show_column_names = object@column_names_param$show
1513
-    column_names_anno = object@column_names_param$anno
1514
-    if(show_column_names) {
1515
-        column_names_height = column_names_anno@height + DIMNAME_PADDING*2
1516
-        column_names_height = min(column_names_height, object@column_names_param$max_height)
1517
-        if(column_names_side == "top") {
1518
-            object@layout$layout_size$column_names_top_height = column_names_height
1519
-            object@layout$layout_index = rbind(object@layout$layout_index, column_names_top = heatmap_layout_index("column_names_top"))
1520 1310
         } else {
1521
-            object@layout$layout_size$column_names_bottom_height = column_names_height
1522
-            object@layout$layout_index = rbind(object@layout$layout_index, column_names_bottom = heatmap_layout_index("column_names_bottom"))
1523
-        }
1524
-        object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) {
1525
-            for(i in seq_len(nc_slice)) {
1526
-                draw_dimnames(object, k = i, which = "column", x = slice_x[i], 
1527
-                    width = slice_width[i], height = unit(1, "npc") - DIMNAME_PADDING*2, just = "left")
1311
+            if(ncol(object@matrix) == 0) {
1312
+                stop("Single heatmap should contains a matrix with at least one column. Zero-column matrix can only be appended to the heatmap list.")
1528 1313
             }
1529
-        })
1530
-    }
1531
-    
1532
-    ##########################################
1533
-    ## annotation on top
1534
-    annotation = object@top_annotation
1535
-    annotation_height = object@top_annotation_param$height
1536
-    if(!is.null(annotation)) {
1537
-        if(length(annotation@anno_list) > 0) {
1538
-            object@layout$layout_size$column_anno_top_height = annotation_height
1539
-            object@layout$layout_index = rbind(object@layout$layout_index, column_anno_top = heatmap_layout_index("column_anno_top"))
1540
-            
1541
-            object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) {
1542
-                for(i in seq_len(nc_slice)) {
1543
-                    draw_annotation(object, k = i, which = "top", x = slice_x[i], width = slice_width[i], 
1544
-                        y = COLUMN_ANNO_PADDING, height = unit(1, "npc") - COLUMN_ANNO_PADDING, 
1545
-                        just = c("left", "bottom"))
1546
-                }
1547
-            }) 
1548
-        }
1549
-    }
1550
-
1551
-    ##########################################
1552
-    ## annotation on bottom
1553
-    annotation = object@bottom_annotation
1554
-    annotation_height = object@bottom_annotation_param$height
1555
-    if(!is.null(annotation)) {
1556
-        if(length(annotation@anno_list) > 0) {
1557
-            object@layout$layout_size$column_anno_bottom_height = annotation_height
1558
-            object@layout$layout_index = rbind(object@layout$layout_index, column_anno_bottom = heatmap_layout_index("column_anno_bottom"))
1559
-            object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) {
1560
-                for(i in seq_len(nc_slice)) {
1561
-                    draw_annotation(object, k = i, which = "bottom", x = slice_x[i], width = slice_width[i], 
1562
-                        y = unit(0, "npc"), height = unit(1, "npc") - COLUMN_ANNO_PADDING, 
1563
-                        just = c("left", "bottom"))
1564
-                }
1565
-            })
1566
-        }
1567
-    }
1568
-
1569
-    ##########################################
1570
-    ## annotation on left
1571
-    annotation = object@left_annotation
1572
-    annotation_width = object@left_annotation_param$width
1573
-    if(!is.null(annotation)) {
1574
-        if(length(annotation@anno_list) > 0) {
1575
-            object@layout$layout_size$row_anno_left_width = annotation_width
1576
-            object@layout$layout_index = rbind(object@layout$layout_index, row_anno_left = heatmap_layout_index("row_anno_left"))
1577
-            object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) {
1578
-                    for(i in seq_len(nr_slice)) {
1579
-                        draw_annotation(object, k = i, which = "left",  y = slice_y[i], height = slice_height[i], 
1580
-                            x = unit(0, "npc"), width = unit(1, "npc") - ROW_ANNO_PADDING, 
1581
-                            just = c("left", "top"))
1582
-                    }
1583
-                }
1584
-            )
1585
-        }
1586
-    }
1587
-
1588
-    ##########################################
1589
-    ## annotation on right
1590
-    annotation = object@right_annotation
1591
-    annotation_width = object@right_annotation_param$width
1592
-    if(!is.null(annotation)) {
1593
-        if(length(annotation@anno_list) > 0) {
1594
-            object@layout$layout_size$row_anno_right_width = annotation_width
1595
-            object@layout$layout_index = rbind(object@layout$layout_index, row_anno_right = heatmap_layout_index("row_anno_right"))
1596
-            object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) {
1597
-                for(i in seq_len(nr_slice)) {
1598
-                    draw_annotation(object, k = i, which = "right", y = slice_y[i], height = slice_height[i], 
1599
-                        x = ROW_ANNO_PADDING, width = unit(1, "npc") - ROW_ANNO_PADDING, 
1600
-                        just = c("left", "top"))
1601
-                }
1602
-            })
1603
-        }
1604
-    }
1605
-
1606
-    layout_size = object@layout$layout_size
1607
-    if(is_abs_unit(object@heatmap_param$width)) {
1608
-        # recalcualte the width of heatmap body
1609
-        object@matrix_param$width = object@heatmap_param$width -
1610
-            sum(layout_size$row_title_left_width,
1611
-                layout_size$row_dend_left_width,
1612
-                layout_size$row_anno_left_width,
1613
-                layout_size$row_names_left_width,
1614
-                layout_size$row_dend_right_width,
1615
-                layout_size$row_anno_right_width,
1616
-                layout_size$row_names_right_width,
1617
-                layout_size$row_title_right_width)   
1618
-    } else if(is_abs_unit(object@matrix_param$width)) {  # e.g. unit(1, "npc")
1619
-        object@heatmap_param$width = sum(
1620
-            layout_size$row_title_left_width,
1621
-            layout_size$row_dend_left_width,
1622
-            layout_size$row_names_left_width,
1623
-            layout_size$row_dend_right_width,
1624
-            layout_size$row_names_right_width,
1625
-            layout_size$row_title_right_width,
1626
-            layout_size$row_anno_left_width,
1627
-            layout_size$row_anno_right_width
1628
-        ) + object@matrix_param$width
1629
-        if(nr_slice > 1) {
1630
-            object@heatmap_param$width = object@heatmap_param$width + sum(row_gap[seq_len(nr_slice-1)])
1631
-        }
1632
-    } else {
1633
-        if(!is.unit(object@heatmap_param$width)) {
1634
-            warning("width of the heatmap can only be set as an absolute unit.")
1635
-        }
1636
-        object@heatmap_param$width = unit(1, "npc")
1637
-    }
1638
-
1639
-    if(is_abs_unit(object@heatmap_param$height)) {
1640
-        object@matrix_param$height = object@heatmap_param$height - 
1641
-            sum(layout_size$column_title_top_height,
1642
-                layout_size$column_dend_top_height,
1643
-                layout_size$column_anno_top_height,
1644
-                layout_size$column_names_top_height,
1645
-                layout_size$column_title_bottom_height,
1646
-                layout_size$column_dend_bottom_height,
1647
-                layout_size$column_anno_bottom_height,
1648
-                layout_size$column_names_bottom_height)
1649
-    } else if(is_abs_unit(object@matrix_param$height)) {
1650
-        object@heatmap_param$height = sum(
1651
-            layout_size$column_title_top_height,
1652
-            layout_size$column_dend_top_height,
1653
-            layout_size$column_anno_top_height,
1654
-            layout_size$column_names_top_height,
1655
-            layout_size$column_title_bottom_height,
1656
-            layout_size$column_dend_bottom_height,
1657
-            layout_size$column_anno_bottom_height,
1658
-            layout_size$column_names_bottom_height
1659
-        ) + object@matrix_param$height
1660
-        if(nc_slice > 1) {
1661
-            object@heatmap_param$height = object@heatmap_param$height + sum(column_gap[seq_len(nc_slice-1)])
1314
+            ht_list = new("HeatmapList")
1315
+            ht_list = add_heatmap(ht_list, object)
1316
+            draw(ht_list, ...)
1662 1317
         }
1663
-    } else {
1664
-        object@heatmap_param$height = unit(1, "npc")
1665 1318
     }
1666
-
1667
-    object@heatmap_param$width_is_absolute_unit = is_abs_unit(object@heatmap_param$width) 
1668
-    object@heatmap_param$height_is_absolute_unit = is_abs_unit(object@heatmap_param$height) 
1669
-    
1670
-    return(object)
1671 1319
 })
1672 1320
 
1673 1321
 # == title
1674
-# Draw the Single Heatmap with Defaults
1675
-#
1676
-# == param
1677
-# -object A `Heatmap-class` object.
1678
-#
1679
-# == details
1680
-# It actually calls `draw,Heatmap-method`, but only with default parameters. If users want to customize the heatmap,
1681
-# they can pass parameters directly to `draw,Heatmap-method`.
1682
-#
1683
-# == value
1684
-# The `HeatmapList-class` object.
1685
-#
1686
-# == author
1687
-# Zuguang Gu <z.gu@dkfz.de>
1688
-#
1689
-setMethod(f = "show",
1690
-    signature = "Heatmap",
1691
-    definition = function(object) {
1692
-
1693
-    draw(object)
1694
-})
1695
-
1696
-# == title
1697
-# Add Heatmap to the Heatmap List
1322
+# Prepare the Heatmap
1698 1323
 #
1699 1324
 # == param
1700 1325
 # -object A `Heatmap-class` object.
1701
-# -x a `Heatmap-class` object, a `HeatmapAnnotation-class` object or a `HeatmapList-class` object.
1702
-# -direction Whether the heatmap is added horizontal or vertically?
1703
-#
1704
-# == details
1705
-# There is a shortcut function ``+.AdditiveUnit``.
1706
-#
1707
-# == value
1708
-# A `HeatmapList-class` object.
1709
-#
1710
-# == author
1711
-# Zuguang Gu <z.gu@dkfz.de>
1712
-#
1713
-setMethod(f = "add_heatmap",
1714
-    signature = "Heatmap",
1715
-    definition = function(object, x, direction = c("horizontal", "vertical")) {
1716
-
1717
-    direction = match.arg(direction)[1]
1718
-
1719
-    ht_list = new("HeatmapList")
1720
-    ht_list@direction = direction
1721
-    
1722
-    ht_list = add_heatmap(ht_list, object, direction = direction)
1723
-    ht_list = add_heatmap(ht_list, x, direction = direction)
1724
-    return(ht_list)
1725
-
1726
-})
1727
-
1728
-# == title
1729
-# Draw the heatmap body
1326
+# -process_rows Whether to process rows of the heatmap.
1730 1327
 #
1731
-# == param
1732
-# -object A `Heatmap-class` object.
1733
-# -kr Row slice index.
1734
-# -kc Column slice index.
1735
-# -... Pass to `grid::viewport` which includes the subset of heatmap body.
1328
+# == detail
1329
+# The preparation of the heatmap includes following steps:
1736 1330
 #
1737
-# == details
1738
-# A viewport is created which contains subset rows and columns of the heatmap.
1331
+# - making clustering on rows if it is specified (by calling `make_row_cluster,Heatmap-method`)
1332
+# - making clustering on columns (by calling `make_column_cluster,Heatmap-method`)
1333
+# - making the layout of the heatmap (by calling `make_layout,Heatmap-method`)
1739 1334
 #
1740 1335
 # This function is only for internal use.
1741 1336
 #
1742 1337
 # == value
1743
-# This function returns no value.
1338
+# The `Heatmap-class` object.
1744 1339
 #
1745 1340
 # == author
1746 1341
 # Zuguang Gu <z.gu@dkfz.de>
1747 1342
 #
1748
-setMethod(f = "draw_heatmap_body",
1343
+setMethod(f = "prepare",
1749 1344
     signature = "Heatmap",
1750
-    definition = function(object, kr = 1, kc = 1, ...) {
1751
-
1752
-    if(ncol(object@matrix) == 0 || nrow(object@matrix) == 0) {
1753
-        return(invisible(NULL))
1754
-    }
1755
-
1756
-    row_order = object@row_order_list[[kr]]
1757
-    column_order = object@column_order_list[[kc]]
1758
-
1759
-    gp = object@matrix_param$gp
1760
-    border = object@matrix_param$border
1761
-
1762
-    use_raster = object@heatmap_param$use_raster
1763
-    raster_device = object@heatmap_param$raster_device
1764
-    raster_quality = object@heatmap_param$raster_quality
1765
-    raster_device_param = object@heatmap_param$raster_device_param
1766
-    if(length(raster_device_param) == 0) raster_device_param = list()
1767
-
1768
-    pushViewport(viewport(name = paste(object@name, "heatmap_body", kr, kc, sep = "_"), ...))
1769
-
1770
-    mat = object@matrix[row_order, column_order, drop = FALSE]
1771
-    col_matrix = map_to_colors(object@matrix_color_mapping, mat)
1772
-
1773
-    nc = ncol(mat)
1774
-    nr = nrow(mat)
1775
-    x = (seq_len(nc) - 0.5) / nc
1776
-    y = (rev(seq_len(nr)) - 0.5) / nr
1777
-    expand_index = expand.grid(seq_len(nr), seq_len(nc))
1778
-    
1779
-    cell_fun = object@matrix_param$cell_fun
1780
-    if(!is.null(cell_fun)) {
1781
-        use_raster = FALSE
1782
-    }
1783
-        
1784
-    if(use_raster) {
1785
-        # write the image into a temporary file and read it back
1786
-        device_info = switch(raster_device,
1787
-            png = c("grDevices", "png", "readPNG"),
1788
-            jpeg = c("grDevices", "jpeg", "readJPEG"),
1789
-            tiff = c("grDevices", "tiff", "readTIFF"),
1790
-            CairoPNG = c("Cairo", "png", "readPNG"),
1791
-            CairoJPEG = c("Cairo", "jpeg", "readJPEG"),
1792
-            CairoTIFF = c("Cairo", "tiff", "readTIFF")
1793
-        )
1794
-        if(!requireNamespace(device_info[1])) {
1795
-            stop(paste0("Need ", device_info[1], " package to write image."))
1796
-        }
1797
-        if(!requireNamespace(device_info[2])) {
1798
-            stop(paste0("Need ", device_info[2], " package to read image."))
1799
-        }
1800
-        # can we get the size of the heatmap body?
1801
-        heatmap_width = convertWidth(unit(1, "npc"), "bigpts", valueOnly = TRUE)
1802
-        heatmap_height = convertHeight(unit(1, "npc"), "bigpts", valueOnly = TRUE)
1803
-        if(heatmap_width <= 0 || heatmap_height <= 0) {
1804
-            stop("The width or height of the raster image is zero, maybe you forget to turn off the previous graphic device or it was corrupted. Run `dev.off()` to close it.")
1805
-        }
1806
-        
1807
-        temp_dir = tempdir()
1808
-                # dir.create(tmp_dir, showWarnings = FALSE)
1809
-        temp_image = tempfile(pattern = paste0(".heatmap_body_", object@name, "_", kr, "_", kc), tmpdir = temp_dir, fileext = paste0(".", device_info[2]))
1810
-        #getFromNamespace(raster_device, ns = device_info[1])(temp_image, width = heatmap_width*raster_quality, height = heatmap_height*raster_quality)
1811
-        device_fun = getFromNamespace(raster_device, ns = device_info[1])
1812
-
1813
-        do.call(device_fun, c(list(filename = temp_image, width = max(c(heatmap_width*raster_quality, 1)), height = max(c(heatmap_height*raster_quality, 1))), raster_device_param))
1814
-        grid.rect(x[expand_index[[2]]], y[expand_index[[1]]], width = unit(1/nc, 'npc'), height = unit(1/nr, 'npc'), gp = do.call('gpar', c(list(fill = col_matrix), gp)))
1815
-        dev.off2()
1816
-        
1817
-        # ############################################
1818
-        # ## make the heatmap body in a another process
1819
-        # temp_R_data = tempfile(pattern = paste0(".heatmap_body_", object@name, "_", kr, "_", kc), tmpdir = temp_dir, fileext = paste0(".RData"))
1820
-        # temp_R_file = tempfile(pattern = paste0(".heatmap_body_", object@name, "_", kr, "_", kc), tmpdir = temp_dir, fileext = paste0(".R"))
1821
-        # if(Sys.info()["sysname"] == "Windows") {
1822
-        #     temp_image = gsub("\\\\", "/", temp_image)
1823
-        #     temp_R_data = gsub("\\\\", "/", temp_R_data)
1824
-        #     temp_R_file = gsub("\\\\", "/", temp_R_file)
1825
-        # }
1826
-        # save(device_fun, device_info, temp_image, heatmap_width, raster_quality, heatmap_height, raster_device_param,
1827
-        #     gp, x, expand_index, nc, nr, col_matrix, row_order, column_order, y,
1828
-        #     file = temp_R_data)
1829
-        # R_cmd = qq("
1830
-        # library(@{device_info[1]})
1831
-        # library(grid)
1832
-        # load('@{temp_R_data}')
1833
-        # do.call('device_fun', c(list(filename = temp_image, width = max(c(heatmap_width*raster_quality, 1)), height = max(c(heatmap_height*raster_quality, 1))), raster_device_param))
1834
-        # grid.rect(x[expand_index[[2]]], y[expand_index[[1]]], width = unit(1/nc, 'npc'), height = unit(1/nr, 'npc'), gp = do.call('gpar', c(list(fill = col_matrix), gp)))
1835
-        # dev.off()
1836
-        # q(save = 'no')
1837
-        # ", code.pattern = "@\\{CODE\\}")
1838
-        # writeLines(R_cmd, con = temp_R_file)
1839
-        # if(grepl(" ", temp_R_file)) {
1840
-        #     if(is_windows()) {
1841
-        #         oe = try(system(qq("\"@{normalizePath(R_binary(), winslash='/')}\" --vanilla < \'@{temp_R_file}\'", code.pattern = "@\\{CODE\\}"), ignore.stdout = TRUE, ignore.stderr = TRUE, show.output.on.console = FALSE), silent = TRUE)
1842
-        #     } else {
1843
-        #         oe = try(system(qq("\"@{normalizePath(R_binary(), winslash='/')}\" --vanilla < \'@{temp_R_file}\'", code.pattern = "@\\{CODE\\}"), ignore.stdout = TRUE, ignore.stderr = TRUE), silent = TRUE)
1844
-        #     }
1845
-        # } else {
1846
-        #     if(is_windows()) {
1847
-        #         oe = try(system(qq("\"@{normalizePath(R_binary(), winslash='/')}\" --vanilla < @{temp_R_file}", code.pattern = "@\\{CODE\\}"), ignore.stdout = TRUE, ignore.stderr = TRUE, show.output.on.console = FALSE), silent = TRUE)
1848
-        #     } else {
1849
-        #         oe = try(system(qq("\"@{normalizePath(R_binary(), winslash='/')}\" --vanilla < @{temp_R_file}", code.pattern = "@\\{CODE\\}"), ignore.stdout = TRUE, ignore.stderr = TRUE), silent = TRUE)
1850
-        #     }
1851
-        # }
1852
-        # ############################################
1853
-        # file.remove(temp_R_data)
1854
-        # file.remove(temp_R_file)
1855
-        # if(inherits(oe, "try-error")) {
1856
-        #     stop(oe)
1857
-        # }
1858
-        image = getFromNamespace(device_info[3], ns = device_info[2])(temp_image)
1859
-        image = as.raster(image)
1860
-        grid.raster(image, width = unit(1, "npc"), height = unit(1, "npc"))
1861
-        file.remove(temp_image)
1862
-
1863
-    } else {
1864
-        if(any(names(gp) %in% c("type"))) {
1865
-            if(gp$type == "none") {
1866
-            } else {
1867
-                grid.rect(x[expand_index[[2]]], y[expand_index[[1]]], width = unit(1/nc, "npc"), height = unit(1/nr, "npc"), gp = do.call("gpar", c(list(fill = col_matrix), gp)))
1868
-            }
1869
-        } else {
1870
-            grid.rect(x[expand_index[[2]]], y[expand_index[[1]]], width = unit(1/nc, "npc"), height = unit(1/nr, "npc"), gp = do.call("gpar", c(list(fill = col_matrix), gp)))
1871
-        }
1345
+    definition = function(object, process_rows = TRUE, process_columns = TRUE) {
1872 1346
 
1873
-        if(is.function(cell_fun)) {
1874
-            for(i in row_order) {
1875
-                for(j in column_order) {
1876
-                    cell_fun(j, i, unit(x[which(column_order == j)], "npc"), unit(y[which(row_order == i)], "npc"), unit(1/nc, "npc"), unit(1/nr, "npc"), col_matrix[which(row_order == i), which(column_order == j)])
1877
-                }
1878
-            }
1879
-        }
1347
+    if(process_rows) {
1348
+        object = make_row_cluster(object)
1880 1349
     }
1881
-
1882
-    if(!identical(border, FALSE)) {
1883
-        grid.rect(gp = gpar(fill = "transparent", col = border))
1350
+    if(process_columns) {
1351
+        object = make_column_cluster(object)
1884 1352
     }
1885 1353
 
1886
-    upViewport()
1354
+    object = make_layout(object)
1355
+    return(object)
1887 1356
 
1888 1357
 })
1889 1358
 
1890
-is_windows = function() {
1891
-    tolower(.Platform$OS.type) == "windows"
1892
-}
1893
-
1894
-R_binary = function() {
1895
-    R_exe = ifelse(is_windows(), "R.exe", "R")
1896
-    return(file.path(R.home("bin"), R_exe))
1897
-}
1898
-
1899
-# == title
1900
-# Draw Heatmap Dendrograms
1901
-#
1902
-# == param
1903
-# -object A `Heatmap-class` object.
1904
-# -which Are the dendrograms put on the row or on the column of the heatmap?
1905
-# -k Slice index.
1906
-# -... Pass to `grid::viewport` which includes the complete heatmap dendrograms.
1907
-#
1908
-# == details
1909
-# A viewport is created which contains dendrograms.
1910
-#
1911
-# This function is only for internal use.
1912
-#
1913
-# == value
1914
-# This function returns no value.
1915
-#
1916
-# == seealso
1917
-# `grid.dendrogram`
1918
-#
1919
-# == author
1920
-# Zuguang Gu <z.gu@dkfz.de>
1921
-#
1922
-setMethod(f = "draw_dend",
1923
-    signature = "Heatmap",
1924
-    definition = function(object,
1925
-    which = c("row", "column"), k = 1, max_height = NULL, ...) {
1926
-
1927
-    which = match.arg(which)[1]
1928
-    
1929
-    side = switch(which,
1930
-        "row" = object@row_dend_param$side,
1931
-        "column" = object@column_dend_param$side)
1932
-    
1933
-    dend = switch(which,
1934
-        "row" = object@row_dend_list[[k]],
1935
-        "column" = object@column_dend_list[[k]])
1936
-    
1937
-    gp = switch(which,
1938
-        "row" = object@row_dend_param$gp,
1939
-        "column" = object@column_dend_param$gp)
1940
-
1941
-    if(length(dend) == 0) {
1942
-        return(invisible(NULL))
1943
-    }
1944
-
1945
-    if(is.null(dend)) return(invisible(NULL))
1946
-
1947
-    if(nobs(dend) <= 1) {
1948
-        return(invisible(NULL))
1949
-    }
1950
-
1951
-    if(is.null(max_height)) {
1952
-        max_height = dend_heights(dend)
1953
-    }
1954
-
1955
-    if(side %in% c("left", "right")) {
1956
-        xscale = c(0, max_height)
1957
-        yscale = c(0, nobs(dend))
1958
-        width = unit(1, "npc")
1959
-        height = unit(1, "npc")
1960
-        name = paste(object@name, "dend_row", k, sep = "_")
1961
-    } else {
1962
-        xscale = c(0, nobs(dend))
1963
-        yscale = c(0, max_height)
1964
-        height = unit(1, "npc")
1965
-        width = unit(1, "npc")
1966
-        name = paste(object@name, "dend_column", k, sep = "_")
1967
-    }
1968
-
1969
-    pushViewport(viewport(...))
1970
-    pushViewport(viewport(name = name, xscale = xscale, yscale = yscale, width = width, height = height))
1971
-
1972
-    if(side == "left") {
1973
-        grid.dendrogram(dend, gp = gp, facing = "right", order = "reverse")
1974
-    } else if(side == "right") {
1975
-        grid.dendrogram(dend, gp = gp, facing = "left", order = "reverse")
1976
-    } else if(side == "top") {
1977
-        grid.dendrogram(dend, gp = gp, facing = "bottom")
1978
-    } else if(side == "bottom") {
1979
-        grid.dendrogram(dend, gp = gp, facing = "top")
1980
-    } 
1981
-
1982
-    upViewport()
1983
-    upViewport()
1984
-
1985
-})
1986
-
1987
-# == title
1988
-# Draw row names or column names
1989
-#
1990
-# == param
1991
-# -object A `Heatmap-class` object.
1992
-# -which Are the names put on the row or on the column of the heatmap?
1993
-# -k Slice index.
1994
-# -... Pass to `grid::viewport` which includes the complete heatmap row/column names.
1995
-#
1996
-# == details
1997
-# A viewport is created which contains row names or column names.
1998
-#
1999
-# This function is only for internal use.
2000
-#
2001
-# == value
2002
-# This function returns no value.
2003
-#
2004
-# == author
2005
-# Zuguang Gu <z.gu@dkfz.de>
2006
-#
2007
-setMethod(f = "draw_dimnames",
2008
-    signature = "Heatmap",
2009
-    definition = function(object,
2010
-    which = c("row", "column"), k = 1, ...) {
2011
-
2012
-    which = match.arg(which)[1]
2013
-
2014
-    anno = switch(which,
2015
-        "row" = object@row_names_param$anno,
2016
-        "column" = object@column_names_param$anno)
2017
-
2018
-    ind = switch(which,
2019
-        "row" = object@row_order_list[[k]],
2020
-        "column" = object@column_order_list[[k]])
2021
-    
2022
-    pushViewport(viewport(name = paste(object@name, which, "names", k, sep = "_"), ...))
2023
-    draw(anno, index = ind)
2024
-    upViewport()
2025
-})
2026
-
2027
-# == title
2028
-# Draw Heatmap Title
2029
-#
2030
-# == param
2031
-# -object A `Heatmap-class` object.
2032
-# -which Is title put on the row or on the column of the heatmap?
2033
-# -k Slice index.
2034
-# -... Pass to `grid::viewport` which includes the complete heatmap title
2035
-#
2036
-# == details
2037
-# A viewport is created which contains heatmap title.
2038
-#
2039
-# This function is only for internal use.
2040
-#
2041
-# == value
2042
-# This function returns no value.
2043
-#
2044
-# == author
2045
-# Zuguang Gu <z.gu@dkfz.de>
2046
-#
2047
-setMethod(f = "draw_title",
2048
-    signature = "Heatmap",
2049
-    definition = function(object,
2050
-    which = c("row", "column"), k = 1, ...) {
2051
-
2052
-    which = match.arg(which)[1]
2053
-
2054
-    side = switch(which,
2055
-        "row" = object@row_title_param$side,
2056
-        "column" = object@column_title_param$side)
2057
-
2058
-    gp = switch(which,
2059
-        "row" = object@row_title_param$gp,
2060
-        "column" = object@column_title_param$gp)
2061
-    
2062
-    gp = subset_gp(gp, k)
2063
-    
2064
-    title = switch(which,
2065
-        "row" = object@row_title[k],
2066
-        "column" = object@column_title[k])
2067
-
2068
-    rot = switch(which,
2069
-        "row" = object@row_title_param$rot,
2070
-        "column" = object@column_title_param$rot)
2071
-
2072
-    just = switch(which, 
2073
-        "row" = object@row_title_param$just,
2074
-        "column" = object@column_title_param$just)
2075
-
2076
-    if(which == "row") {
2077
-        
2078
-        pushViewport(viewport(name = paste(object@name, "row_title", k, sep = "_"), clip = FALSE, ...))
2079
-        if("fill" %in% names(gp)) {
2080
-            grid.rect(gp = gpar(fill = gp$fill))
2081
-        }
2082
-        if(side == "left") {
2083
-            grid.text(title, x = unit(1, "npc") - TITLE_PADDING, rot = rot, just = just, gp = gp)
2084
-        } else {
2085
-            grid.text(title, x = TITLE_PADDING, rot = rot, just = just, gp = gp)
2086
-        }
2087
-        upViewport()
2088
-    } else {
2089
-        pushViewport(viewport(name = paste(object@name, "column_title", k, sep = "_"), clip = FALSE, ...))
2090
-        if("fill" %in% names(gp)) {
2091
-            grid.rect(gp = gpar(fill = gp$fill))
2092
-        }
2093
-        if(side == "top") {
2094
-            grid.text(title, y = TITLE_PADDING, rot = rot, just = just, gp = gp)
2095
-        } else {
2096
-            grid.text(title, y = unit(1, "npc") - TITLE_PADDING, rot = rot, just = just, gp = gp)
2097
-        }
2098
-        upViewport()
2099
-    }
2100
-})
2101
-
2102
-# == title
2103
-# Draw Heatmap Annotations on the Heatmap
2104
-#
2105
-# == param
2106
-# -object A `Heatmap-class` object.
2107
-# -which The position of the heamtap annotation.
2108
-# -k Slice index.
2109
-# -... Pass to `grid::viewport` which includes the complete heatmap annotation.
2110
-#
2111
-# == details
2112
-# A viewport is created which contains column/top annotations.
2113
-#
2114
-# The function calls `draw,HeatmapAnnotation-method` to draw the annotations.
2115
-#
2116
-# This function is only for internal use.
2117
-#
2118
-# == value
2119
-# This function returns no value.
2120
-#
2121
-# == author
2122
-# Zuguang Gu <z.gu@dkfz.de>
2123
-#
2124
-setMethod(f = "draw_annotation",
2125
-    signature = "Heatmap",
2126
-    definition = function(object, which = c("top", "bottom", "left", "right"), k = 1, ...) {
2127
-    
2128
-    which = match.arg(which)[1]
2129
-
2130
-    annotation = switch(which,
2131
-        top = object@top_annotation,
2132
-        bottom = object@bottom_annotation,
2133
-        left = object@left_annotation,
2134
-        right = object@right_annotation)
2135
-
2136
-    # if there is no annotation, draw nothing
2137
-    if(is.null(annotation)) {
2138
-        return(invisible(NULL))
2139
-    }
2140
-
2141
-    if(which %in% c("top", "bottom")) {
2142
-        index = object@column_order_list[[k]]
2143
-        n = length(object@column_order_list)
2144
-    } else {
2145
-        index = object@row_order_list[[k]]
2146
-        n = length(object@row_order_list)
2147
-    }
2148
-
2149
-    pushViewport(viewport(...))
2150
-    draw(annotation, index = index, k = k, n = n)
2151
-    upViewport()
2152
-})
2153
-
2154
-# == title
2155
-# Widths of Heatmap Components
2156
-#
2157
-# == param
2158
-# -object A `Heatmap-class` object.
2159
-# -k Which components in the heatmap. The value should numeric indices or the names
2160
-#    of the corresponding row component. See **Detials**.
2161
-#
2162
-# == details
2163
-# All row components are: ``row_title_left``, ``row_dend_left``, ``row_names_left``, ``row_anno_left``,
2164
-# ``heatmap_body``, ``row_anno_right``, ``row_names_right``, ``row_dend_right``, ``row_title_right``.
2165
-#
2166
-# This function is only for internal use.
2167
-#
2168
-# == value
2169
-# A `grid::unit` object.
2170
-#
2171
-# == author
2172
-# Zuguang Gu <z.gu@dkfz.de>
2173
-#
2174
-setMethod(f = "component_width",
2175
-    signature = "Heatmap",
2176
-    definition = function(object, k = HEATMAP_LAYOUT_ROW_COMPONENT) {
2177
-
2178
-    if(is.numeric(k)) {
2179
-        component_name = names(HEATMAP_LAYOUT_ROW_COMPONENT)[k]
2180
-    } else {
2181
-        component_name = k
2182
-    }
2183
-    # this function is used for grid.layout, so null unit is allowed
2184
-    .single_unit = function(nm) {
2185
-        if(nm == "heatmap_body") {
2186
-            object@matrix_param$width
2187
-        } else {
2188
-            object@layout$layout_size[[paste0(nm, "_width")]]
2189
-        }
2190
-    }
2191
-    
2192
-    do.call("unit.c", lapply(component_name, .single_unit))
2193
-})
2194
-
2195
-# == title
2196
-# Heights of Heatmap Components
2197
-#
2198
-# == param
2199
-# -object A `Heatmap-class` object.
2200
-# -k Which components in the heatmap. The value should numeric indices or the names
2201
-#    of the corresponding column component. See **Detials**.
2202
-#
2203
-# == detail
2204
-# All column components are: ``column_title_top``, ``column_dend_top``, ``column_names_top``, 
2205
-# ``column_anno_top``, ``heatmap_body``, ``column_anno_bottom``, ``column_names_bottom``, 
2206
-# ``column_dend_bottom``, ``column_title_bottom``.
2207
-#
2208
-# This function is only for internal use.
2209
-#
2210
-# == value
2211
-# A `grid::unit` object.
2212
-#
2213
-# == author
2214
-# Zuguang Gu <z.gu@dkfz.de>
2215
-#
2216
-setMethod(f = "component_height",
2217
-    signature = "Heatmap",
2218
-    definition = function(object, k = HEATMAP_LAYOUT_COLUMN_COMPONENT) {
2219
-
2220
-    if(is.numeric(k)) {
2221
-        component_name = names(HEATMAP_LAYOUT_COLUMN_COMPONENT)[k]
2222
-    } else {
2223
-        component_name = k
2224
-    }
2225
-    # this function is used for grid.layout, so null unit is allowed
2226
-    .single_unit = function(nm) {
2227
-        if(nm == "heatmap_body") {
2228
-            object@matrix_param$height
2229
-        } else {
2230
-            object@layout$layout_size[[paste0(nm, "_height")]]
2231
-        }
2232
-    }
2233
-
2234
-    do.call("unit.c", lapply(component_name, .single_unit))
2235
-})
2236
-
2237
-has_component = function(object, component) {
2238
-    m = object@layout$layout_index
2239
-    ind = heatmap_layout_index(component)
2240
-    any(m[, 1] == ind[1] & m[, 2] == ind[2])
2241
-}
2242
-
2243
-
2244
-HEATMAP_LAYOUT_COLUMN_COMPONENT = 1:9
2245
-names(HEATMAP_LAYOUT_COLUMN_COMPONENT) = c("column_title_top", "column_dend_top", "column_names_top", "column_anno_top",
2246
-    "heatmap_body", "column_anno_bottom", "column_names_bottom", "column_dend_bottom", "column_title_bottom")
2247
-HEATMAP_LAYOUT_ROW_COMPONENT = 1:9
2248
-names(HEATMAP_LAYOUT_ROW_COMPONENT) = c("row_title_left", "row_dend_left", "row_names_left", "row_anno_left",
2249
-    "heatmap_body", "row_anno_right", "row_names_right", "row_dend_right", "row_title_right")
2250
-
2251
-heatmap_layout_index = function(nm) {
2252
-    if(grepl("column", nm)) {
2253
-        ind = c(HEATMAP_LAYOUT_COLUMN_COMPONENT[nm], HEATMAP_LAYOUT_ROW_COMPONENT["heatmap_body"])
2254
-    } else if(grepl("row", nm)) {
2255
-        ind = c(HEATMAP_LAYOUT_COLUMN_COMPONENT["heatmap_body"], HEATMAP_LAYOUT_ROW_COMPONENT[nm])
2256
-    } else if(nm == "heatmap_body") { # heatmap_body
2257
-        ind = c(HEATMAP_LAYOUT_COLUMN_COMPONENT["heatmap_body"], HEATMAP_LAYOUT_ROW_COMPONENT["heatmap_body"])
2258
-    }
2259
-    names(ind) = c("layout.pos.row", "layout.pos.col")
2260
-    return(ind)
2261
-}
2262
-
2263
-# == title
2264
-# Set Width of Heatmap Component
2265
-#
2266
-# == param
2267
-# -object A `Heatmap-class` object.
2268
-# -k Which row component? The value should a numeric index or the name
2269
-#    of the corresponding row component. See **Detials**.
2270
-# -v width of the component, a `grid::unit` object.
2271
-#
2272
-# == detail
2273
-# All row components are: ``row_title_left``, ``row_dend_left``, ``row_names_left``, ``row_anno_left``,
2274
-# ``heatmap_body``, ``row_anno_right``, ``row_names_right``, ``row_dend_right``, ``row_title_right``.
2275
-#
2276
-# This function is only for internal use.
2277
-#
2278
-# == value
2279
-# The `Heatmap-class` object.
2280
-#
2281
-# == author
2282
-# Zuguang Gu <z.gu@dkfz.de>
2283
-#
2284
-setMethod(f = "set_component_width",
2285
-    signature = "Heatmap",
2286
-    definition = function(object, k, v) {
2287
-
2288
-    if(is.numeric(k)) {
2289
-        nm = names(HEATMAP_LAYOUT_ROW_COMPONENT)[k]
2290
-    } else {
2291
-        nm = k
2292
-    }
2293
-
2294
-    object@layout$layout_size[[ paste0(nm, "_width") ]] = v
2295
-    
2296
-    if(is_abs_unit(object@matrix_param$width)) {
2297
-        object@heatmap_param$width = sum(component_width(object))
2298
-    }
2299
-
2300
-    return(object)
2301
-})
2302
-
2303
-# == title
2304
-# Set Height of Heatmap Component
2305
-#
2306
-# == param
2307
-# -object A `Heatmap-class` object.
2308
-# -k Which column component? The value should a numeric index or the name
2309
-#    of the corresponding column component. See **Detials**.
2310
-# -v Height of the component, a `grid::unit` object.
2311
-#
2312
-# == detail
2313
-# All column components are: ``column_title_top``, ``column_dend_top``, ``column_names_top``, 
2314
-# ``column_anno_top``, ``heatmap_body``, ``column_anno_bottom``, ``column_names_bottom``, 
2315
-# ``column_dend_bottom``, ``column_title_bottom``.
2316
-#
2317
-# This function is only for internal use.
2318
-#
2319
-# == value
2320
-# The `Heatmap-class` object.
2321
-#
2322
-# == author
2323
-# Zuguang Gu <z.gu@dkfz.de>
2324
-#
2325
-setMethod(f = "set_component_height",
2326
-    signature = "Heatmap",
2327
-    definition = function(object, k, v) {
2328
-
2329
-    if(is.numeric(k)) {
2330
-        nm = names(HEATMAP_LAYOUT_COLUMN_COMPONENT)[k]
2331
-    } else {
2332
-        nm = k
2333
-    }
2334
-
2335
-    object@layout$layout_size[[ paste0(nm, "_height") ]] = v
2336
-    
2337
-    if(is_abs_unit(object@matrix_param$height)) {
2338
-        object@heatmap_param$height = sum(component_height(object))
2339
-    }
2340
-
2341
-    return(object)
2342
-})
2343
-
2344
-# == title
2345
-# Draw a Single Heatmap
2346
-#
2347
-# == param
2348
-# -object A `Heatmap-class` object.
2349
-# -internal If ``TRUE``, it is only used inside the calling of `draw,HeatmapList-method`. 
2350
-#           It only draws the heatmap without legends where the legend will be drawn by `draw,HeatmapList-method`. 
2351
-# -test Only for testing. If it is ``TRUE``, the heatmap body is directly drawn.
2352
-# -... Pass to `draw,HeatmapList-method`.
2353
-#
2354
-# == detail
2355
-# The function creates a `HeatmapList-class` object which only contains a single heatmap
2356
-# and call `draw,HeatmapList-method` to make the final heatmap.
2357
-#
2358
-# There are some arguments which control the global setting of the heatmap such as legends.
2359
-# Please go to `draw,HeatmapList-method` for these arguments.
2360
-#
2361
-# == value
2362
-# A `HeatmapList-class` object.
2363
-#
2364
-# == author
2365
-# Zuguang Gu <z.gu@dkfz.de>
2366
-#
2367
-setMethod(f = "draw",
2368
-    signature = "Heatmap",
2369
-    definition = function(object, internal = FALSE, test = FALSE, ...) {
2370
-
2371
-    if(test) {
2372
-        object = prepare(object)
2373
-        grid.newpage()
2374
-        if(is_abs_unit(object@heatmap_param$width)) {
2375
-            width = object@heatmap_param$width
2376
-        } else {
2377
-            width = 0.8
2378
-        }
2379
-        if(is_abs_unit(object@heatmap_param$height)) {
2380
-            height = object@heatmap_param$height
2381
-        } else {
2382
-            height = 0.8
2383
-        }
2384
-        pushViewport(viewport(width = width, height = height))
2385
-        draw(object, internal = TRUE)
2386
-        upViewport()
2387
-    } else {
2388
-        if(internal) {  # a heatmap without legend
2389
-            layout = grid.layout(nrow = length(HEATMAP_LAYOUT_COLUMN_COMPONENT), 
2390
-                ncol = length(HEATMAP_LAYOUT_ROW_COMPONENT), widths = component_width(object), 
2391
-                heights = component_height(object))
2392
-            pushViewport(viewport(layout = layout))
2393
-            ht_layout_index = object@layout$layout_index
2394
-            ht_graphic_fun_list = object@layout$graphic_fun_list
2395
-            for(j in seq_len(nrow(ht_layout_index))) {
2396
-                if(HEATMAP_LAYOUT_COLUMN_COMPONENT["heatmap_body"] %in% ht_layout_index[j, 1] && 
2397
-                   HEATMAP_LAYOUT_ROW_COMPONENT["heatmap_body"] %in% ht_layout_index[j, 2]) {
2398
-                    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 = "_")))
2399
-                } else {
2400
-                    pushViewport(viewport(layout.pos.row = ht_layout_index[j, 1], layout.pos.col = ht_layout_index[j, 2]))
2401
-                }
2402
-                ht_graphic_fun_list[[j]](object)
2403
-                upViewport()
2404
-            }
2405
-            upViewport()
2406
-        } else {
2407
-            if(ncol(object@matrix) == 0) {
2408
-                stop("Single heatmap should contains a matrix with at least one column. Zero-column matrix can only be appended to the heatmap list.")
2409
-            }
2410
-            ht_list = new("HeatmapList")
2411
-            ht_list = add_heatmap(ht_list, object)
2412
-            draw(ht_list, ...)
2413
-        }
2414
-    }
2415
-})
2416
-
2417
-# == title
2418
-# Prepare the Heatmap
2419
-#
2420
-# == param
2421
-# -object A `Heatmap-class` object.
2422
-# -process_rows Whether to process rows of the heatmap.
2423
-#
2424
-# == detail
2425
-# The preparation of the heatmap includes following steps:
2426
-#
2427
-# - making clustering on rows if it is specified (by calling `make_row_cluster,Heatmap-method`)
2428
-# - making clustering on columns (by calling `make_column_cluster,Heatmap-method`)
2429
-# - making the layout of the heatmap (by calling `make_layout,Heatmap-method`)
2430
-#
2431
-# This function is only for internal use.
2432
-#
2433
-# == value
2434
-# The `Heatmap-class` object.
2435
-#
2436
-# == author
2437
-# Zuguang Gu <z.gu@dkfz.de>
2438
-#
2439
-setMethod(f = "prepare",
2440
-    signature = "Heatmap",
2441
-    definition = function(object, process_rows = TRUE, process_columns = TRUE) {
2442
-
2443
-    if(process_rows) {
2444
-        object = make_row_cluster(object)
2445
-    }
2446
-    if(process_columns) {
2447
-        object = make_column_cluster(object)
2448
-    }
2449
-
2450
-    object = make_layout(object)
2451
-    return(object)
2452
-
2453
-})
2454
-
2455
-# == title
2456
-# Subset a Heatmap
2457
-#
2458
-# == param
2459
-# -x A `Heatmap-class` object.
2460
-# -i Row indices
2461
-# -j Column indices
2462
-#
2463
-# == example
2464
-# m = matrix(rnorm(100), nrow = 10)
2465
-# rownames(m) = letters[1:10]
2466
-# colnames(m) = LETTERS[1:10]
2467
-# ht = Heatmap(m)
2468
-# ht[1:5, ]
2469
-# ht[1:5]
2470
-# ht[, 1:5]
2471
-# ht[1:5, 1:5]
2472
-"[.Heatmap" = function(x, i, j) {
2473
-    if(nargs() == 2) {
2474
-        subset_heatmap_by_row(x, i)
2475
-    } else {
2476
-        if(missing(i)) {
2477
-            subset_heatmap_by_column(x, j)
2478
-        } else if(missing(j)) {
2479
-            subset_heatmap_by_row(x, i)
2480
-        } else {
2481
-            x = subset_heatmap_by_row(x, i)
2482
-            subset_heatmap_by_column(x, j)
2483
-        }
2484
-    }
2485
-}
2486
-
2487
-
2488
-subset_heatmap_by_row = function(ht, ind) {
2489
-    ht@row_order = intersect(ht@row_order, ind)
2490
-    if(!is.null(ht@row_dend_param$obj)) {
2491
-        stop("row dend is specified as a clustering object, cannot do subsetting.")
2492
-    }
2493
-    ht@matrix = ht@matrix[ind, , drop = FALSE]
2494
-    if(!is.null(ht@row_names_param$labels)) {
2495
-        ht@row_names_param$labels = ht@row_names_param$labels[ind]
2496
-    }
2497
-    ht@row_names_param$gp = subset_gp(ht@row_names_param$gp, ind)
2498
-    return(ht)
2499
-}
2500
-
2501
-subset_heatmap_by_column = function(ht, ind) {
2502
-    ht@column_order = intersect(ht@column_order, ind)
2503
-    if(!is.null(ht@column_dend_param$obj)) {
2504
-        stop("column dend is specified as a clustering object, cannot do subsetting.")
2505
-    }
2506
-    ht@matrix = ht@matrix[, ind, drop = FALSE]
2507
-    if(!is.null(ht@column_names_param$labels)) {
2508
-        ht@column_names_param$labels = ht@column_names_param$labels[ind]
2509
-    }
2510
-    ht@column_names_param$gp = subset_gp(ht@column_names_param$gp, ind)
2511
-    if(length(ht@top_annotation@anno_list)) {
2512
-        ht@top_annotation = ht@top_annotation[ind]
2513
-    }
2514
-    if(length(ht@bottom_annotation@anno_list)) {
2515
-        ht@bottom_annotation = ht@bottom_annotation[ind]
2516
-    }
2517
-    return(ht)
2518
-}
2519
-
2520
-# == title
2521
-# Dimension of the Heatmap
2522
-#
2523
-# == param
2524
-# -x A `Heatmap-class` object.
2525
-#
2526
-dim.Heatmap = function(x) {
2527
-    dim(x@matrix)
2528
-}
2529
-
2530
-# == title
2531
-# Number of Rows in the Heatmap
2532
-#
2533
-# == param
2534
-# -x A `Heatmap-class` object.
2535
-#
2536
-nrow.Heatmap = function(x) {
2537
-    nrow(x@matrix)
2538
-}
2539
-
2540
-# == title
2541
-# Number of Columns in the Heatmap
2542
-#
2543
-# == param
2544
-# -x A `Heatmap-class` object.
2545
-#
2546
-ncol.Heatmap = function(x) {
2547
-    ncol(x@matrix)
2548
-}
2549
-
2550
-# == title
2551
-# Print the Summary of a Heatmap
2552
-#
2553
-# == param
2554
-# -object A `Heatmap-class` object.
2555
-# -... Other arguments.
2556
-#
2557
-summary.Heatmap = function(object, ...) {
2558
-    qqcat("a matrix with @{nrow(object@matrix)} rows and @{ncol(object@matrix)} columns\n")
2559
-    qqcat("name: @{object@name}\n")
2560
-    qqcat("color mapping is @{object@matrix_color_mapping@type}\n")
2561
-    
2562
-    if(length(object@column_title)) {
2563
-        qqcat("has column title\n")
2564
-    } else {
2565
-        qqcat("has no column title\n")
2566
-    }
2567
-    if(length(object@row_title)) {
2568
-        qqcat("has row title\n")
2569
-    } else {
2570
-        qqcat("has no row title\n")
2571
-    }
2572
-
2573
-    if(length(object@column_names_param$labels)) {
2574
-        qqcat("has column names\n")
2575
-    } else {
2576
-        qqcat("has no column name\n")
2577
-    }
2578
-    if(length(object@row_names_param$labels)) {
2579
-        qqcat("has row names\n")
2580
-    } else {
2581
-        qqcat("has no row name\n")
2582
-    }
2583
-
2584
-    if(!is.null(object@column_dend_param$obj)) {
2585
-        qqcat("column clustering is provided as a clustering object\n")
2586
-    } else {
2587
-        if(object@column_dend_param$cluster) {
2588
-            if(!is.null(object@column_dend_param$fun)) {
2589
-                qqcat("column clustering is applied with user-defined function\n")
2590
-            } else if(is.function(object@column_dend_param$distance)) {
2591
-                qqcat("column clustering is applied with '@{object@column_dend_param$method}' method and user-defined distance function\n")
2592
-            } else {
2593
-                qqcat("column clustering is applied with '@{object@column_dend_param$method}' method and '@{object@column_dend_param$distance}' distance\n")
2594
-            }
2595
-        } else {
2596
-            qqcat("no column clustering\n")
2597
-        }
2598
-    }
2599
-    if(object@matrix_param$column_km > 1) {
2600
-        qqcat("columns are split by k-means with @{object@matrix_param$column_km} groups\n")
2601
-    }
2602
-    if(!is.null(object@matrix_param$column_split)) {
2603
-        qqcat("columns are split by a categorical data frame\n")
2604
-    }
2605
-    if(!is.null(object@row_dend_param$obj)) {
2606
-        qqcat("row clustering is provided as a clustering object\n")
2607
-    } else {
2608
-        if(object@row_dend_param$cluster) {
2609
-            if(!is.null(object@row_dend_param$fun)) {
2610
-                qqcat("row clustering is applied with user-defined function\n")
2611
-            } else if(is.function(object@row_dend_param$distance)) {
2612
-                qqcat("row clustering is applied with '@{object@row_dend_param$method}' method and user-defined distance function\n")
2613
-            } else {
2614
-                qqcat("row clustering is applied with '@{object@row_dend_param$method}' method and '@{object@row_dend_param$distance}' distance\n")
2615
-            }
2616
-        } else {
2617
-            qqcat("no row clustering\n")
2618
-        }
2619
-    }
2620
-    if(object@matrix_param$row_km > 1) {
2621
-        qqcat("rows are split by k-means with @{object@matrix_param$row_km} groups\n")
2622
-    }
2623
-    if(!is.null(object@matrix_param$row_split)) {
2624
-        qqcat("rows are split by a categorical data frame\n")
2625
-    }
2626
-
2627
-    if(length(object@top_annotation)) {
2628
-        qqcat("has @{length(object@top_annotation)} top annotationa:\n")
2629
-        qqcat("=======================================\n")
2630
-        show(object@top_annotation)
2631
-        qqcat("=======================================\n")
2632
-    } else {
2633
-        qqcat("has no top annotation\n")
2634
-    }
2635
-    if(length(object@bottom_annotation)) {
2636
-        qqcat("has @{length(object@bottom_annotation)} bottom annotation:\n")
2637
-        qqcat("=======================================\n")
2638
-        show(object@bottom_annotation)
2639
-        qqcat("=======================================\n")
2640
-    } else {
2641
-        qqcat("has no bottom annotation\n")
2642
-    }
2643
-    if(length(object@left_annotation)) {
2644
-        qqcat("has @{length(object@left_annotation)} left annotationa:\n")
2645
-        qqcat("=======================================\n")
2646
-        show(object@left_annotation)
2647
-        qqcat("=======================================\n")
2648
-    } else {
2649
-        qqcat("has no left annotation\n")
2650
-    }
2651
-    if(length(object@right_annotation)) {
2652
-        qqcat("has @{length(object@right_annotation)} right annotationa:\n")
2653
-        qqcat("=======================================\n")
2654
-        show(object@right_annotation)
2655
-        qqcat("=======================================\n")
2656
-    } else {
2657
-        qqcat("has no right annotation\n")
2658
-    }
2659
-}
2660
-
2661 1359
new file mode 100644
... ...
@@ -0,0 +1,430 @@
1
+
2
+# == title
3
+# Draw the heatmap body
4
+#
5
+# == param
6
+# -object A `Heatmap-class` object.
7
+# -kr Row slice index.
8
+# -kc Column slice index.
9
+# -... Pass to `grid::viewport` which includes the subset of heatmap body.
10
+#
11
+# == details
12
+# A viewport is created which contains subset rows and columns of the heatmap.
13
+#
14
+# This function is only for internal use.
15
+#
16
+# == value
17
+# This function returns no value.
18
+#
19
+# == author
20
+# Zuguang Gu <z.gu@dkfz.de>
21
+#
22
+setMethod(f = "draw_heatmap_body",
23
+    signature = "Heatmap",
24
+    definition = function(object, kr = 1, kc = 1, ...) {
25
+
26
+    if(ncol(object@matrix) == 0 || nrow(object@matrix) == 0) {
27
+        return(invisible(NULL))
28
+    }
29
+
30
+    row_order = object@row_order_list[[kr]]
31
+    column_order = object@column_order_list[[kc]]
32
+
33
+    gp = object@matrix_param$gp
34
+    border = object@matrix_param$border
35
+
36
+    use_raster = object@heatmap_param$use_raster
37
+    raster_device = object@heatmap_param$raster_device
38
+    raster_quality = object@heatmap_param$raster_quality
39
+    raster_device_param = object@heatmap_param$raster_device_param
40
+    if(length(raster_device_param) == 0) raster_device_param = list()
41
+
42
+    pushViewport(viewport(name = paste(object@name, "heatmap_body", kr, kc, sep = "_"), ...))
43
+
44
+    mat = object@matrix[row_order, column_order, drop = FALSE]
45
+    col_matrix = map_to_colors(object@matrix_color_mapping, mat)
46
+
47
+    nc = ncol(mat)
48
+    nr = nrow(mat)
49
+    x = (seq_len(nc) - 0.5) / nc
50
+    y = (rev(seq_len(nr)) - 0.5) / nr
51
+    expand_index = expand.grid(seq_len(nr), seq_len(nc))
52
+    
53
+    cell_fun = object@matrix_param$cell_fun
54
+    layer_fun = object@matrix_param$layer_fun
55
+    if(!is.null(cell_fun)) {
56
+        use_raster = FALSE
57
+    }
58
+        
59
+    if(use_raster) {
60
+        # write the image into a temporary file and read it back
61
+        device_info = switch(raster_device,
62
+            png = c("grDevices", "png", "readPNG"),
63
+            jpeg = c("grDevices", "jpeg", "readJPEG"),
64
+            tiff = c("grDevices", "tiff", "readTIFF"),
65
+            CairoPNG = c("Cairo", "png", "readPNG"),
66
+            CairoJPEG = c("Cairo", "jpeg", "readJPEG"),
67
+            CairoTIFF = c("Cairo", "tiff", "readTIFF")
68
+        )
69
+        if(!requireNamespace(device_info[1])) {
70
+            stop(paste0("Need ", device_info[1], " package to write image."))
71
+        }
72
+        if(!requireNamespace(device_info[2])) {
73
+            stop(paste0("Need ", device_info[2], " package to read image."))
74
+        }
75
+        # can we get the size of the heatmap body?
76
+        heatmap_width = convertWidth(unit(1, "npc"), "bigpts", valueOnly = TRUE)
77
+        heatmap_height = convertHeight(unit(1, "npc"), "bigpts", valueOnly = TRUE)
78
+        if(heatmap_width <= 0 || heatmap_height <= 0) {
79
+            stop("The width or height of the raster image is zero, maybe you forget to turn off the previous graphic device or it was corrupted. Run `dev.off()` to close it.")
80
+        }
81
+        
82
+        temp_dir = tempdir()
83
+                # dir.create(tmp_dir, showWarnings = FALSE)
84
+        temp_image = tempfile(pattern = paste0(".heatmap_body_", object@name, "_", kr, "_", kc), tmpdir = temp_dir, fileext = paste0(".", device_info[2]))
85
+        #getFromNamespace(raster_device, ns = device_info[1])(temp_image, width = heatmap_width*raster_quality, height = heatmap_height*raster_quality)
86
+        device_fun = getFromNamespace(raster_device, ns = device_info[1])
87
+
88
+        do.call(device_fun, c(list(filename = temp_image, width = max(c(heatmap_width*raster_quality, 1)), height = max(c(heatmap_height*raster_quality, 1))), raster_device_param))
89
+        grid.rect(x[expand_index[[2]]], y[expand_index[[1]]], width = unit(1/nc, 'npc'), height = unit(1/nr, 'npc'), gp = do.call('gpar', c(list(fill = col_matrix), gp)))
90
+        if(is.function(layer_fun)) {
91
+            layer_fun(row_order, column_order)
92
+        }
93
+        dev.off2()
94
+        
95
+        # ############################################
96
+        # ## make the heatmap body in a another process
97
+        # temp_R_data = tempfile(pattern = paste0(".heatmap_body_", object@name, "_", kr, "_", kc), tmpdir = temp_dir, fileext = paste0(".RData"))
98
+        # temp_R_file = tempfile(pattern = paste0(".heatmap_body_", object@name, "_", kr, "_", kc), tmpdir = temp_dir, fileext = paste0(".R"))
99
+        # if(Sys.info()["sysname"] == "Windows") {
100
+        #     temp_image = gsub("\\\\", "/", temp_image)
101
+        #     temp_R_data = gsub("\\\\", "/", temp_R_data)
102
+        #     temp_R_file = gsub("\\\\", "/", temp_R_file)
103
+        # }
104
+        # save(device_fun, device_info, temp_image, heatmap_width, raster_quality, heatmap_height, raster_device_param,
105
+        #     gp, x, expand_index, nc, nr, col_matrix, row_order, column_order, y,
106
+        #     file = temp_R_data)
107
+        # R_cmd = qq("
108
+        # library(@{device_info[1]})
109
+        # library(grid)
110
+        # load('@{temp_R_data}')
111
+        # do.call('device_fun', c(list(filename = temp_image, width = max(c(heatmap_width*raster_quality, 1)), height = max(c(heatmap_height*raster_quality, 1))), raster_device_param))
112
+        # grid.rect(x[expand_index[[2]]], y[expand_index[[1]]], width = unit(1/nc, 'npc'), height = unit(1/nr, 'npc'), gp = do.call('gpar', c(list(fill = col_matrix), gp)))
113
+        # dev.off()
114
+        # q(save = 'no')
115
+        # ", code.pattern = "@\\{CODE\\}")
116
+        # writeLines(R_cmd, con = temp_R_file)
117
+        # if(grepl(" ", temp_R_file)) {
118
+        #     if(is_windows()) {
119
+        #         oe = try(system(qq("\"@{normalizePath(R_binary(), winslash='/')}\" --vanilla < \'@{temp_R_file}\'", code.pattern = "@\\{CODE\\}"), ignore.stdout = TRUE, ignore.stderr = TRUE, show.output.on.console = FALSE), silent = TRUE)
120
+        #     } else {
121
+        #         oe = try(system(qq("\"@{normalizePath(R_binary(), winslash='/')}\" --vanilla < \'@{temp_R_file}\'", code.pattern = "@\\{CODE\\}"), ignore.stdout = TRUE, ignore.stderr = TRUE), silent = TRUE)
122
+        #     }
123
+        # } else {
124
+        #     if(is_windows()) {
125
+        #         oe = try(system(qq("\"@{normalizePath(R_binary(), winslash='/')}\" --vanilla < @{temp_R_file}", code.pattern = "@\\{CODE\\}"), ignore.stdout = TRUE, ignore.stderr = TRUE, show.output.on.console = FALSE), silent = TRUE)
126
+        #     } else {
127
+        #         oe = try(system(qq("\"@{normalizePath(R_binary(), winslash='/')}\" --vanilla < @{temp_R_file}", code.pattern = "@\\{CODE\\}"), ignore.stdout = TRUE, ignore.stderr = TRUE), silent = TRUE)
128
+        #     }
129
+        # }
130
+        # ############################################
131
+        # file.remove(temp_R_data)
132
+        # file.remove(temp_R_file)
133
+        # if(inherits(oe, "try-error")) {
134
+        #     stop(oe)
135
+        # }
136
+        image = getFromNamespace(device_info[3], ns = device_info[2])(temp_image)
137
+        image = as.raster(image)
138
+        grid.raster(image, width = unit(1, "npc"), height = unit(1, "npc"))
139
+        file.remove(temp_image)
140
+
141
+    } else {
142
+        if(any(names(gp) %in% c("type"))) {
143
+            if(gp$type == "none") {
144
+            } else {
145
+                grid.rect(x[expand_index[[2]]], y[expand_index[[1]]], width = unit(1/nc, "npc"), height = unit(1/nr, "npc"), gp = do.call("gpar", c(list(fill = col_matrix), gp)))
146
+            }
147
+        } else {
148
+            grid.rect(x[expand_index[[2]]], y[expand_index[[1]]], width = unit(1/nc, "npc"), height = unit(1/nr, "npc"), gp = do.call("gpar", c(list(fill = col_matrix), gp)))
149
+        }
150
+
151
+        if(is.function(cell_fun)) {
152
+            for(i in row_order) {
153
+                for(j in column_order) {
154
+                    cell_fun(j, i, unit(x[which(column_order == j)], "npc"), unit(y[which(row_order == i)], "npc"), unit(1/nc, "npc"), unit(1/nr, "npc"), col_matrix[which(row_order == i), which(column_order == j)])
155
+                }
156
+            }
157
+        }
158
+    }
159
+
160
+    if(!identical(border, FALSE)) {
161
+        grid.rect(gp = gpar(fill = "transparent", col = border))
162
+    }
163
+
164
+    upViewport()
165
+
166
+})
167
+
168
+is_windows = function() {
169
+    tolower(.Platform$OS.type) == "windows"
170
+}
171
+
172
+R_binary = function() {
173
+    R_exe = ifelse(is_windows(), "R.exe", "R")
174
+    return(file.path(R.home("bin"), R_exe))
175
+}
176
+
177
+# == title
178
+# Draw Heatmap Dendrograms
179
+#
180
+# == param
181
+# -object A `Heatmap-class` object.
182
+# -which Are the dendrograms put on the row or on the column of the heatmap?
183
+# -k Slice index.
184
+# -... Pass to `grid::viewport` which includes the complete heatmap dendrograms.
185
+#
186
+# == details
187
+# A viewport is created which contains dendrograms.
188
+#
189
+# This function is only for internal use.
190
+#
191
+# == value
192
+# This function returns no value.
193
+#
194
+# == seealso
195
+# `grid.dendrogram`
196
+#
197
+# == author
198
+# Zuguang Gu <z.gu@dkfz.de>
199
+#
200
+setMethod(f = "draw_dend",
201
+    signature = "Heatmap",
202
+    definition = function(object,
203
+    which = c("row", "column"), k = 1, max_height = NULL, ...) {
204
+
205
+    which = match.arg(which)[1]
206
+    
207
+    side = switch(which,
208
+        "row" = object@row_dend_param$side,
209
+        "column" = object@column_dend_param$side)
210
+    
211
+    dend = switch(which,
212
+        "row" = object@row_dend_list[[k]],
213
+        "column" = object@column_dend_list[[k]])
214
+    
215
+    gp = switch(which,
216
+        "row" = object@row_dend_param$gp,
217
+        "column" = object@column_dend_param$gp)
218
+
219
+    if(length(dend) == 0) {
220
+        return(invisible(NULL))
221
+    }
222
+
223
+    if(is.null(dend)) return(invisible(NULL))
224
+
225
+    if(nobs(dend) <= 1) {
226
+        return(invisible(NULL))
227
+    }
228
+
229
+    if(is.null(max_height)) {
230
+        max_height = dend_heights(dend)
231
+    }
232
+
233
+    if(side %in% c("left", "right")) {
234
+        xscale = c(0, max_height)
235
+        yscale = c(0, nobs(dend))
236
+        width = unit(1, "npc")
237
+        height = unit(1, "npc")
238
+        name = paste(object@name, "dend_row", k, sep = "_")
239
+    } else {
240
+        xscale = c(0, nobs(dend))
241
+        yscale = c(0, max_height)
242
+        height = unit(1, "npc")
243
+        width = unit(1, "npc")
244