Browse code

add `compute_group` according to ggplot (v2.1.0) <2016-09-29, Thu>

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

Guangchuang Yu authored on 29/09/2016 05:55:59
Showing6 changed files

... ...
@@ -1,5 +1,7 @@
1 1
 CHANGES IN VERSION 1.5.14
2 2
 ------------------------
3
+ o add `compute_group` according to ggplot (v2.1.0) <2016-09-29, Thu>
4
+   + https://github.com/hadley/ggplot2/issues/1797
3 5
  o unit test for groupOTU and groupClade <2016-09-22, Thu>
4 6
  o groupOTU label groups by input group names (when input is a named list) <2016-09-22, Thu>
5 7
  o update angle calculation for geom_tiplab <2016-09-13, Thu>
... ...
@@ -1,6 +1,6 @@
1 1
 ##' annotate a clade with bar and text label
2 2
 ##'
3
-##' 
3
+##'
4 4
 ##' @title geom_cladelabel
5 5
 ##' @param node selected node
6 6
 ##' @param label clade label
... ...
@@ -55,7 +55,7 @@ geom_cladelabel <- function(node, label, offset=0, offset.text=0,
55 55
                                         mapping=mapping, data=data, geom=geom, hjust=hjust,
56 56
                                         position=position, show.legend = show.legend,
57 57
                                         inherit.aes = inherit.aes, na.rm=na.rm, parse=parse, ...)
58
-            
58
+
59 59
         } else {
60 60
             layer_text = stat_cladeText(node=node, label=label, offset=offset+offset.text,
61 61
                                         align=align, size=fontsize, angle=angle, fill=fill,family=family,
... ...
@@ -67,7 +67,7 @@ geom_cladelabel <- function(node, label, offset=0, offset.text=0,
67 67
 
68 68
         layer_bar <- stat_cladeBar(node=node, offset=offset, align=align,
69 69
                                    size=barsize,
70
-                                   mapping=mapping, data=data, 
70
+                                   mapping=mapping, data=data,
71 71
                                    position=position, show.legend = show.legend,
72 72
                                    inherit.aes = inherit.aes, na.rm=na.rm, ...)
73 73
     } else {
... ...
@@ -78,7 +78,7 @@ geom_cladelabel <- function(node, label, offset=0, offset.text=0,
78 78
                                         mapping=mapping, data=data, geom=geom, hjust=hjust,
79 79
                                         position=position, show.legend = show.legend,
80 80
                                         inherit.aes = inherit.aes, na.rm=na.rm, parse=parse, ...)
81
-            
81
+
82 82
         } else {
83 83
             layer_text = stat_cladeText(node=node, label=label, offset=offset+offset.text,
84 84
                                         align=align, size=fontsize, angle=angle, color=labelcolor, fill=fill,family=family,
... ...
@@ -90,12 +90,12 @@ geom_cladelabel <- function(node, label, offset=0, offset.text=0,
90 90
 
91 91
         layer_bar <- stat_cladeBar(node=node, offset=offset, align=align,
92 92
                                    size=barsize, color = barcolor,
93
-                                   mapping=mapping, data=data, 
93
+                                   mapping=mapping, data=data,
94 94
                                    position=position, show.legend = show.legend,
95 95
                                    inherit.aes = inherit.aes, na.rm=na.rm, ...)
96
-        
96
+
97 97
     }
98
-    
98
+
99 99
     list(
100 100
        layer_bar,
101 101
        layer_text
... ...
@@ -114,7 +114,7 @@ stat_cladeText <- function(mapping=NULL, data=NULL,
114 114
     } else {
115 115
         mapping <- modifyList(mapping, default_aes)
116 116
     }
117
-    
117
+
118 118
     layer(stat=StatCladeText,
119 119
           data=data,
120 120
           mapping=mapping,
... ...
@@ -130,7 +130,7 @@ stat_cladeText <- function(mapping=NULL, data=NULL,
130 130
                       parse  = parse,
131 131
                       ...)
132 132
           )
133
-    
133
+
134 134
 }
135 135
 
136 136
 stat_cladeBar <- function(mapping=NULL, data=NULL,
... ...
@@ -143,7 +143,7 @@ stat_cladeBar <- function(mapping=NULL, data=NULL,
143 143
     } else {
144 144
         mapping <- modifyList(mapping, default_aes)
145 145
     }
146
-    
146
+
147 147
     layer(stat=StatCladeBar,
148 148
           data=data,
149 149
           mapping=mapping,
... ...
@@ -170,8 +170,8 @@ StatCladeText <- ggproto("StatCladeText", Stat,
170 170
                          required_aes = c("x", "y", "label")
171 171
                          )
172 172
 
173
-                         
174
-                          
173
+
174
+
175 175
 StatCladeBar <- ggproto("StatCladBar", Stat,
176 176
                         compute_group = function(self, data, scales, params, node, offset, align) {
177 177
                             get_cladelabel_position(data, node, offset, align, adjustRatio=1.02)
... ...
@@ -199,7 +199,7 @@ get_cladelabel_position_ <- function(data, node) {
199 199
 
200 200
     y <- sp.df$y
201 201
     y <- y[!is.na(y)]
202
-    mx <- max(sp.df$x, na.rm=TRUE) 
202
+    mx <- max(sp.df$x, na.rm=TRUE)
203 203
     data.frame(x=mx, y=min(y), yend=max(y))
204 204
 }
205 205
 
... ...
@@ -1,13 +1,13 @@
1 1
 
2 2
 ##' add tip point
3 3
 ##'
4
-##' 
4
+##'
5 5
 ##' @title geom_tippoint
6 6
 ##' @inheritParams geom_point2
7 7
 ##' @return tip point layer
8 8
 ##' @export
9 9
 ##' @author Guangchuang Yu
10
-geom_tippoint <- function(mapping = NULL, data = NULL, 
10
+geom_tippoint <- function(mapping = NULL, data = NULL,
11 11
                        position = "identity", na.rm = FALSE,
12 12
                           show.legend = NA, inherit.aes = TRUE, ...) {
13 13
     isTip <- NULL
... ...
@@ -17,18 +17,18 @@ geom_tippoint <- function(mapping = NULL, data = NULL,
17 17
     } else {
18 18
         mapping %<>% modifyList(self_mapping)
19 19
     }
20
-    geom_point2(mapping, data, position, na.rm, show.legend, inherit.aes, ...)    
20
+    geom_point2(mapping, data, position, na.rm, show.legend, inherit.aes, ...)
21 21
 }
22 22
 
23 23
 ##' add node point
24 24
 ##'
25
-##' 
25
+##'
26 26
 ##' @title geom_nodepoint
27 27
 ##' @inheritParams geom_point2
28 28
 ##' @return node point layer
29 29
 ##' @export
30 30
 ##' @author Guangchuang Yu
31
-geom_nodepoint <- function(mapping = NULL, data = NULL, 
31
+geom_nodepoint <- function(mapping = NULL, data = NULL,
32 32
                        position = "identity", na.rm = FALSE,
33 33
                        show.legend = NA, inherit.aes = TRUE, ...) {
34 34
     isTip <- NULL
... ...
@@ -38,19 +38,19 @@ geom_nodepoint <- function(mapping = NULL, data = NULL,
38 38
     } else {
39 39
         mapping %<>% modifyList(self_mapping)
40 40
     }
41
-    geom_point2(mapping, data, position, na.rm, show.legend, inherit.aes, ...)    
41
+    geom_point2(mapping, data, position, na.rm, show.legend, inherit.aes, ...)
42 42
 }
43 43
 
44 44
 
45 45
 ##' add root point
46 46
 ##'
47
-##' 
47
+##'
48 48
 ##' @title geom_rootpoint
49 49
 ##' @inheritParams geom_point2
50 50
 ##' @return root point layer
51 51
 ##' @export
52 52
 ##' @author Guangchuang Yu
53
-geom_rootpoint <- function(mapping = NULL, data = NULL, 
53
+geom_rootpoint <- function(mapping = NULL, data = NULL,
54 54
                            position = "identity", na.rm = FALSE,
55 55
                            show.legend = NA, inherit.aes = TRUE, ...) {
56 56
     isTip <- node <- parent <- NULL
... ...
@@ -66,7 +66,7 @@ geom_rootpoint <- function(mapping = NULL, data = NULL,
66 66
 
67 67
 ##' geom_point2 support aes(subset) via setup_data
68 68
 ##'
69
-##' 
69
+##'
70 70
 ##' @title geom_point2
71 71
 ##' @param mapping aes mapping
72 72
 ##' @param data data
... ...
@@ -85,14 +85,14 @@ geom_point2 <- function(mapping = NULL, data = NULL,
85 85
                        position = "identity", na.rm = FALSE,
86 86
                        show.legend = NA, inherit.aes = TRUE, ...) {
87 87
 
88
-    
88
+
89 89
     default_aes <- aes_(node=~node)
90 90
     if (is.null(mapping)) {
91 91
         mapping <- default_aes
92 92
     } else {
93 93
         mapping <- modifyList(mapping, default_aes)
94 94
     }
95
-    
95
+
96 96
     layer(
97 97
         data = data,
98 98
         mapping = mapping,
... ...
@@ -116,14 +116,16 @@ GeomPointGGtree <- ggproto("GeomPointGGtree", GeomPoint,
116 116
                                if (is.null(data$subset))
117 117
                                    return(data)
118 118
                                data[data$subset,]
119
-                           }  ## ,
120
-                           
119
+                           }
120
+
121
+                           ## ,
122
+
121 123
                            ## draw_panel = function(data, panel_scales, coord, na.rm = FALSE){
122 124
                            ##     GeomPoint$draw_panel(data, panel_scales, coord, na.rm)
123 125
                            ## },
124
-                           
126
+
125 127
                            ## draw_key = draw_key_point,
126
-                           
128
+
127 129
                            ## required_aes = c("x", "y"),
128 130
                            ## default_aes = aes(shape = 19, colour = "black", size = 1.5, fill = NA,
129 131
                            ##                   alpha = NA, stroke = 0.5)
... ...
@@ -1,6 +1,6 @@
1 1
 ##' geom_text2 support aes(subset) via setup_data
2 2
 ##'
3
-##' 
3
+##'
4 4
 ##' @title geom_text2
5 5
 ##' @param mapping the aesthetic mapping
6 6
 ##' @param data A layer specific dataset -
... ...
@@ -29,17 +29,17 @@ geom_text2 <- function(mapping = NULL, data = NULL,
29 29
         if (!missing(position)) {
30 30
             stop("Specify either `position` or `nudge_x`/`nudge_y`", call. = FALSE)
31 31
         }
32
-        
32
+
33 33
         position <- position_nudge(nudge_x, nudge_y)
34 34
     }
35
-    
35
+
36 36
     default_aes <- aes_(node=~node)
37 37
     if (is.null(mapping)) {
38 38
         mapping <- default_aes
39 39
     } else {
40 40
         mapping <- modifyList(mapping, default_aes)
41 41
     }
42
-    
42
+
43 43
     layer(
44 44
         data = data,
45 45
         mapping = mapping,
... ...
@@ -66,16 +66,19 @@ GeomTextGGtree <- ggproto("GeomTextGGtree", GeomText,
66 66
                                   return(data)
67 67
                               data[data$subset,]
68 68
                           },
69
+                          ## compute_group = function(data, params) {
70
+                          ##     data
71
+                          ## },
69 72
                           draw_panel = function(data, panel_scales, coord, parse = FALSE,
70 73
                               na.rm = TRUE, check_overlap = FALSE) {
71 74
                               GeomText$draw_panel(data, panel_scales, coord, parse,
72 75
                                                   na.rm, check_overlap)
73 76
                           },
74 77
                           required_aes = c("node", "x", "y", "label"),
75
-                          
78
+
76 79
                           default_aes = aes(colour = "black", size = 3.88, angle = 0, hjust = 0.5,
77 80
                               vjust = 0.5, alpha = NA, family = "", fontface = 1, lineheight = 1.2),
78
-                          
81
+
79 82
                           draw_key = draw_key_text
80 83
                           )
81 84
 
... ...
@@ -1,6 +1,6 @@
1 1
 ##' add tree layer
2 2
 ##'
3
-##' 
3
+##'
4 4
 ##' @title geom_tree
5 5
 ##' @param mapping aesthetic mapping
6 6
 ##' @param data data
... ...
@@ -14,7 +14,7 @@
14 14
 ##' @author Yu Guangchuang
15 15
 geom_tree <- function(mapping=NULL, data=NULL, layout="rectangular", multiPhylo=FALSE, ...) {
16 16
     stat_tree(data=data, mapping=mapping, geom="segment",
17
-              layout=layout, multiPhylo=multiPhylo, lineend="round", 
17
+              layout=layout, multiPhylo=multiPhylo, lineend="round",
18 18
               position='identity', show.legend=NA,
19 19
               inherit.aes=TRUE, na.rm=TRUE, ...)
20 20
 }
... ...
@@ -23,12 +23,12 @@ geom_tree <- function(mapping=NULL, data=NULL, layout="rectangular", multiPhylo=
23 23
 stat_tree <- function(mapping=NULL, data=NULL, geom="segment", position="identity",
24 24
                       layout="rectangular", multiPhylo=FALSE, lineend="round", ...,
25 25
                       show.legend=NA, inherit.aes=TRUE, na.rm=FALSE) {
26
-    
26
+
27 27
     default_aes <- aes_(x=~x, y=~y,node=~node, parent=~parent)
28 28
     if (multiPhylo) {
29 29
         default_aes <- modifyList(default_aes, aes_(.id=~.id))
30 30
     }
31
-    
31
+
32 32
     if (is.null(mapping)) {
33 33
         mapping <- default_aes
34 34
     } else {
... ...
@@ -74,11 +74,14 @@ stat_tree <- function(mapping=NULL, data=NULL, geom="segment", position="identit
74 74
                           na.rm = na.rm,
75 75
                           ...)
76 76
               )
77
-    }    
77
+    }
78 78
 }
79 79
 
80 80
 StatTreeHorizontal <- ggproto("StatTreeHorizontal", Stat,
81 81
                               required_aes = c("node", "parent", "x", "y"),
82
+                              compute_group = function(data, params) {
83
+                                  data
84
+                              },
82 85
                               compute_panel = function(self, data, scales, params, layout, lineend) {
83 86
                                   .fun <- function(data) {
84 87
                                       df <- setup_tree_data(data)
... ...
@@ -90,7 +93,7 @@ StatTreeHorizontal <- ggproto("StatTreeHorizontal", Stat,
90 93
                                       df$x <- x[ii]
91 94
                                       return(df)
92 95
                                   }
93
-                                  
96
+
94 97
                                   if ('.id' %in% names(data)) {
95 98
                                       ldf <- split(data, data$.id)
96 99
                                       df <- do.call(rbind, lapply(ldf, .fun))
... ...
@@ -103,6 +106,9 @@ StatTreeHorizontal <- ggproto("StatTreeHorizontal", Stat,
103 106
 
104 107
 StatTreeVertical <- ggproto("StatTreeVertical", Stat,
105 108
                             required_aes = c("node", "parent", "x", "y"),
109
+                            compute_group = function(data, params) {
110
+                                data
111
+                            },
106 112
                             compute_panel = function(self, data, scales, params, layout, lineend) {
107 113
                                 .fun <- function(data) {
108 114
                                     df <- setup_tree_data(data)
... ...
@@ -129,6 +135,9 @@ StatTreeVertical <- ggproto("StatTreeVertical", Stat,
129 135
 
130 136
 StatTree <- ggproto("StatTree", Stat,
131 137
                     required_aes = c("node", "parent", "x", "y"),
138
+                    compute_group = function(data, params) {
139
+                        data
140
+                    },
132 141
                     compute_panel = function(self, data, scales, params, layout, lineend) {
133 142
                         .fun <- function(data) {
134 143
                             df <- setup_tree_data(data)
... ...
@@ -155,7 +164,7 @@ StatTree <- ggproto("StatTree", Stat,
155 164
 setup_tree_data <- function(data) {
156 165
     if (nrow(data) == length(unique(data$node)))
157 166
         return(data)
158
-    
167
+
159 168
     data[match(unique(data$node), data$node),]
160 169
     ## data[order(data$node, decreasing = FALSE), ]
161 170
 }
... ...
@@ -163,7 +172,7 @@ setup_tree_data <- function(data) {
163 172
 
164 173
 ##' add tree layer
165 174
 ##'
166
-##' 
175
+##'
167 176
 ##' @title geom_tree2
168 177
 ##' @param layout one of 'rectangular', 'slanted', 'circular', 'radial' or 'unrooted'
169 178
 ##' @param ... additional parameter
... ...
@@ -182,7 +191,7 @@ geom_tree2 <- function(layout="rectangular", ...) {
182 191
                              y    = y,
183 192
                              yend = y),
184 193
                          lineend  = lineend, ...),
185
-            
194
+
186 195
             geom_segment(aes(x    = x[parent],
187 196
                              xend = x[parent],
188 197
                              y    = y[parent],
... ...
@@ -1,9 +1,9 @@
1 1
 ggtree: an R package for visualization and annotation of phylogenetic trees with their covariates and other associated data
2 2
 ===========================================================================================================================
3 3
 
4
-[![releaseVersion](https://img.shields.io/badge/release%20version-1.4.20-green.svg?style=flat)](https://bioconductor.org/packages/ggtree) [![develVersion](https://img.shields.io/badge/devel%20version-1.5.14-green.svg?style=flat)](https://github.com/GuangchuangYu/ggtree) [![Bioc](http://www.bioconductor.org/shields/years-in-bioc/ggtree.svg)](https://www.bioconductor.org/packages/devel/bioc/html/ggtree.html#since) [![total](https://img.shields.io/badge/downloads-13544/total-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree) [![month](https://img.shields.io/badge/downloads-1122/month-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree)
4
+[![releaseVersion](https://img.shields.io/badge/release%20version-1.4.20-green.svg?style=flat)](https://bioconductor.org/packages/ggtree) [![develVersion](https://img.shields.io/badge/devel%20version-1.5.14-green.svg?style=flat)](https://github.com/GuangchuangYu/ggtree) [![Bioc](http://www.bioconductor.org/shields/years-in-bioc/ggtree.svg)](https://www.bioconductor.org/packages/devel/bioc/html/ggtree.html#since) [![total](https://img.shields.io/badge/downloads-13863/total-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree) [![month](https://img.shields.io/badge/downloads-1122/month-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree)
5 5
 
6
-[![Project Status: Active - The project has reached a stable, usable state and is being actively developed.](http://www.repostatus.org/badges/latest/active.svg)](http://www.repostatus.org/#active) [![codecov](https://codecov.io/gh/GuangchuangYu/ggtree/branch/master/graph/badge.svg)](https://codecov.io/gh/GuangchuangYu/ggtree) [![Last-changedate](https://img.shields.io/badge/last%20change-2016--09--26-green.svg)](https://github.com/GuangchuangYu/ggtree/commits/master) [![GitHub forks](https://img.shields.io/github/forks/GuangchuangYu/ggtree.svg)](https://github.com/GuangchuangYu/ggtree/network) [![GitHub stars](https://img.shields.io/github/stars/GuangchuangYu/ggtree.svg)](https://github.com/GuangchuangYu/ggtree/stargazers) [![Awesome](https://cdn.rawgit.com/sindresorhus/awesome/d7305f38d29fed78fa85652e3a63e154dd8e8829/media/badge.svg)](https://awesome-r.com/#awesome-r-graphic-displays)
6
+[![Project Status: Active - The project has reached a stable, usable state and is being actively developed.](http://www.repostatus.org/badges/latest/active.svg)](http://www.repostatus.org/#active) [![codecov](https://codecov.io/gh/GuangchuangYu/ggtree/branch/master/graph/badge.svg)](https://codecov.io/gh/GuangchuangYu/ggtree) [![Last-changedate](https://img.shields.io/badge/last%20change-2016--09--29-green.svg)](https://github.com/GuangchuangYu/ggtree/commits/master) [![GitHub forks](https://img.shields.io/github/forks/GuangchuangYu/ggtree.svg)](https://github.com/GuangchuangYu/ggtree/network) [![GitHub stars](https://img.shields.io/github/stars/GuangchuangYu/ggtree.svg)](https://github.com/GuangchuangYu/ggtree/stargazers) [![Awesome](https://cdn.rawgit.com/sindresorhus/awesome/d7305f38d29fed78fa85652e3a63e154dd8e8829/media/badge.svg)](https://awesome-r.com/#awesome-r-graphic-displays)
7 7
 
8 8
 [![platform](http://www.bioconductor.org/shields/availability/devel/ggtree.svg)](https://www.bioconductor.org/packages/devel/bioc/html/ggtree.html#archives) [![Build Status](http://www.bioconductor.org/shields/build/devel/bioc/ggtree.svg)](https://bioconductor.org/checkResults/devel/bioc-LATEST/ggtree/) [![Linux/Mac Travis Build Status](https://img.shields.io/travis/GuangchuangYu/ggtree/master.svg?label=Mac%20OSX%20%26%20Linux)](https://travis-ci.org/GuangchuangYu/ggtree) [![AppVeyor Build Status](https://img.shields.io/appveyor/ci/Guangchuangyu/ggtree/master.svg?label=Windows)](https://ci.appveyor.com/project/GuangchuangYu/ggtree) [![install with bioconda](https://img.shields.io/badge/install%20with-bioconda-green.svg?style=flat)](http://bioconda.github.io/recipes/bioconductor-ggtree/README.html)
9 9
 
... ...
@@ -50,7 +50,7 @@ For details, please visit our project website, <https://guangchuangyu.github.io/
50 50
 
51 51
 ### Download stats
52 52
 
53
-[![download](http://www.bioconductor.org/shields/downloads/ggtree.svg)](https://bioconductor.org/packages/stats/bioc/ggtree/) [![total](https://img.shields.io/badge/downloads-13544/total-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree) [![month](https://img.shields.io/badge/downloads-1122/month-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree)
53
+[![download](http://www.bioconductor.org/shields/downloads/ggtree.svg)](https://bioconductor.org/packages/stats/bioc/ggtree/) [![total](https://img.shields.io/badge/downloads-13863/total-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree) [![month](https://img.shields.io/badge/downloads-1122/month-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree)
54 54
 
55 55
          +--------------------------+--------------------------+--------------------------+------------+
56 56
          |                                                                               *             |