Browse code

lots updates

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

Guangchuang Yu authored on 22/12/2015 04:08:02
Showing 110 changed files

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