Browse code

automatically recognize Jupyter environment

Zuguang Gu authored on 31/05/2022 11:42:14
Showing1 changed files
... ...
@@ -1142,3 +1142,15 @@ setAs("list", "HeatmapList", function(from) {
1142 1142
     }
1143 1143
     ht_list
1144 1144
 })
1145
+
1146
+
1147
+draw_heatmap_in_jupyter = function(ht, ...) {
1148
+    width = getOption("repr.plot.width")
1149
+    height = getOption("repr.plot.height")
1150
+
1151
+    p = grid.grabExpr({ht <- draw(ht, ...)}, width = width, height = height)
1152
+    grid.draw(p)
1153
+
1154
+    invisible(ht)
1155
+}
1156
+
Browse code

column_title_rot can be any degree value

Zuguang Gu authored on 31/05/2022 09:48:27
Showing1 changed files
... ...
@@ -286,10 +286,10 @@ subset_gp = function(gp, i) {
286 286
 
287 287
 
288 288
 get_text_just = function(rot, side) {
289
-    rot = rot %% 360
290
-    if(! rot %in% c(0, 90, 270)) {
291
-        stop_wrap("Only support horizontal or vertical rotations for text.\n")
292
-    }
289
+    rot = rot %% 180
290
+    # if(! rot %in% c(0, 90, 270)) {
291
+    #     stop_wrap("Only support horizontal or vertical rotations for text.\n")
292
+    # }
293 293
     if(side == "left") {
294 294
         if(rot == 0) {
295 295
             return(c(1, 0.5))
... ...
@@ -299,27 +299,27 @@ get_text_just = function(rot, side) {
299 299
             return(c(0.5, 1))
300 300
         }
301 301
     } else if(side == "right") {
302
-        if(rot == 0) {
302
+        if(rot >= 0 && rot < 90) {
303 303
             return(c(0, 0.5))
304 304
         } else if(rot == 90) {
305 305
             return(c(0.5, 1))
306
-        } else if(rot == 270) {
307
-            return(c(0.5, 0))
306
+        } else if(rot > 90 && rot < 180) {
307
+            return(c(0, 0.5))
308 308
         }
309 309
     } else if(side == "top") {
310 310
         if(rot == 0) {
311 311
             return(c(0.5, 0))
312
-        } else if(rot == 90) {
312
+        } else if(rot > 0 && rot <= 90) {
313 313
             return(c(0, 0.5))
314
-        } else if(rot == 270) {
314
+        } else if(rot > 90 && rot <= 180) {
315 315
             return(c(1, 0.5))
316 316
         }
317 317
     } else if(side == "bottom") {
318 318
         if(rot == 0) {
319 319
             return(c(0.5, 1))
320
-        } else if(rot == 90) {
320
+        } else if(rot > 0 && rot <= 90) {
321 321
             return(c(1, 0.5))
322
-        } else if(rot == 270) {
322
+        } else if(rot > 90 && rot <= 180) {
323 323
             return(c(0, 0.5))
324 324
         }
325 325
     }
Browse code

global variables in cell_fun are automatically saved

Zuguang Gu authored on 02/04/2022 15:52:11
Showing1 changed files
... ...
@@ -1142,4 +1142,3 @@ setAs("list", "HeatmapList", function(from) {
1142 1142
     }
1143 1143
     ht_list
1144 1144
 })
1145
-
Browse code

add setAs() to convert a list of heatmap to HeatmapList object

Zuguang Gu authored on 24/03/2022 21:02:54
Showing1 changed files
... ...
@@ -1133,3 +1133,13 @@ get_last_ht = function() {
1133 1133
 
1134 1134
 #     ds
1135 1135
 # }
1136
+
1137
+
1138
+setAs("list", "HeatmapList", function(from) {
1139
+    ht_list = NULL
1140
+    for(i in seq_along(from)) {
1141
+        ht_list = ht_list + from[[i]]
1142
+    }
1143
+    ht_list
1144
+})
1145
+
Browse code

delete wrong character

Zuguang Gu authored on 24/03/2022 20:49:42
Showing1 changed files
... ...
@@ -100,7 +100,7 @@ default_col = function(x, main_matrix = FALSE) {
100 100
             } else {
101 101
                 if(length(unique(x)) >= 100) {
102 102
                     q1 = quantile(x, 0.01, na.rm = TRUE)
103
-                    q2 = quantile(x, 0.99, na.rm = TRUE`)
103
+                    q2 = quantile(x, 0.99, na.rm = TRUE)
104 104
                     if(q1 == q2) {
105 105
                         col_fun = colorRamp2(seq(min(x), max(x), length.out = length(ht_opt$COLOR)), ht_opt$COLOR)
106 106
                     } else if(length(unique(x[x > q1 & x < q2])) == 1) {
Browse code

add na.rm = TRUE in quantile()

Zuguang Gu authored on 23/03/2022 16:30:55
Showing1 changed files
... ...
@@ -87,7 +87,7 @@ default_col = function(x, main_matrix = FALSE) {
87 87
                     cat("This matrix has both negative and positive values, use a color mapping symmetric to zero\n")
88 88
                 }
89 89
                 if(length(unique(x)) >= 100) {
90
-                    q1 = quantile(abs(x), 0.99)
90
+                    q1 = quantile(abs(x), 0.99, na.rm = TRUE)
91 91
                     col_fun = colorRamp2(seq(-q1, q1, length.out = length(ht_opt$COLOR)), ht_opt$COLOR)
92 92
 
93 93
                     if(any(x > q1*3 | x < -q1*3)) {
... ...
@@ -99,8 +99,8 @@ default_col = function(x, main_matrix = FALSE) {
99 99
                 }
100 100
             } else {
101 101
                 if(length(unique(x)) >= 100) {
102
-                    q1 = quantile(x, 0.01)
103
-                    q2 = quantile(x, 0.99)
102
+                    q1 = quantile(x, 0.01, na.rm = TRUE)
103
+                    q2 = quantile(x, 0.99, na.rm = TRUE`)
104 104
                     if(q1 == q2) {
105 105
                         col_fun = colorRamp2(seq(min(x), max(x), length.out = length(ht_opt$COLOR)), ht_opt$COLOR)
106 106
                     } else if(length(unique(x[x > q1 & x < q2])) == 1) {
Browse code

add show_name in anno_empty()

Zuguang Gu authored on 03/02/2022 09:53:48
Showing1 changed files
... ...
@@ -117,7 +117,8 @@ default_col = function(x, main_matrix = FALSE) {
117 117
             }
118 118
         } else {
119 119
             #col_fun = colorRamp2(range(min(x), max(x)), c("white", hsv(runif(1), 1, 1)))
120
-            col_fun = colorRamp2(range(min(x), max(x)), c("white", rand_color(1, luminosity = sample(c("bright", "dark"), 1))))
120
+            rc = rand_color(1, luminosity = sample(c("bright", "dark"), 1))
121
+            col_fun = colorRamp2(range(min(x), max(x)), c("white", rc))
121 122
         }
122 123
         return(col_fun)
123 124
     }
Browse code

recycle_gp(): now consider n = 0

Zuguang Gu authored on 13/11/2021 10:42:20
Showing1 changed files
... ...
@@ -241,7 +241,11 @@ get_dend_order = function(x) {
241 241
 recycle_gp = function(gp, n = 1) {
242 242
     for(i in seq_along(gp)) {
243 243
         x = gp[[i]]
244
-        gp[[i]] = c(rep(x, floor(n/length(x))), x[seq_len(n %% length(x))])
244
+        if(n > 0) {
245
+            gp[[i]] = c(rep(x, floor(n/length(x))), x[seq_len(n %% length(x))])
246
+        } else {
247
+            gp[[i]] = x[1]
248
+        }
245 249
     }
246 250
     return(gp)
247 251
 }
Browse code

add a new COLOR global option

Zuguang Gu authored on 08/11/2021 12:27:29
Showing1 changed files
... ...
@@ -88,31 +88,31 @@ default_col = function(x, main_matrix = FALSE) {
88 88
                 }
89 89
                 if(length(unique(x)) >= 100) {
90 90
                     q1 = quantile(abs(x), 0.99)
91
-                    col_fun = colorRamp2(c(-q1, 0, q1), c("blue", "#EEEEEE", "red"))
91
+                    col_fun = colorRamp2(seq(-q1, q1, length.out = length(ht_opt$COLOR)), ht_opt$COLOR)
92 92
 
93 93
                     if(any(x > q1*3 | x < -q1*3)) {
94 94
                         message_wrap("The automatically generated colors map from the minus and plus 99^th of the absolute values in the matrix. There are outliers in the matrix whose patterns might be hidden by this color mapping. You can manually set the color to `col` argument.\n\nUse `suppressMessages()` to turn off this message.")
95 95
                     }
96 96
                 } else {
97 97
                     q1 = max(abs(x))
98
-                    col_fun = colorRamp2(c(-q1, 0, q1), c("blue", "#EEEEEE", "red"))
98
+                    col_fun = colorRamp2(seq(-q1, q1, length.out = length(ht_opt$COLOR)), ht_opt$COLOR)
99 99
                 }
100 100
             } else {
101 101
                 if(length(unique(x)) >= 100) {
102 102
                     q1 = quantile(x, 0.01)
103 103
                     q2 = quantile(x, 0.99)
104 104
                     if(q1 == q2) {
105
-                        col_fun = colorRamp2(seq(min(x), max(x), length = 3), c("blue", "#EEEEEE", "red"))
105
+                        col_fun = colorRamp2(seq(min(x), max(x), length.out = length(ht_opt$COLOR)), ht_opt$COLOR)
106 106
                     } else if(length(unique(x[x > q1 & x < q2])) == 1) {
107
-                        col_fun = colorRamp2(seq(min(x), max(x), length = 3), c("blue", "#EEEEEE", "red"))
107
+                        col_fun = colorRamp2(seq(min(x), max(x), length.out = length(ht_opt$COLOR)), ht_opt$COLOR)
108 108
                     } else {
109
-                        col_fun = colorRamp2(seq(q1, q2, length = 3), c("blue", "#EEEEEE", "red"))
109
+                        col_fun = colorRamp2(seq(q1, q2, length.out = length(ht_opt$COLOR)), ht_opt$COLOR)
110 110
                         if(any(x > q2 + (q2-q1) | x < q1 - (q2-q1))) {
111 111
                             message_wrap("The automatically generated colors map from the 1^st and 99^th of the values in the matrix. There are outliers in the matrix whose patterns might be hidden by this color mapping. You can manually set the color to `col` argument.\n\nUse `suppressMessages()` to turn off this message.")
112 112
                         }
113 113
                     }
114 114
                 } else {
115
-                    col_fun = colorRamp2(seq(min(x), max(x), length = 3), c("blue", "#EEEEEE", "red"))
115
+                    col_fun = colorRamp2(seq(min(x), max(x), length.out = length(ht_opt$COLOR)), ht_opt$COLOR)
116 116
                 }
117 117
             }
118 118
         } else {
Browse code

proper defaults are updated

Zuguang Gu authored on 18/02/2021 20:53:00
Showing1 changed files
... ...
@@ -1112,6 +1112,10 @@ is.na.expression = function(x) {
1112 1112
     })
1113 1113
 }
1114 1114
 
1115
+get_last_ht = function() {
1116
+    .ENV$last
1117
+}
1118
+
1115 1119
 
1116 1120
 # dev.size = function(units = "in") {
1117 1121
 #     ds = par("din")
Browse code

adjust_dend_by_x(): simplified the representation of units

Zuguang Gu authored on 09/02/2021 19:57:24
Showing1 changed files
... ...
@@ -1112,6 +1112,7 @@ is.na.expression = function(x) {
1112 1112
     })
1113 1113
 }
1114 1114
 
1115
+
1115 1116
 # dev.size = function(units = "in") {
1116 1117
 #     ds = par("din")
1117 1118
 
Browse code

expression is properly processed for discrete legends

Zuguang Gu authored on 09/02/2021 13:53:11
Showing1 changed files
... ...
@@ -1105,6 +1105,12 @@ is_RStudio_current_dev = function() {
1105 1105
     }
1106 1106
 }
1107 1107
 
1108
+is.na.expression = function(x) {
1109
+    n = length(x)
1110
+    sapply(seq_len(n), function(i) {
1111
+        identical(as.character(x[i]), "__NA__")
1112
+    })
1113
+}
1108 1114
 
1109 1115
 # dev.size = function(units = "in") {
1110 1116
 #     ds = par("din")
Browse code

won't generate color matrix when type=='none'

Zuguang Gu authored on 15/12/2020 12:03:14
Showing1 changed files
... ...
@@ -4,6 +4,7 @@ INDEX_ENV = new.env()
4 4
 
5 5
 INDEX_ENV$I_FIGURE = 0
6 6
 INDEX_ENV$I_HEATMAP = 0
7
+INDEX_ENV$I_ONCOPRINT = 0
7 8
 INDEX_ENV$I_ANNOTATION = 0
8 9
 INDEX_ENV$I_ROW_ANNOTATION = 0
9 10
 INDEX_ENV$I_COLOR_MAPPING = 0
Browse code

won't generate color matrix when type=='none'

Zuguang Gu authored on 15/12/2020 12:01:39
Showing1 changed files
... ...
@@ -24,6 +24,14 @@ increase_heatmap_index = function() {
24 24
 	INDEX_ENV$I_HEATMAP = INDEX_ENV$I_HEATMAP + 1
25 25
 }
26 26
 
27
+get_oncoprint_index = function() {
28
+    INDEX_ENV$I_ONCOPRINT
29
+}
30
+
31
+increase_oncoprint_index = function() {
32
+    INDEX_ENV$I_ONCOPRINT = INDEX_ENV$I_ONCOPRINT + 1
33
+}
34
+
27 35
 get_annotation_index = function() {
28 36
 	INDEX_ENV$I_ANNOTATION
29 37
 }
Browse code

fixed typo

Zuguang Gu authored on 10/11/2020 12:10:03
Showing1 changed files
... ...
@@ -1097,14 +1097,14 @@ is_RStudio_current_dev = function() {
1097 1097
 }
1098 1098
 
1099 1099
 
1100
-dev.size = function(units = "in") {
1101
-    ds = par("din")
1100
+# dev.size = function(units = "in") {
1101
+#     ds = par("din")
1102 1102
 
1103
-    if(units == "cm") {
1104
-        ds = ds*2.54
1105
-    } else if(units == "px") {
1106
-        stop("px is not supported.")
1107
-    }
1103
+#     if(units == "cm") {
1104
+#         ds = ds*2.54
1105
+#     } else if(units == "px") {
1106
+#         stop("px is not supported.")
1107
+#     }
1108 1108
 
1109
-    ds
1110
-}
1109
+#     ds
1110
+# }
Browse code

temporary solution for retina display with Rstudio

Zuguang Gu authored on 10/11/2020 10:56:48
Showing1 changed files
... ...
@@ -1095,3 +1095,16 @@ is_RStudio_current_dev = function() {
1095 1095
         }
1096 1096
     }
1097 1097
 }
1098
+
1099
+
1100
+dev.size = function(units = "in") {
1101
+    ds = par("din")
1102
+
1103
+    if(units == "cm") {
1104
+        ds = ds*2.54
1105
+    } else if(units == "px") {
1106
+        stop("px is not supported.")
1107
+    }
1108
+
1109
+    ds
1110
+}
Browse code

finally adjust the space of column title according to ggplot2

Zuguang Gu authored on 30/10/2020 15:10:21
Showing1 changed files
... ...
@@ -239,7 +239,7 @@ recycle_gp = function(gp, n = 1) {
239 239
 
240 240
 check_gp = function(gp) {
241 241
     if(!"lineheight" %in% names(gp)) {
242
-        gp$lineheight = 0.8
242
+        gp$lineheight = 0.9
243 243
     }
244 244
     if(!inherits(gp, "gpar")) {
245 245
         stop_wrap("Graphic parameters should be specified by `gpar()`.")
Browse code

enforce length of annotation_label should be the same as number of annotations

Zuguang Gu authored on 27/10/2020 14:13:38
Showing1 changed files
... ...
@@ -683,7 +683,7 @@ recycle_list = function(x, all_names, default = NULL) {
683 683
         return(lt)
684 684
     }
685 685
 
686
-    stop_wrap("wrong input data type.")
686
+    stop_wrap("Not compatible with the annotations.")
687 687
 
688 688
 }
689 689
 
Browse code

Legend(): add row_gap and column_gap arguments

Zuguang Gu authored on 22/10/2020 10:44:27
Showing1 changed files
... ...
@@ -238,6 +238,9 @@ recycle_gp = function(gp, n = 1) {
238 238
 }
239 239
 
240 240
 check_gp = function(gp) {
241
+    if(!"lineheight" %in% names(gp)) {
242
+        gp$lineheight = 0.8
243
+    }
241 244
     if(!inherits(gp, "gpar")) {
242 245
         stop_wrap("Graphic parameters should be specified by `gpar()`.")
243 246
     }
Browse code

optimize the default color mapping

Zuguang Gu authored on 18/08/2020 08:40:58
Showing1 changed files
... ...
@@ -92,8 +92,10 @@ default_col = function(x, main_matrix = FALSE) {
92 92
                 if(length(unique(x)) >= 100) {
93 93
                     q1 = quantile(x, 0.01)
94 94
                     q2 = quantile(x, 0.99)
95
-                    if(length(unique(x[x > q1 & x < q2])) == 1) {
96
-                         col_fun = colorRamp2(seq(min(x), max(x), length = 3), c("blue", "#EEEEEE", "red"))
95
+                    if(q1 == q2) {
96
+                        col_fun = colorRamp2(seq(min(x), max(x), length = 3), c("blue", "#EEEEEE", "red"))
97
+                    } else if(length(unique(x[x > q1 & x < q2])) == 1) {
98
+                        col_fun = colorRamp2(seq(min(x), max(x), length = 3), c("blue", "#EEEEEE", "red"))
97 99
                     } else {
98 100
                         col_fun = colorRamp2(seq(q1, q2, length = 3), c("blue", "#EEEEEE", "red"))
99 101
                         if(any(x > q2 + (q2-q1) | x < q1 - (q2-q1))) {
Browse code

fixed a bug of the legend size due to R 4.0.0

Zuguang Gu authored on 01/07/2020 21:06:46
Showing1 changed files
... ...
@@ -82,7 +82,7 @@ default_col = function(x, main_matrix = FALSE) {
82 82
                     col_fun = colorRamp2(c(-q1, 0, q1), c("blue", "#EEEEEE", "red"))
83 83
 
84 84
                     if(any(x > q1*3 | x < -q1*3)) {
85
-                        message_wrap("The automatically generated color maps from the minus and plus 99^th of the absolute values in the matrix. There are outliers in the matrix whose patterns might be hidden by this color mapping.\n\nUse `suppressMessages()` to turn off this message.")
85
+                        message_wrap("The automatically generated colors map from the minus and plus 99^th of the absolute values in the matrix. There are outliers in the matrix whose patterns might be hidden by this color mapping. You can manually set the color to `col` argument.\n\nUse `suppressMessages()` to turn off this message.")
86 86
                     }
87 87
                 } else {
88 88
                     q1 = max(abs(x))
... ...
@@ -97,7 +97,7 @@ default_col = function(x, main_matrix = FALSE) {
97 97
                     } else {
98 98
                         col_fun = colorRamp2(seq(q1, q2, length = 3), c("blue", "#EEEEEE", "red"))
99 99
                         if(any(x > q2 + (q2-q1) | x < q1 - (q2-q1))) {
100
-                            message_wrap("The automatically generated color maps from the 1^st and 99^th of the values in the matrix. There are outliers in the matrix whose patterns might be hidden by this color mapping.\n\nUse `suppressMessages()` to turn off this message.")
100
+                            message_wrap("The automatically generated colors map from the 1^st and 99^th of the values in the matrix. There are outliers in the matrix whose patterns might be hidden by this color mapping. You can manually set the color to `col` argument.\n\nUse `suppressMessages()` to turn off this message.")
101 101
                         }
102 102
                     }
103 103
                 } else {
... ...
@@ -1006,10 +1006,33 @@ to_unit = function(str) {
1006 1006
 }
1007 1007
 
1008 1008
 
1009
-resize_matrix = function(mat, nr, nc) {
1009
+# nr <= nrow(mat)
1010
+# nc <- ncol(mat)
1011
+resize_matrix = function(mat, nr, nc, fun = median) {
1010 1012
     w_ratio = nc/ncol(mat)
1011 1013
     h_ratio = nr/nrow(mat)
1012
-    mat[ ceiling(1:nr / h_ratio), ceiling(1:nc / w_ratio), drop = FALSE]
1014
+
1015
+    ind_r2 = ceiling(1:nr / h_ratio)
1016
+    ind_r1 = c(1, ind_r2[-length(ind_r2)]+1)
1017
+    ind_c2 = ceiling(1:nc / w_ratio)
1018
+    ind_c1 = c(1, ind_c2[-length(ind_c2)]+1)
1019
+    if(is.null(fun)) {
1020
+        mat[ ceiling(1:nr / h_ratio), ceiling(1:nc / w_ratio), drop = FALSE]
1021
+    } else {
1022
+
1023
+        nr_reduced = length(ind_r1)
1024
+        nc_reduced = length(ind_c1)
1025
+
1026
+        ind_grid = expand.grid(1:nr_reduced, 1:nc_reduced)
1027
+        mat_reduced = matrix(nrow = nr_reduced, ncol = nc_reduced)
1028
+        for(k in seq_len(nrow(ind_grid))) {
1029
+            i = ind_grid[k, 1]
1030
+            j = ind_grid[k, 2]
1031
+            subm = mat[seq(ind_r1[i], ind_r2[i]), seq(ind_c1[j], ind_c1[j]), drop = FALSE]
1032
+            mat_reduced[i, j] = fun(subm)
1033
+        }
1034
+        return(mat_reduced)
1035
+    }
1013 1036
 }
1014 1037
 
1015 1038
 
Browse code

anno_mark(), anno_zoom(); print message under RStudio

Zuguang Gu authored on 14/06/2020 20:36:59
Showing1 changed files
... ...
@@ -1053,3 +1053,17 @@ colorRamp2_biv = function(f1, f2, transparency = 0.5) {
1053 1053
     }
1054 1054
 }
1055 1055
 
1056
+
1057
+is_RStudio_current_dev = function() {
1058
+    dv = names(dev.list())
1059
+    if(length(dv) < 2) {
1060
+        FALSE
1061
+    } else {
1062
+        n = length(dv)
1063
+        if(dv[n-1] == "RStudioGD") {
1064
+            TRUE
1065
+        } else {
1066
+            FALSE
1067
+        }
1068
+    }
1069
+}
Browse code

default_col():print messages if there are outliers

Zuguang Gu authored on 18/05/2020 20:10:51
Showing1 changed files
... ...
@@ -80,6 +80,10 @@ default_col = function(x, main_matrix = FALSE) {
80 80
                 if(length(unique(x)) >= 100) {
81 81
                     q1 = quantile(abs(x), 0.99)
82 82
                     col_fun = colorRamp2(c(-q1, 0, q1), c("blue", "#EEEEEE", "red"))
83
+
84
+                    if(any(x > q1*3 | x < -q1*3)) {
85
+                        message_wrap("The automatically generated color maps from the minus and plus 99^th of the absolute values in the matrix. There are outliers in the matrix whose patterns might be hidden by this color mapping.\n\nUse `suppressMessages()` to turn off this message.")
86
+                    }
83 87
                 } else {
84 88
                     q1 = max(abs(x))
85 89
                     col_fun = colorRamp2(c(-q1, 0, q1), c("blue", "#EEEEEE", "red"))
... ...
@@ -92,6 +96,9 @@ default_col = function(x, main_matrix = FALSE) {
92 96
                          col_fun = colorRamp2(seq(min(x), max(x), length = 3), c("blue", "#EEEEEE", "red"))
93 97
                     } else {
94 98
                         col_fun = colorRamp2(seq(q1, q2, length = 3), c("blue", "#EEEEEE", "red"))
99
+                        if(any(x > q2 + (q2-q1) | x < q1 - (q2-q1))) {
100
+                            message_wrap("The automatically generated color maps from the 1^st and 99^th of the values in the matrix. There are outliers in the matrix whose patterns might be hidden by this color mapping.\n\nUse `suppressMessages()` to turn off this message.")
101
+                        }
95 102
                     }
96 103
                 } else {
97 104
                     col_fun = colorRamp2(seq(min(x), max(x), length = 3), c("blue", "#EEEEEE", "red"))
Browse code

UpSet(): change the annotation name

Zuguang Gu authored on 13/05/2020 08:29:39
Showing1 changed files
... ...
@@ -326,16 +326,22 @@ rep.list = function(x, n) {
326 326
 # == title
327 327
 # List All Heatmap Components
328 328
 #
329
+# == param
330
+# -pattern A regular expression.
331
+#
329 332
 # == value
330 333
 # A vector of viewport names.
331 334
 #
332
-list_components = function() {
335
+list_components = function(pattern = NULL) {
333 336
     vp = grid.ls(viewports = TRUE, grobs = FALSE, flatten = FALSE, print = FALSE)
334 337
     vp = unlist(vp)
335 338
     attributes(vp) = NULL
336 339
     vp = vp[!grepl("^\\d+$", vp)]
337 340
     vp = vp[!grepl("GRID.VP", vp)]
338 341
     # unique(vp)
342
+    if(!is.null(pattern)) {
343
+        vp = grep(pattern, vp, value = TRUE)
344
+    }
339 345
     vp
340 346
 }
341 347
 
Browse code

translate pheatmap to Heatmap

Zuguang Gu authored on 06/05/2020 07:21:34
Showing1 changed files
... ...
@@ -179,6 +179,8 @@ get_dist = function(matrix, method) {
179 179
         } else {
180 180
             stop_wrap("Since your distance method is a function, it can only accept one or two arguments.")
181 181
         }
182
+    } else if(inherits(method, "dist")) {
183
+        return(method)
182 184
     } else if(method %in% c("euclidean", "maximum", "manhattan", "canberra", "binary", "minkowski")) {
183 185
         # if(any(is.na(matrix))) {
184 186
         #     dst = get_dist(matrix, function(x, y) {
... ...
@@ -206,6 +208,8 @@ get_dist = function(matrix, method) {
206 208
                          spearman = as.dist(1 - cor(t(matrix), method = "spearman")),
207 209
                          kendall = as.dist(1 - cor(t(matrix), method = "kendall")))
208 210
         }
211
+    } else {
212
+        stop_wrap(qq("method @{method} not supported"))
209 213
     }
210 214
     return(dst)
211 215
 }
Browse code

rewrite smartAlign()

Zuguang Gu authored on 13/04/2020 11:51:26
Showing1 changed files
... ...
@@ -996,158 +996,6 @@ resize_matrix = function(mat, nr, nc) {
996 996
 }
997 997
 
998 998
 
999
-# == title
1000
-# Adjust positions of rectanglar shapes
1001
-#
1002
-# == param
1003
-# -start position which corresponds to the start (bottom or left) of the rectangle-shapes.
1004
-# -end position which corresponds to the end (top or right) of the rectanglar shapes.
1005
-# -range data ranges (the minimal and maximal values)
1006
-# -plot Whether plot the correspondance between the original positions and the adjusted positions. Only for testing.
1007
-#
1008
-# == details
1009
-# This is an improved version of the `circlize::smartAlign`.
1010
-#
1011
-# It adjusts the positions of the rectangular shapes to make them do not overlap
1012
-#
1013
-# == example
1014
-# range = c(0, 10)
1015
-# pos1 = rbind(c(1, 2), c(5, 7))
1016
-# smartAlign2(pos1, range = range, plot = TRUE)
1017
-#
1018
-# range = c(0, 10)
1019
-# pos1 = rbind(c(-0.5, 2), c(5, 7))
1020
-# smartAlign2(pos1, range = range, plot = TRUE)
1021
-#
1022
-# pos1 = rbind(c(-1, 2), c(3, 4), c(5, 6), c(7, 11))
1023
-# pos1 = pos1 + runif(length(pos1), max = 0.3, min = -0.3)
1024
-# omfrow = par("mfrow")
1025
-# par(mfrow = c(3, 3))
1026
-# for(i in 1:9) {
1027
-#     ind = sample(4, 4)
1028
-#     smartAlign2(pos1[ind, ], range = range, plot = TRUE)
1029
-# }
1030
-# par(mfrow = omfrow)
1031
-#
1032
-# pos1 = rbind(c(3, 6), c(4, 7))
1033
-# smartAlign2(pos1, range = range, plot = TRUE)
1034
-#
1035
-# pos1 = rbind(c(1, 8), c(3, 10))
1036
-# smartAlign2(pos1, range = range, plot = TRUE)
1037
-#
1038
-smartAlign2 = function(start, end, range, plot = FALSE) {
1039
-
1040
-    if(missing(end)) {
1041
-        x1 = start[, 1]
1042
-        x2 = start[, 2]
1043
-    } else {
1044
-        x1 = start
1045
-        x2 = end
1046
-    }
1047
-
1048
-    if(missing(range)) {
1049
-        range = range(c(x1, x2))
1050
-    }
1051
-
1052
-    make_plot = function(pos1, pos2, main = "") {
1053
-        oxpd = par("xpd")
1054
-        par(xpd = NA)
1055
-        plot(NULL, xlim = c(0, 4), ylim = range(c(pos1, pos2)), ann = FALSE, axes = FALSE)
1056
-        col = rand_color(nrow(pos1), transparency = 0.5)
1057
-        rect(0.5, pos1[, 1], 1.5, pos1[, 2], col = col)
1058
-        rect(2.5, pos2[, 1], 3.5, pos2[, 2], col = col)
1059
-        segments(1.5, rowMeans(pos1), 2.5, rowMeans(pos2))
1060
-        text(1, -0.02, "original", adj = c(0.5, 1))
1061
-        text(3, -0.02, "adjusted", adj = c(0.5, 1))
1062
-        title(main)
1063
-        par(xpd = oxpd)
1064
-    }
1065
-
1066
-
1067
-    od = order(x1)
1068
-    rk = rank(x1, ties.method = "random")
1069
-    x1 = x1[od]
1070
-    x2 = x2[od]
1071
-    mid = (x1 + x2)/2
1072
-    h = x2 - x1
1073
-    n = length(x1)
1074
-
1075
-    ox1 = x1
1076
-    ox2 = x2
1077
-
1078
-    # sum of box heights exceeds range
1079
-    if(sum(h) > range[2] - range[1]) {
1080
-        a = ((range[2] - h[n]/2) - (range[1] + h[1]/2))/(n-1)
1081
-        m = range[1] + 1:n*a
1082
-        nx1 = m - h/2
1083
-        nx2 = m + h/2
1084
-
1085
-        if(plot) {
1086
-            make_plot(cbind(ox1, ox2), cbind(nx1, nx2), main = "sum of box heights exceeds range")
1087
-        }
1088
-
1089
-        df = data.frame(start = x1, end = x2)
1090
-        return(df[rk, , drop = FALSE])
1091
-    }
1092
-    
1093
-    ncluster.before = -1
1094
-    ncluster = length(x1)
1095
-    i_try = 1
1096
-    while(ncluster.before != ncluster) {
1097
-        
1098
-        if(i_try > 100) break
1099
-        
1100
-        ncluster.before = ncluster
1101
-        cluster = rep(0, length(x1))
1102
-        i_cluster = 1
1103
-        cluster[1] = i_cluster
1104
-        for(i in seq_along(x1)[-1]) {
1105
-            # overlap with previous one
1106
-            if(x1[i] <= x2[i-1]) {  # this means x1 should be sorted increasingly
1107
-                cluster[i] = i_cluster
1108
-            } else {
1109
-                i_cluster = i_cluster + 1
1110
-                cluster[i] = i_cluster
1111
-            }
1112
-        }
1113
-        ncluster = length(unique(cluster))
1114
-
1115
-        # tile intervals in each cluster and re-assign x1 and x2
1116
-        new_x1 = numeric(length(x1))
1117
-        new_x2 = numeric(length(x2))
1118
-        for(i_cluster in unique(cluster)) {
1119
-            index = which(cluster == i_cluster)
1120
-            box_height = sum(h[index])  # sum of the height in the cluster
1121
-            box_mid = (min(x1[index]) + max(x2[index]))/2
1122
-            box_x1 = box_mid - box_height/2
1123
-            box_x2  = box_mid + box_height/2
1124
-            
1125
-            if(box_x1 < range[1]) { # if it exceed the bottom
1126
-                new_x2[index] = range[1] + cumsum(h[index])
1127
-                new_x1[index] = new_x2[index] - h[index]
1128
-            } else if(box_x2 > range[2]) {
1129
-                new_x1[index] = range[2] - rev(cumsum(h[index]))
1130
-                new_x2[index] = new_x1[index] + h[index]
1131
-            } else {
1132
-                new_x2[index] = box_x1 + cumsum(h[index])
1133
-                new_x1[index] = new_x2[index] - h[index]
1134
-            }
1135
-        }
1136
-
1137
-        x1 = new_x1
1138
-        x2 = new_x2
1139
-
1140
-        if(plot) {
1141
-            make_plot(cbind(ox1, ox2), cbind(x1, x2), main = qq("@{i_try}th try, @{ncluster} clusters"))
1142
-        }
1143
-
1144
-        i_try = i_try + 1
1145
-    }
1146
-    
1147
-    df = data.frame(start = x1, end = x2)
1148
-    df[rk, , drop = FALSE]
1149
-}
1150
-
1151 999
 color_overlap = function (r0, g0, b0, r, g, b, alpha = 1) {
1152 1000
     l_na_1 = is.na(r0) | is.na(g0) | is.na(b0)
1153 1001
     l_na_2 = is.na(r) | is.na(g) | is.na(b)
Browse code

improved subset method for comb_mat class

Zuguang Gu authored on 06/04/2020 13:08:25
Showing1 changed files
... ...
@@ -627,6 +627,44 @@ recycle_param = function(x, all_names, default, as.list = FALSE) {
627 627
     }
628 628
 }
629 629
 
630
+# recycle_list(list(a = 1), "a")
631
+# recycle_list(1, c("a", "b"))
632
+# recycle_list(list(a = 1), c("a", "b"), 0)
633
+recycle_list = function(x, all_names, default = NULL) {
634
+    n = length(all_names)
635
+    if(is.null(x)) {
636
+        lt = rep(list(default), n)
637
+        names(lt) = all_names
638
+        return(lt)
639
+    }
640
+    if(length(x) == 1 && !is.list(x) && n == 1) {
641
+        lt = list(x)
642
+        names(lt) = all_names
643
+        return(lt)
644
+    }
645
+    if(length(x) == 1 && !is.list(x)) {
646
+        lt = rep(list(x), n)
647
+        names(lt) = all_names
648
+        return(lt)
649
+    }
650
+    if(is.list(x)) {
651
+        lt = rep(list(default), n)
652
+        names(lt) = all_names
653
+        for(nm in names(x)) {
654
+            lt[[nm]] = x[[nm]]
655
+        }
656
+        return(lt)
657
+    }
658
+    if(length(x) == n) {
659
+        lt = lapply(x, function(y) y)
660
+        names(lt) = all_names
661
+        return(lt)
662
+    }
663
+
664
+    stop_wrap("wrong input data type.")
665
+
666
+}
667
+
630 668
 # == title
631 669
 # Convert XY in a Parent Viewport
632 670
 #
Browse code

smartAlign2(): correctly calculate positions of boxes

Zuguang Gu authored on 20/03/2020 19:42:24
Showing1 changed files
... ...
@@ -965,7 +965,7 @@ resize_matrix = function(mat, nr, nc) {
965 965
 # -start position which corresponds to the start (bottom or left) of the rectangle-shapes.
966 966
 # -end position which corresponds to the end (top or right) of the rectanglar shapes.
967 967
 # -range data ranges (the minimal and maximal values)
968
-# -range_fixed Whether the range is fixed for ``range`` when adjust the positions?
968
+# -plot Whether plot the correspondance between the original positions and the adjusted positions. Only for testing.
969 969
 #
970 970
 # == details
971 971
 # This is an improved version of the `circlize::smartAlign`.
... ...
@@ -973,25 +973,13 @@ resize_matrix = function(mat, nr, nc) {
973 973
 # It adjusts the positions of the rectangular shapes to make them do not overlap
974 974
 #
975 975
 # == example
976
-# require(circlize)
977
-# make_plot = function(pos1, pos2, range) {
978
-#     oxpd = par("xpd")
979
-#     par(xpd = NA)
980
-#     plot(NULL, xlim = c(0, 4), ylim = range, ann = FALSE)
981
-#     col = rand_color(nrow(pos1), transparency = 0.5)
982
-#     rect(0.5, pos1[, 1], 1.5, pos1[, 2], col = col)
983
-#     rect(2.5, pos2[, 1], 3.5, pos2[, 2], col = col)
984
-#     segments(1.5, rowMeans(pos1), 2.5, rowMeans(pos2))
985
-#     par(xpd = oxpd)
986
-# }
987
-#
988 976
 # range = c(0, 10)
989 977
 # pos1 = rbind(c(1, 2), c(5, 7))
990
-# make_plot(pos1, smartAlign2(pos1, range = range), range)
978
+# smartAlign2(pos1, range = range, plot = TRUE)
991 979
 #
992 980
 # range = c(0, 10)
993 981
 # pos1 = rbind(c(-0.5, 2), c(5, 7))
994
-# make_plot(pos1, smartAlign2(pos1, range = range), range)
982
+# smartAlign2(pos1, range = range, plot = TRUE)
995 983
 #
996 984
 # pos1 = rbind(c(-1, 2), c(3, 4), c(5, 6), c(7, 11))
997 985
 # pos1 = pos1 + runif(length(pos1), max = 0.3, min = -0.3)
... ...
@@ -999,18 +987,17 @@ resize_matrix = function(mat, nr, nc) {
999 987
 # par(mfrow = c(3, 3))
1000 988
 # for(i in 1:9) {
1001 989
 #     ind = sample(4, 4)
1002
-#     make_plot(pos1[ind, ], smartAlign2(pos1[ind, ], range = range), range)
990
+#     smartAlign2(pos1[ind, ], range = range, plot = TRUE)
1003 991
 # }
1004 992
 # par(mfrow = omfrow)
1005 993
 #
1006 994
 # pos1 = rbind(c(3, 6), c(4, 7))
1007
-# make_plot(pos1, smartAlign2(pos1, range = range), range)
995
+# smartAlign2(pos1, range = range, plot = TRUE)
1008 996
 #
1009 997
 # pos1 = rbind(c(1, 8), c(3, 10))
1010
-# make_plot(pos1, smartAlign2(pos1, range = range), range)
1011
-# make_plot(pos1, smartAlign2(pos1, range = range, range_fixed = FALSE), range)
998
+# smartAlign2(pos1, range = range, plot = TRUE)
1012 999
 #
1013
-smartAlign2 = function(start, end, range, range_fixed = TRUE) {
1000
+smartAlign2 = function(start, end, range, plot = FALSE) {
1014 1001
 
1015 1002
     if(missing(end)) {
1016 1003
         x1 = start[, 1]
... ...
@@ -1024,16 +1011,54 @@ smartAlign2 = function(start, end, range, range_fixed = TRUE) {
1024 1011
         range = range(c(x1, x2))
1025 1012
     }
1026 1013
 
1014
+    make_plot = function(pos1, pos2, main = "") {
1015
+        oxpd = par("xpd")
1016
+        par(xpd = NA)
1017
+        plot(NULL, xlim = c(0, 4), ylim = range(c(pos1, pos2)), ann = FALSE, axes = FALSE)
1018
+        col = rand_color(nrow(pos1), transparency = 0.5)
1019
+        rect(0.5, pos1[, 1], 1.5, pos1[, 2], col = col)
1020
+        rect(2.5, pos2[, 1], 3.5, pos2[, 2], col = col)
1021
+        segments(1.5, rowMeans(pos1), 2.5, rowMeans(pos2))
1022
+        text(1, -0.02, "original", adj = c(0.5, 1))
1023
+        text(3, -0.02, "adjusted", adj = c(0.5, 1))
1024
+        title(main)
1025
+        par(xpd = oxpd)
1026
+    }
1027
+
1028
+
1027 1029
     od = order(x1)
1028 1030
     rk = rank(x1, ties.method = "random")
1029 1031
     x1 = x1[od]
1030 1032
     x2 = x2[od]
1033
+    mid = (x1 + x2)/2
1031 1034
     h = x2 - x1
1035
+    n = length(x1)
1036
+
1037
+    ox1 = x1
1038
+    ox2 = x2
1032 1039
 
1040
+    # sum of box heights exceeds range
1041
+    if(sum(h) > range[2] - range[1]) {
1042
+        a = ((range[2] - h[n]/2) - (range[1] + h[1]/2))/(n-1)
1043
+        m = range[1] + 1:n*a
1044
+        nx1 = m - h/2
1045
+        nx2 = m + h/2
1046
+
1047
+        if(plot) {
1048
+            make_plot(cbind(ox1, ox2), cbind(nx1, nx2), main = "sum of box heights exceeds range")
1049
+        }
1050
+
1051
+        df = data.frame(start = x1, end = x2)
1052
+        return(df[rk, , drop = FALSE])
1053
+    }
1054
+    
1033 1055
     ncluster.before = -1
1034 1056
     ncluster = length(x1)
1035
-    i_try = 0
1057
+    i_try = 1
1036 1058
     while(ncluster.before != ncluster) {
1059
+        
1060
+        if(i_try > 100) break
1061
+        
1037 1062
         ncluster.before = ncluster
1038 1063
         cluster = rep(0, length(x1))
1039 1064
         i_cluster = 1
... ...
@@ -1048,43 +1073,35 @@ smartAlign2 = function(start, end, range, range_fixed = TRUE) {
1048 1073
             }
1049 1074
         }
1050 1075
         ncluster = length(unique(cluster))
1051
-        
1052
-        if(ncluster.before == ncluster && i_try > 0) break
1053 1076
 
1054
-        if(i_try > 100) break
1055
-        
1056 1077
         # tile intervals in each cluster and re-assign x1 and x2
1057 1078
         new_x1 = numeric(length(x1))
1058 1079
         new_x2 = numeric(length(x2))
1059 1080
         for(i_cluster in unique(cluster)) {
1060 1081
             index = which(cluster == i_cluster)
1061
-            total_len = sum(x2[index] - x1[index])  # sum of the height in the cluster
1062
-            mid = (min(x1[index]) + max(x2[index]))/2
1063
-            if(total_len > range[2] - range[1]) {
1064
-                # tp = seq(range[1], range[2], length = length(index) + 1)
1065
-                if(range_fixed) {
1066
-                    tp = cumsum(c(0, h[index]/sum(h[index])))*(range[2] - range[1]) + range[1]
1067
-                } else {
1068
-                    tp = c(0, cumsum(h[index])) + mid - sum(h[index])/2
1069
-                }
1070
-            } else if(mid - total_len/2 < range[1]) { # if it exceed the bottom
1071
-                # tp = seq(range[1], range[1] + total_len, length = length(index) + 1)
1072
-                tp = c(0, cumsum(h[index])) + range[1]
1073
-            } else if(mid + total_len/2 > range[2]) {
1074
-                # tp = seq(range[2] - total_len, range[2], length = length(index) + 1)
1075
-                tp = range[2] - rev(c(0, cumsum(h[index])))
1082
+            box_height = sum(h[index])  # sum of the height in the cluster
1083
+            box_mid = (min(x1[index]) + max(x2[index]))/2
1084
+            box_x1 = box_mid - box_height/2
1085
+            box_x2  = box_mid + box_height/2
1086
+            
1087
+            if(box_x1 < range[1]) { # if it exceed the bottom
1088
+                new_x2[index] = range[1] + cumsum(h[index])
1089
+                new_x1[index] = new_x2[index] - h[index]
1090
+            } else if(box_x2 > range[2]) {
1091
+                new_x1[index] = range[2] - rev(cumsum(h[index]))
1092
+                new_x2[index] = new_x1[index] + h[index]
1076 1093
             } else {
1077
-                # tp = seq(mid - total_len/2, mid + total_len/2, length = length(index)+1)
1078
-                tp = c(0, cumsum(h[index])) + mid - sum(h[index])/2
1094
+                new_x2[index] = box_x1 + cumsum(h[index])
1095
+                new_x1[index] = new_x2[index] - h[index]
1079 1096
             }
1080
-            new_x1[index] = tp[-length(tp)]
1081
-            new_x2[index] = tp[-1]
1082 1097
         }
1083
-        mid = (new_x1 + new_x2)/2
1084
-        h = (x2 - x1)
1085
-        
1086
-        x1 = mid - h/2
1087
-        x2 = mid + h/2
1098
+
1099
+        x1 = new_x1
1100
+        x2 = new_x2
1101
+
1102
+        if(plot) {
1103
+            make_plot(cbind(ox1, ox2), cbind(x1, x2), main = qq("@{i_try}th try, @{ncluster} clusters"))
1104
+        }
1088 1105
 
1089 1106
         i_try = i_try + 1
1090 1107
     }
Browse code

add unit_to_numeric() function

jokergoo authored on 05/03/2020 14:31:53
Showing1 changed files
... ...
@@ -545,6 +545,10 @@ unit_in_mm = function(x) {
545 545
     identical(unitType(x), "mm")
546 546
 }
547 547
 
548
+unit_to_numeric = function(x) {
549
+    as.numeric(x)
550
+}
551
+
548 552
 normalize_graphic_param_to_mat = function(x, nc, nr, name) {
549 553
     if(is.matrix(x)) {
550 554
         if(nrow(x) == nr && ncol(x) == nc) {
Browse code

redefine [[.unit and [[<-.unit for a quick fix

jokergoo authored on 05/03/2020 11:10:52
Showing1 changed files
... ...
@@ -528,7 +528,7 @@ unit.c = function(...) {
528 528
     if(!unit_in_mm(y)) {
529 529
         stop_wrap("y should be in mm unit")
530 530
     }
531
-    x[[1]] > y[[1]]
531
+    as.numeric(x) > as.numeric(y)
532 532
 }
533 533
 
534 534
 "<.unit" = function(x, y) {
... ...
@@ -538,16 +538,11 @@ unit.c = function(...) {
538 538
     if(!unit_in_mm(y)) {
539 539
         stop_wrap("y should be in mm unit")
540 540
     }
541
-    x[[1]] < y[[1]]
541
+    as.numeric(x) < as.numeric(y)
542 542
 }
543 543
 
544 544
 unit_in_mm = function(x) {
545
-    if(getRversion() >= "4.0.0") {
546
-        unitType = get("unitType", envir = asNamespace("grid"))
547
-        identical(unitType(x), "mm")
548
-    } else {
549
-        identical(attr(x, "unit"), "mm")
550
-    }
545
+    identical(unitType(x), "mm")
551 546
 }
552 547
 
553 548
 normalize_graphic_param_to_mat = function(x, nc, nr, name) {
Browse code

adjust code according to grid 4.0.0

Zuguang Gu authored on 02/03/2020 21:10:16
Showing1 changed files
... ...
@@ -522,25 +522,34 @@ unit.c = function(...) {
522 522
 }
523 523
 
524 524
 ">.unit" = function(x, y) {
525
-    if(!identical(attr(x, "unit"), "mm")) {
525
+    if(!unit_in_mm(x)) {
526 526
         stop_wrap("x should be in mm unit")
527 527
     }
528
-    if(!identical(attr(y, "unit"), "mm")) {
528
+    if(!unit_in_mm(y)) {
529 529
         stop_wrap("y should be in mm unit")
530 530
     }
531 531
     x[[1]] > y[[1]]
532 532
 }
533 533
 
534 534
 "<.unit" = function(x, y) {
535
-    if(!identical(attr(x, "unit"), "mm")) {
535
+    if(!unit_in_mm(x)) {
536 536
         stop_wrap("x should be in mm unit")
537 537
     }
538
-    if(!identical(attr(y, "unit"), "mm")) {
538
+    if(!unit_in_mm(y)) {
539 539
         stop_wrap("y should be in mm unit")
540 540
     }
541 541
     x[[1]] < y[[1]]
542 542
 }
543 543
 
544
+unit_in_mm = function(x) {
545
+    if(getRversion() >= "4.0.0") {
546
+        unitType = get("unitType", envir = asNamespace("grid"))
547
+        identical(unitType(x), "mm")
548
+    } else {
549
+        identical(attr(x, "unit"), "mm")
550
+    }
551
+}
552
+
544 553
 normalize_graphic_param_to_mat = function(x, nc, nr, name) {
545 554
     if(is.matrix(x)) {
546 555
         if(nrow(x) == nr && ncol(x) == nc) {
Browse code

text positions are correctly calculated when rotating text in anno_mark()

Zuguang Gu authored on 19/10/2019 19:51:41
Showing1 changed files
... ...
@@ -420,20 +420,6 @@ text_width = function(text, gp = gpar()) {
420 420
     convertWidth(u, "mm")
421 421
 }
422 422
 
423
-grid.text = function(label, x = unit(0.5, "npc"), y = unit(0.5, "npc"), 
424
-    just = "centre", hjust = NULL, vjust = NULL, rot = 0, check.overlap = FALSE, 
425
-    default.units = "npc", name = NULL, gp = gpar(), draw = TRUE, 
426
-    vp = NULL) {
427
-    tg <- textGrob(label = label, x = x, y = y, just = just, 
428
-        hjust = hjust, vjust = vjust, rot = rot, check.overlap = check.overlap, 
429
-        default.units = default.units, name = name, gp = gp, 
430
-        vp = vp)
431
-    tw = text_width(label)
432
-    th = text_height(label)
433
-    grid.draw(tg)
434
-    if(identical(just, ""))
435
-}
436
-
437 423
 text_height = function(text, gp = gpar()) {
438 424
     if(is.null(text)) {
439 425
         return(unit(0, "mm"))
Browse code

update

Zuguang Gu authored on 19/10/2019 18:58:27
Showing1 changed files
... ...
@@ -409,6 +409,42 @@ max_text_height = function(text, gp = gpar(), rot = 0) {
409 409
     convertHeight(u, "mm")
410 410
 }
411 411
 
412
+text_width = function(text, gp = gpar()) {
413
+    if(is.null(text)) {
414
+        return(unit(0, "mm"))
415
+    }
416
+    n = length(text)
417
+    gp = recycle_gp(gp, n)
418
+
419
+    u = do.call("unit.c", lapply(seq_len(n), function(i) grobWidth(textGrob(text[i], gp = subset_gp(gp, i)))))
420
+    convertWidth(u, "mm")
421
+}
422
+
423
+grid.text = function(label, x = unit(0.5, "npc"), y = unit(0.5, "npc"), 
424
+    just = "centre", hjust = NULL, vjust = NULL, rot = 0, check.overlap = FALSE, 
425
+    default.units = "npc", name = NULL, gp = gpar(), draw = TRUE, 
426
+    vp = NULL) {
427
+    tg <- textGrob(label = label, x = x, y = y, just = just, 
428
+        hjust = hjust, vjust = vjust, rot = rot, check.overlap = check.overlap, 
429
+        default.units = default.units, name = name, gp = gp, 
430
+        vp = vp)
431
+    tw = text_width(label)
432
+    th = text_height(label)
433
+    grid.draw(tg)
434
+    if(identical(just, ""))
435
+}
436
+
437
+text_height = function(text, gp = gpar()) {
438
+    if(is.null(text)) {
439
+        return(unit(0, "mm"))
440
+    }
441
+    n = length(text)
442
+    gp = recycle_gp(gp, n)
443
+
444
+    u = do.call("unit.c", lapply(seq_len(n), function(i) grobHeight(textGrob(text[i], gp = subset_gp(gp, i)))))
445
+    convertHeight(u, "mm")
446
+}
447
+
412 448
 dev.null = function(...) {
413 449
     pdf(file = NULL, ...)
414 450
 }
Browse code

add labels_rot argument to anno_mark()

Zuguang Gu authored on 02/07/2019 20:34:44
Showing1 changed files
... ...
@@ -341,6 +341,7 @@ list_components = function() {
341 341
 # == param
342 342
 # -text A vector of text.
343 343
 # -gp Graphic parameters for text.
344
+# -rot Rotation of the text, scalar.
344 345
 #
345 346
 # == details
346 347
 # It simply calculates maximum width of a list of `grid::textGrob` objects.
... ...
@@ -360,14 +361,14 @@ list_components = function() {
360 361
 # x = c("a", "bb", "ccc")
361 362
 # max_text_width(x, gp = gpar(fontsize = 10))
362 363
 #
363
-max_text_width = function(text, gp = gpar()) {
364
+max_text_width = function(text, gp = gpar(), rot = 0) {
364 365
     if(is.null(text)) {
365 366
         return(unit(0, "mm"))
366 367
     }
367 368
     n = length(text)
368 369
     gp = recycle_gp(gp, n)
369 370
 
370
-    u = max(do.call("unit.c", lapply(seq_len(n), function(i) grobWidth(textGrob(text[i], gp = subset_gp(gp, i))))))
371
+    u = max(do.call("unit.c", lapply(seq_len(n), function(i) grobWidth(textGrob(text[i], gp = subset_gp(gp, i), rot = rot)))))
371 372
     convertWidth(u, "mm")
372 373
 }
373 374
 
... ...
@@ -377,6 +378,7 @@ max_text_width = function(text, gp = gpar()) {
377 378
 # == param
378 379
 # -text A vector of text.
379 380
 # -gp Graphic parameters for text.
381
+# -rot Rotation of the text, scalar.
380 382
 #
381 383
 # == details
382 384
 # It simply calculates maximum height of a list of `grid::textGrob` objects.
... ...
@@ -396,14 +398,14 @@ max_text_width = function(text, gp = gpar()) {
396 398
 # x = c("a", "b\nb", "c\nc\nc")
397 399
 # max_text_height(x, gp = gpar(fontsize = 10))
398 400
 #
399
-max_text_height = function(text, gp = gpar()) {
401
+max_text_height = function(text, gp = gpar(), rot = 0) {
400 402
     if(is.null(text)) {
401 403
         return(unit(0, "mm"))
402 404
     }
403 405
     n = length(text)
404 406
     gp = recycle_gp(gp, n)
405 407
 
406
-    u = max(do.call("unit.c", lapply(seq_len(n), function(i) grobHeight(textGrob(text[i], gp = subset_gp(gp, i))))))
408
+    u = max(do.call("unit.c", lapply(seq_len(n), function(i) grobHeight(textGrob(text[i], gp = subset_gp(gp, i), rot = rot)))))
407 409
     convertHeight(u, "mm")
408 410
 }
409 411
 
Browse code

try to implement bivariate color mapping

Zuguang Gu authored on 20/04/2019 21:10:28
Showing1 changed files
... ...
@@ -1061,3 +1061,43 @@ smartAlign2 = function(start, end, range, range_fixed = TRUE) {
1061 1061
     df[rk, , drop = FALSE]
1062 1062
 }
1063 1063
 
1064
+color_overlap = function (r0, g0, b0, r, g, b, alpha = 1) {
1065
+    l_na_1 = is.na(r0) | is.na(g0) | is.na(b0)
1066
+    l_na_2 = is.na(r) | is.na(g) | is.na(b)
1067
+    r = ifelse(l_na_1 & l_na_2, 1, ifelse(l_na_1, r * alpha,
1068
+        ifelse(l_na_2, r0, r * alpha + r0 * (1 - alpha))))
1069
+    g = ifelse(l_na_1 & l_na_2, 1, ifelse(l_na_1, g * alpha,
1070
+        ifelse(l_na_2, g0, g * alpha + g0 * (1 - alpha))))
1071
+    b = ifelse(l_na_1 & l_na_2, 1, ifelse(l_na_1, b * alpha,
1072
+        ifelse(l_na_2, b0, b * alpha + b0 * (1 - alpha))))
1073
+    return(list(r = r, g = g, b = b))
1074
+}
1075
+
1076
+colorRamp2_biv = function(f1, f2, transparency = 0.5) {
1077
+    f1 = f1
1078
+    f2 = f2
1079
+    if(length(transparency) == 1) transparency = rep(transparency, 2)
1080
+    f = function(x1, x2) {
1081
+        if(missing(x2)) {
1082
+            if(ncol(x1) == 2) {
1083
+                x2 = x1[, 2]
1084
+                x1 = x1[, 1]
1085
+            } else {
1086
+                stop_wrap("If only one variable is specified, it should be a matrix/data frame with two columns.")
1087
+            }
1088
+        }
1089
+        col1 = col2rgb(f1(x1), alpha = TRUE)/255
1090
+        col2 = col2rgb(f2(x2), alpha = TRUE)/255
1091
+
1092
+        if(length(transparency)) {
1093
+            col1[4, ] = 1 - transparency[1]
1094
+            col2[4, ] = 1 - transparency[2]
1095
+        }
1096
+
1097
+        col1 = col1[1:3, , drop = FALSE] * rep(col1[4, ], each = 3)
1098
+        lt = color_overlap(col1[1, ], col1[2, ], col1[3, ],
1099
+            col2[1, ], col2[2, ], col2[3, ], alpha = col2[4, ])
1100
+        rgb(lt[[1]], lt[[2]], lt[[3]])
1101
+    }
1102
+}
1103
+
Browse code

version bump

Zuguang Gu authored on 26/03/2019 14:25:36
Showing1 changed files
... ...
@@ -56,7 +56,7 @@ default_col = function(x, main_matrix = FALSE) {
56 56
         x = as.vector(x)
57 57
     }
58 58
 
59
-    if(length(unique(x)) == 1) {
59
+    if(length(unique(as.vector(x))) == 1) {
60 60
         x = as.character(x)
61 61
     }
62 62
 
Browse code

gp in anno_text() supports fill and border

Zuguang Gu authored on 24/03/2019 22:20:59
Showing1 changed files
... ...
@@ -73,7 +73,7 @@ default_col = function(x, main_matrix = FALSE) {
73 73
     } else if(is.numeric(x)) {
74 74
         if(main_matrix) {
75 75
             p = sum(x > 0)/sum(x != 0)
76
-            if(p > 0.3 & p < 0.7) {
76
+            if(p > 0.25 & p < 0.75) {
77 77
                 if(ht_opt$verbose) {
78 78
                     cat("This matrix has both negative and positive values, use a color mapping symmetric to zero\n")
79 79
                 }
... ...
@@ -721,6 +721,90 @@ pindex = function(m, i, j) {
721 721
     }
722 722
 }
723 723
 
724
+# == title
725
+# Restore the index vector to index matrix in layer_fun
726
+#
727
+# == param
728
+# -j Column indices directly from ``layer_fun``.
729
+# -i Row indices directly from ``layer_fun``.
730
+# -x Position on x-direction directly from ``layer_fun``.
731
+# -y Position on y-direction directly from ``layer_fun``.
732
+#
733
+# == details
734
+# The values that are sent to ``layer_fun`` are all vectors (for the vectorization
735
+# of the grid graphic functions), however, the heatmap slice where
736
+# ``layer_fun`` is applied to, is still represented by a matrix, thus, it would be
737
+# very convinient if all the arguments in ``layer_fun`` can be converted to the
738
+# sub-matrix for the current slice. Here, as shown in above example,
739
+# `restore_matrix` does the job. `restore_matrix` directly accepts the first
740
+# four argument in ``layer_fun`` and returns an index matrix, where rows and
741
+# columns correspond to the rows and columns in the current slice, from top to
742
+# bottom and from left to right. The values in the matrix are the natural order
743
+# of e.g. vector ``j`` in current slice.
744
+#
745
+# For following code:
746
+#
747
+#     Heatmap(small_mat, name = "mat", col = col_fun,
748
+#         row_km = 2, column_km = 2,
749
+#         layer_fun = function(j, i, x, y, w, h, fill) {
750
+#             ind_mat = restore_matrix(j, i, x, y)
751
+#             print(ind_mat)
752
+#         }
753
+#     )
754
+#
755
+# The first output which is for the top-left slice:
756
+# 
757
+#          [,1] [,2] [,3] [,4] [,5]
758
+#     [1,]    1    4    7   10   13
759
+#     [2,]    2    5    8   11   14
760
+#     [3,]    3    6    9   12   15
761
+#
762
+# As you see, this is a three-row and five-column index matrix where the first
763
+# row corresponds to the top row in the slice. The values in the matrix
764
+# correspond to the natural index (i.e. 1, 2, ...) in ``j``, ``i``, ``x``, ``y``,
765
+# ... in ``layer_fun``. Now, if we want to add values on the second column in the
766
+# top-left slice, the code which is put inside ``layer_fun`` would look like:
767
+#
768
+#     for(ind in ind_mat[, 2]) {
769
+#         grid.text(small_mat[i[ind], j[ind]], x[ind], y[ind], ...)
770
+#     }
771
+#
772
+# == example
773
+# set.seed(123)
774
+# mat = matrix(rnorm(81), nr = 9)
775
+# Heatmap(mat, row_km = 2, column_km = 2,
776
+#     layer_fun = function(j, i, x, y, width, height, fill) {
777
+#        ind_mat = restore_matrix(j, i, x, y)
778
+#        print(ind_mat)
779
+# })
780
+#
781
+# set.seed(123)
782
+# mat = matrix(round(rnorm(81), 2), nr = 9)
783
+# Heatmap(mat, row_km = 2, column_km = 2,
784
+#     layer_fun = function(j, i, x, y, width, height, fill) {
785
+#        ind_mat = restore_matrix(j, i, x, y)
786
+#        ind = unique(c(ind_mat[2, ], ind_mat[, 3]))
787
+#        grid.text(pindex(mat, i[ind], j[ind]), x[ind], y[ind])
788
+# })
789
+restore_matrix = function(j, i, x, y) {
790
+    x = as.numeric(x)
791
+    y = as.numeric(y)
792
+    od = order(x, rev(y))
793
+    ind = seq_along(i)
794
+    j = j[od]
795
+    i = i[od]
796
+    x = x[od]
797
+    y = y[od]
798
+    ind = ind[od]
799
+    
800
+    nr = length(unique(i))
801
+    nc = length(unique(j))
802
+    # I = matrix(i, nrow = nr, ncol = nc)
803
+    # J = matrix(j, nrow = nr, ncol = nc)
804
+    IND = matrix(ind, nrow = nr, ncol = nc)
805
+    return(IND)
806
+}
807
+
724 808
 
725 809
 unit_with_vp = function(..., vp = current.viewport()$name) {
726 810
     u = unit(...)
Browse code

use non-zero values

jokergoo authored on 13/03/2019 08:52:38
Showing1 changed files
... ...
@@ -72,7 +72,7 @@ default_col = function(x, main_matrix = FALSE) {
72 72
         return(colors)
73 73
     } else if(is.numeric(x)) {
74 74
         if(main_matrix) {
75
-            p = sum(x > 0)/length(x)
75
+            p = sum(x > 0)/sum(x != 0)
76 76
             if(p > 0.3 & p < 0.7) {
77 77
                 if(ht_opt$verbose) {
78 78
                     cat("This matrix has both negative and positive values, use a color mapping symmetric to zero\n")
Browse code

color mapping symmetric to zero for a matrix with both positive and negative values

Zuguang Gu authored on 12/02/2019 08:33:38
Showing1 changed files
... ...
@@ -72,16 +72,30 @@ default_col = function(x, main_matrix = FALSE) {
72 72
         return(colors)
73 73
     } else if(is.numeric(x)) {
74 74
         if(main_matrix) {
75
-            if(length(unique(x)) > 100) {
76
-                q1 = quantile(x, 0.01)
77
-                q2 = quantile(x, 0.99)
78
-                if(length(unique(x[x > q1 & x < q2])) == 1) {
79
-                     col_fun = colorRamp2(seq(min(x), max(x), length = 3), c("blue", "#EEEEEE", "red"))
75
+            p = sum(x > 0)/length(x)
76
+            if(p > 0.3 & p < 0.7) {
77
+                if(ht_opt$verbose) {
78
+                    cat("This matrix has both negative and positive values, use a color mapping symmetric to zero\n")
79
+                }
80
+                if(length(unique(x)) >= 100) {
81
+                    q1 = quantile(abs(x), 0.99)
82
+                    col_fun = colorRamp2(c(-q1, 0, q1), c("blue", "#EEEEEE", "red"))
80 83
                 } else {
81
-                    col_fun = colorRamp2(seq(q1, q2, length = 3), c("blue", "#EEEEEE", "red"))
84
+                    q1 = max(abs(x))
85
+                    col_fun = colorRamp2(c(-q1, 0, q1), c("blue", "#EEEEEE", "red"))
82 86
                 }
83 87
             } else {
84
-                col_fun = colorRamp2(seq(min(x), max(x), length = 3), c("blue", "#EEEEEE", "red"))
88
+                if(length(unique(x)) >= 100) {
89
+                    q1 = quantile(x, 0.01)
90
+                    q2 = quantile(x, 0.99)
91
+                    if(length(unique(x[x > q1 & x < q2])) == 1) {
92
+                         col_fun = colorRamp2(seq(min(x), max(x), length = 3), c("blue", "#EEEEEE", "red"))
93
+                    } else {
94
+                        col_fun = colorRamp2(seq(q1, q2, length = 3), c("blue", "#EEEEEE", "red"))
95
+                    }
96
+                } else {
97
+                    col_fun = colorRamp2(seq(min(x), max(x), length = 3), c("blue", "#EEEEEE", "red"))
98
+                }
85 99
             }
86 100
         } else {
87 101
             #col_fun = colorRamp2(range(min(x), max(x)), c("white", hsv(runif(1), 1, 1)))
Browse code

add UpSet()

Zuguang Gu authored on 26/12/2018 08:44:58
Showing1 changed files
... ...
@@ -804,8 +804,8 @@ grid.boxplot = function(value, pos, outline = TRUE, box_width = 0.6,
804 804
     }
805 805
 }
806 806
 
807
-random_str = function() {
808
-    paste(sample(c(letters, LETTERS, 0:9), 8), collapse = "")
807
+random_str = function(k = 1, len = 10) {
808
+    sapply(seq_len(k), function(i) paste(sample(c(letters, LETTERS, 0:9), len), collapse = ""))
809 809
 }
810 810
 
811 811
 
Browse code

get rid of infinite loop

Zuguang Gu authored on 13/12/2018 13:08:13
Showing1 changed files
... ...
@@ -920,6 +920,8 @@ smartAlign2 = function(start, end, range, range_fixed = TRUE) {
920 920
         ncluster = length(unique(cluster))
921 921
         
922 922
         if(ncluster.before == ncluster && i_try > 0) break
923
+
924
+        if(i_try > 100) break
923 925
         
924 926
         # tile intervals in each cluster and re-assign x1 and x2
925 927
         new_x1 = numeric(length(x1))
Browse code

add smartAlign2()

Zuguang Gu authored on 13/12/2018 11:37:32
Showing1 changed files
... ...
@@ -826,3 +826,138 @@ resize_matrix = function(mat, nr, nc) {
826 826
     h_ratio = nr/nrow(mat)
827 827
     mat[ ceiling(1:nr / h_ratio), ceiling(1:nc / w_ratio), drop = FALSE]
828 828
 }
829
+
830
+
831
+# == title
832
+# Adjust positions of rectanglar shapes
833
+#
834
+# == param
835
+# -start position which corresponds to the start (bottom or left) of the rectangle-shapes.
836
+# -end position which corresponds to the end (top or right) of the rectanglar shapes.
837
+# -range data ranges (the minimal and maximal values)
838
+# -range_fixed Whether the range is fixed for ``range`` when adjust the positions?
839
+#
840
+# == details
841
+# This is an improved version of the `circlize::smartAlign`.
842
+#
843
+# It adjusts the positions of the rectangular shapes to make them do not overlap
844
+#
845
+# == example
846
+# require(circlize)
847
+# make_plot = function(pos1, pos2, range) {
848
+#     oxpd = par("xpd")
849
+#     par(xpd = NA)
850
+#     plot(NULL, xlim = c(0, 4), ylim = range, ann = FALSE)
851
+#     col = rand_color(nrow(pos1), transparency = 0.5)
852
+#     rect(0.5, pos1[, 1], 1.5, pos1[, 2], col = col)
853
+#     rect(2.5, pos2[, 1], 3.5, pos2[, 2], col = col)
854
+#     segments(1.5, rowMeans(pos1), 2.5, rowMeans(pos2))
855
+#     par(xpd = oxpd)
856
+# }
857
+#
858
+# range = c(0, 10)
859
+# pos1 = rbind(c(1, 2), c(5, 7))
860
+# make_plot(pos1, smartAlign2(pos1, range = range), range)
861
+#
862
+# range = c(0, 10)
863
+# pos1 = rbind(c(-0.5, 2), c(5, 7))
864
+# make_plot(pos1, smartAlign2(pos1, range = range), range)
865
+#
866
+# pos1 = rbind(c(-1, 2), c(3, 4), c(5, 6), c(7, 11))
867
+# pos1 = pos1 + runif(length(pos1), max = 0.3, min = -0.3)
868
+# omfrow = par("mfrow")
869
+# par(mfrow = c(3, 3))
870
+# for(i in 1:9) {
871
+#     ind = sample(4, 4)
872
+#     make_plot(pos1[ind, ], smartAlign2(pos1[ind, ], range = range), range)
873
+# }
874
+# par(mfrow = omfrow)
875
+#
876
+# pos1 = rbind(c(3, 6), c(4, 7))
877
+# make_plot(pos1, smartAlign2(pos1, range = range), range)
878
+#
879
+# pos1 = rbind(c(1, 8), c(3, 10))
880
+# make_plot(pos1, smartAlign2(pos1, range = range), range)
881
+# make_plot(pos1, smartAlign2(pos1, range = range, range_fixed = FALSE), range)
882
+#
883
+smartAlign2 = function(start, end, range, range_fixed = TRUE) {
884
+
885
+    if(missing(end)) {
886
+        x1 = start[, 1]
887
+        x2 = start[, 2]
888
+    } else {
889
+        x1 = start
890
+        x2 = end
891
+    }
892
+
893
+    if(missing(range)) {
894
+        range = range(c(x1, x2))
895
+    }
896
+
897
+    od = order(x1)
898
+    rk = rank(x1, ties.method = "random")
899
+    x1 = x1[od]
900
+    x2 = x2[od]
901
+    h = x2 - x1
902
+
903
+    ncluster.before = -1
904
+    ncluster = length(x1)
905
+    i_try = 0
906
+    while(ncluster.before != ncluster) {
907
+        ncluster.before = ncluster
908
+        cluster = rep(0, length(x1))
909
+        i_cluster = 1
910
+        cluster[1] = i_cluster
911
+        for(i in seq_along(x1)[-1]) {
912
+            # overlap with previous one
913
+            if(x1[i] <= x2[i-1]) {  # this means x1 should be sorted increasingly
914
+                cluster[i] = i_cluster
915
+            } else {
916
+                i_cluster = i_cluster + 1
917
+                cluster[i] = i_cluster
918
+            }
919
+        }
920
+        ncluster = length(unique(cluster))
921
+        
922
+        if(ncluster.before == ncluster && i_try > 0)