Browse code

some changes

Zuguang Gu authored on 12/08/2018 20:47:19
Showing 17 changed files

... ...
@@ -25,7 +25,7 @@ setGeneric('prepare', function(object, ...) standardGeneric('prepare'))
25 25
 
26 26
 setGeneric('draw_annotation', function(object, ...) standardGeneric('draw_annotation'))
27 27
 
28
-setGeneric('get_color_mapping_param_list', function(object, ...) standardGeneric('get_color_mapping_param_list'))
28
+setGeneric('get_legend_param_list', function(object, ...) standardGeneric('get_legend_param_list'))
29 29
 
30 30
 setGeneric('draw_dimnames', function(object, ...) standardGeneric('draw_dimnames'))
31 31
 
... ...
@@ -55,4 +55,5 @@ setGeneric('row_dend', function(object, ...) standardGeneric('row_dend'))
55 55
 
56 56
 setGeneric('copy_all', function(object, ...) standardGeneric('copy_all'))
57 57
 setGeneric('resize', function(object, ...) standardGeneric('resize'))
58
+setGeneric('adjust_heatmap_list', function(object, ...) standardGeneric('adjust_heatmap_list'))
58 59
 
... ...
@@ -223,10 +223,10 @@ setMethod(f = "show",
223 223
 	cat("  items:", ifelse(object@n == 0, "unknown", object@n), "\n")
224 224
 	cat("  width:", as.character(object@width), "\n")
225 225
 	cat("  height:", as.character(object@height), "\n")
226
-	var_imported = names(anno@var_env)
226
+	var_imported = names(object@var_env)
227 227
 	if(length(var_imported)) {
228 228
 		cat("  imported variable:", paste(var_imported, collapse = ", "), "\n")
229
-		var_subsetable = names(anno@subset_rule)
229
+		var_subsetable = names(object@subset_rule)
230 230
 		if(length(var_subsetable)) {
231 231
 			cat("  subsetable variable:", paste(var_subsetable, collapse = ", "), "\n")
232 232
 		}
... ...
@@ -442,19 +442,19 @@ anno_image = function(image, which = c("column", "row"), border = TRUE,
442 442
 			if(!requireNamespace("png")) {
443 443
 				stop("Need png package to read png images.")
444 444
 			}
445
-			image_list[[i]] = getFromNamespace("readPNG", ns = "png")(image[i])
445
+			image_list[[i]] = png::readPNG(image[i])
446 446
 			image_class[i] = "raster"
447 447
 		} else if(image_type[i] %in% c("jpeg", "jpg")) {
448 448
 			if(!requireNamespace("jpeg")) {
449 449
 				stop("Need jpeg package to read jpeg/jpg images.")
450 450
 			}
451
-			image_list[[i]] = getFromNamespace("readJPEG", ns = "jpeg")(image[i])
451
+			image_list[[i]] = jpeg::readJPEG(image[i])
452 452
 			image_class[i] = "raster"
453 453
 		} else if(image_type[i] == "tiff") {
454 454
 			if(!requireNamespace("tiff")) {
455 455
 				stop("Need tiff package to read tiff images.")
456 456
 			}
457
-			image_list[[i]] = getFromNamespace("readTIFF", ns = "tiff")(image[i])
457
+			image_list[[i]] = tiff::readTIFF(image[i])
458 458
 			image_class[i] = "raster"
459 459
 		} else if(image_type[i] %in% c("pdf", "eps")) {
460 460
 			if(!requireNamespace("grImport")) {
... ...
@@ -462,7 +462,7 @@ anno_image = function(image, which = c("column", "row"), border = TRUE,
462 462
 			}
463 463
 			temp_file = tempfile()
464 464
 			getFromNamespace("PostScriptTrace", ns = "grImport")(image[[i]], temp_file)
465
-			image_list[[i]] = getFromNamespace("readPicture", ns = "grImport")(temp_file)
465
+			image_list[[i]] = grImport::readPicture(temp_file)
466 466
 			file.remove(temp_file)
467 467
 			image_class[i] = "grImport::Picture"
468 468
 		} else if(image_type[i] == "svg") {
... ...
@@ -473,8 +473,8 @@ anno_image = function(image, which = c("column", "row"), border = TRUE,
473 473
 				stop("Need rsvg package to convert svg images.")
474 474
 			}
475 475
 			temp_file = tempfile()
476
-			getFromNamespace("rsvg_svg", ns = "rsvg")(image[i], temp_file)
477
-			image_list[[i]] = getFromNamespace("readPicture", ns = "grImport2")(temp_file)
476
+			rsvg::rsvg_svg(image[i], temp_file)
477
+			image_list[[i]] = grImport2::readPicture(temp_file)
478 478
 			file.remove(temp_file)
479 479
 			image_class[i] = "grImport2::Picture"
480 480
 		}
... ...
@@ -781,6 +781,147 @@ update_anno_extend = function(anno, axis_grob, axis_param) {
781 781
 	return(extended)
782 782
 }
783 783
 
784
+anno_lines = function(x, which = c("column", "row"), border = TRUE, gp = gpar(), 
785
+	add_points = TRUE, pch = 16, size = unit(2, "mm"), pt_gp = gpar(), ylim = NULL, 
786
+	extend = 0.05, axis = TRUE, axis_param = default_axis_param(which),
787
+	width = NULL, height = NULL) {
788
+
789
+	if(is.null(.ENV$current_annotation_which)) {
790
+		which = match.arg(which)[1]
791
+	} else {
792
+		which = .ENV$current_annotation_which
793
+	}
794
+
795
+	if(is.data.frame(x)) x = as.matrix(x)
796
+	if(is.matrix(x)) {
797
+		if(ncol(x) == 1) {
798
+			x = x[, 1]
799
+		}
800
+	}
801
+	input_is_matrix = is.matrix(x)
802
+
803
+	anno_size = anno_width_and_height(which, width, height, unit(1, "cm"))
804
+
805
+	if(is.matrix(x)) {
806
+		n = nrow(x)
807
+		nr = n
808
+		nc = ncol(x)
809
+	} else {
810
+		n = length(x)
811
+		nr = n
812
+		nc = 1
813
+	}
814
+
815
+	if(is.atomic(x)) {
816
+		gp = recycle_gp(gp, 1)
817
+		pt_gp = recycle_gp(pt_gp, n)
818
+		if(length(pch) == 1) pch = rep(pch, n)
819
+		if(length(size) == 1) size = rep(size, n)
820
+	} else if(input_is_matrix) {
821
+		gp = recycle_gp(gp, nc)
822
+		pt_gp = recycle_gp(pt_gp, nc)
823
+		if(length(pch) == 1) pch = rep(pch, nc)
824
+		if(length(size) == 1) size = rep(size, nc)
825
+	}
826
+	
827
+	if(is.null(ylim)) {
828
+		data_scale = range(x, na.rm = TRUE)
829
+	} else {
830
+		data_scale = ylim
831
+	}
832
+	data_scale = data_scale + c(-extend, extend)*(data_scale[2] - data_scale[1])
833
+
834
+	value = x
835
+
836
+	axis_param = validate_axis_param(axis_param, which)
837
+	axis_grob = if(axis) construct_axis_grob(axis_param, which, data_scale) else NULL
838
+
839
+	row_fun = function(index) {
840
+		n = length(index)
841
+
842
+		pushViewport(viewport(xscale = data_scale, yscale = c(0.5, n+0.5)))
843
+		if(is.matrix(value)) {
844
+			for(i in seq_len(ncol(value))) {
845
+				grid.lines(value[index, i], n - seq_along(index) + 1, gp = subset_gp(gp, i), 
846
+					default.units = "native")
847
+				if(add_points) {
848
+					grid.points(value[index, i], n - seq_along(index) + 1, gp = subset_gp(pt_gp, i), 
849
+						default.units = "native", pch = pch[i], size = size[i])
850
+				}
851
+			}
852
+		} else {
853
+			grid.lines(value[index, i], n - seq_along(index) + 1, gp = gp, 
854
+				default.units = "native")
855
+			if(add_points) {
856
+				grid.points(value[index], n - seq_along(index) + 1, gp = gp, default.units = "native", 
857
+					pch = pch[index], size = size[index])
858
+			}
859
+		}
860
+		if(axis) grid.draw(axis_grob)
861
+		if(border) grid.rect(gp = gpar(fill = "transparent"))
862
+		popViewport()
863
+	}
864
+
865
+	column_fun = function(index) {
866
+		n = length(index)
867
+		
868
+		pushViewport(viewport(yscale = data_scale, xscale = c(0.5, n+0.5)))
869
+		if(is.matrix(value)) {
870
+			for(i in seq_len(ncol(value))) {
871
+				grid.lines(seq_along(index), value[index, i], gp = subset_gp(gp, i), 
872
+					default.units = "native")
873
+				if(add_points) {
874
+					grid.points(seq_along(index), value[index, i], gp = subset_gp(pt_gp, i), 
875
+						default.units = "native", pch = pch[i], size = size[i])
876
+				}
877
+			}
878
+		} else {
879
+			grid.lines(seq_along(index), value[index], gp = gp, default.units = "native")
880
+			if(add_points) {
881
+				grid.points(seq_along(index), value[index], gp = pt_gp, default.units = "native", 
882
+					pch = pch[index], size = size[index])
883
+			}
884
+		}
885
+		if(axis) grid.draw(axis_grob)
886
+		if(border) grid.rect(gp = gpar(fill = "transparent"))
887
+		popViewport()
888
+	}
889
+
890
+	if(which == "row") {
891
+		fun = row_fun
892
+	} else if(which == "column") {
893
+		fun = column_fun
894
+	}
895
+
896
+	anno = AnnotationFunction(
897
+		fun = fun,
898
+		fun_name = "anno_points",
899
+		which = which,
900
+		width = anno_size$width,
901
+		height = anno_size$height,
902
+		n = n,
903
+		data_scale = data_scale,
904
+		var_import = list(value, gp, border, pch, size, pt_gp, axis, axis_param, axis_grob, data_scale, add_points)
905
+	)
906
+
907
+	anno@subset_rule$gp = subset_vector
908
+	if(input_is_matrix) {
909
+		anno@subset_rule$value = subset_matrix_by_row
910
+	} else {
911
+		anno@subset_rule$value = subset_vector
912
+		anno@subset_rule$gp = subset_gp
913
+		anno@subset_rule$pt_gp = subset_gp
914
+		anno@subset_rule$size = subset_vector
915
+		anno@subset_rule$pch = subset_vector
916
+	}
917
+
918
+	anno@subsetable = TRUE
919
+
920
+	anno@extended = update_anno_extend(anno, axis_grob, axis_param)
921
+		
922
+	return(anno) 
923
+}
924
+
784 925
 # == title
785 926
 # Using barplot as annotation
786 927
 #
... ...
@@ -1526,7 +1667,7 @@ anno_text = function(x, which = c("column", "row"), gp = gpar(),
1526 1667
 		unit(ifelse(which == "column", 1, 0), "npc")
1527 1668
 	}
1528 1669
 
1529
-	rot = rot[1]
1670
+	rot = rot[1] %% 360
1530 1671
 	just = just[1]
1531 1672
 	if(!missing(offset)) {
1532 1673
 		warning("`offset` is deprecated, use `location` instead.")
... ...
@@ -307,7 +307,7 @@ setMethod(f = "color_mapping_legend",
307 307
 	if(plot) {
308 308
 		pushViewport(viewport(..., width = grobWidth(gf), height = grobHeight(gf), name = paste0("legend_", object@name)))
309 309
 		grid.draw(gf)
310
-		upViewport()
310
+		popViewport()
311 311
 	}
312 312
 
313 313
 	#size = unit.c(vp_width, vp_height)
... ...
@@ -71,24 +71,23 @@ Heatmap = setClass("Heatmap",
71 71
         matrix = "matrix",  # one or more matrix which are spliced by rows
72 72
         matrix_param = "list",
73 73
         matrix_color_mapping = "ANY",
74
-        matrix_color_mapping_param = "ANY",
74
+        matrix_legend_param = "ANY",
75 75
 
76 76
         row_title = "ANY",
77
-        row_title_rot = "numeric",
78
-        row_title_just = "numeric",
79 77
         row_title_param = "list",
80 78
         column_title = "ANY",
81 79
         column_title_param = "list",
82
-        column_title_rot = "numeric",
83
-        column_title_just = "numeric",
84 80
 
85 81
         row_dend_list = "list", # one or more row clusters
82
+        row_dend_slice = "ANY",
86 83
         row_dend_param = "list", # parameters for row cluster
87 84
         row_order_list = "list",
88 85
         row_order = "numeric",
89 86
 
90
-        column_dend = "ANY",
87
+        column_dend_list = "list",
88
+        column_dend_slice = "ANY",
91 89
         column_dend_param = "list", # parameters for column cluster
90
+        column_order_list = "list",
92 91
         column_order = "numeric",
93 92
 
94 93
         row_names_param = "list",
... ...
@@ -96,7 +95,6 @@ Heatmap = setClass("Heatmap",
96 95
 
97 96
         top_annotation = "ANY", # NULL or a `HeatmapAnnotation` object
98 97
         top_annotation_param = "list",
99
-
100 98
         bottom_annotation = "ANY",
101 99
         bottom_annotation_param = "list",
102 100
 
... ...
@@ -231,7 +229,9 @@ Heatmap = function(matrix, col, name,
231 229
     na_col = "grey", 
232 230
     color_space = "LAB",
233 231
     rect_gp = gpar(col = NA), 
232
+    border = NA,
234 233
     cell_fun = NULL,
234
+
235 235
     row_title = character(0), 
236 236
     row_title_side = c("left", "right"), 
237 237
     row_title_gp = gpar(fontsize = 14), 
... ...
@@ -240,6 +240,7 @@ Heatmap = function(matrix, col, name,
240 240
     column_title_side = c("top", "bottom"), 
241 241
     column_title_gp = gpar(fontsize = 14), 
242 242
     column_title_rot = 0,
243
+
243 244
     cluster_rows = TRUE, 
244 245
     clustering_distance_rows = "euclidean",
245 246
     clustering_method_rows = "complete", 
... ...
@@ -248,11 +249,6 @@ Heatmap = function(matrix, col, name,
248 249
     show_row_dend = TRUE, 
249 250
     row_dend_reorder = TRUE,
250 251
     row_dend_gp = gpar(), 
251
-    row_hclust_side = row_dend_side,
252
-    row_hclust_width = row_dend_width, 
253
-    show_row_hclust = show_row_dend, 
254
-    row_hclust_reorder = row_dend_reorder,
255
-    row_hclust_gp = row_dend_gp, 
256 252
     cluster_columns = TRUE, 
257 253
     clustering_distance_columns = "euclidean", 
258 254
     clustering_method_columns = "complete",
... ...
@@ -261,89 +257,95 @@ Heatmap = function(matrix, col, name,
261 257
     show_column_dend = TRUE, 
262 258
     column_dend_gp = gpar(), 
263 259
     column_dend_reorder = TRUE,
264
-    column_hclust_side = column_dend_side, 
265
-    column_hclust_height = column_dend_height, 
266
-    show_column_hclust = show_column_dend, 
267
-    column_hclust_gp = column_dend_gp, 
268
-    column_hclust_reorder = column_dend_reorder,
260
+
269 261
     row_order = NULL, 
270 262
     column_order = NULL,
263
+
264
+    row_labels = rownames(matrix),
271 265
     row_names_side = c("right", "left"), 
272 266
     show_row_names = TRUE, 
273
-    row_names_max_width = default_row_names_max_width(), 
267
+    row_names_max_width = unit(6, "cm"), 
274 268
     row_names_gp = gpar(fontsize = 12), 
269
+    row_names_rot = 0,
270
+    column_labels = colnames(matrix),
275 271
     column_names_side = c("bottom", "top"), 
276 272
     show_column_names = TRUE, 
277
-    column_names_max_height = default_column_names_max_height(), 
273
+    column_names_max_height = unit(6, "cm"), 
278 274
     column_names_gp = gpar(fontsize = 12),
275
+    column_names_rot = 90,
276
+
279 277
     top_annotation = new("HeatmapAnnotation"),
280 278
     top_annotation_height = top_annotation@size,
281 279
     bottom_annotation = new("HeatmapAnnotation"),
282 280
     bottom_annotation_height = bottom_annotation@size,
281
+
283 282
     km = 1, 
284
-    km_title = "cluster%i",
285 283
     split = NULL, 
284
+    row_km = km,
285
+    row_split = split,
286 286
     column_km = 1,
287
-    column_km_title = "cluster%i",
288 287
     column_split = NULL,
289 288
     gap = unit(1, "mm"),
290
-    column_gap = unit(2, "mm"),
291
-    combined_name_fun = function(x) paste(x, collapse = "/"),
292
-    width = NULL, 
289
+    row_gap = unit(1, "mm"),
290
+    column_gap = unit(1, "mm"),
291
+
292
+    width = unit(1, "npc"),
293
+    heatmap_body_width = NULL,
294
+    height = unit(1, "npc"), 
295
+    heatmap_body_height = NULL,
296
+
293 297
     show_heatmap_legend = TRUE,
294 298
     heatmap_legend_param = list(title = name),
295
-    use_raster = FALSE, 
299
+
300
+    use_raster = nrow(matrix) > 5000, 
296 301
     raster_device = c("png", "jpeg", "tiff", "CairoPNG", "CairoJPEG", "CairoTIFF"),
297 302
     raster_quality = 2,
298 303
     raster_device_param = list()) {
299 304
 
305
+    verbose = ht_global_opt("verbose")
306
+
307
+    if(!dev.interactive()) {
308
+        pdf(file = NULL)
309
+        on.exit(dev.off())
310
+    }
311
+
312
+    .Object = new("Heatmap")
313
+    if(missing(name)) {
314
+        name = paste0("matrix_", get_heatmap_index() + 1)
315
+        increase_heatmap_index()
316
+    }
317
+    .Object@name = name
318
+
300 319
     # re-define some of the argument values according to global settings
301 320
     called_args = names(as.list(match.call())[-1])
302
-    e = environment()
303 321
     for(opt_name in c("row_names_gp", "column_names_gp", "row_title_gp", "column_title_gp")) {
304 322
         opt_name2 = paste0("heatmap_", opt_name)
305 323
         if(! opt_name %in% called_args) { # if this argument is not called
306 324
             if(!is.null(ht_global_opt(opt_name2))) {
307
-                assign(opt_name, ht_global_opt(opt_name2), envir = e)
325
+                if(verbose) qqcat("re-assign @{opt_name} with `ht_global_opt('@{opt_name2}'')`\n")
326
+                assign(opt_name, ht_global_opt(opt_name2))
308 327
             }
309 328
         }
310 329
     }
311 330
 
312
-    for(ca in called_args) {
313
-        if(ca %in% c("row_hclust_side", "row_hclust_width", "show_row_hclust", "row_hclust_reorder", "row_hclust_gp",
314
-                     "column_hclust_side", "column_hclust_height", "show_column_hclust", "column_hclust_gp", "column_hclust_reorder")) {
315
-            ca_new = gsub("hclust", "dend", ca)
316
-            if(!ca_new %in% called_args) {
317
-                assign(ca_new, get(ca))
318
-            }
319
-            warning(paste0("'", ca, "' is deprecated in the future, use '", ca_new, "' instead."))
320
-        }
321
-    }
322
-   
323 331
     if("heatmap_legend_param" %in% called_args) {
324 332
         for(opt_name in setdiff(c("title_gp", "title_position", "labels_gp", "grid_width", "grid_height", "grid_border"), names(heatmap_legend_param))) {
325 333
             opt_name2 = paste0("heatmap_legend_", opt_name)
326 334
             if(!is.null(ht_global_opt(opt_name2)))
335
+                if(verbose) qqcat("re-assign heatmap_legend_param$@{opt_name} with `ht_global_opt('@{opt_name2}'')`\n")
327 336
                 heatmap_legend_param[[opt_name]] = ht_global_opt(opt_name2)
328 337
         }
329 338
     } else {
330 339
         for(opt_name in c("title_gp", "title_position", "labels_gp", "grid_width", "grid_height", "grid_border")) {
331 340
             opt_name2 = paste0("heatmap_legend_", opt_name)
332 341
             if(!is.null(ht_global_opt(opt_name2)))
342
+                if(verbose) qqcat("re-assign heatmap_legend_param$@{opt_name} with `ht_global_opt('@{opt_name2}'')`\n")
333 343
                 heatmap_legend_param[[opt_name]] = ht_global_opt(opt_name2)
334 344
         }
335 345
     }
336 346
 
337
-    .Object = new("Heatmap")
338
-
339
-    .Object@heatmap_param$width = width
340
-    .Object@heatmap_param$show_heatmap_legend = show_heatmap_legend
341
-    .Object@heatmap_param$use_raster = use_raster
342
-    .Object@heatmap_param$raster_device = match.arg(raster_device)[1]
343
-    .Object@heatmap_param$raster_quality = raster_quality
344
-    .Object@heatmap_param$raster_device_param = raster_device_param
345
-
346 347
     if(is.data.frame(matrix)) {
348
+        if(verbose) qqcat("convert data frame to matrix\n")
347 349
         matrix = as.matrix(matrix)
348 350
     }
349 351
     if(!is.matrix(matrix)) {
... ...
@@ -352,20 +354,22 @@ Heatmap = function(matrix, col, name,
352 354
             matrix = matrix(matrix, ncol = 1)
353 355
             if(!is.null(rn)) rownames(matrix) = rn
354 356
             if(!missing(name)) colnames(matrix) = name
357
+            if(verbose) qqcat("convert simple vector to one-column matrix\n")
355 358
         } else {
356 359
             stop("If data is not a matrix, it should be a simple vector.")
357 360
         }
358 361
     }
359 362
 
360
-    if(is.null(width)) {
361
-        .Object@heatmap_param$width = ncol(matrix)
362
-    }
363
-
364 363
     if(ncol(matrix) == 0) {
365 364
         .Object@heatmap_param$show_heatmap_legend = FALSE
366
-        .Object@heatmap_param$width = unit(0, "mm")
367 365
     }
368 366
 
367
+    ### normalize km/split and row_km/row_split
368
+    if(missing(row_km)) row_km = km
369
+    if(missing(row_split)) row_split = split
370
+    if(missing(row_gap)) row_gap = gap
371
+
372
+    ####### zero and one column matrix ########
369 373
     if(ncol(matrix) == 0 || nrow(matrix) == 0) {
370 374
         if(!inherits(cluster_columns, c("dendrogram", "hclust"))) {
371 375
             cluster_columns = FALSE
... ...
@@ -375,21 +379,27 @@ Heatmap = function(matrix, col, name,
375 379
             cluster_rows = FALSE
376 380
             show_row_dend = FALSE
377 381
         }
378
-        km = 1
382
+        row_km = 1
383
+        column_km = 1
384
+        if(verbose) qqcat("zero row/column matrix, set cluster_columns/rows to FALSE\n")
379 385
     }
380 386
     if(ncol(matrix) == 1) {
381 387
         if(!inherits(cluster_columns, c("dendrogram", "hclust"))) {
382 388
             cluster_columns = FALSE
383 389
             show_column_dend = FALSE
384 390
         }
391
+        column_km = 1
392
+        if(verbose) qqcat("one-column matrix, set cluster_columns to FALSE\n")
385 393
     }
386 394
     if(nrow(matrix) == 1) {
387 395
         if(!inherits(cluster_rows, c("dendrogram", "hclust"))) {
388 396
             cluster_rows = FALSE
389 397
             show_row_dend = FALSE
390 398
         }
391
-        km = 1
399
+        row_km = 1
400
+        if(verbose) qqcat("one-row matrix, set cluster_rows to FALSE\n")
392 401
     }
402
+
393 403
     if(is.character(matrix)) {
394 404
         called_args = names(match.call()[-1])
395 405
         if("clustering_distance_rows" %in% called_args) {
... ...
@@ -399,6 +409,7 @@ Heatmap = function(matrix, col, name,
399 409
             show_row_dend = FALSE
400 410
         }
401 411
         row_dend_reorder = FALSE
412
+
402 413
         if("clustering_distance_columns" %in% called_args) {
403 414
         } else if(inherits(cluster_columns, c("dendrogram", "hclust"))) {
404 415
         } else {
... ...
@@ -406,32 +417,34 @@ Heatmap = function(matrix, col, name,
406 417
             show_column_dend = FALSE
407 418
         }
408 419
         column_dend_reorder = FALSE
409
-        km = 1
420
+        row_km = 1
421
+        column_km = 1
422
+        if(verbose) qqcat("matrix is character. Do not cluster unless distance method is provided.\n")
410 423
     }
411 424
     .Object@matrix = matrix
412 425
 
413
-    .Object@matrix_param$km = km
414
-    .Object@matrix_param$km_title = km_title
415
-    .Object@matrix_param$gap = gap
416
-    if(!is.null(split)) {
426
+    .Object@matrix_param$row_km = row_km
427
+    .Object@matrix_param$row_gap = row_gap
428
+    .Object@matrix_param$column_km = column_km
429
+    .Object@matrix_param$column_gap = column_gap
430
+
431
+    ### check row_split and column_split ###
432
+    if(!is.null(row_split)) {
417 433
         if(inherits(cluster_rows, c("dendrogram", "hclust"))) {
418
-            .Object@matrix_param$split = split
434
+            .Object@matrix_param$row_split = row_split
419 435
         } else {
420
-            if(identical(cluster_rows, TRUE) && is.numeric(split) && length(split) == 1) {
436
+            if(identical(cluster_rows, TRUE) && is.numeric(row_split) && length(row_split) == 1) {
421 437
 
422 438
             } else {
423
-                if(!is.data.frame(split)) split = data.frame(split)
424
-                if(nrow(split) != nrow(matrix)) {
425
-                    stop("Length or number of rows of `split` should be same as rows in `matrix`.")
439
+                if(!is.data.frame(row_split)) row_split = data.frame(row_split)
440
+                if(nrow(row_split) != nrow(matrix)) {
441
+                    stop("Length or number of rows of `row_split` should be same as rows in `matrix`.")
426 442
                 }
427 443
             }
428 444
         }
429 445
     }
430
-    .Object@matrix_param$split = split
446
+    .Object@matrix_param$row_split = row_split
431 447
 
432
-
433
-    .Object@matrix_param$column_km = column_km
434
-    .Object@matrix_param$column_gap = column_gap
435 448
     if(!is.null(column_split)) {
436 449
         if(inherits(cluster_columns, c("dendrogram", "hclust"))) {
437 450
             .Object@matrix_param$column_split = column_split
... ...
@@ -440,7 +453,7 @@ Heatmap = function(matrix, col, name,
440 453
 
441 454
             } else {
442 455
                 if(!is.data.frame(column_split)) column_split = data.frame(column_split)
443
-                if(nrow(column_split) != nrow(matrix)) {
456
+                if(nrow(column_split) != ncol(matrix)) {
444 457
                     stop("Length or number of columns of `column_split` should be same as columns in `matrix`.")
445 458
                 }
446 459
             }
... ...
@@ -448,100 +461,132 @@ Heatmap = function(matrix, col, name,
448 461
     }
449 462
     .Object@matrix_param$column_split = column_split
450 463
 
451
-    .Object@matrix_param$gp =check_gp(rect_gp)
464
+
465
+    ### parameters for heatmap body ###
466
+    .Object@matrix_param$gp = check_gp(rect_gp)
467
+    if(identical(border, TRUE)) border = "black"
468
+    .Object@matrix_param$border = border
452 469
     .Object@matrix_param$cell_fun = cell_fun
453 470
     
454
-    if(missing(name)) {
455
-        name = paste0("matrix_", get_heatmap_index() + 1)
456
-        increase_heatmap_index()
471
+    if(!missing(heatmap_body_width)) {
472
+        if(is_abs_unit(heatmap_body_width)) {
473
+            width = unit(1, "npc") # since width is a relative unit and all components are absolute, it will be refit
474
+        }
457 475
     }
458
-    .Object@name = name
459
-
460
-    # if(ncol(matrix) == 1 && is.null(colnames(matrix))) {
461
-    #     colnames(matrix) = name
462
-    #     .Object@matrix = matrix
463
-    # }
476
+    if(!missing(heatmap_body_height)) {
477
+        if(is_abs_unit(heatmap_body_height)) {
478
+            height = unit(1, "npc")
479
+        }
480
+    }
481
+    if(is.null(heatmap_body_width)) {
482
+        heatmap_body_width = unit(ncol(matrix), "null")
483
+    }
484
+    if(is.null(heatmap_body_height)) {
485
+        heatmap_body_height = unit(nrow(matrix), "null")
486
+    }
487
+    .Object@matrix_param$width = heatmap_body_width
488
+    .Object@matrix_param$height = heatmap_body_height
489
+    
464 490
 
465
-    # color for main matrix
491
+    ### color for main matrix #########
466 492
     if(ncol(matrix) > 0 && nrow(matrix) > 0) {
467 493
         if(missing(col)) {
468 494
             col = default_col(matrix, main_matrix = TRUE)
495
+            if(verbose) qqcat("color is not specified, use randomly generated colors\n")
469 496
         }
470 497
         if(is.function(col)) {
471 498
             .Object@matrix_color_mapping = ColorMapping(col_fun = col, name = name, na_col = na_col)
499
+            if(verbose) qqcat("input color is a color mapping function\n")
472 500
         } else {
473 501
             if(is.null(names(col))) {
474 502
                 if(length(col) == length(unique(as.vector(matrix)))) {
475 503
                     names(col) = sort(unique(as.vector(matrix)))
476 504
                     .Object@matrix_color_mapping = ColorMapping(colors = col, name = name, na_col = na_col)
505
+                    if(verbose) qqcat("input color is a vector with no names, treat it as discrete color mapping\n")
477 506
                 } else if(is.numeric(matrix)) {
478 507
                     col = colorRamp2(seq(min(matrix, na.rm = TRUE), max(matrix, na.rm = TRUE), length = length(col)),
479 508
                                      col, space = color_space)
480 509
                     .Object@matrix_color_mapping = ColorMapping(col_fun = col, name = name, na_col = na_col)
510
+                    if(verbose) qqcat("input color is a vector with no names, treat it as continuous color mapping\n")
481 511
                 } else {
482 512
                     stop("`col` should have names to map to values in `mat`.")
483 513
                 }
484 514
             } else {
485 515
                 col = col[intersect(c(names(col), "_NA_"), as.character(matrix))]
486 516
                 .Object@matrix_color_mapping = ColorMapping(colors = col, name = name, na_col = na_col)
517
+                if(verbose) qqcat("input color is a named vector\n")
487 518
             }
488 519
         }
489
-        .Object@matrix_color_mapping_param = heatmap_legend_param
520
+        .Object@matrix_legend_param = heatmap_legend_param
490 521
     }
491 522
     
523
+    ##### titles, should also consider titles after row splitting #####
492 524
     if(length(row_title) == 0) {
493
-        row_title = character(0)
494 525
     } else if(!inherits(row_title, c("expression", "call"))) {
495
-            if(is.na(row_title)) {
526
+        if(is.na(row_title)) {
496 527
             row_title = character(0)
497 528
         } else if(row_title == "") {
498 529
             row_title = character(0)
499 530
         }
500 531
     }
501 532
     .Object@row_title = row_title
502
-    .Object@row_title_rot = row_title_rot %% 360
533
+    .Object@row_title_param$rot = row_title_rot %% 360
503 534
     .Object@row_title_param$side = match.arg(row_title_side)[1]
504 535
     .Object@row_title_param$gp = check_gp(row_title_gp)  # if the number of settings is same as number of row-splits, gp will be adjusted by `make_row_dend`
505
-    .Object@row_title_param$combined_name_fun = combined_name_fun
506
-    .Object@row_title_just = get_text_just(rot = row_title_rot, side = .Object@row_title_param$side)
536
+    .Object@row_title_param$just = get_text_just(rot = row_title_rot, side = .Object@row_title_param$side)
507 537
 
508 538
     if(length(column_title) == 0) {
509
-        column_title = character(0)
510 539
     } else if(!inherits(column_title, c("expression", "call"))) {
511
-            if(is.na(column_title)) {
540
+        if(is.na(column_title)) {
512 541
             column_title = character(0)
513 542
         } else if(column_title == "") {
514 543
             column_title = character(0)
515 544
         }
516 545
     }
517 546
     .Object@column_title = column_title
518
-    .Object@column_title_rot = column_title_rot %% 360
547
+    .Object@column_title_param$rot = column_title_rot %% 360
519 548
     .Object@column_title_param$side = match.arg(column_title_side)[1]
520 549
     .Object@column_title_param$gp = check_gp(column_title_gp)
521
-    .Object@column_title_just = get_text_just(rot = column_title_rot, side = .Object@column_title_param$side)
550
+    .Object@column_title_param$just = get_text_just(rot = column_title_rot, side = .Object@column_title_param$side)
522 551
 
552
+    ### row labels/column labels ###
523 553
     if(is.null(rownames(matrix))) {
524 554
         show_row_names = FALSE
525 555
     }
556
+    .Object@row_names_param$labels = row_labels
526 557
     .Object@row_names_param$side = match.arg(row_names_side)[1]
527 558
     .Object@row_names_param$show = show_row_names
528 559
     .Object@row_names_param$gp = check_gp(row_names_gp)
529
-    default_row_names_max_width = function() {
530
-        min(unit.c(unit(6, "cm")), max_text_width(rownames(matrix), gp = .Object@row_names_param$gp))
531
-    }
560
+    .Object@row_names_param$rot = row_names_rot
532 561
     .Object@row_names_param$max_width = row_names_max_width + unit(2, "mm")
562
+    # we use anno_text to draw row/column names because it already takes care of text rotation
563
+    if(length(row_labels)) {
564
+        row_names_anno = anno_text(row_labels, which = "row", gp = row_names_gp, rot = row_names_rot,
565
+            location = ifelse(.Object@row_names_param$side == "left", 1, 0), 
566
+            just = ifelse(.Object@row_names_param$side == "left", "right", "left"))
567
+        .Object@row_names_param$anno = row_names_anno
568
+    }
533 569
 
534 570
     if(is.null(colnames(matrix))) {
535 571
         show_column_names = FALSE
536 572
     }
573
+    .Object@column_names_param$labels = column_labels
537 574
     .Object@column_names_param$side = match.arg(column_names_side)[1]
538 575
     .Object@column_names_param$show = show_column_names
539 576
     .Object@column_names_param$gp = check_gp(column_names_gp)
540
-    default_column_names_max_height = function() {
541
-        min(unit.c(unit(6, "cm")), max_text_width(colnames(matrix), gp = .Object@column_names_param$gp))
542
-    }
577
+    .Object@column_names_param$rot = column_names_rot
543 578
     .Object@column_names_param$max_height = column_names_max_height + unit(2, "mm")
579
+    if(length(column_labels)) {
580
+        column_names_anno = anno_text(column_labels, which = "column", gp = column_names_gp, rot = column_names_rot,
581
+            location = ifelse(.Object@column_names_param$side == "top", 0, 1), 
582
+            just = ifelse(.Object@column_names_param$side == "top", "left", "right"))
583
+        .Object@column_names_param$anno = column_names_anno
584
+    }
544 585
 
586
+    #### dendrograms ########
587
+    if(missing(cluster_rows) && !missing(row_order)) {
588
+        cluster_rows = FALSE
589
+    }
545 590
     if(inherits(cluster_rows, "dendrogram") || inherits(cluster_rows, "hclust")) {
546 591
         .Object@row_dend_param$obj = cluster_rows
547 592
         .Object@row_dend_param$cluster = TRUE
... ...
@@ -576,6 +621,9 @@ Heatmap = function(matrix, col, name,
576 621
         .Object@row_order = row_order
577 622
     }
578 623
 
624
+    if(missing(cluster_columns) && !missing(column_order)) {
625
+        cluster_columns = FALSE
626
+    }
579 627
     if(inherits(cluster_columns, "dendrogram") || inherits(cluster_columns, "hclust")) {
580 628
         .Object@column_dend_param$obj = cluster_columns
581 629
         .Object@column_dend_param$cluster = TRUE
... ...
@@ -592,7 +640,7 @@ Heatmap = function(matrix, col, name,
592 640
     if(!show_column_dend) {
593 641
         column_dend_height = unit(0, "mm")
594 642
     }
595
-    .Object@column_dend = NULL
643
+    .Object@column_dend_list = list()
596 644
     .Object@column_dend_param$distance = clustering_distance_columns
597 645
     .Object@column_dend_param$method = clustering_method_columns
598 646
     .Object@column_dend_param$side = match.arg(column_dend_side)[1]
... ...
@@ -609,6 +657,7 @@ Heatmap = function(matrix, col, name,
609 657
         .Object@column_order = column_order
610 658
     }
611 659
 
660
+    ######### annotations #############
612 661
     .Object@top_annotation = top_annotation # a `HeatmapAnnotation` object
613 662
     if(is.null(top_annotation)) {
614 663
         .Object@top_annotation_param$height = unit(0, "mm")    
... ...
@@ -638,117 +687,41 @@ Heatmap = function(matrix, col, name,
638 687
     }
639 688
 
640 689
     .Object@layout = list(
641
-        layout_column_title_top_height = unit(0, "mm"),
642
-        layout_column_dend_top_height = unit(0, "mm"),
643
-        layout_column_anno_top_height = unit(0, "mm"),
644
-        layout_column_names_top_height = unit(0, "mm"),
645
-        layout_column_title_bottom_height = unit(0, "mm"),
646
-        layout_column_dend_bottom_height = unit(0, "mm"),
647
-        layout_column_anno_bottom_height = unit(0, "mm"),
648
-        layout_column_names_bottom_height = unit(0, "mm"),
649
-
650
-        layout_row_title_left_width = unit(0, "mm"),
651
-        layout_row_dend_left_width = unit(0, "mm"),
652
-        layout_row_names_left_width = unit(0, "mm"),
653
-        layout_row_dend_right_width = unit(0, "mm"),
654
-        layout_row_names_right_width = unit(0, "mm"),
655
-        layout_row_title_right_width = unit(0, "mm"),
656
-
657
-        layout_heatmap_width = width, # for the layout of heatmap list
658
-
659
-        layout_index = matrix(nrow = 0, ncol = 2),
690
+        layout_size = list(
691
+            column_title_top_height = unit(0, "mm"),
692
+            column_dend_top_height = unit(0, "mm"),
693
+            column_anno_top_height = unit(0, "mm"),
694
+            column_names_top_height = unit(0, "mm"),
695
+            column_title_bottom_height = unit(0, "mm"),
696
+            column_dend_bottom_height = unit(0, "mm"),
697
+            column_anno_bottom_height = unit(0, "mm"),
698
+            column_names_bottom_height = unit(0, "mm"),
699
+
700
+            row_title_left_width = unit(0, "mm"),
701
+            row_dend_left_width = unit(0, "mm"),
702
+            row_names_left_width = unit(0, "mm"),
703
+            row_dend_right_width = unit(0, "mm"),
704
+            row_names_right_width = unit(0, "mm"),
705
+            row_title_right_width = unit(0, "mm")
706
+        ),
707
+
708
+        layout_index = data.frame(),
660 709
         graphic_fun_list = list()
661 710
     )
662 711
 
712
+    .Object@heatmap_param$width = width
713
+    .Object@heatmap_param$height = height
714
+    .Object@heatmap_param$show_heatmap_legend = show_heatmap_legend
715
+    .Object@heatmap_param$use_raster = use_raster
716
+    .Object@heatmap_param$raster_device = match.arg(raster_device)[1]
717
+    .Object@heatmap_param$raster_quality = raster_quality
718
+    .Object@heatmap_param$raster_device_param = raster_device_param
719
+    .Object@heatmap_param$verbose = verbose
720
+
663 721
     return(.Object)
664 722
 
665 723
 }
666 724
 
667
-# == title
668
-# Make cluster on columns
669
-#
670
-# == param
671
-# -object a `Heatmap-class` object.
672
-#
673
-# == details
674
-# The function will fill or adjust ``column_dend`` and ``column_order`` slots.
675
-#
676
-# This function is only for internal use.
677
-#
678
-# == value
679
-# A `Heatmap-class` object.
680
-#
681
-# == author
682
-# Zuguang Gu <z.gu@dkfz.de>
683
-#
684
-setMethod(f = "make_column_cluster",
685
-    signature = "Heatmap",
686
-    definition = function(object) {
687
-    
688
-    if(ht_global_opt("fast_hclust")) {
689
-        hclust = fastcluster::hclust
690
-    } else {
691
-        hclust = stats::hclust
692
-    }
693
-    
694
-    mat = object@matrix
695
-    distance = object@column_dend_param$distance
696
-    method = object@column_dend_param$method
697
-    order = object@column_order
698
-    reorder = object@column_dend_param$reorder
699
-
700
-    if(object@column_dend_param$cluster) {
701
-        if(!is.null(object@column_dend_param$obj)) {
702
-            object@column_dend = object@column_dend_param$obj
703
-        } else if(!is.null(object@column_dend_param$fun)) {
704
-            object@column_dend = object@column_dend_param$fun(t(mat))
705
-        } else {
706
-            object@column_dend = hclust(get_dist(t(mat), distance), method = method)
707
-        }
708
-        column_order = get_dend_order(object@column_dend)  # we don't need the pre-defined orders
709
-
710
-        if(inherits(object@column_dend, "hclust")) {
711
-            object@column_dend = as.dendrogram(object@column_dend)
712
-        }
713
-
714
-        if(identical(reorder, NULL)) {
715
-            if(is.numeric(mat)) {
716
-                reorder = TRUE
717
-            } else {
718
-                reorder = FALSE
719
-            }
720
-        }
721
-
722
-        do_reorder = TRUE
723
-        if(identical(reorder, NA) || identical(reorder, FALSE)) {
724
-            do_reorder = FALSE
725
-        }
726
-        if(identical(reorder, TRUE)) {
727
-            do_reorder = TRUE
728
-            reorder = colMeans(mat, na.rm = TRUE)
729
-        }
730
-
731
-        if(do_reorder) {
732
-            if(length(reorder) != ncol(mat)) {
733
-                stop("weight of reordering should have same length as number of columns.\n")
734
-            }
735
-            object@column_dend = reorder(object@column_dend, reorder)
736
-            column_order = order.dendrogram(object@column_dend)
737
-        }
738
-    } else {
739
-        column_order = order
740
-    }
741
-
742
-    # re-order
743
-    object@column_order = column_order
744
-
745
-    if(ncol(mat) != length(column_order)) {
746
-        stop("Number of columns in the matrix are not the same as the length of\nthe cluster or the column order.")
747
-    }
748
-
749
-    return(object)
750
-})
751
-
752 725
 
753 726
 # == title
754 727
 # Make cluster on rows
... ...
@@ -773,57 +746,94 @@ setMethod(f = "make_row_cluster",
773 746
     signature = "Heatmap",
774 747
     definition = function(object) {
775 748
 
749
+    make_cluster(object, "row")
750
+})
751
+
752
+setMethod(f = "make_column_cluster",
753
+    signature = "Heatmap",
754
+    definition = function(object) {
755
+
756
+    make_cluster(object, "column")
757
+})
758
+
759
+make_cluster = function(object, which = c("row", "column")) {
760
+
761
+    which = match.arg(which)[1]
762
+
763
+    verbose = object@heatmap_param$verbose
764
+
776 765
     if(ht_global_opt("fast_hclust")) {
777 766
         hclust = fastcluster::hclust
767
+        if(verbose) qqcat("apply hclust by fastcluster::hclust\n")
778 768
     } else {
779 769
         hclust = stats::hclust
780 770
     }
781 771
 
782 772
     mat = object@matrix
783
-    distance = object@row_dend_param$distance
784
-    method = object@row_dend_param$method
785
-    order = object@row_order  # pre-defined row order
786
-    km = object@matrix_param$km
787
-    km_title = object@matrix_param$km_title
788
-    split = object@matrix_param$split
789
-    reorder = object@row_dend_param$reorder
773
+    distance = slot(object, paste0(which, "_dend_param"))$distance
774
+    method = slot(object, paste0(which, "_dend_param"))$method
775
+    order = slot(object, paste0(which, "_order"))  # pre-defined row order
776
+    km = getElement(object@matrix_param, paste0(which, "_km"))
777
+    split = getElement(object@matrix_param, paste0(which, "_split"))
778
+    reorder = slot(object, paste0(which, "_dend_param"))$reorder
779
+    cluster = slot(object, paste0(which, "_dend_param"))$cluster
780
+    gap = getElement(object@matrix_param, paste0(which, "_gap"))
790 781
 
791
-    if(object@row_dend_param$cluster) {
782
+    dend_param = slot(object, paste0(which, "_dend_param"))
783
+    dend_list = slot(object, paste0(which, "_dend_list"))
784
+    dend_slice = slot(object, paste0(which, "_dend_slice"))
785
+    order_list = slot(object, paste0(which, "_order_list"))
786
+    order = slot(object, paste0(which, "_order"))
787
+
788
+    names_param = slot(object, paste0(which, "_names_param"))
789
+
790
+    if(cluster) {
792 791
 
793 792
         if(is.numeric(split) && length(split) == 1) {
794
-            if(is.null(object@row_dend_param$obj)) {
795
-                object@row_dend_param$obj = hclust(get_dist(mat, distance), method = method)
793
+            if(is.null(dend_param$obj)) {
794
+                if(verbose) qqcat("split @{which}s by cutree, apply hclust on the entire @{which}s\n")
795
+                if(which == "row") {
796
+                    dend_param$obj = hclust(get_dist(mat, distance), method = method)
797
+                } else {
798
+                    dend_param$obj = hclust(get_dist(t(mat), distance), method = method)
799
+                }
796 800
             }
797 801
         }
798 802
 
799
-        if(!is.null(object@row_dend_param$obj)) {
803
+        if(!is.null(dend_param$obj)) {
800 804
             if(km > 1) {
801
-                stop("You can not make k-means clustering since you have already specified a clustering object.")
805
+                stop("You can not make k-means partition since you have already specified a clustering object.")
802 806
             }
803 807
 
804
-            if(inherits(object@row_dend_param$obj, "hclust")) {
805
-                object@row_dend_param$obj = as.dendrogram(object@row_dend_param$obj)
808
+            if(inherits(dend_param$obj, "hclust")) {
809
+                dend_param$obj = as.dendrogram(dend_param$obj)
810
+                if(verbose) qqcat("convert hclust object to dendrogram object\n")
806 811
             }
807 812
 
808 813
             if(is.null(split)) {
809
-                object@row_dend_list = list(object@row_dend_param$obj)
810
-                object@row_order_list = list(get_dend_order(object@row_dend_param$obj))
814
+                dend_list = list(dend_param$obj)
815
+                order_list = list(get_dend_order(dend_param$obj))
816
+                if(verbose) qqcat("since you provided a clustering object and @{which}_split is null, the entrie clustering object is taken as an one-element list.\n")
811 817
             } else {
812 818
                 if(length(split) > 1 || !is.numeric(split)) {
813
-                    stop("Since you specified a clustering object, you can only split rows by providing a number (number of row slices.")
819
+                    stop(qq("Since you specified a clustering object, you can only split @{which}s by providing a number (number of @{which} slices)."))
814 820
                 }
815 821
                 if(split < 2) {
816 822
                     stop("Here `split` should be equal or larger than 2.")
817 823
                 }
818 824
                 
819
-                object@row_dend_list = cut_dendrogram(object@row_dend_param$obj, split)
820
-                sth = tapply(order.dendrogram(object@row_dend_param$obj), 
821
-                    rep(seq_along(object@row_dend_list), times = sapply(object@row_dend_list, nobs)), 
825
+                ct = cut_dendrogram(dend_param$obj, split)
826
+                dend_list = ct$lower
827
+                dend_slice = ct$upper
828
+                sth = tapply(order.dendrogram(dend_param$obj), 
829
+                    rep(seq_along(dend_list), times = sapply(dend_list, nobs)), 
822 830
                     function(x) x)
823 831
                 attributes(sth) = NULL
824
-                object@row_order_list = sth
832
+                order_list = sth
833
+                if(verbose) qqcat("cut @{which} dendrogram into @{split} slices.\n")
825 834
             }
826 835
 
836
+            ### do reordering if specified
827 837
             if(identical(reorder, NULL)) {
828 838
                 if(is.numeric(mat)) {
829 839
                     reorder = TRUE
... ...
@@ -838,70 +848,141 @@ setMethod(f = "make_row_cluster",
838 848
             }
839 849
             if(identical(reorder, TRUE)) {
840 850
                 do_reorder = TRUE
841
-                reorder = -rowMeans(mat, na.rm = TRUE)
851
+                if(which == "row") {
852
+                    reorder = -rowMeans(mat, na.rm = TRUE)
853
+                } else {
854
+                    reorder = -colMeans(mat, na.rm = TRUE)
855
+                }
842 856
             }
843 857
 
844 858
             if(do_reorder) {
845 859
 
846
-                if(length(reorder) != nrow(mat)) {
847
-                    stop("weight of reordering should have same length as number of rows.\n")
860
+                if(which == "row") {
861
+                    if(length(reorder) != nrow(mat)) {
862
+                        stop("weight of reordering should have same length as number of rows.\n")
863
+                    }
864
+                } else {
865
+                    if(length(reorder) != ncol(mat)) {
866
+                        stop("weight of reordering should have same length as number of columns\n")
867
+                    }
868
+                }
869
+                
870
+                for(i in seq_along(dend_list)) {
871
+                    if(length(order_list[[i]]) > 1) {
872
+                        sub_ind = sort(order_list[[i]])
873
+                        dend_list[[i]] = reorder(dend_list[[i]], reorder[sub_ind])
874
+                        # the order of object@row_dend_list[[i]] is the order corresponding to the big dendrogram
875
+                        order_list[[i]] = order.dendrogram(dend_list[[i]])
876
+                    }
848 877
                 }
849
-                row_order_list = object@row_order_list
850
-                row_dend_list = object@row_dend_list
851
-                o_row_order_list = row_order_list
852
-                for(i in seq_along(row_dend_list)) {
853
-                    if(length(row_order_list[[i]]) > 1) {
854
-                        sub_ind = which(seq_len(nrow(mat)) %in% o_row_order_list[[i]])
855
-                        object@row_dend_list[[i]] = reorder(object@row_dend_list[[i]], reorder[sub_ind])
856
-                        # object@row_order_list[[i]] = sub_ind[ order(order.dendrogram(object@row_dend_list[[i]])) ]
857
-                        object@row_order_list[[i]] = order.dendrogram(object@row_dend_list[[i]])
878
+            }
879
+
880
+            dend_list = lapply(dend_list, adjust_dend_by_x)
881
+
882
+            slot(object, paste0(which, "_order")) = unlist(order_list)
883
+            slot(object, paste0(which, "_order_list")) = order_list
884
+            slot(object, paste0(which, "_dend_list")) = dend_list
885
+            slot(object, paste0(which, "_dend_param")) = dend_param
886
+            slot(object, paste0(which, "_dend_slice")) = dend_slice
887
+            split = data.frame(rep(seq_along(order_list), times = sapply(order_list, length)))
888
+            object@matrix_param[[ paste0(which, "_split") ]] = split
889
+
890
+            # adjust row_names_param$gp if the length of some elements is the same as row slices
891
+            for(i in seq_along(names_param$gp)) {
892
+                if(length(names_param$gp[[i]]) == length(order_list)) {
893
+                    gp_temp = NULL
894
+                    for(j in seq_along(order_list)) {
895
+                        gp_temp[ order_list[[j]] ] = names_param$gp[[i]][j]
858 896
                     }
897
+                    names_param$gp[[i]] = gp_temp
859 898
                 }
860 899
             }
900
+            if(!is.null(names_param$anno)) {
901
+                names_param$anno@var_env$gp = names_param$gp
902
+            }
903
+            slot(object, paste0(which, "_names_param")) = names_param
904
+
905
+            n_slice = length(order_list)
906
+            if(length(gap) == 1) {
907
+                gap = rep(gap, n_slice)
908
+            } else if(length(gap) == n_slice - 1) {
909
+                gap = unit.c(gap, unit(0, "mm"))
910
+            } else if(length(gap) != n_slice) {
911
+                stop(qq("Length of `gap` should be 1 or number of @{which} slices."))
912
+            }
913
+            object@matrix_param[[ paste0(which, "_gap") ]] = gap# adjust title
914
+            
915
+            title = slot(object, paste0(which, "_title"))
916
+            if(!is.null(split)) {
917
+                if(length(title) == 0 && !is.null(title)) { ## default title
918
+                    title = apply(unique(split), 1, paste, collapse = ",")
919
+                } else if(length(title) == 1) {
920
+                    if(grepl("%s", title)) {
921
+                        title = apply(unique(split), 1, function(x) {
922
+                            lt = lapply(x, function(x) x)
923
+                            lt$fmt = title
924
+                            do.call(sprintf, lt)
925
+                        })
926
+                    }
927
+                }
928
+            }
929
+            slot(object, paste0(which, "_title")) = title
930
+
861 931
             return(object)
862 932
         }
863 933
 
864
-        row_order = seq_len(nrow(mat))
865 934
     } else {
866
-        row_order = order
935
+        if(verbose) qqcat("no clustering is applied/exists on @{which}s\n")
867 936
     }
868
-
937
+    
938
+    if(verbose) qq("clustering object is not pre-defined, clustering is applied to each @{which} slice\n")
869 939
     # make k-means clustering to add a split column
870 940
     if(km > 1 && is.numeric(mat)) {
871
-        km.fit = kmeans(mat, centers = km)
872
-        cluster = km.fit$cluster
873
-        meanmat = lapply(unique(cluster), function(i) {
874
-            colMeans(mat[cluster == i, , drop = FALSE])
875
-        })
941
+        if(which == "row") {
942
+            km.fit = kmeans(mat, centers = km)
943
+            cl = km.fit$cluster
944
+            meanmat = lapply(unique(cl), function(i) {
945
+                colMeans(mat[cl == i, , drop = FALSE])
946
+            })
947
+        } else {
948
+            km.fit = kmeans(t(mat), centers = km)
949
+            cl = km.fit$cluster
950
+            meanmat = lapply(unique(cl), function(i) {
951
+                rowMeans(mat[, cl == i, drop = FALSE])
952
+            })
953
+        }
954
+        
876 955
         meanmat = as.matrix(as.data.frame(meanmat))
877 956
         hc = hclust(dist(t(meanmat)))
878 957
         weight = colMeans(meanmat)
879 958
         hc = as.hclust(reorder(as.dendrogram(hc), -weight))
880
-        cluster2 = numeric(length(cluster))
959
+        cl2 = numeric(length(cl))
881 960
         for(i in seq_along(hc$order)) {
882
-            cluster2[cluster == hc$order[i]] = i
961
+            cl2[cl == hc$order[i]] = i
883 962
         }
884
-        cluster2 = factor(paste0("cluster", cluster2), levels = paste0("cluster", seq_along(hc$order)))
885
-        cluster2 = factor(sprintf(km_title, cluster2), levels = sprintf(km_title, seq_along(hc$order)))
963
+        cl2 = factor(cl2, levels = seq_along(hc$order))
886 964
 
887 965
         if(is.null(split)) {
888
-            split = data.frame(cluster2)
966
+            split = data.frame(cl2)
889 967
         } else if(is.matrix(split)) {
890 968
             split = as.data.frame(split)
891
-            split = cbind(cluster2, split)
969
+            split = cbind(cl2, split)
892 970
         } else if(is.null(ncol(split))) {
893
-            split = data.frame(cluster2, split)
971
+            split = data.frame(cl2, split)
894 972
         } else {
895
-            split = cbind(cluster2, split)
973
+            split = cbind(cl2, split)
896 974
         }
975
+        if(verbose) qqcat("apply k-means (@{km} groups) on @{which}s, append to the `split` data frame\n")
897 976
             
898 977
     }
899 978
 
900 979
     # split the original order into a list according to split
901
-    row_order_list = list()
980
+    order_list = list()
902 981
     if(is.null(split)) {
903
-        row_order_list[[1]] = row_order
982
+        order_list[[1]] = order
904 983
     } else {
984
+
985
+        if(verbose) qqcat("process `split` data frame\n")
905 986
         if(is.null(ncol(split))) split = data.frame(split)
906 987
         if(is.matrix(split)) split = as.data.frame(split)
907 988
 
... ...
@@ -916,53 +997,58 @@ setMethod(f = "make_row_cluster",
916 997
             }
917 998
         }
918 999
 
919
-        split_name = NULL
920
-        combined_name_fun = object@row_title_param$combined_name_fun
921
-        if(!is.null(combined_name_fun)) {
922
-            split_name = apply(as.matrix(split), 1, combined_name_fun)
923
-        } else {
924
-            split_name = apply(as.matrix(split), 1, paste, collapse = "\n")
925
-        }
926
-
927
-        row_order2 = do.call("order", split)
928
-        row_level = unique(split_name[row_order2])
929
-        for(k in seq_along(row_level)) {
930
-            l = split_name == row_level[k]
931
-            row_order_list[[k]] = intersect(row_order, which(l))
932
-        }
1000
+        split_name = apply(as.matrix(split), 1, paste, collapse = "\n")
933 1001
 
934
-        object@row_order_list = row_order_list
935
-
936
-        if(!is.null(combined_name_fun)) {
937
-            object@row_title = row_level
1002
+        order2 = do.call("order", split)
1003
+        level = unique(split_name[order2])
1004
+        for(k in seq_along(level)) {
1005
+            l = split_name == level[k]
1006
+            order_list[[k]] = intersect(order, which(l))
938 1007
         }
1008
+        names(order_list) = level
939 1009
     }
940
-    o_row_order_list = row_order_list
1010
+
941 1011
     # make dend in each slice
942
-    if(object@row_dend_param$cluster) {
943
-        row_dend_list = rep(list(NULL), length(row_order_list))
944
-        for(i in seq_along(row_order_list)) {
945
-            submat = mat[ row_order_list[[i]], , drop = FALSE]
946
-            if(nrow(submat) > 1) {
947
-                if(!is.null(object@row_dend_param$fun)) {
948
-                    row_dend_list[[i]] = object@row_dend_param$fun(mat)
949
-                    row_order_list[[i]] = row_order_list[[i]][ get_dend_order(row_dend_list[[i]]) ]
1012
+    if(cluster) {
1013
+        if(verbose) qqcat("apply clustering on each @{cluster} slice (@{length(order_list)} slices)\n")
1014
+        dend_list = rep(list(NULL), length(order_list))
1015
+        for(i in seq_along(order_list)) {
1016
+            if(which == "row") {
1017
+                submat = mat[ order_list[[i]], , drop = FALSE]
1018
+            } else {
1019
+                submat = mat[, order_list[[i]], drop = FALSE]
1020
+            }
1021
+            nd = 0
1022
+            if(which == "row") nd = nrow(submat) else nd = ncol(submat)
1023
+            if(nd > 1) {
1024
+                if(!is.null(dend_param$fun)) {
1025
+                    if(which == "row") {
1026
+                        dend_list[[i]] = dend_param$fun(submat)
1027
+                    } else {
1028
+                        dend_list[[i]] = dend_param$fun(t(submat))
1029
+                    }
1030
+                    order_list[[i]] = order_list[[i]][ get_dend_order(dend_list[[i]]) ]
950 1031
                 } else {
951
-                    #if(is.numeric(mat)) {
952
-                        row_dend_list[[i]] = hclust(get_dist(submat, distance), method = method)
953
-                        row_order_list[[i]] = row_order_list[[i]][ get_dend_order(row_dend_list[[i]]) ]
1032
+
1033
+                        if(which == "row") {
1034
+                            dend_list[[i]] = hclust(get_dist(submat, distance), method = method)
1035
+                        } else {
1036
+                            dend_list[[i]] = hclust(get_dist(t(submat), distance), method = method)
1037
+                        }
1038
+                        order_list[[i]] = order_list[[i]][ get_dend_order(dend_list[[i]]) ]
954 1039
                     #}
955 1040
                 }
956 1041
             } else {
957
-                #row_dend_list[[i]] = NULL
958
-                row_order_list[[i]] = row_order_list[[i]][1]
1042
+                # a dendrogram with one leaf
1043
+                dend_list[[i]] = structure(1, members = 1, height = 0, leaf = TRUE, class = "dendrogram")
1044
+                order_list[[i]] = order_list[[i]][1]
959 1045
             }
960 1046
         }
961
-        object@row_dend_list = row_dend_list
1047
+        names(dend_list) = names(order_list)
962 1048
 
963
-        for(i in seq_along(object@row_dend_list)) {
964
-            if(inherits(object@row_dend_list[[i]], "hclust")) {
965
-                object@row_dend_list[[i]] = as.dendrogram(object@row_dend_list[[i]])
1049
+        for(i in seq_along(dend_list)) {
1050
+            if(inherits(dend_list[[i]], "hclust")) {
1051
+                dend_list[[i]] = as.dendrogram(dend_list[[i]])
966 1052
             }
967 1053
         }
968 1054
 
... ...
@@ -980,47 +1066,108 @@ setMethod(f = "make_row_cluster",
980 1066
         }
981 1067
         if(identical(reorder, TRUE)) {
982 1068
             do_reorder = TRUE
983
-            reorder = -rowMeans(mat, na.rm = TRUE)
1069
+            if(which == "row") {
1070
+                reorder = -rowMeans(mat, na.rm = TRUE)
1071
+            } else {
1072
+                reorder = -colMeans(mat, na.rm = TRUE)
1073
+            }
984 1074
         }
985 1075
 
986 1076
         if(do_reorder) {
987 1077
 
988
-            if(length(reorder) != nrow(mat)) {
989
-                stop("weight of reordering should have same length as number of rows.\n")
1078
+            if(which == "row") {
1079
+                if(length(reorder) != nrow(mat)) {
1080
+                    stop("weight of reordering should have same length as number of rows\n")
1081
+                }
1082
+            } else {
1083
+                if(length(reorder) != ncol(mat)) {
1084
+                    stop("weight of reordering should have same length as number of columns\n")
1085
+                }
990 1086
             }
991
-            for(i in seq_along(row_dend_list)) {
992
-                if(length(row_order_list[[i]]) > 1) {
993
-                    sub_ind = which(seq_len(nrow(mat)) %in% o_row_order_list[[i]])
994
-                    object@row_dend_list[[i]] = reorder(object@row_dend_list[[i]], reorder[sub_ind])
995
-                    row_order_list[[i]] = sub_ind[ order.dendrogram(object@row_dend_list[[i]]) ]
1087
+            for(i in seq_along(dend_list)) {
1088
+                if(length(order_list[[i]]) > 1) {
1089
+                    sub_ind = sort(order_list[[i]])
1090
+                    dend_list[[i]] = reorder(dend_list[[i]], reorder[sub_ind])
1091
+                    order_list[[i]] = sub_ind[ order.dendrogram(dend_list[[i]]) ]
996 1092
                 }
997 1093
             }
1094
+            if(verbose) qqcat("reorder dendrograms in each @{which} slice\n")
998 1095
         }
999
-    }
1000 1096
 
1001
-    
1097
+        if(length(order_list) > 1) {
1098
+            if(which == "row") {
1099
+                slice_mean = sapply(order_list, function(ind) colMeans(mat[ind, , drop = FALSE]))
1100
+            } else {
1101
+                slice_mean = sapply(order_list, function(ind) rowMeans(mat[, ind, drop = FALSE]))
1102
+            }
1103
+            dend_slice = as.dendrogram(hclust(dist(t(slice_mean))))
1104
+            if(verbose) qqcat("perform clustering on mean of @{which} slices\n")
1105
+        }
1106
+    }
1002 1107
 
1003
-    object@row_order_list = row_order_list
1004
-    object@matrix_param$split = split
1108
+    dend_list = lapply(dend_list, adjust_dend_by_x)
1005 1109
 
1110
+    slot(object, paste0(which, "_order")) = unlist(order_list)
1111
+    slot(object, paste0(which, "_order_list")) = order_list
1112
+    slot(object, paste0(which, "_dend_list")) = dend_list
1113
+    slot(object, paste0(which, "_dend_param")) = dend_param
1114
+    slot(object, paste0(which, "_dend_slice")) = dend_slice
1115
+    object@matrix_param[[ paste0(which, "_split") ]] = split
1006 1116
 
1007
-    if(nrow(mat) != length(unlist(row_order_list))) {
1008
-        stop("Number of rows in the matrix are not the same as the length of\nthe cluster or the row orders.")
1117
+    if(which == "row") {
1118
+        if(nrow(mat) != length(order)) {
1119
+            stop(qq("Number of rows in the matrix are not the same as the length of the cluster or the @{which} orders."))
1120
+        }
1121
+    } else {
1122
+        if(ncol(mat) != length(order)) {
1123
+            stop(qq("Number of columns in the matrix are not the same as the length of the cluster or the @{which} orders."))
1124
+        }
1009 1125
     }
1010 1126
 
1011
-    # adjust row_names_param$gp if the length of some elements is the same as row slices
1012
-    for(i in seq_along(object@row_names_param$gp)) {
1013
-        if(length(object@row_names_param$gp[[i]]) == length(object@row_order_list)) {
1127
+    # adjust names_param$gp if the length of some elements is the same as slices
1128
+    for(i in seq_along(names_param$gp)) {
1129
+        if(length(names_param$gp[[i]]) == length(order_list)) {
1014 1130
             gp_temp = NULL
1015
-            for(j in seq_along(object@row_order_list)) {
1016
-                gp_temp[ object@row_order_list[[j]] ] = object@row_names_param$gp[[i]][j]
1131
+            for(j in seq_along(order_list)) {
1132
+                gp_temp[ order_list[[j]] ] = names_param$gp[[i]][j]
1017 1133
             }
1018
-            object@row_names_param$gp[[i]] = gp_temp
1134
+            names_param$gp[[i]] = gp_temp   
1019 1135
         }
1020 1136
     }
1137
+    if(!is.null(names_param$anno)) {
1138
+        names_param$anno@var_env$gp = names_param$gp
1139
+    }
1140
+    slot(object, paste0(which, "_names_param")) = names_param
1141
+
1142
+    n_slice = length(order_list)
1143
+    if(length(gap) == 1) {
1144
+        gap = rep(gap, n_slice)
1145
+    } else if(length(gap) == n_slice - 1) {
1146
+        gap = unit.c(gap, unit(0, "mm"))
1147
+    } else if(length(gap) != n_slice) {
1148
+        stop(qq("Length of `gap` should be 1 or number of @{which} slices."))
1149
+    }
1150
+    object@matrix_param[[ paste0(which, "_gap") ]] = gap
1151
+    
1152
+    # adjust title
1153
+    title = slot(object, paste0(which, "_title"))
1154
+    if(!is.null(split)) {
1155
+        if(length(title) == 0 && !is.null(title)) { ## default title
1156
+            title = apply(unique(split), 1, paste, collapse = ",")
1157
+        } else if(length(title) == 1) {
1158
+            if(grepl("%s", title)) {
1159
+                title = apply(unique(split), 1, function(x) {
1160
+                    lt = lapply(x, function(x) x)
1161
+                    lt$fmt = title