1. ggtree
  2. Commit 7790e533be4949b88619c9fbf563317abaffdc79
Browse code

Merged changes from upstream into origin branches.

Merge remote-tracking branch 'upstream/master'

# Conflicts:
# R/geom_cladelabel.R
# R/geom_hilight.R

JustGitting authored on 12/09/2017 01:52:08
Showing 282 changed files
.Rbuildignore
History View file @ 7790e533
... ... 
@@ -9,11 +9,10 @@ Makefile
9 9 
 README.Rmd
10 10 
 mkdocs
11 11 
 docs
12 
-logo.png.github
12 
+logo.png
13 13 
 .github
14 
-<<<<<<< HEAD
15 14 
 ^.*\.Rproj$
16 15 
 ^\.Rproj\.user$
17 
-=======
18 16 
 ggtree_sticker.R
19 
->>>>>>> 6c3d0a213ebba123a58af768ef6d7b4ec93b85d1
17 
+site_src
18 
+ggtree.png
.gitignore
History View file @ 7790e533
... ... 
@@ -12,4 +12,5 @@ __init__.pyc
12 12 
 *.ignore
13 13 
 .web_cache
14 14 
 ggtree.Rproj
15 
-.Rproj.user
16 15 
\ No newline at end of file
16 
+.Rproj.user
17 
+ggtree
17 18 
\ No newline at end of file
.svnignore
History View file @ 7790e533
... ... 
@@ -6,5 +6,6 @@ appveyor.yml
6 6 
 .travis.yml
7 7 
 docs
8 8 
 mkdocs
9 
+site_src
9 10 
 .gitmodules
10 11 
 .github
CONTRIBUTING.md
History View file @ 7790e533
11 12 
new file mode 100644
... ... 
@@ -0,0 +1,67 @@
1 
+# Contribute
2 
+
3 
+## Introduction
4 
+
5 
+First, thank you for considering contributing to ggtree! It's people like you that make the open source community such a great community! 😊
6 
+
7 
+We welcome any type of contribution, not only code. You can help with
8 
+- **QA**: file bug reports, the more details you can give the better (e.g. screenshots with the console open)
9 
+- **Marketing**: writing blog posts, howto's, printing stickers, ...
10 
+- **Community**: presenting the project at meetups, organizing a dedicated meetup for the local community, ...
11 
+- **Code**: take a look at the [open issues](issues). Even if you can't write code, commenting on them, showing that you care about a given issue matters. It helps us triage them.
12 
+- **Money**: we welcome financial contributions in full transparency on our [open collective](https://opencollective.com/ggtree).
13 
+
14 
+## Your First Contribution
15 
+
16 
+Working on your first Pull Request? You can learn how from this *free* series, [How to Contribute to an Open Source Project on GitHub](https://egghead.io/series/how-to-contribute-to-an-open-source-project-on-github).
17 
+
18 
+## Submitting code
19 
+
20 
+Any code change should be submitted as a pull request. The description should explain what the code does and give steps to execute it. The pull request should also contain tests.
21 
+
22 
+## Code review process
23 
+
24 
+The bigger the pull request, the longer it will take to review and merge. Try to break down large pull requests in smaller chunks that are easier to review and merge.
25 
+It is also always helpful to have some context for your pull request. What was the purpose? Why does it matter to you?
26 
+
27 
+## Financial contributions
28 
+
29 
+We also welcome financial contributions in full transparency on our [open collective](https://opencollective.com/ggtree).
30 
+Anyone can file an expense. If the expense makes sense for the development of the community, it will be "merged" in the ledger of our open collective by the core contributors and the person who filed the expense will be reimbursed.
31 
+
32 
+## Questions
33 
+
34 
+If you have any questions, create an [issue](issue) (protip: do a quick search first to see if someone else didn't ask the same question before!).
35 
+You can also reach us at hello@ggtree.opencollective.com.
36 
+
37 
+## Credits
38 
+
39 
+### Contributors
40 
+
41 
+Thank you to all the people who have already contributed to ggtree!
42 
+<a href="graphs/contributors"><img src="https://opencollective.com/ggtree/contributors.svg?width=890" /></a>
43 
+
44 
+
45 
+### Backers
46 
+
47 
+Thank you to all our backers! [[Become a backer](https://opencollective.com/ggtree#backer)]
48 
+
49 
+<a href="https://opencollective.com/ggtree#backers" target="_blank"><img src="https://opencollective.com/ggtree/backers.svg?width=890"></a>
50 
+
51 
+
52 
+### Sponsors
53 
+
54 
+Thank you to all our sponsors! (please ask your company to also support this open source project by [becoming a sponsor](https://opencollective.com/ggtree#sponsor))
55 
+
56 
+<a href="https://opencollective.com/ggtree/sponsor/0/website" target="_blank"><img src="https://opencollective.com/ggtree/sponsor/0/avatar.svg"></a>
57 
+<a href="https://opencollective.com/ggtree/sponsor/1/website" target="_blank"><img src="https://opencollective.com/ggtree/sponsor/1/avatar.svg"></a>
58 
+<a href="https://opencollective.com/ggtree/sponsor/2/website" target="_blank"><img src="https://opencollective.com/ggtree/sponsor/2/avatar.svg"></a>
59 
+<a href="https://opencollective.com/ggtree/sponsor/3/website" target="_blank"><img src="https://opencollective.com/ggtree/sponsor/3/avatar.svg"></a>
60 
+<a href="https://opencollective.com/ggtree/sponsor/4/website" target="_blank"><img src="https://opencollective.com/ggtree/sponsor/4/avatar.svg"></a>
61 
+<a href="https://opencollective.com/ggtree/sponsor/5/website" target="_blank"><img src="https://opencollective.com/ggtree/sponsor/5/avatar.svg"></a>
62 
+<a href="https://opencollective.com/ggtree/sponsor/6/website" target="_blank"><img src="https://opencollective.com/ggtree/sponsor/6/avatar.svg"></a>
63 
+<a href="https://opencollective.com/ggtree/sponsor/7/website" target="_blank"><img src="https://opencollective.com/ggtree/sponsor/7/avatar.svg"></a>
64 
+<a href="https://opencollective.com/ggtree/sponsor/8/website" target="_blank"><img src="https://opencollective.com/ggtree/sponsor/8/avatar.svg"></a>
65 
+<a href="https://opencollective.com/ggtree/sponsor/9/website" target="_blank"><img src="https://opencollective.com/ggtree/sponsor/9/avatar.svg"></a>
66 
+
67 
+<!-- This `CONTRIBUTING.md` is based on @nayafia's template https://github.com/nayafia/contributing-template -->
0 68 
\ No newline at end of file
DESCRIPTION
History View file @ 7790e533
... ... 
@@ -2,7 +2,7 @@ Package: ggtree
2 2 
 Type: Package
3 3 
 Title: an R package for visualization and annotation of phylogenetic trees with
4 4 
     their covariates and other associated data
5 
-Version: 1.9.1
5 
+Version: 1.9.4
6 6 
 Authors@R: c(
7 7 
 	   person("Guangchuang", "Yu", email = "guangchuangyu@gmail.com", role = c("aut", "cre", "cph")),
8 8 
 	   person("Tommy Tsan-Yuk", "Lam", email = "tylam.tommy@gmail.com", rol = c("aut", "ths")),
Makefile
History View file @ 7790e533
... ... 
@@ -4,7 +4,7 @@ PKGSRC  := $(shell basename `pwd`)
4 4
5 5 
 all: rd readme check clean
6 6
7 
-alldocs: rd readme mkdocs
7 
+alldocs: site rd readme
8 8
9 9 
 rd:
10 10 
 	Rscript -e 'roxygen2::roxygenise(".")'
... ... 
@@ -44,7 +44,15 @@ clean:
44 44 
 	cd ..;\
45 45 
 	$(RM) -r $(PKGNAME).Rcheck/
46 46
47 
-site: mkdocs
47 
+site:
48 
+	cd site_src;\
49 
+	ln -s ../../software/themes themes;\
50 
+	Rscript -e 'blogdown::build_site()';\
51 
+	rm themes;\
52 
+	cd ..
53 
+
54 
+preview:
55 
+	Rscript -e 'setwd("site_src"); blogdown::serve_site()'
48 56
49 57 
 mkdocs: mdfiles
50 58 
 	cd mkdocs;\
... ... 
@@ -70,3 +78,28 @@ svncommit:
70 78 
 	git push -u origin devel;\
71 79 
 	git checkout master;\
72 80 
 	git merge devel
81 
+
82 
+
83 
+gitmaintain:
84 
+	git gc --auto;\
85 
+	git prune -v;\
86 
+	git fsck --full
87 
+
88 
+
89 
+pushX:
90 
+	git push -u origin master;\
91 
+	git checkout bioc;\
92 
+	git pull;\
93 
+	git merge master;\
94 
+	git push upstream master;\
95 
+	git checkout master
96 
+
97 
+update:
98 
+	git fetch --all;\
99 
+	git checkout master;\
100 
+	git merge upstream/master;\
101 
+	git merge origin/master
102 
+
103 
+push: update
104 
+	git push upstream master;\
105 
+	git push origin master
NAMESPACE
History View file @ 7790e533
... ... 
@@ -49,6 +49,7 @@ export(geom_cladelabel2)
49 49 
 export(geom_hilight)
50 50 
 export(geom_hilight_encircle)
51 51 
 export(geom_label2)
52 
+export(geom_motif)
52 53 
 export(geom_nodepoint)
53 54 
 export(geom_point2)
54 55 
 export(geom_range)
... ... 
@@ -89,6 +90,7 @@ export(rotate_tree)
89 90 
 export(scaleClade)
90 91 
 export(scale_color)
91 92 
 export(scale_x_ggtree)
93 
+export(set_hilight_legend)
92 94 
 export(stat_balance)
93 95 
 export(stat_chull)
94 96 
 export(stat_hilight)
NEWS
History View file @ 7790e533
... ... 
@@ -1,3 +1,27 @@
1 
+CHANGES IN VERSION 1.9.4
2 
+------------------------
3 
+ o set_hilight_legend <2017-08-30, Wed>
4 
+ o geom_motif for aligned motif <2017-08-22, Tue>
5 
+   + https://github.com/GuangchuangYu/ggtree/issues/148
6 
+ o fixed `R CMD build` error: cannot stat 'ggtree/site_src/themes': No such file or directory <2017-08-22, Tue>
7 
+
8 
+CHANGES IN VERSION 1.9.3
9 
+------------------------
10 
+ o update to using !! in tidyr::gather for compatible with tidyr 0.7.0 <2017-08-03, Thu>
11 
+ o now geom_text2, geom_label2, geom_point2 and geom_segment2 work with ggplot2 <2017-08-01, Tue>
12 
+ o update fortify.jplace to support number of placement (nplace) <2017-07-27, Thu>
13 
+
14 
+CHANGES IN VERSION 1.9.2
15 
+------------------------
16 
+ o add bg_line and height parameter in msaplot <2017-07-26, Wed>
17 
+   + use can set bg_line = FALSE and height = 1 to plot more beautiful alignment
18 
+ o extend parameter in geom_cladebar <2017-07-26, Wed>
19 
+   + https://github.com/GuangchuangYu/ggtree/issues/142#issuecomment-317817995
20 
+ o scaleClade works after calling viewClade <2017-07-20, Thu>
21 
+   + https://groups.google.com/forum/?utm_medium=email&utm_source=footer#!topic/bioc-ggtree/QVSryszPaFY
22 
+ o gheatmap support handling collapsed tree <2017-06-29, Thu>
23 
+   + https://github.com/GuangchuangYu/ggtree/issues/137
24 
+
1 25 
 CHANGES IN VERSION 1.9.1
2 26 
 ------------------------
3 27 
  o now mapping parameter will passed to segment layer in geom_tiplab(align=T) <2017-06-19, Mon>
R/clade-functions.R
History View file @ 7790e533
... ... 
@@ -42,10 +42,18 @@ viewClade <- function(tree_view=NULL, node, xmax_adjust=0) {
42 42 
     cpos <- get_clade_position(tree_view, node=node)
43 43 
     xmax <- ggplot_build(tree_view)$layout$panel_ranges[[1]]$x.range[2]
44 44
45 
+    attr(tree_view, 'viewClade') <- TRUE
46 
+    attr(tree_view, 'viewClade_node') <- node
47 
+
45 48 
     ## tree_view+xlim(cpos$xmin, xmax + xmax_adjust) + ylim(cpos$ymin, cpos$ymax)
46 49 
     tree_view + coord_cartesian(xlim=c(cpos$xmin, xmax), ylim=c(cpos$ymin, cpos$ymax), expand=FALSE)
47 50 
 }
48 51
52 
+is.viewClade <- function(tree_view) {
53 
+    x <- attr(tree_view, 'viewClade')
54 
+    !is.null(x) && x
55 
+}
56 
+
49 57
50 58
51 59 
 ##' collapse a clade
... ... 
@@ -298,10 +306,18 @@ scaleClade <- function(tree_view=NULL, node, scale=1, vertical_only=TRUE) {
298 306 
     df <- calculate_branch_mid(df)
299 307
300 308 
     tree_view$data <- calculate_angle(df)
309 
+
310 
+
311 
+    if (is.viewClade(tree_view)) {
312 
+        vc_node <- attr(tree_view, 'viewClade_node')
313 
+        tree_view <- viewClade(tree_view, vc_node)
314 
+    }
315 
+
301 316 
     tree_view
302 317 
 }
303 318
304 319
320 
+
305 321 
 reassign_y_from_node_to_root <- function(df, node) {
306 322 
     root <- which(df$node == df$parent)
307 323 
     pp <- df[node, "parent"]
R/experimental_function.R
History View file @ 7790e533
... ... 
@@ -1,3 +1,37 @@
1 
+##' geom layer to draw aligned motif
2 
+##'
3 
+##'
4 
+##' @title geom_motif
5 
+##' @param mapping aes mapping
6 
+##' @param data data
7 
+##' @param on gene to center (i.e. set middle position of the `on` gene to 0)
8 
+##' @param ... additional parameters
9 
+##' @return geom layer
10 
+##' @export
11 
+##' @author guangchuang yu
12 
+geom_motif <- function(mapping, data, on, ...) {
13 
+    if (is.null(unlist(mapping)$y)) {
14 
+        seqnames <- as.character(unlist(mapping)$group)
15 
+    } else {
16 
+        seqnames <- as.character(unlist(mapping)$y)
17 
+    }
18 
+
19 
+    if (is.null(unlist(mapping$fill))) {
20 
+        id <- as.character(unlist(mapping$id))
21 
+    } else {
22 
+        id <- as.character(unlist(mapping$fill))
23 
+    }
24 
+    dd <- data[unlist(data[, id]) == on,]
25 
+    mid <- dd$start + (dd$end - dd$start)/2
26 
+    names(mid) <- as.character(unlist(dd[, seqnames]))
27 
+    adj <- mid[as.character(unlist(data[, seqnames]))]
28 
+    data$start <- data$start - adj
29 
+    data$end <- data$end - adj
30 
+    geom_gene_arrow <- get_fun_from_pkg("gggenes", "geom_gene_arrow")
31 
+    geom_gene_arrow(mapping = mapping, data = as.data.frame(data), ...)
32 
+}
33 
+
34 
+
1 35 
 plot_fantree <- function(fantree, upper=TRUE) {
2 36 
     if (upper) {
3 37 
         ymin <- -.25
... ... 
@@ -226,4 +260,18 @@ coplot <- function(tree1, tree2, hjust=0) {
226 260
227 261
228 262
229 
-
263 
+##' set legend for multiple geom_hilight layers
264 
+##'
265 
+##'
266 
+##' @title set_hilight_legend
267 
+##' @param p ggtree object
268 
+##' @param color color vector
269 
+##' @param label label vector
270 
+##' @return updated ggtree object
271 
+##' @export
272 
+##' @author guangchuang yu
273 
+set_hilight_legend <- function(p, color, label) {
274 
+	d <- data.frame(color=color, clade=label, x=0, y=1)
275 
+	p + geom_rect(aes_(fill=~clade, xmin=~x, xmax=~x, ymin=~y, ymax=~y), data=d, inherit.aes=F) +
276 
+		guides(fill=guide_legend(override.aes=list(fill=d$color)))
277 
+}
R/geom_cladelabel.R
History View file @ 7790e533
... ... 
@@ -6,6 +6,7 @@
6 6 
 ##' @param label clade label
7 7 
 ##' @param offset offset of bar and text from the clade
8 8 
 ##' @param offset.text offset of text from bar
9 
+##' @param extend extend bar height
9 10 
 ##' @param align logical
10 11 
 ##' @param barsize size of bar
11 12 
 ##' @param fontsize size of text
... ... 
@@ -20,11 +21,21 @@
20 21 
 ##' @return ggplot layers
21 22 
 ##' @export
22 23 
 ##' @author Guangchuang Yu
23 
-geom_cladelabel <- function(node, label, offset=0, offset.text=0,
24 
-                            align=FALSE, barsize=0.5, fontsize=3.88,
25 
-                            angle=0, geom="text", hjust = 0,
26 
-                            color = NULL, fill=NA,
27 
-                            family="sans", parse=FALSE, ...) {
24 
+geom_cladelabel <- function(node, label,
25 
+                            offset      = 0,
26 
+                            offset.text = 0,
27 
+                            extend      = 0,
28 
+                            align       = FALSE,
29 
+                            barsize     = 0.5,
30 
+                            fontsize    = 3.88,
31 
+                            angle       = 0,
32 
+                            geom        = "text",
33 
+                            hjust       = 0,
34 
+                            color       = NULL,
35 
+                            fill        = NA,
36 
+                            family      = "sans",
37 
+                            parse       = FALSE,
38 
+                            ...) {
28 39 
     mapping <- NULL
29 40 
     data <- NULL
30 41 
     position <- "identity"
... ... 
@@ -73,7 +84,7 @@ geom_cladelabel <- function(node, label, offset=0, offset.text=0,
73 84 
         }
74 85
75 86 
         layer_bar <- stat_cladeBar(node=node, offset=offset, align=align,
76 
-                                   size=barsize,
87 
+                                   size=barsize, extend = extend,
77 88 
                                    mapping=mapping, data=data,
78 89 
                                    position=position, show.legend = show.legend,
79 90 
                                    inherit.aes = inherit.aes, na.rm=na.rm, ...)
... ... 
@@ -94,13 +105,21 @@ geom_cladelabel <- function(node, label, offset=0, offset.text=0,
94 105 
                                         inherit.aes = inherit.aes, na.rm=na.rm,
95 106 
                                         parse = parse,  ...)
96 107 
         }
97 
-
98 
-      layer_bar <- stat_cladeBar(node=node, offset=offset, align=align,
99 
-                                 size=barsize, color = barcolor,
100 
-                                 mapping=mapping, data=data,
101 
-                                 position=position, show.legend = show.legend,
102 
-                                 inherit.aes = inherit.aes, na.rm=na.rm, ...)
103 
-
108 
+
109 
+        layer_bar <- stat_cladeBar(node        = node,
110 
+                                   offset      = offset,
111 
+                                   align       = align,
112 
+                                   size        = barsize,
113 
+                                   color       = barcolor,
114 
+                                   extend      = extend,
115 
+                                   mapping     = mapping,
116 
+                                   data        = data,
117 
+                                   position    = position,
118 
+                                   show.legend = show.legend,
119 
+                                   inherit.aes = inherit.aes,
120 
+                                   na.rm       = na.rm, ...)
121 
+
122 
+
104 123 
     }
105 124
106 125 
     list(
... ... 
@@ -110,11 +129,11 @@ geom_cladelabel <- function(node, label, offset=0, offset.text=0,
110 129 
 }
111 130
112 131
113 
-stat_cladeText <- function(mapping=NULL, data=NULL,
114 
-                           geom="text", position="identity",
132 
+stat_cladeText <- function(mapping = NULL, data = NULL,
133 
+                           geom = "text", position = "identity",
115 134 
                            node, label, offset, align, ..., angle,
116 
-                           show.legend=NA, inherit.aes=FALSE,
117 
-                           na.rm=FALSE, parse=FALSE) {
135 
+                           show.legend = NA, inherit.aes = FALSE,
136 
+                           na.rm = FALSE, parse = FALSE) {
118 137
119 138 
     default_aes <- aes_(x=~x, y=~y, node=~node, parent=~parent, angle=~angle)
120 139 
     if (is.null(mapping)) {
... ... 
@@ -123,14 +142,14 @@ stat_cladeText <- function(mapping=NULL, data=NULL,
123 142 
         mapping <- modifyList(mapping, default_aes)
124 143 
     }
125 144
126 
-    layer(stat=StatCladeText,
127 
-          data=data,
128 
-          mapping=mapping,
129 
-          geom=geom,
130 
-          position=position,
145 
+    layer(stat = StatCladeText,
146 
+          data = data,
147 
+          mapping = mapping,
148 
+          geom = geom,
149 
+          position = position,
131 150 
           show.legend = show.legend,
132 151 
           inherit.aes = inherit.aes,
133 
-          params=list(node=node,
152 
+          params=list(node   = node,
134 153 
                       label  = label,
135 154 
                       offset = offset,
136 155 
                       align  = align,
... ... 
@@ -146,29 +165,32 @@ stat_cladeText <- function(mapping=NULL, data=NULL,
146 165
147 166 
 stat_cladeBar <- function(mapping=NULL, data=NULL,
148 167 
                           geom="segment", position="identity",
149 
-                          node, offset, align,  ...,
168 
+                          node, offset, align, extend,  ...,
150 169 
                           show.legend=NA, inherit.aes=FALSE, na.rm=FALSE) {
151 
-  default_aes <- aes_(x=~x, y=~y, node=~node, parent=~parent, xend=~x, yend=~y)
152 
-  if (is.null(mapping)) {
153 
-    mapping <- default_aes
154 
-  } else {
155 
-    mapping <- modifyList(mapping, default_aes)
156 
-  }
170 
+
157 171
158 
-  layer(stat=StatCladeBar,
159 
-        data=data,
160 
-        mapping=mapping,
161 
-        geom=geom,
162 
-        position=position,
163 
-        show.legend = show.legend,
164 
-        inherit.aes = inherit.aes,
165 
-        params=list(node=node,
166 
-                    offset=offset,
167 
-                    align=align,
168 
-                    na.rm=na.rm,
169 
-                    ...),
170 
-        check.aes = FALSE
171 
-  )
172 
+    default_aes <- aes_(x=~x, y=~y, node=~node, parent=~parent, xend=~x, yend=~y)
173 
+    if (is.null(mapping)) {
174 
+        mapping <- default_aes
175 
+    } else {
176 
+        mapping <- modifyList(mapping, default_aes)
177 
+    }
178 
+
179 
+    layer(stat = StatCladeBar,
180 
+          data = data,
181 
+          mapping = mapping,
182 
+          geom = geom,
183 
+          position = position,
184 
+          show.legend = show.legend,
185 
+          inherit.aes = inherit.aes,
186 
+          params = list(node = node,
187 
+                      offset = offset,
188 
+                      extend = extend,
189 
+                      align  = align,
190 
+                      na.rm  = na.rm,
191 
+                      ...),
192 
+          check.aes = FALSE
193 
+          )
172 194 
 }
173 195
174 196 
 StatCladeText <- ggproto("StatCladeText", Stat,
... ... 
@@ -182,15 +204,15 @@ StatCladeText <- ggproto("StatCladeText", Stat,
182 204 
                          )
183 205
184 206 
 StatCladeBar <- ggproto("StatCladBar", Stat,
185 
-                        compute_group = function(self, data, scales, params, node, offset, align) {
186 
-                          get_cladelabel_position(data, node, offset, align, adjustRatio=1.02, angle=0)
207 
+                        compute_group = function(self, data, scales, params, node, offset, align, extend) {
208 
+                            get_cladelabel_position(data, node, offset, align, adjustRatio=1.02, angle=0, extend=extend)
187 209 
                         },
188 210 
                         required_aes = c("x", "y", "xend", "yend")
189 211 
 )
190 212
191 213
192 
-get_cladelabel_position <- function(data, node, offset, align, adjustRatio, angle="auto") {
193 
-    df <- get_cladelabel_position_(data, node, angle)
214 
+get_cladelabel_position <- function(data, node, offset, align, adjustRatio, angle="auto", extend=0) {
215 
+    df <- get_cladelabel_position_(data, node, angle, extend)
194 216 
     if (align) {
195 217 
         # Find max x value for all tree nodes so all clade labels align to same position.
196 218 
         mx <- max(data$x, na.rm=TRUE)
... ... 
@@ -204,12 +226,13 @@ get_cladelabel_position <- function(data, node, offset, align, adjustRatio, angl
204 226 
     ## }
205 227
206 228 
     mx <- mx * adjustRatio + offset
207 
-
229 
+
208 230 
     data.frame(x=mx, xend=mx, y=df$y, yend=df$yend, angle=angle)
209 231 
 }
210 232
211 
-  # get x, y and yend of clade region.
212 
-get_cladelabel_position_ <- function(data, node, angle="auto") {
233 
+# get x, y and yend of clade region.
234 
+get_cladelabel_position_ <- function(data, node, angle = "auto", extend = 0) {
235 
+
213 236 
     sp <- get.offspring.df(data, node)
214 237 
     sp2 <- c(sp, node)
215 238 
     sp.df <- data[match(sp2, data$node),]
... ... 
@@ -218,7 +241,7 @@ get_cladelabel_position_ <- function(data, node, angle="auto") {
218 241 
     y <- y[!is.na(y)]
219 242 
     mx <- max(sp.df$x, na.rm=TRUE)
220 243
221 
-    d <- data.frame(x=mx, y=min(y), yend=max(y))
244 
+    d <- data.frame(x=mx, y=min(y) - extend, yend=max(y) + extend)
222 245 
     if (missing(angle))
223 246 
         return(d)
224 247
... ... 
@@ -227,6 +250,7 @@ get_cladelabel_position_ <- function(data, node, angle="auto") {
227 250 
     } else {
228 251 
         d$angle <- angle
229 252 
     }
253 
+
230 254 
     return(d)
231 255
232 256 
 }
R/geom_hilight.R
History View file @ 7790e533
... ... 
@@ -131,27 +131,27 @@ get_clade_position <- function(treeview, node) {
131 131 
 }
132 132
133 133 
 get_clade_position_ <- function(data, node) {
134 
-  sp <- tryCatch(get.offspring.df(data, node), error=function(e) NULL)
135 
-
136 
-  i <- match(node, data$node)
137 
-  if (is.null(sp)) {
138 
-    ## tip
139 
-    sp.df <- data[i,]
140 
-  } else {
141 
-    sp <- c(sp, node)
142 
-    sp.df <- data[match(sp, data$node),]
143 
-  }
144 
-
145 
-  x <- sp.df$x
146 
-  y <- sp.df$y
147 
-
148 
-  if ("branch.length" %in% colnames(data)) {
149 
-    xmin <- min(x)-data[i, "branch.length"]/2
150 
-  } else {
151 
-    xmin <- min(sp.df$branch)
152 
-  }
153 
-  data.frame(xmin=xmin,
154 
-             xmax=max(x),
155 
-             ymin=min(y)-0.5,
156 
-             ymax=max(y)+0.5)
134 
+    sp <- tryCatch(get.offspring.df(data, node), error=function(e) NULL)
135 
+
136 
+    i <- match(node, data$node)
137 
+    if (is.null(sp)) {
138 
+        ## tip
139 
+        sp.df <- data[i,]
140 
+    } else {
141 
+        sp <- c(sp, node)
142 
+        sp.df <- data[match(sp, data$node),]
143 
+    }
144 
+
145 
+    x <- sp.df$x
146 
+    y <- sp.df$y
147 
+
148 
+    if ("branch.length" %in% colnames(data)) {
149 
+        xmin <- min(x, na.rm=TRUE)-data[i, "branch.length"]/2
150 
+    } else {
151 
+        xmin <- min(sp.df$branch, na.rm=TRUE)
152 
+    }
153 
+    data.frame(xmin=xmin,
154 
+               xmax=max(x, na.rm=TRUE),
155 
+               ymin=min(y, na.rm=TRUE) - 0.5,
156 
+               ymax=max(y, na.rm=TRUE) + 0.5)
157 157 
 }
R/geom_label.R
History View file @ 7790e533
... ... 
@@ -6,6 +6,7 @@
6 6 
 ##' @param data A layer specific dataset -
7 7 
 ##'             only needed if you want to override the plot defaults.
8 8 
 ##' @param ... other arguments passed on to 'layer'
9 
+##' @param stat Name of stat to modify data
9 10 
 ##' @param position The position adjustment to use for overlapping points on this layer
10 11 
 ##' @param family sans by default, can be any supported font
11 12 
 ##' @param parse if TRUE, the labels will be passd into expressions
... ... 
@@ -26,6 +27,7 @@
26 27 
 ##' @author Guangchuang Yu
27 28 
 geom_label2 <- function(mapping = NULL, data = NULL,
28 29 
                         ...,
30 
+                        stat = "identity",
29 31 
                         position = "identity",
30 32 
                         family = "sans",
31 33 
                         parse = FALSE,
... ... 
@@ -46,7 +48,7 @@ geom_label2 <- function(mapping = NULL, data = NULL,
46 48 
         position <- position_nudge(nudge_x, nudge_y)
47 49 
     }
48 50
49 
-    default_aes <- aes_(node=~node)
51 
+    default_aes <- aes_() #node=~node)
50 52 
     if (is.null(mapping)) {
51 53 
         mapping <- default_aes
52 54 
     } else {
... ... 
@@ -65,7 +67,7 @@ geom_label2 <- function(mapping = NULL, data = NULL,
65 67 
     layer(
66 68 
         data = data,
67 69 
         mapping = mapping,
68 
-        stat = StatTreeData,
70 
+        stat = stat,
69 71 
         geom = GeomLabelGGtree,
70 72 
         position = position,
71 73 
         show.legend = show.legend,
... ... 
@@ -90,24 +92,24 @@ GeomLabelGGtree <- ggproto("GeomLabelGGtree", GeomLabel,
90 92 
                                if (is.null(data$subset))
91 93 
                                    return(data)
92 94 
                                data[which(data$subset),]
93 
-                           },
94 
-                           draw_panel = function(self, data, panel_scales, coord, parse = FALSE,
95 
-                                                 na.rm = FALSE,
96 
-                                                 label.padding = unit(0.25, "lines"),
97 
-                                                 label.r = unit(0.15, "lines"),
98 
-                                                 label.size = 0.25) {
99 
-                               GeomLabel$draw_panel(data, panel_scales, coord, parse,
100 
-                                                   na.rm, label.padding, label.r, label.size)
101 
-                           },
102 
-                           required_aes = c("node", "x", "y", "label"),
95 
+                           }## ,
96 
+                           ## draw_panel = function(self, data, panel_scales, coord, parse = FALSE,
97 
+                           ##                       na.rm = FALSE,
98 
+                           ##                       label.padding = unit(0.25, "lines"),
99 
+                           ##                       label.r = unit(0.15, "lines"),
100 
+                           ##                       label.size = 0.25) {
101 
+                           ##     GeomLabel$draw_panel(data, panel_scales, coord, parse,
102 
+                           ##                         na.rm, label.padding, label.r, label.size)
103 
+                           ## },
104 
+                           ## required_aes = c("x", "y", "label"),
103 105
104 
-                           default_aes = aes(
105 
-                               colour = "black", fill = "white", size = 3.88, angle = 0,
106 
-                               hjust = 0.5, vjust = 0.5, alpha = NA, family = "", fontface = 1,
107 
-                               lineheight = 1.2
108 
-                           ),
106 
+                           ## default_aes = aes(
107 
+                           ##     colour = "black", fill = "white", size = 3.88, angle = 0,
108 
+                           ##     hjust = 0.5, vjust = 0.5, alpha = NA, family = "", fontface = 1,
109 
+                           ##     lineheight = 1.2
110 
+                           ## ),
109 111
110 
-                           draw_key = draw_key_label
112 
+                           ## draw_key = draw_key_label
111 113 
                            )
112 114
113 115
R/geom_point.R
History View file @ 7790e533
... ... 
@@ -10,14 +10,13 @@
10 10 
 geom_tippoint <- function(mapping = NULL, data = NULL,
11 11 
                        position = "identity", na.rm = FALSE,
12 12 
                           show.legend = NA, inherit.aes = TRUE, ...) {
13 
-    isTip <- NULL
14 
-    self_mapping <- aes(subset = isTip)
13 
+    self_mapping <- aes_(node = ~node, subset = ~isTip)
15 14 
     if (is.null(mapping)) {
16 15 
         mapping <- self_mapping
17 16 
     } else {
18 17 
         mapping <- modifyList(self_mapping, mapping)
19 18 
     }
20 
-    geom_point2(mapping, data, position, na.rm, show.legend, inherit.aes, ...)
19 
+    geom_point2(mapping, data, position, na.rm, show.legend, inherit.aes, stat = StatTreeData, ...)
21 20 
 }
22 21
23 22 
 ## angle is not supported,
... ... 
@@ -52,14 +51,14 @@ geom_tippoint <- function(mapping = NULL, data = NULL,
52 51 
 geom_nodepoint <- function(mapping = NULL, data = NULL,
53 52 
                        position = "identity", na.rm = FALSE,
54 53 
                        show.legend = NA, inherit.aes = TRUE, ...) {
55 
-    isTip <- NULL
56 
-    self_mapping <- aes(subset = !isTip)
54 
+    node <- isTip <- NULL
55 
+    self_mapping <- aes(node = node, subset = !isTip)
57 56 
     if (is.null(mapping)) {
58 57 
         mapping <- self_mapping
59 58 
     } else {
60 59 
         mapping %<>% modifyList(self_mapping)
61 60 
     }
62 
-    geom_point2(mapping, data, position, na.rm, show.legend, inherit.aes, ...)
61 
+    geom_point2(mapping, data, position, na.rm, show.legend, inherit.aes, stat = StatTreeData, ...)
63 62 
 }
64 63
65 64
... ... 
@@ -75,13 +74,13 @@ geom_rootpoint <- function(mapping = NULL, data = NULL,
75 74 
                            position = "identity", na.rm = FALSE,
76 75 
                            show.legend = NA, inherit.aes = TRUE, ...) {
77 76 
     isTip <- node <- parent <- NULL
78 
-    self_mapping <- aes(subset = (node == parent))
77 
+    self_mapping <- aes(node = node, subset = (node == parent))
79 78 
     if (is.null(mapping)) {
80 79 
         mapping <- self_mapping
81 80 
     } else {
82 81 
         mapping %<>% modifyList(self_mapping)
83 82 
     }
84 
-    geom_point2(mapping, data, position, na.rm, show.legend, inherit.aes, ...)
83 
+    geom_point2(mapping, data, position, na.rm, show.legend, inherit.aes, stat = StatTreeData, ...)
85 84 
 }
86 85
87 86
... ... 
@@ -91,6 +90,7 @@ geom_rootpoint <- function(mapping = NULL, data = NULL,
91 90 
 ##' @title geom_point2
92 91 
 ##' @param mapping aes mapping
93 92 
 ##' @param data data
93 
+##' @param stat Name of stat to modify data
94 94 
 ##' @param position position
95 95 
 ##' @param na.rm logical
96 96 
 ##' @param show.legend logical
... ... 
@@ -102,12 +102,12 @@ geom_rootpoint <- function(mapping = NULL, data = NULL,
102 102 
 ##' \link[ggplot2]{geom_point}
103 103 
 ##' @return point layer
104 104 
 ##' @author Guangchuang Yu
105 
-geom_point2 <- function(mapping = NULL, data = NULL,
105 
+geom_point2 <- function(mapping = NULL, data = NULL, stat = "identity",
106 106 
                        position = "identity", na.rm = FALSE,
107 107 
                        show.legend = NA, inherit.aes = TRUE, ...) {
108 108
109 109
110 
-    default_aes <- aes_(node=~node)
110 
+    default_aes <- aes_() # node=~node)
111 111 
     if (is.null(mapping)) {
112 112 
         mapping <- default_aes
113 113 
     } else {
... ... 
@@ -117,7 +117,7 @@ geom_point2 <- function(mapping = NULL, data = NULL,
117 117 
     layer(
118 118 
         data = data,
119 119 
         mapping = mapping,
120 
-        stat = StatTreeData,
120 
+        stat = stat,
121 121 
         geom = GeomPointGGtree,
122 122 
         position = position,
123 123 
         show.legend = show.legend,
R/geom_segment.R
History View file @ 7790e533
... ... 
@@ -18,7 +18,7 @@ geom_aline <- function(mapping=NULL, linetype="dotted", size=1, ...) {
18 18
19 19 
     geom_segment2(dot_mapping,
20 20 
                   linetype=linetype,
21 
-                  size=size, ...)
21 
+                  size=size, stat = StatTreeData, ...)
22 22 
 }
23 23
24 24
... ... 
@@ -29,6 +29,7 @@ geom_aline <- function(mapping=NULL, linetype="dotted", size=1, ...) {
29 29 
 ##' @title geom_segment2
30 30 
 ##' @param mapping aes mapping
31 31 
 ##' @param data data
32 
+##' @param stat Name of stat to modify data
32 33 
 ##' @param position position
33 34 
 ##' @param arrow arrow
34 35 
 ##' @param lineend lineend
... ... 
@@ -42,7 +43,7 @@ geom_aline <- function(mapping=NULL, linetype="dotted", size=1, ...) {
42 43 
 ##' \link[ggplot2]{geom_segment}
43 44 
 ##' @return add segment layer
44 45 
 ##' @author Guangchuang Yu
45 
-geom_segment2 <- function(mapping = NULL, data = NULL,
46 
+geom_segment2 <- function(mapping = NULL, data = NULL, stat = "identity",
46 47 
                          position = "identity", arrow = NULL, lineend = "butt",
47 48 
                          na.rm = FALSE, show.legend = NA, inherit.aes = TRUE,
48 49 
                          ...) {
... ... 
@@ -57,7 +58,7 @@ geom_segment2 <- function(mapping = NULL, data = NULL,
57 58 
     layer(
58 59 
         data = data,
59 60 
         mapping = mapping,
60 
-        stat = StatTreeData,
61 
+        stat = stat,
61 62 
         geom = GeomSegmentGGtree,
62 63 
         position = position,
63 64 
         show.legend = show.legend,
... ... 
@@ -79,19 +80,21 @@ GeomSegmentGGtree <- ggproto("GeomSegmentGGtree", GeomSegment,
79 80 
                                  if (is.null(data$subset))
80 81 
                                      return(data)
81 82 
                                  data[which(data$subset),]
82 
-                             },
83 
+                             }
83 84
84 
-                             draw_panel = function(data, panel_scales, coord, arrow = NULL,
85 
-                                                   lineend = "butt", na.rm = FALSE) {
85 
+                            ## ,
86 86
87 
-                                 GeomSegment$draw_panel(data, panel_scales, coord, arrow,
88 
-                                                        lineend, na.rm)
89 
-                             },
87 
+                            ##  draw_panel = function(data, panel_scales, coord, arrow = NULL,
88 
+                            ##                        lineend = "butt", na.rm = FALSE) {
90 89
91 
-                             required_aes = c("x", "y", "xend", "yend"),
92 
-                             default_aes = aes(colour = "black", size = 0.5, linetype = 1, alpha = NA),
90 
+                            ##      GeomSegment$draw_panel(data, panel_scales, coord, arrow,
91 
+                            ##                             lineend, na.rm)
92 
+                            ##  },
93 93
94 
-                             draw_key = draw_key_path
94 
+                            ##  required_aes = c("x", "y", "xend", "yend"),
95 
+                            ##  default_aes = aes(colour = "black", size = 0.5, linetype = 1, alpha = NA),
96 
+
97 
+                            ##  draw_key = draw_key_path
95 98 
                              )
96 99
97 100
R/geom_text.R
History View file @ 7790e533
... ... 
@@ -6,6 +6,7 @@
6 6 
 ##' @param data A layer specific dataset -
7 7 
 ##'             only needed if you want to override he plot defaults.
8 8 
 ##' @param ... other arguments passed on to 'layer'
9 
+##' @param stat Name of stat to modify data
9 10 
 ##' @param position The position adjustment to use for overlapping points on this layer
10 11 
 ##' @param family sans by default, can be any supported font
11 12 
 ##' @param parse if TRUE, the labels will be passd into expressions
... ... 
@@ -25,6 +26,7 @@
25 26 
 ##' @author Guangchuang Yu
26 27 
 geom_text2 <- function(mapping = NULL, data = NULL,
27 28 
                        ...,
29 
+                       stat = "identity",
28 30 
                        position = "identity",
29 31 
                        family="sans",
30 32 
                        parse = FALSE,
... ... 
@@ -43,7 +45,7 @@ geom_text2 <- function(mapping = NULL, data = NULL,
43 45 
         position <- position_nudge(nudge_x, nudge_y)
44 46 
     }
45 47
46 
-    default_aes <- aes_(node=~node)
48 
+    default_aes <- aes_() #node=~node)
47 49 
     if (is.null(mapping)) {
48 50 
         mapping <- default_aes
49 51 
     } else {
... ... 
@@ -61,7 +63,7 @@ geom_text2 <- function(mapping = NULL, data = NULL,
61 63 
     layer(
62 64 
         data = data,
63 65 
         mapping = mapping,
64 
-        stat = StatTreeData,
66 
+        stat = stat, #StatTreeData,
65 67 
         geom = GeomTextGGtree,
66 68 
         position = position,
67 69 
         show.legend = show.legend,
... ... 
@@ -94,7 +96,7 @@ GeomTextGGtree <- ggproto("GeomTextGGtree", GeomText,
94 96 
                               GeomText$draw_panel(data, panel_scales, coord, parse,
95 97 
                                                   na.rm, check_overlap)
96 98 
                           },
97 
-                          required_aes = c("node", "x", "y", "label"),
99 
+                          required_aes = c("x", "y", "label"),
98 100
99 101 
                           default_aes = aes(colour = "black", size = 3.88, angle = 0, hjust = 0.5,
100 102 
                               vjust = 0.5, alpha = NA, family = "", fontface = 1, lineheight = 1.2),
R/geom_tiplab.R
History View file @ 7790e533
... ... 
@@ -25,12 +25,12 @@ geom_tiplab <- function(mapping=NULL, hjust = 0,  align = FALSE, linetype = "dot
25 25 
     } else {
26 26 
         text_geom <- geom_label2
27 27 
     }
28 
-    x <- y <- label <- isTip <- NULL
28 
+    x <- y <- label <- isTip <- node <- NULL
29 29 
     if (align == TRUE) {
30 
-        self_mapping <- aes(x = max(x, na.rm=TRUE) + diff(range(x, na.rm=TRUE))/200, y = y, label = label, subset= isTip)
30 
+        self_mapping <- aes(x = max(x, na.rm=TRUE) + diff(range(x, na.rm=TRUE))/200, y = y, label = label, node = node, subset = isTip)
31 31 
     }
32 32 
     else {
33 
-        self_mapping <- aes(x = x + diff(range(x, na.rm=TRUE))/200, y= y, label = label, subset= isTip)
33 
+        self_mapping <- aes(x = x + diff(range(x, na.rm=TRUE))/200, y= y, label = label, node = node, subset = isTip)
34 34 
     }
35 35
36 36 
     if (is.null(mapping)) {
... ... 
@@ -46,19 +46,20 @@ geom_tiplab <- function(mapping=NULL, hjust = 0,  align = FALSE, linetype = "dot
46 46 
         segment_mapping <- aes(x = max(x, na.rm=TRUE),
47 47 
                                xend = x + diff(range(x, na.rm=TRUE))/200,
48 48 
                                y = y, yend = y,
49 
-                               subset=isTip)
49 
+                               node = node,
50 
+                               subset = isTip)
50 51 
         if (!is.null(mapping))
51 52 
             segment_mapping <- modifyList(segment_mapping, mapping)
52 53 
     }
53 54
54 55 
     list(
55 56 
         text_geom(mapping=text_mapping,
56 
-                  hjust = hjust, nudge_x = offset, ...)
57 
+                  hjust = hjust, nudge_x = offset, stat = StatTreeData, ...)
57 58 
         ,
58 59 
         if (show_segment)
59 60 
             geom_segment2(mapping = segment_mapping,
60 61 
                           linetype = linetype,
61 
-                          size = linesize, ...)
62 
+                          size = linesize, stat = StatTreeData, ...)
62 63
63 64 
             ## geom_tipsegment(mapping = segment_mapping,
64 65 
             ##                 offset = offset,
... ... 
@@ -81,12 +82,12 @@ geom_tiplab <- function(mapping=NULL, hjust = 0,  align = FALSE, linetype = "dot
81 82 
 ##' @references \url{https://groups.google.com/forum/#!topic/bioc-ggtree/o35PV3iHO-0}
82 83 
 geom_tiplab2 <- function(mapping=NULL, hjust=0, ...) {
83 84
84 
-    angle <- NULL
85 
-    isTip <- NULL
85 
+    angle <- isTip <- node <- NULL
86 
+
86 87 
     ## m1 <- aes(subset=(abs(angle) < 90), angle=angle)
87 88 
     ## m2 <- aes(subset=(abs(angle) >= 90), angle=angle+180)
88 
-    m1 <- aes(subset=(isTip & (angle < 90 | angle > 270)), angle=angle)
89 
-    m2 <- aes(subset=(isTip & (angle >= 90 & angle <=270)), angle=angle+180)
89 
+    m1 <- aes(subset=(isTip & (angle < 90 | angle > 270)), angle=angle, node = node)
90 
+    m2 <- aes(subset=(isTip & (angle >= 90 & angle <=270)), angle=angle+180, node = node)
90 91
91 92 
     if (!is.null(mapping)) {
92 93 
         m1 <- modifyList(mapping, m1)
R/gheatmap.R
History View file @ 7790e533
... ... 
@@ -40,17 +40,23 @@ gheatmap <- function(p, data, offset=0, width=1, low="green", high="red", color=
40 40 
     ## }
41 41
42 42 
     ## convert width to width of each cell
43 
-    width <- width * (p$data$x %>% range %>% diff) / ncol(data)
43 
+    width <- width * (p$data$x %>% range(na.rm=TRUE) %>% diff) / ncol(data)
44 44
45 45 
     isTip <- x <- y <- variable <- value <- from <- to <- NULL
46 46
47 47 
     df <- p$data
48 48 
     df <- df[df$isTip,]
49 
-    start <- max(df$x) + offset
49 
+    start <- max(df$x, na.rm=TRUE) + offset
50 50
51 51 
     dd <- as.data.frame(data)
52 52 
     ## dd$lab <- rownames(dd)
53 
-    lab <- df$label[order(df$y)]
53 
+    i <- order(df$y)
54 
+
55 
+    ## handle collapsed tree
56 
+    ## https://github.com/GuangchuangYu/ggtree/issues/137
57 
+    i <- i[!is.na(df$y[i])]
58 
+
59 
+    lab <- df$label[i]
54 60 
     dd <- dd[lab, , drop=FALSE]
55 61 
     dd$y <- sort(df$y)
56 62 
     dd$lab <- lab
R/inset.R
History View file @ 7790e533
... ... 
@@ -63,7 +63,7 @@ nodebar <- function(data, cols, color, alpha=1, position="stack") {
63 63 
     }
64 64 
     type <- value <- NULL
65 65
66 
-    ldf <- gather(data, type, value, cols) %>% split(., .$node)
66 
+    ldf <- gather(data, type, value, !! cols) %>% split(., .$node)
67 67 
     bars <- lapply(ldf, function(df) ggplot(df, aes_(x=1, y=~value, fill=~type)) +
68 68 
                                      geom_bar(stat='identity', alpha=alpha, position=position) +
69 69 
                                      theme_inset()
... ... 
@@ -96,7 +96,7 @@ nodepie <- function(data, cols, color, alpha=1) {
96 96 
     if (missingArg(color)) {
97 97 
         color <- NA
98 98 
     }
99 
-    ldf <- gather(data, type, value, cols) %>% split(., .$node)
99 
+    ldf <- gather(data, type, value, !! cols) %>% split(., .$node)
100 100 
     lapply(ldf, function(df) ggpie(df, y=~value, fill=~type, color, alpha))
101 101 
 }
102 102
R/jplace.R
History View file @ 7790e533
103 103 
deleted file mode 100644
... ... 
@@ -1,235 +0,0 @@
1 
-## ##' read jplace file
2 
-## ##'
3 
-## ##'
4 
-## ##' @title read.jplace
5 
-## ##' @param file jplace file
6 
-## ##' @return \code{jplace} instance
7 
-## ##' @importFrom jsonlite fromJSON
8 
-## ##' @export
9 
-## ##' @author ygc
10 
-## ##' @examples
11 
-## ##' jp <- system.file("extdata", "sample.jplace", package="ggtree")
12 
-## ##' read.jplace(jp)
13 
-## read.jplace <- function(file) {
14 
-##     fields <- tree <- placements <- NULL
15 
-##     version <- metadata <- NULL
16 
-##     with(fromJSON(file),
17 
-##          new("jplace",
18 
-##              fields     = fields,
19 
-##              treetext   = tree,
20 
-##              phylo      = jplace_treetext_to_phylo(tree),
21 
-##              placements = placements,
22 
-##              version    = version,
23 
-##              metadata   = metadata,
24 
-##              file       = filename(file)
25 
-##              )
26 
-##          )
27 
-## }
28 
-
29 
-
30 
-
31 
-## ##' @rdname scale_color-methods
32 
-## ##' @exportMethod scale_color
33 
-## setMethod("scale_color", signature(object="jplace"),
34 
-##           function(object, by, ...) {
35 
-##               scale_color_(object, by, ...)
36 
-##           })
37 
-
38 
-
39 
-
40 
-
41 
-## ##' get.treeinfo method
42 
-## ##'
43 
-## ##'
44 
-## ##' @docType methods
45 
-## ##' @name get.treeinfo
46 
-## ##' @rdname get.treeinfo-methods
47 
-## ##' @aliases get.treeinfo,jplace,ANY-method
48 
-## ##' @exportMethod get.treeinfo
49 
-## ##' @author Guangchuang Yu \url{http://ygc.name}
50 
-## ##' @usage get.treeinfo(object, layout, ladderize, right, ...)
51 
-## ##' @examples
52 
-## ##' jp <- system.file("extdata", "sample.jplace", package="ggtree")
53 
-## ##' jp <- read.jplace(jp)
54 
-## ##' get.treeinfo(jp)
55 
-## setMethod("get.treeinfo", signature(object = "jplace"),
56 
-##           function(object, layout="phylogram",
57 
-##                    ladderize=TRUE, right=FALSE, ...) {
58 
-##               get.treeinfo.jplace(object, layout,
59 
-##                                   ladderize, right, ...)
60 
-##           }
61 
-##           )
62 
-
63 
-
64 
-## ##' get.treetext method
65 
-## ##'
66 
-## ##'
67 
-## ##' @docType methods
68 
-## ##' @name get.treetext
69 
-## ##' @rdname get.treetext-methods
70 
-## ##' @aliases get.treetext,jplace,ANY-method
71 
-## ##' @exportMethod get.treetext
72 
-## ##' @author Guangchuang Yu \url{http://ygc.name}
73 
-## ##' @usage get.treetext(object, ...)
74 
-## ##' @examples
75 
-## ##' jp <- system.file("extdata", "sample.jplace", package="ggtree")
76 
-## ##' jp <- read.jplace(jp)
77 
-## ##' get.treetext(jp)
78 
-## setMethod("get.treetext", signature(object = "jplace"),
79 
-##           function(object, ...) {
80 
-##               get.treetext.jplace(object, ...)
81 
-##           }
82 
-##           )
83 
-
84 
-
85 
-## ##' get.fields method
86 
-## ##'
87 
-## ##'
88 
-## ##' @docType methods
89 
-## ##' @name get.fields
90 
-## ##' @rdname get.fields-methods
91 
-## ##' @aliases get.fields,jplace,ANY-method
92 
-## ##' @exportMethod get.fields
93 
-## ##' @author Guangchuang Yu \url{http://ygc.name}
94 
-## ##' @usage get.fields(object, ...)
95 
-## ##' @examples
96 
-## ##' jp <- system.file("extdata", "sample.jplace", package="ggtree")
97 
-## ##' jp <- read.jplace(jp)
98 
-## ##' get.fields(jp)
99 
-## setMethod("get.fields", signature(object = "jplace"),
100 
-##           function(object, ...) {
101 
-##               get.fields.tree(object)
102 
-##           }
103 
-##           )
104 
-
105 
-## ##' get.placement method
106 
-## ##'
107 
-## ##'
108 
-## ##' @docType methods
109 
-## ##' @name get.placements
110 
-## ##' @rdname get.placements-methods
111 
-## ##' @aliases get.placements,jplace,ANY-method
112 
-## ##' @exportMethod get.placements
113 
-## ##' @author Guangchuang Yu \url{http://ygc.name}
114 
-## ##' @usage get.placements(object, by, ...)
115 
-## ##' @examples
116 
-## ##' jp <- system.file("extdata", "sample.jplace", package="ggtree")
117 
-## ##' jp <- read.jplace(jp)
118 
-## ##' get.placements(jp, by="all")
119 
-## setMethod("get.placements", signature(object = "jplace"),
120 
-##           function(object, by="best", ...) {
121 
-
122 
-##               placements <- object@placements
123 
-##               place <- placements[,1]
124 
-
125 
-##               ids <- NULL
126 
-##               if (length(placements) == 2) {
127 
-##                   ids <- sapply(placements[,2], function(x) x[1])
128 
-##                   names(place) <- ids
129 
-##               }
130 
-##               if (by == "best") { ## best hit
131 
-##                   place <- lapply(place, function(x) {
132 
-##                       if (is(x, "data.frame") || is(x, "matrix")) {
133 
-##                           if (nrow(x) == 1) {
134 
-##                               return(x)
135 
-##                           }
136 
-##                           ## http://astrostatistics.psu.edu/su07/R/html/base/html/all.equal.html
137 
-##                           ## due to precision, number are identical maynot be equal, so use all.equal which can test nearly equal number
138 
-##                           ## if not equals, the output is a descript string of the differences
139 
-##                           idx <- sapply(2:nrow(x), function(i) all.equal(x[1,2], x[i,2]))
140 
-##                           if (any(idx == TRUE)) {
141 
-##                               return(x[c(1, which(idx==TRUE)+1),])
142 
-##                           } else {
143 
-##                               return(x[1,])
144 
-##                           }
145 
-
146 
-##                       } else {
147 
-##                           ## if only 1 row, it may stored as vector
148 
-##                           ## the edge number, for example 523 can be 523.0000 due to R stored number as real number
149 
-##                           ## be careful in mapping edge number.
150 
-##                           return(x)
151 
-##                       }
152 
-##                   })
153 
-
154 
-##               }
155 
-
156 
-##               place.df <- do.call("rbind", place)
157 
-##               row.names(place.df) <- NULL
158 
-##               if (!is.null(ids)) {
159 
-##                   nn <- rep(ids, sapply(place, function(x) {
160 
-##                       nr <- nrow(x)
161 
-##                       if (is.null(nr))
162 
-##                           return(1)
163 
-##                       return(nr)
164 
-##                   }))
165 
-##                   place.df <- data.frame(name=nn, place.df)
166 
-##                   colnames(place.df) <- c("name", object@fields)
167 
-##               } else {
168 
-##                   colnames(place.df) <- object@fields
169 
-##               }
170 
-##               res <- as.data.frame(place.df, stringsAsFactor=FALSE)
171 
-
172 
-##               ## res[] <- lapply(res, as.character)
173 
-##               ## for (i in 1:ncol(res)) {
174 
-##               ##     if (all(grepl("^[0-9\\.e]+$", res[,i]))) {
175 
-##               ##         res[,i] <- as.numeric(res[,i])
176 
-##               ##     }
177 
-##               ## }
178 
-##               return(res)
179 
-##           })
180 
-
181 
-
182 
-## get.treetext.jplace <- function(object, ...) {
183 
-##     object@treetext
184 
-## }
185 
-
186 
-## get.fields.jplace <- function(object, ...) {
187 
-##     object@fields
188 
-## }
189 
-
190 
-## get.treeinfo.jplace <- function(object, layout,
191 
-##                                 ladderize, right, ...) {
192 
-##     extract.treeinfo.jplace(object, layout,
193 
-##                             ladderize, right, ...)
194 
-## }
195 
-
196 
-## ##' generate jplace file
197 
-## ##'
198 
-## ##'
199 
-## ##' @title write.jplace
200 
-## ##' @param nwk tree in newick format
201 
-## ##' @param data annotation data
202 
-## ##' @param outfile jplace output file
203 
-## ##' @return jplace file
204 
-## ##' @export
205 
-## ##' @author ygc
206 
-## ##' @examples
207 
-## ##' tree <- system.file("extdata", "pa.nwk", package="ggtree")
208 
-## ##' data <- read.csv(system.file("extdata", "pa_subs.csv", package="ggtree"),
209 
-## ##'                 stringsAsFactor=FALSE)
210 
-## ##' outfile <- tempfile()
211 
-## ##' write.jplace(tree, data, outfile)
212 
-## write.jplace <- function(nwk, data, outfile) {
213 
-##     out <- file(outfile, "w")
214 
-##     data[] = lapply(data, as.character) ## remove factor
215 
-##     writeLines("{", out)
216 
-##     writeLines(paste0('\t"tree": "', readLines(nwk), '",'), out)
217 
-##     writeLines('\t"placements": [', out)
218 
-##     for (i in 1:nrow(data)) {
219 
-##         writeLines(paste0('\t{"p":["', paste(data[i,], collapse = '", "'), '"]}'), out, sep="")
220 
-##         if (i != nrow(data)) {
221 
-##             writeLines(',', out)
222 
-##         }
223 
-##     }
224 
-##     writeLines('],', out)
225 
-##     writeLines('\t"metadata": {"info": "generated by ggtree package"},',
226 
-##                out)
227 
-##     writeLines('\t"version": 2,', out)
228 
-##     writeLines(paste0('\t"fields": [', '"',
229 
-##                       paste(colnames(data), collapse='", "'),
230 
-##                       '"'),
231 
-##                out)
232 
-##     writeLines('\t]\n}', out)
233 
-##     close(out)
234 
-## }
235 
-
R/method-fortify.R
History View file @ 7790e533
... ... 
@@ -371,7 +371,13 @@ fortify.jplace <- function(model, data,
371 371 
     df <- extract.treeinfo.jplace(model, layout, ladderize, right, mrsd=mrsd, ...)
372 372 
     place <- get.placements(model, by="best")
373 373
374 
-    df <- df %add2% place
374 
+    nplace <- split(place, place$edge_num) %>% lapply(nrow)
375 
+    nplace.df <- data.frame(edgeNum = names(nplace), nplace=unlist(nplace))
376 
+
377 
+    ## df <- merge(df, place, by.x="edgeNum", by.y="edge_num", all.x=TRUE)
378 
+    df <- merge(df, nplace.df, by.x="edgeNum", by.y="edgeNum", all.x=TRUE)
379 
+
380 
+    df$nplace[is.na(df$nplace)] <- 0
375 381
376 382 
     df <- scaleY(model@phylo, df, yscale, layout, ...)
377 383
R/msaplot.R
History View file @ 7790e533
... ... 
@@ -1,13 +1,15 @@
1 1 
 ##' multiple sequence alignment with phylogenetic tree
2 2 
 ##'
3 
-##'
3 
+##'
4 4 
 ##' @title msaplot
5 5 
 ##' @param p tree view
6 6 
 ##' @param fasta fasta file, multiple sequence alignment
7 7 
 ##' @param offset offset of MSA to tree
8 8 
 ##' @param width total width of alignment, compare to width of tree
9 
-##' @param color color
9 
+##' @param color color
10 10 
 ##' @param window specific a slice to display
11 
+##' @param bg_line whether add background line in alignment
12 
+##' @param height height ratio of sequence
11 13 
 ##' @return tree view
12 14 
 ##' @export
13 15 
 ## @importFrom Biostrings readBStringSet
... ... 
@@ -17,7 +19,7 @@
17 19 
 ##' @importFrom ggplot2 geom_rect
18 20 
 ##' @importFrom ggplot2 scale_fill_manual
19 21 
 ##' @author Guangchuang Yu
20 
-msaplot <- function(p, fasta, offset=0, width=1, color=NULL, window=NULL){
22 
+msaplot <- function(p, fasta, offset=0, width=1, color=NULL, window=NULL, bg_line = TRUE, height = 0.8){
21 23 
     if (missingArg(fasta)) {
22 24 
         aln <- NULL
23 25 
     } else if (is(fasta, "BStringSet")) {
... ... 
@@ -28,7 +30,7 @@ msaplot <- function(p, fasta, offset=0, width=1, color=NULL, window=NULL){
28 30 
     } else {
29 31 
         aln <- NULL
30 32 
     }
31 
-
33 
+
32 34 
     if (is(p, "phylip")) {
33 35 
         BStringSet <- get_fun_from_pkg("Biostrings", "BStringSet")
34 36 
         aln <- BStringSet(p@sequence)
... ... 
@@ -40,12 +42,12 @@ msaplot <- function(p, fasta, offset=0, width=1, color=NULL, window=NULL){
40 42 
     }
41 43
42 44 
     width_fun <- get_fun_from_pkg("Biostrings", "width")
43 
-
45 
+
44 46 
     if (is.null(window)) {
45 47 
         window <- c(1, width_fun(aln)[1])
46 48 
     }
47 49 
     slice <- seq(window[1], window[2], by=1)
48 
-
50 
+
49 51 
     seqs <- lapply(1:length(aln), function(i) {
50 52 
         x <- toString(aln[i])
51 53 
         seq <- substring(x, slice, slice)
... ... 
@@ -56,7 +58,7 @@ msaplot <- function(p, fasta, offset=0, width=1, color=NULL, window=NULL){
56 58 
         return(seq)
57 59 
     })
58 60 
     names(seqs) <- names(aln)
59 
-
61 
+
60 62 
     if(is.null(color)) {
61 63 
         alphabet <- unlist(seqs) %>% unique
62 64 
         alphabet <- alphabet[alphabet != '-']
... ... 
@@ -73,7 +75,7 @@ msaplot <- function(p, fasta, offset=0, width=1, color=NULL, window=NULL){
73 75
74 76 
     ## convert width to width of each cell
75 77 
     width <- width * (df$x %>% range %>% diff) / diff(window)
76 
-
78 
+
77 79 
     df=df[df$isTip,]
78 80 
     start <- max(df$x) * 1.02 + offset
79 81
... ... 
@@ -84,14 +86,17 @@ msaplot <- function(p, fasta, offset=0, width=1, color=NULL, window=NULL){
84 86 
     xmax <- start + seq_along(slice) * width
85 87 
     xmin <- xmax - width
86 88 
     y <- sort(df$y)
87 
-    ymin <- y - 0.4 *h
88 
-    ymax <- y + 0.4 *h
89 
+    ymin <- y - height/2 *h
90 
+    ymax <- y + height/2 *h
89 91
90 92 
     from <- to <- NULL
91 
-
93 
+
92 94 
     lines.df <- data.frame(from=min(xmin), to=max(xmax), y = y)
93 95
94 
-    p <- p + geom_segment(data=lines.df, aes(x=from, xend=to, y=y, yend=y))
96 
+    if (bg_line) {
97 
+        p <- p + geom_segment(data=lines.df, aes(x=from, xend=to, y=y, yend=y), size=h*.2)
98 
+    }
99 
+
95 100 
     msa <- lapply(1:length(y), function(i) {
96 101 
         data.frame(name=names(seqs)[i],
97 102 
                    xmin=xmin,
... ... 
@@ -103,7 +108,7 @@ msaplot <- function(p, fasta, offset=0, width=1, color=NULL, window=NULL){
103 108
104 109 
     msa.df <- do.call("rbind", msa)
105 110
106 
-    p <- p + geom_rect(data=msa.df, aes(x=xmin, y=ymin,
111 
+    p <- p + geom_rect(data=msa.df, aes(x=xmin, y=ymin,
107 112 
                            xmin=xmin, xmax=xmax,
108 113 
                            ymin=ymin, ymax=ymax, fill=seq)) +
109 114 
                                scale_fill_manual(values=color)
... ... 
@@ -112,7 +117,7 @@ msaplot <- function(p, fasta, offset=0, width=1, color=NULL, window=NULL){
112 117 
     pos <- start + breaks * width
113 118 
     mapping <- data.frame(from=breaks+1, to=pos)
114 119 
     attr(p, "mapping") <- mapping
115 
-
120 
+
116 121 
     return(p)
117 122 
 }
118 123
README.Rmd
History View file @ 7790e533
... ... 
@@ -11,9 +11,11 @@ html_preview: false
11 11 
 #  ggtree: an R package for visualization and annotation of phylogenetic trees with their covariates and other associated data
12 12
13 13 
 ```{r echo=FALSE, results="hide", message=FALSE}
14 
-library("txtplot")
14 
+#library("txtplot")
15 15 
 library("badger")
16 16 
 library("ypages")
17 
+library("ggplot2")
18 
+library("yyplot")
17 19 
 ```
18 20
19 21 
 <img src="https://raw.githubusercontent.com/Bioconductor/BiocStickers/master/ggtree/ggtree.png" height="200" align="right" />
... ... 
@@ -37,7 +39,8 @@ library("ypages")
37 39 
 [![Build Status](http://www.bioconductor.org/shields/build/devel/bioc/ggtree.svg)](https://bioconductor.org/checkResults/devel/bioc-LATEST/ggtree/)
38 40 
 [![Linux/Mac Travis Build Status](https://img.shields.io/travis/GuangchuangYu/ggtree/master.svg?label=Mac%20OSX%20%26%20Linux)](https://travis-ci.org/GuangchuangYu/ggtree)
39 41 
 [![AppVeyor Build Status](https://img.shields.io/appveyor/ci/Guangchuangyu/ggtree/master.svg?label=Windows)](https://ci.appveyor.com/project/GuangchuangYu/ggtree)
40 
-
42 
+[![Backers on Open Collective](https://opencollective.com/ggtree/backers/badge.svg)](#backers)
43 
+[![Sponsors on Open Collective](https://opencollective.com/ggtree/sponsors/badge.svg)](#sponsors)
41 44
42 45
43 46 
 The `ggtree` package extending the `ggplot2` package. It based on grammar of graphics and takes all the good parts of `ggplot2`. `ggtree` is designed for not only viewing phylogenetic tree but also displaying annotation data on the tree.
... ... 
@@ -62,21 +65,24 @@ __G Yu__, DK Smith, H Zhu, Y Guan, TTY Lam^\*^. ggtree: an R package for visuali
62 65
63 66 
 `r badge_doi("10.1111/2041-210X.12628", "green")`
64 67 
 `r badge_altmetric("10533079", "green")`
68 
+`r badge_citation("HtEfBTGE9r8C", "7268358477862164627", "green")`
69 
+
65 70
66 71 
 ----------------------------------------------------------------------------------------
67 72
68 73
69