Browse code

Adds ggtree/ seq2pathway/ sidap/ to the repos.

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

Marc Carlson authored on 14/01/2015 21:22:07
Showing 76 changed files

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
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)
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>
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
+         )
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
+
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
+}
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
+
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
+                        
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
+
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
+
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
+
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