... | ... |
@@ -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 |