1. ggtree
  2. Commit f1f0d8d2ae1f725f19cdc5a77fabbb740ae6629e
Browse code

lots updates

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

g.yu authored on 22/12/2015 04:08:02
Showing 110 changed files
.gitignore
History View file @ f1f0d8d2
... ... 
@@ -1,5 +1,6 @@
1 1 
 .DS_Store
2 2 
 R/.DS_Store
3 3 
 vignettes/.DS_Store
4 
-
4 
+*~
5 
+*.Rhistrory
5 6 
 .svn
DESCRIPTION
History View file @ f1f0d8d2
... ... 
@@ -1,7 +1,7 @@
1 1 
 Package: ggtree
2 2 
 Type: Package
3 3 
 Title: a phylogenetic tree viewer for different types of tree annotations
4 
-Version: 1.3.0
4 
+Version: 1.3.6
5 5 
 Author: Guangchuang Yu and Tommy Tsan-Yuk Lam
6 6 
 Maintainer: Guangchuang Yu <guangchuangyu@gmail.com>
7 7 
 Description: ggtree extends the ggplot2 plotting system which implemented the
... ... 
@@ -9,11 +9,11 @@ Description: ggtree extends the ggplot2 plotting system which implemented the
9 9 
     and different types of associated annotation data.
10 10 
 Depends:
11 11 
     R (>= 3.1.0)
12 
+    ggplot2 (>= 2.0.0)
12 13 
 Imports:
13 14 
     ape,
14 15 
     Biostrings,
15 16 
     colorspace,
16 
-    EBImage,
17 17 
     ggplot2,
18 18 
     grid,
19 19 
     gridExtra,
... ... 
@@ -23,15 +23,19 @@ Imports:
23 23 
     reshape2,
24 24 
     stats4
25 25 
 Suggests:
26 
-    phylobase,
27 26 
     BiocStyle,
27 
+    EBImage,
28 28 
     knitr,
29 
-    testthat,
30 
-    rmarkdown
29 
+    phylobase,
30 
+    phytools,
31 
+    phangorn,
32 
+    rmarkdown,
33 
+    testthat
31 34 
 VignetteBuilder: knitr
32 35 
 License: Artistic-2.0
33 36 
 URL: https://github.com/GuangchuangYu/ggtree
34 37 
 BugReports: https://github.com/GuangchuangYu/ggtree/issues
35 38 
 Packaged: 2014-12-03 08:16:14 UTC; root
36 
-biocViews: Alignment, Annotation, Clustering, DataImport, MultipleSequenceAlignment,
37 
-	   ReproducibleResearch, Software, Visualization
39 
+biocViews: Alignment, Annotation, Clustering, DataImport,
40 
+    MultipleSequenceAlignment, ReproducibleResearch, Software, Visualization
41 
+RoxygenNote: 5.0.1
NAMESPACE
History View file @ f1f0d8d2
... ... 
@@ -1,14 +1,17 @@
1 
-# Generated by roxygen2 (4.1.1): do not edit by hand
1 
+# Generated by roxygen2: do not edit by hand
2 2
3 3 
 S3method(as.binary,phylo)
4 4 
 S3method(as.data.frame,phylo)
5 
+S3method(fortify,apeBootstrap)
5 6 
 S3method(fortify,beast)
6 7 
 S3method(fortify,codeml)
7 8 
 S3method(fortify,codeml_mlc)
8 9 
 S3method(fortify,hyphy)
9 10 
 S3method(fortify,jplace)
10 11 
 S3method(fortify,multiPhylo)
12 
+S3method(fortify,nhx)
11 13 
 S3method(fortify,paml_rst)
14 
+S3method(fortify,phangorn)
12 15 
 S3method(fortify,phylo)
13 16 
 S3method(fortify,phylo4)
14 17 
 S3method(fortify,r8s)
... ... 
@@ -18,12 +21,14 @@ export("%<+%")
18 21 
 export("%>%")
19 22 
 export(.)
20 23 
 export(Date2decimal)
24 
+export(MRCA)
25 
+export(StatHilight)
21 26 
 export(add_colorbar)
22 
-export(add_legend)
23 27 
 export(aes)
24 28 
 export(annotation_clade)
25 29 
 export(annotation_clade2)
26 30 
 export(annotation_image)
31 
+export(apeBoot)
27 32 
 export(as.binary)
28 33 
 export(collapse)
29 34 
 export(decimal2Date)
... ... 
@@ -31,12 +36,18 @@ export(download.phylopic)
31 36 
 export(expand)
32 37 
 export(flip)
33 38 
 export(geom_aline)
39 
+export(geom_cladelabel)
40 
+export(geom_hilight)
34 41 
 export(geom_nodepoint)
42 
+export(geom_point2)
35 43 
 export(geom_rootpoint)
44 
+export(geom_segment2)
36 45 
 export(geom_text)
46 
+export(geom_text2)
37 47 
 export(geom_tiplab)
38 48 
 export(geom_tippoint)
39 49 
 export(geom_tree)
50 
+export(geom_treescale)
40 51 
 export(get.fields)
41 52 
 export(get.offspring.tip)
42 53 
 export(get.path)
... ... 
@@ -49,6 +60,8 @@ export(get.treeinfo)
49 60 
 export(get.treetext)
50 61 
 export(getNodeNum)
51 62 
 export(getRoot)
63 
+export(get_clade_position)
64 
+export(get_heatmap_column_position)
52 65 
 export(get_taxa_name)
53 66 
 export(ggplotGrob)
54 67 
 export(ggtree)
... ... 
@@ -57,18 +70,20 @@ export(gplot)
57 70 
 export(groupClade)
58 71 
 export(groupOTU)
59 72 
 export(gzoom)
60 
-export(hilight)
61 73 
 export(mask)
62 74 
 export(merge_tree)
63 75 
 export(msaplot)
76 
+export(phyPML)
64 77 
 export(phylopic)
65 78 
 export(plot)
79 
+export(pmlToSeq)
66 80 
 export(read.baseml)
67 81 
 export(read.beast)
68 82 
 export(read.codeml)
69 83 
 export(read.codeml_mlc)
70 84 
 export(read.hyphy)
71 85 
 export(read.jplace)
86 
+export(read.nhx)
72 87 
 export(read.paml_rst)
73 88 
 export(read.r8s)
74 89 
 export(read.raxml)
... ... 
@@ -79,17 +94,21 @@ export(rtree)
79 94 
 export(scaleClade)
80 95 
 export(scale_color)
81 96 
 export(scale_x_ggtree)
97 
+export(stat_hilight)
82 98 
 export(subview)
83 99 
 export(theme_transparent)
84 100 
 export(theme_tree)
85 101 
 export(theme_tree2)
86 102 
 export(write.jplace)
103 
+exportClasses(apeBootstrap)
87 104 
 exportClasses(beast)
88 105 
 exportClasses(codeml)
89 106 
 exportClasses(codeml_mlc)
90 107 
 exportClasses(hyphy)
91 108 
 exportClasses(jplace)
109 
+exportClasses(nhx)
92 110 
 exportClasses(paml_rst)
111 
+exportClasses(phangorn)
93 112 
 exportClasses(r8s)
94 113 
 exportClasses(raxml)
95 114 
 exportMethods(get.fields)
... ... 
@@ -106,14 +125,15 @@ exportMethods(plot)
106 125 
 exportMethods(reroot)
107 126 
 exportMethods(scale_color)
108 127 
 exportMethods(show)
128 
+importFrom(Biostrings,DNAStringSet)
109 129 
 importFrom(Biostrings,GENETIC_CODE)
110 130 
 importFrom(Biostrings,readBStringSet)
111 131 
 importFrom(Biostrings,toString)
112 
-importFrom(EBImage,channel)
113 
-importFrom(EBImage,readImage)
132 
+importFrom(ape,Nnode)
114 133 
 importFrom(ape,Ntip)
115 134 
 importFrom(ape,drop.tip)
116 135 
 importFrom(ape,extract.clade)
136 
+importFrom(ape,getMRCA)
117 137 
 importFrom(ape,is.binary.tree)
118 138 
 importFrom(ape,ladderize)
119 139 
 importFrom(ape,print.phylo)
... ... 
@@ -124,27 +144,38 @@ importFrom(ape,which.edge)
124 144 
 importFrom(ape,write.tree)
125 145 
 importFrom(colorspace,rainbow_hcl)
126 146 
 importFrom(ggplot2,"%+replace%")
147 
+importFrom(ggplot2,GeomPoint)
148 
+importFrom(ggplot2,GeomRect)
149 
+importFrom(ggplot2,GeomSegment)
150 
+importFrom(ggplot2,GeomText)
151 
+importFrom(ggplot2,Stat)
127 152 
 importFrom(ggplot2,aes)
153 
+importFrom(ggplot2,aes_)
128 154 
 importFrom(ggplot2,aes_string)
129 155 
 importFrom(ggplot2,annotate)
130 156 
 importFrom(ggplot2,annotation_custom)
131 157 
 importFrom(ggplot2,coord_flip)
132 158 
 importFrom(ggplot2,coord_polar)
159 
+importFrom(ggplot2,draw_key_path)
160 
+importFrom(ggplot2,draw_key_point)
161 
+importFrom(ggplot2,draw_key_text)
133 162 
 importFrom(ggplot2,element_blank)
134 163 
 importFrom(ggplot2,element_line)
135 164 
 importFrom(ggplot2,element_rect)
136 165 
 importFrom(ggplot2,element_text)
137 166 
 importFrom(ggplot2,fortify)
138 
-importFrom(ggplot2,geom_point)
139 167 
 importFrom(ggplot2,geom_rect)
140 168 
 importFrom(ggplot2,geom_segment)
141 169 
 importFrom(ggplot2,geom_text)
142 170 
 importFrom(ggplot2,geom_tile)
143 171 
 importFrom(ggplot2,ggplot)
144 172 
 importFrom(ggplot2,ggplotGrob)
173 
+importFrom(ggplot2,ggproto)
145 174 
 importFrom(ggplot2,guide_legend)
146 175 
 importFrom(ggplot2,guides)
147 176 
 importFrom(ggplot2,labs)
177 
+importFrom(ggplot2,layer)
178 
+importFrom(ggplot2,position_nudge)
148 179 
 importFrom(ggplot2,scale_color_manual)
149 180 
 importFrom(ggplot2,scale_fill_discrete)
150 181 
 importFrom(ggplot2,scale_fill_gradient)
... ... 
@@ -158,14 +189,9 @@ importFrom(ggplot2,theme_bw)
158 189 
 importFrom(ggplot2,xlab)
159 190 
 importFrom(ggplot2,xlim)
160 191 
 importFrom(ggplot2,ylab)
161 
-importFrom(ggplot2,ylim)
162 192 
 importFrom(grDevices,col2rgb)
163 193 
 importFrom(grDevices,rgb)
164 
-importFrom(grid,editGrob)
165 
-importFrom(grid,gpar)
166 
-importFrom(grid,linesGrob)
167 194 
 importFrom(grid,rasterGrob)
168 
-importFrom(grid,textGrob)
169 195 
 importFrom(grid,unit)
170 196 
 importFrom(gridExtra,grid.arrange)
171 197 
 importFrom(jsonlite,fromJSON)
NEWS
History View file @ f1f0d8d2
... ... 
@@ -1,6 +1,58 @@
1 
-CHANGES IN VERSION 1.1.20
1 
+CHANGES IN VERSION 1.3.6
2 
+------------------------
3 
+ o MRCA function for finding Most Recent Common Ancestor among a vector of tips <2015-12-22, Tue>
4 
+ o geom_cladelabel: add bar and label to annotate a clade <2015-12-21, Mon>
5 
+   - remove annotation_clade and annotation_clade2 functions.
6 
+ o geom_treescale: tree scale layer. (add_legend was removed) <2015-12-21, Mon>
7 
+
8 
+CHANGES IN VERSION 1.3.5
9 
+------------------------
10 
+ o bug fixed, read.nhx now works with scientific notation <2015-11-30, Mon>
11 
+   + see https://github.com/GuangchuangYu/ggtree/issues/30
12 
+
13 
+CHANGES IN VERSION 1.3.4
14 
+------------------------
15 
+ o rename beast feature when name conflict with reserve keywords (label, branch, etc) <2015-11-27, Fri>
16 
+ o get_clade_position function <2015-11-26, Thu>
17 
+   + https://github.com/GuangchuangYu/ggtree/issues/28
18 
+ o get_heatmap_column_position function <2015-11-25, Wed>
19 
+   + see https://github.com/GuangchuangYu/ggtree/issues/26
20 
+ o support NHX (New Hampshire X) format via read.nhx function <2015-11-17, Tue>
21 
+ o bug fixed in extract.treeinfo.jplace <2015-11-17, Thu>
22 
+
23 
+CHANGES IN VERSION 1.3.3
24 
+------------------------
25 
+ o support color=NULL in gheatmap, then no colored line will draw within the heatmap <2015-10-30, Fri>
26 
+ o add `angle` for also rectangular, so that it will be available for layout='rectangular' following by coord_polar() <2015-10-27, Tue>
27 
+
28 
+CHANGES IN VERSION 1.3.2
2 29 
 ------------------------
30 
+ o update vignette, add example of ape bootstrap and phangorn ancestral sequences <2015-10-26, Mon>
31 
+ o add support of ape bootstrap analysis <2015-10-26, Mon>
32 
+   see https://github.com/GuangchuangYu/ggtree/issues/20
33 
+ o add support of ancestral sequences inferred by phangorn <2015-10-26, Mon>
34 
+   see https://github.com/GuangchuangYu/ggtree/issues/21
35 
+
36 
+CHANGES IN VERSION 1.3.1
37 
+------------------------
38 
+ o change angle to angle + 90, so that label will in radial direction <2015-10-22, Thu>
39 
+   + see https://github.com/GuangchuangYu/ggtree/issues/17
40 
+ o na.rm should be always passed to layer(), fixed it in geom_hilight and geom_text2 <2015-10-21, Wed>
41 
+   + see https://github.com/hadley/ggplot2/issues/1380
42 
+ o matching beast stats with tree using internal node number instead of label <2015-10-20, Tue>
43 
+
44 
+CHANGES IN VERSION 1.3.0
45 
+------------------------
46 
+ o BioC 3.3 branch
47 
+
48 
+CHANGES IN VERSION 1.1.21
49 
+------------------------
50 
+ o support hyphy output of ancestral sequences that is in phylip sequential format (no TAXALABELS block available) <2015-10-07, Wed>
3 51 
  o fixed bug in geom_tiplab when x contains NA (eg, removing by collapse function) <2015-10-01, Thu>
52 
+ o new implementation of geom_hilight, a truly geom layer function <2015-09-10, Thu>
53 
+
54 
+CHANGES IN VERSION 1.1.20
55 
+------------------------
4 56 
  o bug fixed in %add2%, if node available use node, otherwise use label <2015-09-04, Fri>
5 57 
  o bug fixed of subview for considering aes mapping of x and y <2015-09-03, Thu>
6 58 
  o update vignette by adding r8s example <2015-09-02, Wed>
R/AllClasses.R
History View file @ f1f0d8d2
... ... 
@@ -3,6 +3,11 @@ setOldClass("multiPhylo")
3 3 
 setOldClass("gg")
4 4 
 setOldClass("ggplot")
5 5
6 
+supported_tree_object <- function() {
7 
+    c("hyphy", "r8s", "nhx", "apeBootstrap", "raxml",
8 
+      "paml_rst", "phangorn", "codeml_mlc", "codeml",
9 
+      "jplace", "beast")
10 
+}
6 11
7 12 
 ##' Class "hyphy"
8 13 
 ##' This class stores information of HYPHY output
... ... 
@@ -66,6 +71,78 @@ setClass("r8s",
66 71 
              )
67 72 
          )
68 73
74 
+##' Class "r8s"
75 
+##' This class stores output info from r8s
76 
+##'
77 
+##'
78 
+##' @name r8s-class
79 
+##' @docType class
80 
+##' @slot file input file
81 
+##' @slot fields available feature
82 
+##' @slot treetext tree text
83 
+##' @slot phylo multiPhylo, time tree, rate tree and absolute substitution tree
84 
+##' @slot extraInfo extra information
85 
+##' @exportClass r8s
86 
+##' @author Guangchuang Yu \url{http://ygc.name}
87 
+##' @keywords classes
88 
+setClass("r8s",
89 
+         representation = representation(
90 
+             file      = "character",
91 
+             fields    = "character",
92 
+             treetext  = "character",
93 
+             phylo     = "multiPhylo",
94 
+             extraInfo = "data.frame"
95 
+         )
96 
+         )
97 
+
98 
+##' Class "nhx"
99 
+##' This class stores nhx tree
100 
+##'
101 
+##'
102 
+##' @name nhx-class
103 
+##' @rdname nhx-class
104 
+##' @docType class
105 
+##' @slot file input file
106 
+##' @slot fields available feature
107 
+##' @slot phylo phylo object
108 
+##' @slot nhx_tags tag information in nhx file
109 
+##' @slot extraInfo extra information
110 
+##' @exportClass nhx
111 
+##' @author Guangchuang Yu \url{http://ygc.name}
112 
+##' @keywords classes
113 
+setClass("nhx",
114 
+         representation = representation(
115 
+             file = "character",
116 
+             fields = "character",
117 
+             phylo = "phylo",
118 
+             nhx_tags = "data.frame",
119 
+             extraInfo = "data.frame"
120 
+         )
121 
+         )
122 
+
123 
+##' Class "apeBootstrap"
124 
+##' This class stores ape bootstrapping analysis result
125 
+##'
126 
+##'
127 
+##' @name apeBootstrap-class
128 
+##' @docType class
129 
+##' @slot phylo phylo object of treetext
130 
+##' @slot fields available features
131 
+##' @slot bootstrap bootstrap value
132 
+##' @slot extraInfo extra information
133 
+##' @exportClass apeBootstrap
134 
+##' @author Guangchuang Yu \url{http://ygc.name}
135 
+##' @keywords classes
136 
+setClass("apeBootstrap",
137 
+         representation = representation(
138 
+             phylo = "phylo",
139 
+             fields = "character",
140 
+             bootstrap = "data.frame",
141 
+             extraInfo = "data.frame"
142 
+         )
143 
+         )
144 
+
145 
+
69 146 
 ##' Class "raxml"
70 147 
 ##' This class stores RAxML bootstrapping analysis result
71 148 
 ##'
... ... 
@@ -84,12 +161,9 @@ setClass("r8s",
84 161 
 setClass("raxml",
85 162 
          representation = representation(
86 163 
              file       = "character",
87 
-             fields     = "character",
88 
-             treetext   = "character",
89 
-             phylo      = "phylo",
90 
-             bootstrap  = "data.frame",
91 
-             extraInfo  = "data.frame"
92 
-             )
164 
+             treetext   = "character"
165 
+         ),
166 
+         contains = "apeBootstrap"
93 167 
          )
94 168
95 169
... ... 
@@ -138,6 +212,37 @@ setClass("paml_rst",
138 212 
          )
139 213 
          )
140 214
215 
+##' Class "phangorn"
216 
+##' This class stores ancestral sequences inferred from 'phangorn'
217 
+##'
218 
+##'
219 
+##' @name phangorn-class
220 
+##' @docType class
221 
+##' @slot fields available attributes
222 
+##' @slot phylo phylo object
223 
+##' @slot seq_type one of "NT" and "AA"
224 
+##' @slot tip_seq sequences of tips
225 
+##' @slot ancseq ancenstral sequences
226 
+##' @slot subs sequence substitution
227 
+##' @slot AA_subs Amino acid sequence substitution
228 
+##' @slot extraInfo extra information
229 
+##' @exportClass phangorn
230 
+##' @author Guangchuang Yu \url{http://ygc.name}
231 
+##' @seealso \linkS4class{paml_rst}
232 
+##' @keywords classes
233 
+setClass("phangorn",
234 
+         representation = representation(
235 
+             fields = "character",
236 
+             phylo = "phylo",
237 
+             seq_type = "character",
238 
+             tip_seq = "character",
239 
+             ancseq = "character",
240 
+             subs = "data.frame",
241 
+             AA_subs = "data.frame",
242 
+             extraInfo = "data.frame")
243 
+         )
244 
+
245 
+
141 246 
 ##' Class "codeml_mlc"
142 247 
 ##' This class stores information of mlc file frm codeml output
143 248 
 ##'
R/AllGenerics.R
History View file @ f1f0d8d2
... ... 
@@ -26,7 +26,7 @@ if ( !isGeneric("plot") )
26 26 
 ##' @name reroot
27 27 
 ##' @rdname reroot-methods
28 28 
 ##' @title reroot method
29 
-##' @param object one of \code{phylo}, \code{jplace}, \code{beast}, \code{hyphy}, \code{codeml}, \code{codeml_mlc}, \code{paml_rst} object
29 
+##' @param object one of \code{phylo}, \code{nhx}, \code{phangorn}, \code{jplace}, \code{beast}, \code{hyphy}, \code{codeml}, \code{codeml_mlc}, \code{paml_rst} object
30 30 
 ##' @param node internal nnode number
31 31 
 ##' @param ... additional parameter
32 32 
 ##' @return tree object
... ... 
@@ -37,7 +37,7 @@ setGeneric("reroot", function(object, node, ...) standardGeneric("reroot"))
37 37 
 ##' @name get.tree
38 38 
 ##' @rdname get.tree-methods
39 39 
 ##' @title get.tree method
40 
-##' @param object one of \code{phylo}, \code{jplace}, \code{beast}, \code{hyphy}, \code{codeml}, \code{codeml_mlc}, \code{paml_rst} object
40 
+##' @param object one of \code{phylo}, \code{jplace}, \code{nhx}, \code{phangorn}, \code{beast}, \code{hyphy}, \code{codeml}, \code{codeml_mlc}, \code{paml_rst} object
41 41 
 ##' @param ... additional parameter
42 42 
 ##' @return phylo object
43 43 
 ##' @export
R/ape.R
History View file @ f1f0d8d2
... ... 
@@ -43,3 +43,77 @@ read.tree <- ape::read.tree
43 43 
 ##' \link[ape]{rtree}
44 44 
 rtree <- ape::rtree
45 45
46 
+
47 
+##' merge phylo and output of boot.phylo to 'apeBootstrap' object
48 
+##'
49 
+##'
50 
+##' @title apeBoot
51 
+##' @param phylo phylo
52 
+##' @param boot bootstrap values
53 
+##' @return an instance of 'apeBootstrap'
54 
+##' @importFrom ape Nnode
55 
+##' @export
56 
+##' @author Guangchuang Yu
57 
+apeBoot <- function(phylo, boot) {
58 
+    ## phylo is a phylo object
59 
+    ## boot is output from boot.phylo
60 
+    new("apeBootstrap",
61 
+        phylo=phylo,
62 
+        bootstrap=data.frame(node=(1:Nnode(phylo)) + Ntip(phylo), bootstrap=boot)
63 
+        )
64 
+}
65 
+
66 
+
67 
+##' @rdname show-methods
68 
+##' @importFrom ape print.phylo
69 
+##' @exportMethod show
70 
+setMethod("show", signature(object = "apeBootstrap"),
71 
+          function(object) {
72 
+              cat("'apeBoot' S4 object that stored bootstrap value generated by 'ape::boot.phylo'", ".\n\n")
73 
+              cat("...@ tree: ")
74 
+              print.phylo(get.tree(object))
75 
+          })
76 
+
77 
+
78 
+
79 
+
80 
+##' @rdname groupClade-methods
81 
+##' @exportMethod groupClade
82 
+setMethod("groupClade", signature(object="apeBootstrap"),
83 
+          function(object, node, group_name="group") {
84 
+              groupClade_(object, node, group_name)
85 
+          })
86 
+
87 
+##' @rdname scale_color-methods
88 
+##' @exportMethod scale_color
89 
+setMethod("scale_color", signature(object="apeBootstrap"),
90 
+          function(object, by="bootstrap", ...) {
91 
+              scale_color_(object, by, ...)
92 
+          })
93 
+
94 
+
95 
+##' @rdname gzoom-methods
96 
+##' @exportMethod gzoom
97 
+setMethod("gzoom", signature(object="apeBootstrap"),
98 
+          function(object, focus, subtree=FALSE, widths=c(.3, .7)) {
99 
+              gzoom.phylo(get.tree(object), focus, subtree, widths)
100 
+          })
101 
+
102 
+
103 
+##' @rdname get.tree-methods
104 
+##' @exportMethod get.tree
105 
+setMethod("get.tree", signature(object="apeBootstrap"),
106 
+          function(object,...) {
107 
+              object@phylo
108 
+          }
109 
+          )
110 
+
111 
+
112 
+##' @rdname get.fields-methods
113 
+##' @exportMethod get.fields
114 
+setMethod("get.fields", signature(object="apeBootstrap"),
115 
+          function(object, ...) {
116 
+              get.fields.tree(object)
117 
+          }
118 
+          )
119 
+
R/beast.R
History View file @ f1f0d8d2
... ... 
@@ -13,6 +13,8 @@
13 13 
 ##' read.beast(file)
14 14 
 read.beast <- function(file) {
15 15 
     stats <- read.stats_beast(file)
16 
+    stats$node %<>% gsub("\"*'*", "", .)
17 
+
16 18 
     fields <- sub("_lower|_upper", "", names(stats)) %>% unique
17 19 
     fields %<>% `[`(.!="node")
18 20
... ... 
@@ -35,26 +37,6 @@ read.beast <- function(file) {
35 37 
 }
36 38
37 39
38 
-##' @rdname show-methods
39 
-##' @importFrom ape print.phylo
40 
-##' @exportMethod show
41 
-setMethod("show", signature(object = "beast"),
42 
-          function(object) {
43 
-              cat("'beast' S4 object that stored information of\n\t",
44 
-                  paste0("'", object@file, "'.\n\n"))
45 
-              cat("...@ tree: ")
46 
-              print.phylo(get.tree(object))
47 
-              cat("\nwith the following features available:\n")
48 
-              print_fields(object)
49 
-          })
50 
-
51 
-##' @rdname groupOTU-methods
52 
-##' @exportMethod groupOTU
53 
-setMethod("groupOTU", signature(object="beast"),
54 
-          function(object, focus, group_name="group") {
55 
-              groupOTU_(object, focus, group_name)
56 
-          }
57 
-          )
58 40
59 41 
 ##' @rdname groupClade-methods
60 42 
 ##' @exportMethod groupClade
... ... 
@@ -63,20 +45,7 @@ setMethod("groupClade", signature(object="beast"),
63 45 
               groupClade_(object, node, group_name)
64 46 
           })
65 47
66 
-##' @rdname scale_color-methods
67 
-##' @exportMethod scale_color
68 
-setMethod("scale_color", signature(object="beast"),
69 
-          function(object, by, ...) {
70 
-              scale_color_(object, by, ...)
71 
-          })
72 
-
73 48
74 
-##' @rdname gzoom-methods
75 
-##' @exportMethod gzoom
76 
-setMethod("gzoom", signature(object="beast"),
77 
-          function(object, focus, subtree=FALSE, widths=c(.3, .7)) {
78 
-              gzoom.phylo(get.tree(object), focus, subtree, widths)
79 
-          })
80 49
81 50 
 ##' get.tree method
82 51 
 ##'
... ... 
@@ -163,8 +132,8 @@ read.stats_beast <- function(file) {
163 132 
     ## node name corresponding to stats
164 133 
     nn <- strsplit(tree2, split=",") %>% unlist %>%
165 134 
         strsplit(., split="\\)") %>% unlist %>%
166 
-            gsub("\\(*", "", .) %>%
167 
-                gsub("[:;].*", "", .)
135 
+        gsub("\\(*", "", .) %>%
136 
+        gsub("[:;].*", "", .)
168 137
169 138 
     phylo <- read.tree(text = tree2)
170 139 
     root <- getRoot(phylo)
... ... 
@@ -211,9 +180,14 @@ read.stats_beast <- function(file) {
211 180 
     ##                                                ##
212 181 
     ####################################################
213 182 
     treeinfo <- fortify.phylo(phylo)
214 
-    label2 <- c(treeinfo[treeinfo$isTip, "label"],
215 
-                root:(root+nnode-1))
216 
-    node <- label2[match(nn, treeinfo$label)]
183 
+
184 
+    if (any(grepl("TRANSLATE", beast, ignore.case = TRUE))) {
185 
+        label2 <- c(treeinfo[treeinfo$isTip, "label"],
186 
+                    root:(root+nnode-1))
187 
+        node <- label2[match(nn, treeinfo$label)]
188 
+    } else {
189 
+        node <- as.character(treeinfo$node[match(nn, treeinfo$label)])
190 
+    }
217 191
218 192 
     ## stats <- unlist(strsplit(tree, "\\["))[-1]
219 193 
     ## stats <- sub(":.+$", "", stats
R/geom_point.R
History View file @ f1f0d8d2
... ... 
@@ -1,46 +1,120 @@
1 
+
1 2 
 ##' add tip point
2 3 
 ##'
3 4 
 ##'
4 5 
 ##' @title geom_tippoint
5 
-##' @param mapping aes mapping
6 
-##' @param ... additional parameter
6 
+##' @inheritParams geom_point2
7 7 
 ##' @return tip point layer
8 8 
 ##' @export
9 9 
 ##' @author Guangchuang Yu
10 
-geom_tippoint <- function(mapping = NULL, ...) {
10 
+geom_tippoint <- function(mapping = NULL, data = NULL, stat = "identity",
11 
+                       position = "identity", na.rm = FALSE,
12 
+                          show.legend = NA, inherit.aes = TRUE, ...) {
11 13 
     isTip <- NULL
12 
-    geom_point(mapping, subset=.(isTip), ...)
14 
+    self_mapping <- aes(subset = isTip)
15 
+    if (is.null(mapping)) {
16 
+        mapping <- self_mapping
17 
+    } else {
18 
+        mapping %<>% modifyList(self_mapping)
19 
+    }
20 
+    geom_point2(mapping, data, stat, position, na.rm, show.legend, inherit.aes, ...)
13 21 
 }
14 22
15 23 
 ##' add node point
16 24 
 ##'
17 25 
 ##'
18 26 
 ##' @title geom_nodepoint
19 
-##' @param mapping aes mapping
20 
-##' @param ... additional parameter
27 
+##' @inheritParams geom_point2
21 28 
 ##' @return node point layer
22 29 
 ##' @export
23 30 
 ##' @author Guangchuang Yu
24 
-geom_nodepoint <- function(mapping = NULL,  ...) {
31 
+geom_nodepoint <- function(mapping = NULL, data = NULL, stat = "identity",
32 
+                       position = "identity", na.rm = FALSE,
33 
+                       show.legend = NA, inherit.aes = TRUE, ...) {
25 34 
     isTip <- NULL
26 
-    geom_point(mapping, subset=.(!isTip), ...)
35 
+    self_mapping <- aes(subset = !isTip)
36 
+    if (is.null(mapping)) {
37 
+        mapping <- self_mapping
38 
+    } else {
39 
+        mapping %<>% modifyList(self_mapping)
40 
+    }
41 
+    geom_point2(mapping, data, stat, position, na.rm, show.legend, inherit.aes, ...)
27 42 
 }
28 43
29 44
30 
-
31 45 
 ##' add root point
32 46 
 ##'
33 47 
 ##'
34 48 
 ##' @title geom_rootpoint
35 
-##' @param mapping aes mapping
36 
-##' @param ... additional parameter
49 
+##' @inheritParams geom_point2
37 50 
 ##' @return root point layer
38 
-##' @importFrom ggplot2 geom_point
39 51 
 ##' @export
40 52 
 ##' @author Guangchuang Yu
41 
-geom_rootpoint <- function(mapping = NULL,  ...) {
53 
+geom_rootpoint <- function(mapping = NULL, data = NULL, stat = "identity",
54 
+                           position = "identity", na.rm = FALSE,
55 
+                           show.legend = NA, inherit.aes = TRUE, ...) {
42 56 
     isTip <- node <- parent <- NULL
43 
-    geom_point(mapping, subset=.(node == parent), ...)
57 
+    self_mapping <- aes(subset = (node == parent))
58 
+    if (is.null(mapping)) {
59 
+        mapping <- self_mapping
60 
+    } else {
61 
+        mapping %<>% modifyList(self_mapping)
62 
+    }
63 
+    geom_point2(mapping, data, stat, position, na.rm, show.legend, inherit.aes, ...)
44 64 
 }
45 65
46 66
67 
+##' geom_point2 support aes(subset) via setup_data
68 
+##'
69 
+##'
70 
+##' @title geom_point2
71 
+##' @param mapping aes mapping
72 
+##' @param data data
73 
+##' @param stat stat
74 
+##' @param position position
75 
+##' @param na.rm logical
76 
+##' @param show.legend logical
77 
+##' @param inherit.aes logical
78 
+##' @param ... addktional parameter
79 
+##' @importFrom ggplot2 layer
80 
+##' @export
81 
+##' @seealso
82 
+##' \link[ggplot2]{geom_point}
83 
+##' @return point layer
84 
+##' @author Guangchuang Yu
85 
+geom_point2 <- function(mapping = NULL, data = NULL, stat = "identity",
86 
+                       position = "identity", na.rm = FALSE,
87 
+                       show.legend = NA, inherit.aes = TRUE, ...) {
88 
+  layer(
89 
+    data = data,
90 
+    mapping = mapping,
91 
+    stat = stat,
92 
+    geom = GeomPointGGtree,
93 
+    position = position,
94 
+    show.legend = show.legend,
95 
+    inherit.aes = inherit.aes,
96 
+    params = list(
97 
+      na.rm = na.rm,
98 
+      ...
99 
+    )
100 
+  )
101 
+}
102 
+
103 
+##' @importFrom ggplot2 ggproto
104 
+##' @importFrom ggplot2 GeomPoint
105 
+##' @importFrom ggplot2 draw_key_point
106 
+GeomPointGGtree <- ggproto("GeomPointGGtree", GeomPoint,
107 
+                           setup_data = function(data, params) {
108 
+                               data[data$subset,]
109 
+                           }  ## ,
110 
+
111 
+##                            draw_panel = function(data, panel_scales, coord, na.rm = FALSE){
112 
+##                                GeomPoint$draw_panel(data, panel_scales, coord, na.rm)
113 
+##                            },
114 
+
115 
+##                            draw_key = draw_key_point,
116 
+
117 
+##                            required_aes = c("x", "y"),
118 
+##                            default_aes = aes(shape = 19, colour = "black", size = 1.5, fill = NA,
119 
+##                                alpha = NA, stroke = 0.5)
120 
+                            )
R/geom_segment.R
History View file @ f1f0d8d2
... ... 
@@ -11,14 +11,75 @@
11 11 
 ##' @author Yu Guangchuang
12 12 
 geom_aline <- function(mapping=NULL, linetype="dotted", size=1, ...) {
13 13 
     x <- y <- isTip <- NULL
14 
-    dot_mapping <- aes(xend=x+diff(range(x))/200, x=max(x), yend=y)
14 
+    dot_mapping <- aes(xend=x+diff(range(x))/200, x=max(x), yend=y, subset=isTip)
15 15 
     if (!is.null(mapping)) {
16 16 
         dot_mapping <- modifyList(dot_mapping, mapping)
17 17 
     }
18 18
19 
-    geom_segment(mapping,
20 
-                 subset=.(isTip),
21 
-                 linetype=linetype,
22 
-                 size=size, ...)
19 
+    geom_segment2(dot_mapping,
20 
+                  linetype=linetype,
21 
+                  size=size, ...)
23 22 
 }
24 23
24 
+
25 
+
26 
+##' geom_segment2 support aes(subset) via setup_data
27 
+##'
28 
+##'
29 
+##' @title geom_segment2
30 
+##' @param mapping aes mapping
31 
+##' @param data data
32 
+##' @param stat stat
33 
+##' @param position position
34 
+##' @param arrow arrow
35 
+##' @param lineend lineend
36 
+##' @param na.rm logical
37 
+##' @param show.legend logical
38 
+##' @param inherit.aes logical
39 
+##' @param ... additional parameter
40 
+##' @importFrom ggplot2 layer
41 
+##' @export
42 
+##' @seealso
43 
+##' \link[ggplot2]{geom_segment}
44 
+##' @return add segment layer
45 
+##' @author Guangchuang Yu
46 
+geom_segment2 <- function(mapping = NULL, data = NULL, stat = "identity",
47 
+                         position = "identity", arrow = NULL, lineend = "butt",
48 
+                         na.rm = FALSE, show.legend = NA, inherit.aes = TRUE,
49 
+                         ...) {
50 
+  layer(
51 
+    data = data,
52 
+    mapping = mapping,
53 
+    stat = stat,
54 
+    geom = GeomSegmentGGtree,
55 
+    position = position,
56 
+    show.legend = show.legend,
57 
+    inherit.aes = inherit.aes,
58 
+    params = list(
59 
+      arrow = arrow,
60 
+      lineend = lineend,
61 
+      na.rm = na.rm,
62 
+      ...
63 
+    )
64 
+  )
65 
+}
66 
+
67 
+##' @importFrom ggplot2 GeomSegment
68 
+##' @importFrom ggplot2 draw_key_path
69 
+GeomSegmentGGtree <- ggproto("GeomSegmentGGtree", GeomSegment,
70 
+                          setup_data = function(data, params) {
71 
+                              data[data$subset,]
72 
+                          },
73 
+
74 
+                          draw_panel = function(data, panel_scales, coord, arrow = NULL,
75 
+                              lineend = "butt", na.rm = FALSE) {
76 
+
77 
+                              GeomSegment$draw_panel(data, panel_scales, coord, arrow,
78 
+                                                     lineend, na.rm)
79 
+                          },
80 
+
81 
+                          required_aes = c("x", "y", "xend", "yend"),
82 
+                          default_aes = aes(colour = "black", size = 0.5, linetype = 1, alpha = NA),
83 
+
84 
+                          draw_key = draw_key_path
85 
+                          )
R/geom_text.R
History View file @ f1f0d8d2
... ... 
@@ -1,3 +1,43 @@
1 
+##' geom_text2 support aes(subset) via setup_data
2 
+##'
3 
+##'
4 
+##' @title geom_text2
5 
+##' @inheritParams geom_text
6 
+##' @return text layer
7 
+##' @importFrom ggplot2 layer
8 
+##' @importFrom ggplot2 position_nudge
9 
+##' @export
10 
+##' @seealso
11 
+##' \link[ggplot2]{geom_text}
12 
+##' @author Guangchuang Yu
13 
+geom_text2 <- function(mapping = NULL, data = NULL, stat = "identity",
14 
+  position = "identity", parse = FALSE, na.rm=TRUE, show.legend = NA, inherit.aes = TRUE,
15 
+  ..., nudge_x = 0, nudge_y = 0, check_overlap = FALSE)
16 
+{
17 
+  if (!missing(nudge_x) || !missing(nudge_y)) {
18 
+    if (!missing(position)) {
19 
+      stop("Specify either `position` or `nudge_x`/`nudge_y`", call. = FALSE)
20 
+    }
21 
+
22 
+    position <- position_nudge(nudge_x, nudge_y)
23 
+  }
24 
+
25 
+  layer(
26 
+      data = data,
27 
+      mapping = mapping,
28 
+      stat = stat,
29 
+      geom = GeomTextGGtree,
30 
+      position = position,
31 
+      show.legend = show.legend,
32 
+      inherit.aes = inherit.aes,
33 
+      params = list(
34 
+          parse = parse,
35 
+          check_overlap = check_overlap,
36 
+          na.rm = na.rm,
37 
+          ...
38 
+          )
39 
+      )
40 
+}
1 41
2 42 
 ##' text annotations
3 43 
 ##' @export
... ... 
@@ -8,7 +48,13 @@
8 48 
 ##' @param stat The statistical transformation to use on the data for this layer
9 49 
 ##' @param position The position adjustment to use for overlapping points on this layer
10 50 
 ##' @param parse if TRUE, the labels will be passd into expressions
51 
+##' @param na.rm logical
52 
+##' @param show.legend logical
53 
+##' @param inherit.aes logical
11 54 
 ##' @param ... other arguments passed on to 'layer'
55 
+##' @param nudge_x horizontal adjustment
56 
+##' @param nudge_y vertical adjustment
57 
+##' @param check_overlap if TRUE, text that overlaps previous text in the same layer will not be plotted
12 58 
 ##' @source
13 59 
 ##' This is just the imported function
14 60 
 ##' from the ggplot2 package. The documentation you should
... ... 
@@ -18,3 +64,24 @@
18 64 
 ##' \link[ggplot2]{geom_text}
19 65 
 geom_text <- ggplot2::geom_text
20 66
67 
+
68 
+##' @importFrom ggplot2 GeomText
69 
+##' @importFrom ggplot2 draw_key_text
70 
+GeomTextGGtree <- ggproto("GeomTextGGtree", GeomText,
71 
+                          setup_data = function(data, params) {
72 
+                              data[data$subset,]
73 
+                          },
74 
+
75 
+                          draw_panel = function(data, panel_scales, coord, parse = FALSE,
76 
+                              na.rm = FALSE, check_overlap = FALSE) {
77 
+                              GeomText$draw_panel(data, panel_scales, coord, parse,
78 
+                                                  na.rm, check_overlap)
79 
+                          },
80 
+
81 
+                          required_aes = c("x", "y", "label"),
82 
+
83 
+                          default_aes = aes(colour = "black", size = 3.88, angle = 0, hjust = 0.5,
84 
+                              vjust = 0.5, alpha = NA, family = "", fontface = 1, lineheight = 1.2),
85 
+
86 
+                          draw_key = draw_key_text
87 
+                          )
R/geom_tiplab.R
History View file @ f1f0d8d2
... ... 
@@ -40,12 +40,10 @@ geom_tiplab <- function(mapping=NULL, hjust = 0, align = FALSE, linetype = "dott
40 40 
     }
41 41
42 42 
     list(
43 
-        geom_text(mapping=text_mapping,
44 
-                  subset=.(isTip),
45 
-                  hjust = hjust, ...),
43 
+        geom_text2(mapping=text_mapping,
44 
+                   hjust = hjust, ...),
46 45 
         if (!is.null(dot_mapping))
47 
-            geom_segment(mapping=dot_mapping,
48 
-                         subset=.(isTip),
46 
+            geom_segment2(mapping=dot_mapping,
49 47 
                           linetype = linetype,
50 48 
                           size = linesize, ...)
51 49 
         )
R/ggtree.R
History View file @ f1f0d8d2
... ... 
@@ -35,7 +35,7 @@ ggtree <- function(tr,
35 35 
                    showDistance=FALSE,
36 36 
                    layout="rectangular",
37 37 
                    mrsd = NULL,
38 
-                   as.Date=FALSE,
38 
+                   as.Date = FALSE,
39 39 
                    yscale="none",
40 40 
                    yscale_mapping = NULL,
41 41 
                    ladderize = TRUE, right=FALSE,
... ... 
@@ -54,6 +54,7 @@ ggtree <- function(tr,
54 54 
         layout <- "slanted"
55 55 
     }
56 56 
     if (layout == "fan" || layout == "circular") {
57 
+        layout <- "circular"
57 58 
         type <- "circular"
58 59 
     } else if (layout == "radial") {
59 60 
         layout <- "slanted"
... ... 
@@ -82,6 +83,7 @@ ggtree <- function(tr,
82 83 
     if (type == "circular" || type == "radial") {
83 84 
         p <- p + coord_polar(theta = "y")
84 85 
         ## refer to: https://github.com/GuangchuangYu/ggtree/issues/6
86 
+        ## and also have some space for tree scale (legend)
85 87 
         p <- p + scale_y_continuous(limits=c(0, max(p$data$y)))
86 88 
     }
87 89
... ... 
@@ -141,26 +143,6 @@ geom_tree <- function(layout="rectangular", ...) {
141 143 
 }
142 144
143 145
144 
-##' hilight clade with rectangle
145 
-##'
146 
-##'
147 
-##' @title geom_hilight
148 
-##' @param tree_object supported tree object
149 
-##' @param node internal node
150 
-##' @param ... additional parameters
151 
-##' @return ggplot layer
152 
-##' @importFrom ape extract.clade
153 
-##' @author Guangchuang Yu
154 
-geom_hilight <- function(tree_object, node, ...) {
155 
-    clade <- extract.clade(get.tree(tree_object), node)
156 
-    idx <- groupOTU(tree_object, clade$tip.label)
157 
-    dd <- fortify(tree_object, ...)
158 
-    x <- dd[idx == 2, "x"]
159 
-    y <- dd[idx == 2, "y"]
160 
-    annotate("rect", xmin=min(x)-dd[node, "branch.length"]/2,
161 
-             xmax=max(x), ymin=min(y)-0.5, ymax=max(y)+0.5, ...)
162 
-}
163 
-
164 146
165 147 
 ##' tree theme
166 148 
 ##'
... ... 
@@ -243,29 +225,6 @@ theme_transparent <- function(...) {
243 225 
 }
244 226
245 227
246 
-##' hilight clade with rectangle
247 
-##'
248 
-##'
249 
-##' @title hilight
250 
-##' @param tree_view tree view
251 
-##' @param node clade node
252 
-##' @param fill fill color
253 
-##' @param alpha alpha
254 
-##' @param ... additional parameter
255 
-##' @return tree view
256 
-##' @export
257 
-##' @author Guangchuang Yu
258 
-hilight <- function(tree_view, node, fill="steelblue", alpha=0.5, ...) {
259 
-    df <- tree_view$data
260 
-    sp <- get.offspring.df(df, node)
261 
-    sp.df <- df[c(sp, node),]
262 
-    x <- sp.df$x
263 
-    y <- sp.df$y
264 
-    tree_view + annotate("rect", xmin=min(x)-df[node, "branch.length"]/2,
265 
-                         xmax=max(x), ymin=min(y)-0.5, ymax=max(y)+0.5,
266 
-                         fill = fill, alpha = alpha, ...)
267 
-}
268 
-
269 228 
 ##' scale clade
270 229 
 ##'
271 230 
 ##'
... ... 
@@ -467,7 +426,7 @@ collapse <- function(tree_view, node) {
467 426
468 427 
     ## re-calculate branch mid position
469 428 
     df <- calculate_branch_mid(df)
470 
-
429 
+
471 430 
     tree_view$data <- df
472 431 
     clade <- paste0("clade_", node)
473 432 
     attr(tree_view, clade) <- sp.df
... ... 
@@ -535,14 +494,12 @@ add_colorbar <- function(p, color, x=NULL, ymin=NULL, ymax=NULL, font.size=4) {
535 494 
     mrsd <- attr(p, "mrsd")
536 495 
     if (!is.null(mrsd)) {
537 496 
         attr(p, "mrsd") <- NULL
538 
-        if (class(p$data$x) == "Date") {
539 
-            p$data$x <- Date2decimal(p$data$x)
540 
-            p$data$branch <- Date2decimal(p$data$branch)
541 
-        }
497 
+
498 
+        p$data$x <- Date2decimal(p$data$x)
499 
+        p$data$branch <- Date2decimal(p$data$branch)
542 500 
         ## annotation segment not support using Date as x-axis
543 501 
     }
544 
-
545 
-
502 
+
546 503 
     legend <- do.call("cbind", attr(color, "scale"))
547 504
548 505 
     legend[,1] <- round(as.numeric(legend[,1]), 2)
... ... 
@@ -584,56 +541,15 @@ add_colorbar <- function(p, color, x=NULL, ymin=NULL, ymax=NULL, font.size=4) {
584 541
585 542 
 }
586 543
587 
-##' add evolution distance legend
588 
-##'
589 
-##'
590 
-##' @title add_legend
591 
-##' @param p tree view
592 
-##' @param width width of legend
593 
-##' @param x x position
594 
-##' @param y y position
595 
-##' @param offset offset of text and line
596 
-##' @param font.size font size
597 
-##' @param ... additional parameter
598 
-##' @return tree view
599 
-##' @importFrom grid linesGrob
600 
-##' @importFrom grid textGrob
601 
-##' @importFrom grid gpar
602 
-##' @importFrom ggplot2 ylim
603 
-##' @export
604 
-##' @author Guangchuang Yu
605 
-add_legend <- function(p, width=NULL, x=NULL, y=NULL, offset=NULL, font.size=4, ...) {
606 
-    dx <- p$data$x %>% range %>% diff
607 
-
608 
-    if (is.null(x)) {
609 
-        ## x <- min(p$data$x)
610 
-        x <- dx/2
611 
-    }
612 
-    if (is.null(y)) {
613 
-        y <- 0
614 
-        p <- p + ylim(0, max(p$data$y))
615 
-    }
616 544
617 
-    if (is.null(width) || is.na(width)) {
618 
-        d <- dx/10
619 
-        n <- 0
620 
-        while (d < 1) {
621 
-            d <- d*10
622 
-            n <- n + 1
623 
-        }
624 
-        d <- floor(d)/(10^n)
625 
-    } else {
626 
-        d <- width
627 
-    }
628 
-
629 
-    if (is.null(offset)) {
630 
-        offset <- 0.4
631 
-    }
632 
-    p <- p + annotation_custom(linesGrob(), xmin=x, xmax=x+d, ymin=y, ymax=y) +
633 
-        annotation_custom(textGrob(label=d, gp = gpar(fontsize = font.size)),
634 
-                          xmin=x+d/2, xmax=x+d/2, ymin=y+offset, ymax=y+offset)
635 
-    return(p)
636 
-}
545 
+
546 
+
547 
+
548 
+
549 
+
550 
+
551 
+
552 
+
637 553
638 554 
 ##' get taxa name of a selected node
639 555 
 ##'
... ... 
@@ -744,3 +660,6 @@ setMethod("groupClade", signature(object="gg"),
744 660 
               groupClade.ggplot(object, node, group_name)
745 661 
           })
746 662
663 
+
664 
+
665 
+
R/gplot.R
History View file @ f1f0d8d2
... ... 
@@ -56,8 +56,11 @@ gheatmap <- function(p, data, offset=0, width=1, low="green", high="red",
56 56
57 57 
     dd$x <- V2
58 58
59 
-    p2 <- p + geom_tile(data=dd, aes(x, y, fill=value), color=color, inherit.aes=FALSE)
60 
-
59 
+    if (is.null(color)) {
60 
+        p2 <- p + geom_tile(data=dd, aes(x, y, fill=value), inherit.aes=FALSE)
61 
+    } else {
62 
+        p2 <- p + geom_tile(data=dd, aes(x, y, fill=value), color=color, inherit.aes=FALSE)
63 
+    }
61 64 
     if (is(dd$value,"numeric")) {
62 65 
         p2 <- p2 + scale_fill_gradient(low=low, high=high, na.value="white")
63 66 
     } else {
... ... 
@@ -80,6 +83,33 @@ gheatmap <- function(p, data, offset=0, width=1, low="green", high="red",
80 83 
     return(p2)
81 84 
 }
82 85
86 
+##' return a data.frame that contains position information
87 
+##' for labeling column names of heatmap produced by `gheatmap` function
88 
+##'
89 
+##'
90 
+##' @title get_heatmap_column_position
91 
+##' @param treeview output of `gheatmap`
92 
+##' @param by one of 'bottom' or 'top'
93 
+##' @return data.frame
94 
+##' @export
95 
+##' @author Guangchuang Yu
96 
+get_heatmap_column_position <- function(treeview, by="bottom") {
97 
+    by %<>% match.arg(c("bottom", "top"))
98 
+
99 
+    mapping <- attr(treeview, "mapping")
100 
+    if (is.null(mapping)) {
101 
+        stop("treeview is not an output of `gheatmap`...")
102 
+    }
103 
+
104 
+    colnames(mapping) <- c("label", "x")
105 
+    if (by == "bottom") {
106 
+        mapping$y <- 0
107 
+    } else {
108 
+        mapping$y <- max(treeview$data$y) + 1
109 
+    }
110 
+    return(mapping)
111 
+}
112 
+
83 113 
 ##' multiple sequence alignment with phylogenetic tree
84 114 
 ##'
85 115 
 ##'
... ... 
@@ -195,12 +225,12 @@ scale_x_ggtree <- function(p, breaks=NULL, labels=NULL) {
195 225 
     } else {
196 226 
         x <- p$data$x
197 227 
     }
228 
+
198 229 
     if (is.null(breaks)) {
199 230 
         breaks <- hist(x, breaks=5, plot=FALSE)$breaks
200 231 
     }
201 232 
     m <- attr(p, "mapping")
202 233
203 
-
204 234 
     if (!is.null(mrsd) &&class(m$to) == "Date") {
205 235 
         to <- Date2decimal(m$to)
206 236 
     } else {
... ... 
@@ -218,13 +248,13 @@ scale_x_ggtree <- function(p, breaks=NULL, labels=NULL) {
218 248
219 249 
     breaks <- c(breaks, to)
220 250 
     labels <- c(labels, gsub("\\.", "", as.character(m$from)))
221 
-
251 
+
222 252 
     if (!is.null(mrsd) && class(p$data$x) == "Date") {
223 253 
         p <- p + scale_x_date(breaks=decimal2Date(breaks), labels)
224 254 
     } else {
225 255 
         p <- p + scale_x_continuous(breaks=breaks, labels=labels)
226 256 
     }
227 
-    return(p)
257 
+    return(p)
228 258 
 }
229 259
230 260
R/hyphy.R
History View file @ f1f0d8d2
... ... 
@@ -17,27 +17,54 @@
17 17 
 ##' read.hyphy(nwk, ancseq)
18 18 
 read.hyphy <- function(nwk, ancseq, tip.fasfile=NULL) {
19 19 
     anc <- scan(ancseq, what="", sep="\n", quiet=TRUE)
20 
-    end <- grep("END;", anc)
20 
+    end <- grep("END;", anc, ignore.case=TRUE)
21 21
22 
-    seq.start <- grep("MATRIX", anc)
22 
+    seq.start <- grep("MATRIX", anc, ignore.case=TRUE)
23 23 
     seq.end   <- end[end > seq.start][1]
24 24 
     seq       <- anc[(seq.start+1):(seq.end-1)]
25 
-    seq       <- gsub(" ", "", seq)
26 
-
27 
-    label.start <- grep("TAXLABELS", anc)
28 
-    label.end   <- end[end > label.start][1]
29 
-    label       <- anc[(label.start+1):(label.end-1)]
25 
+    seq       <- seq[seq != ";"]
26 
+    seq       <- seq[seq != ""]
27 
+
28 
+    ## some files may only contains sequences (should have TAXALABELS block that contains seq names).
29 
+    ## some may contains sequence name like phylip format in MATRIX block (no need to have TAXALABELS block).
30 
+    ##
31 
+    ## extract sequence name if available
32 
+    if (all(grepl("\\s+", seq))) {
33 
+        ## if contains blank space, may contains seq name
34 
+        sn <- gsub("(\\w*)\\s.*", "\\1", seq)
35 
+    }
36 
+
37 
+    seq <- gsub("\\w*\\s+", "", seq)
38 
+
39 
+    label.start <- grep("TAXLABELS", anc, ignore.case = TRUE)
40 
+    if (length(label.start) == 0) {
41 
+        if (all(sn == "")) {
42 
+            stop("taxa labels is not available...")
43 
+        }
44 
+        label <- sn
45 
+    } else {
46 
+        label.end   <- end[end > label.start][1]
47 
+        label       <- anc[(label.start+1):(label.end-1)]
48 
+
49 
+        label <- sub("^\t+", "", label)
50 
+        label <- sub("\\s*;$", "", label)
51 
+        label <- unlist(strsplit(label, split="\\s+"))
52 
+        label <- gsub("'|\"", "", label)
53 
+    }
30 54
31 
-    label <- sub("^\t+", "", label)
32 
-    label <- sub("\\s*;$", "", label)
33 
-    label <- unlist(strsplit(label, split="\\s+"))
34 
-    label <- gsub("'|\"", "", label)
35 
-
36 55 
     names(seq) <- label
37 56
38 57 
     tr <- read.tree(nwk)
39 58 
     nl <- tr$node.label
40 
-    nl[nl == ""] <- "Node1"
59 
+    ## root node may missing, which was supposed to be 'Node1'
60 
+    ##
61 
+    ## from a user's file, which is 'Node0', but it seems the file is not from the output of HYPHY.
62 
+    ##
63 
+    ## I am not sure. But it's safe to use "label[!label %in% nl]" instead of just assign it to "Node1".
64 
+    ##
65 
+    ## nl[nl == ""] <- "Node1"
66 
+    nl[nl == ""] <- label[!label %in% nl]
67 
+
41 68 
     tr$node.label <- nl
42 69
43 70 
     type <- get_seqtype(seq)
R/jplace.R
History View file @ f1f0d8d2
... ... 
@@ -199,7 +199,7 @@ setMethod("get.placements", signature(object = "jplace"),
199 199 
                           ## if not equals, the output is a descript string of the differences
200 200 
                           idx <- sapply(2:nrow(x), function(i) all.equal(x[1,2], x[i,2]))
201 201 
                           if (any(idx == TRUE)) {
202 
-                              return(x[c(1, which(idx==TRUE)),])
202 
+                              return(x[c(1, which(idx==TRUE)+1),])
203 203 
                           } else {
204 204 
                               return(x[1,])
205 205 
                           }
... ... 
@@ -251,7 +251,7 @@ get.fields.jplace <- function(object, ...) {
251 251 
 get.treeinfo.jplace <- function(object, layout,
252 252 
                                 ladderize, right, ...) {
253 253 
     extract.treeinfo.jplace(object, layout,
254 
-                            ladderize, right)
254 
+                            ladderize, right, ...)
255 255 
 }
256 256
257 257 
 ##' generate jplace file
R/paml_rst.R
History View file @ f1f0d8d2
... ... 
@@ -62,14 +62,6 @@ read.paml_rst <- function(rstfile) {
62 62 
 }
63 63
64 64
65 
-##' @rdname gzoom-methods
66 
-##' @exportMethod gzoom
67 
-setMethod("gzoom", signature(object="paml_rst"),
68 
-          function(object, focus, subtree=FALSE, widths=c(.3, .7)) {
69 
-              gzoom.phylo(get.tree(object), focus, subtree, widths)
70 
-          })
71 
-
72 
-
73 65
74 66 
 ##' @rdname groupClade-methods
75 67 
 ##' @exportMethod groupClade
... ... 
@@ -79,13 +71,10 @@ setMethod("groupClade", signature(object="paml_rst"),
79 71 
           }
80 72 
           )
81 73
82 
-##' @rdname scale_color-methods
83 
-##' @exportMethod scale_color
84 
-setMethod("scale_color", signature(object="paml_rst"),
85 
-          function(object, by, ...) {
86 
-              scale_color_(object, by, ...)
87 
-          })
88 74
75 
+##' get tipseq
76 
+##'
77 
+##'
89 78 
 ##' @rdname get.tipseq-methods
90 79 
 ##' @exportMethod get.tipseq
91 80 
 setMethod("get.tipseq", signature(object="paml_rst"),
... ... 
@@ -149,7 +138,9 @@ setMethod("get.tree", signature(object = "paml_rst"),
149 138 
           )
150 139
151 140
152 
-
141 
+##' get substitution information
142 
+##'
143 
+##'
153 144 
 ##' @rdname get.subs-methods
154 145 
 ##' @exportMethod get.subs
155 146 
 setMethod("get.subs", signature(object = "paml_rst"),
R/phylo.R
History View file @ f1f0d8d2
... ... 
@@ -1,10 +1,13 @@
1 
+##' reroot a tree
2 
+##'
3 
+##'
1 4 
 ##' @rdname reroot-methods
2 5 
 ##' @exportMethod reroot
3 6 
 setMethod("reroot", signature(object="phylo"),
4 7 
           function(object, node, ...) {
5 8 
               pos <- 0.5* object$edge.length[which(object$edge[,2] == node)]
6 9
7 
-              ##' @importFrom phytools reroot
10 
+              ## @importFrom phytools reroot
8 11 
               phytools <- "phytools"
9 12 
               require(phytools, character.only = TRUE)
10 13
... ... 
@@ -80,11 +83,5 @@ groupClade.phylo <- function(object, node, group_name) {
80 83 
 }
81 84
82 85
83 
-##' @rdname gzoom-methods
84 
-##' @exportMethod gzoom
85 
-setMethod("gzoom", signature(object="phylo"),
86 
-          function(object, focus, subtree=FALSE, widths=c(.3, .7)) {
87 
-              gzoom.phylo(object, focus, subtree, widths)
88 
-          })
89 86
90 87
R/phylopic.R
History View file @ f1f0d8d2
... ... 
@@ -24,14 +24,20 @@ get.phylopic <- function(id, size=512, color="black", alpha=1) {
24 24 
 ##' @return matrix
25 25 
 ##' @importFrom grDevices rgb
26 26 
 ##' @importFrom grDevices col2rgb
27 
-##' @importFrom EBImage readImage
28 
-##' @importFrom EBImage channel
27 
+## @importFrom EBImage readImage
28 
+## @importFrom EBImage channel
29 29 
 ##' @export
30 30 
 ##' @author Guangchuang Yu
31 31 
 download.phylopic <- function(id, size=512, color="black", alpha=1) {
32 32 
     imgfile <- tempfile(fileext = ".png")
33 33 
     download.phylopic_internal(id, size, imgfile)
34 34
35 
+    EBImage <- "EBImage"
36 
+    require(EBImage, character.only = TRUE)
37 
+
38 
+    readImage <- eval(parse(text="readImage"))
39 
+    channel <- eval(parse(text="channel"))
40 
+
35 41 
     img <- readImage(imgfile)
36 42
37 43 
     color <- col2rgb(color) / 255
... ... 
@@ -130,6 +136,10 @@ annotation_image <- function(tree_view, img_info, width=0.1, align=TRUE, linetyp
130 136 
     x <- df[idx, "x"]
131 137 
     y <- df[idx, "y"]
132 138
139 
+    EBImage <- "EBImage"
140 
+    require(EBImage, character.only = TRUE)
141 
+    readImage <- eval(parse(text="readImage"))
142 
+
133 143 
     images <- lapply(img_info[,2], readImage)
134 144
135 145 
     ARs <- sapply(images, getAR)
R/r8s.R
History View file @ f1f0d8d2
... ... 
@@ -84,4 +84,3 @@ setMethod("get.fields", signature(object="r8s"),
84 84 
               get.fields.tree(object)
85 85 
           }
86 86 
           )
87 
-
R/subview.R
History View file @ f1f0d8d2