Browse code

update

Zuguang Gu authored on 09/10/2018 20:28:04
Showing8 changed files

... ...
@@ -2653,7 +2653,9 @@ row_anno_link = function(...) {
2653 2653
 	anno_link(..., which = "row")
2654 2654
 }
2655 2655
 
2656
-anno_summarize = function(which = c("column", "row"),
2656
+# only allow for one-column/one-row heamtap
2657
+# discrete: barplot; continuous: boxplot (maybe also barplot, e.g. pct overlap)
2658
+anno_summary = function(which = c("column", "row"), bar_width = 0.8,
2657 2659
 	width = NULL, height = NULL, border = FALSE, ...) {
2658 2660
 
2659 2661
 	if(is.null(.ENV$current_annotation_which)) {
... ...
@@ -2662,15 +2664,53 @@ anno_summarize = function(which = c("column", "row"),
2662 2664
 		which = .ENV$current_annotation_which
2663 2665
 	}
2664 2666
 
2665
-	if(which == "column") {
2666
-		stop_wrap("`anno_summarize()` is only allowed as a column annotation.")
2667
-	}
2668
-
2669 2667
 	anno_size = anno_width_and_height(which, width, height, unit(2, "cm"))
2670 2668
 
2671 2669
 	# get variables fron oncoPrint() function
2672 2670
 	pf = parent.frame()
2673 2671
 	# find where the heatmap object is.
2672
+	row_fun = function(index) {
2673
+
2674
+	}
2675
+	column_fun = function(index) {
2676
+		ht = get("object", envir = parent.frame(7))
2677
+		mat = ht@matrix
2678
+		cm = ht@matrix_color_mapping
2679
+		order_list = ht@row_order_list
2680
+		ng = length(order_list)
2681
+
2682
+		if(cm@type == "discrete") {
2683
+			tl = lapply(order_list, function(od) table(mat[od, 1]))
2684
+			tl = lapply(tl, function(x) x/sum(x))
2685
+			pushViewport(viewport(xscale = c(0.5, ng+0.5), yscale = c(0, 1)))
2686
+			for(i in 1:ng) {
2687
+				x = i
2688
+				y = cumsum(tl[[i]])
2689
+				grid.rect(x, y, w = bar_width, just = "top", gp = gpar(fill = map_to_colors(cm, names(y))))
2690
+			}
2691
+			# axis
2692
+			popViewport()
2693
+		}
2694
+
2695
+	}
2696
+
2697
+	if(which == "row") {
2698
+		fun = row_fun
2699
+	} else if(which == "column") {
2700
+		fun = column_fun
2701
+	}
2674 2702
 	
2703
+	anno = AnnotationFunction(
2704
+		fun = fun,
2705
+		fun_name = "anno_summary",
2706
+		which = which,
2707
+		width = width,
2708
+		height = height,
2709
+		n = 1,
2710
+		show_name = FALSE
2711
+	)
2712
+
2713
+	anno@subsetable = FALSE
2714
+	return(anno)
2675 2715
 }
2676 2716
 
... ...
@@ -1244,6 +1244,9 @@ make_cluster = function(object, which = c("row", "column")) {
1244 1244
             } else {
1245 1245
                 slice_mean = sapply(order_list, function(ind) rowMeans(mat[, ind, drop = FALSE]))
1246 1246
             }
1247
+            if(!is.matrix(slice_mean)) {
1248
+                slice_mean = matrix(slice_mean, nrow = 1)
1249
+            }
1247 1250
             dend_slice = as.dendrogram(hclust(dist(t(slice_mean))))
1248 1251
             if(verbose) qqcat("perform clustering on mean of @{which} slices\n")
1249 1252
         }
... ...
@@ -370,9 +370,9 @@ setMethod(f = "draw_title",
370 370
             grid.rect(gp = gpar(fill = gp$fill))
371 371
         }
372 372
         if(side == "left") {
373
-            grid.text(title, x = unit(1, "npc") - TITLE_PADDING, rot = rot, just = just, gp = gp)
373
+            grid.text(title, x = unit(1, "npc") - ht_opt$TITLE_PADDING, rot = rot, just = just, gp = gp)
374 374
         } else {
375
-            grid.text(title, x = TITLE_PADDING, rot = rot, just = just, gp = gp)
375
+            grid.text(title, x = ht_opt$TITLE_PADDING, rot = rot, just = just, gp = gp)
376 376
         }
377 377
         upViewport()
378 378
     } else {
... ...
@@ -381,9 +381,9 @@ setMethod(f = "draw_title",
381 381
             grid.rect(gp = gpar(fill = gp$fill))
382 382
         }
383 383
         if(side == "top") {
384
-            grid.text(title, y = TITLE_PADDING, rot = rot, just = just, gp = gp)
384
+            grid.text(title, y = ht_opt$TITLE_PADDING, rot = rot, just = just, gp = gp)
385 385
         } else {
386
-            grid.text(title, y = unit(1, "npc") - TITLE_PADDING, rot = rot, just = just, gp = gp)
386
+            grid.text(title, y = unit(1, "npc") - ht_opt$TITLE_PADDING, rot = rot, just = just, gp = gp)
387 387
         }
388 388
         upViewport()
389 389
     }
... ...
@@ -308,7 +308,7 @@ setMethod(f = "draw",
308 308
     ht_gap = gap, 
309 309
 
310 310
     main_heatmap = which(sapply(object@ht_list, inherits, "Heatmap"))[1],
311
-    padding = NULL,
311
+    padding = GLOBAL_PADDING,
312 312
     adjust_annotation_extension = TRUE,
313 313
     
314 314
     auto_adjust = TRUE,
... ...
@@ -479,12 +479,6 @@ setMethod(f = "draw",
479 479
         heatmap_body_width = heatmap_body_width
480 480
     )
481 481
 
482
-    # calculate proper padding
483
-    if(is.null(padding)) {
484
-        padding = GLOBAL_PADDING
485
-        object@ht_list_param$padding = padding
486
-    }
487
-
488 482
     layout = grid.layout(nrow = length(HEATMAP_LIST_LAYOUT_COLUMN_COMPONENT), 
489 483
         ncol = length(HEATMAP_LAYOUT_ROW_COMPONENT), 
490 484
         widths = component_width(object), 
... ...
@@ -84,7 +84,7 @@ setMethod(f = "make_layout",
84 84
     ht_gap = unit(2, "mm"), 
85 85
 
86 86
     main_heatmap = which(sapply(object@ht_list, inherits, "Heatmap"))[1],
87
-    padding = NULL,
87
+    padding = GLOBAL_PADDING,
88 88
 
89 89
     auto_adjust = TRUE,
90 90
     row_dend_side = c("original", "left", "right"),
... ...
@@ -125,6 +125,20 @@ setMethod(f = "make_layout",
125 125
         return(object)
126 126
     }
127 127
 
128
+    # the size of the plotting page
129
+    # if current viewport is top viewport
130
+    current_vp = current.viewport()$name
131
+    if(current_vp == "ROOT") {
132
+        object@layout$page_size = unit(dev.size("cm"), "cm")
133
+    } else {
134
+        grid::upViewport()
135
+        object@layout$page_size = unit.c(convertWidth(unit(1, "npc"), "mm"),
136
+                                         convertHeight(unit(1, "npc"), "mm"))
137
+        grid::downViewport()
138
+
139
+    }
140
+    object@ht_list_param$padding = padding
141
+
128 142
     n_ht = length(object@ht_list)
129 143
     i_main = main_heatmap[1]
130 144
     direction = object@direction
... ...
@@ -634,10 +648,10 @@ setMethod(f = "make_layout",
634 648
     object@column_title_param$side = column_title_side
635 649
     if(length(column_title) > 0) {
636 650
         if(column_title_side == "top") {
637
-            object@layout$layout_column_title_top_height = grobHeight(textGrob(column_title, gp = column_title_gp)) + TITLE_PADDING*2
651
+            object@layout$layout_column_title_top_height = grobHeight(textGrob(column_title, gp = column_title_gp)) + ht_opt$TITLE_PADDING*2
638 652
             object@layout$layout_index = rbind(object@layout$layout_index, column_title_top = heatmap_list_layout_index("column_title_top"))
639 653
         } else {
640
-            object@layout$layout_column_title_bottom_height = grobHeight(textGrob(column_title, gp = column_title_gp)) + TITLE_PADDING*2
654
+            object@layout$layout_column_title_bottom_height = grobHeight(textGrob(column_title, gp = column_title_gp)) + ht_opt$TITLE_PADDING*2
641 655
             object@layout$layout_index = rbind(object@layout$layout_index, column_title_bottom = heatmap_list_layout_index("column_title_bottom"))
642 656
         }
643 657
         object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) draw_title(object, which = "column"))
... ...
@@ -660,10 +674,10 @@ setMethod(f = "make_layout",
660 674
     object@row_title_param$side = row_title_side
661 675
     if(length(row_title) > 0) {
662 676
         if(row_title_side == "left") {
663
-            object@layout$layout_row_title_left_width = grobHeight(textGrob(row_title, gp = row_title_gp)) + TITLE_PADDING*2
677
+            object@layout$layout_row_title_left_width = grobHeight(textGrob(row_title, gp = row_title_gp)) + ht_opt$TITLE_PADDING*2
664 678
             object@layout$layout_index = rbind(object@layout$layout_index, row_title_left = heatmap_list_layout_index("row_title_left"))
665 679
         } else {
666
-            object@layout$layout_row_title_right_width = grobHeight(textGrob(row_title, gp = row_title_gp)) + TITLE_PADDING*2
680
+            object@layout$layout_row_title_right_width = grobHeight(textGrob(row_title, gp = row_title_gp)) + ht_opt$TITLE_PADDING*2
667 681
             object@layout$layout_index = rbind(object@layout$layout_index, row_title_right = heatmap_list_layout_index("row_title_right"))
668 682
         }
669 683
         object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) draw_title(object, which = "row"))
... ...
@@ -717,7 +731,10 @@ setMethod(f = "make_layout",
717 731
             }
718 732
         }
719 733
     }
720
-    if(length(ColorMappingList) == 0 && length(heatmap_legend_list) == 0) {
734
+    if(merge_legends) {
735
+        heatmap_legend_list = c(heatmap_legend_list, annotation_legend_list)
736
+    }
737
+     if(length(ColorMappingList) == 0 && length(heatmap_legend_list) == 0) {
721 738
         show_heatmap_legend = FALSE
722 739
     }
723 740
 
... ...
@@ -738,30 +755,34 @@ setMethod(f = "make_layout",
738 755
     if(show_heatmap_legend) {
739 756
         if(heatmap_legend_side == "top") {
740 757
             object@heatmap_legend_param$padding = unit(c(2, 0, 0, 0), "mm")
741
-            size = heatmap_legend_size(object, legend_list = heatmap_legend_list)
758
+            size = heatmap_legend_size(object, legend_list = heatmap_legend_list, max_width = calc_legends_max_width(object))
742 759
             object@heatmap_legend_param$size = size
743 760
             object@layout$layout_heatmap_legend_top_height = size[2]
744 761
             object@layout$layout_index = rbind(object@layout$layout_index, heatmap_legend_top = heatmap_list_layout_index("heatmap_legend_top"))
745 762
         } else if(heatmap_legend_side == "bottom") {
746 763
             object@heatmap_legend_param$padding = unit(c(0, 0, 2, 0), "mm")
747
-            size = heatmap_legend_size(object, legend_list = heatmap_legend_list)
764
+            size = heatmap_legend_size(object, legend_list = heatmap_legend_list, max_width = calc_legends_max_width(object))
748 765
             object@heatmap_legend_param$size = size
749 766
             object@layout$layout_heatmap_legend_bottom_height = size[2]
750 767
             object@layout$layout_index = rbind(object@layout$layout_index, heatmap_legend_bottom = heatmap_list_layout_index("heatmap_legend_bottom"))
751 768
         } else if(heatmap_legend_side == "left") {
752 769
             object@heatmap_legend_param$padding = unit(c(0, 0, 0, 2), "mm")
753
-            size = heatmap_legend_size(object, legend_list = heatmap_legend_list)
770
+            size = heatmap_legend_size(object, legend_list = heatmap_legend_list, max_height = calc_legends_max_height(object))
754 771
             object@heatmap_legend_param$size = size
755 772
             object@layout$layout_heatmap_legend_left_width = size[1]
756 773
             object@layout$layout_index = rbind(object@layout$layout_index, heatmap_legend_left = heatmap_list_layout_index("heatmap_legend_left"))
757 774
         } else if(heatmap_legend_side == "right") {
758 775
             object@heatmap_legend_param$padding = unit(c(0, 2, 0, 0), "mm")
759
-            size = heatmap_legend_size(object, legend_list = heatmap_legend_list)
776
+            size = heatmap_legend_size(object, legend_list = heatmap_legend_list, max_height = calc_legends_max_height(object))
760 777
             object@heatmap_legend_param$size = size
761 778
             object@layout$layout_heatmap_legend_right_width = size[1]
762 779
             object@layout$layout_index = rbind(object@layout$layout_index, heamap_legend_right = heatmap_list_layout_index("heatmap_legend_right"))
763 780
         }
764
-        object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) draw_heatmap_legend(object, legend_list = heatmap_legend_list))
781
+        if(heatmap_legend_side %in% c("top", "bottom")) {
782
+            object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) draw_heatmap_legend(object, legend_list = heatmap_legend_list, max_width = calc_legends_max_width(object)))
783
+        } else {
784
+            object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) draw_heatmap_legend(object, legend_list = heatmap_legend_list, max_height = calc_legends_max_height(object)))
785
+        }
765 786
     } else {
766 787
         object@heatmap_legend_param$size = unit(c(0, 0), "mm")
767 788
     }
... ...
@@ -805,30 +826,34 @@ setMethod(f = "make_layout",
805 826
     if(show_annotation_legend) {
806 827
         if(annotation_legend_side == "top") {
807 828
             object@annotation_legend_param$padding = unit(c(2, 0, 0, 0), "mm")
808
-            size = annotation_legend_size(object, legend_list = annotation_legend_list)
829
+            size = annotation_legend_size(object, legend_list = annotation_legend_list, max_width = calc_legends_max_width(object))
809 830
             object@annotation_legend_param$size = size
810 831
             object@layout$layout_annotation_legend_top_height = size[2]
811 832
             object@layout$layout_index = rbind(object@layout$layout_index, annotation_legend_top = heatmap_list_layout_index("annotation_legend_top"))
812 833
         } else if(annotation_legend_side == "bottom") {
813 834
             object@annotation_legend_param$padding = unit(c(0, 0, 2, 0), "mm")
814
-            size = annotation_legend_size(object, legend_list = annotation_legend_list)
835
+            size = annotation_legend_size(object, legend_list = annotation_legend_list, max_width = calc_legends_max_width(object))
815 836
             object@annotation_legend_param$size = size
816 837
             object@layout$layout_annotation_legend_bottom_height = size[2]
817 838
             object@layout$layout_index = rbind(object@layout$layout_index, annotation_legend_bottom = heatmap_list_layout_index("annotation_legend_bottom"))
818 839
         } else if(annotation_legend_side == "left") {
819 840
             object@annotation_legend_param$padding = unit(c(0, 0, 0, 2), "mm")
820
-            size = annotation_legend_size(object, legend_list = annotation_legend_list)
841
+            size = annotation_legend_size(object, legend_list = annotation_legend_list, max_height = calc_legends_max_height(object))
821 842
             object@annotation_legend_param$size = size
822 843
             object@layout$layout_annotation_legend_left_width = size[1]
823 844
             object@layout$layout_index = rbind(object@layout$layout_index, annotation_legend_left = heatmap_list_layout_index("annotation_legend_left"))
824 845
         } else if(annotation_legend_side == "right") {
825 846
             object@annotation_legend_param$padding = unit(c(0, 2, 0, 0), "mm")
826
-            size = annotation_legend_size(object, legend_list = annotation_legend_list)
847
+            size = annotation_legend_size(object, legend_list = annotation_legend_list, max_height = calc_legends_max_height(object))
827 848
             object@annotation_legend_param$size = size
828 849
             object@layout$layout_annotation_legend_right_width = size[1]
829 850
             object@layout$layout_index = rbind(object@layout$layout_index, annotation_legend_right = heatmap_list_layout_index("annotation_legend_right"))
830 851
         }
831
-        object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) draw_annotation_legend(object, legend_list = annotation_legend_list))
852
+        if(annotation_legend_side %in% c("top", "bottom")) {
853
+            object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) draw_annotation_legend(object, legend_list = annotation_legend_list, max_width = calc_legends_max_width(object)))
854
+        } else {
855
+            object@layout$graphic_fun_list = c(object@layout$graphic_fun_list, function(object) draw_annotation_legend(object, legend_list = annotation_legend_list, max_height = calc_legends_max_height(object)))
856
+        }
832 857
     } else {
833 858
         object@annotation_legend_param$size = unit(c(0, 0), "null")
834 859
     }
... ...
@@ -876,8 +901,19 @@ setMethod(f = "make_layout",
876 901
     return(object)
877 902
 })
878 903
 
904
+calc_legends_max_height = function(object) {
905
+    gh = object@layout$page_size[2]
906
+    h = gh - object@layout$layout_column_title_top_height - object@layout$layout_column_title_bottom_height -
907
+             object@ht_list_param$padding[1] - object@ht_list_param$padding[3]
908
+    convertHeight(h, "mm")
909
+}
879 910
 
880
-
911
+calc_legends_max_width = function(object) {
912
+    gh = object@layout$page_size[1]
913
+    h = gh - object@layout$layout_row_title_right_width - object@layout$layout_row_title_left_width -
914
+             object@ht_list_param$padding[2] - object@ht_list_param$padding[4]
915
+    convertWidth(h, "mm")
916
+}
881 917
 
882 918
 HEATMAP_LIST_LAYOUT_COLUMN_COMPONENT = 1:7
883 919
 names(HEATMAP_LIST_LAYOUT_COLUMN_COMPONENT) = c("annotation_legend_top", "heatmap_legend_top", "column_title_top",
... ...
@@ -401,7 +401,7 @@ draw_legend = function(ColorMappingList, ColorMappingParamList, side = c("right"
401 401
         } else if(side == "top") {
402 402
             draw(pk, y = unit(1, "npc"), just = "top")
403 403
         } else if(side == "bottom") {
404
-            draw(pk, y = unit(1, "npc"), just = "top")
404
+            draw(pk, y = unit(0, "npc"), just = "bottom")
405 405
         }
406 406
     }
407 407
 
... ...
@@ -977,6 +977,8 @@ valid_just = function(just) {
977 977
 			"left" = c("left", "center"),
978 978
 			"right" = c("right", "center"),
979 979
 			"top" = c("center", "top"),
980
+			"bottom" = c("center", "bottom"),
981
+			"top" = c("center", "top"),
980 982
 			c("center", "center"))
981 983
 	}
982 984
 	if(length(just) != 2) {
... ...
@@ -589,3 +589,11 @@ pindex = function(m, i, j) {
589 589
     }
590 590
 }
591 591
 
592
+
593
+unit_with_vp = function(..., vp = current.viewport()$name) {
594
+    u = unit(...)
595
+    attr(u, "viewport") = vp
596
+    return(u)
597
+}
598
+
599
+