Browse code

import cli

Guangchuang Yu authored on 10/11/2022 03:31:25
Showing9 changed files

... ...
@@ -1,7 +1,7 @@
1 1
 Package: ggtree
2 2
 Type: Package
3 3
 Title: an R package for visualization of tree and annotation data
4
-Version: 3.6.1
4
+Version: 3.6.2
5 5
 Authors@R: c(
6 6
        person("Guangchuang", "Yu",     email = "guangchuangyu@gmail.com", role = c("aut", "cre", "cph"), 
7 7
             comment = c(ORCID = "0000-0002-6485-8781")),
... ...
@@ -38,7 +38,8 @@ Imports:
38 38
     treeio (>= 1.8.0),
39 39
     utils,
40 40
     scales,
41
-    stats
41
+    stats,
42
+    cli
42 43
 Suggests:
43 44
     emojifont,
44 45
     ggimage,
... ...
@@ -168,6 +168,7 @@ importFrom(ape,reorder.phylo)
168 168
 importFrom(ape,rtree)
169 169
 importFrom(aplot,plot_list)
170 170
 importFrom(aplot,xrange)
171
+importFrom(cli,cli_alert_warning)
171 172
 importFrom(dplyr,collapse)
172 173
 importFrom(dplyr,filter)
173 174
 importFrom(dplyr,full_join)
... ...
@@ -123,6 +123,7 @@ geom_hilight_rect2 <- function(data=NULL,
123 123
 
124 124
 #' @importFrom ggplot2 draw_key_polygon Geom ggproto aes GeomPolygon
125 125
 #' @importFrom grid rectGrob gpar grobTree
126
+#' @importFrom cli cli_alert_warning
126 127
 GeomHilightRect <- ggproto("GeomHilightRect", Geom,
127 128
                            default_aes = aes(colour = NA, fill = "steelblue", 
128 129
                                              linewidth = 0.5, linetype = 1, alpha = 0.5,
... ...
@@ -146,18 +147,16 @@ GeomHilightRect <- ggproto("GeomHilightRect", Geom,
146 147
                                    flag2 <- data$extendto < data$xmax
147 148
                                    flag <- equals(flag1, flag2)
148 149
                                    if (all(flag1) && any(flag)){
149
-                                       warning_wrap("extendto ", 
150
-                                                    paste0(data$extendto[flag], collapse="; "), 
151
-                                                    ifelse(length(data$extendto[flag])>1, " are", " is"), 
152
-                                                    " too small for node: ", paste0(data$clade_root_node[flag], collapse="; "),
153
-                                                    ", keep the original xmax value(s): ", paste0(data$xmax[flag], collapse="; "), ".")
150
+                                       cli_alert_warning(c("{.code extendto} ", paste0(data$extendto[flag], collapse="; "), 
151
+                                                    ifelse(length(data$extendto[flag])>1, " are", " is")," too small for node: ", 
152
+                                                    paste0(data$clade_root_node[flag], collapse="; "),", keep the original xmax value(s): ", 
153
+                                                    paste0(data$xmax[flag], collapse="; "), "."), wrap = TRUE)
154 154
                                        data$xmax[!flag] <- data$extendto[!flag]
155 155
                                    }else if(!all(flag1) && any(flag)){
156
-                                       warning_wrap("extendto ", 
157
-                                                    paste0(data$extendto[flag], collapse="; "), 
158
-                                                    ifelse(length(data$extendto[flag])>1, " are", " is"),
159
-                                                    " too big for node: ", paste0(data$clade_root_node[flag], collapse="; "),
160
-                                                    ", keep the original xmax value(s): ", paste0(data$xmax[flag], collapse="; "), ".")
156
+                                       cli_alert_warning(c("{.code extendto} ", paste0(data$extendto[flag], collapse="; "), 
157
+                                                    ifelse(length(data$extendto[flag])>1, " are", " is"), " too big for node: ", 
158
+                                                    paste0(data$clade_root_node[flag], collapse="; "), ", keep the original xmax value(s): ", 
159
+                                                    paste0(data$xmax[flag], collapse="; "), "."), wrap = TRUE)
161 160
                                        data$xmax[!flag] <- data$extendto[!flag]
162 161
                                    }else{
163 162
                                        data$xmax <- data$extendto 
... ...
@@ -166,10 +165,12 @@ GeomHilightRect <- ggproto("GeomHilightRect", Geom,
166 165
                                data <- build_align_data(data=data, align=align) 
167 166
                                if (!coord$is_linear()) {
168 167
                                    if (gradient){
169
-                                       warning_wrap("The gradient color hight light layer only presents in rectangular, ellipse, roundrect layouts")
168
+                                       cli_alert_warning("The gradient color hight light layer only presents in 
169
+                                                         rectangular, ellipse, roundrect layouts.", wrap = TRUE)
170 170
                                    }
171 171
                                    if (roundrect){
172
-                                       warning_wrap("The round rectangular hight light layer only presents in rectangular, ellipse, roundrect layouts")
172
+                                       cli_alert_warning("The round rectangular hight light layer only presents in 
173
+                                                         rectangular, ellipse, roundrect layouts.", wrap =TRUE)
173 174
                                    }
174 175
                                    aesthetics <- setdiff(colnames(data), #"x.start", "y.start", "x.stop", "y.stop"), 
175 176
                                                          c("xmin", "xmax", "ymin", "ymax", "clade_root_node"))
... ...
@@ -212,7 +213,7 @@ GeomHilightRect <- ggproto("GeomHilightRect", Geom,
212 213
                                    hilightGrob <- ifelse(roundrect, grid::roundrectGrob, grid::rectGrob)
213 214
                                    if (gradient){
214 215
                                        if (roundrect){
215
-                                           warning_wrap("The round rectangular and gradient are not applied simultaneously")
216
+                                           cli_alert_warning("The round rectangular and gradient are not applied simultaneously")
216 217
                                        }
217 218
                                        gradient.direction <- match.arg(gradient.direction, c("rt", "tr"))
218 219
                                        rects <- lapply(split(coords, seq_len(nrow(coords))), function(row){
... ...
@@ -304,6 +305,10 @@ geom_hilight_encircle2 <- function(data=NULL,
304 305
           )
305 306
 }
306 307
 
308
+check_linewidth <- getFromNamespace('check_linewidth', 'ggplot2')
309
+snake_class <- getFromNamespace('snake_class', 'ggplot2')
310
+snakeize <- getFromNamespace('snakeize', 'ggplot2')
311
+
307 312
 GeomHilightEncircle <- ggproto("GeomHilightEncircle", Geom,
308 313
                                 required_aes = c("x", "y", "clade_root_node"),
309 314
                                 default_aes = aes(colour="black", fill="steelblue", alpha = 0.5,
... ...
@@ -311,7 +316,8 @@ GeomHilightEncircle <- ggproto("GeomHilightEncircle", Geom,
311 316
                                                   s_shape=0.5, s_open=FALSE),
312 317
                                 draw_key = draw_key_polygon,
313 318
                                 rename_size = TRUE,
314
-                                draw_panel = function(data, panel_scales, coord){
319
+                                draw_panel = function(self, data, panel_scales, coord){
320
+                                    data <- check_linewidth(data, snake_class(self))
315 321
                                     globs <- lapply(split(data, data$clade_root_node), function(i)
316 322
                                                    get_glob_encircle(i, panel_scales, coord))
317 323
                                     ggname("geom_hilight_encircle2", do.call("grobTree", globs))
... ...
@@ -477,14 +483,7 @@ build_align_data <- function(data, align){
477 483
 
478 484
 
479 485
 #' @importFrom utils getFromNamespace
480
-#warning_wrap <- getFromNamespace("warning_wrap", "ggplot2")
481
-warning_wrap <- function(...){
482
-    x = paste0(...)
483
-    x = paste(strwrap(x), collapse = "\n")
484
-    warning(x, call. = FALSE)
485
-}
486 486
 rect_to_poly <- getFromNamespace("rect_to_poly", "ggplot2")
487
-#new_data_frame <- getFromNamespace("new_data_frame", "ggplot2")
488 487
 
489 488
 ## ##' layer of hilight clade with rectangle
490 489
 ## ##'
... ...
@@ -139,7 +139,7 @@ get_glob_encircle <- function(data, panel_scales, coord){
139 139
     data.frame(x,y,first_row[!names(first_row) %in% c("x","y")])
140 140
   }
141 141
 
142
-  coords <- coords[ch,]
142
+  coords <- coords[ch,,drop=FALSE]
143 143
   ## FIXME: using grid:: a lot. importFrom instead?
144 144
 
145 145
   ## convert from lengths to physical units, for computing *directions*
... ...
@@ -195,7 +195,8 @@ get_glob_encircle <- function(data, panel_scales, coord){
195 195
   ## browser()
196 196
 
197 197
   gp <- grid::get.gpar()
198
-  pars1 <- c("colour","linetype","alpha","fill","size")
198
+  # the 'size' of line in ggplot2 3.4.0 have been replaced with 'linewidth'
199
+  pars1 <- c("colour","linetype","alpha","fill","linewidth")
199 200
   pars2 <- c("col","lty","alpha","fill","lwd")
200 201
   gp[pars2] <- first_row[pars1]
201 202
   grid::xsplineGrob(
... ...
@@ -133,10 +133,11 @@ geom_tiplab_rectangular <- function(mapping=NULL, hjust = 0,  align = FALSE,
133 133
     params <- list(...)
134 134
     if ("nudge_x" %in% names(params)){
135 135
         if (offset != 0){
136
-            warning_wrap("Both nudge_x and offset arguments are provided.
136
+            cli_alert_warning("Both {.code nudge_x} and {.code offset} arguments are provided.
137 137
                          Because they all adjust the horizontal offset of labels,
138
-                         and the 'nudge_x' is consistent with 'ggplot2'. The
139
-                         'offset' will be deprecated here and only the 'nudge_x' will be used.")
138
+                         and the {.code nudge_x} is consistent with {.code ggplot2}. The
139
+                         {.code offset} will be deprecated here and only the {.code nudge_x} will be used.", 
140
+                         wrap = TRUE)
140 141
         }
141 142
         offset <- params$nudge_x
142 143
         params$nudge_x <- NULL
... ...
@@ -39,14 +39,10 @@
39 39
 ##' <http://yulab-smu.top/treedata-book/index.html> by Guangchuang Yu.
40 40
 geom_tree <- function(mapping=NULL, data=NULL, layout="rectangular", multiPhylo=FALSE, continuous="none", position="identity", ...) {
41 41
     if (is.logical(continuous)){
42
-        warning_wrap('The type of "continuous" argument was changed (v>=2.5.2). Now, 
43
-                     it should be one of "color" (or "colour"), "size", "all", and "none".')
44
-        ifelse(continuous,
45
-               warning_wrap('It was set to TRUE, it should be replaced with "color" (or "colour"), 
46
-                            this meaning the aesthethic of "color" (or "colour") is continuous.'),
47
-               warning_wrap('It was set to FALSE, it should be replaced with "none", 
48
-                            this meaning the aesthethic of "color" (or "colour") or "size" will not be continuous.')
49
-        )
42
+        cli::cli_warn(c("The type of {.code continuous} argument was changed (v>=2.5.2). Now,", 
43
+                        "i" = "Consider using {.code continuous = \"color\"}, {.code continuous = \"colour\"}, ", 
44
+                        "{.code continuous = \"size\"}, {.code continuous = \"all\"} or",
45
+                        " {.code continuous = \"none\"} instead."))
50 46
         continuous <- ifelse(continuous, "color", "none")
51 47
     }
52 48
     continuous <- match.arg(continuous, c("color", "colour", "size", "none", "all"))
... ...
@@ -100,7 +100,7 @@ nodebar <- function(data, cols, color, alpha=1, position="stack") {
100 100
                                      theme_inset()
101 101
                    )
102 102
 
103
-    if (missingArg(color) || is.null(color) || is.na(color)) {
103
+    if (missingArg(color) || is.null(color) || any(is.na(color))) {
104 104
         ## do nothing
105 105
     } else {
106 106
         bars <- lapply(bars, function(p) p+scale_fill_manual(values=color))
... ...
@@ -345,8 +345,9 @@ ggplot_add.cladelab <- function(object, plot, object_name){
345 345
                 samevars <- Reduce(intersect,list(extract_all_aes_var(object$mapping), colnames(plot$data), colnames(object$data)))
346 346
                 object$data <- merge(object$data, plot$data, by.x=quo_name(object$mapping$node), by.y="node", all.x=TRUE)
347 347
                 if (length(samevars) > 0){
348
-                    warning_wrap('The "', paste(samevars, collapse=", ") ,'" has(have) been found in tree data. You might need to 
349
-                                 rename the variable(s) in the data of "geom_cladelab" to avoid this warning!')
348
+                    cli_alert_warning(text=c('The "', paste(samevars, collapse=", ") ,'" has(have) been found in tree data. You might need to 
349
+                                 rename the variable(s) in the data of "geom_cladelab" to avoid this warning!'),
350
+                                 wrap = TRUE)
350 351
                     object$mapping <- remapping(mapping=object$mapping, samevars=samevars)
351 352
                 }
352 353
             }
... ...
@@ -504,8 +505,10 @@ ggplot_add.hilight <- function(object, plot, object_name){
504 505
                      samevars <- Reduce(intersect,list(extract_all_aes_var(object$mapping), colnames(plot$data), colnames(object$data)))
505 506
                      object$data <- merge(object$data, plot$data, by.x=quo_name(object$mapping$node), by.y="node", all.x=TRUE)
506 507
                      if (length(samevars) > 0){
507
-                         warning_wrap('The "', paste(samevars, collapse=", ") ,'" has(have) been found in tree data. You might need to 
508
-                                      rename the variable(s) in the data of "geom_hilight" to avoid this warning!')
508
+                         cli_alert_warning(text=c('The "', paste(samevars, collapse=", ") ,'" has(have) been found in tree data. You might need to 
509
+                                      rename the variable(s) in the data of "geom_hilight" to avoid this warning!'),
510
+                                      wrap = TRUE
511
+                                     )
509 512
                          object$mapping <- remapping(mapping=object$mapping, samevars=samevars)
510 513
                      }
511 514
                  }
... ...
@@ -42,7 +42,9 @@ layoutEqualAngle <- function(model, branch.length = "branch.length"){
42 42
 
43 43
   if (! is.null(tree$edge.length)) {
44 44
       if (anyNA(tree$edge.length)) {
45
-          warning("'edge.length' contains NA values...\n## setting 'edge.length' to NULL automatically when plotting the tree...")
45
+          cli_alert_warning(c("{.code edge.length} contains NA values...",
46
+                          "## setting {.code edge.length} of the tree to NULL ",
47
+                          "automatically when plotting the tree..."), wrap = TRUE)
46 48
           tree$edge.length <- NULL
47 49
       }
48 50
   }
... ...
@@ -771,12 +773,10 @@ getXcoord2 <- function(x, root, parent, child, len, start=0, rev=FALSE) {
771 773
     ignore_negative_edge <- getOption("ignore.negative.edge", default=FALSE)
772 774
 
773 775
     if (any(len < 0) && !ignore_negative_edge) {
774
-        warning_wrap("The tree contained negative ", 
775
-                     ifelse(sum(len < 0)>1, "edge lengths", "edge length"),
776
-                     ". If you want to ignore the ", 
777
-                     ifelse(sum(len<0) > 1, "edges", "edge"),
778
-                     ", you can set 'options(ignore.negative.edge=TRUE)', then re-run ggtree."
779
-                     )
776
+        cli_alert_warning(c("The tree contained negative ", ifelse(sum(len < 0)>1, "edge lengths", "edge length"), 
777
+                        ". If you want to ignore the ", ifelse(sum(len<0) > 1, "edges", "edge"), ", you can 
778
+                        set {.code options(ignore.negative.edge=TRUE)}, then re-run ggtree."
779
+                     ), wrap = TRUE)
780 780
     }
781 781
     while(anyNA(x)) {
782 782
         idx <- which(parent %in% currentNode)