git-svn-id: https://hedgehog.fhcrc.org/bioconductor/trunk/madman/Rpacks/ggtree@117331 bc3139a8-67e5-0310-9ffc-ced21a209358
... | ... |
@@ -82,6 +82,7 @@ export(msaplot) |
82 | 82 |
export(multiplot) |
83 | 83 |
export(nodebar) |
84 | 84 |
export(nodepie) |
85 |
+export(open_tree) |
|
85 | 86 |
export(phyPML) |
86 | 87 |
export(phylopic) |
87 | 88 |
export(plot) |
... | ... |
@@ -102,6 +103,7 @@ export(read.tree) |
102 | 103 |
export(reroot) |
103 | 104 |
export(rescale_tree) |
104 | 105 |
export(rotate) |
106 |
+export(rotate_tree) |
|
105 | 107 |
export(rtree) |
106 | 108 |
export(scaleClade) |
107 | 109 |
export(scale_color) |
... | ... |
@@ -1,5 +1,7 @@ |
1 | 1 |
CHANGES IN VERSION 1.5.3 |
2 | 2 |
------------------------ |
3 |
+ o add angle in ggtree function, fan layout supported <2016-05-12, Thu> |
|
4 |
+ o rotate_tree and open_tree function <2016-05-12, Thu> |
|
3 | 5 |
o support reading BEAST MCC trees (multiple trees in one file) via the read.beast function <2016-05-12, Thu> |
4 | 6 |
|
5 | 7 |
CHANGES IN VERSION 1.5.2 |
... | ... |
@@ -1,3 +1,5 @@ |
1 |
+ |
|
2 |
+ |
|
1 | 3 |
##' return a data.frame that contains position information |
2 | 4 |
##' for labeling column names of heatmap produced by `gheatmap` function |
3 | 5 |
##' |
... | ... |
@@ -25,120 +27,6 @@ get_heatmap_column_position <- function(treeview, by="bottom") { |
25 | 27 |
return(mapping) |
26 | 28 |
} |
27 | 29 |
|
28 |
-##' multiple sequence alignment with phylogenetic tree |
|
29 |
-##' |
|
30 |
-##' |
|
31 |
-##' @title msaplot |
|
32 |
-##' @param p tree view |
|
33 |
-##' @param fasta fasta file, multiple sequence alignment |
|
34 |
-##' @param offset offset of MSA to tree |
|
35 |
-##' @param width total width of alignment, compare to width of tree |
|
36 |
-##' @param color color |
|
37 |
-##' @param window specific a slice to display |
|
38 |
-##' @return tree view |
|
39 |
-##' @export |
|
40 |
-##' @importFrom Biostrings readBStringSet |
|
41 |
-##' @importMethodsFrom Biostrings width |
|
42 |
-## @importFrom colorspace rainbow_hcl |
|
43 |
-##' @importFrom ggplot2 geom_segment |
|
44 |
-##' @importFrom ggplot2 geom_rect |
|
45 |
-##' @importFrom ggplot2 scale_fill_manual |
|
46 |
-##' @author Guangchuang Yu |
|
47 |
-msaplot <- function(p, fasta, offset=0, width=1, color=NULL, window=NULL){ |
|
48 |
- if (missingArg(fasta)) { |
|
49 |
- aln <- NULL |
|
50 |
- } else if (is(fasta, "BStringSet")) { |
|
51 |
- aln <- fasta |
|
52 |
- } else if (is(fasta, "character")) { |
|
53 |
- aln <- readBStringSet(fasta) |
|
54 |
- } else { |
|
55 |
- aln <- NULL |
|
56 |
- } |
|
57 |
- |
|
58 |
- if (is(p, "phylip")) { |
|
59 |
- aln <- p@sequence |
|
60 |
- p <- ggtree(p) + geom_tiplab() |
|
61 |
- } |
|
62 |
- |
|
63 |
- if (is.null(aln)) { |
|
64 |
- stop("multiple sequence alignment is not available...\n-> check the parameter 'fasta'...") |
|
65 |
- } |
|
66 |
- |
|
67 |
- if (is.null(window)) { |
|
68 |
- window <- c(1, width(aln)[1]) |
|
69 |
- } |
|
70 |
- slice <- seq(window[1], window[2], by=1) |
|
71 |
- |
|
72 |
- seqs <- lapply(1:length(aln), function(i) { |
|
73 |
- x <- toString(aln[i]) |
|
74 |
- seq <- substring(x, slice, slice) |
|
75 |
- |
|
76 |
- seq[seq == '?'] <- '-' |
|
77 |
- seq[seq == '*'] <- '-' |
|
78 |
- seq[seq == ' '] <- '-' |
|
79 |
- return(seq) |
|
80 |
- }) |
|
81 |
- names(seqs) <- names(aln) |
|
82 |
- |
|
83 |
- if(is.null(color)) { |
|
84 |
- alphabet <- unlist(seqs) %>% unique |
|
85 |
- alphabet <- alphabet[alphabet != '-'] |
|
86 |
- ## color <- rainbow_hcl(length(alphabet)) |
|
87 |
- color <- getCols(length(alphabet)) |
|
88 |
- names(color) <- alphabet |
|
89 |
- color <- c(color, '-'=NA) |
|
90 |
- } |
|
91 |
- |
|
92 |
- df <- p$data |
|
93 |
- ## if (is.null(width)) { |
|
94 |
- ## width <- (df$x %>% range %>% diff)/500 |
|
95 |
- ## } |
|
96 |
- |
|
97 |
- ## convert width to width of each cell |
|
98 |
- width <- width * (df$x %>% range %>% diff) / diff(window) |
|
99 |
- |
|
100 |
- df=df[df$isTip,] |
|
101 |
- start <- max(df$x) * 1.02 + offset |
|
102 |
- |
|
103 |
- seqs <- seqs[df$label[order(df$y)]] |
|
104 |
- ## seqs.df <- do.call("rbind", seqs) |
|
105 |
- |
|
106 |
- h <- ceiling(diff(range(df$y))/length(df$y)) |
|
107 |
- xmax <- start + seq_along(slice) * width |
|
108 |
- xmin <- xmax - width |
|
109 |
- y <- sort(df$y) |
|
110 |
- ymin <- y - 0.4 *h |
|
111 |
- ymax <- y + 0.4 *h |
|
112 |
- |
|
113 |
- from <- to <- NULL |
|
114 |
- |
|
115 |
- lines.df <- data.frame(from=min(xmin), to=max(xmax), y = y) |
|
116 |
- |
|
117 |
- p <- p + geom_segment(data=lines.df, aes(x=from, xend=to, y=y, yend=y)) |
|
118 |
- msa <- lapply(1:length(y), function(i) { |
|
119 |
- data.frame(name=names(seqs)[i], |
|
120 |
- xmin=xmin, |
|
121 |
- xmax=xmax, |
|
122 |
- ymin=ymin[i], |
|
123 |
- ymax=ymax[i], |
|
124 |
- seq=seqs[[i]]) |
|
125 |
- }) |
|
126 |
- |
|
127 |
- msa.df <- do.call("rbind", msa) |
|
128 |
- |
|
129 |
- p <- p + geom_rect(data=msa.df, aes(x=xmin, y=ymin, |
|
130 |
- xmin=xmin, xmax=xmax, |
|
131 |
- ymin=ymin, ymax=ymax, fill=seq)) + |
|
132 |
- scale_fill_manual(values=color) |
|
133 |
- |
|
134 |
- breaks <- hist(seq_along(slice), breaks=10, plot=FALSE)$breaks |
|
135 |
- pos <- start + breaks * width |
|
136 |
- mapping <- data.frame(from=breaks+1, to=pos) |
|
137 |
- attr(p, "mapping") <- mapping |
|
138 |
- |
|
139 |
- return(p) |
|
140 |
-} |
|
141 |
- |
|
142 | 30 |
##' scale x for tree with heatmap |
143 | 31 |
##' |
144 | 32 |
##' |
... | ... |
@@ -4,7 +4,8 @@ |
4 | 4 |
##' @title ggtree |
5 | 5 |
##' @param tr phylo object |
6 | 6 |
##' @param mapping aes mapping |
7 |
-##' @param layout one of 'rectangular', 'slanted', 'fan'/'circular', 'radial' or 'unrooted' |
|
7 |
+##' @param layout one of 'rectangular', 'slanted', 'fan', 'circular', 'radial' or 'unrooted' |
|
8 |
+##' @param open.angle open angle, only for 'fan' layout |
|
8 | 9 |
##' @param mrsd most recent sampling date |
9 | 10 |
##' @param as.Date logical whether using Date class in time tree |
10 | 11 |
##' @param yscale y scale |
... | ... |
@@ -32,6 +33,7 @@ |
32 | 33 |
ggtree <- function(tr, |
33 | 34 |
mapping = NULL, |
34 | 35 |
layout = "rectangular", |
36 |
+ open.angle = 0, |
|
35 | 37 |
mrsd = NULL, |
36 | 38 |
as.Date = FALSE, |
37 | 39 |
yscale = "none", |
... | ... |
@@ -52,15 +54,7 @@ ggtree <- function(tr, |
52 | 54 |
## for 2d tree |
53 | 55 |
layout <- "slanted" |
54 | 56 |
} |
55 |
- if (layout == "fan" || layout == "circular") { |
|
56 |
- layout <- "circular" |
|
57 |
- type <- "circular" |
|
58 |
- } else if (layout == "radial") { |
|
59 |
- layout <- "slanted" |
|
60 |
- type <- "radial" |
|
61 |
- } else { |
|
62 |
- type <- "none" |
|
63 |
- } |
|
57 |
+ |
|
64 | 58 |
if (is.null(mapping)) { |
65 | 59 |
mapping <- aes_(~x, ~y) |
66 | 60 |
} else { |
... | ... |
@@ -88,12 +82,14 @@ ggtree <- function(tr, |
88 | 82 |
|
89 | 83 |
p <- p + theme_tree() |
90 | 84 |
|
91 |
- if (type == "circular" || type == "radial") { |
|
92 |
- p <- p + coord_polar(theta = "y") |
|
85 |
+ if (layout == "circular" || layout == "radial") { |
|
86 |
+ p <- layout_circular(p) |
|
93 | 87 |
## refer to: https://github.com/GuangchuangYu/ggtree/issues/6 |
94 | 88 |
## and also have some space for tree scale (legend) |
95 | 89 |
p <- p + scale_y_continuous(limits=c(0, max(p$data$y)+1)) |
96 |
- } |
|
97 |
- |
|
90 |
+ } else if (layout == "fan") { |
|
91 |
+ p <- layout_fan(p, open.angle) |
|
92 |
+ } |
|
93 |
+ |
|
98 | 94 |
return(p) |
99 | 95 |
} |
100 | 96 |
new file mode 100644 |
... | ... |
@@ -0,0 +1,46 @@ |
1 |
+##' rotate circular tree |
|
2 |
+##' |
|
3 |
+##' |
|
4 |
+##' @title rotate_tree |
|
5 |
+##' @param treeview tree view |
|
6 |
+##' @param angle angle |
|
7 |
+##' @return updated tree view |
|
8 |
+##' @export |
|
9 |
+##' @author Guangchuang Yu |
|
10 |
+rotate_tree <- function(treeview, angle) { |
|
11 |
+ treeview <- treeview + coord_polar(theta='y', start=(angle-90)/180*pi, -1) |
|
12 |
+ treeview$data$angle <- treeview$data$angle + angle |
|
13 |
+ return(treeview) |
|
14 |
+} |
|
15 |
+ |
|
16 |
+ |
|
17 |
+layout_circular <- function(treeview) { |
|
18 |
+ treeview + coord_polar(theta='y', start=-pi/2, -1) |
|
19 |
+} |
|
20 |
+ |
|
21 |
+##' open tree with specific angle |
|
22 |
+##' |
|
23 |
+##' |
|
24 |
+##' @title open_tree |
|
25 |
+##' @param treeview tree view |
|
26 |
+##' @param angle angle |
|
27 |
+##' @return updated tree view |
|
28 |
+##' @export |
|
29 |
+##' @author Guangchuang Yu |
|
30 |
+open_tree <- function(treeview, angle) { |
|
31 |
+ p <- layout_circular(treeview) |
|
32 |
+ ymax <- max(range(p$data$y)) |
|
33 |
+ p <- p + scale_y_continuous(limits = c(0, |
|
34 |
+ max(c(ymax * (1+angle/(360-angle)), ymax+1)) |
|
35 |
+ )) |
|
36 |
+ N <- nrow(p$data) |
|
37 |
+ idx <- match(1:N, order(p$data$y)) |
|
38 |
+ NN <- N *(1+angle/(360-angle)) |
|
39 |
+ angle <- 360/(3+NN) * (1:N+1) |
|
40 |
+ angle <- angle[idx] |
|
41 |
+ p$data$angle <- angle |
|
42 |
+ return(p) |
|
43 |
+} |
|
44 |
+ |
|
45 |
+layout_fan <- open_tree |
|
46 |
+ |
... | ... |
@@ -584,9 +584,11 @@ as.data.frame.phylo_ <- function(x, layout="rectangular", |
584 | 584 |
## angle for all layout, if 'rectangular', user use coord_polar, can still use angle |
585 | 585 |
## if (layout == "circular") { |
586 | 586 |
idx <- match(1:N, order(res$y)) |
587 |
- angle <- -360/(3+N) * (1:N+1) |
|
587 |
+ ## angle <- -360/(3+N) * (1:N+1) |
|
588 |
+ angle <- 360/(3+N) * (1:N+1) |
|
588 | 589 |
angle <- angle[idx] |
589 |
- res$angle <- angle + 90 |
|
590 |
+ ## res$angle <- angle + 90 |
|
591 |
+ res$angle <- angle |
|
590 | 592 |
## } |
591 | 593 |
|
592 | 594 |
return(res) |
593 | 595 |
new file mode 100644 |
... | ... |
@@ -0,0 +1,114 @@ |
1 |
+##' multiple sequence alignment with phylogenetic tree |
|
2 |
+##' |
|
3 |
+##' |
|
4 |
+##' @title msaplot |
|
5 |
+##' @param p tree view |
|
6 |
+##' @param fasta fasta file, multiple sequence alignment |
|
7 |
+##' @param offset offset of MSA to tree |
|
8 |
+##' @param width total width of alignment, compare to width of tree |
|
9 |
+##' @param color color |
|
10 |
+##' @param window specific a slice to display |
|
11 |
+##' @return tree view |
|
12 |
+##' @export |
|
13 |
+##' @importFrom Biostrings readBStringSet |
|
14 |
+##' @importMethodsFrom Biostrings width |
|
15 |
+## @importFrom colorspace rainbow_hcl |
|
16 |
+##' @importFrom ggplot2 geom_segment |
|
17 |
+##' @importFrom ggplot2 geom_rect |
|
18 |
+##' @importFrom ggplot2 scale_fill_manual |
|
19 |
+##' @author Guangchuang Yu |
|
20 |
+msaplot <- function(p, fasta, offset=0, width=1, color=NULL, window=NULL){ |
|
21 |
+ if (missingArg(fasta)) { |
|
22 |
+ aln <- NULL |
|
23 |
+ } else if (is(fasta, "BStringSet")) { |
|
24 |
+ aln <- fasta |
|
25 |
+ } else if (is(fasta, "character")) { |
|
26 |
+ aln <- readBStringSet(fasta) |
|
27 |
+ } else { |
|
28 |
+ aln <- NULL |
|
29 |
+ } |
|
30 |
+ |
|
31 |
+ if (is(p, "phylip")) { |
|
32 |
+ aln <- p@sequence |
|
33 |
+ p <- ggtree(p) + geom_tiplab() |
|
34 |
+ } |
|
35 |
+ |
|
36 |
+ if (is.null(aln)) { |
|
37 |
+ stop("multiple sequence alignment is not available...\n-> check the parameter 'fasta'...") |
|
38 |
+ } |
|
39 |
+ |
|
40 |
+ if (is.null(window)) { |
|
41 |
+ window <- c(1, width(aln)[1]) |
|
42 |
+ } |
|
43 |
+ slice <- seq(window[1], window[2], by=1) |
|
44 |
+ |
|
45 |
+ seqs <- lapply(1:length(aln), function(i) { |
|
46 |
+ x <- toString(aln[i]) |
|
47 |
+ seq <- substring(x, slice, slice) |
|
48 |
+ |
|
49 |
+ seq[seq == '?'] <- '-' |
|
50 |
+ seq[seq == '*'] <- '-' |
|
51 |
+ seq[seq == ' '] <- '-' |
|
52 |
+ return(seq) |
|
53 |
+ }) |
|
54 |
+ names(seqs) <- names(aln) |
|
55 |
+ |
|
56 |
+ if(is.null(color)) { |
|
57 |
+ alphabet <- unlist(seqs) %>% unique |
|
58 |
+ alphabet <- alphabet[alphabet != '-'] |
|
59 |
+ ## color <- rainbow_hcl(length(alphabet)) |
|
60 |
+ color <- getCols(length(alphabet)) |
|
61 |
+ names(color) <- alphabet |
|
62 |
+ color <- c(color, '-'=NA) |
|
63 |
+ } |
|
64 |
+ |
|
65 |
+ df <- p$data |
|
66 |
+ ## if (is.null(width)) { |
|
67 |
+ ## width <- (df$x %>% range %>% diff)/500 |
|
68 |
+ ## } |
|
69 |
+ |
|
70 |
+ ## convert width to width of each cell |
|
71 |
+ width <- width * (df$x %>% range %>% diff) / diff(window) |
|
72 |
+ |
|
73 |
+ df=df[df$isTip,] |
|
74 |
+ start <- max(df$x) * 1.02 + offset |
|
75 |
+ |
|
76 |
+ seqs <- seqs[df$label[order(df$y)]] |
|
77 |
+ ## seqs.df <- do.call("rbind", seqs) |
|
78 |
+ |
|
79 |
+ h <- ceiling(diff(range(df$y))/length(df$y)) |
|
80 |
+ xmax <- start + seq_along(slice) * width |
|
81 |
+ xmin <- xmax - width |
|
82 |
+ y <- sort(df$y) |
|
83 |
+ ymin <- y - 0.4 *h |
|
84 |
+ ymax <- y + 0.4 *h |
|
85 |
+ |
|
86 |
+ from <- to <- NULL |
|
87 |
+ |
|
88 |
+ lines.df <- data.frame(from=min(xmin), to=max(xmax), y = y) |
|
89 |
+ |
|
90 |
+ p <- p + geom_segment(data=lines.df, aes(x=from, xend=to, y=y, yend=y)) |
|
91 |
+ msa <- lapply(1:length(y), function(i) { |
|
92 |
+ data.frame(name=names(seqs)[i], |
|
93 |
+ xmin=xmin, |
|
94 |
+ xmax=xmax, |
|
95 |
+ ymin=ymin[i], |
|
96 |
+ ymax=ymax[i], |
|
97 |
+ seq=seqs[[i]]) |
|
98 |
+ }) |
|
99 |
+ |
|
100 |
+ msa.df <- do.call("rbind", msa) |
|
101 |
+ |
|
102 |
+ p <- p + geom_rect(data=msa.df, aes(x=xmin, y=ymin, |
|
103 |
+ xmin=xmin, xmax=xmax, |
|
104 |
+ ymin=ymin, ymax=ymax, fill=seq)) + |
|
105 |
+ scale_fill_manual(values=color) |
|
106 |
+ |
|
107 |
+ breaks <- hist(seq_along(slice), breaks=10, plot=FALSE)$breaks |
|
108 |
+ pos <- start + breaks * width |
|
109 |
+ mapping <- data.frame(from=breaks+1, to=pos) |
|
110 |
+ attr(p, "mapping") <- mapping |
|
111 |
+ |
|
112 |
+ return(p) |
|
113 |
+} |
|
114 |
+ |
... | ... |
@@ -8,8 +8,8 @@ |
8 | 8 |
\title{visualizing phylogenetic tree and heterogenous associated data based on grammar of graphics |
9 | 9 |
\code{ggtree} provides functions for visualizing phylogenetic tree and its associated data in R.} |
10 | 10 |
\usage{ |
11 |
-ggtree(tr, mapping = NULL, layout = "rectangular", mrsd = NULL, |
|
12 |
- as.Date = FALSE, yscale = "none", yscale_mapping = NULL, |
|
11 |
+ggtree(tr, mapping = NULL, layout = "rectangular", open.angle = 0, |
|
12 |
+ mrsd = NULL, as.Date = FALSE, yscale = "none", yscale_mapping = NULL, |
|
13 | 13 |
ladderize = TRUE, right = FALSE, branch.length = "branch.length", |
14 | 14 |
ndigits = NULL, ...) |
15 | 15 |
} |
... | ... |
@@ -18,7 +18,9 @@ ggtree(tr, mapping = NULL, layout = "rectangular", mrsd = NULL, |
18 | 18 |
|
19 | 19 |
\item{mapping}{aes mapping} |
20 | 20 |
|
21 |
-\item{layout}{one of 'rectangular', 'slanted', 'fan'/'circular', 'radial' or 'unrooted'} |
|
21 |
+\item{layout}{one of 'rectangular', 'slanted', 'fan', 'circular', 'radial' or 'unrooted'} |
|
22 |
+ |
|
23 |
+\item{open.angle}{open angle, only for 'fan' layout} |
|
22 | 24 |
|
23 | 25 |
\item{mrsd}{most recent sampling date} |
24 | 26 |
|
6 | 6 |
new file mode 100644 |
... | ... |
@@ -0,0 +1,23 @@ |
1 |
+% Generated by roxygen2: do not edit by hand |
|
2 |
+% Please edit documentation in R/layout.R |
|
3 |
+\name{open_tree} |
|
4 |
+\alias{open_tree} |
|
5 |
+\title{open_tree} |
|
6 |
+\usage{ |
|
7 |
+open_tree(treeview, angle) |
|
8 |
+} |
|
9 |
+\arguments{ |
|
10 |
+\item{treeview}{tree view} |
|
11 |
+ |
|
12 |
+\item{angle}{angle} |
|
13 |
+} |
|
14 |
+\value{ |
|
15 |
+updated tree view |
|
16 |
+} |
|
17 |
+\description{ |
|
18 |
+open tree with specific angle |
|
19 |
+} |
|
20 |
+\author{ |
|
21 |
+Guangchuang Yu |
|
22 |
+} |
|
23 |
+ |
0 | 24 |
new file mode 100644 |
... | ... |
@@ -0,0 +1,23 @@ |
1 |
+% Generated by roxygen2: do not edit by hand |
|
2 |
+% Please edit documentation in R/layout.R |
|
3 |
+\name{rotate_tree} |
|
4 |
+\alias{rotate_tree} |
|
5 |
+\title{rotate_tree} |
|
6 |
+\usage{ |
|
7 |
+rotate_tree(treeview, angle) |
|
8 |
+} |
|
9 |
+\arguments{ |
|
10 |
+\item{treeview}{tree view} |
|
11 |
+ |
|
12 |
+\item{angle}{angle} |
|
13 |
+} |
|
14 |
+\value{ |
|
15 |
+updated tree view |
|
16 |
+} |
|
17 |
+\description{ |
|
18 |
+rotate circular tree |
|
19 |
+} |
|
20 |
+\author{ |
|
21 |
+Guangchuang Yu |
|
22 |
+} |
|
23 |
+ |