git-svn-id: https://hedgehog.fhcrc.org/bioconductor/trunk/madman/Rpacks/ggtree@113679 bc3139a8-67e5-0310-9ffc-ced21a209358
... | ... |
@@ -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.10 |
|
4 |
+Version: 1.3.13 |
|
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 |
... | ... |
@@ -13,16 +13,16 @@ Depends: |
13 | 13 |
Imports: |
14 | 14 |
ape, |
15 | 15 |
Biostrings, |
16 |
- colorspace, |
|
17 | 16 |
grid, |
18 |
- gridExtra, |
|
19 | 17 |
jsonlite, |
20 | 18 |
magrittr, |
21 | 19 |
methods, |
22 | 20 |
stats4, |
23 | 21 |
tidyr |
24 | 22 |
Suggests: |
23 |
+ colorspace, |
|
25 | 24 |
EBImage, |
25 |
+ gridExtra, |
|
26 | 26 |
knitr, |
27 | 27 |
phylobase, |
28 | 28 |
phytools, |
... | ... |
@@ -16,6 +16,7 @@ S3method(fortify,phangorn) |
16 | 16 |
S3method(fortify,phylip) |
17 | 17 |
S3method(fortify,phylo) |
18 | 18 |
S3method(fortify,phylo4) |
19 |
+S3method(fortify,phyloseq) |
|
19 | 20 |
S3method(fortify,r8s) |
20 | 21 |
S3method(fortify,raxml) |
21 | 22 |
export("%<%") |
... | ... |
@@ -41,11 +42,11 @@ export(geom_nodepoint) |
41 | 42 |
export(geom_point2) |
42 | 43 |
export(geom_rootpoint) |
43 | 44 |
export(geom_segment2) |
44 |
-export(geom_text) |
|
45 | 45 |
export(geom_text2) |
46 | 46 |
export(geom_tiplab) |
47 | 47 |
export(geom_tippoint) |
48 | 48 |
export(geom_tree) |
49 |
+export(geom_tree2) |
|
49 | 50 |
export(geom_treescale) |
50 | 51 |
export(get.fields) |
51 | 52 |
export(get.offspring.tip) |
... | ... |
@@ -71,12 +72,14 @@ export(inset) |
71 | 72 |
export(mask) |
72 | 73 |
export(merge_tree) |
73 | 74 |
export(msaplot) |
75 |
+export(multiplot) |
|
74 | 76 |
export(nodebar) |
75 | 77 |
export(nodepie) |
76 | 78 |
export(phyPML) |
77 | 79 |
export(phylopic) |
78 | 80 |
export(plot) |
79 | 81 |
export(pmlToSeq) |
82 |
+export(raxml2nwk) |
|
80 | 83 |
export(read.baseml) |
81 | 84 |
export(read.beast) |
82 | 85 |
export(read.codeml) |
... | ... |
@@ -90,6 +93,7 @@ export(read.r8s) |
90 | 93 |
export(read.raxml) |
91 | 94 |
export(read.tree) |
92 | 95 |
export(reroot) |
96 |
+export(rescale_tree) |
|
93 | 97 |
export(rotate) |
94 | 98 |
export(rtree) |
95 | 99 |
export(scaleClade) |
... | ... |
@@ -147,7 +151,6 @@ importFrom(ape,read.tree) |
147 | 151 |
importFrom(ape,reorder.phylo) |
148 | 152 |
importFrom(ape,which.edge) |
149 | 153 |
importFrom(ape,write.tree) |
150 |
-importFrom(colorspace,rainbow_hcl) |
|
151 | 154 |
importFrom(ggplot2,"%+replace%") |
152 | 155 |
importFrom(ggplot2,GeomPoint) |
153 | 156 |
importFrom(ggplot2,GeomRect) |
... | ... |
@@ -196,8 +199,12 @@ importFrom(ggplot2,xlim) |
196 | 199 |
importFrom(ggplot2,ylab) |
197 | 200 |
importFrom(grDevices,col2rgb) |
198 | 201 |
importFrom(grDevices,rgb) |
202 |
+importFrom(grid,grid.layout) |
|
203 |
+importFrom(grid,grid.newpage) |
|
204 |
+importFrom(grid,pushViewport) |
|
199 | 205 |
importFrom(grid,rasterGrob) |
200 |
-importFrom(gridExtra,grid.arrange) |
|
206 |
+importFrom(grid,unit) |
|
207 |
+importFrom(grid,viewport) |
|
201 | 208 |
importFrom(jsonlite,fromJSON) |
202 | 209 |
importFrom(magrittr,"%<>%") |
203 | 210 |
importFrom(magrittr,"%>%") |
... | ... |
@@ -1,5 +1,33 @@ |
1 |
+CHANGES IN VERSION 1.3.13 |
|
2 |
+------------------------ |
|
3 |
+ o add example of rescale_tree function in treeAnnotation.Rmd <2016-02-07, Sun> |
|
4 |
+ o geom_cladelabel work with collapse <2016-02-07, Sun> |
|
5 |
+ + see https://github.com/GuangchuangYu/ggtree/issues/38 |
|
6 |
+ |
|
7 |
+CHANGES IN VERSION 1.3.12 |
|
8 |
+------------------------ |
|
9 |
+ o exchange function name of geom_tree and geom_tree2 <2016-01-25, Mon> |
|
10 |
+ o solved issues of geom_tree2 <2016-01-25, Mon> |
|
11 |
+ + https://github.com/hadley/ggplot2/issues/1512 |
|
12 |
+ o colnames_level parameter in gheatmap <2016-01-25, Mon> |
|
13 |
+ o raxml2nwk function for converting raxml bootstrap tree to newick format <2016-01-25, Mon> |
|
14 |
+ |
|
15 |
+CHANGES IN VERSION 1.3.11 |
|
16 |
+------------------------ |
|
17 |
+ o solved issues of geom_tree2 <2016-01-25, Mon> |
|
18 |
+ + https://github.com/GuangchuangYu/ggtree/issues/36 |
|
19 |
+ o change compute_group() to compute_panel in geom_tree2() <2016-01-21, Thu> |
|
20 |
+ + fixed issue, https://github.com/GuangchuangYu/ggtree/issues/36 |
|
21 |
+ o support phyloseq object <2016-01-21, Thu> |
|
22 |
+ o update geom_point2, geom_text2 and geom_segment2 to support setup_tree_data <2016-01-21, Thu> |
|
23 |
+ o implement geom_tree2 layer that support duplicated node records via the setup_tree_data function <2016-01-21, Thu> |
|
24 |
+ o rescale_tree function for rescaling branch length of tree object <2016-01-20, Wed> |
|
25 |
+ o upgrade set_branch_length, now branch can be rescaled using feature in extraInfo slot <2016-01-20, Wed> |
|
26 |
+ |
|
1 | 27 |
CHANGES IN VERSION 1.3.10 |
2 | 28 |
------------------------ |
29 |
+ o remove dependency of gridExtra by implementing multiplot function instead of using grid.arrange <2016-01-20, Wed> |
|
30 |
+ o remove dependency of colorspace <2016-01-20, Wed> |
|
3 | 31 |
o support phylip tree format and update vignette of phylip example <2016-01-15, Fri> |
4 | 32 |
|
5 | 33 |
CHANGES IN VERSION 1.3.9 |
... | ... |
@@ -7,7 +7,13 @@ |
7 | 7 |
##' @export |
8 | 8 |
##' @author Guangchuang Yu |
9 | 9 |
Date2decimal <- function(x) { |
10 |
- x <- as.Date(x) |
|
10 |
+ if (is(x, "numeric")) { |
|
11 |
+ return(x) |
|
12 |
+ } |
|
13 |
+ |
|
14 |
+ if (is(x, "character")) { |
|
15 |
+ x <- as.Date(x) |
|
16 |
+ } |
|
11 | 17 |
year <- format(x, "%Y") |
12 | 18 |
y <- x - as.Date(paste0(year, "-01-01")) |
13 | 19 |
as.numeric(year) + as.numeric(y)/365 |
... | ... |
@@ -24,7 +24,7 @@ geom_cladelabel <- function(node, label, offset=0, offset.text=0, |
24 | 24 |
data <- NULL |
25 | 25 |
position <- "identity" |
26 | 26 |
show.legend <- NA |
27 |
- na.rm <- FALSE |
|
27 |
+ na.rm <- TRUE |
|
28 | 28 |
inherit.aes <- FALSE |
29 | 29 |
|
30 | 30 |
if (geom == "text") { |
... | ... |
@@ -133,7 +133,7 @@ StatCladeBar <- ggproto("StatCladBar", Stat, |
133 | 133 |
get_cladelabel_position <- function(data, node, offset, align, adjustRatio) { |
134 | 134 |
df <- get_cladelabel_position_(data, node) |
135 | 135 |
if (align) { |
136 |
- mx <- max(data$x) |
|
136 |
+ mx <- max(data$x, na.rm=TRUE) |
|
137 | 137 |
} else { |
138 | 138 |
mx <- df$x |
139 | 139 |
} |
... | ... |
@@ -144,9 +144,12 @@ get_cladelabel_position <- function(data, node, offset, align, adjustRatio) { |
144 | 144 |
|
145 | 145 |
get_cladelabel_position_ <- function(data, node) { |
146 | 146 |
sp <- get.offspring.df(data, node) |
147 |
- sp.df <- data[c(sp, node),] |
|
147 |
+ sp2 <- c(sp, node) |
|
148 |
+ sp.df <- data[match(sp2, data$node),] |
|
149 |
+ |
|
148 | 150 |
y <- sp.df$y |
149 |
- mx <- max(sp.df$x) |
|
151 |
+ y <- y[!is.na(y)] |
|
152 |
+ mx <- max(sp.df$x, na.rm=TRUE) |
|
150 | 153 |
data.frame(x=mx, y=min(y), yend=max(y)) |
151 | 154 |
} |
152 | 155 |
|
... | ... |
@@ -85,19 +85,28 @@ geom_rootpoint <- function(mapping = NULL, data = NULL, stat = "identity", |
85 | 85 |
geom_point2 <- function(mapping = NULL, data = NULL, stat = "identity", |
86 | 86 |
position = "identity", na.rm = FALSE, |
87 | 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 |
- ... |
|
88 |
+ |
|
89 |
+ |
|
90 |
+ default_aes <- aes_(node=~node) |
|
91 |
+ if (is.null(mapping)) { |
|
92 |
+ mapping <- default_aes |
|
93 |
+ } else { |
|
94 |
+ mapping <- modifyList(mapping, default_aes) |
|
95 |
+ } |
|
96 |
+ |
|
97 |
+ layer( |
|
98 |
+ data = data, |
|
99 |
+ mapping = mapping, |
|
100 |
+ stat = StatTreePoint, |
|
101 |
+ geom = GeomPointGGtree, |
|
102 |
+ position = position, |
|
103 |
+ show.legend = show.legend, |
|
104 |
+ inherit.aes = inherit.aes, |
|
105 |
+ params = list( |
|
106 |
+ na.rm = na.rm, |
|
107 |
+ ... |
|
108 |
+ ) |
|
99 | 109 |
) |
100 |
- ) |
|
101 | 110 |
} |
102 | 111 |
|
103 | 112 |
##' @importFrom ggplot2 ggproto |
... | ... |
@@ -105,16 +114,26 @@ geom_point2 <- function(mapping = NULL, data = NULL, stat = "identity", |
105 | 114 |
##' @importFrom ggplot2 draw_key_point |
106 | 115 |
GeomPointGGtree <- ggproto("GeomPointGGtree", GeomPoint, |
107 | 116 |
setup_data = function(data, params) { |
117 |
+ if (is.null(data$subset)) |
|
118 |
+ return(data) |
|
108 | 119 |
data[data$subset,] |
109 | 120 |
} ## , |
110 | 121 |
|
111 |
-## draw_panel = function(data, panel_scales, coord, na.rm = FALSE){ |
|
112 |
-## GeomPoint$draw_panel(data, panel_scales, coord, na.rm) |
|
113 |
-## }, |
|
122 |
+ ## draw_panel = function(data, panel_scales, coord, na.rm = FALSE){ |
|
123 |
+ ## GeomPoint$draw_panel(data, panel_scales, coord, na.rm) |
|
124 |
+ ## }, |
|
114 | 125 |
|
115 |
-## draw_key = draw_key_point, |
|
126 |
+ ## draw_key = draw_key_point, |
|
116 | 127 |
|
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) |
|
128 |
+ ## required_aes = c("x", "y"), |
|
129 |
+ ## default_aes = aes(shape = 19, colour = "black", size = 1.5, fill = NA, |
|
130 |
+ ## alpha = NA, stroke = 0.5) |
|
120 | 131 |
) |
132 |
+ |
|
133 |
+ |
|
134 |
+StatTreePoint <- ggproto("StatTreePoint", Stat, |
|
135 |
+ required_aes = "node", |
|
136 |
+ compute_group = function(data, scales) { |
|
137 |
+ setup_tree_data(data) |
|
138 |
+ } |
|
139 |
+ ) |
... | ... |
@@ -47,39 +47,59 @@ geom_segment2 <- function(mapping = NULL, data = NULL, stat = "identity", |
47 | 47 |
position = "identity", arrow = NULL, lineend = "butt", |
48 | 48 |
na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, |
49 | 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 |
- ... |
|
50 |
+ |
|
51 |
+ default_aes <- aes_(node=~node) |
|
52 |
+ if (is.null(mapping)) { |
|
53 |
+ mapping <- default_aes |
|
54 |
+ } else { |
|
55 |
+ mapping <- modifyList(mapping, default_aes) |
|
56 |
+ } |
|
57 |
+ |
|
58 |
+ layer( |
|
59 |
+ data = data, |
|
60 |
+ mapping = mapping, |
|
61 |
+ stat = StatTreeSegment, |
|
62 |
+ geom = GeomSegmentGGtree, |
|
63 |
+ position = position, |
|
64 |
+ show.legend = show.legend, |
|
65 |
+ inherit.aes = inherit.aes, |
|
66 |
+ params = list( |
|
67 |
+ arrow = arrow, |
|
68 |
+ lineend = lineend, |
|
69 |
+ na.rm = na.rm, |
|
70 |
+ ... |
|
71 |
+ ) |
|
63 | 72 |
) |
64 |
- ) |
|
65 | 73 |
} |
66 | 74 |
|
67 | 75 |
##' @importFrom ggplot2 GeomSegment |
68 | 76 |
##' @importFrom ggplot2 draw_key_path |
69 | 77 |
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) { |
|
78 |
+ setup_data = function(data, params) { |
|
79 |
+ if (is.null(data$subset)) |
|
80 |
+ return(data) |
|
81 |
+ data[data$subset,] |
|
82 |
+ }, |
|
83 |
+ |
|
84 |
+ draw_panel = function(data, panel_scales, coord, arrow = NULL, |
|
85 |
+ lineend = "butt", na.rm = FALSE) { |
|
86 |
+ |
|
87 |
+ GeomSegment$draw_panel(data, panel_scales, coord, arrow, |
|
88 |
+ lineend, na.rm) |
|
89 |
+ }, |
|
90 |
+ |
|
91 |
+ required_aes = c("x", "y", "xend", "yend"), |
|
92 |
+ default_aes = aes(colour = "black", size = 0.5, linetype = 1, alpha = NA), |
|
93 |
+ |
|
94 |
+ draw_key = draw_key_path |
|
95 |
+ ) |
|
76 | 96 |
|
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 |
|
97 |
+ |
|
98 |
+StatTreeSegment <- ggproto("StatTreeSegment", Stat, |
|
99 |
+ required_aes = "node", |
|
100 |
+ compute_group = function(data, scales) { |
|
101 |
+ setup_tree_data(data) |
|
102 |
+ } |
|
85 | 103 |
) |
104 |
+ |
|
105 |
+ |
... | ... |
@@ -2,46 +2,6 @@ |
2 | 2 |
##' |
3 | 3 |
##' |
4 | 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 |
-} |
|
41 |
- |
|
42 |
-##' text annotations |
|
43 |
-##' @export |
|
44 |
-##' @rdname geom_text |
|
45 | 5 |
##' @param mapping the aesthetic mapping |
46 | 6 |
##' @param data A layer specific dataset - |
47 | 7 |
##' only needed if you want to override he plot defaults. |
... | ... |
@@ -55,33 +15,76 @@ geom_text2 <- function(mapping = NULL, data = NULL, stat = "identity", |
55 | 15 |
##' @param nudge_x horizontal adjustment |
56 | 16 |
##' @param nudge_y vertical adjustment |
57 | 17 |
##' @param check_overlap if TRUE, text that overlaps previous text in the same layer will not be plotted |
58 |
-##' @source |
|
59 |
-##' This is just the imported function |
|
60 |
-##' from the ggplot2 package. The documentation you should |
|
61 |
-##' read for the geom_text function can be found here: \link[ggplot2]{geom_text} |
|
62 |
-##' |
|
18 |
+##' @return text layer |
|
19 |
+##' @importFrom ggplot2 layer |
|
20 |
+##' @importFrom ggplot2 position_nudge |
|
21 |
+##' @export |
|
63 | 22 |
##' @seealso |
64 | 23 |
##' \link[ggplot2]{geom_text} |
65 |
-geom_text <- ggplot2::geom_text |
|
24 |
+##' @author Guangchuang Yu |
|
25 |
+geom_text2 <- function(mapping = NULL, data = NULL, stat = "identity", |
|
26 |
+ position = "identity", parse = FALSE, na.rm=TRUE, show.legend = NA, inherit.aes = TRUE, |
|
27 |
+ ..., nudge_x = 0, nudge_y = 0, check_overlap = FALSE) { |
|
28 |
+ |
|
29 |
+ if (!missing(nudge_x) || !missing(nudge_y)) { |
|
30 |
+ if (!missing(position)) { |
|
31 |
+ stop("Specify either `position` or `nudge_x`/`nudge_y`", call. = FALSE) |
|
32 |
+ } |
|
33 |
+ |
|
34 |
+ position <- position_nudge(nudge_x, nudge_y) |
|
35 |
+ } |
|
36 |
+ |
|
37 |
+ default_aes <- aes_(node=~node) |
|
38 |
+ if (is.null(mapping)) { |
|
39 |
+ mapping <- default_aes |
|
40 |
+ } else { |
|
41 |
+ mapping <- modifyList(mapping, default_aes) |
|
42 |
+ } |
|
43 |
+ |
|
44 |
+ layer( |
|
45 |
+ data = data, |
|
46 |
+ mapping = mapping, |
|
47 |
+ stat = StatTreeLabel, |
|
48 |
+ geom = GeomTextGGtree, |
|
49 |
+ position = position, |
|
50 |
+ show.legend = show.legend, |
|
51 |
+ inherit.aes = inherit.aes, |
|
52 |
+ params = list( |
|
53 |
+ parse = parse, |
|
54 |
+ check_overlap = check_overlap, |
|
55 |
+ na.rm = na.rm, |
|
56 |
+ ... |
|
57 |
+ ) |
|
58 |
+ ) |
|
59 |
+} |
|
66 | 60 |
|
67 | 61 |
|
68 | 62 |
##' @importFrom ggplot2 GeomText |
69 | 63 |
##' @importFrom ggplot2 draw_key_text |
70 | 64 |
GeomTextGGtree <- ggproto("GeomTextGGtree", GeomText, |
71 | 65 |
setup_data = function(data, params) { |
66 |
+ if (is.null(data$subset)) |
|
67 |
+ return(data) |
|
72 | 68 |
data[data$subset,] |
73 | 69 |
}, |
74 |
- |
|
75 | 70 |
draw_panel = function(data, panel_scales, coord, parse = FALSE, |
76 |
- na.rm = FALSE, check_overlap = FALSE) { |
|
71 |
+ na.rm = TRUE, check_overlap = FALSE) { |
|
77 | 72 |
GeomText$draw_panel(data, panel_scales, coord, parse, |
78 | 73 |
na.rm, check_overlap) |
79 | 74 |
}, |
80 |
- |
|
81 |
- required_aes = c("x", "y", "label"), |
|
75 |
+ required_aes = c("node", "x", "y", "label"), |
|
82 | 76 |
|
83 | 77 |
default_aes = aes(colour = "black", size = 3.88, angle = 0, hjust = 0.5, |
84 | 78 |
vjust = 0.5, alpha = NA, family = "", fontface = 1, lineheight = 1.2), |
85 | 79 |
|
86 | 80 |
draw_key = draw_key_text |
87 | 81 |
) |
82 |
+ |
|
83 |
+StatTreeLabel <- ggproto("StatTreeLabel", Stat, |
|
84 |
+ required_aes = "node", |
|
85 |
+ compute_group = function(data, scales) { |
|
86 |
+ setup_tree_data(data) |
|
87 |
+ } |
|
88 |
+ ) |
|
89 |
+ |
|
90 |
+ |
88 | 91 |
new file mode 100644 |
... | ... |
@@ -0,0 +1,200 @@ |
1 |
+##' add tree layer |
|
2 |
+##' |
|
3 |
+##' |
|
4 |
+##' @title geom_tree |
|
5 |
+##' @param mapping aesthetic mapping |
|
6 |
+##' @param data data |
|
7 |
+##' @param layout one of 'rectangular', 'slanted', 'circular', 'radial' or 'unrooted' |
|
8 |
+##' @param multiPhylo logical |
|
9 |
+##' @param ... additional parameter |
|
10 |
+##' @return tree layer |
|
11 |
+##' @importFrom ggplot2 geom_segment |
|
12 |
+##' @importFrom ggplot2 aes |
|
13 |
+##' @export |
|
14 |
+##' @author Yu Guangchuang |
|
15 |
+geom_tree <- function(mapping=NULL, data=NULL, layout="rectangular", multiPhylo=FALSE, ...) { |
|
16 |
+ stat_tree(data=data, mapping=mapping, geom="segment", |
|
17 |
+ layout=layout, multiPhylo=multiPhylo, lineend="round", |
|
18 |
+ position='identity', show.legend=NA, |
|
19 |
+ inherit.aes=TRUE, na.rm=TRUE, ...) |
|
20 |
+} |
|
21 |
+ |
|
22 |
+ |
|
23 |
+stat_tree <- function(mapping=NULL, data=NULL, geom="segment", position="identity", |
|
24 |
+ layout="rectangular", multiPhylo=FALSE, lineend="round", ..., |
|
25 |
+ show.legend=NA, inherit.aes=TRUE, na.rm=FALSE) { |
|
26 |
+ |
|
27 |
+ default_aes <- aes_(x=~x, y=~y,node=~node, parent=~parent) |
|
28 |
+ if (multiPhylo) { |
|
29 |
+ default_aes <- modifyList(default_aes, aes_(.id=~.id)) |
|
30 |
+ } |
|
31 |
+ |
|
32 |
+ if (is.null(mapping)) { |
|
33 |
+ mapping <- default_aes |
|
34 |
+ } else { |
|
35 |
+ mapping <- modifyList(mapping, default_aes) |
|
36 |
+ } |
|
37 |
+ |
|
38 |
+ if (layout %in% c("rectangular", "fan", "circular")) { |
|
39 |
+ list(layer(data=data, |
|
40 |
+ mapping=mapping, |
|
41 |
+ stat=StatTreeHorizontal, |
|
42 |
+ geom = geom, |
|
43 |
+ position=position, |
|
44 |
+ show.legend = show.legend, |
|
45 |
+ inherit.aes = inherit.aes, |
|
46 |
+ params=list(layout = layout, |
|
47 |
+ lineend = lineend, |
|
48 |
+ na.rm = na.rm, |
|
49 |
+ ...) |
|
50 |
+ ), |
|
51 |
+ layer(data=data, |
|
52 |
+ mapping=mapping, |
|
53 |
+ stat=StatTreeVertical, |
|
54 |
+ geom = geom, |
|
55 |
+ position=position, |
|
56 |
+ show.legend = show.legend, |
|
57 |
+ inherit.aes = inherit.aes, |
|
58 |
+ params=list(layout = layout, |
|
59 |
+ lineend = lineend, |
|
60 |
+ na.rm = na.rm, |
|
61 |
+ ...) |
|
62 |
+ ) |
|
63 |
+ ) |
|
64 |
+ } else if (layout %in% c("slanted", "radial", "unrooted")) { |
|
65 |
+ layer(stat=StatTree, |
|
66 |
+ data=data, |
|
67 |
+ mapping=mapping, |
|
68 |
+ geom = geom, |
|
69 |
+ position=position, |
|
70 |
+ show.legend = show.legend, |
|
71 |
+ inherit.aes = inherit.aes, |
|
72 |
+ params=list(layout = layout, |
|
73 |
+ lineend = lineend, |
|
74 |
+ na.rm = na.rm, |
|
75 |
+ ...) |
|
76 |
+ ) |
|
77 |
+ } |
|
78 |
+} |
|
79 |
+ |
|
80 |
+StatTreeHorizontal <- ggproto("StatTreeHorizontal", Stat, |
|
81 |
+ required_aes = c("node", "parent", "x", "y"), |
|
82 |
+ compute_panel = function(self, data, scales, params, layout, lineend) { |
|
83 |
+ .fun <- function(data) { |
|
84 |
+ df <- setup_tree_data(data) |
|
85 |
+ x <- df$x |
|
86 |
+ y <- df$y |
|
87 |
+ df$xend <- x |
|
88 |
+ df$yend <- y |
|
89 |
+ ii <- with(df, match(parent, node)) |
|
90 |
+ df$x <- x[ii] |
|
91 |
+ return(df) |
|
92 |
+ } |
|
93 |
+ |
|
94 |
+ if ('.id' %in% names(data)) { |
|
95 |
+ ldf <- split(data, data$.id) |
|
96 |
+ df <- do.call(rbind, lapply(ldf, .fun)) |
|
97 |
+ } else { |
|
98 |
+ df <- .fun(data) |
|
99 |
+ } |
|
100 |
+ return(df) |
|
101 |
+ } |
|
102 |
+ ) |
|
103 |
+ |
|
104 |
+StatTreeVertical <- ggproto("StatTreeVertical", Stat, |
|
105 |
+ required_aes = c("node", "parent", "x", "y"), |
|
106 |
+ compute_panel = function(self, data, scales, params, layout, lineend) { |
|
107 |
+ .fun <- function(data) { |
|
108 |
+ df <- setup_tree_data(data) |
|
109 |
+ x <- df$x |
|
110 |
+ y <- df$y |
|
111 |
+ ii <- with(df, match(parent, node)) |
|
112 |
+ df$x <- x[ii] |
|
113 |
+ df$y <- y[ii] |
|
114 |
+ df$xend <- x[ii] |
|
115 |
+ df$yend <- y |
|
116 |
+ return(df) |
|
117 |
+ } |
|
118 |
+ if ('.id' %in% names(data)) { |
|
119 |
+ ldf <- split(data, data$.id) |
|
120 |
+ df <- do.call(rbind, lapply(ldf, .fun)) |
|
121 |
+ } else { |
|
122 |
+ df <- .fun(data) |
|
123 |
+ } |
|
124 |
+ return(df) |
|
125 |
+ } |
|
126 |
+ ) |
|
127 |
+ |
|
128 |
+ |
|
129 |
+ |
|
130 |
+StatTree <- ggproto("StatTree", Stat, |
|
131 |
+ required_aes = c("node", "parent", "x", "y"), |
|
132 |
+ compute_panel = function(self, data, scales, params, layout, lineend) { |
|
133 |
+ .fun <- function(data) { |
|
134 |
+ df <- setup_tree_data(data) |
|
135 |
+ x <- df$x |
|
136 |
+ y <- df$y |
|
137 |
+ ii <- with(df, match(parent, node)) |
|
138 |
+ df$x <- x[ii] |
|
139 |
+ df$y <- y[ii] |
|
140 |
+ df$xend <- x |
|
141 |
+ df$yend <- y |
|
142 |
+ return(df) |
|
143 |
+ } |
|
144 |
+ if ('.id' %in% names(data)) { |
|
145 |
+ ldf <- split(data, data$.id) |
|
146 |
+ df <- do.call(rbind, lapply(ldf, .fun)) |
|
147 |
+ } else { |
|
148 |
+ df <- .fun(data) |
|
149 |
+ } |
|
150 |
+ return(df) |
|
151 |
+ } |
|
152 |
+ ) |
|
153 |
+ |
|
154 |
+ |
|
155 |
+setup_tree_data <- function(data) { |
|
156 |
+ if (nrow(data) == length(unique(data$node))) |
|
157 |
+ return(data) |
|
158 |
+ |
|
159 |
+ data[match(unique(data$node), data$node),] |
|
160 |
+ ## data[order(data$node, decreasing = FALSE), ] |
|
161 |
+} |
|
162 |
+ |
|
163 |
+ |
|
164 |
+##' add tree layer |
|
165 |
+##' |
|
166 |
+##' |
|
167 |
+##' @title geom_tree2 |
|
168 |
+##' @param layout one of 'rectangular', 'slanted', 'circular', 'radial' or 'unrooted' |
|
169 |
+##' @param ... additional parameter |
|
170 |
+##' @return tree layer |
|
171 |
+##' @importFrom ggplot2 geom_segment |
|
172 |
+##' @importFrom ggplot2 aes |
|
173 |
+##' @export |
|
174 |
+##' @author Yu Guangchuang |
|
175 |
+geom_tree2 <- function(layout="rectangular", ...) { |
|
176 |
+ x <- y <- parent <- NULL |
|
177 |
+ lineend = "round" |
|
178 |
+ if (layout == "rectangular" || layout == "fan" || layout == "circular") { |
|
179 |
+ list( |
|
180 |
+ geom_segment(aes(x = x[parent], |
|
181 |
+ xend = x, |
|
182 |
+ y = y, |
|
183 |
+ yend = y), |
|
184 |
+ lineend = lineend, ...), |
|
185 |
+ |
|
186 |
+ geom_segment(aes(x = x[parent], |
|
187 |
+ xend = x[parent], |
|
188 |
+ y = y[parent], |
|
189 |
+ yend = y), |
|
190 |
+ lineend = lineend, ...) |
|
191 |
+ ) |
|
192 |
+ } else if (layout == "slanted" || layout == "radial" || layout == "unrooted") { |
|
193 |
+ geom_segment(aes(x = x[parent], |
|
194 |
+ xend = x, |
|
195 |
+ y = y[parent], |
|
196 |
+ yend = y), |
|
197 |
+ lineend = lineend, ...) |
|
198 |
+ } |
|
199 |
+} |
|
200 |
+ |
... | ... |
@@ -76,8 +76,17 @@ ggtree <- function(tr, |
76 | 76 |
right = right, |
77 | 77 |
branch.length = branch.length, |
78 | 78 |
ndigits = ndigits, ...) |
79 |
+ |
|
80 |
+ if (is(tr, "multiPhylo")) { |
|
81 |
+ multiPhylo <- TRUE |
|
82 |
+ } else { |
|
83 |
+ multiPhylo <- FALSE |
|
84 |
+ } |
|
79 | 85 |
|
80 |
- p <- p + geom_tree(layout, ...) + theme_tree() |
|
86 |
+ p <- p + geom_tree(layout=layout, multiPhylo=multiPhylo, ...) |
|
87 |
+ |
|
88 |
+ |
|
89 |
+ p <- p + theme_tree() |
|
81 | 90 |
|
82 | 91 |
if (type == "circular" || type == "radial") { |
83 | 92 |
p <- p + coord_polar(theta = "y") |
... | ... |
@@ -96,123 +105,5 @@ ggtree <- function(tr, |
96 | 105 |
return(p) |
97 | 106 |
} |
98 | 107 |
|
99 |
-##' add tree layer |
|
100 |
-##' |
|
101 |
-##' |
|
102 |
-##' @title geom_tree |
|
103 |
-##' @param layout one of 'rectangular', 'slanted', 'circular', 'radial' or 'unrooted' |
|
104 |
-##' @param ... additional parameter |
|
105 |
-##' @return tree layer |
|
106 |
-##' @importFrom ggplot2 geom_segment |
|
107 |
-##' @importFrom ggplot2 aes |
|
108 |
-##' @export |
|
109 |
-##' @author Yu Guangchuang |
|
110 |
-##' @examples |
|
111 |
-##' require(ape) |
|
112 |
-##' tr <- rtree(10) |
|
113 |
-##' require(ggplot2) |
|
114 |
-##' ggplot(tr) + geom_tree() |
|
115 |
-geom_tree <- function(layout="rectangular", ...) { |
|
116 |
- x <- y <- parent <- NULL |
|
117 |
- lineend = "round" |
|
118 |
- if (layout == "rectangular" || layout == "fan" || layout == "circular") { |
|
119 |
- list( |
|
120 |
- geom_segment(aes(x = x[parent], |
|
121 |
- xend = x, |
|
122 |
- y = y, |
|
123 |
- yend = y), |
|
124 |
- lineend = lineend, ...), |
|
125 |
- |
|
126 |
- geom_segment(aes(x = x[parent], |
|
127 |
- xend = x[parent], |
|
128 |
- y = y[parent], |
|
129 |
- yend = y), |
|
130 |
- lineend = lineend, ...) |
|
131 |
- ) |
|
132 |
- } else if (layout == "slanted" || layout == "radial" || layout == "unrooted") { |
|
133 |
- geom_segment(aes(x = x[parent], |
|
134 |
- xend = x, |
|
135 |
- y = y[parent], |
|
136 |
- yend = y), |
|
137 |
- lineend = lineend, ...) |
|
138 |
- } |
|
139 |
-} |
|
140 |
- |
|
141 |
- |
|
142 |
- |
|
143 |
- |
|
144 |
- |
|
145 |
- |
|
146 |
- |
|
147 |
- |
|
148 |
- |
|
149 |
-##' add colorbar legend |
|
150 |
-##' |
|
151 |
-##' |
|
152 |
-##' @title add_colorbar |
|
153 |
-##' @param p tree view |
|
154 |
-##' @param color output of scale_color function |
|
155 |
-##' @param x x position |
|
156 |
-##' @param ymin ymin |
|
157 |
-##' @param ymax ymax |
|
158 |
-##' @param font.size font size |
|
159 |
-##' @return ggplot2 object |
|
160 |
-##' @export |
|
161 |
-##' @importFrom ggplot2 annotate |
|
162 |
-##' @author Guangchuang Yu |
|
163 |
-add_colorbar <- function(p, color, x=NULL, ymin=NULL, ymax=NULL, font.size=4) { |
|
164 |
- mrsd <- attr(p, "mrsd") |
|
165 |
- if (!is.null(mrsd)) { |
|
166 |
- attr(p, "mrsd") <- NULL |
|
167 |
- |
|
168 |
- p$data$x <- Date2decimal(p$data$x) |
|
169 |
- p$data$branch <- Date2decimal(p$data$branch) |
|
170 |
- ## annotation segment not support using Date as x-axis |
|
171 |
- } |
|
172 |
- |
|
173 |
- legend <- do.call("cbind", attr(color, "scale")) |
|
174 |
- |
|
175 |
- legend[,1] <- round(as.numeric(legend[,1]), 2) |
|
176 |
- |
|
177 |
- ## legend[nrow(legend),1] <- paste(">=", legend[nrow(legend),1]) |
|
178 |
- |
|
179 |
- if (is.null(x)) { |
|
180 |
- xx <- range(p$data$x) |
|
181 |
- x <- min(xx)+diff(xx)/100 |
|
182 |
- } |
|
183 |
- |
|
184 |
- yy <- range(p$data$y) |
|
185 |
- if (is.null(ymin)) { |
|
186 |
- if (is.null(ymax)) { |
|
187 |
- ymax <- max(yy) - diff(yy)/100 |
|
188 |
- } |
|
189 |
- ymin <- ymax - diff(yy)/15 |
|
190 |
- } |
|
191 |
- |
|
192 |
- if (is.null(ymax)) { |
|
193 |
- ymax <- ymin + diff(yy)/15 |
|
194 |
- } |
|
195 |
- |
|
196 |
- yy <- seq(ymin, ymax, length.out=nrow(legend)+1) |
|
197 |
- |
|
198 |
- ymin <- yy[1:nrow(legend)] |
|
199 |
- ymax <- yy[2:length(yy)] |
|
200 |
- y <- (ymin+ymax)/2 |
|
201 |
- |
|
202 |
- i <- seq(1, length(y), length.out = 5) %>% round(0) |
|
203 |
- offset <- diff(range(p$data$x))/40 |
|
204 |
- barwidth <- offset/5 |
|
205 |
- |
|
206 |
- p + annotate("text", x=x+offset*1.5, y=y[i], label=legend[i,1], size=font.size, hjust=0) + |
|
207 |
- annotate("rect", xmin=x, xmax=x+offset, ymin=ymin, |
|
208 |
- ymax = ymax, fill=legend[,2], color=legend[,2]) + |
|
209 |
- annotate("segment", x=x, xend=x+barwidth, y=y[i], yend=y[i], color="white") + |
|
210 |
- annotate("segment", x=x+offset-barwidth, xend=x+offset, y=y[i], yend=y[i], color="white") |
|
211 |
- |
|
212 |
-} |
|
213 |
- |
|
214 |
- |
|
215 |
- |
|
216 |
- |
|
217 | 108 |
|
218 | 109 |
|
219 | 110 |
new file mode 100644 |
... | ... |
@@ -0,0 +1,93 @@ |
1 |
+##' append a heatmap of a matrix to right side of phylogenetic tree |
|
2 |
+##' |
|
3 |
+##' |
|
4 |
+##' @title gheatmap |
|
5 |
+##' @param p tree view |
|
6 |
+##' @param data matrix or data.frame |
|
7 |
+##' @param offset offset of heatmap to tree |
|
8 |
+##' @param width total width of heatmap, compare to width of tree |
|
9 |
+##' @param low color of lowest value |
|
10 |
+##' @param high color of highest value |
|
11 |
+##' @param color color of heatmap cell border |
|
12 |
+##' @param colnames logical, add matrix colnames or not |
|
13 |
+##' @param colnames_position one of 'bottom' or 'top' |
|
14 |
+##' @param colnames_level levels of colnames |
|
15 |
+##' @param font.size font size of matrix colnames |
|
16 |
+##' @return tree view |
|
17 |
+##' @importFrom ggplot2 geom_tile |
|
18 |
+##' @importFrom ggplot2 geom_text |
|
19 |
+##' @importFrom ggplot2 theme |
|
20 |
+##' @importFrom ggplot2 element_blank |
|
21 |
+##' @importFrom ggplot2 guides |
|
22 |
+##' @importFrom ggplot2 guide_legend |
|
23 |
+##' @importFrom ggplot2 scale_fill_gradient |
|
24 |
+##' @importFrom ggplot2 scale_fill_discrete |
|
25 |
+##' @export |
|
26 |
+##' @author Guangchuang Yu |
|
27 |
+gheatmap <- function(p, data, offset=0, width=1, low="green", high="red", color="white", |
|
28 |
+ colnames=TRUE, colnames_position="bottom", colnames_level=NULL, font.size=4) { |
|
29 |
+ |
|
30 |
+ colnames_position %<>% match.arg(c("bottom", "top")) |
|
31 |
+ variable <- value <- lab <- y <- NULL |
|
32 |
+ |
|
33 |
+ ## if (is.null(width)) { |
|
34 |
+ ## width <- (p$data$x %>% range %>% diff)/30 |
|
35 |
+ ## } |
|
36 |
+ |
|
37 |
+ ## convert width to width of each cell |
|
38 |
+ width <- width * (p$data$x %>% range %>% diff) / ncol(data) |
|
39 |
+ |
|
40 |
+ isTip <- x <- y <- variable <- value <- from <- to <- NULL |
|
41 |
+ |
|
42 |
+ df <- p$data |
|
43 |
+ df <- df[df$isTip,] |
|
44 |
+ start <- max(df$x) + offset |
|
45 |
+ |
|
46 |
+ dd <- data[df$label[order(df$y)],] |
|
47 |
+ dd$y <- sort(df$y) |
|
48 |
+ |
|
49 |
+ dd$lab <- rownames(dd) |
|
50 |
+ ## dd <- melt(dd, id=c("lab", "y")) |
|
51 |
+ dd <- gather(dd, variable, value, -c(lab, y)) |
|
52 |
+ |
|
53 |
+ if (any(dd$value == "")) { |
|
54 |
+ dd$value[dd$value == ""] <- NA |
|
55 |
+ } |
|
56 |
+ if (is.null(colnames_level)) { |
|
57 |
+ dd$variable <- factor(dd$variable, levels=colnames(data)) |
|
58 |
+ } else { |
|
59 |
+ dd$variable <- factor(dd$variable, levels=colnames_level) |
|
60 |
+ } |
|
61 |
+ V2 <- start + as.numeric(dd$variable) * width |
|
62 |
+ mapping <- data.frame(from=dd$variable, to=V2) |
|
63 |
+ mapping <- unique(mapping) |
|
64 |
+ |
|
65 |
+ dd$x <- V2 |
|
66 |
+ |
|
67 |
+ if (is.null(color)) { |
|
68 |
+ p2 <- p + geom_tile(data=dd, aes(x, y, fill=value), inherit.aes=FALSE) |
|
69 |
+ } else { |
|
70 |
+ p2 <- p + geom_tile(data=dd, aes(x, y, fill=value), color=color, inherit.aes=FALSE) |
|
71 |
+ } |
|
72 |
+ if (is(dd$value,"numeric")) { |
|
73 |
+ p2 <- p2 + scale_fill_gradient(low=low, high=high, na.value="white") |
|
74 |
+ } else { |
|
75 |
+ p2 <- p2 + scale_fill_discrete(na.value="white") |
|
76 |
+ } |
|
77 |
+ |
|
78 |
+ if (colnames) { |
|
79 |
+ if (colnames_position == "bottom") { |
|
80 |
+ y <- 0 |
|
81 |
+ } else { |
|
82 |
+ y <- max(p$data$y) + 1 |
|
83 |
+ } |
|
84 |
+ p2 <- p2 + geom_text(data=mapping, aes(x=to, label=from), y=y, size=font.size, inherit.aes = FALSE) |
|
85 |
+ } |
|
86 |
+ |
|
87 |
+ p2 <- p2 + theme(legend.position="right", legend.title=element_blank()) |
|
88 |
+ p2 <- p2 + guides(fill = guide_legend(override.aes = list(colour = NULL))) |
|
89 |
+ |
|
90 |
+ attr(p2, "mapping") <- mapping |
|
91 |
+ return(p2) |
|
92 |
+} |
|
93 |
+ |
... | ... |
@@ -1,91 +1,3 @@ |
1 |
-##' append a heatmap of a matrix to right side of phylogenetic tree |
|
2 |
-##' |
|
3 |
-##' |
|
4 |
-##' @title gheatmap |
|
5 |
-##' @param p tree view |
|
6 |
-##' @param data matrix or data.frame |
|
7 |
-##' @param offset offset of heatmap to tree |
|
8 |
-##' @param width total width of heatmap, compare to width of tree |
|
9 |
-##' @param low color of lowest value |
|
10 |
-##' @param high color of highest value |
|
11 |
-##' @param color color of heatmap cell border |
|
12 |
-##' @param colnames logical, add matrix colnames or not |
|
13 |
-##' @param colnames_position one of 'bottom' or 'top' |
|
14 |
-##' @param font.size font size of matrix colnames |
|
15 |
-##' @return tree view |
|
16 |
-##' @importFrom ggplot2 geom_tile |
|
17 |
-##' @importFrom ggplot2 geom_text |
|
18 |
-##' @importFrom ggplot2 theme |
|
19 |
-##' @importFrom ggplot2 element_blank |
|
20 |
-##' @importFrom ggplot2 guides |
|
21 |
-##' @importFrom ggplot2 guide_legend |
|
22 |
-##' @importFrom ggplot2 scale_fill_gradient |
|
23 |
-##' @importFrom ggplot2 scale_fill_discrete |
|
24 |
-##' @export |
|
25 |
-##' @author Guangchuang Yu |
|
26 |
-gheatmap <- function(p, data, offset=0, width=1, low="green", high="red", |
|
27 |
- color="white", colnames=TRUE, colnames_position="bottom", font.size=4) { |
|
28 |
- |
|
29 |
- colnames_position %<>% match.arg(c("bottom", "top")) |
|
30 |
- variable <- value <- lab <- y <- NULL |
|
31 |
- |
|
32 |
- ## if (is.null(width)) { |
|
33 |
- ## width <- (p$data$x %>% range %>% diff)/30 |
|
34 |
- ## } |
|
35 |
- |
|
36 |
- ## convert width to width of each cell |
|
37 |
- width <- width * (p$data$x %>% range %>% diff) / ncol(data) |
|
38 |
- |
|
39 |
- isTip <- x <- y <- variable <- value <- from <- to <- NULL |
|
40 |
- |
|
41 |
- df=p$data |
|
42 |
- df=df[df$isTip,] |
|
43 |
- start <- max(df$x) + offset |
|
44 |
- |
|
45 |
- dd <- data[df$label[order(df$y)],] |
|
46 |
- dd$y <- sort(df$y) |
|
47 |
- |
|
48 |
- dd$lab <- rownames(dd) |
|
49 |
- ## dd <- melt(dd, id=c("lab", "y")) |
|
50 |
- dd <- gather(dd, variable, value, -c(lab, y)) |
|
51 |
- |
|
52 |
- if (any(dd$value == "")) { |
|
53 |
- dd$value[dd$value == ""] <- NA |
|
54 |
- } |
|
55 |
- |
|
56 |
- V2 <- start + as.numeric(dd$variable) * width |
|
57 |
- mapping <- data.frame(from=dd$variable, to=V2) |
|
58 |
- mapping <- unique(mapping) |
|
59 |
- |
|
60 |
- dd$x <- V2 |
|
61 |
- |
|
62 |
- if (is.null(color)) { |
|
63 |
- p2 <- p + geom_tile(data=dd, aes(x, y, fill=value), inherit.aes=FALSE) |
|
64 |
- } else { |
|
65 |
- p2 <- p + geom_tile(data=dd, aes(x, y, fill=value), color=color, inherit.aes=FALSE) |
|
66 |
- } |
|
67 |
- if (is(dd$value,"numeric")) { |
|
68 |
- p2 <- p2 + scale_fill_gradient(low=low, high=high, na.value="white") |
|
69 |
- } else { |
|
70 |
- p2 <- p2 + scale_fill_discrete(na.value="white") |
|
71 |
- } |
|
72 |
- |
|
73 |
- if (colnames) { |
|
74 |
- if (colnames_position == "bottom") { |
|
75 |
- y <- 0 |
|
76 |
- } else { |
|
77 |
- y <- max(p$data$y) + 1 |
|
78 |
- } |
|
79 |
- p2 <- p2 + geom_text(data=mapping, aes(x=to, label=from), y=y, size=font.size, inherit.aes = FALSE) |
|
80 |
- } |
|
81 |
- |
|
82 |
- p2 <- p2 + theme(legend.position="right", legend.title=element_blank()) |
|
83 |
- p2 <- p2 + guides(fill = guide_legend(override.aes = list(colour = NULL))) |
|
84 |
- |
|
85 |
- attr(p2, "mapping") <- mapping |
|
86 |
- return(p2) |
|
87 |
-} |
|
88 |
- |
|
89 | 1 |
##' return a data.frame that contains position information |
90 | 2 |
##' for labeling column names of heatmap produced by `gheatmap` function |
91 | 3 |
##' |
... | ... |
@@ -127,7 +39,7 @@ get_heatmap_column_position <- function(treeview, by="bottom") { |
127 | 39 |
##' @export |
128 | 40 |
##' @importFrom Biostrings readBStringSet |
129 | 41 |
##' @importMethodsFrom Biostrings width |
130 |
-##' @importFrom colorspace rainbow_hcl |
|
42 |
+## @importFrom colorspace rainbow_hcl |
|
131 | 43 |
##' @importFrom ggplot2 geom_segment |
132 | 44 |
##' @importFrom ggplot2 geom_rect |
133 | 45 |
##' @importFrom ggplot2 scale_fill_manual |
... | ... |
@@ -115,7 +115,7 @@ fortify.beast <- function(model, data, |
115 | 115 |
|
116 | 116 |
phylo <- set_branch_length(model, branch.length) |
117 | 117 |
|
118 |
- df <- fortify(phylo, layout=layout, |
|
118 |
+ df <- fortify(phylo, layout=layout, branch.length=branch.length, |
|
119 | 119 |
ladderize=ladderize, right=right, mrsd = mrsd, ...) |
120 | 120 |
|
121 | 121 |
stats <- model@stats |
... | ... |
@@ -515,6 +515,10 @@ as.data.frame.phylo <- function(x, row.names, optional, |
515 | 515 |
|
516 | 516 |
as.data.frame.phylo_ <- function(x, layout="rectangular", |
517 | 517 |
branch.length="branch.length", ...) { |
518 |
+ if (branch.length != 'none') { |
|
519 |
+ branch.length = "branch.length" |
|
520 |
+ } |
|
521 |
+ |
|
518 | 522 |
tip.label <- x[["tip.label"]] |
519 | 523 |
Ntip <- length(tip.label) |
520 | 524 |
N <- getNodeNum(x) |
... | ... |
@@ -610,9 +614,9 @@ fortify.multiPhylo <- function(model, data, layout="rectangular", |
610 | 614 |
df$.id <- rep(names(df.list), times=sapply(df.list, nrow)) |
611 | 615 |
df$.id <- factor(df$.id, levels=names(df.list)) |
612 | 616 |
|
613 |
- nNode <- sapply(df.list, nrow) |
|
614 |
- nNode2 <- cumsum(c(0, nNode[-length(nNode)])) |
|
615 |
- df$parent <- df$parent + rep(nNode2, times=nNode) |
|
617 |
+ ## nNode <- sapply(df.list, nrow) |
|
618 |
+ ## nNode2 <- cumsum(c(0, nNode[-length(nNode)])) |
|
619 |
+ ## df$parent <- df$parent + rep(nNode2, times=nNode) |
|
616 | 620 |
return(df) |
617 | 621 |
} |
618 | 622 |
|
... | ... |
@@ -654,7 +658,30 @@ fortify.obkData <- function(model, data, layout="rectangular", |
654 | 658 |
df <- df[order(df$node, decreasing = FALSE),] |
655 | 659 |
return(df) |
656 | 660 |
} |
657 |
- |
|
661 |
+ |
|
662 |
+##' @method fortify phyloseq |
|
663 |
+##' @export |
|
664 |
+fortify.phyloseq <- function(model, data, layout="rectangular", |
|
665 |
+ ladderize=TRUE, right=FALSE, mrsd=NULL, ...) { |
|
666 |
+ |
|
667 |
+ df <- fortify(model@phy_tree, layout=layout, ladderize=ladderize, right=right, mrsd=mrsd, ...) |
|
668 |
+ phyloseq <- "phyloseq" |
|
669 |
+ require(phyloseq, character.only=TRUE) |
|
670 |
+ psmelt <- eval(parse(text="psmelt")) |
|
671 |
+ dd <- psmelt(model) |
|
672 |
+ if ('Abundance' %in% colnames(dd)) { |
|
673 |
+ dd <- dd[dd$Abundance > 0, ] |
|
674 |
+ } |
|
675 |
+ |
|
676 |
+ data <- merge(df, dd, by.x="label", by.y="OTU", all.x=TRUE) |
|
677 |
+ spacing <- 0.02 |
|
678 |
+ idx <- with(data, sapply(table(node)[unique(node)], function(i) 1:i)) %>% unlist |
|
679 |
+ data$hjust <- spacing * idx * max(data$x) |
|
680 |
+ ## data$hjust <- data$x + hjust |
|
681 |
+ |
|
682 |
+ data[order(data$node, decreasing = FALSE), ] |
|
683 |
+} |
|
684 |
+ |
|
658 | 685 |
|
659 | 686 |
## fortify.cophylo <- function(model, data, layout="rectangular", |
660 | 687 |
## ladderize=TRUE, right=FALSE, mrsd = NULL, ...) { |
... | ... |
@@ -10,7 +10,6 @@ |
10 | 10 |
##' @importFrom ggplot2 xlim |
11 | 11 |
##' @importFrom ggplot2 scale_color_manual |
12 | 12 |
##' @importFrom ape drop.tip |
13 |
-##' @importFrom gridExtra grid.arrange |
|
14 | 13 |
##' @author ygc |
15 | 14 |
##' @examples |
16 | 15 |
##' require(ape) |
... | ... |
@@ -35,7 +34,7 @@ gzoom.phylo <- function(phy, focus, subtree=FALSE, widths=c(.3, .7)) { |
35 | 34 |
|
36 | 35 |
p2 <- ggtree(subtr, color="red") + geom_tiplab(hjust=-0.05) |
37 | 36 |
p2 <- p2 + xlim(0, max(p2$data$x)*1.2) |
38 |
- grid.arrange(p1, p2, ncol=2, widths=widths) |
|
37 |
+ multiplot(p1, p2, ncol=2, widths=widths) |
|
39 | 38 |
|
40 | 39 |
invisible(list(p1=p1, p2=p2)) |
41 | 40 |
} |
... | ... |
@@ -46,7 +45,7 @@ gzoom.ggplot <- function(tree_view, focus, widths=c(.3, .7), xmax_adjust=0) { |
46 | 45 |
p2 <- with(cpos, tree_view+ |
47 | 46 |
xlim(xmin, xmax+xmax_adjust)+ |
48 | 47 |
ylim(ymin, ymax)) |
49 |
- grid.arrange(tree_view, p2, ncol=2, widths=widths) |
|
48 |
+ multiplot(tree_view, p2, ncol=2, widths=widths) |
|
50 | 49 |
invisible(list(p1=tree_view, p2=p2)) |
51 | 50 |
} |
52 | 51 |
|
... | ... |
@@ -24,3 +24,133 @@ setMethod("scale_color", signature(object="paml_rst"), |
24 | 24 |
}) |
25 | 25 |
|
26 | 26 |
|
27 |
+ |
|
28 |
+ |
|
29 |
+##' add colorbar legend |
|
30 |
+##' |
|
31 |
+##' |
|
32 |
+##' @title add_colorbar |
|
33 |
+##' @param p tree view |
|
34 |
+##' @param color output of scale_color function |
|
35 |
+##' @param x x position |
|
36 |
+##' @param ymin ymin |
|
37 |
+##' @param ymax ymax |
|
38 |
+##' @param font.size font size |
|
39 |
+##' @return ggplot2 object |
|
40 |
+##' @export |
|
41 |
+##' @importFrom ggplot2 annotate |
|
42 |
+##' @author Guangchuang Yu |
|
43 |
+add_colorbar <- function(p, color, x=NULL, ymin=NULL, ymax=NULL, font.size=4) { |
|
44 |
+ mrsd <- attr(p, "mrsd") |
|
45 |
+ if (!is.null(mrsd)) { |
|
46 |
+ attr(p, "mrsd") <- NULL |
|
47 |
+ |
|
48 |
+ p$data$x <- Date2decimal(p$data$x) |
|
49 |
+ p$data$branch <- Date2decimal(p$data$branch) |
|
50 |
+ ## annotation segment not support using Date as x-axis |
|
51 |
+ } |
|
52 |
+ |
|
53 |
+ legend <- do.call("cbind", attr(color, "scale")) |
|
54 |
+ |
|
55 |
+ legend[,1] <- round(as.numeric(legend[,1]), 2) |
|
56 |
+ |
|
57 |
+ ## legend[nrow(legend),1] <- paste(">=", legend[nrow(legend),1]) |
|
58 |
+ |
|
59 |
+ if (is.null(x)) { |
|
60 |
+ xx <- range(p$data$x) |
|
61 |
+ x <- min(xx)+diff(xx)/100 |
|
62 |
+ } |
|
63 |
+ |
|
64 |
+ yy <- range(p$data$y) |
|
65 |
+ if (is.null(ymin)) { |
|
66 |
+ if (is.null(ymax)) { |
|
67 |
+ ymax <- max(yy) - diff(yy)/100 |
|
68 |
+ } |
|
69 |
+ ymin <- ymax - diff(yy)/15 |
|
70 |
+ } |
|
71 |
+ |
|
72 |
+ if (is.null(ymax)) { |
|
73 |
+ ymax <- ymin + diff(yy)/15 |
|
74 |
+ } |
|
75 |
+ |
|
76 |
+ yy <- seq(ymin, ymax, length.out=nrow(legend)+1) |
|
77 |
+ |
|
78 |
+ ymin <- yy[1:nrow(legend)] |
|
79 |
+ ymax <- yy[2:length(yy)] |
|
80 |
+ y <- (ymin+ymax)/2 |
|
81 |
+ |
|
82 |
+ i <- seq(1, length(y), length.out = 5) %>% round(0) |
|
83 |
+ offset <- diff(range(p$data$x))/40 |
|
84 |
+ barwidth <- offset/5 |
|
85 |
+ |
|
86 |
+ p + annotate("text", x=x+offset*1.5, y=y[i], label=legend[i,1], size=font.size, hjust=0) + |
|
87 |
+ annotate("rect", xmin=x, xmax=x+offset, ymin=ymin, |
|
88 |
+ ymax = ymax, fill=legend[,2], color=legend[,2]) + |
|
89 |
+ annotate("segment", x=x, xend=x+barwidth, y=y[i], yend=y[i], color="white") + |
|
90 |
+ annotate("segment", x=x+offset-barwidth, xend=x+offset, y=y[i], yend=y[i], color="white") |
|
91 |
+ |
|
92 |
+} |
|
93 |
+ |
|
94 |
+ |
|
95 |
+ |
|
96 |
+ |
|
97 |
+## @importFrom colorspace rainbow_hcl |
|
98 |
+scale_color_ <- function(phylo, by, low=NULL, high=NULL, na.color=NULL, default.color="darkgrey", interval=NULL) { |
|
99 |
+ df <- fortify(phylo) |
|
100 |
+ vals <- df[, by] |
|
101 |
+ |
|
102 |
+ MIN=min(vals, na.rm=TRUE) |
|
103 |
+ MAX=max(vals, na.rm=TRUE) |
|
104 |
+ |
|
105 |
+ if (is.null(interval)) { |
|
106 |
+ interval <- seq(MIN, MAX, length.out=100) |
|
107 |
+ } |
|
108 |
+ n <- length(interval) |
|
109 |
+ |
|
110 |
+ if (!is.null(low) & ! is.null(high)) { |
|
111 |
+ cols <- color_scale(low, high, n) |
|
112 |
+ } else { |
|
113 |
+ colorspace <- "colorspace" |
|
114 |
+ require(colorspace, character.only = TRUE) |
|
115 |
+ rainbow_hcl <- eval(parse(text="rainbow_hcl")) |
|
116 |
+ cols <- rainbow_hcl(n) |
|
117 |
+ } |
|
118 |
+ |
|
119 |
+ idx <- getIdx(vals, MIN=MIN, MAX=MAX, interval=interval) |
|
120 |
+ interval <- attr(idx, "interval") |
|
121 |
+ |
|
122 |
+ df$color <- cols[idx] |
|
123 |
+ |
|
124 |
+ tree <- get.tree(phylo) |
|
125 |
+ |
|
126 |
+ if (is.null(na.color)) { |
|
127 |
+ nodes <- getNodes_by_postorder(tree) |
|
128 |
+ for (curNode in nodes) { |
|
129 |
+ children <- getChild(tree, curNode) |
|
130 |
+ if (length(children) == 0) { |
|
131 |
+ next |
|
132 |
+ } |
|
133 |
+ idx <- which(is.na(df[children, "color"])) |
|
134 |
+ if (length(idx) > 0) { |
|
135 |
+ df[children[idx], "color"] <- df[curNode, "color"] |
|
136 |
+ } |
|
137 |
+ } |
|
138 |
+ ii <- which(is.na(df[, "color"])) |
|
139 |
+ if (length(ii) > 0) { |
|
140 |
+ df[ii, "color"] <- default.color |
|
141 |
+ } |
|
142 |
+ } else { |
|
143 |
+ ii <- which(is.na(df[, "color"])) |
|
144 |
+ if (length(ii) > 0) { |
|
145 |
+ df[ii, "color"] <- na.color |
|
146 |
+ } |
|
147 |
+ } |
|
148 |
+ |
|
149 |
+ ## cols[is.na(cols)] <- "grey" |
|
150 |
+ color <- df$color |
|
151 |
+ |
|
152 |
+ attr(color, "scale") <- list(interval=interval, color=cols) |
|
153 |
+ return(color) |
|
154 |
+} |
|
155 |
+ |
|
156 |
+ |
27 | 157 |
new file mode 100644 |
... | ... |
@@ -0,0 +1,42 @@ |
1 |
+##' plot multiple ggplot objects in one page |
|
2 |
+##' |
|
3 |
+##' |
|
4 |
+##' @title multiplot |
|
5 |
+##' @param ... plots |
|
6 |
+##' @param plotlist plot list |
|
7 |
+##' @param ncol number of column |
|
8 |
+##' @param widths widths of plots |
|
9 |
+##' @param labels labels for labeling the plots |
|
10 |
+##' @param label_size font size of label |
|
11 |
+##' @return plot |
|
12 |
+##' @importFrom grid grid.newpage |
|
13 |
+##' @importFrom grid unit |
|
14 |
+##' @importFrom grid viewport |
|
15 |
+##' @importFrom grid pushViewport |
|
16 |
+##' @importFrom grid grid.layout |
|
17 |
+##' @export |
|
18 |
+##' @author Guangchuang Yu |
|
19 |
+multiplot <- function(..., plotlist=NULL, ncol, widths = rep_len(1, ncol), labels=NULL, label_size=5) { |
|
20 |
+ plots <- c(list(...), plotlist) |
|
21 |
+ |
|
22 |
+ n <- length(plots) |
|
23 |
+ layout <- matrix(seq(1, ncol * ceiling(n/ncol)), |
|
24 |
+ ncol = ncol, nrow = ceiling(n/ncol)) |
|
25 |
+ |
|
26 |
+ grid.newpage() |
|
27 |
+ pushViewport(viewport(layout = grid.layout(nrow(layout), ncol(layout), widths=unit(widths, "null")))) |
|
28 |
+ for (i in 1:n) { |
|
29 |
+ ii <- as.data.frame(which(layout == i, arr.ind = TRUE)) |
|
30 |
+ p <- plots[[i]] |
|
31 |
+ |
|
32 |
+ if (!is.null(labels)) { |
|
33 |
+ x <- p$data$x %>% min |
|
34 |
+ y <- p$data$y %>% max |
|
35 |
+ p <- p + annotate("text", x=x, y=y, label=labels[i], size=label_size, fontface='bold', hjust=-.5, vjust=-.5) |
|
36 |
+ } |
|
37 |
+ print(p, vp = viewport(layout.pos.row = ii$row, |
|
38 |
+ layout.pos.col = ii$col) |
|
39 |
+ ) |
|
40 |
+ } |
|
41 |
+} |
|
42 |
+ |
0 | 43 |
new file mode 100644 |
... | ... |
@@ -0,0 +1,18 @@ |
1 |
+##' convert raxml bootstrap tree to newick format |
|
2 |
+##' |
|
3 |
+##' |
|
4 |
+##' @title raxml2nwk |
|
5 |
+##' @param infile input file |
|
6 |
+##' @param outfile output file |
|
7 |
+##' @return newick file |
|
8 |
+##' @export |
|
9 |
+##' @importFrom ape write.tree |
|
10 |
+##' @author Guangchuang Yu |
|
11 |
+raxml2nwk <- function(infile, outfile="raxml.tree") { |
|
12 |
+ raxml <- read.raxml(infile) |
|
13 |
+ nlabel <- raxml@bootstrap[,2] |
|
14 |
+ nlabel[is.na(nlabel)] <- "" |
|
15 |
+ raxml@phylo$node.label <- nlabel |
|
16 |
+ write.tree(raxml@phylo, file=outfile) |
|
17 |
+} |
|
18 |
+ |
0 | 19 |
new file mode 100644 |
... | ... |
@@ -0,0 +1,13 @@ |
1 |
+##' rescale branch length of tree object |
|
2 |
+##' |
|
3 |
+##' |
|
4 |
+##' @title rescale_tree |
|
5 |
+##' @param tree_object tree object |
|
6 |
+##' @param branch.length numerical features (e.g. dN/dS) |
|
7 |
+##' @return update tree object |
|
8 |
+##' @export |
|
9 |
+##' @author Guangchuang Yu |
|
10 |
+rescale_tree <- function(tree_object, branch.length) { |
|
11 |
+ tree_object@phylo <- set_branch_length(tree_object, branch.length) |
|
12 |
+ return(tree_object) |
|
13 |
+} |
... | ... |
@@ -31,68 +31,6 @@ reroot_node_mapping <- function(tree, tree2) { |
31 | 31 |
} |
32 | 32 |
|
33 | 33 |
|
34 |
-##' @importFrom colorspace rainbow_hcl |
|
35 |
-scale_color_ <- function(phylo, by, low=NULL, high=NULL, na.color=NULL, default.color="darkgrey", interval=NULL) { |
|
36 |
- df <- fortify(phylo) |
|
37 |
- vals <- df[, by] |
|
38 |
- |
|
39 |
- MIN=min(vals, na.rm=TRUE) |
|
40 |
- MAX=max(vals, na.rm=TRUE) |
|
41 |
- |
|
42 |
- if (is.null(interval)) { |
|
43 |
- interval <- seq(MIN, MAX, length.out=100) |
|
44 |
- } |
|
45 |
- n <- length(interval) |
|
46 |
- |
|
47 |
- if (!is.null(low) & ! is.null(high)) { |
|
48 |
- cols <- color_scale(low, high, n) |
|
49 |
- } else { |
|
50 |
- cols <- rainbow_hcl(n) |
|
51 |
- } |
|
52 |
- |
|
53 |
- idx <- getIdx(vals, MIN=MIN, MAX=MAX, interval=interval) |
|
54 |
- interval <- attr(idx, "interval") |
|
55 |
- |
|
56 |
- df$color <- cols[idx] |
|
57 |
- |
|
58 |
- tree <- get.tree(phylo) |
|
59 |
- |
|
60 |
- if (is.null(na.color)) { |
|
61 |
- nodes <- getNodes_by_postorder(tree) |
|
62 |
- for (curNode in nodes) { |
|
63 |
- children <- getChild(tree, curNode) |
|
64 |
- if (length(children) == 0) { |
|
65 |
- next |
|
66 |
- } |
|
67 |
- idx <- which(is.na(df[children, "color"])) |
|
68 |
- if (length(idx) > 0) { |
|
69 |
- df[children[idx], "color"] <- df[curNode, "color"] |
|
70 |
- } |
|
71 |
- } |
|
72 |
- ii <- which(is.na(df[, "color"])) |
|
73 |
- if (length(ii) > 0) { |
|
74 |
- df[ii, "color"] <- default.color |
|
75 |
- } |
|
76 |
- } else { |
|
77 |
- ii <- which(is.na(df[, "color"])) |
|
78 |
- if (length(ii) > 0) { |
|
79 |
- df[ii, "color"] <- na.color |
|
80 |
- } |
|
81 |
- } |
|
82 |
- |
|
83 |
- ## cols[is.na(cols)] <- "grey" |
|
84 |
- color <- df$color |
|
85 |
- |
|
86 |
- attr(color, "scale") <- list(interval=interval, color=cols) |
|
87 |
- return(color) |
|
88 |
-} |
|
89 |
- |
|
90 |
- |
|
91 |
- |
|
92 |
- |
|
93 |
- |
|
94 |
- |
|
95 |
- |
|
96 | 34 |
|
97 | 35 |
##' @importFrom ape reorder.phylo |
98 | 36 |
layout.unrooted <- function(tree) { |
... | ... |
@@ -784,11 +722,18 @@ set_branch_length <- function(tree_object, branch.length) { |
784 | 722 |
} else if (is(tree_object, "beast")) { |
785 | 723 |
tree_anno <- tree_object@stats |
786 | 724 |
} |
725 |
+ if (has.extraInfo(tree_object)) { |
|
726 |
+ tree_anno <- merge(tree_anno, tree_object@extraInfo, by.x="node", by.y="node") |
|
727 |
+ } |
|
728 |
+ cn <- colnames(tree_anno) |
|
729 |
+ cn <- cn[!cn %in% c('node', 'parent')] |
|
787 | 730 |
|
788 |
- length <- match.arg(branch.length, c("none", "branch.length", |
|
789 |
- colnames(tree_anno)[-c(1,2)])) |
|
731 |
+ length <- match.arg(branch.length, cn) |
|
790 | 732 |
|
791 |
- |
|