1. ggtree
  2. R
  3. merge_tree.R
Browse code

move code to treeio

guangchuang yu authored on 21/12/2016 08:57:38
Showing 1 changed files
R/merge_tree.R
History View file @ 1d7f426b
1 1 
deleted file mode 100644
... ... 
@@ -1,122 +0,0 @@
1 
-##' merge two tree object
2 
-##'
3 
-##'
4 
-##' @title merge_tree
5 
-##' @param obj1 tree object 1
6 
-##' @param obj2 tree object 2
7 
-##' @return tree object
8 
-##' @importFrom magrittr %<>%
9 
-##' @export
10 
-##' @author Guangchuang Yu
11 
-merge_tree <- function(obj1, obj2) {
12 
-    ##
13 
-    ## INFO:
14 
-    ## ape::all.equal.phylo can be used to test equal phylo topology.
15 
-    ##
16 
-
17 
-    if (has.slot(obj1, "extraInfo") == FALSE) {
18 
-        stop("input tree object is not supported...")
19 
-    }
20 
-
21 
-    if ((is.tree(obj1) & is.tree(obj2)) == FALSE) {
22 
-        stop("input should be tree objects...")
23 
-    }
24 
-
25 
-    tr1 <- get.tree(obj1)
26 
-    tr2 <- get.tree(obj2)
27 
-
28 
-    if (getNodeNum(tr1) != getNodeNum(tr2)) {
29 
-        stop("number of nodes not equals...")
30 
-    }
31 
-
32 
-    if (Ntip(tr1) != Ntip(tr2)) {
33 
-        stop("number of tips not equals...")
34 
-    }
35 
-
36 
-    if (all(tr1$tip.label %in% tr2$tip.label) == FALSE) {
37 
-        stop("tip names not match...")
38 
-    }
39 
-
40 
-
41 
-    ## order tip.label in tr2 as in tr1
42 
-    ## mapping corresponding ID
43 
-    idx <- match(tr2$tip.label, tr1$tip.label)
44 
-    tr2$edge[match(1:Ntip(tr2), tr2$edge[,2]), 2] <- idx
45 
-    tr2$tip.label <- tr1$tip.label
46 
-
47 
-    node_map <- list()
48 
-    node_map$from %<>% c(1:Ntip(tr2))
49 
-    node_map$to %<>% c(idx)
50 
-
51 
-    root <- getRoot(tr1)
52 
-    root.2 <- getRoot(tr2)
53 
-    tr2$edge[tr2$edge[,1] == root.2, 1] <-  root
54 
-
55 
-    node_map$from %<>% c(root.2)
56 
-    node_map$to %<>% c(root)
57 
-
58 
-
59 
-    currentNode <- 1:Ntip(tr1)
60 
-    while(length(currentNode)) {
61 
-        p1 <- sapply(currentNode, getParent, tr=tr1)
62 
-        p2 <- sapply(currentNode, getParent, tr=tr2)
63 
-
64 
-        if (length(p1) != length(p2)) {
65 
-            stop("trees are not identical...")
66 
-        }
67 
-
68 
-        jj <- match(p2, tr2$edge[,1])
69 
-        if (length(jj)) {
70 
-            notNA <- which(!is.na(jj))
71 
-            jj <- jj[notNA]
72 
-        }
73 
-        if (length(jj)) {
74 
-            tr2$edge[jj,1] <- p1[notNA]
75 
-        }
76 
-
77 
-
78 
-        ii <- match(p2, tr2$edge[,2])
79 
-        if (length(ii)) {
80 
-            notNA <- which(!is.na(ii))
81 
-            ii <- ii[notNA]
82 
-        }
83 
-        if (length(ii)) {
84 
-            tr2$edge[ii,2] <- p1[notNA]
85 
-        }
86 
-
87 
-        node_map$from %<>% c(p2)
88 
-        node_map$to %<>% c(p1)
89 
-
90 
-        ## parent of root will return 0, which is in-valid node ID
91 
-        currentNode <- unique(p1[p1 != 0])
92 
-    }
93 
-
94 
-    if ( any(tr2$edge != tr2$edge) ) {
95 
-        stop("trees are not identical...")
96 
-    }
97 
-
98 
-    node_map.df <- do.call("cbind", node_map)
99 
-    node_map.df <- unique(node_map.df)
100 
-    node_map.df <- node_map.df[node_map.df[,1] != 0,]
101 
-    i <- order(node_map.df[,1], decreasing = FALSE)
102 
-    node_map.df <- node_map.df[i,]
103 
-
104 
-    info2 <- fortify(obj2)
105 
-    info2$node <- node_map.df[info2$node, 2]
106 
-    info2$parent <- node_map.df[info2$parent, 2]
107 
-
108 
-    cn <- colnames(info2)
109 
-    i <- match(c("x", "y", "isTip", "label", "branch", "branch.length", "angle"), cn)
110 
-    i <- i[!is.na(i)]
111 
-    info2 <- info2[, -i]
112 
-
113 
-    extraInfo <- obj1@extraInfo
114 
-    if (nrow(extraInfo) == 0) {
115 
-        obj1@extraInfo <- info2
116 
-    } else {
117 
-        info <- merge(extraInfo, info2, by.x =c("node", "parent"), by.y = c("node", "parent"))
118 
-        obj1@extraInfo <- info
119 
-    }
120 
-
121 
-    return(obj1)
122 
-}
Browse code

fixed drop.tip issues

guangchuang yu authored on 11/11/2016 05:33:47
Showing 1 changed files
R/merge_tree.R
History View file @ 0b9c272f
... ... 
@@ -1,12 +1,11 @@
1 1 
 ##' merge two tree object
2 2 
 ##'
3 
-##'
3 
+##'
4 4 
 ##' @title merge_tree
5 5 
 ##' @param obj1 tree object 1
6 6 
 ##' @param obj2 tree object 2
7 7 
 ##' @return tree object
8 8 
 ##' @importFrom magrittr %<>%
9 
-##' @importFrom ape Ntip
10 9 
 ##' @export
11 10 
 ##' @author Guangchuang Yu
12 11 
 merge_tree <- function(obj1, obj2) {
... ... 
@@ -14,11 +13,11 @@ merge_tree <- function(obj1, obj2) {
14 13 
     ## INFO:
15 14 
     ## ape::all.equal.phylo can be used to test equal phylo topology.
16 15 
     ##
17 
-
16 
+
18 17 
     if (has.slot(obj1, "extraInfo") == FALSE) {
19 18 
         stop("input tree object is not supported...")
20 19 
     }
21 
-
20 
+
22 21 
     if ((is.tree(obj1) & is.tree(obj2)) == FALSE) {
23 22 
         stop("input should be tree objects...")
24 23 
     }
... ... 
@@ -33,7 +32,7 @@ merge_tree <- function(obj1, obj2) {
33 32 
     if (Ntip(tr1) != Ntip(tr2)) {
34 33 
         stop("number of tips not equals...")
35 34 
     }
36 
-
35 
+
37 36 
     if (all(tr1$tip.label %in% tr2$tip.label) == FALSE) {
38 37 
         stop("tip names not match...")
39 38 
     }
... ... 
@@ -56,7 +55,7 @@ merge_tree <- function(obj1, obj2) {
56 55 
     node_map$from %<>% c(root.2)
57 56 
     node_map$to %<>% c(root)
58 57
59 
-
58 
+
60 59 
     currentNode <- 1:Ntip(tr1)
61 60 
     while(length(currentNode)) {
62 61 
         p1 <- sapply(currentNode, getParent, tr=tr1)
... ... 
@@ -75,7 +74,7 @@ merge_tree <- function(obj1, obj2) {
75 74 
             tr2$edge[jj,1] <- p1[notNA]
76 75 
         }
77 76
78 
-
77 
+
79 78 
         ii <- match(p2, tr2$edge[,2])
80 79 
         if (length(ii)) {
81 80 
             notNA <- which(!is.na(ii))
... ... 
@@ -87,7 +86,7 @@ merge_tree <- function(obj1, obj2) {
87 86
88 87 
         node_map$from %<>% c(p2)
89 88 
         node_map$to %<>% c(p1)
90 
-
89 
+
91 90 
         ## parent of root will return 0, which is in-valid node ID
92 91 
         currentNode <- unique(p1[p1 != 0])
93 92 
     }
... ... 
@@ -95,7 +94,7 @@ merge_tree <- function(obj1, obj2) {
95 94 
     if ( any(tr2$edge != tr2$edge) ) {
96 95 
         stop("trees are not identical...")
97 96 
     }
98 
-
97 
+
99 98 
     node_map.df <- do.call("cbind", node_map)
100 99 
     node_map.df <- unique(node_map.df)
101 100 
     node_map.df <- node_map.df[node_map.df[,1] != 0,]
... ... 
@@ -118,6 +117,6 @@ merge_tree <- function(obj1, obj2) {
118 117 
         info <- merge(extraInfo, info2, by.x =c("node", "parent"), by.y = c("node", "parent"))
119 118 
         obj1@extraInfo <- info
120 119 
     }
121 
-
120 
+
122 121 
     return(obj1)
123 122 
 }
Browse code

update README

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

g.yu authored on 21/03/2016 01:54:10
Showing 1 changed files
R/merge_tree.R
History View file @ 40108ce1
... ... 
@@ -10,6 +10,10 @@
10 10 
 ##' @export
11 11 
 ##' @author Guangchuang Yu
12 12 
 merge_tree <- function(obj1, obj2) {
13 
+    ##
14 
+    ## INFO:
15 
+    ## ape::all.equal.phylo can be used to test equal phylo topology.
16 
+    ##
13 17
14 18 
     if (has.slot(obj1, "extraInfo") == FALSE) {
15 19 
         stop("input tree object is not supported...")
Browse code

update ggtree with new features according to ggplot2 v2

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

g.yu authored on 29/12/2015 11:53:44
Showing 1 changed files
R/merge_tree.R
History View file @ 25ce9608
... ... 
@@ -103,7 +103,7 @@ merge_tree <- function(obj1, obj2) {
103 103 
     info2$parent <- node_map.df[info2$parent, 2]
104 104
105 105 
     cn <- colnames(info2)
106 
-    i <- match(c("x", "y", "isTip", "label", "branch", "branch.length"), cn)
106 
+    i <- match(c("x", "y", "isTip", "label", "branch", "branch.length", "angle"), cn)
107 107 
     i <- i[!is.na(i)]
108 108 
     info2 <- info2[, -i]
109 109
Browse code

Commit made by the Bioconductor Git-SVN bridge.

Commit id: 652bb7c24e092a61c71765d9ae2de1e384b1c408

update vignette to add example of merge_tree <2015-04-29, Wed>


Commit id: ac252d451f6b2e5b0d27c055e050e1e42a6ffe56

add examples folder in inst that contains sample data <2015-04-29, Wed>


Commit id: d3bb757a48866f960e5c3b5c4da088241a410deb

in addition to parsing beast time scale tree in XXX_year[\\.\\d]*, now supports XXX/year[\\.\\d]*


Commit id: 33d9f8a12db641fe8580a20e3a2b51f4798fd96f

update gplot, now rowname of heatmap will not be displayed <2015-04-28, Tue>


Commit id: 94b64487871856f3394ed53d1ab55a4b6abc0baa

add line break if substitution longer than 50 character <2015-04-28, Tue>


Commit id: 396f41d759d1eb1ffa2b8af9d1b9eda695afe110

support calculating branch for time scale tree


Commit id: 0ba9f78c1626ec0fa1c503ac8b6f50e363976586

update vignette


Commit id: 5510c5f96044238cdeca127c9514b9a02851ecdb

remove parsing tip sequence from mlb and mlc file <2015-04-28, Tue>


Commit id: fc375e2b9825d840855c6276cf4301802f3e5bdc

o remove tip.fasfile in read.paml_rst for rstfile already contains tip sequence <2015-04-28, Tue>


Commit id: 03109db58c26037aeab23dbaf372638edbad5f67

scale_color accepts user specific interval and output contains scale attribute that can be used for adding legend <2015-04-28, Tue>


Commit id: 7c5829cfa47d36db179fd8b0c089a5c4f34ff345

extend fortify methods to support additional fields <2015-04-28, Tue>


Commit id: 1b0d72edd2f8e299b56296bc6066259a682128ad

extend tree class to support additional info by merging two tree <2015-04-28, Tue>


Commit id: a8b2f5480b31e0bef233e0483966afc4ea5ef9d6

extend get.fields methods to support additional fields <2015-04-28, Tue>


Commit id: 70831ecc379dbfc6f77cd1373d3a0e03241bbf4d

implement merge_tree function to merge two tree objects into one



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

g.yu authored on 29/04/2015 10:37:43
Showing 1 changed files
R/merge_tree.R
History View file @ bbc1de08
1 1 
new file mode 100644
... ... 
@@ -0,0 +1,119 @@
1 
+##' merge two tree object
2 
+##'
3 
+##'
4 
+##' @title merge_tree
5 
+##' @param obj1 tree object 1
6 
+##' @param obj2 tree object 2
7 
+##' @return tree object
8 
+##' @importFrom magrittr %<>%
9 
+##' @importFrom ape Ntip
10 
+##' @export
11 
+##' @author Guangchuang Yu
12 
+merge_tree <- function(obj1, obj2) {
13 
+
14 
+    if (has.slot(obj1, "extraInfo") == FALSE) {
15 
+        stop("input tree object is not supported...")
16 
+    }
17 
+
18 
+    if ((is.tree(obj1) & is.tree(obj2)) == FALSE) {
19 
+        stop("input should be tree objects...")
20 
+    }
21 
+
22 
+    tr1 <- get.tree(obj1)
23 
+    tr2 <- get.tree(obj2)
24 
+
25 
+    if (getNodeNum(tr1) != getNodeNum(tr2)) {
26 
+        stop("number of nodes not equals...")
27 
+    }
28 
+
29 
+    if (Ntip(tr1) != Ntip(tr2)) {
30 
+        stop("number of tips not equals...")
31 
+    }
32 
+
33 
+    if (all(tr1$tip.label %in% tr2$tip.label) == FALSE) {
34 
+        stop("tip names not match...")
35 
+    }
36 
+
37 
+
38 
+    ## order tip.label in tr2 as in tr1
39 
+    ## mapping corresponding ID
40 
+    idx <- match(tr2$tip.label, tr1$tip.label)
41 
+    tr2$edge[match(1:Ntip(tr2), tr2$edge[,2]), 2] <- idx
42 
+    tr2$tip.label <- tr1$tip.label
43 
+
44 
+    node_map <- list()
45 
+    node_map$from %<>% c(1:Ntip(tr2))
46 
+    node_map$to %<>% c(idx)
47 
+
48 
+    root <- getRoot(tr1)
49 
+    root.2 <- getRoot(tr2)
50 
+    tr2$edge[tr2$edge[,1] == root.2, 1] <-  root
51 
+
52 
+    node_map$from %<>% c(root.2)
53 
+    node_map$to %<>% c(root)
54 
+
55 
+
56 
+    currentNode <- 1:Ntip(tr1)
57 
+    while(length(currentNode)) {
58 
+        p1 <- sapply(currentNode, getParent, tr=tr1)
59 
+        p2 <- sapply(currentNode, getParent, tr=tr2)
60 
+
61 
+        if (length(p1) != length(p2)) {
62 
+            stop("trees are not identical...")
63 
+        }
64 
+
65 
+        jj <- match(p2, tr2$edge[,1])
66 
+        if (length(jj)) {
67 
+            notNA <- which(!is.na(jj))
68 
+            jj <- jj[notNA]
69 
+        }
70 
+        if (length(jj)) {
71 
+            tr2$edge[jj,1] <- p1[notNA]
72 
+        }
73 
+
74 
+
75 
+        ii <- match(p2, tr2$edge[,2])
76 
+        if (length(ii)) {
77 
+            notNA <- which(!is.na(ii))
78 
+            ii <- ii[notNA]
79 
+        }
80 
+        if (length(ii)) {
81 
+            tr2$edge[ii,2] <- p1[notNA]
82 
+        }
83 
+
84 
+        node_map$from %<>% c(p2)
85 
+        node_map$to %<>% c(p1)
86 
+
87 
+        ## parent of root will return 0, which is in-valid node ID
88 
+        currentNode <- unique(p1[p1 != 0])
89 
+    }
90 
+
91 
+    if ( any(tr2$edge != tr2$edge) ) {
92 
+        stop("trees are not identical...")
93 
+    }
94 
+
95 
+    node_map.df <- do.call("cbind", node_map)
96 
+    node_map.df <- unique(node_map.df)
97 
+    node_map.df <- node_map.df[node_map.df[,1] != 0,]
98 
+    i <- order(node_map.df[,1], decreasing = FALSE)
99 
+    node_map.df <- node_map.df[i,]
100 
+
101 
+    info2 <- fortify(obj2)
102 
+    info2$node <- node_map.df[info2$node, 2]
103 
+    info2$parent <- node_map.df[info2$parent, 2]
104 
+
105 
+    cn <- colnames(info2)
106 
+    i <- match(c("x", "y", "isTip", "label", "branch", "branch.length"), cn)
107 
+    i <- i[!is.na(i)]
108 
+    info2 <- info2[, -i]
109 
+
110 
+    extraInfo <- obj1@extraInfo
111 
+    if (nrow(extraInfo) == 0) {
112 
+        obj1@extraInfo <- info2
113 
+    } else {
114 
+        info <- merge(extraInfo, info2, by.x =c("node", "parent"), by.y = c("node", "parent"))
115 
+        obj1@extraInfo <- info
116 
+    }
117 
+
118 
+    return(obj1)
119 
+}