Browse code

overlap parameter in groupOTU

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

Guangchuang Yu authored on 16/11/2016 05:50:08
Showing34 changed files

... ...
@@ -9,3 +9,4 @@ Makefile
9 9
 README.Rmd
10 10
 mkdocs
11 11
 docs
12
+logo.png
12 13
\ No newline at end of file
... ...
@@ -1,21 +1,20 @@
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")),
8 8
 	   person("Justin", "Silverman", email = "jsilve24@gmail.com", rol = "ctb", comment = "geom_balance"),
9 9
 	   person("Casey", "Dunn", email = "casey_dunn@brown.edu", rol = "ctb",
10
-	          comment = c("propose using txtConnection so that parser functions can use tree strings as input",
11
-		  "modified nhx parsing to retain tip node numbers"))
10
+	          comment = "NHX")
12 11
 	   )
13 12
 Maintainer: Guangchuang Yu <guangchuangyu@gmail.com>
14 13
 Description: 'ggtree' extends the 'ggplot2' plotting system which implemented the grammar of graphics.
15 14
 	     'ggtree' is designed for visualization and annotation of phylogenetic trees with their covariates and other associated data.
16 15
 Depends:
17 16
     R (>= 3.3.1),
18
-    ggplot2 (>= 2.1.0)
17
+    ggplot2 (>= 2.2.0)
19 18
 Imports:
20 19
     ape,
21 20
     grDevices,
... ...
@@ -47,7 +47,9 @@ mkdocs: mdfiles
47 47
 	mkdocs build;\
48 48
 	cd ../docs;\
49 49
 	rm -rf fonts;\
50
-	rm -rf css/font-awesome*
50
+	rm -rf css/font-awesome*;\
51
+	Rscript -e 'library(ypages); add_biobabble("index.html")'
52
+
51 53
 
52 54
 mdfiles:
53 55
 	cd mkdocs;\
... ...
@@ -58,7 +60,6 @@ mdfiles:
58 60
 	cd docs;\
59 61
 	ln -f -s ../mysoftware/* ./
60 62
 
61
-
62 63
 svnignore:
63 64
 	svn propset svn:ignore -F .svnignore .
64 65
 
... ...
@@ -39,6 +39,7 @@ export(as.polytomy)
39 39
 export(collapse)
40 40
 export(decimal2Date)
41 41
 export(download.phylopic)
42
+export(drop.tip)
42 43
 export(expand)
43 44
 export(facet_plot)
44 45
 export(flip)
... ...
@@ -141,6 +142,7 @@ exportClasses(phangorn)
141 142
 exportClasses(phylip)
142 143
 exportClasses(r8s)
143 144
 exportClasses(raxml)
145
+exportMethods(drop.tip)
144 146
 exportMethods(get.fields)
145 147
 exportMethods(get.placements)
146 148
 exportMethods(get.subs)
... ...
@@ -155,10 +157,7 @@ exportMethods(plot)
155 157
 exportMethods(reroot)
156 158
 exportMethods(scale_color)
157 159
 exportMethods(show)
158
-importFrom(ape,Nnode)
159
-importFrom(ape,Ntip)
160 160
 importFrom(ape,di2multi)
161
-importFrom(ape,drop.tip)
162 161
 importFrom(ape,extract.clade)
163 162
 importFrom(ape,getMRCA)
164 163
 importFrom(ape,is.binary.tree)
... ...
@@ -249,4 +248,5 @@ importFrom(stats4,plot)
249 248
 importFrom(tidyr,gather)
250 249
 importFrom(utils,download.file)
251 250
 importFrom(utils,modifyList)
251
+importFrom(utils,packageDescription)
252 252
 importFrom(utils,packageVersion)
... ...
@@ -1,5 +1,12 @@
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
 ------------------------
8
+ o drop.tip method for NHX object <2016-11-11, Fri>
9
+ o update startup message <2016-11-09, Wed>
3 10
  o reverse timescale x-axis <2016-11-07, Mon>
4 11
    + https://github.com/GuangchuangYu/ggtree/issues/87
5 12
 
... ...
@@ -164,3 +164,19 @@ setGeneric("scale_color", function(object, by, ...) standardGeneric("scale_color
164 164
 ##' @return figure
165 165
 ##' @export
166 166
 setGeneric("gzoom", function(object, focus, subtree=FALSE, widths=c(.3, .7), ...) standardGeneric("gzoom"))
167
+
168
+
169
+##' @docType methods
170
+##' @name drop.tip
171
+##' @rdname drop.tip-methods
172
+##' @title drop.tip method
173
+##' @param object An nhx or phylo object
174
+##' @param tip a vector of mode numeric or character specifying the tips to delete
175
+##' @param ... additional parameters
176
+##' @return updated object
177
+##' @export
178
+setGeneric (
179
+	name = "drop.tip",
180
+	def = function( object, tip, ... )
181
+		{ standardGeneric("drop.tip") }
182
+)
... ...
@@ -33,7 +33,7 @@ read.nhx <- function(file) {
33 33
     matches <- nhx.matches[[1]]
34 34
     match.pos <- as.numeric(matches)
35 35
     if (length(match.pos) == 1 && (match.pos == -1)) {
36
-        nhx_stats <- data.frame(node = treeinfo$node)
36
+        nhx_tags <- data.frame(node = as.numeric(treeinfo$node))
37 37
     } else {
38 38
         match.len <- attr(matches, 'match.length')
39 39
 
... ...
@@ -44,22 +44,25 @@ read.nhx <- function(file) {
44 44
             gsub("\\[&&NHX:", "", .) %>%
45 45
             gsub("\\]", "", .)
46 46
 
47
-        nhx_stats <- get_nhx_feature(nhx_features)
48
-        fields <- names(nhx_stats)
49
-        for (i in ncol(nhx_stats)) {
50
-            if(any(grepl("\\D+", nhx_stats[,i])) == FALSE) {
47
+        nhx_tags <- get_nhx_feature(nhx_features)
48
+        fields <- names(nhx_tags)
49
+        for (i in ncol(nhx_tags)) {
50
+            if(any(grepl("\\D+", nhx_tags[,i])) == FALSE) {
51 51
                 ## should be numerical varialbe
52
-                nhx_stats[,i] <- as.numeric(nhx_stats[,i])
52
+                nhx_tags[,i] <- as.numeric(nhx_tags[,i])
53 53
             }
54 54
         }
55
-        nhx_stats$node <- node
55
+        nhx_tags$node <- as.numeric(node)
56 56
     }
57 57
 
58
+    # Order rows by row number to facilitate downstream manipulations
59
+    nhx_tags=nhx_tags[order(nhx_tags$node),]
60
+
58 61
     new("nhx",
59 62
         file = filename(file),
60 63
         fields = fields,
61 64
         phylo = phylo,
62
-        nhx_tags = nhx_stats
65
+        nhx_tags = nhx_tags
63 66
         )
64 67
 }
65 68
 
... ...
@@ -28,12 +28,11 @@ rtree <- ape::rtree
28 28
 
29 29
 ##' merge phylo and output of boot.phylo to 'apeBootstrap' object
30 30
 ##'
31
-##' 
31
+##'
32 32
 ##' @title apeBoot
33 33
 ##' @param phylo phylo
34 34
 ##' @param boot bootstrap values
35 35
 ##' @return an instance of 'apeBootstrap'
36
-##' @importFrom ape Nnode
37 36
 ##' @export
38 37
 ##' @author Guangchuang Yu
39 38
 apeBoot <- function(phylo, boot) {
... ...
@@ -53,7 +52,7 @@ setMethod("show", signature(object = "apeBootstrap"),
53 52
           function(object) {
54 53
               cat("'apeBoot' S4 object that stored bootstrap value generated by 'ape::boot.phylo'", ".\n\n")
55 54
               cat("...@ tree: ")
56
-              print.phylo(get.tree(object))                  
55
+              print.phylo(get.tree(object))
57 56
           })
58 57
 
59 58
 
... ...
@@ -1,24 +1,23 @@
1 1
 
2 2
 ##' collapse binary tree to polytomy by applying 'fun' to 'feature'
3 3
 ##'
4
-##' 
4
+##'
5 5
 ##' @title as.polytomy
6 6
 ##' @param tree tree object
7 7
 ##' @param feature selected feature
8 8
 ##' @param fun function to select nodes to collapse
9 9
 ##' @return polytomy tree
10 10
 ##' @author Guangchuang
11
-##' @importFrom ape Ntip
12 11
 ##' @importFrom ape di2multi
13 12
 ##' @export
14 13
 as.polytomy <- function(tree, feature, fun) {
15 14
     if (!is(tree, 'phylo')) {
16 15
         stop("currently only 'phylo' object is supported...")
17 16
     }
18
-    
17
+
19 18
     df <- fortify(tree)
20 19
     phylo <- get.tree(tree)
21
-    
20
+
22 21
     if (feature == 'node.label') {
23 22
         feat <- df[!df$isTip, 'label']
24 23
     } else if (feature == 'tip.label') {
... ...
@@ -26,7 +25,7 @@ as.polytomy <- function(tree, feature, fun) {
26 25
     } else {
27 26
         feat <- df[, feature]
28 27
     }
29
-    
28
+
30 29
     idx <- which(fun(feat))
31 30
     if (feature == 'node.label') {
32 31
         nodes <- Ntip(phylo) + df$node[idx]
... ...
@@ -36,7 +35,7 @@ as.polytomy <- function(tree, feature, fun) {
36 35
     edge_idx <- match(nodes, phylo$edge[,2])
37 36
     phylo$edge.length[edge_idx] <- 0
38 37
     poly_tree <- di2multi(phylo)
39
-    ## 
38
+    ##
40 39
     ## map stats to poly_tree and update tree object
41 40
     ##
42 41
     return(poly_tree)
... ...
@@ -1,8 +1,8 @@
1 1
 #' highlights the two direct descendant clades of an internal node
2
-#' 
2
+#'
3 3
 #' Particularly useful when studying neighboring clades. Note that balances that
4 4
 #' correspond to multichotomies will not be displayed.
5
-#' 
5
+#'
6 6
 #' @title geom_balance
7 7
 #' @param node selected node (balance) to highlight
8 8
 #' @param fill color fill
... ...
@@ -19,17 +19,17 @@
19 19
 #' @references J. Silverman, et al. \emph{A phylogenetic transform enhances
20 20
 #'   analysis of compositional microbiota data}. (in preparation)
21 21
 geom_balance <- function(node, fill="steelblue", color='white', alpha=.5, extend=0, extendto=NULL) {
22
-  
22
+
23 23
   data = NULL
24 24
   stat = "balance"
25 25
   position = "identity"
26 26
   show.legend = NA
27 27
   na.rm = TRUE
28 28
   inherit.aes = FALSE
29
-  
29
+
30 30
   default_aes <- aes_(x=~x, y=~y, node=~node, parent=~parent, branch.length=~branch.length)
31 31
   mapping <- default_aes
32
-  
32
+
33 33
   l1 <- layer(
34 34
     stat=StatBalance,
35 35
     data = data,
... ...
@@ -44,9 +44,9 @@ geom_balance <- function(node, fill="steelblue", color='white', alpha=.5, extend
44 44
                   alpha=alpha,
45 45
                   extend=extend,
46 46
                   extendto=extendto,
47
-                  direction=1, 
47
+                  direction=1,
48 48
                   na.rm = na.rm),
49
-    if (packageVersion('ggplot2') > '2.1.0') check.aes = FALSE
49
+    check.aes = FALSE
50 50
   )
51 51
   l2 <- layer(
52 52
     stat=StatBalance,
... ...
@@ -64,7 +64,7 @@ geom_balance <- function(node, fill="steelblue", color='white', alpha=.5, extend
64 64
                   extendto=extendto,
65 65
                   direction=2,
66 66
                   na.rm = na.rm),
67
-    if (packageVersion('ggplot2') > '2.1.0') check.aes = FALSE
67
+    check.aes = FALSE
68 68
   )
69 69
   return(c(l1,l2))
70 70
 }
... ...
@@ -90,7 +90,7 @@ geom_balance <- function(node, fill="steelblue", color='white', alpha=.5, extend
90 90
 #' @importFrom ggplot2 layer
91 91
 #' @export
92 92
 stat_balance <- function(mapping=NULL, data=NULL, geom="rect",
93
-                         position="identity",  node, 
93
+                         position="identity",  node,
94 94
                          show.legend=NA, inherit.aes=FALSE,
95 95
                          fill, color, alpha, extend=0, extendto=NULL,
96 96
                          ...) {
... ...
@@ -100,7 +100,7 @@ stat_balance <- function(mapping=NULL, data=NULL, geom="rect",
100 100
   } else {
101 101
     mapping <- modifyList(mapping, default_aes)
102 102
   }
103
-  
103
+
104 104
   l1 <- layer(
105 105
     stat=StatBalance,
106 106
     data = data,
... ...
@@ -117,7 +117,7 @@ stat_balance <- function(mapping=NULL, data=NULL, geom="rect",
117 117
                   extendto=extendto,
118 118
                   direction=1,
119 119
                   ...),
120
-    if (packageVersion('ggplot2') > '2.1.0') check.aes = FALSE
120
+    check.aes = FALSE
121 121
   )
122 122
   l2 <- layer(
123 123
     stat=StatBalance,
... ...
@@ -135,7 +135,7 @@ stat_balance <- function(mapping=NULL, data=NULL, geom="rect",
135 135
                   extendto=extendto,
136 136
                   direction=2,
137 137
                   ...),
138
-    if (packageVersion('ggplot2') > '2.1.0') check.aes = FALSE
138
+    check.aes = FALSE
139 139
   )
140 140
   return(c(l1,l2))
141 141
 }
... ...
@@ -149,7 +149,7 @@ stat_balance <- function(mapping=NULL, data=NULL, geom="rect",
149 149
 StatBalance <- ggproto("StatBalance", Stat,
150 150
                        compute_group = function(self, data, scales, params, node, extend, extendto, direction) {
151 151
                          df <- get_balance_position_(data, node, direction)
152
-                         
152
+
153 153
                          df$xmax <- df$xmax + extend
154 154
                          if (!is.null(extendto) && !is.na(extendto)) {
155 155
                            if (extendto < df$xmax) {
... ...
@@ -170,7 +170,7 @@ StatBalance <- ggproto("StatBalance", Stat,
170 170
 #' @title get_balance_position
171 171
 #' @param treeview tree view
172 172
 #' @param node selected node
173
-#' @param direction either (1 for 'up' or 2 for 'down') 
173
+#' @param direction either (1 for 'up' or 2 for 'down')
174 174
 #' @return data.frame
175 175
 #' @export
176 176
 #' @author Justin Silverman
... ...
@@ -180,20 +180,20 @@ get_balance_position <- function(treeview, node, direction) {
180 180
 
181 181
 get_balance_position_ <- function(data, node, direction) {
182 182
   ch <- tryCatch(getChild.df(data, node), error=function(e) NULL)
183
-  
183
+
184 184
   if (length(ch) < 2 || is.null(ch)){
185 185
     stop('balance cannot be a tip')
186 186
   } else if (length(ch) > 2){
187 187
     stop('balance has >2 direct child nodes, can use ape::multi2di to convert to binary tree')
188 188
   }
189
-  
189
+
190 190
   i <- match(node, data$node)
191 191
   sp <- tryCatch(get.offspring.df(data, ch[direction]), error=function(e) ch[direction])
192 192
   sp.all <- get.offspring.df(data, i)
193 193
   sp.df <- data[match(sp, data$node),]
194 194
   sp.all.df <- data[match(sp.all, data$node),]
195 195
   n.df <- data[i,]
196
-  
196
+
197 197
   # X direction is uniform for both children, but y is only based on range of
198 198
   # one of the two children (direction)
199 199
   x <- sp.all.df$x
... ...
@@ -129,7 +129,7 @@ stat_cladeText <- function(mapping=NULL, data=NULL,
129 129
                       na.rm  = na.rm,
130 130
                       parse  = parse,
131 131
                       ...),
132
-          if (packageVersion('ggplot2') > '2.1.0') check.aes = FALSE
132
+          check.aes = FALSE
133 133
           )
134 134
 
135 135
 }
... ...
@@ -157,7 +157,7 @@ stat_cladeBar <- function(mapping=NULL, data=NULL,
157 157
                       align=align,
158 158
                       na.rm=na.rm,
159 159
                       ...),
160
-          if (packageVersion('ggplot2') > '2.1.0') check.aes = FALSE
160
+          check.aes = FALSE
161 161
           )
162 162
 }
163 163
 
... ...
@@ -1,6 +1,6 @@
1 1
 ##' layer of hilight clade with rectangle
2 2
 ##'
3
-##' 
3
+##'
4 4
 ##' @title geom_hilight
5 5
 ##' @param node selected node to hilight
6 6
 ##' @param fill color fill
... ...
@@ -13,18 +13,18 @@
13 13
 ##' @importFrom ggplot2 GeomRect
14 14
 ##' @author Guangchuang Yu
15 15
 geom_hilight <- function(node, fill="steelblue", alpha=.5, extend=0, extendto=NULL) {
16
-                         
17
-    
16
+
17
+
18 18
     data = NULL
19 19
     stat = "hilight"
20 20
     position = "identity"
21 21
     show.legend = NA
22 22
     na.rm = TRUE
23 23
     inherit.aes = FALSE
24
-    
24
+
25 25
     default_aes <- aes_(x=~x, y=~y, node=~node, parent=~parent, branch.length=~branch.length)
26 26
     mapping <- default_aes
27
-    
27
+
28 28
 
29 29
     layer(
30 30
         stat=StatHilight,
... ...
@@ -40,7 +40,7 @@ geom_hilight <- function(node, fill="steelblue", alpha=.5, extend=0, extendto=NU
40 40
                       extend=extend,
41 41
                       extendto=extendto,
42 42
                       na.rm = na.rm),
43
-        if (packageVersion('ggplot2') > '2.1.0') check.aes = FALSE
43
+        check.aes = FALSE
44 44
     )
45 45
 }
46 46
 
... ...
@@ -64,7 +64,7 @@ geom_hilight <- function(node, fill="steelblue", alpha=.5, extend=0, extendto=NU
64 64
 ##' @importFrom ggplot2 layer
65 65
 ##' @export
66 66
 stat_hilight <- function(mapping=NULL, data=NULL, geom="rect",
67
-                         position="identity",  node, 
67
+                         position="identity",  node,
68 68
                          show.legend=NA, inherit.aes=FALSE,
69 69
                          fill, alpha, extend=0, extendto=NULL,
70 70
                          ...) {
... ...
@@ -74,7 +74,7 @@ stat_hilight <- function(mapping=NULL, data=NULL, geom="rect",
74 74
     } else {
75 75
         mapping <- modifyList(mapping, default_aes)
76 76
     }
77
-    
77
+
78 78
     layer(
79 79
         stat=StatHilight,
80 80
         data = data,
... ...
@@ -117,7 +117,7 @@ StatHilight <- ggproto("StatHilight", Stat,
117 117
 
118 118
 ##' get position of clade (xmin, xmax, ymin, ymax)
119 119
 ##'
120
-##' 
120
+##'
121 121
 ##' @title get_clade_position
122 122
 ##' @param treeview tree view
123 123
 ##' @param node selected node
... ...
@@ -142,7 +142,7 @@ get_clade_position_ <- function(data, node) {
142 142
 
143 143
     x <- sp.df$x
144 144
     y <- sp.df$y
145
-    
145
+
146 146
     if ("branch.length" %in% colnames(data)) {
147 147
         xmin <- min(x)-data[i, "branch.length"]/2
148 148
     } else {
... ...
@@ -1,6 +1,6 @@
1 1
 ##' geom_text2 support aes(subset) via setup_data
2 2
 ##'
3
-##' 
3
+##'
4 4
 ##' @title geom_text2
5 5
 ##' @param mapping the aesthetic mapping
6 6
 ##' @param data A layer specific dataset -
... ...
@@ -9,7 +9,7 @@
9 9
 ##' @param parse if TRUE, the labels will be passd into expressions
10 10
 ##' @param nudge_x horizontal adjustment
11 11
 ##' @param nudge_y vertical adjustment
12
-##' @param label.padding Amount of padding around label. 
12
+##' @param label.padding Amount of padding around label.
13 13
 ##' @param label.r Radius of rounded corners.
14 14
 ##' @param label.size Size of label border, in mm
15 15
 ##' @param na.rm logical
... ...
@@ -35,22 +35,22 @@ geom_label2 <- function(mapping = NULL, data = NULL,
35 35
                         inherit.aes = TRUE) {
36 36
 
37 37
     position = "identity"
38
-    
38
+
39 39
     if (!missing(nudge_x) || !missing(nudge_y)) {
40 40
         if (!missing(position)) {
41 41
             stop("Specify either `position` or `nudge_x`/`nudge_y`", call. = FALSE)
42 42
         }
43
-        
43
+
44 44
         position <- position_nudge(nudge_x, nudge_y)
45 45
     }
46
-    
46
+
47 47
     default_aes <- aes_(node=~node)
48 48
     if (is.null(mapping)) {
49 49
         mapping <- default_aes
50 50
     } else {
51 51
         mapping <- modifyList(mapping, default_aes)
52 52
     }
53
-    
53
+
54 54
     layer(
55 55
         data = data,
56 56
         mapping = mapping,
... ...
@@ -67,7 +67,7 @@ geom_label2 <- function(mapping = NULL, data = NULL,
67 67
             na.rm = na.rm,
68 68
             ...
69 69
         ),
70
-        if (packageVersion('ggplot2') > '2.1.0') check.aes = FALSE
70
+        check.aes = FALSE
71 71
     )
72 72
 }
73 73
 
... ...
@@ -89,13 +89,13 @@ GeomLabelGGtree <- ggproto("GeomLabelGGtree", GeomLabel,
89 89
                                                    na.rm, label.padding, label.r, label.size)
90 90
                            },
91 91
                            required_aes = c("node", "x", "y", "label"),
92
-                           
92
+
93 93
                            default_aes = aes(
94 94
                                colour = "black", fill = "white", size = 3.88, angle = 0,
95 95
                                hjust = 0.5, vjust = 0.5, alpha = NA, family = "", fontface = 1,
96 96
                                lineheight = 1.2
97 97
                            ),
98
-                           
98
+
99 99
                            draw_key = draw_key_label
100 100
                            )
101 101
 
... ...
@@ -126,7 +126,7 @@ geom_point2 <- function(mapping = NULL, data = NULL,
126 126
             na.rm = na.rm,
127 127
             ...
128 128
         ),
129
-        if (packageVersion('ggplot2') > '2.1.0') check.aes = FALSE
129
+        check.aes = FALSE
130 130
     )
131 131
 }
132 132
 
... ...
@@ -27,7 +27,7 @@ geom_range <- function(range="height_0.95_HPD", ...) {
27 27
         show.legend=show.legend,
28 28
         inherit.aes = inherit.aes,
29 29
         params = list(na.rm = na.rm, ...),
30
-        if (packageVersion('ggplot2') > '2.1.0') check.aes = FALSE
30
+        check.aes = FALSE
31 31
     )
32 32
 
33 33
 }
... ...
@@ -1,6 +1,6 @@
1 1
 ##' add horizontal align lines
2 2
 ##'
3
-##' 
3
+##'
4 4
 ##' @title geom_aline
5 5
 ##' @param mapping aes mapping
6 6
 ##' @param linetype line type
... ...
@@ -15,7 +15,7 @@ geom_aline <- function(mapping=NULL, linetype="dotted", size=1, ...) {
15 15
     if (!is.null(mapping)) {
16 16
         dot_mapping <- modifyList(dot_mapping, mapping)
17 17
     }
18
-    
18
+
19 19
     geom_segment2(dot_mapping,
20 20
                   linetype=linetype,
21 21
                   size=size, ...)
... ...
@@ -25,9 +25,9 @@ geom_aline <- function(mapping=NULL, linetype="dotted", size=1, ...) {
25 25
 
26 26
 ##' geom_segment2 support aes(subset) via setup_data
27 27
 ##'
28
-##' 
28
+##'
29 29
 ##' @title geom_segment2
30
-##' @param mapping aes mapping 
30
+##' @param mapping aes mapping
31 31
 ##' @param data data
32 32
 ##' @param position position
33 33
 ##' @param arrow arrow
... ...
@@ -42,7 +42,7 @@ geom_aline <- function(mapping=NULL, linetype="dotted", size=1, ...) {
42 42
 ##' \link[ggplot2]{geom_segment}
43 43
 ##' @return add segment layer
44 44
 ##' @author Guangchuang Yu
45
-geom_segment2 <- function(mapping = NULL, data = NULL, 
45
+geom_segment2 <- function(mapping = NULL, data = NULL,
46 46
                          position = "identity", arrow = NULL, lineend = "butt",
47 47
                          na.rm = FALSE, show.legend = NA, inherit.aes = TRUE,
48 48
                          ...) {
... ...
@@ -53,7 +53,7 @@ geom_segment2 <- function(mapping = NULL, data = NULL,
53 53
     } else {
54 54
         mapping <- modifyList(mapping, default_aes)
55 55
     }
56
-    
56
+
57 57
     layer(
58 58
         data = data,
59 59
         mapping = mapping,
... ...
@@ -68,7 +68,7 @@ geom_segment2 <- function(mapping = NULL, data = NULL,
68 68
             na.rm = na.rm,
69 69
             ...
70 70
         ),
71
-        if (packageVersion('ggplot2') > '2.1.0') check.aes = FALSE
71
+        check.aes = FALSE
72 72
     )
73 73
 }
74 74
 
... ...
@@ -80,17 +80,17 @@ GeomSegmentGGtree <- ggproto("GeomSegmentGGtree", GeomSegment,
80 80
                                      return(data)
81 81
                                  data[data$subset,]
82 82
                              },
83
-                             
83
+
84 84
                              draw_panel = function(data, panel_scales, coord, arrow = NULL,
85 85
                                                    lineend = "butt", na.rm = FALSE) {
86
-                                 
86
+
87 87
                                  GeomSegment$draw_panel(data, panel_scales, coord, arrow,
88 88
                                                         lineend, na.rm)
89 89
                              },
90
-                             
90
+
91 91
                              required_aes = c("x", "y", "xend", "yend"),
92 92
                              default_aes = aes(colour = "black", size = 0.5, linetype = 1, alpha = NA),
93
-                             
93
+
94 94
                              draw_key = draw_key_path
95 95
                              )
96 96
 
... ...
@@ -98,7 +98,7 @@ stat_stripText <- function(mapping=NULL, data=NULL,
98 98
                       na.rm=na.rm,
99 99
                       parse=parse,
100 100
                       ...),
101
-          if (packageVersion('ggplot2') > '2.1.0') check.aes = FALSE
101
+          check.aes = FALSE
102 102
           )
103 103
 
104 104
 }
... ...
@@ -134,7 +134,7 @@ stat_stripBar <- function(mapping=NULL, data=NULL,
134 134
                       barextend=barextend,
135 135
                       na.rm=na.rm,
136 136
                       ...),
137
-          if (packageVersion('ggplot2') > '2.1.0') check.aes = FALSE
137
+          check.aes = FALSE
138 138
           )
139 139
 
140 140
 }
... ...
@@ -32,7 +32,7 @@ geom_taxalink <- function(taxa1, taxa2, curvature=0.5, ...) {
32 32
                         curvature = curvature,
33 33
                         na.rm = na.rm,
34 34
                         ...),
35
-          if (packageVersion('ggplot2') > '2.1.0') check.aes = FALSE
35
+          check.aes = FALSE
36 36
           )
37 37
 }
38 38
 
... ...
@@ -55,7 +55,7 @@ geom_text2 <- function(mapping = NULL, data = NULL,
55 55
           na.rm = na.rm,
56 56
           ...
57 57
         ),
58
-        if (packageVersion('ggplot2') > '2.1.0') check.aes = FALSE
58
+        check.aes = FALSE
59 59
     )
60 60
 }
61 61
 
... ...
@@ -111,7 +111,7 @@ geom_tipsegment <- function(mapping=NULL, data=NULL,
111 111
           params = list(offset = offset,
112 112
                         na.rm = na.rm,
113 113
                         ...),
114
-          if (packageVersion('ggplot2') > '2.1.0') check.aes = FALSE
114
+          check.aes = FALSE
115 115
           )
116 116
 }
117 117
 
... ...
@@ -47,7 +47,7 @@ stat_tree <- function(mapping=NULL, data=NULL, geom="segment", position="identit
47 47
                                lineend = lineend,
48 48
                                na.rm = na.rm,
49 49
                                ...),
50
-                   if (packageVersion('ggplot2') > '2.1.0') check.aes = FALSE
50
+                   check.aes = FALSE
51 51
                    ),
52 52
              layer(data=data,
53 53
                    mapping=mapping,
... ...
@@ -60,7 +60,7 @@ stat_tree <- function(mapping=NULL, data=NULL, geom="segment", position="identit
60 60
                                lineend = lineend,
61 61
                                na.rm = na.rm,
62 62
                                ...),
63
-                   if (packageVersion('ggplot2') > '2.1.0') check.aes = FALSE
63
+                   check.aes = FALSE
64 64
                    )
65 65
              )
66 66
     } else if (layout %in% c("slanted", "radial", "unrooted")) {
... ...
@@ -75,7 +75,7 @@ stat_tree <- function(mapping=NULL, data=NULL, geom="segment", position="identit
75 75
                           lineend = lineend,
76 76
                           na.rm = na.rm,
77 77
                           ...),
78
-              if (packageVersion('ggplot2') > '2.1.0') check.aes = FALSE
78
+              check.aes = FALSE
79 79
               )
80 80
     }
81 81
 }
... ...
@@ -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
 }
... ...
@@ -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
-
... ...
@@ -1,6 +1,6 @@
1
-##' plots simultaneously a whole phylogenetic tree and a portion of it. 
1
+##' plots simultaneously a whole phylogenetic tree and a portion of it.
2
+##'
2 3
 ##'
3
-##' 
4 4
 ##' @title gzoom
5 5
 ##' @param phy phylo object
6 6
 ##' @param focus selected tips
... ...
@@ -9,7 +9,6 @@
9 9
 ##' @return a list of ggplot object
10 10
 ##' @importFrom ggplot2 xlim
11 11
 ##' @importFrom ggplot2 scale_color_manual
12
-##' @importFrom ape drop.tip
13 12
 ##' @author ygc
14 13
 ##' @examples
15 14
 ##' require(ape)
... ...
@@ -28,14 +27,14 @@ gzoom.phylo <- function(phy, focus, subtree=FALSE, widths=c(.3, .7)) {
28 27
     cols <- c("black", "red")[foc+1]
29 28
 
30 29
     p1 <- ggtree(phy, color=cols)
31
-    
30
+
32 31
     subtr <- drop.tip(phy, phy$tip.label[-focus],
33 32
                       subtree=subtree, rooted=TRUE)
34
-    
33
+
35 34
     p2 <- ggtree(subtr, color="red") + geom_tiplab(hjust=-0.05)
36 35
     p2 <- p2 + xlim(0, max(p2$data$x)*1.2)
37
-    multiplot(p1, p2, ncol=2, widths=widths) 
38
-    
36
+    multiplot(p1, p2, ncol=2, widths=widths)
37
+
39 38
     invisible(list(p1=p1, p2=p2))
40 39
 }
41 40
 
... ...
@@ -68,7 +67,7 @@ setMethod("gzoom", signature(object="apeBootstrap"),
68 67
 
69 68
 ##' zoom selected subtree
70 69
 ##'
71
-##' 
70
+##'
72 71
 ##' @rdname gzoom-methods
73 72
 ##' @exportMethod gzoom
74 73
 setMethod("gzoom", signature(object="beast"),
... ...
@@ -1,8 +1,8 @@
1 1
 ##' site mask
2 2
 ##'
3
-##' 
3
+##'
4 4
 ##' @title mask
5
-##' @param tree_object tree object 
5
+##' @param tree_object tree object
6 6
 ##' @param field selected field
7 7
 ##' @param site site
8 8
 ##' @param mask_site if TRUE, site will be masked.
... ...
@@ -38,15 +38,15 @@ mask <- function(tree_object, field, site, mask_site=FALSE) {
38 38
         gsub("^[a-zA-Z]+", "", . ) %>%
39 39
         gsub("[a-zA-Z]\\s*$", "", .) %>%
40 40
         as.numeric
41
-    
41
+
42 42
     if (mask_site == FALSE) {
43 43
         pos2 <- 1:max(pos)
44 44
         pos2 <- pos2[-site]
45 45
         site <- pos2
46 46
     }
47
-    
47
+
48 48
     site <- site[site %in% pos]
49
-    
49
+
50 50
     for (i in seq_along(field_data)) {
51 51
         if (is.na(field_data[i]))
52 52
             next
... ...
@@ -95,7 +95,7 @@ read.dnds_mlc <- function(mlcfile) {
95 95
     mlc <- readLines(mlcfile)
96 96
     i <- grep("dN & dS for each branch", mlc)
97 97
     j <- grep("tree length for dN", mlc)
98
-    
98
+
99 99
     mlc <- mlc[i:j]
100 100
     hi <- grep("dN/dS", mlc)
101 101
     cn <- strsplit(mlc[hi], " ") %>% unlist %>% `[`(nzchar(.))
... ...
@@ -110,14 +110,14 @@ read.dnds_mlc <- function(mlcfile) {
110 110
         yy <- c(edge, y[-1])
111 111
         as.numeric(yy)
112 112
     }))
113
-             
113
+
114 114
     row.names(res) <- NULL
115 115
     colnames(res) <- c("parent", "node", cn[-1])
116 116
     colnames(res) <- gsub("\\*", "_x_", colnames(res))
117 117
     colnames(res) <- gsub("\\/", "_vs_", colnames(res))
118 118
     return(res)
119 119
 }
120
-    
120
+
121 121
 read.treetext_paml_mlc <- function(mlcfile) {
122 122
     read.treetext_paml(mlcfile, "mlc")
123 123
 }
... ...
@@ -138,14 +138,13 @@ read.treetext_paml <- function(file, by) {
138 138
     } else {
139 139
         stop("_by_ should be one of 'rst' or 'mlc'")
140 140
     }
141
-        
141
+
142 142
     return(x[tr.idx][ii])
143 143
 }
144 144
 
145
-##' @importFrom ape Ntip
146 145
 read.phylo_paml_mlc <- function(mlcfile) {
147 146
     parent <- node <- label <- NULL
148
-    
147
+
149 148
     mlc <- readLines(mlcfile)
150 149
     edge <- get_tree_edge_paml(mlc)
151 150
 
... ...
@@ -189,7 +188,7 @@ read.phylo_paml_mlc <- function(mlcfile) {
189 188
                 }
190 189
                 treeinfo[ii, "visited"] <- TRUE
191 190
             }
192
-            
191
+
193 192
         }
194 193
         currentNode <- unique(pNode)
195 194
     }
... ...
@@ -211,7 +210,7 @@ read.phylo_paml_mlc <- function(mlcfile) {
211 210
 ##' @importFrom ape reorder.phylo
212 211
 read.phylo_paml_rst <- function(rstfile) {
213 212
     parent <- node <- label <- NULL
214
-    
213
+
215 214
     ## works fine with baseml and codeml
216 215
     rst <- readLines(rstfile)
217 216
     tr.idx <- get_tree_index_paml(rst)
... ...
@@ -220,7 +219,7 @@ read.phylo_paml_rst <- function(rstfile) {
220 219
     tr3 <- read.tree(text=rst[tr.idx][3])
221 220
 
222 221
     edge <- get_tree_edge_paml(rst)
223
-    
222
+
224 223
     label=c(tr3$tip.label, tr3$node.label)
225 224
     root <- getRoot(tr3)
226 225
     label %<>% `[`(. != root)
... ...
@@ -231,14 +230,14 @@ read.phylo_paml_rst <- function(rstfile) {
231 230
     ## node.length$node <- sub("_\\w+", "", node.length$label
232 231
     node.length$node <- gsub("^(\\d+)_.*", "\\1", node.length$label)
233 232
     node.length$label %<>% sub("\\d+_", "", .)
234
-    
233
+
235 234
     edge <- as.data.frame(edge)
236 235
     colnames(edge) <- c("parent", "node")
237 236
 
238 237
     treeinfo <- merge(edge, node.length, by.x="node", by.y="node")
239 238
     edge2 <- treeinfo[, c("parent", "node")]
240 239
     edge2 %<>% as.matrix
241
-    
240
+
242 241
     ntip <- Ntip(tr3)
243 242
 
244 243
     phylo <- with(treeinfo,
... ...
@@ -253,7 +252,7 @@ read.phylo_paml_rst <- function(rstfile) {
253 252
 
254 253
     class(phylo) <- "phylo"
255 254
     phylo <- reorder.phylo(phylo, "cladewise")
256
-    
255
+
257 256
     return(phylo)
258 257
 }
259 258
 
... ...
@@ -262,10 +261,10 @@ read.ancseq_paml_rst <- function(rstfile, by="Marginal") {
262 261
     rst <- readLines(rstfile)
263 262
 
264 263
     by <- match.arg(by, c("Marginal", "Joint"))
265
-    query <- paste(by, "reconstruction of ancestral sequences") 
264
+    query <- paste(by, "reconstruction of ancestral sequences")
266 265
     idx <- grep(query, rst)
267 266
     if(length(idx) == 0) {
268
-        ## in some paml setting, joint_ancseq are not available. 
267
+        ## in some paml setting, joint_ancseq are not available.
269 268
         return("")
270 269
     }
271 270
     si <- grep("reconstructed sequences", rst)
... ...
@@ -323,13 +322,13 @@ set.paml_rst_ <- function(object) {
323 322
     if (length(object@tip_seq) == 0) {
324 323
         return(object)
325 324
     }
326
-    
325
+
327 326
     types <- get.fields(object)
328 327
     for (type in types) {
329 328
         value <- subs_paml_rst(object, type)
330 329
         if (all(is.na(value)))
331 330
             next
332
-        
331
+
333 332
         if (type == "marginal_subs") {
334 333
             object@marginal_subs <- value
335 334
         } else if (type == "marginal_AA_subs") {
... ...
@@ -1,3 +1,16 @@
1
+Ntip <- function(tree) {
2
+    phylo <- get.tree(tree)
3
+    length(phylo$tip.label)
4
+}
5
+
6
+Nnode <- function(tree, internal.only=TRUE) {
7
+    phylo <- get.tree(tree)
8
+    if (internal.only)
9
+        return(phylo$Nnode)
10
+
11
+    Ntip(phylo) + phylo$Nnode
12
+}
13
+
1 14
 
2 15
 filename <- function(file) {
3 16
     ## textConnection(text_string) will work just like a file
... ...
@@ -12,7 +25,7 @@ filename <- function(file) {
12 25
 
13 26
 ##' @importFrom ggplot2 last_plot
14 27
 get_tree_view <- function(tree_view) {
15
-    if (is.null(tree_view)) 
28
+    if (is.null(tree_view))
16 29
         tree_view <- last_plot()
17 30
 
18 31
     return(tree_view)
... ...
@@ -33,7 +46,7 @@ has.field <- function(tree_object, field) {
33 46
     if ( ! field %in% get.fields(tree_object) ) {
34 47
         return(FALSE)
35 48
     }
36
-    
49
+
37 50
     if (is(tree_object, "codeml")) {
38 51
         is_codeml <- TRUE
39 52
         tree <- tree_object@rst
... ...
@@ -41,22 +54,22 @@ has.field <- function(tree_object, field) {
41 54
         is_codeml <- FALSE
42 55
         tree <- tree_object
43 56
     }
44
-    
57
+
45 58
     if (.hasSlot(tree, field)) {
46 59
         has_slot <- TRUE
47 60
     } else {
48 61
         has_slot <- FALSE
49 62
     }
50
-    
63
+
51 64
     if (has_slot == FALSE) {
52 65
         if (has.extraInfo(tree_object) == FALSE) {
53 66
             return(FALSE)
54 67
         }
55
-        
68
+
56 69
         if (nrow(tree_object@extraInfo) == 0) {
57 70
             return(FALSE)
58 71
         }
59
-        
72
+
60 73
         if (!field %in% colnames(tree_object@extraInfo)) {
61 74
             return(FALSE)
62 75
         }
... ...
@@ -82,7 +95,7 @@ has.extraInfo <- function(object) {
82 95
         return(TRUE)
83 96
     }
84 97
 
85
-    return(FALSE)        
98
+    return(FALSE)
86 99
 }
87 100
 
88 101
 append_extraInfo <- function(df, object) {
... ...
@@ -110,7 +123,7 @@ get.fields.tree <- function(object) {
110 123
     } else {
111 124
         fields <- object@fields
112 125
     }
113
-    
126
+
114 127
     if (has.slot(object, "extraInfo")) {
115 128
         extraInfo <- object@extraInfo
116 129
         if (nrow(extraInfo) > 0) {
... ...
@@ -124,7 +137,7 @@ get.fields.tree <- function(object) {
124 137
 }
125 138
 
126 139
 print_fields <- function(object, len=5) {
127
-    fields <- get.fields(object)    
140
+    fields <- get.fields(object)
128 141
     n <- length(fields)
129 142
     i <- floor(n/len)
130 143
     for (j in 0:i) {
... ...
@@ -158,7 +171,7 @@ plot.subs <- function(x, layout, show.tip.label,
158 171
                       position, annotation,
159 172
                       annotation.color = "black",
160 173
                       annotation.size=3, ...) {
161
-    
174
+
162 175
     p <- ggtree(x, layout=layout, ...)
163 176
     if (show.tip.label) {
164 177
         p <- p + geom_tiplab(hjust = tip.label.hjust,
... ...
@@ -174,7 +187,7 @@ plot.subs <- function(x, layout, show.tip.label,
174 187
 
175 188
 .add_new_line <- function(res) {
176 189
     ## res <- paste0(strwrap(res, 50), collapse="\n")
177
-    ## res %<>% gsub("\\s/\n", "\n", .) %>% gsub("\n/\\s", "\n", .) 
190
+    ## res %<>% gsub("\\s/\n", "\n", .) %>% gsub("\n/\\s", "\n", .)
178 191
     if (nchar(res) > 50) {
179 192
         idx <- gregexpr("/", res)[[1]]
180 193
         i <- idx[floor(length(idx)/2)]
... ...
@@ -198,7 +211,7 @@ get.subs_ <- function(tree, fasta, translate=TRUE, removeGap=TRUE) {
198 211
         }
199 212
         .add_new_line(res)
200 213
     })
201
-    
214
+
202 215
     dd <- data.frame(node=node, parent=parent, label=label, subs=subs)
203 216
     dd <- dd[dd$parent != 0,]
204 217
     dd <- dd[, -c(1,2)]
... ...
@@ -214,7 +227,7 @@ getSubsLabel <- function(seqs, A, B, translate, removeGap) {
214 227
     if (nchar(seqA) != nchar(seqB)) {
215 228
         stop("seqA should have equal length to seqB")
216 229
     }
217
-    
230
+
218 231
     if (translate == TRUE) {
219 232
         AA <- seqA %>% seq2codon %>% codon2AA
220 233
         BB <- seqB %>% seq2codon %>% codon2AA
... ...
@@ -227,7 +240,7 @@ getSubsLabel <- function(seqs, A, B, translate, removeGap) {
227 240
         AA <- strsplit(seqA, split="") %>% unlist
228 241
         BB <- strsplit(seqB, split="") %>% unlist
229 242
     }
230
-    
243
+
231 244
     ii <- which(AA != BB)
232 245
 
233 246
     if (removeGap == TRUE) {
... ...
@@ -239,11 +252,11 @@ getSubsLabel <- function(seqs, A, B, translate, removeGap) {
239 252
             ii <- ii[AA[ii] != "-" & BB[ii] != "-"]
240 253
         }
241 254
     }
242
-    
255
+
243 256
     if (length(ii) == 0) {
244 257
         return(NULL)
245 258
     }
246
-    
259
+
247 260
     res <- paste(AA[ii], ii, BB[ii], sep="", collapse=" / ")
248 261
     return(res)
249 262
 }
... ...
@@ -255,7 +268,7 @@ seq2codon <- function(x) {
255 268
 ## @importFrom Biostrings GENETIC_CODE
256 269
 codon2AA <- function(codon) {
257 270
     ## a genetic code name vector
258
-    GENETIC_CODE <- get_fun_from_pkg("Biostrings", "GENETIC_CODE") 
271
+    GENETIC_CODE <- get_fun_from_pkg("Biostrings", "GENETIC_CODE")
259 272
     aa <- GENETIC_CODE[codon]
260 273
     aa[is.na(aa)] <- "X"
261 274
     return(aa)
... ...
@@ -327,22 +340,22 @@ jplace_treetext_to_phylo <- function(tree.text) {
327 340
     ##                         edgeNum = as.numeric(gsub(".+\\{", "", edgeLN)))
328 341
 
329 342
     ## xx <- merge(edgeLN.df, edgeNum.df, by.x="node", by.y="node")
330
-    
343
+
331 344
     return(phylo)
332 345
 }
333 346
 
334 347
 extract.treeinfo.jplace <- function(object, layout="phylogram", ladderize=TRUE, right=FALSE, ...) {
335 348
 
336 349
     tree <- get.tree(object)
337
-    
350
+
338 351
     df <- fortify.phylo(tree, layout=layout, ladderize=ladderize, right=right, ...)
339 352
 
340 353
     edgeNum.df <- attr(tree, "edgeNum")
341 354
     if (!is.null(edgeNum.df)) {
342
-        df2 <- merge(df, edgeNum.df, by.x="node", by.y="node", all.x=TRUE) 
355
+        df2 <- merge(df, edgeNum.df, by.x="node", by.y="node", all.x=TRUE)
343 356
         df <- df2[match(df[, "node"], df2[, "node"]),]
344 357
     }
345
-    
358
+
346 359
     attr(df, "ladderize") <- ladderize
347 360
     attr(df, "right") <- right
348 361
     return(df)
... ...
@@ -356,7 +369,7 @@ edgeNum2nodeNum <- function(jp, edgeNum) {
356 369
     if (length(idx) == 0) {
357 370
         return(NA)
358 371
     }
359
-    
372
+
360 373
     edges[idx, "node"]
361 374
 }
362 375
 
... ...
@@ -427,7 +440,7 @@ is.tree_attribute <- function(df, var) {
427 440
        !is.null(var)    &&
428 441
        var %in% colnames(df)) {
429 442
         return(TRUE)
430
-    } 
443
+    }
431 444
     return(FALSE)
432 445
 }
433 446
 
... ...
@@ -483,14 +496,14 @@ roundDigit <- function(d) {
483 496
 ## from ChIPseeker
484 497
 ##' @importFrom grDevices colorRampPalette
485 498
 getCols <- function (n) {
486
-    col <- c("#8dd3c7", "#ffffb3", "#bebada", "#fb8072", "#80b1d3", 
487
-             "#fdb462", "#b3de69", "#fccde5", "#d9d9d9", "#bc80bd", 
499
+    col <- c("#8dd3c7", "#ffffb3", "#bebada", "#fb8072", "#80b1d3",
500
+             "#fdb462", "#b3de69", "#fccde5", "#d9d9d9", "#bc80bd",
488 501
              "#ccebc5", "#ffed6f")
489
-    col2 <- c("#1f78b4", "#ffff33", "#c2a5cf", "#ff7f00", "#810f7c", 
490
-              "#a6cee3", "#006d2c", "#4d4d4d", "#8c510a", "#d73027", 
502
+    col2 <- c("#1f78b4", "#ffff33", "#c2a5cf", "#ff7f00", "#810f7c",
503
+              "#a6cee3", "#006d2c", "#4d4d4d", "#8c510a", "#d73027",
491 504
               "#78c679", "#7f0000", "#41b6c4", "#e7298a", "#54278f")
492
-    col3 <- c("#a6cee3", "#1f78b4", "#b2df8a", "#33a02c", "#fb9a99", 
493
-              "#e31a1c", "#fdbf6f", "#ff7f00", "#cab2d6", "#6a3d9a", 
505
+    col3 <- c("#a6cee3", "#1f78b4", "#b2df8a", "#33a02c", "#fb9a99",
506
+              "#e31a1c", "#fdbf6f", "#ff7f00", "#cab2d6", "#6a3d9a",
494 507
               "#ffff99", "#b15928")
495 508
     colorRampPalette(col3)(n)
496 509
 }
... ...
@@ -1,8 +1,13 @@
1
+##' @importFrom utils packageDescription
1 2
 .onAttach <- function(libname, pkgname) {
2
-    ##	pkgVersion <- packageDescription(pkgname, fields="Version")
3
-    msg <- paste0("If you use ggtree in published research, please cite:\n\n",
4
-                  "Guangchuang Yu, David Smith, Huachen Zhu, Yi Guan, Tommy Tsan-Yuk Lam.\n",
5
-                  "ggtree: an R package for visualization and annotation of phylogenetic trees with their covariates and other associated data.\n",
6
-                  "Methods in Ecology and Evolution 2016, doi:10.1111/2041-210X.12628\n\n")
7
-    packageStartupMessage(msg)
3
+    pkgVersion <- packageDescription(pkgname, fields="Version")
4
+    msg <- paste0(pkgname, " v", pkgVersion, "  ",
5
+                  "For help: https://guangchuangyu.github.io/", pkgname, "\n\n")
6
+
7
+    citation <- paste0("If you use ", pkgname, " in published research, please cite:\n",
8
+                  "Guangchuang Yu, David Smith, Huachen Zhu, Yi Guan, Tommy Tsan-Yuk Lam. ",
9
+                  "ggtree: an R package for visualization and annotation of phylogenetic trees with their covariates and other associated data. ",
10
+                  "Methods in Ecology and Evolution 2016, doi:10.1111/2041-210X.12628")
11
+
12
+    packageStartupMessage(paste0(msg, citation))
8 13
 }
... ...
@@ -5,6 +5,9 @@ output:
5 5
 html_preview: false
6 6
 ---
7 7
 
8
+<!-- README.md is generated from README.Rmd. Please edit that file -->
9
+
10
+
8 11
 #  ggtree: an R package for visualization and annotation of phylogenetic trees with their covariates and other associated data
9 12
 
10 13
 ```{r echo=FALSE, results="hide", message=FALSE}
... ...
@@ -17,7 +20,7 @@ library("ypages")
17 20
 [![Bioc](http://www.bioconductor.org/shields/years-in-bioc/ggtree.svg)](https://www.bioconductor.org/packages/devel/bioc/html/ggtree.html#since)
18 21
 `r badge_download("ggtree", "total", "blue")`
19 22
 `r badge_download("ggtree", "month", "blue")`
20
-
23
+<img src="logo.png" align="right" />
21 24
 
22 25
 [![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)
23 26
 [![codecov](https://codecov.io/gh/GuangchuangYu/ggtree/branch/master/graph/badge.svg)](https://codecov.io/gh/GuangchuangYu/ggtree)
... ...
@@ -69,7 +72,7 @@ txtplot(d$year, d$cites, xlim=c(2015, 2017))
69 72
 
70 73
 ### Download stats
71 74
 
72
-[![download](http://www.bioconductor.org/shields/downloads/ggtree.svg)](https://bioconductor.org/packages/stats/bioc/ggtree/)
75
+`r badge_download_bioc("ggtree")`
73 76
 `r badge_download("ggtree", "total", "blue")`
74 77
 `r badge_download("ggtree", "month", "blue")`
75 78
 
... ...
@@ -1,9 +1,10 @@
1
+<!-- README.md is generated from README.Rmd. Please edit that file -->
1 2
 ggtree: an R package for visualization and annotation of phylogenetic trees with their covariates and other associated data
2 3
 ===========================================================================================================================
3 4
 
4
-[![releaseVersion](https://img.shields.io/badge/release%20version-1.6.2-green.svg?style=flat)](https://bioconductor.org/packages/ggtree) [![develVersion](https://img.shields.io/badge/devel%20version-1.7.2-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-16279/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)
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" />
5 6
 
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--11--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)
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)
7 8
 
8 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)
9 10
 
... ...
@@ -17,7 +18,7 @@ Please cite the following article when using `ggtree`:
17 18
 
18 19
 **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 20
 
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) [![citation](https://img.shields.io/badge/cited%20by-1-green.svg?style=flat)](https://scholar.google.com.hk/scholar?oi=bibs&hl=en&cites=7268358477862164627) [![Altmetric](https://img.shields.io/badge/Altmetric-274-green.svg?style=flat)](https://www.altmetric.com/details/10533079)
21
+[![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) [![citation](https://img.shields.io/badge/cited%20by-1-green.svg?style=flat)](https://scholar.google.com.hk/scholar?oi=bibs&hl=en&cites=7268358477862164627) [![Altmetric](https://img.shields.io/badge/Altmetric-273-green.svg?style=flat)](https://www.altmetric.com/details/10533079)
21 22
 
22 23
 ------------------------------------------------------------------------
23 24
 
... ...
@@ -50,7 +51,7 @@ For details, please visit our project website, <https://guangchuangyu.github.io/
50 51
 
51 52
 ### Download stats
52 53
 
53
-[![download](http://www.bioconductor.org/shields/downloads/ggtree.svg)](https://bioconductor.org/packages/stats/bioc/ggtree/) [![total](https://img.shields.io/badge/downloads-16279/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)
54
+[![download](http://www.bioconductor.org/shields/downloads/ggtree.svg)](https://bioconductor.org/packages/stats/bioc/ggtree) [![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)
54 55
 
55 56
          +------------------------+-----------------------+-----------------------+--------------------+
56 57
          |                                                                                    *        |
57 58
new file mode 100644
58 59
Binary files /dev/null and b/logo.png differ
59 60
new file mode 100644
... ...
@@ -0,0 +1,42 @@
1
+% Generated by roxygen2: do not edit by hand
2
+% Please edit documentation in R/AllGenerics.R, R/method-drop-tip.R
3
+\docType{methods}
4
+\name{drop.tip}
5
+\alias{drop.tip}
6
+\alias{drop.tip,nhx}
7
+\alias{drop.tip,nhx-method}
8
+\alias{drop.tip,phylo}
9
+\alias{drop.tip,phylo-method}
10
+\title{drop.tip method}
11
+\source{
12
+drop.tip for phylo object is a wrapper method of ape::drop.tip
13
+from the ape package. The documentation you should
14
+read for the drop.tip function can be found here: \link[ape]{drop.tip}
15
+}
16
+\usage{
17
+drop.tip(object, tip, ...)
18
+
19
+drop.tip(object, tip, ...)
20
+
21
+\S4method{drop.tip}{phylo}(object, tip, ...)
22
+}
23
+\arguments{
24
+\item{object}{An nhx or phylo object}
25
+
26
+\item{tip}{a vector of mode numeric or character specifying the tips to delete}
27
+
28
+\item{...}{additional parameters}
29
+}
30
+\value{
31
+updated object
32
+}
33
+\description{
34
+drop.tip method
35
+}
36
+\author{
37
+Casey Dunn \url{http://dunnlab.org}  and Guangchuang Yu \url{https://guangchuangyu.github.io}
38
+}
39
+\seealso{
40
+\link[ape]{drop.tip}
41
+}
42
+
... ...
@@ -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,
... ...
@@ -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
... ...
@@ -7,16 +7,16 @@ test_phyldog_nhx_text = "(((Prayidae_D27SS7@2825365:0.0682841[&&NHX:Ev=S:S=58:ND
7 7
 
8 8
 test_notung_nhx_text = "((((Rhizophysa_filiformis@2564549:0.09666991738603078[&&NHX:S=Rhizophysa_filiformis],((Marrus_claudanielis@2027078:0.03368582974818837[&&NHX:S=Marrus_claudanielis],((Erenna_richardi@1434201:0.014306889954561298[&&NHX:S=Erenna_richardi],Marrus_claudanielis@2027079:0.010842363778569869[&&NHX:S=Marrus_claudanielis])n5940011:0.01779384958849464[&&NHX:S=n57:D=N],(((Agalma_elegans@88626:0.05872379503260147[&&NHX:S=Agalma_elegans],Lychnagalma_utricularia@1828459:0.04211137470826968[&&NHX:S=Lychnagalma_utricularia])n5940018:0.02375590664436535[&&NHX:S=n47:D=N],(((Bargmannia_amoena@3459111:0.19058396964770352[&&NHX:S=Bargmannia_amoena],Bargmannia_elongata@469437:1.00000050002909E-6[&&NHX:S=Bargmannia_elongata])n5939974:0.11560220708003867[&&NHX:S=n22:D=N],Cordagalma_sp_@1115328:0.04829417133033771[&&NHX:S=Cordagalma_sp_])n5939976:0.011316847557531757[&&NHX:S=n62:D=N],Forskalia_asymmetrica@1220430:0.01667566952752948[&&NHX:S=Forskalia_asymmetrica])n5939978:0.0063213422810751655[&&NHX:S=n62:D=Y])n5940014:0.017792661031819083[&&NHX:S=n62:D=Y],(Resomia_ornicephala@2657185:0.004262563771468986[&&NHX:S=Resomia_ornicephala],Frillagalma_vityazi@663744:0.028441637105547157[&&NHX:S=Frillagalma_vityazi])n5939981:0.006136291467151878[&&NHX:S=n51:D=N])n5940013:0.013546839136761205[&&NHX:S=n62:D=Y])n5940012:0.011839606018978143[&&NHX:S=n62:D=Y])n5940008:0.013840645450221475[&&NHX:S=n62:D=Y],(((Chelophyes_appendiculata@1615707:0.007647023552225329[&&NHX:S=Chelophyes_appendiculata],Clytia_hemisphaerica@756642:0.643907456299178[&&NHX:S=Clytia_hemisphaerica])n5939984:0.08603691877960613[&&NHX:S=n67:D=N],(Chuniphyes_multidentata@930929:0.01248550133310033[&&NHX:S=Chuniphyes_multidentata],Kephyes_ovata@1966030:0.014671165587181996[&&NHX:S=Kephyes_ovata])n5939987:0.013285803501636162[&&NHX:S=n27:D=N])n5939988:0.008000411801689693[&&NHX:S=n67:D=Y],(((Hippopodius_hippopus@1084434:0.0505718831943577[&&NHX:S=Hippopodius_hippopus],Prayidae_D27D2@2878798:0.00905875758406546[&&NHX:S=Prayidae_D27D2])n5939991:0.021772123626769023[&&NHX:S=n38:D=N],Prayidae_D27SS7@2181711:0.029009000260863272[&&NHX:S=Prayidae_D27SS7])n5939993:1.00000050002909E-6[&&NHX:S=n38:D=Y],Prayidae_D27D2@2878801:1.00000050002909E-6[&&NHX:S=Prayidae_D27D2])n5939995:0.00916688375355408[&&NHX:S=n38:D=Y])n5939996:0.05191099091093772[&&NHX:S=n67:D=Y])n5940006:0.03953811931719265[&&NHX:S=n67:D=Y])n5940005:0.10134081070615458[&&NHX:S=n67:D=Y],(Podocoryna_carnea@3033951:0.11270255504816476[&&NHX:S=Podocoryna_carnea],Hydractinia_symbiolongicarpus@1679508:0.030168043235021993[&&NHX:S=Hydractinia_symbiolongicarpus])n5939999:0.17223048099362362[&&NHX:S=n11:D=N])n5940003:0.16233679521228994[&&NHX:S=n67:D=Y],Hydra_magnipapillata@801936:0.585696573276294[&&NHX:S=Hydra_magnipapillata])n5940002:0.4403044529817829[&&NHX:S=n68:D=N],Aegina_citrea@825314:0.4403044529817829[&&NHX:S=Aegina_citrea])n5942419[&&NHX:S=n70:D=N];"
9 9
 
10
-# A function to simplify NHX text so that it can be parsed by 
11
-# ape::read.tree(). Discards much useful information. Intent is to 
10
+# A function to simplify NHX text so that it can be parsed by
11
+# ape::read.tree(). Discards much useful information. Intent is to
12 12
 # be able to compare node annotations that have been independently
13
-# parsed with different methods. 
13
+# parsed with different methods.
14 14
 simplify_nhx_string <- function( text ){
15 15
 	# Remove branch lengths so NHX tags are adjacent to nodes
16 16
 	# Accommodate lengths in scientific notation, eg 1e-6
17 17
 	text = gsub( "\\:[\\d\\.]+e[\\d\\-]+","", text, perl=TRUE )
18 18
 	text = gsub( "\\:[\\d\\.]+","", text, perl=TRUE )
19
-	
19
+
20 20
 	# Remove NHX tags at tips
21 21
 	text = gsub( "([^\\)])\\[.+?\\]","\\1", text, perl=TRUE )
22 22
 
... ...
@@ -27,7 +27,7 @@ simplify_nhx_string <- function( text ){
27 27
 	# Replace NHX tag formatting characters that aren't allowed
28 28
 	text = gsub( ":","_", text, perl=TRUE )
29 29
 	text = gsub( "=","-", text, perl=TRUE )
30
-	
30
+
31 31
 	return(text)
32 32
 }
33 33
 
... ...
@@ -74,4 +74,13 @@ test_that("can parse phyldog nhx tree string", {
74 74
 	S.tip.values = c(58, 69, 70, 31, 37, 38, 61, 52, 53, 54, 65, 71, 64, 26, 16, 15)
75 75
 	expect_equal( S.tip.values[match(nhx@phylo$tip.label, tip.labels)], as.numeric(tip_tags$S))
76 76
 
77
-})
78 77
\ No newline at end of file
78
+})
79
+
80
+test_that("can drop tips", {
81
+	nhx <- read.nhx( textConnection(test_phyldog_nhx_text) )
82
+        to_drop = c("Physonect_sp_@2066767", "Lychnagalma_utricularia@2253871", "Kephyes_ovata@2606431")
83
+
84
+	nhx_reduced = drop.tip(nhx, to_drop)
85
+	expect_equal( length(nhx_reduced@phylo$tip.label), 13 )
86
+        expect_true( all(nhx_reduced@nhx_tags$node %in% fortify(nhx_reduced)$node) )
87
+})