Browse code

open_tree & rotate_tree

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

g.yu authored on 12/05/2016 10:16:07
Showing 11 changed files

... ...
@@ -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
 
... ...
@@ -1,5 +1,5 @@
1 1
 % Generated by roxygen2: do not edit by hand
2
-% Please edit documentation in R/experimental_function.R
2
+% Please edit documentation in R/msaplot.R
3 3
 \name{msaplot}
4 4
 \alias{msaplot}
5 5
 \title{msaplot}
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
+