Browse code

as.polytomy

git-svn-id: file:///home/git/hedgehog.fhcrc.org/bioconductor/trunk/madman/Rpacks/ggtree@121115 bc3139a8-67e5-0310-9ffc-ced21a209358

Guangchuang Yu authored on 19/09/2016 07:21:18
Showing9 changed files

... ...
@@ -1,7 +1,7 @@
1 1
 Package: ggtree
2 2
 Type: Package
3 3
 Title: an R package for visualization and annotation of phylogenetic trees with their covariates and other associated data
4
-Version: 1.5.13
4
+Version: 1.5.14
5 5
 Author: Guangchuang Yu and Tommy Tsan-Yuk Lam
6 6
 Maintainer: Guangchuang Yu <guangchuangyu@gmail.com>
7 7
 Description: 'ggtree' extends the 'ggplot2' plotting system which implemented the grammar of graphics.
... ...
@@ -35,6 +35,7 @@ export(add_colorbar)
35 35
 export(annotation_image)
36 36
 export(apeBoot)
37 37
 export(as.binary)
38
+export(as.polytomy)
38 39
 export(collapse)
39 40
 export(decimal2Date)
40 41
 export(download.phylopic)
... ...
@@ -152,6 +153,7 @@ exportMethods(scale_color)
152 153
 exportMethods(show)
153 154
 importFrom(ape,Nnode)
154 155
 importFrom(ape,Ntip)
156
+importFrom(ape,di2multi)
155 157
 importFrom(ape,drop.tip)
156 158
 importFrom(ape,extract.clade)
157 159
 importFrom(ape,getMRCA)
... ...
@@ -1,3 +1,10 @@
1
+CHANGES IN VERSION 1.5.14
2
+------------------------
3
+ o update angle calculation for geom_tiplab <2016-09-13, Thu>
4
+ o as.polytomy to collapse binary tree to polytomy by applying 'fun' to selected 'feature' (e.g. bootstrap value less than 70). <2016-09-13, Tue>
5
+   + currently only phylo object supported.
6
+   + add test for as.polytomy
7
+   
1 8
 CHANGES IN VERSION 1.5.13
2 9
 ------------------------
3 10
  o facet_plot for plotting data with tree <2016-09-06, Tue>
4 11
new file mode 100644
... ...
@@ -0,0 +1,43 @@
1
+
2
+##' collapse binary tree to polytomy by applying 'fun' to 'feature'
3
+##'
4
+##' 
5
+##' @title as.polytomy
6
+##' @param tree tree object
7
+##' @param feature selected feature
8
+##' @param fun function to select nodes to collapse
9
+##' @return polytomy tree
10
+##' @author Guangchuang
11
+##' @importFrom ape Ntip
12
+##' @importFrom ape di2multi
13
+##' @export
14
+as.polytomy <- function(tree, feature, fun) {
15
+    if (!is(tree, 'phylo')) {
16
+        stop("currently only 'phylo' object is supported...")
17
+    }
18
+    
19
+    df <- fortify(tree)
20
+    phylo <- get.tree(tree)
21
+    
22
+    if (feature == 'node.label') {
23
+        feat <- df[!df$isTip, 'label']
24
+    } else if (feature == 'tip.label') {
25
+        feat <- df[df$isTip, 'label']
26
+    } else {
27
+        feat <- df[, feature]
28
+    }
29
+    
30
+    idx <- which(fun(feat))
31
+    if (feature == 'node.label') {
32
+        nodes <- Ntip(phylo) + df$node[idx]
33
+    } else {
34
+        nodes <- df$node[idx]
35
+    }
36
+    edge_idx <- match(nodes, phylo$edge[,2])
37
+    phylo$edge.length[edge_idx] <- 0
38
+    poly_tree <- di2multi(phylo)
39
+    ## 
40
+    ## map stats to poly_tree and update tree object
41
+    ##
42
+    return(poly_tree)
43
+}
... ...
@@ -557,16 +557,16 @@ as.data.frame.phylo_ <- function(x, layout="rectangular",
557 557
     ## add branch mid position
558 558
     res <- calculate_branch_mid(res)
559 559
 
560
-    ## angle for all layout, if 'rectangular', user use coord_polar, can still use angle
561
-    ## if (layout == "circular") {
562
-    idx <- match(1:N, order(res$y))
563
-    ## angle <- -360/(3+N) * (1:N+1)
564
-    angle <- 360/(3+N) * (1:N+1)
565
-    angle <- angle[idx]
566
-    ## res$angle <- angle + 90
567
-    res$angle <- angle
560
+    ## ## angle for all layout, if 'rectangular', user use coord_polar, can still use angle
561
+    ## ## if (layout == "circular") {
562
+    ## idx <- match(1:N, order(res$y))
563
+    ## ## angle <- -360/(3+N) * (1:N+1)
564
+    ## angle <- 360/(3+N) * (1:N+1)
565
+    ## angle <- angle[idx]
566
+    ## ## res$angle <- angle + 90
567
+    ## res$angle <- angle
568 568
     ## } 
569
-    
569
+    res$angle <- 360/(diff(range(res$y)) + 1) * res$y
570 570
     return(res)
571 571
 }
572 572
 
... ...
@@ -100,7 +100,7 @@
100 100
 ##' @author Guangchuang Yu
101 101
 `%+>%` <- function(p, data) {
102 102
     df <- p$data
103
-    res <- merge(df[, c('label', 'y')], data, by.x='label', by.y=1, all.x=TRUE)
103
+    res <- merge(df[, c('label', 'y')], data, by.x='label', by.y=1) ## , all.x=TRUE)
104 104
     lv <- levels(df$panel)
105 105
     res$panel <- factor(lv[length(lv)], levels=lv)
106 106
     return(res)
... ...
@@ -1,9 +1,9 @@
1 1
 ggtree: an R package for visualization and annotation of phylogenetic trees with their covariates and other associated data
2 2
 ===========================================================================================================================
3 3
 
4
-[![releaseVersion](https://img.shields.io/badge/release%20version-1.4.20-green.svg?style=flat)](https://bioconductor.org/packages/ggtree) [![develVersion](https://img.shields.io/badge/devel%20version-1.5.13-green.svg?style=flat)](https://github.com/GuangchuangYu/ggtree) [![Bioc](http://www.bioconductor.org/shields/years-in-bioc/ggtree.svg)](https://www.bioconductor.org/packages/devel/bioc/html/ggtree.html#since) [![total](https://img.shields.io/badge/downloads-12850/total-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree) [![month](https://img.shields.io/badge/downloads-1122/month-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree)
4
+[![releaseVersion](https://img.shields.io/badge/release%20version-1.4.20-green.svg?style=flat)](https://bioconductor.org/packages/ggtree) [![develVersion](https://img.shields.io/badge/devel%20version-1.5.14-green.svg?style=flat)](https://github.com/GuangchuangYu/ggtree) [![Bioc](http://www.bioconductor.org/shields/years-in-bioc/ggtree.svg)](https://www.bioconductor.org/packages/devel/bioc/html/ggtree.html#since) [![total](https://img.shields.io/badge/downloads-13115/total-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree) [![month](https://img.shields.io/badge/downloads-1122/month-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree)
5 5
 
6
-[![Project Status: Active - The project has reached a stable, usable state and is being actively developed.](http://www.repostatus.org/badges/latest/active.svg)](http://www.repostatus.org/#active) [![codecov](https://codecov.io/gh/GuangchuangYu/ggtree/branch/master/graph/badge.svg)](https://codecov.io/gh/GuangchuangYu/ggtree) [![Last-changedate](https://img.shields.io/badge/last%20change-2016--09--07-green.svg)](https://github.com/GuangchuangYu/ggtree/commits/master) [![GitHub forks](https://img.shields.io/github/forks/GuangchuangYu/ggtree.svg)](https://github.com/GuangchuangYu/ggtree/network) [![GitHub stars](https://img.shields.io/github/stars/GuangchuangYu/ggtree.svg)](https://github.com/GuangchuangYu/ggtree/stargazers) [![Awesome](https://cdn.rawgit.com/sindresorhus/awesome/d7305f38d29fed78fa85652e3a63e154dd8e8829/media/badge.svg)](https://awesome-r.com/#awesome-r-graphic-displays)
6
+[![Project Status: Active - The project has reached a stable, usable state and is being actively developed.](http://www.repostatus.org/badges/latest/active.svg)](http://www.repostatus.org/#active) [![codecov](https://codecov.io/gh/GuangchuangYu/ggtree/branch/master/graph/badge.svg)](https://codecov.io/gh/GuangchuangYu/ggtree) [![Last-changedate](https://img.shields.io/badge/last%20change-2016--09--13-green.svg)](https://github.com/GuangchuangYu/ggtree/commits/master) [![GitHub forks](https://img.shields.io/github/forks/GuangchuangYu/ggtree.svg)](https://github.com/GuangchuangYu/ggtree/network) [![GitHub stars](https://img.shields.io/github/stars/GuangchuangYu/ggtree.svg)](https://github.com/GuangchuangYu/ggtree/stargazers) [![Awesome](https://cdn.rawgit.com/sindresorhus/awesome/d7305f38d29fed78fa85652e3a63e154dd8e8829/media/badge.svg)](https://awesome-r.com/#awesome-r-graphic-displays)
7 7
 
8 8
 [![platform](http://www.bioconductor.org/shields/availability/devel/ggtree.svg)](https://www.bioconductor.org/packages/devel/bioc/html/ggtree.html#archives) [![Build Status](http://www.bioconductor.org/shields/build/devel/bioc/ggtree.svg)](https://bioconductor.org/checkResults/devel/bioc-LATEST/ggtree/) [![Linux/Mac Travis Build Status](https://img.shields.io/travis/GuangchuangYu/ggtree/master.svg?label=Mac%20OSX%20%26%20Linux)](https://travis-ci.org/GuangchuangYu/ggtree) [![AppVeyor Build Status](https://img.shields.io/appveyor/ci/Guangchuangyu/ggtree/master.svg?label=Windows)](https://ci.appveyor.com/project/GuangchuangYu/ggtree) [![install with bioconda](https://img.shields.io/badge/install%20with-bioconda-green.svg?style=flat)](http://bioconda.github.io/recipes/bioconductor-ggtree/README.html)
9 9
 
... ...
@@ -17,7 +17,7 @@ Please cite the following article when using `ggtree`:
17 17
 
18 18
 **G Yu**, DK Smith, H Zhu, Y Guan, TTY Lam<sup>\*</sup>. ggtree: an R package for visualization and annotation of phylogenetic trees with their covariates and other associated data. ***Methods in Ecology and Evolution***. *accepted*
19 19
 
20
-[![doi](https://img.shields.io/badge/doi-10.1111/2041--210X.12628-green.svg?style=flat)](http://dx.doi.org/10.1111/2041-210X.12628) [![Altmetric](https://img.shields.io/badge/Altmetric-140-green.svg?style=flat)](https://www.altmetric.com/details/10533079)
20
+[![doi](https://img.shields.io/badge/doi-10.1111/2041--210X.12628-green.svg?style=flat)](http://dx.doi.org/10.1111/2041-210X.12628) [![Altmetric](https://img.shields.io/badge/Altmetric-148-green.svg?style=flat)](https://www.altmetric.com/details/10533079)
21 21
 
22 22
 ------------------------------------------------------------------------
23 23
 
... ...
@@ -30,7 +30,7 @@ For details, please visit our project website, <https://guangchuangyu.github.io/
30 30
 
31 31
 ### Download stats
32 32
 
33
-[![download](http://www.bioconductor.org/shields/downloads/ggtree.svg)](https://bioconductor.org/packages/stats/bioc/ggtree/) [![total](https://img.shields.io/badge/downloads-12850/total-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree) [![month](https://img.shields.io/badge/downloads-1122/month-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree)
33
+[![download](http://www.bioconductor.org/shields/downloads/ggtree.svg)](https://bioconductor.org/packages/stats/bioc/ggtree/) [![total](https://img.shields.io/badge/downloads-13115/total-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree) [![month](https://img.shields.io/badge/downloads-1122/month-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree)
34 34
 
35 35
          +--------------------------+--------------------------+--------------------------+------------+
36 36
          |                                                                               *             |
37 37
new file mode 100644
... ...
@@ -0,0 +1,25 @@
1
+% Generated by roxygen2: do not edit by hand
2
+% Please edit documentation in R/as.polytomy.R
3
+\name{as.polytomy}
4
+\alias{as.polytomy}
5
+\title{as.polytomy}
6
+\usage{
7
+as.polytomy(tree, feature, fun)
8
+}
9
+\arguments{
10
+\item{tree}{tree object}
11
+
12
+\item{feature}{selected feature}
13
+
14
+\item{fun}{function to select nodes to collapse}
15
+}
16
+\value{
17
+polytomy tree
18
+}
19
+\description{
20
+collapse binary tree to polytomy by applying 'fun' to 'feature'
21
+}
22
+\author{
23
+Guangchuang
24
+}
25
+
0 26
new file mode 100644
... ...
@@ -0,0 +1,10 @@
1
+context('as.polytomy')
2
+
3
+test_that('collapse tree to polytomy', {
4
+    file <- system.file("extdata/RAxML", "RAxML_bipartitions.H3", package="ggtree")
5
+    tree <- read.tree(file)
6
+    cutoff <- 70
7
+    tree2 <- as.polytomy(tree, 'node.label', function(x) as.numeric(x) < cutoff)
8
+    expect_true(all(as.numeric(tree2$node.label) > 70, na.rm=T))
9
+})
10
+