1. ggtree
  2. Commit 3846507e4539cf31ef55e8eeea659ca57f16bf7e
Browse code

overlap parameter in groupOTU

guangchuang yu authored on 16/11/2016 05:54:24
Showing 6 changed files
DESCRIPTION
History View file @ 3846507e
... ... 
@@ -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.7.3
4 
+Version: 1.7.4
5 5 
 Authors@R: c(
6 6 
 	   person("Guangchuang", "Yu", email = "guangchuangyu@gmail.com", role = c("aut", "cre", "cph")),
7 7 
 	   person("Tommy Tsan-Yuk", "Lam", email = "tylam.tommy@gmail.com", rol = c("aut", "ths")),
NEWS
History View file @ 3846507e
... ... 
@@ -1,3 +1,8 @@
1 
+CHANGES IN VERSION 1.7.4
2 
+------------------------
3 
+ o groupOTU method now accept 'overlap = c("overwrite", "origin", "abandon")' parameter <2016-11-16, Wed>
4 
+   + https://groups.google.com/forum/#!topic/bioc-ggtree/Q4LnwoTf1DM
5 
+
1 6 
 CHANGES IN VERSION 1.7.3
2 7 
 ------------------------
3 8 
  o drop.tip method for NHX object <2016-11-11, Fri>
R/method-groupOTU.R
History View file @ 3846507e
... ... 
@@ -1,8 +1,8 @@
1 1 
 ##' @rdname groupOTU-methods
2 2 
 ##' @exportMethod groupOTU
3 3 
 setMethod("groupOTU", signature(object="apeBootstrap"),
4 
-          function(object, focus, group_name="group") {
5 
-              groupOTU_(object, focus, group_name)
4 
+          function(object, focus, group_name="group", ...) {
5 
+              groupOTU_(object, focus, group_name, ...)
6 6 
           }
7 7 
           )
8 8
... ... 
@@ -10,16 +10,16 @@ setMethod("groupOTU", signature(object="apeBootstrap"),
10 10 
 ##' @rdname groupOTU-methods
11 11 
 ##' @exportMethod groupOTU
12 12 
 setMethod("groupOTU", signature(object="beast"),
13 
-          function(object, focus, group_name="group") {
14 
-              groupOTU_(object, focus, group_name)
13 
+          function(object, focus, group_name="group", ...) {
14 
+              groupOTU_(object, focus, group_name, ...)
15 15 
           }
16 16 
           )
17 17
18 18 
 ##' @rdname groupOTU-methods
19 19 
 ##' @exportMethod groupOTU
20 20 
 setMethod("groupOTU", signature(object="codeml"),
21 
-          function(object, focus, group_name="group") {
22 
-              groupOTU_(object, focus, group_name)
21 
+          function(object, focus, group_name="group", ...) {
22 
+              groupOTU_(object, focus, group_name, ...)
23 23 
           }
24 24 
           )
25 25
... ... 
@@ -27,63 +27,63 @@ setMethod("groupOTU", signature(object="codeml"),
27 27 
 ##' @rdname groupOTU-methods
28 28 
 ##' @exportMethod groupOTU
29 29 
 setMethod("groupOTU", signature(object="codeml_mlc"),
30 
-          function(object, focus, group_name="group") {
31 
-              groupOTU_(object, focus, group_name)
30 
+          function(object, focus, group_name="group", ...) {
31 
+              groupOTU_(object, focus, group_name, ...)
32 32 
           }
33 33 
           )
34 34
35 35 
 ##' @rdname groupOTU-methods
36 36 
 ##' @exportMethod groupOTU
37 37 
 setMethod("groupOTU", signature(object="gg"),
38 
-          function(object, focus, group_name) {
39 
-              groupOTU.ggplot(object, focus, group_name)
38 
+          function(object, focus, group_name, ...) {
39 
+              groupOTU.ggplot(object, focus, group_name, ...)
40 40 
           })
41 41
42 42 
 ##' @rdname groupOTU-methods
43 43 
 ##' @exportMethod groupOTU
44 44 
 setMethod("groupOTU", signature(object="ggplot"),
45 
-          function(object, focus, group_name="group") {
46 
-              groupOTU.ggplot(object, focus, group_name)
45 
+          function(object, focus, group_name="group", ...) {
46 
+              groupOTU.ggplot(object, focus, group_name, ...)
47 47 
           })
48 48
49 49
50 50 
 ##' @rdname groupOTU-methods
51 51 
 ##' @exportMethod groupOTU
52 52 
 setMethod("groupOTU", signature(object="jplace"),
53 
-          function(object, focus, group_name="group") {
54 
-              groupOTU_(object, focus, group_name)
53 
+          function(object, focus, group_name="group", ...) {
54 
+              groupOTU_(object, focus, group_name, ...)
55 55 
           }
56 56 
           )
57 57
58 58 
 ##' @rdname groupOTU-methods
59 59 
 ##' @exportMethod groupOTU
60 60 
 setMethod("groupOTU", signature(object="nhx"),
61 
-          function(object, focus, group_name="group") {
62 
-              groupOTU_(object, focus, group_name)
61 
+          function(object, focus, group_name="group", ...) {
62 
+              groupOTU_(object, focus, group_name, ...)
63 63 
           }
64 64 
           )
65 65
66 66 
 ##' @rdname groupOTU-methods
67 67 
 ##' @exportMethod groupOTU
68 68 
 setMethod("groupOTU", signature(object="phangorn"),
69 
-          function(object, focus, group_name="group") {
70 
-              groupOTU_(object, focus, group_name)
69 
+          function(object, focus, group_name="group", ...) {
70 
+              groupOTU_(object, focus, group_name, ...)
71 71 
           }
72 72 
           )
73 73
74 74 
 ##' @rdname groupOTU-methods
75 75 
 ##' @exportMethod groupOTU
76 76 
 setMethod("groupOTU", signature(object="phylip"),
77 
-          function(object, focus, group_name="group") {
78 
-              groupOTU_(object, focus, group_name)
77 
+          function(object, focus, group_name="group", ...) {
78 
+              groupOTU_(object, focus, group_name, ...)
79 79 
           }
80 80 
           )
81 81
82 82 
 ##' @rdname groupOTU-methods
83 83 
 ##' @exportMethod groupOTU
84 84 
 setMethod("groupOTU", signature(object="paml_rst"),
85 
-          function(object, focus, group_name="group") {
86 
-              groupOTU_(object, focus, group_name)
85 
+          function(object, focus, group_name="group", ...) {
86 
+              groupOTU_(object, focus, group_name, ...)
87 87 
           }
88 88 
           )
89 89
... ... 
@@ -94,16 +94,16 @@ setMethod("groupOTU", signature(object="paml_rst"),
94 94 
 ##' @rdname groupOTU-methods
95 95 
 ##' @exportMethod groupOTU
96 96 
 setMethod("groupOTU", signature(object="phylo"),
97 
-          function(object, focus, group_name="group") {
98 
-              groupOTU.phylo(object, focus, group_name)
97 
+          function(object, focus, group_name="group", ...) {
98 
+              groupOTU.phylo(object, focus, group_name, ...)
99 99 
           })
100 100
101 101 
 ##' @rdname groupOTU-methods
102 102 
 ##' @exportMethod groupOTU
103 103 
 ##' @param tree which tree selected
104 104 
 setMethod("groupOTU", signature(object="r8s"),
105 
-          function(object, focus, group_name="group", tree="TREE") {
106 
-              groupOTU_(get.tree(object)[[tree]], focus, group_name)
105 
+          function(object, focus, group_name="group", tree="TREE", ...) {
106 
+              groupOTU_(get.tree(object)[[tree]], focus, group_name, ...)
107 107 
           }
108 108 
           )
109 109
... ... 
@@ -111,7 +111,9 @@ setMethod("groupOTU", signature(object="r8s"),
111 111
112 112
113 113 
 ##' @importFrom ape which.edge
114 
-gfocus <- function(phy, focus, group_name, focus_label=NULL) {
114 
+gfocus <- function(phy, focus, group_name, focus_label=NULL, overlap="overwrite") {
115 
+    overlap <- match.arg(overlap, c("origin", "overwrite", "abandon"))
116 
+
115 117 
     if (is.character(focus)) {
116 118 
         focus <- which(phy$tip.label %in% focus)
117 119 
     }
... ... 
@@ -123,11 +125,23 @@ gfocus <- function(phy, focus, group_name, focus_label=NULL) {
123 125 
         foc <- attr(phy, group_name)
124 126 
     }
125 127 
     i <- max(suppressWarnings(as.numeric(foc)), na.rm=TRUE) + 1
126 
-    ## sn <- phy$edge[which.edge(phy, focus),] %>% as.vector %>% unique
127 
-    sn <- unique(as.vector(phy$edge[which.edge(phy, focus),]))
128 128 
     if (is.null(focus_label)) {
129 
-        foc[sn] <- i
129 
+        focus_label <- i
130 
+    }
131 
+
132 
+    ## sn <- phy$edge[which.edge(phy, focus),] %>% as.vector %>% unique
133 
+    hit <- unique(as.vector(phy$edge[which.edge(phy, focus),]))
134 
+    if (overlap == "origin") {
135 
+        sn <- hit[is.na(foc[hit]) | foc[hit] == 0]
136 
+    } else if (overlap == "abandon") {
137 
+        idx <- !is.na(foc[hit]) & foc[hit] != 0
138 
+        foc[hit[idx]] <- NA
139 
+        sn <- hit[!idx]
130 140 
     } else {
141 
+        sn <- hit
142 
+    }
143 
+
144 
+    if (length(sn) > 0) {
131 145 
         foc[sn] <- focus_label
132 146 
     }
133 147
... ... 
@@ -143,72 +157,91 @@ gfocus <- function(phy, focus, group_name, focus_label=NULL) {
143 157 
 ##' @param phy tree object
144 158 
 ##' @param focus tip list
145 159 
 ##' @param group_name name of the group
160 
+##' @param ... additional parameters
146 161 
 ##' @return phylo object
147 162 
 ##' @author ygc
148 
-groupOTU.phylo <- function(phy, focus, group_name="group") {
163 
+groupOTU.phylo <- function(phy, focus, group_name="group", ...) {
149 164 
     attr(phy, group_name) <- NULL
150 165 
     if ( is(focus, "list") ) {
151 166 
         for (i in 1:length(focus)) {
152 
-            phy <- gfocus(phy, focus[[i]], group_name, names(focus)[i])
167 
+            phy <- gfocus(phy, focus[[i]], group_name, names(focus)[i], ...)
153 168 
         }
154 169 
     } else {
155 
-        phy <- gfocus(phy, focus, group_name)
170 
+        phy <- gfocus(phy, focus, group_name, ...)
156 171 
     }
157 
-    attr(phy, group_name) <- factor(attr(phy, group_name))
172 
+    res <- attr(phy, group_name)
173 
+    res[is.na(res)] <- 0
174 
+    attr(phy, group_name) <- factor(res)
158 175 
     return(phy)
159 176 
 }
160 177
161 
-groupOTU_ <- function(object, focus, group_name) {
178 
+groupOTU_ <- function(object, focus, group_name, ...) {
162 179 
     if (is(object, "phylo")) {
163 
-        object <- groupOTU.phylo(object, focus, group_name)
180 
+        object <- groupOTU.phylo(object, focus, group_name, ...)
164 181 
     } else {
165 
-        object@phylo <- groupOTU.phylo(get.tree(object), focus, group_name)
182 
+        object@phylo <- groupOTU.phylo(get.tree(object), focus, group_name, ...)
166 183 
     }
167 184 
     return(object)
168 185 
 }
169 186
170 187
171 
-groupOTU.ggplot <- function(object, focus, group_name) {
188 
+groupOTU.ggplot <- function(object, focus, group_name, ...) {
172 189 
     df <- object$data
173 190 
     df[, group_name] <- 0
174 
-    object$data <- groupOTU.df(df, focus, group_name)
191 
+    object$data <- groupOTU.df(df, focus, group_name, ...)
175 192 
     return(object)
176 193 
 }
177 194
178 195
179 
-groupOTU.df <- function(df, focus, group_name) {
196 
+groupOTU.df <- function(df, focus, group_name, ...) {
180 197 
     if (is(focus, "list")) {
181 198 
         for (i in 1:length(focus)) {
182 
-            df <- gfocus.df(df, focus[[i]], group_name, names(focus)[i])
199 
+            df <- gfocus.df(df, focus[[i]], group_name, names(focus)[i], ...)
183 200 
         }
184 201 
     } else {
185 
-        df <- gfocus.df(df, focus, group_name)
202 
+        df <- gfocus.df(df, focus, group_name, ...)
186 203 
     }
187 204 
     df[, group_name] <- factor(df[, group_name])
188 205 
     return(df)
189 206 
 }
190 207
191 
-gfocus.df <- function(df, focus, group_name, focus_label=NULL) {
208 
+gfocus.df <- function(df, focus, group_name, focus_label=NULL, overlap="overwrite") {
209 
+    overlap <- match.arg(overlap, c("origin", "overwrite", "abandon"))
210 
+
192 211 
     focus <- df$node[which(df$label %in% focus)]
193 212 
     if (is.null(focus_label))
194 213 
         focus_label <- max(suppressWarnings(as.numeric(df[, group_name])), na.rm=TRUE) + 1
195 214
196 215 
     if (length(focus) == 1) {
197 
-        df[match(focus, df$node), group_name] <-focus_label
198 
-        return(df)
216 
+        hit <- match(focus, df$node)
217 
+    } else {
218 
+        anc <- getAncestor.df(df, focus[1])
219 
+        foc <- c(focus[1], anc)
220 
+        for (j in 2:length(focus)) {
221 
+            anc2 <- getAncestor.df(df, focus[j])
222 
+            comAnc <- intersect(anc, anc2)
223 
+            foc <- c(foc, focus[j], anc2)
224 
+            foc <- foc[! foc %in% comAnc]
225 
+            foc <- c(foc, comAnc[1])
226 
+        }
227 
+        hit <- match(foc, df$node)
228 
+    }
229 
+
230 
+    foc <- df[, group_name]
231 
+    if (overlap == "origin") {
232 
+        sn <- hit[is.na(foc[hit]) | foc[hit] == 0]
233 
+    } else if (overlap == "abandon") {
234 
+        idx <- !is.na(foc[hit]) & foc[hit] != 0
235 
+        foc[hit[idx]] <- NA
236 
+        sn <- hit[!idx]
237 
+    } else {
238 
+        sn <- hit
199 239 
     }
200 240
201 
-    anc <- getAncestor.df(df, focus[1])
202 
-    foc <- c(focus[1], anc)
203 
-    for (j in 2:length(focus)) {
204 
-        anc2 <- getAncestor.df(df, focus[j])
205 
-        comAnc <- intersect(anc, anc2)
206 
-        foc <- c(foc, focus[j], anc2)
207 
-        foc <- foc[! foc %in% comAnc]
208 
-        foc <- c(foc, comAnc[1])
241 
+    if (length(sn) > 0) {
242 
+        foc[sn] <- focus_label
209 243 
     }
210 
-    idx <- match(foc, df$node)
211 
-    df[idx, group_name] <- focus_label
244 
+
245 
+    df[, group_name] <- foc
212 246 
     return(df)
213 247 
 }
214 
-
README.md
History View file @ 3846507e
... ... 
@@ -2,9 +2,9 @@
2 2 
 ggtree: an R package for visualization and annotation of phylogenetic trees with their covariates and other associated data
3 3 
 ===========================================================================================================================
4 4
5 
-[![releaseVersion](https://img.shields.io/badge/release%20version-1.6.3-green.svg?style=flat)](https://bioconductor.org/packages/ggtree) [![develVersion](https://img.shields.io/badge/devel%20version-1.7.3-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-16443/total-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree) [![month](https://img.shields.io/badge/downloads-1621/month-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree) <img src="logo.png" align="right" />
5 
+[![releaseVersion](https://img.shields.io/badge/release%20version-1.6.4-green.svg?style=flat)](https://bioconductor.org/packages/ggtree) [![develVersion](https://img.shields.io/badge/devel%20version-1.7.3-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-16443/total-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree) [![month](https://img.shields.io/badge/downloads-1621/month-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree) <img src="logo.png" align="right" />
6 6
7 
-[![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--11--14-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 
+[![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--11--16-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)
8 8
9 9 
 [![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)
10 10
man/groupOTU-methods.Rd
History View file @ 3846507e
... ... 
@@ -26,31 +26,32 @@ groupOTU(object, focus, group_name = "group", ...)
26 26
27 27 
 \S4method{groupOTU}{hyphy}(object, focus, group_name = "group")
28 28
29 
-\S4method{groupOTU}{apeBootstrap}(object, focus, group_name = "group")
29 
+\S4method{groupOTU}{apeBootstrap}(object, focus, group_name = "group", ...)
30 30
31 
-\S4method{groupOTU}{beast}(object, focus, group_name = "group")
31 
+\S4method{groupOTU}{beast}(object, focus, group_name = "group", ...)
32 32
33 
-\S4method{groupOTU}{codeml}(object, focus, group_name = "group")
33 
+\S4method{groupOTU}{codeml}(object, focus, group_name = "group", ...)
34 34
35 
-\S4method{groupOTU}{codeml_mlc}(object, focus, group_name = "group")
35 
+\S4method{groupOTU}{codeml_mlc}(object, focus, group_name = "group", ...)
36 36
37 
-\S4method{groupOTU}{gg}(object, focus, group_name)
37 
+\S4method{groupOTU}{gg}(object, focus, group_name = "group", ...)
38 38
39 
-\S4method{groupOTU}{ggplot}(object, focus, group_name = "group")
39 
+\S4method{groupOTU}{ggplot}(object, focus, group_name = "group", ...)
40 40
41 
-\S4method{groupOTU}{jplace}(object, focus, group_name = "group")
41 
+\S4method{groupOTU}{jplace}(object, focus, group_name = "group", ...)
42 42
43 
-\S4method{groupOTU}{nhx}(object, focus, group_name = "group")
43 
+\S4method{groupOTU}{nhx}(object, focus, group_name = "group", ...)
44 44
45 
-\S4method{groupOTU}{phangorn}(object, focus, group_name = "group")
45 
+\S4method{groupOTU}{phangorn}(object, focus, group_name = "group", ...)
46 46
47 
-\S4method{groupOTU}{phylip}(object, focus, group_name = "group")
47 
+\S4method{groupOTU}{phylip}(object, focus, group_name = "group", ...)
48 48
49 
-\S4method{groupOTU}{paml_rst}(object, focus, group_name = "group")
49 
+\S4method{groupOTU}{paml_rst}(object, focus, group_name = "group", ...)
50 50
51 
-\S4method{groupOTU}{phylo}(object, focus, group_name = "group")
51 
+\S4method{groupOTU}{phylo}(object, focus, group_name = "group", ...)
52 52
53 
-\S4method{groupOTU}{r8s}(object, focus, group_name = "group", tree = "TREE")
53 
+\S4method{groupOTU}{r8s}(object, focus, group_name = "group", tree = "TREE",
54 
+  ...)
54 55 
 }
55 56 
 \arguments{
56 57 
 \item{object}{supported objects, including phylo, paml_rst,
man/groupOTU.phylo.Rd
History View file @ 3846507e
... ... 
@@ -4,7 +4,7 @@
4 4 
 \alias{groupOTU.phylo}
5 5 
 \title{groupOTU.phylo}
6 6 
 \usage{
7 
-groupOTU.phylo(phy, focus, group_name = "group")
7 
+groupOTU.phylo(phy, focus, group_name = "group", ...)
8 8 
 }
9 9 
 \arguments{
10 10 
 \item{phy}{tree object}
... ... 
@@ -12,6 +12,8 @@ groupOTU.phylo(phy, focus, group_name = "group")
12 12 
 \item{focus}{tip list}
13 13
14 14 
 \item{group_name}{name of the group}
15 
+
16 
+\item{...}{additional parameters}
15 17 
 }
16 18 
 \value{
17 19 
 phylo object