1. ggtree
  2. Commit d32146c6ce5ac178ef8e255574b6b678d79a1262
Browse code

Adds ggtree/ seq2pathway/ sidap/ to the repos.

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

m.carlson authored on 14/01/2015 21:22:07
Showing 76 changed files
DESCRIPTION
History View file @ d32146c6
1 1 
new file mode 100644
... ... 
@@ -0,0 +1,20 @@
1 
+Package: ggtree
2 
+Type: Package
3 
+Title: a phylogenetic tree viewer for different types of tree
4 
+        annotations
5 
+Version: 0.99.5
6 
+Author: Guangchuang Yu
7 
+Maintainer: Guangchuang Yu <guangchuangyu@gmail.com>
8 
+Description: ggtree extends the ggplot2 plotting system which
9 
+        implemented the grammar of graphics. ggtree is designed for
10 
+        visualizing phylogenetic tree and different types of associated
11 
+        annotation data.
12 
+Depends: R (>= 3.1.0), ape, ggplot2
13 
+Imports: Biostrings, grid, gridExtra, jsonlite, magrittr, methods,
14 
+        reshape2, stats4
15 
+Suggests: phylobase, BiocStyle, knitr, testthat, rmarkdown
16 
+VignetteBuilder: knitr
17 
+License: Artistic-2.0
18 
+URL: https://github.com/GuangchuangYu/ggtree
19 
+BugReports: https://github.com/GuangchuangYu/ggtree/issues
20 
+biocViews: Visualization
NAMESPACE
History View file @ d32146c6
0 21 
new file mode 100644
... ... 
@@ -0,0 +1,97 @@
1 
+# Generated by roxygen2 (4.1.0): do not edit by hand
2 
+
3 
+S3method(as.binary,phylo)
4 
+S3method(as.data.frame,phylo)
5 
+S3method(fortify,beast)
6 
+S3method(fortify,codeml)
7 
+S3method(fortify,codeml_mlc)
8 
+S3method(fortify,hyphy)
9 
+S3method(fortify,jplace)
10 
+S3method(fortify,paml_rst)
11 
+S3method(fortify,phylo)
12 
+S3method(fortify,phylo4)
13 
+export("%<%")
14 
+export("%<+%")
15 
+export(.)
16 
+export(as.binary)
17 
+export(geom_aline)
18 
+export(geom_tiplab)
19 
+export(geom_tippoint)
20 
+export(geom_tree)
21 
+export(get.fields)
22 
+export(get.placements)
23 
+export(get.subs)
24 
+export(get.tree)
25 
+export(get.treeinfo)
26 
+export(get.treetext)
27 
+export(ggtree)
28 
+export(gplot)
29 
+export(plot)
30 
+export(read.baseml)
31 
+export(read.beast)
32 
+export(read.codeml)
33 
+export(read.codeml_mlc)
34 
+export(read.hyphy)
35 
+export(read.jplace)
36 
+export(read.paml_rst)
37 
+export(theme_tree)
38 
+export(theme_tree2)
39 
+export(write.jplace)
40 
+exportClasses(beast)
41 
+exportClasses(codeml)
42 
+exportClasses(codeml_mlc)
43 
+exportClasses(hyphy)
44 
+exportClasses(jplace)
45 
+exportClasses(paml_rst)
46 
+exportMethods(get.fields)
47 
+exportMethods(get.placements)
48 
+exportMethods(get.subs)
49 
+exportMethods(get.tree)
50 
+exportMethods(get.treeinfo)
51 
+exportMethods(get.treetext)
52 
+exportMethods(plot)
53 
+exportMethods(show)
54 
+importFrom(Biostrings,GENETIC_CODE)
55 
+importFrom(Biostrings,readBStringSet)
56 
+importFrom(Biostrings,toString)
57 
+importFrom(ape,Ntip)
58 
+importFrom(ape,extract.clade)
59 
+importFrom(ape,is.binary.tree)
60 
+importFrom(ape,ladderize)
61 
+importFrom(ape,print.phylo)
62 
+importFrom(ape,read.nexus)
63 
+importFrom(ape,read.tree)
64 
+importFrom(ape,reorder.phylo)
65 
+importFrom(ape,write.tree)
66 
+importFrom(ggplot2,"%+replace%")
67 
+importFrom(ggplot2,aes)
68 
+importFrom(ggplot2,aes_string)
69 
+importFrom(ggplot2,annotate)
70 
+importFrom(ggplot2,coord_flip)
71 
+importFrom(ggplot2,coord_polar)
72 
+importFrom(ggplot2,element_blank)
73 
+importFrom(ggplot2,element_line)
74 
+importFrom(ggplot2,element_rect)
75 
+importFrom(ggplot2,element_text)
76 
+importFrom(ggplot2,fortify)
77 
+importFrom(ggplot2,geom_point)
78 
+importFrom(ggplot2,geom_segment)
79 
+importFrom(ggplot2,geom_text)
80 
+importFrom(ggplot2,geom_tile)
81 
+importFrom(ggplot2,ggplot)
82 
+importFrom(ggplot2,scale_fill_gradient)
83 
+importFrom(ggplot2,scale_x_reverse)
84 
+importFrom(ggplot2,theme)
85 
+importFrom(ggplot2,theme_bw)
86 
+importFrom(ggplot2,xlab)
87 
+importFrom(ggplot2,ylab)
88 
+importFrom(grid,unit)
89 
+importFrom(gridExtra,grid.arrange)
90 
+importFrom(jsonlite,fromJSON)
91 
+importFrom(magrittr,"%<>%")
92 
+importFrom(magrittr,"%>%")
93 
+importFrom(magrittr,add)
94 
+importFrom(magrittr,equals)
95 
+importFrom(methods,show)
96 
+importFrom(reshape2,melt)
97 
+importFrom(stats4,plot)
NEWS
History View file @ d32146c6
0 98 
new file mode 100644
... ... 
@@ -0,0 +1,92 @@
1 
+CHANGES IN VERSION 0.99.5
2 
+------------------------
3 
+ o add examples in man pages of %<% and %<+% operators <2015-01-06, Tue>
4 
+ o remove <<- and update vignette <2015-01-06, Tue>
5 
+ o update vignette and use BibTex and CSL for references <2015-01-05, Mon>
6 
+ o update cladogram layout <2015-01-05, Mon>
7 
+ o read.baseml function and update vignette with baseml example <2015-01-04, Sun>
8 
+ o plot method for hyphy and hyphy example in vignette <2015-01-04, Sun>
9 
+ o merge all vignettes to ggtree vignette <2015-01-04, Sun>
10 
+
11 
+CHANGES IN VERSION 0.99.4
12 
+------------------------
13 
+ o ggtree now support branch.length = "none" to only draw tree topology <2015-01-03, Sat>
14 
+ o get.subs method for hyphy object <2015-01-03, Sat>
15 
+ o show, get.tree and get.subs methods of hyphy <2015-01-02, Fri>
16 
+ o export read.hyphy <2015-01-02, Fri>
17 
+ o export hyphy class <2015-01-01, Thu>
18 
+ o plot method for beast class and get.tree method for codeml class <2014-12-31, Wed>
19 
+ o show, get.fields, get.subs and plot methods for codeml class <2014-12-30, Tue>
20 
+ o plot method for paml_rst class <2014-12-30, Tue>
21 
+ o get.subs, method for paml_rst class <2014-12-30, Tue>
22 
+ o show, plot, get.tree and fority methods for codeml_mlc class <2014-12-29, Mon>
23 
+ o codeml class <2014-12-29, Mon>
24 
+ o hyphy class and read.hyphy prototype <2014-12-27, Sat>
25 
+ o update man file and add example file of beast output <2014-12-26, Fri>
26 
+ o get.tree and get.fileds methods of beast class <2014-12-26, Fri>
27 
+ o read.beast <2014-12-26, Fri>
28 
+ o beast class and show method <2014-12-26, Fri>
29 
+ o coplot prototype<2014-12-24, Wed>
30 
+ o parse translation matrix in beast nexus <2014-12-24, Wed>
31 
+ o extract beast stats info <2014-12-23, Tue>
32 
+
33 
+CHANGES IN VERSION 0.99.3
34 
+------------------------
35 
+ o gplot function that can view a tree and an associated matrix simultaneously <2014-12-22, Mon>
36 
+ o modified vignette to show based on branch position and break the evolution distance scale <2014-12-22, Mon>
37 
+ o label and annotation can be put based on branch. <2014-12-22, Mon>
38 
+ o write.jplace and fully supports of jplace by ggtree. <2014-12-21, Sun>
39 
+ o support unrooted layout in ggplot. <2014-12-21, Sun>
40 
+ o support fan, radial, dendrogram layout in geom_tree. <2014-12-21, Sun>
41 
+
42 
+CHANGES IN VERSION 0.99.2
43 
+------------------------
44 
+ o layout of unrooted tree, implemented equal-angle algorithm that described in Chapter 34
45 
+   of 'Inferring Phylogenies' (page 578-580) <2014-12-20, Sat>
46 
+ o add layout parameter in ggtree and geom_tree, now supports phylogram and cladogram <2014-12-20, Sat>
47 
+ o %<+% function for inserting annotation data to a tree view <2014-12-20, Sat>
48 
+ o update ggtree-treeAnnotation vignette <2014-12-20, Sat>
49 
+
50 
+CHANGES IN VERSION 0.99.1
51 
+------------------------
52 
+ o %<% function for updating tree view with a new tree <2014-12-19, Fri>
53 
+ o add examples in man files <2014-12-19, Fri>
54 
+
55 
+CHANGES IN VERSION 0.2.3
56 
+------------------------
57 
+ o add README.md <2014-12-19, Fri>
58 
+ o update ggtree-treeViewer vignette <2014-12-19, Fri>
59 
+ o use BiocStyle in vignette <2014-12-19, Fri>
60 
+ o geom_nplace and geom_place layer <2014-12-18, Thu>
61 
+ o add theme_tree2 theme for showing evolution distance <2014-12-18, Thu>
62 
+ o rm.singleton.newick now supports internal node like:
63 
+   ((()X, ()Y)Z)AA, in which Z is a singleton. <2014-12-15, Mon>
64 
+
65 
+CHANGES IN VERSION 0.2.2
66 
+------------------------
67 
+ o rm.singleton.newick <2014-12-09, Tue>
68 
+ o as.binary method <2014-12-09, Tue>
69 
+
70 
+CHANGES IN VERSION 0.2.1
71 
+------------------------
72 
+ o geom_eplace <2014-12-07, Sun>
73 
+
74 
+CHANGES IN VERSION 0.2.0
75 
+------------------------
76 
+ o read.jplace to read the jplace file <2014-12-05, Fri>
77 
+ o jplace class for storing information of jplace file <2014-12-05, Fri>
78 
+ o show method of jplace class <2014-12-05, Fri>
79 
+ o get.tree method to get tree from jplace class <2014-12-05, Fri>
80 
+ o extend ggplot2 to support jplace class <2014-12-05, Fri>
81 
+
82 
+CHANGES IN VERSION 0.1.1
83 
+------------------------
84 
+ o add distance legend in ggtree <2014-12-05, Fri>
85 
+
86 
+CHANGES IN VERSION 0.1.0
87 
+------------------------
88 
+ o support ladderize tree <2014-12-05, Fri>
89 
+ o implement geom_tree, geom_tiplab, geom_tippoint, geom_aline and theme_tree <2014-12-04, Thu>
90 
+ o extend ggplot to support phylo object and implement ggtree function <2014-12-04, Thu>
91 
+ o implement fortify function <2014-12-04, Thu>
92 
+ o add getRoot, isRoot and getParent functions <2014-12-03, Wed>
R/AllClasses.R
History View file @ d32146c6
0 93 
new file mode 100644
... ... 
@@ -0,0 +1,198 @@
1 
+setOldClass("phylo")
2 
+
3 
+
4 
+##' Class "hyphy"
5 
+##' This class stores information of HYPHY output
6 
+##'
7 
+##'
8 
+##' @name hyphy-class
9 
+##' @docType class
10 
+##' @slot fields available features
11 
+##' @slot treetext tree text
12 
+##' @slot phylo phylo object
13 
+##' @slot seq_type one of "NT" and "AA"
14 
+##' @slot subs sequence substitutions
15 
+##' @slot AA_subs Amino acid sequence substitution
16 
+##' @slot ancseq ancestral sequences
17 
+##' @slot tip_seq tip sequences
18 
+##' @slot tip.fasfile fasta file of tip sequences
19 
+##' @slot tree.file tree file
20 
+##' @slot ancseq.file ancestral sequence file, nexus format
21 
+##' @exportClass hyphy
22 
+##' @author Guangchuang Yu \url{http://ygc.name}
23 
+##' @seealso \linkS4class{paml_rst}
24 
+##' @keywords classes
25 
+setClass("hyphy",
26 
+         representation  = representation(
27 
+             fields      = "character",
28 
+             treetext    = "character",
29 
+             phylo       = "phylo",
30 
+             seq_type    = "character",
31 
+             subs        = "data.frame",
32 
+             AA_subs     = "data.frame",
33 
+             ancseq      = "character",
34 
+             tip_seq     = "character",
35 
+             tip.fasfile = "character",
36 
+             tree.file   = "character",
37 
+             ancseq.file = "character"
38 
+             )
39 
+         )
40 
+
41 
+
42 
+##' Class "paml_rst"
43 
+##' This class stores information of rst file from PAML output
44 
+##'
45 
+##'
46 
+##' @name paml_rst-class
47 
+##' @aliases paml_rst-class
48 
+##'   set.subs,paml_rst-method
49 
+##'   set.subs<-,paml_rst-method
50 
+##'
51 
+##' @docType class
52 
+##' @slot fields availabel attributes
53 
+##' @slot treetext tree text
54 
+##' @slot phylo phylo object
55 
+##' @slot seq_type one of "NT" and "AA"
56 
+##' @slot tip_seq sequences of tips
57 
+##' @slot marginal_ancseq Marginal reconstruction of ancestral sequences
58 
+##' @slot joint_ancseq Joint reconstruction of ancestral sequences
59 
+##' @slot marginal_subs sequence substitutions based on marginal_ancseq
60 
+##' @slot joint_subs sequence substitutions based on joint_ancseq
61 
+##' @slot marginal_AA_subs Amino acid sequence substitutions based on marginal_ancseq
62 
+##' @slot joint_AA_subs Amino acid sequence substitutions based on joint_ancseq
63 
+##' @slot tip.fasfile fasta file of tip sequences
64 
+##' @slot rstfile rst file
65 
+##' @exportClass paml_rst
66 
+##' @author Guangchuang Yu \url{http://ygc.name}
67 
+##' @seealso \linkS4class{codeml} \linkS4class{codeml_mlc}
68 
+##' @keywords classes
69 
+setClass("paml_rst",
70 
+         representation       = representation(
71 
+             fields           = "character",
72 
+             treetext         = "character",
73 
+             phylo            = "phylo",
74 
+             seq_type         = "character",
75 
+             tip_seq          = "character",
76 
+             marginal_ancseq  = "character",
77 
+             joint_ancseq     = "character",
78 
+             marginal_subs    = "data.frame",
79 
+             joint_subs       = "data.frame",
80 
+             marginal_AA_subs = "data.frame",
81 
+             joint_AA_subs    = "data.frame",
82 
+             tip.fasfile      = "character",
83 
+             rstfile          = "character"
84 
+         )
85 
+         )
86 
+
87 
+##' Class "codeml_mlc"
88 
+##' This class stores information of mlc file frm codeml output
89 
+##'
90 
+##'
91 
+##' @name codeml_mlc-class
92 
+##' @docType class
93 
+##' @slot fields available features
94 
+##' @slot treetext tree text
95 
+##' @slot phylo phylo object
96 
+##' @slot dNdS dN dS information
97 
+##' @slot seq_type one of "NT" and "AA"
98 
+##' @slot tip_seq sequences of tips
99 
+##' @slot mlcfile mlc file
100 
+##' @exportClass codeml_mlc
101 
+##' @author Guangchuang Yu
102 
+##' @seealso \linkS4class{paml_rst} \linkS4class{codeml}
103 
+##' @keywords classes
104 
+setClass("codeml_mlc",
105 
+         representation = representation(
106 
+             fields     = "character",
107 
+             treetext   = "character",
108 
+             phylo      = "phylo",
109 
+             dNdS       = "matrix",
110 
+             seq_type   = "character",
111 
+             tip_seq    = "character",
112 
+             mlcfile    = "character"
113 
+             )
114 
+         )
115 
+
116 
+##' Class "codeml"
117 
+##' This class stores information of output from codeml
118 
+##'
119 
+##'
120 
+##' @name codeml-class
121 
+##' @docType class
122 
+##' @slot mlc A \code{code_mlc} object
123 
+##' @slot rst A \code{paml_rst} object
124 
+##' @exportClass codeml
125 
+##' @seealso \linkS4class{codeml_mlc} \linkS4class{paml_rst}
126 
+##' @keywords codeml
127 
+setClass("codeml",
128 
+         representation = representation(
129 
+             mlc = "codeml_mlc",
130 
+             rst = "paml_rst"
131 
+             )
132 
+         )
133 
+
134 
+##' Class "jplace"
135 
+##' This class stores information of jplace file.
136 
+##'
137 
+##'
138 
+##' @name jplace-class
139 
+##' @aliases jplace-class
140 
+##'   show,jplace-method
141 
+##'   get.placements,jplace-method
142 
+##'   get.treeinfo,jplace-method
143 
+##'   get.fields,jplace-method
144 
+##'   get.treetext,jplace-method
145 
+##'
146 
+##' @docType class
147 
+##' @slot fields colnames of first variable of placements
148 
+##' @slot treetext tree text
149 
+##' @slot placements placement information
150 
+##' @slot version version
151 
+##' @slot metadata metadata
152 
+##' @slot file jplace file
153 
+##' @exportClass jplace
154 
+##' @author Guangchuang Yu \url{http://ygc.name}
155 
+##' @seealso \code{\link{show}} \code{\link{get.tree}}
156 
+##'          \code{\link{ggtree}}
157 
+##' @keywords classes
158 
+setClass("jplace",
159 
+         representation = representation(
160 
+             fields     = "character",
161 
+             treetext   = "character",
162 
+             placements = "data.frame",
163 
+             version    = "numeric",
164 
+             metadata   = "list",
165 
+             file       = "character"
166 
+             )
167 
+         )
168 
+
169 
+##' Class "beast"
170 
+##' This class stores information of beast output
171 
+##'
172 
+##'
173 
+##' @name beast-class
174 
+##' @aliases beast-class
175 
+##'      get.tree,beast-method
176 
+##'
177 
+##' @docType class
178 
+##' @slot fields beast statistic variables
179 
+##' @slot treetext tree text in beast file
180 
+##' @slot phylo tree phylo object
181 
+##' @slot translation tip number to name translation in beast file
182 
+##' @slot stats beast statistics
183 
+##' @slot file beast file, nexus format
184 
+##' @exportClass beast
185 
+##' @author Guangchuang Yu \url{http://ygc.name}
186 
+##' @seealso \code{\link{show}} \code{\link{get.fields}}
187 
+##'           \code{\link{ggtree}}
188 
+##' @keywords classes
189 
+setClass("beast",
190 
+         representation  = representation(
191 
+             fields      = "character",
192 
+             treetext    = "character",
193 
+             phylo       = "phylo",
194 
+             translation = "matrix",
195 
+             stats       = "data.frame",
196 
+             file        = "character"
197 
+             )
198 
+         )
R/AllGenerics.R
History View file @ d32146c6
0 199 
new file mode 100644
... ... 
@@ -0,0 +1,95 @@
1 
+##' @title as.binary
2 
+##' @param tree phylo, object
3 
+##' @param ... additional parameter
4 
+##' @rdname as.binary
5 
+##' @export
6 
+as.binary <- function(tree, ...) {
7 
+    UseMethod("as.binary")
8 
+}
9 
+
10 
+##' plot method generics
11 
+##'
12 
+##'
13 
+##' @docType methods
14 
+##' @name plot
15 
+##' @rdname plot-methods
16 
+##' @title plot method
17 
+##' @param x object
18 
+##' @param ... Additional argument list
19 
+##' @return plot
20 
+##' @importFrom stats4 plot
21 
+##' @export
22 
+if ( !isGeneric("plot") )
23 
+	setGeneric("plot", function(x, ...) standardGeneric("plot"))
24 
+
25 
+
26 
+##' @docType methods
27 
+##' @name get.tree
28 
+##' @rdname get.tree-methods
29 
+##' @title get.tree method
30 
+##' @param object one of \code{jplace}, \code{beast} object
31 
+##' @param ... additional parameter
32 
+##' @return phylo object
33 
+##' @export
34 
+setGeneric("get.tree", function(object, ...) standardGeneric("get.tree"))
35 
+
36 
+##' @docType methods
37 
+##' @name get.treetext
38 
+##' @rdname get.treetext-methods
39 
+##' @title get.treetext method
40 
+##' @param object one of \code{jplace}, \code{beast} object
41 
+##' @param ... additional parameter
42 
+##' @return phylo object
43 
+##' @export
44 
+setGeneric("get.treetext", function(object, ...) standardGeneric("get.treetext"))
45 
+
46 
+
47 
+##' @docType methods
48 
+##' @name get.treeinfo
49 
+##' @rdname get.treeinfo-methods
50 
+##' @title get.treeinfo method
51 
+##' @param object jplace object
52 
+##' @param layout layout
53 
+##' @param ladderize ladderize, logical
54 
+##' @param right logical, parameter for ladderize
55 
+##' @param ... additional parameter
56 
+##' @return data.frame
57 
+##' @export
58 
+setGeneric("get.treeinfo", function(object, layout="phylogram", ladderize=TRUE, right=FALSE, ...) standardGeneric("get.treeinfo"))
59 
+
60 
+
61 
+##' @docType methods
62 
+##' @name get.fields
63 
+##' @rdname get.fields-methods
64 
+##' @title get.fields method
65 
+##' @param object one of \code{jplace}, \code{beast} object
66 
+##' @param ... additional parameter
67 
+##' @return available annotation variables
68 
+##' @export
69 
+setGeneric("get.fields", function(object, ...) standardGeneric("get.fields"))
70 
+
71 
+
72 
+##' @docType methods
73 
+##' @name get.placements
74 
+##' @rdname get.placements-methods
75 
+##' @title get.placements method
76 
+##' @param object jplace object
77 
+##' @param by get best hit or others
78 
+##' @param ... additional parameter
79 
+##' @return data.frame
80 
+##' @export
81 
+setGeneric("get.placements", function(object, by, ...) standardGeneric("get.placements"))
82 
+
83 
+##' @docType methods
84 
+##' @name get.subs
85 
+##' @rdname get.subs-methods
86 
+##' @title get.subs method
87 
+##' @param object paml_rst object
88 
+##' @param type one of 'marginal_subs', 'marginal_AA_subs',
89 
+##'                     'joint_subs' or 'joint_AA_subs'.
90 
+##' @param ... additional parameter
91 
+##' @return data.frame
92 
+##' @export
93 
+setGeneric("get.subs", function(object, type, ...) standardGeneric("get.subs"))
94 
+
95 
+
R/NJ.R
History View file @ d32146c6
0 96 
new file mode 100644
... ... 
@@ -0,0 +1,88 @@
1 
+##' neighbor-joining method
2 
+##'
3 
+##'
4 
+##' @title NJ
5 
+##' @param X distance matrix
6 
+##' @return phylo object
7 
+##' @author ygc
8 
+##' @examples
9 
+##' \dontrun{
10 
+##' X <- matrix(c(0,5,4,7,6,8,
11 
+##'		5,0,7,10,9,11,
12 
+##'		4,7,0,7,6,8,
13 
+##'		7,10,7,0,5,9,
14 
+##'		6,9,6,5,0,8,
15 
+##'		8,11,8,9,8,0), ncol=6)
16 
+##' rownames(X) <- colnames(X) <- LETTERS[1:6]
17 
+##' tree <- NJ(X)
18 
+##' print(tree)
19 
+##' }
20 
+NJ <- function(X) {
21 
+    labels <- colnames(X)
22 
+    N <- ncol(X)
23 
+    otu_labs <- 1:N
24 
+
25 
+    dm <- as.matrix(X)
26 
+    S <- colSums(dm)
27 
+
28 
+    ## edge list of node 1 and node 2
29 
+    edge1 <- edge2 <- numeric(2*N-3)
30 
+    edge_length <- numeric(2*N-3)
31 
+    k <- 1
32 
+    cur_node <- 2*N-2
33 
+    while (N > 3) {
34 
+        ds <- 1e50
35 
+        for (i in 1:(N-1)) {
36 
+            for (j in (i+1):N) {
37 
+                A <- N * dm[i,j] - S[i] - S[j]
38 
+                if (A < ds) {
39 
+                    OUT1 <- i;
40 
+                    OUT2 <- j;
41 
+                    ds <- A
42 
+                }
43 
+            }
44 
+        }
45 
+        edge2[k] <- otu_labs[OUT1]
46 
+        edge2[k+1] <- otu_labs[OUT2]
47 
+        edge1[k] <- edge1[k+1] <- cur_node
48 
+        dij <- dm[OUT1, OUT2]
49 
+        B <- (S[OUT1]-S[OUT2]) / (N-2)
50 
+        edge_length[k] <- (dij + B)/2
51 
+        edge_length[k+1] <- (dij - B)/2
52 
+
53 
+        ij <- 1
54 
+        new_dist <- numeric(N-2)
55 
+        ## d_kn=1/2(d_ik+d_jk−d_ij)
56 
+        for (i in 1:N) {
57 
+            if (i == OUT1 || i == OUT2) next
58 
+            x <- dm[i, OUT1]
59 
+            y <- dm[i, OUT2]
60 
+            new_dist[ij] <- 1/2 * (x+y-dij)
61 
+            ij <- ij + 1
62 
+        }
63 
+        ## update data
64 
+        dm <- dm[-c(OUT1, OUT2), -c(OUT1, OUT2)]
65 
+        dm <- rbind(dm, new_dist)
66 
+        dm <- cbind(dm, c(new_dist, 0))
67 
+        otu_labs <- otu_labs[-c(OUT1, OUT2)]
68 
+        otu_labs <- c(otu_labs, cur_node)
69 
+        rownames(dm) <- otu_labs
70 
+        colnames(dm) <- otu_labs
71 
+        S <- colSums(dm)
72 
+        cur_node <- cur_node-1
73 
+        k <- k+2
74 
+        N <- N - 1
75 
+    }
76 
+
77 
+    n <- length(edge1)
78 
+    edge1[(n-2):n] <- cur_node
79 
+    edge2[(n-2):n] <- otu_labs
80 
+    edge_length[n-2] <- (dm[1,2]+dm[1,3]-dm[2,3])/2
81 
+    edge_length[n-1] <- (dm[2,1]+dm[2,3]-dm[1,3])/2
82 
+    edge_length[n] <- (dm[3,1]+dm[3,2]-dm[1,2])/2
83 
+    obj <- list(edge=cbind(as.numeric(edge1), as.numeric(edge2)),
84 
+                edge.length=edge_length,
85 
+                tip.label=labels, Nnode=length(labels)-2)
86 
+    class(obj) <- "phylo"
87 
+    return(obj)
88 
+}
R/beast.R
History View file @ d32146c6
0 89 
new file mode 100644
... ... 
@@ -0,0 +1,265 @@
1 
+
2 
+##' read beast output
3 
+##'
4 
+##'
5 
+##' @title read.beast
6 
+##' @param file beast file
7 
+##' @return \code{beast} object
8 
+##' @importFrom ape read.nexus
9 
+##' @export
10 
+##' @author Guangchuang Yu \url{http://ygc.name}
11 
+##' @examples
12 
+##' file <- system.file("extdata/BEAST", "beast_mcc.tree", package="ggtree")
13 
+##' read.beast(file)
14 
+read.beast <- function(file) {
15 
+    stats <- read.stats_beast(file)
16 
+    fields <- sub("_lower|_upper", "", names(stats)) %>% unique
17 
+    fields %<>% `[`(.!="node")
18 
+
19 
+    new("beast",
20 
+        fields      = fields,
21 
+        treetext    = read.treetext_beast(file),
22 
+        phylo       = read.nexus(file),
23 
+        translation = read.trans_beast(file),
24 
+        stats       = stats,
25 
+        file        = file
26 
+        )
27 
+}
28 
+
29 
+##' @rdname plot-methods
30 
+##' @exportMethod plot
31 
+##' @param tip.label.size size of tip label
32 
+##' @param tip.label.hjust hjust of tip.label
33 
+##' @param annotation.size size of annotation
34 
+##' @param annotation.color color of annotation
35 
+##' @examples
36 
+##' file <- system.file("extdata/BEAST", "beast_mcc.tree", package="ggtree")
37 
+##' beast <- read.beast(file)
38 
+##' plot(beast, annotation="length_0.95_HPD", branch.length="none") + theme_tree()
39 
+setMethod("plot", signature( x= "beast"),
40 
+          function(x, layout = "phylogram",
41 
+                   branch.length = "branch.length",
42 
+                   show.tip.label = TRUE,
43 
+                   tip.label.size = 4,
44 
+                   tip.label.hjust = -0.1,
45 
+                   position = "branch",
46 
+                   annotation = "rate",
47 
+                   ndigits = 2,
48 
+                   annotation.size = 3,
49 
+                   annotation.color = "black",
50 
+                   ...) {
51 
+
52 
+              p <- ggtree(x, layout     = layout,
53 
+                          branch.length = branch.length,
54 
+                          ndigits       = ndigits, ...)
55 
+
56 
+              if (show.tip.label) {
57 
+                  p <- p + geom_tiplab(hjust = tip.label.hjust,
58 
+                                       size  = tip.label.size)
59 
+                  offset <- ceiling(max(p$data$x)) * 0.1
60 
+                  p <- p + xlim(-offset, max(p$data$x) + offset)
61 
+              }
62 
+              if (!is.null(annotation) && !is.na(annotation)) {
63 
+                  p <- p + geom_text(aes_string(x=position,
64 
+                                                label=annotation),
65 
+                                     size=annotation.size, vjust=-.5,
66 
+                                     color=annotation.color)
67 
+              }
68 
+              p + theme_tree2()
69 
+          })
70 
+
71 
+##' @rdname show-methods
72 
+##' @importFrom ape print.phylo
73 
+##' @exportMethod show
74 
+setMethod("show", signature(object = "beast"),
75 
+          function(object) {
76 
+              cat("'beast' S4 object that stored information of\n\t",
77 
+                  paste0("'", object@file, "'.\n\n"))
78 
+              cat("...@ tree: ")
79 
+              print.phylo(get.tree(object))
80 
+              cat("\nwith the following features available:\n")
81 
+              print_fields(object)
82 
+          })
83 
+
84 
+
85 
+##' get.tree method
86 
+##'
87 
+##'
88 
+##' @docType methods
89 
+##' @name get.tree
90 
+##' @rdname get.tree-methods
91 
+##' @aliases get.tree,beast
92 
+##' @exportMethod get.tree
93 
+##' @author Guangchuang Yu \url{http://ygc.name}
94 
+##' @usage get.tree(object, ...)
95 
+setMethod("get.tree", signature(object="beast"),
96 
+          function(object,...) {
97 
+              object@phylo
98 
+          }
99 
+          )
100 
+
101 
+
102 
+##' @rdname get.fields-methods
103 
+##' @exportMethod get.fields
104 
+setMethod("get.fields", signature(object="beast"),
105 
+          function(object, ...) {
106 
+              object@fields
107 
+          }
108 
+          )
109 
+
110 
+
111 
+read.treetext_beast <- function(file) {
112 
+    beast <- readLines(file)
113 
+    ii <- grep("tree TREE1\\s+=", beast)
114 
+    jj <- grep("End;", beast)
115 
+    jj <- jj[jj > ii][1]
116 
+    tree <- beast[ii:(jj-1)]
117 
+    if (length(tree) > 1) {
118 
+        tree <- paste0(tree)
119 
+    }
120 
+    tree %<>% sub("tree TREE1\\s+=\\s+\\[&R\\]\\s+", "", .)
121 
+    return(tree)
122 
+}
123 
+
124 
+read.trans_beast <- function(file) {
125 
+    beast <- readLines(file)
126 
+    i <- grep("TRANSLATE", beast, ignore.case = TRUE)
127 
+    end <- grep(";", beast)
128 
+    j <- end[end %>% `>`(i) %>% which %>% `[`(1)]
129 
+    trans <- beast[(i+1):j]
130 
+    trans %<>% gsub("\\t+", "", .)
131 
+    trans %<>% gsub(",|;", "", .)
132 
+    trans %<>% `[`(nzchar(trans))
133 
+    ## remove quote if strings were quoted
134 
+    trans %<>% gsub("'|\"", "",.)
135 
+    trans %<>% sapply(., strsplit, split="\\s+")
136 
+    trans %<>% do.call(rbind, .)
137 
+    ## trans is a matrix
138 
+    return(trans)
139 
+}
140 
+
141 
+read.stats_beast <- function(file) {
142 
+    beast <- readLines(file)
143 
+    tree <- read.treetext_beast(file)
144 
+
145 
+    tree2 <- gsub("\\[[^\\[]*\\]", "", tree)
146 
+    phylo <- read.tree(text = tree2)
147 
+    if(is.null(phylo$node.label)) {
148 
+        nnode <- phylo$Nnode
149 
+        nlab <- paste("X", 1:nnode, sep="")
150 
+        for (i in 1:nnode) {
151 
+            tree2 <- sub("\\)([:;])", paste0("\\)", nlab[i], "\\1"), tree2)
152 
+        }
153 
+    }
154 
+
155 
+    ## node name corresponding to stats
156 
+    nn <- strsplit(tree2, split=",") %>% unlist %>%
157 
+        strsplit(., split="\\)") %>% unlist %>%
158 
+            gsub("\\(*", "", .) %>%
159 
+                gsub("[:;].*", "", .)
160 
+
161 
+    phylo <- read.tree(text = tree2)
162 
+    root <- getRoot(phylo)
163 
+    nnode <- phylo$Nnode
164 
+
165 
+    ## phylo2 <- read.nexus(file)
166 
+    ## treeinfo <- fortify.phylo(phylo)
167 
+    ## treeinfo2 <- fortify.phylo(phylo2)
168 
+    ## treeinfo$label2 <- NA
169 
+    ## treeinfo$label2[treeinfo$isTip] <- treeinfo2$node[as.numeric(treeinfo$label[treeinfo$isTip])]
170 
+    ## treeinfo$visited <- FALSE
171 
+    ## root <- getRoot(phylo2)
172 
+    ## treeinfo[root, "visited"] <- TRUE
173 
+    ## currentNode <- 1:Ntip(phylo2)
174 
+    ## while(any(treeinfo$visited == FALSE)) {
175 
+    ##     pNode <- c()
176 
+    ##     for (kk in currentNode) {
177 
+    ##         i <- which(treeinfo$label2 == kk)
178 
+    ##         treeinfo[i, "visited"] <- TRUE
179 
+    ##         j <- which(treeinfo2$node == kk)
180 
+    ##         ip <- treeinfo$parent[i]
181 
+    ##         if (ip != root) {
182 
+    ##             ii <- which(treeinfo$node == ip)
183 
+    ##             if (treeinfo$visited[ii] == FALSE) {
184 
+    ##                 jp <- treeinfo2$parent[j]
185 
+    ##                 jj <- which(treeinfo2$node == jp)
186 
+    ##                 treeinfo[ii, "label2"] <- treeinfo2[jj, "node"]
187 
+    ##                 pNode <- c(pNode, jp)
188 
+    ##             }
189 
+    ##             treeinfo[ii, "visited"] <- TRUE
190 
+    ##         }
191 
+    ##     }
192 
+    ##     currentNode <- unique(pNode)
193 
+    ## }
194 
+    ## treeinfo[root, "label2"] <- root
195 
+    ## ## convert nn to node that encoded in phylo2
196 
+    ## node <- treeinfo$label2[match(nn, treeinfo$label)]
197 
+
198 
+
199 
+    ####################################################
200 
+    ##                                                ##
201 
+    ##  after doing it in the hard way                ##
202 
+    ##  I finally figure out the following easy way   ##
203 
+    ##                                                ##
204 
+    ####################################################
205 
+    treeinfo <- fortify.phylo(phylo)
206 
+    label2 <- c(treeinfo[treeinfo$isTip, "label"],
207 
+                root:(root+nnode-1))
208 
+    node <- label2[match(nn, treeinfo$label)]
209 
+
210 
+
211 
+
212 
+    stats <- unlist(strsplit(tree, "\\["))[-1]
213 
+    stats <- sub(":.+$", "", stats)
214 
+    stats <- sub("^&", "", stats)
215 
+    stats <- sub("];*$", "", stats)
216 
+
217 
+    stats2 <- lapply(stats, function(x) {
218 
+        y <- unlist(strsplit(x, ","))
219 
+        idx <- grep("=\\{", y)
220 
+        names.range <- gsub("=\\{.*", "", y[idx])
221 
+        nr.lower <- paste0(names.range, "_lower")
222 
+        nr.upper <- paste0(names.range, "_upper")
223 
+
224 
+        lo <- as.numeric(gsub(".*=\\{", "", y[idx]))
225 
+        hi <- as.numeric(gsub("\\}", "", y[idx+1]))
226 
+
227 
+
228 
+        jj <- -c(idx, idx+1)
229 
+        names <- gsub("=.*", "", y[jj])
230 
+        val <- as.numeric(gsub(".*=", "", y[jj]))
231 
+
232 
+        nn <- c(nr.lower, nr.upper, names)
233 
+        res <- numeric(length(nn))
234 
+        names(res) <- nn
235 
+        for (i in seq_along(nr.lower)) {
236 
+            res[i] <- lo[i]
237 
+        }
238 
+        j <- i
239 
+        for (i in seq_along(nr.upper)) {
240 
+            res[i+j] <- hi[i]
241 
+        }
242 
+        j <- i+j
243 
+        for (i in seq_along(names)) {
244 
+            res[i+j] <- val[i]
245 
+        }
246 
+        return(res)
247 
+    })
248 
+
249 
+    nn <- lapply(stats2, names) %>% unlist %>%
250 
+        unique %>% sort
251 
+
252 
+    ## stats3 is a matrix
253 
+    stats3 <- t(sapply(stats2, function(x) {
254 
+        for (ii in nn[!nn %in% names(x)]) {
255 
+            x[ii] <- NA
256 
+        }
257 
+        x[nn]
258 
+    }))
259 
+
260 
+    stats3 <- as.data.frame(stats3)
261 
+    stats3$node <- node
262 
+    colnames(stats3) <- gsub("(\\d+)%", "0.\\1", colnames(stats3))
263 
+    return(stats3)
264 
+}
265 
+
R/codeml.R
History View file @ d32146c6
0 266 
new file mode 100644
... ... 
@@ -0,0 +1,106 @@
1 
+##' read baseml output
2 
+##'
3 
+##'
4 
+##' @title read.codeml
5 
+##' @param rstfile rst file
6 
+##' @param mlcfile mlc file
7 
+##' @return A \code{codeml} object
8 
+##' @export
9 
+##' @author ygc
10 
+##' @examples
11 
+##' rstfile <- system.file("extdata/PAML_Codeml", "rst", package="ggtree")
12 
+##' mlcfile <- system.file("extdata/PAML_Codeml", "mlc", package="ggtree")
13 
+##' read.codeml(rstfile, mlcfile)
14 
+read.codeml <- function(rstfile, mlcfile) {
15 
+    rst = read.paml_rst(rstfile)
16 
+    mlc = read.codeml_mlc(mlcfile)
17 
+    rst@tip_seq <- mlc@tip_seq
18 
+    new("codeml",
19 
+        rst = set.paml_rst_(rst),
20 
+        mlc = mlc
21 
+        )
22 
+}
23 
+
24 
+
25 
+##' @rdname show-methods
26 
+##' @exportMethod show
27 
+setMethod("show", signature(object = "codeml"),
28 
+          function(object) {
29 
+              cat("'codeml' S4 object that stored information of\n\t",
30 
+                  paste0("'", object@rst@rstfile, "' and \n\t'",
31 
+                         object@mlc@mlcfile, "'."),
32 
+                  "\n\n")
33 
+              cat("...@ tree:")
34 
+              print.phylo(get.tree(object))
35 
+              cat("\nwith the following features available:\n")
36 
+              print_fields(object, len=4)
37 
+          })
38 
+
39 
+
40 
+##' @rdname get.tree-methods
41 
+##' @exportMethod get.tree
42 
+##' @param by one of rst or mlc
43 
+setMethod("get.tree", signature(object="codeml"),
44 
+          function(object, by="rst", ...) {
45 
+              if (by == "rst") {
46 
+                  return(object@rst@phylo)
47 
+              } else {
48 
+                  return(object@mlc@phylo)
49 
+              }
50 
+          })
51 
+
52 
+##' @rdname get.subs-methods
53 
+##' @exportMethod get.subs
54 
+setMethod("get.subs", signature(object = "codeml"),
55 
+          function(object, type, ...) {
56 
+              get.subs(object@rst, type, ...)
57 
+          }
58 
+          )
59 
+
60 
+
61 
+##' @rdname get.fields-methods
62 
+##' @exportMethod get.fields
63 
+setMethod("get.fields", signature(object="codeml"),
64 
+          function(object) {
65 
+              fields <- c(get.fields(object@rst),
66 
+                          get.fields(object@mlc))
67 
+              return(unique(fields))
68 
+          }
69 
+          )
70 
+
71 
+##' @rdname plot-methods
72 
+##' @exportMethod plot
73 
+##' @importFrom ggplot2 aes_string
74 
+setMethod("plot", signature(x = "codeml"),
75 
+          function(x, layout        = "phylogram",
76 
+                   branch.length    = "mlc.branch.length",
77 
+                   show.tip.label   = TRUE,
78 
+                   tip.label.size   = 4,
79 
+                   tip.label.hjust  = -0.1,
80 
+                   position         = "branch",
81 
+                   annotation       = "dN.dS",
82 
+                   annotation.size  = 3,
83 
+                   annotation.color = "black",
84 
+                   ndigits          = 2,
85 
+                   ...) {
86 
+
87 
+              p <- ggtree(x, layout = layout,
88 
+                          branch.length = branch.length,
89 
+                          ndigits=ndigits, ...)
90 
+
91 
+              if (show.tip.label) {
92 
+                  p <- p + geom_tiplab(hjust = tip.label.hjust,
93 
+                                       size  = tip.label.size)
94 
+              }
95 
+
96 
+              if (!is.null(annotation) && !is.na(annotation)) {
97 
+                  p <- p + geom_text(aes_string(x=position,
98 
+                                                label = annotation),
99 
+                                     size = annotation.size, vjust = -.5,
100 
+                                     color = annotation.color)
101 
+              }
102 
+              p + theme_tree2()
103 
+          }
104 
+          )
105 
+
106 
+
R/codeml_mlc.R
History View file @ d32146c6
0 107 
new file mode 100644
... ... 
@@ -0,0 +1,110 @@
1 
+##' read mlc file of codeml output
2 
+##'
3 
+##'
4 
+##' @title read.codeml_mlc
5 
+##' @param mlcfile mlc file
6 
+##' @return A \code{codeml_mlc} object
7 
+##' @export
8 
+##' @author ygc
9 
+##' @examples
10 
+##' mlcfile <- system.file("extdata/PAML_Codeml", "mlc", package="ggtree")
11 
+##' read.codeml_mlc(mlcfile)
12 
+read.codeml_mlc <- function(mlcfile) {
13 
+    tip_seq <- read.tip_seq_mlc(mlcfile)
14 
+    dNdS <- read.dnds_mlc(mlcfile)
15 
+
16 
+    new("codeml_mlc",
17 
+        fields   = colnames(dNdS)[-c(1,2)],
18 
+        treetext = read.treetext_paml_mlc(mlcfile),
19 
+        phylo    = read.phylo_paml_mlc(mlcfile),
20 
+        dNdS     = dNdS,
21 
+        seq_type = get_seqtype(tip_seq),
22 
+        tip_seq  = tip_seq,
23 
+        mlcfile  = mlcfile)
24 
+}
25 
+
26 
+##' @rdname show-methods
27 
+##' @exportMethod show
28 
+setMethod("show", signature(object = "codeml_mlc"),
29 
+          function(object) {
30 
+              cat("'codeml_mlc' S4 object that stored information of\n\t",
31 
+                  paste0("'", object@mlcfile, "'."),
32 
+                  "\n\n")
33 
+
34 
+              cat("...@ tree:")
35 
+              print.phylo(get.tree(object))
36 
+
37 
+              cat("\nwith the following features available:\n")
38 
+              cat("\t", paste0("'",
39 
+                                 paste(get.fields(object), collapse="',\t'"),
40 
+                                 "'."),
41 
+                  "\n")
42 
+          }
43 
+          )
44 
+
45 
+
46 
+##' @rdname get.fields-methods
47 
+##' @exportMethod get.fields
48 
+setMethod("get.fields", signature(object = "codeml_mlc"),
49 
+          function(object) {
50 
+              object@fields
51 
+          })
52 
+
53 
+##' @rdname plot-methods
54 
+##' @exportMethod plot
55 
+##' @param layout layout
56 
+##' @param branch.length branch length
57 
+##' @param show.tip.label logical
58 
+##' @param position one of "branch" and "node"
59 
+##' @param annotation one of get.fields(x)
60 
+##' @param ndigits round digits
61 
+setMethod("plot", signature(x = "codeml_mlc"),
62 
+          function(x, layout        = "phylogram",
63 
+                   branch.length    = "branch.length",
64 
+                   show.tip.label   = TRUE,
65 
+                   tip.label.size   = 4,
66 
+                   tip.label.hjust  = -0.1,
67 
+                   position         = "branch",
68 
+                   annotation       = "dN_vs_dS",
69 
+                   annotation.size  = 3,
70 
+                   annotation.color = "black",
71 
+                   ndigits          = 2,
72 
+                   ...
73 
+                   ) {
74 
+
75 
+              p <- ggtree(x, layout=layout,
76 
+                          branch.length=branch.length,
77 
+                          ndigits=ndigits, ...)
78 
+
79 
+              if (show.tip.label) {
80 
+                  p <- p + geom_tiplab(hjust = tip.label.hjust,
81 
+                                       size  = tip.label.size)
82 
+              }
83 
+              plot.codeml_mlc_(p, position, annotation,
84 
+                               annotation.size, annotation.color)
85 
+          })
86 
+
87 
+
88 
+plot.codeml_mlc_<- function(p, position, annotation=NULL,
89 
+                            annotation.size, annotation.color){
90 
+
91 
+    if (!is.null(annotation) && !is.na(annotation)) {
92 
+        p <- p + geom_text(aes_string(x=position,
93 
+                                      label = annotation),
94 
+                           size=annotation.size, vjust=-.5,
95 
+                           color = annotation.color)
96 
+    }
97 
+    p + theme_tree2()
98 
+}
99 
+
100 
+
101 
+##' @rdname get.tree-methods
102 
+##' @exportMethod get.tree
103 
+setMethod("get.tree", signature(object = "codeml_mlc"),
104 
+          function(object, ...) {
105 
+              object@phylo
106 
+          }
107 
+          )
108 
+
109 
+
110 
+
R/ggtree-package.R
History View file @ d32146c6
0 111 
new file mode 100644
... ... 
@@ -0,0 +1,8 @@
1 
+##' visualizing phylogenetic tree and heterogenous associated data based on grammar of graphics
2 
+##' \code{ggtree} provides functions for visualizing phylogenetic tree and its associated data in R.
3 
+##'
4 
+##' @docType package
5 
+##' @name ggtree
6 
+##' @aliases ggtree package-ggtree
7 
+NULL
8 
+
R/ggtree.R
History View file @ d32146c6
0 9 
new file mode 100644
... ... 
@@ -0,0 +1,205 @@
1 
+##' drawing phylogenetic tree from phylo object
2 
+##'
3 
+##'
4 
+##' @title ggtree
5 
+##' @param tr phylo object
6 
+##' @param showDistance add distance legend, logical
7 
+##' @param layout one of phylogram, dendrogram, cladogram, fan, radial and unrooted
8 
+##' @param ... additional parameter
9 
+##' @return tree
10 
+##' @importFrom ggplot2 ggplot
11 
+##' @importFrom ggplot2 xlab
12 
+##' @importFrom ggplot2 ylab
13 
+##' @importFrom ggplot2 annotate
14 
+##' @importFrom ggplot2 scale_x_reverse
15 
+##' @importFrom ggplot2 coord_flip
16 
+##' @importFrom ggplot2 coord_polar
17 
+##' @export
18 
+##' @author Yu Guangchuang
19 
+##' @examples
20 
+##' require(ape)
21 
+##' tr <- rtree(10)
22 
+##' ggtree(tr)
23 
+ggtree <- function(tr, showDistance=FALSE, layout="phylogram", ...) {
24 
+    d <- x <- y <- NULL
25 
+    if (layout == "fan") {
26 
+        layout <- "phylogram"
27 
+        type <- "fan"
28 
+    } else if (layout == "radial") {
29 
+        layout <- "cladogram"
30 
+        type <- "radial"
31 
+    } else if (layout == "dendrogram") {
32 
+        layout <- "phylogram"
33 
+        type <- "dendrogram"
34 
+    } else {
35 
+        type <- "none"
36 
+    }
37 
+    p <- ggplot(tr, aes(x, y), layout=layout, ...) + geom_tree(layout, ...) + xlab("") + ylab("") + theme_tree2()
38 
+
39 
+    if (type == "dendrogram") {
40 
+        p <- p + scale_x_reverse() + coord_flip()
41 
+    } else if (type == "fan" || type == "radial") {
42 
+        p <- p + coord_polar(theta = "y")
43 
+    }
44 
+
45 
+    if (showDistance == FALSE) {
46 
+        p <- p + theme_tree()
47 
+    }
48 
+    return(p)
49 
+}
50 
+
51 
+##' add tree layer
52 
+##'
53 
+##'
54 
+##' @title geom_tree
55 
+##' @param layout one of phylogram, cladogram
56 
+##' @param ... additional parameter
57 
+##' @return tree layer
58 
+##' @importFrom ggplot2 geom_segment
59 
+##' @importFrom ggplot2 aes
60 
+##' @export
61 
+##' @author Yu Guangchuang
62 
+##' @examples
63 
+##' require(ape)
64 
+##' tr <- rtree(10)
65 
+##' require(ggplot2)
66 
+##' ggplot(tr) + geom_tree()
67 
+geom_tree <- function(layout="phylogram", ...) {
68 
+    x <- y <- parent <- NULL
69 
+    if (layout == "phylogram") {
70 
+        geom_segment(aes(x=c(x[parent], x[parent]),
71 
+                         xend=c(x, x[parent]),
72 
+                         y=c(y, y[parent]),
73 
+                         yend=c(y, y)),...)
74 
+    } else if (layout == "cladogram" || layout == "unrooted") {
75 
+        geom_segment(aes(x=x[parent],
76 
+                         xend=x,
77 
+                         y=y[parent],
78 
+                         yend=y))
79 
+    }
80 
+}
81 
+
82 
+##' add tip label layer
83 
+##'
84 
+##'
85 
+##' @title geom_tiplab
86 
+##' @param align align tip lab or not, logical
87 
+##' @param hjust horizontal adjustment
88 
+##' @param ... additional parameter
89 
+##' @return tip label layer
90 
+##' @importFrom ggplot2 geom_text
91 
+##' @export
92 
+##' @author Yu Guangchuang
93 
+##' @examples
94 
+##' require(ape)
95 
+##' tr <- rtree(10)
96 
+##' ggtree(tr) + geom_tiplab()
97 
+geom_tiplab <- function(align=FALSE, hjust=-.25, ...) {
98 
+    x <- y <- label <- isTip <- NULL
99 
+    if (align == TRUE) {
100 
+        geom_text(aes(x=max(x), label=label), subset=.(isTip), hjust=hjust, ...)
101 
+    } else {
102 
+        geom_text(aes(label=label), subset=.(isTip), hjust=hjust, ...)
103 
+    }
104 
+}
105 
+
106 
+
107 
+
108 
+##' add horizontal align lines
109 
+##'
110 
+##'
111 
+##' @title geom_aline
112 
+##' @param linetype line type
113 
+##' @param ... additional parameter
114 
+##' @return aline layer
115 
+##' @export
116 
+##' @author Yu Guangchuang
117 
+##' @examples
118 
+##' require(ape)
119 
+##' tr <- rtree(10)
120 
+##' ggtree(tr) + geom_tiplab(align=TRUE) + geom_aline()
121 
+geom_aline <- function(linetype="dashed", ...) {
122 
+    x <- y <- isTip <- NULL
123 
+    geom_segment(aes(x=ifelse(x==max(x), x, x*1.02),
124 
+                     xend=max(x), yend=y),
125 
+                 subset=.(isTip), linetype=linetype, ...)
126 
+}
127 
+
128 
+##' add points layer of tips
129 
+##'
130 
+##'
131 
+##' @title geom_tippoint
132 
+##' @param ... additional parameter
133 
+##' @return tip point layer
134 
+##' @importFrom ggplot2 geom_point
135 
+##' @export
136 
+##' @author Yu Guangchuang
137 
+##' @examples
138 
+##' require(ape)
139 
+##' tr <- rtree(10)
140 
+##' ggtree(tr) + geom_tippoint()
141 
+geom_tippoint <- function(...) {
142 
+    isTip <- NULL
143 
+    geom_point(subset=.(isTip), ...)
144 
+}
145 
+
146 
+
147 
+##' tree theme
148 
+##'
149 
+##'
150 
+##' @title theme_tree
151 
+##' @param bgcolor background color
152 
+##' @param fgcolor foreground color
153 
+##' @importFrom ggplot2 theme_bw
154 
+##' @importFrom ggplot2 theme
155 
+##' @importFrom ggplot2 element_blank
156 
+##' @importFrom ggplot2 %+replace%
157 
+##' @export
158 
+##' @return updated ggplot object with new theme
159 
+##' @author Yu Guangchuang
160 
+##' @examples
161 
+##' require(ape)
162 
+##' tr <- rtree(10)
163 
+##' ggtree(tr) + theme_tree()
164 
+theme_tree <- function(bgcolor="white", fgcolor="black") {
165 
+    theme_tree2() %+replace%
166 
+    theme(panel.background=element_rect(fill=bgcolor, colour=bgcolor),
167 
+          axis.line.x = element_line(color=bgcolor),
168 
+          axis.text.x = element_blank(),
169 
+          axis.ticks.x = element_blank()
170 
+          )
171 
+}
172 
+
173 
+##' tree2 theme
174 
+##'
175 
+##'
176 
+##' @title theme_tree2
177 
+##' @param bgcolor background color
178 
+##' @param fgcolor foreground color
179 
+##' @importFrom ggplot2 theme_bw
180 
+##' @importFrom ggplot2 theme
181 
+##' @importFrom ggplot2 element_blank
182 
+##' @importFrom ggplot2 element_line
183 
+##' @importFrom ggplot2 %+replace%
184 
+##' @importFrom ggplot2 element_rect
185 
+##' @export
186 
+##' @return updated ggplot object with new theme
187 
+##' @author Yu Guangchuang
188 
+##' @examples
189 
+##' require(ape)
190 
+##' tr <- rtree(10)
191 
+##' ggtree(tr) + theme_tree2()
192 
+theme_tree2 <- function(bgcolor="white", fgcolor="black") {
193 
+    theme_bw() %+replace%
194 
+    theme(legend.position="none",
195 
+          panel.grid.minor=element_blank(),
196 
+          panel.grid.major=element_blank(),
197 
+          panel.background=element_rect(fill=bgcolor, colour=bgcolor),
198 
+          panel.border=element_blank(),
199 
+          axis.line=element_line(color=fgcolor),
200 
+          axis.line.y=element_line(color=bgcolor),
201 
+          axis.ticks.y=element_blank(),
202 
+          axis.text.y=element_blank()
203 
+          )
204 
+}
205 
+
R/gmerge.R
History View file @ d32146c6
0 206 
new file mode 100644
... ... 
@@ -0,0 +1,79 @@
1 
+
2 
+merge_baseml_hyphy <- function(baseml, hyphy) {
3 
+    ml_phylo <- baseml@mlc@phylo
4 
+    hy_phylo <- hyphy@phylo
5 
+    phylo_merge_check(ml_phylo, hy_phylo)
6 
+}
7 
+
8 
+
9 
+phylo_merge_check <- function(phy1, phy2) {
10 
+    if (Ntip(phy1) != Ntip(phy2)) {
11 
+        stop("Number of tip is not eqaul...")
12 
+    }
13 
+    if ( ! all(phy1$tip.label %in% phy2$tip.label)) {
14 
+        stop("tip label is not consistent...")
15 
+    }
16 
+
17 
+    if (phy1$Nnode != phy2$Nnode) {
18 
+        stop("Number of node is not eqaul...")
19 
+    }
20 
+    if (!is.null(phy1$node.label) && !is.null(phy2$node.label)) {
21 
+        n <- getNodeNum(phy1)
22 
+        node <- (Ntip(phy1)+1):n
23 
+        if (all(phy1$node.label == node) || all(phy2$node.label == node)) {
24 
+            ## nothing happend.
25 
+        } else if (any(phy1$node.label != phy2$node.label)){
26 
+            stop("node label is not consistent...")
27 
+        }
28 
+    }
29 
+
30 
+    degree1 <- table(phy1$edge[,1]) %>% sort
31 
+    degree2 <- table(phy2$edge[,1]) %>% sort
32 
+    if (length(degree1) != length(degree2)) {
33 
+        stop("node degree is not consistent...")
34 
+    } else if (!all(degree1 == degree2)) {
35 
+        stop("node degree is not consistent...")
36 
+    }
37 
+}
38 
+
39 
+
40 
+node_mapper <- function(phy1, phy2) {
41 
+   df1 <- fortify(phy1)
42 
+   df2 <- fortify(phy2)
43 
+
44 
+   df1$node2 <- NA
45 
+   df1$visited <- FALSE
46 
+   ntip <- Ntip(phy1)
47 
+   df1$node2[1:ntip] <- match(phy1$tip.label, phy2$tip.label)
48 
+
49 
+   root <- getRoot(phy1)
50 
+   currentNode <- 1:ntip
51 
+   while(any(df1$visited == FALSE)) {
52 
+       pNode <- c()
53 
+       for (i in currentNode) {
54 
+           df1[i, "visited"] <- TRUE
55 
+           j <- df1[i, "node2"]
56 
+           ip <- df1[i, "parent"]
57 
+           if (df1[ip, "visited"] == FALSE) {
58 
+               jp <- df2[j, "parent"]
59 
+               df1[ip, "node2"] <- jp
60 
+               df1[ip, "visited"] <- TRUE
61 
+           }
62 
+           pNode <- c(pNode, ip)
63 
+       }
64 
+       currentNode <- unique(pNode)
65 
+   }
66 
+
67 
+   if (df1[root, "node"] != df1[root, "node2"]) {
68 
+       stop("phylogenies not compatible...")
69 
+   }
70 
+
71 
+
72 
+   node <- df1$node
73 
+   names(node) <- df1$node2
74 
+   phy2$edge <- cbind(node[as.character(phy2$edge[,1])],
75 
+                      node[as.character(phy2$edge[,2])])
76 
+   phy2$tip.label <- phy1$tip.label
77 
+
78