1. ComplexHeatmap
  2. R
  3. utils.R
Browse code

automatically recognize Jupyter environment

Zuguang Gu authored on 31/05/2022 11:42:14
Showing1 changed files
R/utils.R
History View file @1ad73d8
... ... 
@@ -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
R/utils.R
History View file @518ef04
... ... 
@@ -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
R/utils.R
History View file @425c85f
... ... 
@@ -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
R/utils.R
History View file @22ab8e0
... ... 
@@ -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
R/utils.R
History View file @64c1050
... ... 
@@ -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
R/utils.R
History View file @ab225a0
... ... 
@@ -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
R/utils.R
History View file @8ed806b
... ... 
@@ -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
R/utils.R
History View file @5c6415b
... ... 
@@ -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
R/utils.R
History View file @2d09112
... ... 
@@ -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
R/utils.R
History View file @ccd4b14
... ... 
@@ -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
R/utils.R
History View file @9e36ee6
... ... 
@@ -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
R/utils.R
History View file @06550f3
... ... 
@@ -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
R/utils.R
History View file @e626fd7
... ... 
@@ -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
R/utils.R
History View file @110a6d6
... ... 
@@ -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
R/utils.R
History View file @a929490
... ... 
@@ -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
R/utils.R
History View file @231f22f
... ... 
@@ -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
R/utils.R
History View file @1721a63
... ... 
@@ -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
R/utils.R
History View file @202973d
... ... 
@@ -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
R/utils.R
History View file @ab07104
... ... 
@@ -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
R/utils.R
History View file @71d9900
... ... 
@@ -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
R/utils.R
History View file @2989e79
... ... 
@@ -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
R/utils.R
History View file @cb0ddba
... ... 
@@ -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
R/utils.R
History View file @019330c
... ... 
@@ -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
R/utils.R
History View file @28b6388
... ... 
@@ -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
R/utils.R
History View file @17a402b
... ... 
@@ -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
R/utils.R
History View file @7e84d7a
... ... 
@@ -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
R/utils.R
History View file @73277ab
... ... 
@@ -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
R/utils.R
History View file @448f5de
... ... 
@@ -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
R/utils.R
History View file @d574e5e
... ... 
@@ -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
R/utils.R
History View file @28b2e79
... ... 
@@ -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
R/utils.R
History View file @0a2c5a5
... ... 
@@ -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
R/utils.R
History View file @70c20a0
... ... 
@@ -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
R/utils.R
History View file @1dbbe82
... ... 
@@ -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
R/utils.R
History View file @f4dac00
... ... 
@@ -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
R/utils.R
History View file @c51b634
... ... 
@@ -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
R/utils.R
History View file @0d456ec
... ... 
@@ -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
R/utils.R
History View file @9c4d56c
... ... 
@@ -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
R/utils.R
History View file @2a88897
... ... 
@@ -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
R/utils.R
History View file @d90404d
... ... 
@@ -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
R/utils.R
History View file @36c3a37
... ... 
@@ -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
R/utils.R
History View file @c6d85bd
... ... 
@@ -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
R/utils.R
History View file @1f0f3de
... ... 
@@ -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)