Browse code

new features

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

g.yu authored on 16/02/2016 04:04:44
Showing 33 changed files

... ...
@@ -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
-