Browse code

Merge branch 'master' into dev_for_new_ggplot2

xiangpin authored on 23/08/2022 12:39:47
Showing15 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.5.1.901
4
+Version: 3.5.2.992
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")),
... ...
@@ -37,7 +37,8 @@ Imports:
37 37
     tidytree (>= 0.3.9),
38 38
     treeio (>= 1.8.0),
39 39
     utils,
40
-    scales
40
+    scales,
41
+    stats
41 42
 Suggests:
42 43
     emojifont,
43 44
     ggimage,
... ...
@@ -47,7 +48,6 @@ Suggests:
47 48
     knitr,
48 49
     prettydoc,
49 50
     rmarkdown,
50
-    stats,
51 51
     testthat,
52 52
     tibble,
53 53
     glue
... ...
@@ -57,10 +57,10 @@ VignetteBuilder: knitr
57 57
 ByteCompile: true
58 58
 Encoding: UTF-8
59 59
 License: Artistic-2.0
60
-URL: https://yulab-smu.top/treedata-book/ (book), http://onlinelibrary.wiley.com/doi/10.1111/2041-210X.12628 (paper)
60
+URL: https://www.amazon.com/Integration-Manipulation-Visualization-Phylogenetic-Computational-ebook/dp/B0B5NLZR1Z/ (book), http://onlinelibrary.wiley.com/doi/10.1111/2041-210X.12628 (paper)
61 61
 BugReports: https://github.com/YuLab-SMU/ggtree/issues
62 62
 Packaged: 2014-12-03 08:16:14 UTC; root
63 63
 biocViews: Alignment, Annotation, Clustering, DataImport,
64 64
     MultipleSequenceAlignment, Phylogenetics, ReproducibleResearch, Software, Visualization
65
-RoxygenNote: 7.2.0
65
+RoxygenNote: 7.2.1
66 66
 Roxygen: list(markdown = TRUE)
... ...
@@ -7,6 +7,7 @@ S3method(fortify,dendrogram)
7 7
 S3method(fortify,diana)
8 8
 S3method(fortify,hclust)
9 9
 S3method(fortify,igraph)
10
+S3method(fortify,linkage)
10 11
 S3method(fortify,multiPhylo)
11 12
 S3method(fortify,obkData)
12 13
 S3method(fortify,phylo)
... ...
@@ -268,6 +269,8 @@ importFrom(rlang,abort)
268 269
 importFrom(rlang,as_name)
269 270
 importFrom(rlang,quo_name)
270 271
 importFrom(scales,alpha)
272
+importFrom(stats,as.hclust)
273
+importFrom(stats,cutree)
271 274
 importFrom(tidyr,gather)
272 275
 importFrom(tidytree,MRCA)
273 276
 importFrom(tidytree,ancestor)
... ...
@@ -24,11 +24,18 @@
24 24
   - <https://github.com/thomasp85/ggraph/commit/14de66f1225336179b4598cb42a4beda95682211>
25 25
 
26 26
 -->
27
+# ggtree 3.5.2.992
27 28
 
28
-# ggtree 3.5.1.901
29
++ update `fortify` method for `pvclust` object (2022-08-15, Mon)
30
++ add citation of the tree data book (2022-08-13, Sat)
29 31
 
32
+# ggtree 3.5.2
33
+
34
++ `scale_color_subtree()` now supports passing a numeric value and internally it will call `cutree(tree, k)` (2022-08-11, Thu)
35
++ support 'linkage' class defined in the 'mdendro' package (2022-08-11, Thu)
36
++ clone the plot environment before assigning layout (2022-07-19, Tue, #516)
30 37
 + bug fixed in 'equal_angle' layout (2022-07-08, Fri, #514)
31
-+ optimize `geom_tiplab` to better compatible with dendrogram layout (2022-06-23, Thu)
38
++ optimize `geom_tiplab` to better compatible with dendrogram layout (2022-06-23, Thu, #508)
32 39
 
33 40
 # ggtree 3.5.1
34 41
 
... ...
@@ -113,6 +113,9 @@ scale_x_range <- function() {
113 113
 ##' p2 + scale_x_continuous(labels=abs)
114 114
 ##' @author Guangchuang Yu
115 115
 revts <- function(treeview) {
116
+    if (!is.null(attr(treeview$data, 'revts.done'))){
117
+         return(treeview)
118
+    }
116 119
     x <- treeview$data$x
117 120
     mx <- max(x, na.rm=TRUE)
118 121
     treeview$data$x <- x - mx
... ...
@@ -32,6 +32,22 @@ scaleY <- function(phylo, df, yscale, layout, ...) {
32 32
 }
33 33
 
34 34
 
35
+adjust_hclust_tip.edge.len <- function(df, phylo){
36
+    if (inherits(phylo, 'treedata')){
37
+        tip.edge.len <- attr(phylo@phylo, 'tip.edge.len')
38
+    }else{
39
+        tip.edge.len <- attr(phylo, 'tip.edge.len')
40
+    }
41
+    if (!is.null(tip.edge.len)){
42
+        mx <- max(df$x, na.rm=TRUE)
43
+        df$x <- df$x - mx
44
+        df$branch <- df$branch - mx
45
+        df[df$isTip, "x", drop=TRUE] <- tip.edge.len
46
+        attr(df, 'revts.done') = TRUE
47
+    }                       
48
+    return(df)
49
+}
50
+
35 51
 ##
36 52
 ##
37 53
 ## old version of fortify.phylo
... ...
@@ -205,6 +205,9 @@ GeomCurvelink <- ggproto("GeomCurvelink", GeomSegment,
205 205
         trans$curvature <- curvature
206 206
     }else{
207 207
         trans <- coord$transform(data, panel_params)
208
+        if (inherits(coord, 'CoordFlip')){ 
209
+            trans$curvature <- -1 * trans$curvature
210
+        }
208 211
     }
209 212
     arrow.fill <- arrow.fill %|||% trans$colour
210 213
 
... ...
@@ -226,6 +229,7 @@ GeomCurvelink <- ggproto("GeomCurvelink", GeomSegment,
226 229
   }
227 230
 )
228 231
 
232
+
229 233
 # for inward curve lines
230 234
 generate_curvature <- function(starttheta, endtheta, hratio, ncp){
231 235
     flag <- endtheta - starttheta
... ...
@@ -17,6 +17,9 @@
17 17
 ##' @param root.position position of the root node (default = 0)
18 18
 ##' @param xlim x limits, only works for 'inward_circular' layout
19 19
 ##' @param layout.params list, the parameters of layout, when layout is a function.
20
+##' @param hang numeric The fraction of the tree plot height by which labels should hang 
21
+##' below the rest of the plot. A negative value will cause the labels to hang down from 0. This
22
+##' parameter only work with the 'dendrogram' layout for 'hclust' like class, default is 0.1.
20 23
 ##' @return tree
21 24
 ##' @importFrom ggplot2 ggplot
22 25
 ##' @importFrom ggplot2 xlab
... ...
@@ -59,6 +62,7 @@ ggtree <- function(tr,
59 62
                    root.position  = 0,
60 63
                    xlim = NULL,
61 64
                    layout.params = list(),
65
+                   hang = .1,
62 66
                    ...) {
63 67
 
64 68
     # Check if layout string is valid.
... ...
@@ -102,6 +106,7 @@ ggtree <- function(tr,
102 106
                 right         = right,
103 107
                 branch.length = branch.length,
104 108
                 root.position = root.position,
109
+                hang          = hang,
105 110
                 ...)
106 111
 
107 112
     if (!is.null(dd)){
... ...
@@ -15,6 +15,7 @@
15 15
 rotate_tree <- function(treeview, angle) {
16 16
     treeview <- treeview + coord_polar(theta='y', start=(angle-90)/180*pi, -1)
17 17
     treeview$data$angle <- treeview$data$angle + angle
18
+    treeview$plot_env <- build_new_plot_env(treeview$plot_env)
18 19
     assign("layout", "circular", envir = treeview$plot_env)
19 20
     return(treeview)
20 21
 }
... ...
@@ -46,6 +47,7 @@ open_tree <- function(treeview, angle) {
46 47
     angle <- 360/(2+NN) * (1:N+1)
47 48
     angle <- angle[idx]
48 49
     p$data$angle <- angle
50
+    p$plot_env <- build_new_plot_env(p$plot_env)
49 51
     assign("layout", "fan", envir = p$plot_env)
50 52
     return(p)
51 53
 }
... ...
@@ -68,6 +68,7 @@ fortify.phylo <- function(model, data,
68 68
         res <- calculate_angle(res)
69 69
     }
70 70
     res <- scaleY(as.phylo(model), res, yscale, layout, ...)
71
+    res <- adjust_hclust_tip.edge.len(res, x)
71 72
     class(res) <- c("tbl_tree", class(res))
72 73
     attr(res, "layout") <- layout
73 74
     return(res)
... ...
@@ -133,13 +134,15 @@ fortify.phylo4 <- function(model, data,
133 134
                            ladderize = TRUE,
134 135
                            right     = FALSE,
135 136
                            mrsd      = NULL,
137
+                           hang      = .1,
136 138
                            ...) {
137
-    if (inherits(model, c("dendrogram", "agnes", "diana", "twins"))) {
139
+    if (inherits(model, c("dendrogram", "linkage", 
140
+                        "agnes", "diana", "twins"))) {
138 141
         model <- stats::as.hclust(model)
139 142
     }
140 143
 
141 144
     if (inherits(model, "hclust")) {
142
-        phylo <- as.phylo.hclust2(model)
145
+        phylo <- as.phylo.hclust2(model, hang = hang)
143 146
     } else {
144 147
         phylo <- as.phylo(model)
145 148
     }
... ...
@@ -181,6 +184,9 @@ fortify.phylog <- fortify.phylo4
181 184
 ##' @export
182 185
 fortify.igraph <- fortify.phylo4
183 186
 
187
+##' @method fortify linkage
188
+##' @export
189
+fortify.linkage <- fortify.phylo4
184 190
 
185 191
 ##' @method fortify phylo4d
186 192
 ##' @importFrom treeio as.treedata
... ...
@@ -192,8 +198,11 @@ fortify.phylo4d <- function(model, data,
192 198
                             right         = FALSE,
193 199
                             branch.length = "branch.length",
194 200
                             mrsd          = NULL,
201
+							hang          = 0.1,
195 202
                             ...) {
196
-    fortify(as.treedata(model), data, layout, yscale, ladderize, right, branch.length, mrsd, ...)
203
+    model <- as.treedata(model, hang = hang)
204
+    df <- fortify(model, data, layout, yscale, ladderize, right, branch.length, mrsd, ...)
205
+    return (df)
197 206
 }
198 207
 
199 208
 ##' @method fortify pvclust
... ...
@@ -100,7 +100,7 @@ ggplot_add.layout_ggtree <- function(object, plot, object_name) {
100 100
 
101 101
     if (object$layout == 'dendrogram') {
102 102
         plot <- revts(plot)
103
-        obj <- list(scale_x_reverse(labels = abs),
103
+        obj <- list(scale_x_reverse(labels = function(x){-x}),
104 104
                     coord_flip(clip = 'off')
105 105
                     )
106 106
     } else if (object$layout == 'circular' || object$layout == "inward_circular") {
... ...
@@ -115,8 +115,10 @@ ggplot_add.layout_ggtree <- function(object, plot, object_name) {
115 115
     } else { ## rectangular
116 116
         obj <- coord_cartesian(clip = 'off')
117 117
     }
118
+    plot <- ggplot_add(obj, plot, object_name)
119
+    plot$plot_env <- build_new_plot_env(plot$plot_env)
118 120
     assign("layout", object$layout, envir = plot$plot_env)
119
-    ggplot_add(obj, plot, object_name)
121
+    return(plot)
120 122
 }
121 123
 
122 124
 
... ...
@@ -200,8 +202,16 @@ ggplot_add.facet_plot <- function(object, plot, object_name) {
200 202
 ##' @export
201 203
 ggplot_add.tiplab <- function(object, plot, object_name) {
202 204
     layout <- get_layout(plot)
203
-    if (layout == 'dendrogram' && object$hjust == 0 ){
204
-        object$hjust <- .5
205
+    if (layout == 'dendrogram'){
206
+        if( object$hjust == 0 ){
207
+            object$hjust = 1
208
+        }
209
+        if (!'vjust' %in% names(object)){
210
+            object$vjust = .5
211
+        }
212
+        if (!'angle' %in% names(object)){
213
+            object$angle = 90
214
+        }
205 215
     }
206 216
     if (object$as_ylab) {
207 217
         if (layout != "rectangular" && layout != "dendrogram") {
... ...
@@ -214,11 +224,11 @@ ggplot_add.tiplab <- function(object, plot, object_name) {
214 224
         ly <- do.call(geom_tiplab_rectangular, object)
215 225
         plot <- ggplot_add(ly, plot, object_name)
216 226
         object$size <- fontsize
217
-        object$mapping <- NULL
227
+        #object$mapping <- NULL
218 228
         object$align <- NULL
219 229
         object$linetype <- NULL
220 230
         object$linesize <- NULL
221
-        object$geom <- NULL
231
+        #object$geom <- NULL
222 232
         object$offset <- NULL
223 233
         object$nodelab <- NULL
224 234
         res <- ggplot_add.tiplab_ylab(object, plot, object_name)
... ...
@@ -249,11 +259,30 @@ ggplot_add.tiplab_ylab <- function(object, plot, object_name) {
249 259
     }
250 260
 
251 261
     df <- plot$data
252
-    df <- df[df$isTip, ]
262
+    if ('label' %in% names(object$mapping)){
263
+        if (object$geom == 'text'){
264
+            xx <- do.call('geom_text', list(mapping=object$mapping))
265
+            xx$computed_mapping <- c(xx$mapping, plot$mapping[setdiff(names(plot$mapping), names(xx$mapping))])
266
+            class(xx$computed_mapping) <- "uneval"
267
+            if (!is.null(object$data)){
268
+                df <- object$data
269
+            }else{
270
+                df <- df[df$isTip,]
271
+            }
272
+            df <- suppressWarnings(xx$compute_aesthetics(data=df, plot=plot))
273
+        }else{
274
+            message('The geom is not text, as_ylab will use original tip labels of tree')
275
+            df <- df[df$isTip, ]
276
+        }
277
+    }else{
278
+        df <- df[df$isTip, ]
279
+    }
253 280
     yscale <- scale_y_continuous(breaks = df$y, labels = df$label,
254 281
                                  position = object$position, expand = expansion(0, 0.6))
255 282
 
256 283
     object$position <- NULL
284
+    object$mapping <- NULL
285
+    object$geom <- NULL
257 286
     object$node <- NULL
258 287
     ytext <- do.call(element_text, object)
259 288
 
... ...
@@ -518,6 +547,9 @@ ggplot_add.hilight <- function(object, plot, object_name){
518 547
         if (flag_tbl_tree){
519 548
             object$data <-  object$data[,!colnames(object$data) %in% setdiff(flag_names, as_name(object$mapping$node)),drop=FALSE]
520 549
         }
550
+        object$data <- object$data[, !colnames(object$data) %in% setdiff(intersect(colnames(object$data), 
551
+                                                                     colnames(data)), 
552
+                                                                     as_name(object$mapping$node)), drop=FALSE]
521 553
         object$data <- merge(data, object$data, by.x="clade_root_node", by.y=as_name(object$mapping$node))
522 554
         object$data[[as_name(object$mapping$node)]] <- as.vector(object$data$clade_root_node)
523 555
         object$mapping <- object$mapping[!names(object$mapping) %in% c("node")]
... ...
@@ -10,7 +10,7 @@
10 10
 scale_color_subtree <- function(group) {
11 11
     if (inherits(group, 'kmeans')) {
12 12
         group <- group$cluster
13
-    }
13
+    } 
14 14
 
15 15
     structure(group,
16 16
               class = 'color_subtree'
... ...
@@ -18,10 +18,17 @@ scale_color_subtree <- function(group) {
18 18
 }
19 19
 
20 20
 ##' @rdname scale-color-subtree
21
+##' @importFrom stats as.hclust
22
+##' @importFrom stats cutree
21 23
 ##' @export
22 24
 scale_colour_subtree <- scale_color_subtree
23 25
 
24
-scale_color_subtree_ <- function(p, group) {    
26
+scale_color_subtree_ <- function(p, group) {
27
+
28
+    if (is.numeric(group) && length(group) == 1) {
29
+        group <- cutree(as.hclust(as.phylo(p$data)), group)
30
+    } 
31
+
25 32
     g <- split(names(group), group)
26 33
     groupOTU(p, g, group_name = 'subtree') +
27 34
         aes_(color = ~subtree)
... ...
@@ -1355,14 +1355,21 @@ as.phylo.hclust2 <- function(x, hang=0.1, ...) {
1355 1355
     }
1356 1356
   }
1357 1357
 
1358
-  len <- numeric(max(tr$edge))
1359
-  len[nodes] <- h$height
1360
-  pn <- ev[nodes]
1361
-  pn[pn == 0] <- treeio::rootnode(tr)
1362
-  len[nodes] <- len[pn] - len[nodes]
1363
-  len[1:Ntip(tr)] <- hang #max(h$height)/10
1364
-
1365
-  tr$edge.length <- len[tr$edge[,2]]
1358
+  #len <- numeric(max(tr$edge))
1359
+  #len[nodes] <- h$height
1360
+  #pn <- ev[nodes]
1361
+  #pn[pn == 0] <- treeio::rootnode(tr)
1362
+  #len[nodes] <- len[pn] - len[nodes]
1363
+  #len[1:Ntip(tr)] <- hang #max(h$height)/10
1364
+
1365
+  #tr$edge.length <- len[tr$edge[,2]]
1366
+
1367
+  tip2parent <- tr$edge[match(seq_len(Ntip(tr)), tr$edge[,2]), 1]
1368
+  if (hang > 0){
1369
+    tip.edge.len <- hang * max(h$height) - h$height[match(tip2parent, nodes)]
1370
+    attr(tr,'tip.edge.len') <- tip.edge.len
1371
+  }
1372
+  tr$edge.length <- tr$edge.length * 2
1366 1373
   return(tr)
1367 1374
 }
1368 1375
 
... ...
@@ -1,5 +1,4 @@
1 1
 
2
-
3 2
 ##' @importFrom ggplot2 last_plot
4 3
 get_tree_view <- function(tree_view) {
5 4
     if (is.null(tree_view))
... ...
@@ -17,6 +16,18 @@ get_layout <- function(tree_view = NULL) {
17 16
     return(layout)
18 17
 }
19 18
 
19
+build_new_plot_env <- function(env){
20
+    newenv <- list2env(
21
+                x = as.list(
22
+                  env, 
23
+                  all.names = TRUE
24
+                ), 
25
+                parent = parent.env(env)
26
+              )
27
+    attributes(newenv) <- attributes(env)
28
+    return(newenv)
29
+}
30
+
20 31
 reverse.treeview <- function(tv) {
21 32
     tv$data <- reverse.treeview.data(tv$data)
22 33
     return(tv)
... ...
@@ -1,5 +1,18 @@
1 1
 citHeader("To cite ggtree in publications use:")
2 2
 
3
+citEntry(
4
+    entry  = "book",
5
+    title = "Data Integration, Manipulation and Visualization of Phylogenetic Treess",
6
+    author = person("Guangchuang", "Yu"),
7
+	publisher = "Chapman and Hall/{CRC}",
8
+    year = "2022",
9
+	edition = "1st edition",
10
+    url = "https://www.amazon.com/Integration-Manipulation-Visualization-Phylogenetic-Computational-ebook/dp/B0B5NLZR1Z/",
11
+    textVersion = paste("Guangchuang Yu. (2022).",
12
+                        "Data Integration, Manipulation and Visualization of Phylogenetic Trees (1st edition).",
13
+                        "Chapman and Hall/CRC.")   
14
+)
15
+
3 16
 citEntry(
4 17
     entry  = "article",
5 18
     title = "Using ggtree to Visualize Data on Tree-Like Structures",
... ...
@@ -22,6 +22,7 @@ ggtree(
22 22
   root.position = 0,
23 23
   xlim = NULL,
24 24
   layout.params = list(),
25
+  hang = 0.1,
25 26
   ...
26 27
 )
27 28
 }
... ...
@@ -57,6 +58,10 @@ right-hand side? See \code{\link[ape:ladderize]{ape::ladderize()}} for more info
57 58
 
58 59
 \item{layout.params}{list, the parameters of layout, when layout is a function.}
59 60
 
61
+\item{hang}{numeric The fraction of the tree plot height by which labels should hang
62
+below the rest of the plot. A negative value will cause the labels to hang down from 0. This
63
+parameter only work with the 'dendrogram' layout for 'hclust' like class, default is 0.1.}
64
+
60 65
 \item{...}{additional parameter
61 66
 
62 67
 some dot arguments: