1. ggtree
  2. R
  3. method-groupOTU.R
Browse code

update according to treeio and tidytree

guangchuang yu authored on 11/12/2017 14:18:00
Showing 1 changed files
R/method-groupOTU.R
History View file @ fcbe901f
... ... 
@@ -1,251 +1,7 @@
1 
-## ##' @rdname groupOTU-methods
2 
-## ##' @exportMethod groupOTU
3 
-## setMethod("groupOTU", signature(object="apeBootstrap"),
4 
-##           function(object, focus, group_name="group", ...) {
5 
-##               groupOTU_(object, focus, group_name, ...)
6 
-##           }
7 
-##           )
8 
-
9 
-
10 
-## ##' @rdname groupOTU-methods
11 
-## ##' @exportMethod groupOTU
12 
-## setMethod("groupOTU", signature(object="beast"),
13 
-##           function(object, focus, group_name="group", ...) {
14 
-##               groupOTU_(object, focus, group_name, ...)
15 
-##           }
16 
-##           )
17 
-
18 
-## ##' @rdname groupOTU-methods
19 
-## ##' @exportMethod groupOTU
20 
-## setMethod("groupOTU", signature(object="codeml"),
21 
-##           function(object, focus, group_name="group", ...) {
22 
-##               groupOTU_(object, focus, group_name, ...)
23 
-##           }
24 
-##           )
25 
-
26 
-
27 
-## ##' @rdname groupOTU-methods
28 
-## ##' @exportMethod groupOTU
29 
-## setMethod("groupOTU", signature(object="codeml_mlc"),
30 
-##           function(object, focus, group_name="group", ...) {
31 
-##               groupOTU_(object, focus, group_name, ...)
32 
-##           }
33 
-##           )
34 
-
35 
-
36 
-## ##' @rdname groupOTU-methods
37 
-## ##' @exportMethod groupOTU
38 
-## setMethod("groupOTU", signature(object="jplace"),
39 
-##           function(object, focus, group_name="group", ...) {
40 
-##               groupOTU_(object, focus, group_name, ...)
41 
-##           }
42 
-##           )
43 
-
44 
-## ##' @rdname groupOTU-methods
45 
-## ##' @exportMethod groupOTU
46 
-## setMethod("groupOTU", signature(object="nhx"),
47 
-##           function(object, focus, group_name="group", ...) {
48 
-##               groupOTU_(object, focus, group_name, ...)
49 
-##           }
50 
-##           )
51 
-
52 
-## ##' @rdname groupOTU-methods
53 
-## ##' @exportMethod groupOTU
54 
-## setMethod("groupOTU", signature(object="phangorn"),
55 
-##           function(object, focus, group_name="group", ...) {
56 
-##               groupOTU_(object, focus, group_name, ...)
57 
-##           }
58 
-##           )
59 
-
60 
-## ##' @rdname groupOTU-methods
61 
-## ##' @exportMethod groupOTU
62 
-## setMethod("groupOTU", signature(object="phylip"),
63 
-##           function(object, focus, group_name="group", ...) {
64 
-##               groupOTU_(object, focus, group_name, ...)
65 
-##           }
66 
-##           )
67 
-
68 
-## ##' @rdname groupOTU-methods
69 
-## ##' @exportMethod groupOTU
70 
-## setMethod("groupOTU", signature(object="paml_rst"),
71 
-##           function(object, focus, group_name="group", ...) {
72 
-##               groupOTU_(object, focus, group_name, ...)
73 
-##           }
74 
-##           )
75 
-
76 
-
77 
-## ##' group tree based on selected OTU, will traceback to MRCA
78 
-## ##'
79 
-## ##'
80 
-## ##' @rdname groupOTU-methods
81 
-## ##' @exportMethod groupOTU
82 
-## setMethod("groupOTU", signature(object="phylo"),
83 
-##           function(object, focus, group_name="group", ...) {
84 
-##               groupOTU.phylo(object, focus, group_name, ...)
85 
-##           })
86 
-
87 
-## ##' @rdname groupOTU-methods
88 
-## ##' @exportMethod groupOTU
89 
-## ##' @param tree which tree selected
90 
-## setMethod("groupOTU", signature(object="r8s"),
91 
-##           function(object, focus, group_name="group", tree="TREE", ...) {
92 
-##               groupOTU_(get.tree(object)[[tree]], focus, group_name, ...)
93 
-##           }
94 
-##           )
95 
-
96 
-
97 
-
98 
-
99 
-## ##' @importFrom ape which.edge
100 
-## gfocus <- function(phy, focus, group_name, focus_label=NULL, overlap="overwrite") {
101 
-##     overlap <- match.arg(overlap, c("origin", "overwrite", "abandon"))
102 
-
103 
-##     if (is.character(focus)) {
104 
-##         focus <- which(phy$tip.label %in% focus)
105 
-##     }
106 
-
107 
-##     n <- getNodeNum(phy)
108 
-##     if (is.null(attr(phy, group_name))) {
109 
-##         foc <- rep(0, n)
110 
-##     } else {
111 
-##         foc <- attr(phy, group_name)
112 
-##     }
113 
-##     i <- max(suppressWarnings(as.numeric(foc)), na.rm=TRUE) + 1
114 
-##     if (is.null(focus_label)) {
115 
-##         focus_label <- i
116 
-##     }
117 
-
118 
-##     ## sn <- phy$edge[which.edge(phy, focus),] %>% as.vector %>% unique
119 
-##     hit <- unique(as.vector(phy$edge[which.edge(phy, focus),]))
120 
-##     if (overlap == "origin") {
121 
-##         sn <- hit[is.na(foc[hit]) | foc[hit] == 0]
122 
-##     } else if (overlap == "abandon") {
123 
-##         idx <- !is.na(foc[hit]) & foc[hit] != 0
124 
-##         foc[hit[idx]] <- NA
125 
-##         sn <- hit[!idx]
126 
-##     } else {
127 
-##         sn <- hit
128 
-##     }
129 
-
130 
-##     if (length(sn) > 0) {
131 
-##         foc[sn] <- focus_label
132 
-##     }
133 
-
134 
-##     attr(phy, group_name) <- foc
135 
-##     phy
136 
-## }
137 
-
138 
-
139 
-## ##' group OTU
140 
-## ##'
141 
-## ##'
142 
-## ##' @title groupOTU.phylo
143 
-## ##' @param phy tree object
144 
-## ##' @param focus tip list
145 
-## ##' @param group_name name of the group
146 
-## ##' @param ... additional parameters
147 
-## ##' @return phylo object
148 
-## ##' @author ygc
149 
-## groupOTU.phylo <- function(phy, focus, group_name="group", ...) {
150 
-##     attr(phy, group_name) <- NULL
151 
-##     if ( is(focus, "list") ) {
152 
-##         for (i in 1:length(focus)) {
153 
-##             phy <- gfocus(phy, focus[[i]], group_name, names(focus)[i], ...)
154 
-##         }
155 
-##     } else {
156 
-##         phy <- gfocus(phy, focus, group_name, ...)
157 
-##     }
158 
-##     res <- attr(phy, group_name)
159 
-##     res[is.na(res)] <- 0
160 
-##     attr(phy, group_name) <- factor(res)
161 
-##     return(phy)
162 
-## }
163 
-
164 
-## groupOTU_ <- function(object, focus, group_name, ...) {
165 
-##     if (is(object, "phylo")) {
166 
-##         object <- groupOTU.phylo(object, focus, group_name, ...)
167 
-##     } else {
168 
-##         object@phylo <- groupOTU.phylo(get.tree(object), focus, group_name, ...)
169 
-##     }
170 
-##     return(object)
171 
-## }
172 
-
173 
-##' groupOTU method for ggtree object
174 
-##'
175 
-##'
176 
-##' @name groupOTU
177 
-##' @title groupOTU method
178 
-##' @rdname groupOTU-methods
179 
-##' @param object ggtree object
180 
-##' @param focus OTU to focus
181 
-##' @param group_name name of the group
182 
-##' @param ... additional parameters
183 
-##' @importFrom treeio groupOTU
184 
-##' @exportMethod groupOTU
185 
-##' @aliases groupOTU,ggtree-method
186 
-setMethod("groupOTU", signature(object="ggtree"),
187 
-          function(object, focus, group_name="group", ...) {
188 
-              groupOTU.ggtree(object, focus, group_name, ...)
189 
-          })
190 
-
191 
-
192 
-groupOTU.ggtree <- function(object, focus, group_name, ...) {
193 
-    df <- object$data
194 
-    df[[group_name]] <- 0
195 
-    object$data <- groupOTU.tbl(df, focus, group_name, ...)
196 
-    return(object)
197 
-}
198 
-
199 
-
200 
-groupOTU.tbl <- function(df, focus, group_name, ...) {
201 
-    if (is(focus, "list")) {
202 
-        for (i in 1:length(focus)) {
203 
-            df <- gfocus.tbl(df, focus[[i]], group_name, names(focus)[i], ...)
204 
-        }
205 
-    } else {
206 
-        df <- gfocus.tbl(df, focus, group_name, ...)
207 
-    }
208 
-    df[[group_name]] <- factor(df[[group_name]])
209 
-    return(df)
210 
-}
211 
-
212 
-gfocus.tbl <- function(df, focus, group_name, focus_label=NULL, overlap="overwrite") {
213 
-    overlap <- match.arg(overlap, c("origin", "overwrite", "abandon"))
214 
-
215 
-    focus <- df$node[which(df$label %in% focus)]
216 
-    if (is.null(focus_label))
217 
-        focus_label <- max(suppressWarnings(as.numeric(df[[group_name]])), na.rm=TRUE) + 1
218 
-
219 
-    if (length(focus) == 1) {
220 
-        hit <- match(focus, df$node)
221 
-    } else {
222 
-        anc <- getAncestor.df(df, focus[1])
223 
-        foc <- c(focus[1], anc)
224 
-        for (j in 2:length(focus)) {
225 
-            anc2 <- getAncestor.df(df, focus[j])
226 
-            comAnc <- intersect(anc, anc2)
227 
-            foc <- c(foc, focus[j], anc2)
228 
-            foc <- foc[! foc %in% comAnc]
229 
-            foc <- c(foc, comAnc[1])
230 
-        }
231 
-        hit <- match(foc, df$node)
232 
-    }
233 
-
234 
-    foc <- df[[group_name]]
235 
-    if (overlap == "origin") {
236 
-        sn <- hit[is.na(foc[hit]) | foc[hit] == 0]
237 
-    } else if (overlap == "abandon") {
238 
-        idx <- !is.na(foc[hit]) & foc[hit] != 0
239 
-        foc[hit[idx]] <- NA
240 
-        sn <- hit[!idx]
241 
-    } else {
242 
-        sn <- hit
243 
-    }
244 
-
245 
-    if (length(sn) > 0) {
246 
-        foc[sn] <- focus_label
247 
-    }
248 
-
249 
-    df[, group_name] <- foc
250 
-    return(df)
1 
+##' @method groupOTU ggtree
2 
+##' @export
3 
+##' @importFrom tidytree groupOTU
4 
+groupOTU.ggtree <- function(.data, .node, group_name = "group", ...) {
5 
+    .data$data <- groupOTU(.data$data, .node, group_name, ...)
6 
+    return(.data)
251 7 
 }
Browse code

remove paml_rst, codeml_mlc, codeml and jplace fortify methods according to the change of treeio (v = 1.3.3)

guangchuang yu authored on 07/12/2017 07:21:58
Showing 1 changed files
R/method-groupOTU.R
History View file @ 6be958c5
... ... 
@@ -191,30 +191,30 @@ setMethod("groupOTU", signature(object="ggtree"),
191 191
192 192 
 groupOTU.ggtree <- function(object, focus, group_name, ...) {
193 193 
     df <- object$data
194 
-    df[, group_name] <- 0
195 
-    object$data <- groupOTU.df(df, focus, group_name, ...)
194 
+    df[[group_name]] <- 0
195 
+    object$data <- groupOTU.tbl(df, focus, group_name, ...)
196 196 
     return(object)
197 197 
 }
198 198
199 199
200 
-groupOTU.df <- function(df, focus, group_name, ...) {
200 
+groupOTU.tbl <- function(df, focus, group_name, ...) {
201 201 
     if (is(focus, "list")) {
202 202 
         for (i in 1:length(focus)) {
203 
-            df <- gfocus.df(df, focus[[i]], group_name, names(focus)[i], ...)
203 
+            df <- gfocus.tbl(df, focus[[i]], group_name, names(focus)[i], ...)
204 204 
         }
205 205 
     } else {
206 
-        df <- gfocus.df(df, focus, group_name, ...)
206 
+        df <- gfocus.tbl(df, focus, group_name, ...)
207 207 
     }
208 
-    df[, group_name] <- factor(df[, group_name])
208 
+    df[[group_name]] <- factor(df[[group_name]])
209 209 
     return(df)
210 210 
 }
211 211
212 
-gfocus.df <- function(df, focus, group_name, focus_label=NULL, overlap="overwrite") {
212 
+gfocus.tbl <- function(df, focus, group_name, focus_label=NULL, overlap="overwrite") {
213 213 
     overlap <- match.arg(overlap, c("origin", "overwrite", "abandon"))
214 214
215 215 
     focus <- df$node[which(df$label %in% focus)]
216 216 
     if (is.null(focus_label))
217 
-        focus_label <- max(suppressWarnings(as.numeric(df[, group_name])), na.rm=TRUE) + 1
217 
+        focus_label <- max(suppressWarnings(as.numeric(df[[group_name]])), na.rm=TRUE) + 1
218 218
219 219 
     if (length(focus) == 1) {
220 220 
         hit <- match(focus, df$node)
... ... 
@@ -231,7 +231,7 @@ gfocus.df <- function(df, focus, group_name, focus_label=NULL, overlap="overwrit
231 231 
         hit <- match(foc, df$node)
232 232 
     }
233 233
234 
-    foc <- df[, group_name]
234 
+    foc <- df[[group_name]]
235 235 
     if (overlap == "origin") {
236 236 
         sn <- hit[is.na(foc[hit]) | foc[hit] == 0]
237 237 
     } else if (overlap == "abandon") {
Browse code

rm files

guangchuang yu authored on 21/12/2016 09:36:53
Showing 1 changed files
R/method-groupOTU.R
History View file @ 1d4d2daf
... ... 
@@ -33,25 +33,6 @@
33 33 
 ##           )
34 34
35 35
36 
-##' groupOTU method for ggtree object
37 
-##'
38 
-##'
39 
-##' @name groupOTU
40 
-##' @title groupOTU method
41 
-##' @rdname groupOTU-methods
42 
-##' @param object ggtree object
43 
-##' @param focus OTU to focus
44 
-##' @param group_name name of the group
45 
-##' @param ... additional parameters
46 
-##' @importFrom treeio groupOTU
47 
-##' @exportMethod groupOTU
48 
-##' @aliases groupOTU,ggtree-method
49 
-setMethod("groupOTU", signature(object="ggtree"),
50 
-          function(object, focus, group_name="group", ...) {
51 
-              groupOTU.ggtree(object, focus, group_name, ...)
52 
-          })
53 
-
54 
-
55 36 
 ## ##' @rdname groupOTU-methods
56 37 
 ## ##' @exportMethod groupOTU
57 38 
 ## setMethod("groupOTU", signature(object="jplace"),
... ... 
@@ -189,6 +170,24 @@ setMethod("groupOTU", signature(object="ggtree"),
189 170 
 ##     return(object)
190 171 
 ## }
191 172
173 
+##' groupOTU method for ggtree object
174 
+##'
175 
+##'
176 
+##' @name groupOTU
177 
+##' @title groupOTU method
178 
+##' @rdname groupOTU-methods
179 
+##' @param object ggtree object
180 
+##' @param focus OTU to focus
181 
+##' @param group_name name of the group
182 
+##' @param ... additional parameters
183 
+##' @importFrom treeio groupOTU
184 
+##' @exportMethod groupOTU
185 
+##' @aliases groupOTU,ggtree-method
186 
+setMethod("groupOTU", signature(object="ggtree"),
187 
+          function(object, focus, group_name="group", ...) {
188 
+              groupOTU.ggtree(object, focus, group_name, ...)
189 
+          })
190 
+
192 191
193 192 
 groupOTU.ggtree <- function(object, focus, group_name, ...) {
194 193 
     df <- object$data
Browse code

move code to treeio

guangchuang yu authored on 21/12/2016 08:57:38
Showing 1 changed files
R/method-groupOTU.R
History View file @ 1d7f426b
... ... 
@@ -33,11 +33,19 @@
33 33 
 ##           )
34 34
35 35
36 
+##' groupOTU method for ggtree object
37 
+##'
38 
+##'
36 39 
 ##' @name groupOTU
37 40 
 ##' @title groupOTU method
38 41 
 ##' @rdname groupOTU-methods
42 
+##' @param object ggtree object
43 
+##' @param focus OTU to focus
44 
+##' @param group_name name of the group
45 
+##' @param ... additional parameters
39 46 
 ##' @importFrom treeio groupOTU
40 47 
 ##' @exportMethod groupOTU
48 
+##' @aliases groupOTU,ggtree-method
41 49 
 setMethod("groupOTU", signature(object="ggtree"),
42 50 
           function(object, focus, group_name="group", ...) {
43 51 
               groupOTU.ggtree(object, focus, group_name, ...)
... ... 
@@ -172,14 +180,14 @@ setMethod("groupOTU", signature(object="ggtree"),
172 180 
 ##     return(phy)
173 181 
 ## }
174 182
175 
-groupOTU_ <- function(object, focus, group_name, ...) {
176 
-    if (is(object, "phylo")) {
177 
-        object <- groupOTU.phylo(object, focus, group_name, ...)
178 
-    } else {
179 
-        object@phylo <- groupOTU.phylo(get.tree(object), focus, group_name, ...)
180 
-    }
181 
-    return(object)
182 
-}
183 
+## groupOTU_ <- function(object, focus, group_name, ...) {
184 
+##     if (is(object, "phylo")) {
185 
+##         object <- groupOTU.phylo(object, focus, group_name, ...)
186 
+##     } else {
187 
+##         object@phylo <- groupOTU.phylo(get.tree(object), focus, group_name, ...)
188 
+##     }
189 
+##     return(object)
190 
+## }
183 191
184 192
185 193 
 groupOTU.ggtree <- function(object, focus, group_name, ...) {
Browse code

depends treeio

GuangchuangYu authored on 20/12/2016 16:39:07
Showing 1 changed files
R/method-groupOTU.R
History View file @ 817c093d
... ... 
@@ -1,39 +1,42 @@
1 
+## ##' @rdname groupOTU-methods
2 
+## ##' @exportMethod groupOTU
3 
+## setMethod("groupOTU", signature(object="apeBootstrap"),
4 
+##           function(object, focus, group_name="group", ...) {
5 
+##               groupOTU_(object, focus, group_name, ...)
6 
+##           }
7 
+##           )
8 
+
9 
+
10 
+## ##' @rdname groupOTU-methods
11 
+## ##' @exportMethod groupOTU
12 
+## setMethod("groupOTU", signature(object="beast"),
13 
+##           function(object, focus, group_name="group", ...) {
14 
+##               groupOTU_(object, focus, group_name, ...)
15 
+##           }
16 
+##           )
17 
+
18 
+## ##' @rdname groupOTU-methods
19 
+## ##' @exportMethod groupOTU
20 
+## setMethod("groupOTU", signature(object="codeml"),
21 
+##           function(object, focus, group_name="group", ...) {
22 
+##               groupOTU_(object, focus, group_name, ...)
23 
+##           }
24 
+##           )
25 
+
26 
+
27 
+## ##' @rdname groupOTU-methods
28 
+## ##' @exportMethod groupOTU
29 
+## setMethod("groupOTU", signature(object="codeml_mlc"),
30 
+##           function(object, focus, group_name="group", ...) {
31 
+##               groupOTU_(object, focus, group_name, ...)
32 
+##           }
33 
+##           )
34 
+
35 
+
36 
+##' @name groupOTU
37 
+##' @title groupOTU method
1 38 
 ##' @rdname groupOTU-methods
2 
-##' @exportMethod groupOTU
3 
-setMethod("groupOTU", signature(object="apeBootstrap"),
4 
-          function(object, focus, group_name="group", ...) {
5 
-              groupOTU_(object, focus, group_name, ...)
6 
-          }
7 
-          )
8 
-
9 
-
10 
-##' @rdname groupOTU-methods
11 
-##' @exportMethod groupOTU
12 
-setMethod("groupOTU", signature(object="beast"),
13 
-          function(object, focus, group_name="group", ...) {
14 
-              groupOTU_(object, focus, group_name, ...)
15 
-          }
16 
-          )
17 
-
18 
-##' @rdname groupOTU-methods
19 
-##' @exportMethod groupOTU
20 
-setMethod("groupOTU", signature(object="codeml"),
21 
-          function(object, focus, group_name="group", ...) {
22 
-              groupOTU_(object, focus, group_name, ...)
23 
-          }
24 
-          )
25 
-
26 
-
27 
-##' @rdname groupOTU-methods
28 
-##' @exportMethod groupOTU
29 
-setMethod("groupOTU", signature(object="codeml_mlc"),
30 
-          function(object, focus, group_name="group", ...) {
31 
-              groupOTU_(object, focus, group_name, ...)
32 
-          }
33 
-          )
34 
-
35 
-
36 
-##' @rdname groupOTU-methods
39 
+##' @importFrom treeio groupOTU
37 40 
 ##' @exportMethod groupOTU
38 41 
 setMethod("groupOTU", signature(object="ggtree"),
39 42 
           function(object, focus, group_name="group", ...) {
... ... 
@@ -41,133 +44,133 @@ setMethod("groupOTU", signature(object="ggtree"),
41 44 
           })
42 45
43 46
44 
-##' @rdname groupOTU-methods
45 
-##' @exportMethod groupOTU
46 
-setMethod("groupOTU", signature(object="jplace"),
47 
-          function(object, focus, group_name="group", ...) {
48 
-              groupOTU_(object, focus, group_name, ...)
49 
-          }
50 
-          )
51 
-
52 
-##' @rdname groupOTU-methods
53 
-##' @exportMethod groupOTU
54 
-setMethod("groupOTU", signature(object="nhx"),
55 
-          function(object, focus, group_name="group", ...) {
56 
-              groupOTU_(object, focus, group_name, ...)
57 
-          }
58 
-          )
59 
-
60 
-##' @rdname groupOTU-methods
61 
-##' @exportMethod groupOTU
62 
-setMethod("groupOTU", signature(object="phangorn"),
63 
-          function(object, focus, group_name="group", ...) {
64 
-              groupOTU_(object, focus, group_name, ...)
65 
-          }
66 
-          )
67 
-
68 
-##' @rdname groupOTU-methods
69 
-##' @exportMethod groupOTU
70 
-setMethod("groupOTU", signature(object="phylip"),
71 
-          function(object, focus, group_name="group", ...) {
72 
-              groupOTU_(object, focus, group_name, ...)
73 
-          }
74 
-          )
75 
-
76 
-##' @rdname groupOTU-methods
77 
-##' @exportMethod groupOTU
78 
-setMethod("groupOTU", signature(object="paml_rst"),
79 
-          function(object, focus, group_name="group", ...) {
80 
-              groupOTU_(object, focus, group_name, ...)
81 
-          }
82 
-          )
83 
-
84 
-
85 
-##' group tree based on selected OTU, will traceback to MRCA
86 
-##'
87 
-##'
88 
-##' @rdname groupOTU-methods
89 
-##' @exportMethod groupOTU
90 
-setMethod("groupOTU", signature(object="phylo"),
91 
-          function(object, focus, group_name="group", ...) {
92 
-              groupOTU.phylo(object, focus, group_name, ...)
93 
-          })
94 
-
95 
-##' @rdname groupOTU-methods
96 
-##' @exportMethod groupOTU
97 
-##' @param tree which tree selected
98 
-setMethod("groupOTU", signature(object="r8s"),
99 
-          function(object, focus, group_name="group", tree="TREE", ...) {
100 
-              groupOTU_(get.tree(object)[[tree]], focus, group_name, ...)
101 
-          }
102 
-          )
103 
-
104 
-
105 
-
106 
-
107 
-##' @importFrom ape which.edge
108 
-gfocus <- function(phy, focus, group_name, focus_label=NULL, overlap="overwrite") {
109 
-    overlap <- match.arg(overlap, c("origin", "overwrite", "abandon"))
110 
-
111 
-    if (is.character(focus)) {
112 
-        focus <- which(phy$tip.label %in% focus)
113 
-    }
114 
-
115 
-    n <- getNodeNum(phy)
116 
-    if (is.null(attr(phy, group_name))) {
117 
-        foc <- rep(0, n)
118 
-    } else {
119 
-        foc <- attr(phy, group_name)
120 
-    }
121 
-    i <- max(suppressWarnings(as.numeric(foc)), na.rm=TRUE) + 1
122 
-    if (is.null(focus_label)) {
123 
-        focus_label <- i
124 
-    }
125 
-
126 
-    ## sn <- phy$edge[which.edge(phy, focus),] %>% as.vector %>% unique
127 
-    hit <- unique(as.vector(phy$edge[which.edge(phy, focus),]))
128 
-    if (overlap == "origin") {
129 
-        sn <- hit[is.na(foc[hit]) | foc[hit] == 0]
130 
-    } else if (overlap == "abandon") {
131 
-        idx <- !is.na(foc[hit]) & foc[hit] != 0
132 
-        foc[hit[idx]] <- NA
133 
-        sn <- hit[!idx]
134 
-    } else {
135 
-        sn <- hit
136 
-    }
137 
-
138 
-    if (length(sn) > 0) {
139 
-        foc[sn] <- focus_label
140 
-    }
141 
-
142 
-    attr(phy, group_name) <- foc
143 
-    phy
144 
-}
145 
-
146 
-
147 
-##' group OTU
148 
-##'
149 
-##'
150 
-##' @title groupOTU.phylo
151 
-##' @param phy tree object
152 
-##' @param focus tip list
153 
-##' @param group_name name of the group
154 
-##' @param ... additional parameters
155 
-##' @return phylo object
156 
-##' @author ygc
157 
-groupOTU.phylo <- function(phy, focus, group_name="group", ...) {
158 
-    attr(phy, group_name) <- NULL
159 
-    if ( is(focus, "list") ) {
160 
-        for (i in 1:length(focus)) {
161 
-            phy <- gfocus(phy, focus[[i]], group_name, names(focus)[i], ...)
162 
-        }
163 
-    } else {
164 
-        phy <- gfocus(phy, focus, group_name, ...)
165 
-    }
166 
-    res <- attr(phy, group_name)
167 
-    res[is.na(res)] <- 0
168 
-    attr(phy, group_name) <- factor(res)
169 
-    return(phy)
170 
-}
47 
+## ##' @rdname groupOTU-methods
48 
+## ##' @exportMethod groupOTU
49 
+## setMethod("groupOTU", signature(object="jplace"),
50 
+##           function(object, focus, group_name="group", ...) {
51 
+##               groupOTU_(object, focus, group_name, ...)
52 
+##           }
53 
+##           )
54 
+
55 
+## ##' @rdname groupOTU-methods
56 
+## ##' @exportMethod groupOTU
57 
+## setMethod("groupOTU", signature(object="nhx"),
58 
+##           function(object, focus, group_name="group", ...) {
59 
+##               groupOTU_(object, focus, group_name, ...)
60 
+##           }
61 
+##           )
62 
+
63 
+## ##' @rdname groupOTU-methods
64 
+## ##' @exportMethod groupOTU
65 
+## setMethod("groupOTU", signature(object="phangorn"),
66 
+##           function(object, focus, group_name="group", ...) {
67 
+##               groupOTU_(object, focus, group_name, ...)
68 
+##           }
69 
+##           )
70 
+
71 
+## ##' @rdname groupOTU-methods
72 
+## ##' @exportMethod groupOTU
73 
+## setMethod("groupOTU", signature(object="phylip"),
74 
+##           function(object, focus, group_name="group", ...) {
75 
+##               groupOTU_(object, focus, group_name, ...)
76 
+##           }
77 
+##           )
78 
+
79 
+## ##' @rdname groupOTU-methods
80 
+## ##' @exportMethod groupOTU
81 
+## setMethod("groupOTU", signature(object="paml_rst"),
82 
+##           function(object, focus, group_name="group", ...) {
83 
+##               groupOTU_(object, focus, group_name, ...)
84 
+##           }
85 
+##           )
86 
+
87 
+
88 
+## ##' group tree based on selected OTU, will traceback to MRCA
89 
+## ##'
90 
+## ##'
91 
+## ##' @rdname groupOTU-methods
92 
+## ##' @exportMethod groupOTU
93 
+## setMethod("groupOTU", signature(object="phylo"),
94 
+##           function(object, focus, group_name="group", ...) {
95 
+##               groupOTU.phylo(object, focus, group_name, ...)
96 
+##           })
97 
+
98 
+## ##' @rdname groupOTU-methods
99 
+## ##' @exportMethod groupOTU
100 
+## ##' @param tree which tree selected
101 
+## setMethod("groupOTU", signature(object="r8s"),
102 
+##           function(object, focus, group_name="group", tree="TREE", ...) {
103 
+##               groupOTU_(get.tree(object)[[tree]], focus, group_name, ...)
104 
+##           }
105 
+##           )
106 
+
107 
+
108 
+
109 
+
110 
+## ##' @importFrom ape which.edge
111 
+## gfocus <- function(phy, focus, group_name, focus_label=NULL, overlap="overwrite") {
112 
+##     overlap <- match.arg(overlap, c("origin", "overwrite", "abandon"))
113 
+
114 
+##     if (is.character(focus)) {
115 
+##         focus <- which(phy$tip.label %in% focus)
116 
+##     }
117 
+
118 
+##     n <- getNodeNum(phy)
119 
+##     if (is.null(attr(phy, group_name))) {
120 
+##         foc <- rep(0, n)
121 
+##     } else {
122 
+##         foc <- attr(phy, group_name)
123 
+##     }
124 
+##     i <- max(suppressWarnings(as.numeric(foc)), na.rm=TRUE) + 1
125 
+##     if (is.null(focus_label)) {
126 
+##         focus_label <- i
127 
+##     }
128 
+
129 
+##     ## sn <- phy$edge[which.edge(phy, focus),] %>% as.vector %>% unique
130 
+##     hit <- unique(as.vector(phy$edge[which.edge(phy, focus),]))
131 
+##     if (overlap == "origin") {
132 
+##         sn <- hit[is.na(foc[hit]) | foc[hit] == 0]
133 
+##     } else if (overlap == "abandon") {
134 
+##         idx <- !is.na(foc[hit]) & foc[hit] != 0
135 
+##         foc[hit[idx]] <- NA
136 
+##         sn <- hit[!idx]
137 
+##     } else {
138 
+##         sn <- hit
139 
+##     }
140 
+
141 
+##     if (length(sn) > 0) {
142 
+##         foc[sn] <- focus_label
143 
+##     }
144 
+
145 
+##     attr(phy, group_name) <- foc
146 
+##     phy
147 
+## }
148 
+
149 
+
150 
+## ##' group OTU
151 
+## ##'
152 
+## ##'
153 
+## ##' @title groupOTU.phylo
154 
+## ##' @param phy tree object
155 
+## ##' @param focus tip list
156 
+## ##' @param group_name name of the group
157 
+## ##' @param ... additional parameters
158 
+## ##' @return phylo object
159 
+## ##' @author ygc
160 
+## groupOTU.phylo <- function(phy, focus, group_name="group", ...) {
161 
+##     attr(phy, group_name) <- NULL
162 
+##     if ( is(focus, "list") ) {
163 
+##         for (i in 1:length(focus)) {
164 
+##             phy <- gfocus(phy, focus[[i]], group_name, names(focus)[i], ...)
165 
+##         }
166 
+##     } else {
167 
+##         phy <- gfocus(phy, focus, group_name, ...)
168 
+##     }
169 
+##     res <- attr(phy, group_name)
170 
+##     res[is.na(res)] <- 0
171 
+##     attr(phy, group_name) <- factor(res)
172 
+##     return(phy)
173 
+## }
171 174
172 175 
 groupOTU_ <- function(object, focus, group_name, ...) {
173 176 
     if (is(object, "phylo")) {
Browse code

fixed R check

guangchuang yu authored on 06/12/2016 12:05:09
Showing 1 changed files
R/method-groupOTU.R
History View file @ 9bd4fbab
... ... 
@@ -32,18 +32,12 @@ setMethod("groupOTU", signature(object="codeml_mlc"),
32 32 
           }
33 33 
           )
34 34
35 
-##' @rdname groupOTU-methods
36 
-##' @exportMethod groupOTU
37 
-setMethod("groupOTU", signature(object="gg"),
38 
-          function(object, focus, group_name, ...) {
39 
-              groupOTU.ggplot(object, focus, group_name, ...)
40 
-          })
41 35
42 36 
 ##' @rdname groupOTU-methods
43 37 
 ##' @exportMethod groupOTU
44 
-setMethod("groupOTU", signature(object="ggplot"),
38 
+setMethod("groupOTU", signature(object="ggtree"),
45 39 
           function(object, focus, group_name="group", ...) {
46 
-              groupOTU.ggplot(object, focus, group_name, ...)
40 
+              groupOTU.ggtree(object, focus, group_name, ...)
47 41 
           })
48 42
49 43
... ... 
@@ -185,7 +179,7 @@ groupOTU_ <- function(object, focus, group_name, ...) {
185 179 
 }
186 180
187 181
188 
-groupOTU.ggplot <- function(object, focus, group_name, ...) {
182 
+groupOTU.ggtree <- function(object, focus, group_name, ...) {
189 183 
     df <- object$data
190 184 
     df[, group_name] <- 0
191 185 
     object$data <- groupOTU.df(df, focus, group_name, ...)
Browse code

overlap parameter in groupOTU

guangchuang yu authored on 16/11/2016 05:54:24
Showing 1 changed files
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", ...) {