Browse code

geom_label2

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

g.yu authored on 07/04/2016 04:02:44
Showing 15 changed files

... ...
@@ -38,6 +38,7 @@ export(flip)
38 38
 export(geom_aline)
39 39
 export(geom_cladelabel)
40 40
 export(geom_hilight)
41
+export(geom_label2)
41 42
 export(geom_nodepoint)
42 43
 export(geom_point2)
43 44
 export(geom_range)
... ...
@@ -156,6 +157,7 @@ importFrom(ape,which.edge)
156 157
 importFrom(ape,write.tree)
157 158
 importFrom(ggplot2,"%+replace%")
158 159
 importFrom(ggplot2,GeomCurve)
160
+importFrom(ggplot2,GeomLabel)
159 161
 importFrom(ggplot2,GeomPoint)
160 162
 importFrom(ggplot2,GeomRect)
161 163
 importFrom(ggplot2,GeomSegment)
... ...
@@ -1,5 +1,7 @@
1 1
 CHANGES IN VERSION 1.3.15
2 2
 ------------------------
3
+ o geom_tiplab and geom_tiplab2 support using geom_label2 by passing geom="label" <2016-04-07, Thu>
4
+ o geom_label2 that support subsetting <2016-04-07, Thu>
3 5
  o geom_tiplab2 for adding tip label of circular layout <2016-04-06, Wed>
4 6
  o use plot$plot_env to access ggplot2 parameter <2016-04-06, Wed>
5 7
  o geom_taxalink for connecting related taxa <2016-04-01, Fri> 
6 8
new file mode 100644
... ...
@@ -0,0 +1,101 @@
1
+##' geom_text2 support aes(subset) via setup_data
2
+##'
3
+##' 
4
+##' @title geom_text2
5
+##' @param mapping the aesthetic mapping
6
+##' @param data A layer specific dataset -
7
+##'             only needed if you want to override he plot defaults.
8
+##' @param ... other arguments passed on to 'layer'
9
+##' @param parse if TRUE, the labels will be passd into expressions
10
+##' @param nudge_x horizontal adjustment
11
+##' @param nudge_y vertical adjustment
12
+##' @param label.padding Amount of padding around label. 
13
+##' @param label.r Radius of rounded corners.
14
+##' @param label.size Size of label border, in mm
15
+##' @param na.rm logical
16
+##' @param show.legend logical
17
+##' @param inherit.aes logical
18
+##' @return label layer
19
+##' @importFrom ggplot2 layer
20
+##' @importFrom ggplot2 position_nudge
21
+##' @export
22
+##' @seealso
23
+##' \link[ggplot2]{geom_label}
24
+##' @author Guangchuang Yu
25
+geom_label2 <- function(mapping = NULL, data = NULL,
26
+                        ...,
27
+                        parse = FALSE,
28
+                        nudge_x = 0,
29
+                        nudge_y = 0,
30
+                        label.padding = unit(0.25, "lines"),
31
+                        label.r = unit(0.15, "lines"),
32
+                        label.size = 0.25,
33
+                        na.rm = TRUE,
34
+                        show.legend = NA,
35
+                        inherit.aes = TRUE) {
36
+
37
+    position = "identity"
38
+    
39
+    if (!missing(nudge_x) || !missing(nudge_y)) {
40
+        if (!missing(position)) {
41
+            stop("Specify either `position` or `nudge_x`/`nudge_y`", call. = FALSE)
42
+        }
43
+        
44
+        position <- position_nudge(nudge_x, nudge_y)
45
+    }
46
+    
47
+    default_aes <- aes_(node=~node)
48
+    if (is.null(mapping)) {
49
+        mapping <- default_aes
50
+    } else {
51
+        mapping <- modifyList(mapping, default_aes)
52
+    }
53
+    
54
+    layer(
55
+        data = data,
56
+        mapping = mapping,
57
+        stat = StatTreeData,
58
+        geom = GeomLabelGGtree,
59
+        position = position,
60
+        show.legend = show.legend,
61
+        inherit.aes = inherit.aes,
62
+        params = list(
63
+            parse = parse,
64
+            label.padding = label.padding,
65
+            label.r = label.r,
66
+            label.size = label.size,
67
+            na.rm = na.rm,
68
+            ...
69
+        )
70
+    )
71
+}
72
+
73
+
74
+
75
+##' @importFrom ggplot2 GeomLabel
76
+GeomLabelGGtree <- ggproto("GeomLabelGGtree", GeomLabel,
77
+                           setup_data = function(data, params) {
78
+                               if (is.null(data$subset))
79
+                                   return(data)
80
+                               data[data$subset,]
81
+                           },
82
+                           draw_panel = function(self, data, panel_scales, coord, parse = FALSE,
83
+                                                 na.rm = FALSE,
84
+                                                 label.padding = unit(0.25, "lines"),
85
+                                                 label.r = unit(0.15, "lines"),
86
+                                                 label.size = 0.25) {
87
+                               GeomLabel$draw_panel(data, panel_scales, coord, parse,
88
+                                                   na.rm, label.padding, label.r, label.size)
89
+                           },
90
+                           required_aes = c("node", "x", "y", "label"),
91
+                           
92
+                           default_aes = aes(
93
+                               colour = "black", fill = "white", size = 3.88, angle = 0,
94
+                               hjust = 0.5, vjust = 0.5, alpha = NA, family = "", fontface = 1,
95
+                               lineheight = 1.2
96
+                           ),
97
+                           
98
+                           draw_key = draw_key_label
99
+                           )
100
+
101
+
... ...
@@ -7,7 +7,7 @@
7 7
 ##' @return tip point layer
8 8
 ##' @export
9 9
 ##' @author Guangchuang Yu
10
-geom_tippoint <- function(mapping = NULL, data = NULL, stat = "identity",
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,7 +17,7 @@ geom_tippoint <- function(mapping = NULL, data = NULL, stat = "identity",
17 17
     } else {
18 18
         mapping %<>% modifyList(self_mapping)
19 19
     }
20
-    geom_point2(mapping, data, stat, 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
... ...
@@ -28,7 +28,7 @@ geom_tippoint <- function(mapping = NULL, data = NULL, stat = "identity",
28 28
 ##' @return node point layer
29 29
 ##' @export
30 30
 ##' @author Guangchuang Yu
31
-geom_nodepoint <- function(mapping = NULL, data = NULL, stat = "identity",
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,7 +38,7 @@ geom_nodepoint <- function(mapping = NULL, data = NULL, stat = "identity",
38 38
     } else {
39 39
         mapping %<>% modifyList(self_mapping)
40 40
     }
41
-    geom_point2(mapping, data, stat, 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
 
... ...
@@ -50,7 +50,7 @@ geom_nodepoint <- function(mapping = NULL, data = NULL, stat = "identity",
50 50
 ##' @return root point layer
51 51
 ##' @export
52 52
 ##' @author Guangchuang Yu
53
-geom_rootpoint <- function(mapping = NULL, data = NULL, stat = "identity",
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
... ...
@@ -60,7 +60,7 @@ geom_rootpoint <- function(mapping = NULL, data = NULL, stat = "identity",
60 60
     } else {
61 61
         mapping %<>% modifyList(self_mapping)
62 62
     }
63
-    geom_point2(mapping, data, stat, position, na.rm, show.legend, inherit.aes, ...)
63
+    geom_point2(mapping, data, position, na.rm, show.legend, inherit.aes, ...)
64 64
 }
65 65
 
66 66
 
... ...
@@ -70,7 +70,6 @@ geom_rootpoint <- function(mapping = NULL, data = NULL, stat = "identity",
70 70
 ##' @title geom_point2
71 71
 ##' @param mapping aes mapping
72 72
 ##' @param data data
73
-##' @param stat stat
74 73
 ##' @param position position
75 74
 ##' @param na.rm logical
76 75
 ##' @param show.legend logical
... ...
@@ -82,7 +81,7 @@ geom_rootpoint <- function(mapping = NULL, data = NULL, stat = "identity",
82 81
 ##' \link[ggplot2]{geom_point}
83 82
 ##' @return point layer
84 83
 ##' @author Guangchuang Yu
85
-geom_point2 <- function(mapping = NULL, data = NULL, stat = "identity",
84
+geom_point2 <- function(mapping = NULL, data = NULL,
86 85
                        position = "identity", na.rm = FALSE,
87 86
                        show.legend = NA, inherit.aes = TRUE, ...) {
88 87
 
... ...
@@ -97,7 +96,7 @@ geom_point2 <- function(mapping = NULL, data = NULL, stat = "identity",
97 96
     layer(
98 97
         data = data,
99 98
         mapping = mapping,
100
-        stat = StatTreePoint,
99
+        stat = StatTreeData,
101 100
         geom = GeomPointGGtree,
102 101
         position = position,
103 102
         show.legend = show.legend,
... ...
@@ -130,10 +129,3 @@ GeomPointGGtree <- ggproto("GeomPointGGtree", GeomPoint,
130 129
                            ##                   alpha = NA, stroke = 0.5)
131 130
                             )
132 131
 
133
-
134
-StatTreePoint <-  ggproto("StatTreePoint", Stat,
135
-                          required_aes = "node",
136
-                          compute_group = function(data, scales) {
137
-                              setup_tree_data(data)
138
-                          }
139
-                          )
... ...
@@ -29,7 +29,6 @@ geom_aline <- function(mapping=NULL, linetype="dotted", size=1, ...) {
29 29
 ##' @title geom_segment2
30 30
 ##' @param mapping aes mapping 
31 31
 ##' @param data data
32
-##' @param stat stat
33 32
 ##' @param position position
34 33
 ##' @param arrow arrow
35 34
 ##' @param lineend lineend
... ...
@@ -43,7 +42,7 @@ geom_aline <- function(mapping=NULL, linetype="dotted", size=1, ...) {
43 42
 ##' \link[ggplot2]{geom_segment}
44 43
 ##' @return add segment layer
45 44
 ##' @author Guangchuang Yu
46
-geom_segment2 <- function(mapping = NULL, data = NULL, stat = "identity",
45
+geom_segment2 <- function(mapping = NULL, data = NULL, 
47 46
                          position = "identity", arrow = NULL, lineend = "butt",
48 47
                          na.rm = FALSE, show.legend = NA, inherit.aes = TRUE,
49 48
                          ...) {
... ...
@@ -58,7 +57,7 @@ geom_segment2 <- function(mapping = NULL, data = NULL, stat = "identity",
58 57
     layer(
59 58
         data = data,
60 59
         mapping = mapping,
61
-        stat = StatTreeSegment,
60
+        stat = StatTreeData,
62 61
         geom = GeomSegmentGGtree,
63 62
         position = position,
64 63
         show.legend = show.legend,
... ...
@@ -95,11 +94,5 @@ GeomSegmentGGtree <- ggproto("GeomSegmentGGtree", GeomSegment,
95 94
                              )
96 95
 
97 96
 
98
-StatTreeSegment <-  ggproto("StatTreeSegment", Stat,
99
-                          required_aes = "node",
100
-                          compute_group = function(data, scales) {
101
-                              setup_tree_data(data)
102
-                          }
103
-                          )
104 97
 
105 98
 
... ...
@@ -5,7 +5,6 @@
5 5
 ##' @param mapping the aesthetic mapping
6 6
 ##' @param data A layer specific dataset -
7 7
 ##'             only needed if you want to override he plot defaults.
8
-##' @param stat The statistical transformation to use on the data for this layer
9 8
 ##' @param position The position adjustment to use for overlapping points on this layer
10 9
 ##' @param parse if TRUE, the labels will be passd into expressions
11 10
 ##' @param na.rm logical
... ...
@@ -22,7 +21,7 @@
22 21
 ##' @seealso
23 22
 ##' \link[ggplot2]{geom_text}
24 23
 ##' @author Guangchuang Yu
25
-geom_text2 <- function(mapping = NULL, data = NULL, stat = "identity",
24
+geom_text2 <- function(mapping = NULL, data = NULL,
26 25
                        position = "identity", parse = FALSE, na.rm=TRUE, show.legend = NA, inherit.aes = TRUE,
27 26
                        ..., nudge_x = 0, nudge_y = 0, check_overlap = FALSE) {
28 27
 
... ...
@@ -44,7 +43,7 @@ geom_text2 <- function(mapping = NULL, data = NULL, stat = "identity",
44 43
     layer(
45 44
         data = data,
46 45
         mapping = mapping,
47
-        stat = StatTreeLabel,
46
+        stat = StatTreeData,
48 47
         geom = GeomTextGGtree,
49 48
         position = position,
50 49
         show.legend = show.legend,
... ...
@@ -80,11 +79,11 @@ GeomTextGGtree <- ggproto("GeomTextGGtree", GeomText,
80 79
                           draw_key = draw_key_text
81 80
                           )
82 81
 
83
-StatTreeLabel <-  ggproto("StatTreeLabel", Stat,
84
-                          required_aes = "node",
85
-                          compute_group = function(data, scales) {
86
-                              setup_tree_data(data)
87
-                          }
88
-                          )
82
+StatTreeData <-  ggproto("StatTreeLabel", Stat,
83
+                         required_aes = "node",
84
+                         compute_group = function(data, scales) {
85
+                             setup_tree_data(data)
86
+                         }
87
+                         )
89 88
 
90 89
 
... ...
@@ -7,6 +7,7 @@
7 7
 ##' @param align align tip lab or not, logical
8 8
 ##' @param linetype linetype for adding line if align = TRUE
9 9
 ##' @param linesize line size of line if align = TRUE
10
+##' @param geom one of 'text' and 'label'
10 11
 ##' @param ... additional parameter
11 12
 ##' @return tip label layer
12 13
 ##' @importFrom ggplot2 geom_text
... ...
@@ -16,7 +17,9 @@
16 17
 ##' require(ape)
17 18
 ##' tr <- rtree(10)
18 19
 ##' ggtree(tr) + geom_tiplab()
19
-geom_tiplab <- function(mapping=NULL, hjust = 0, align = FALSE, linetype = "dotted", linesize=1, ...) {
20
+geom_tiplab <- function(mapping=NULL, hjust = 0, align = FALSE, linetype = "dotted", linesize=1, geom="text", ...) {
21
+    geom <- match.arg(geom, c("text", "label"))
22
+
20 23
     x <- y <- label <- isTip <- NULL
21 24
     if (align == TRUE) {
22 25
         self_mapping <- aes(x = max(x, na.rm=TRUE) + diff(range(x, na.rm=TRUE))/200, y = y, label = label, subset= isTip)
... ...
@@ -40,13 +43,18 @@ geom_tiplab <- function(mapping=NULL, hjust = 0, align = FALSE, linetype = "dott
40 43
     } 
41 44
     
42 45
     list(
43
-        geom_text2(mapping=text_mapping, 
44
-                   hjust = hjust, ...),
46
+        if (geom == "text") {
47
+            geom_text2(mapping=text_mapping, 
48
+                       hjust = hjust, ...)
49
+        } else {
50
+            geom_label2(mapping=text_mapping, 
51
+                        hjust = hjust, ...)
52
+        },
45 53
         if (!is.null(dot_mapping))
46 54
             geom_segment2(mapping=dot_mapping,
47 55
                           linetype = linetype,
48 56
                           size = linesize, ...)
49
-        )
57
+    )
50 58
 }
51 59
 
52 60
 
53 61
new file mode 100644
... ...
@@ -0,0 +1,50 @@
1
+% Generated by roxygen2: do not edit by hand
2
+% Please edit documentation in R/geom_label.R
3
+\name{geom_label2}
4
+\alias{geom_label2}
5
+\title{geom_text2}
6
+\usage{
7
+geom_label2(mapping = NULL, data = NULL, ..., parse = FALSE,
8
+  nudge_x = 0, nudge_y = 0, label.padding = unit(0.25, "lines"),
9
+  label.r = unit(0.15, "lines"), label.size = 0.25, na.rm = TRUE,
10
+  show.legend = NA, inherit.aes = TRUE)
11
+}
12
+\arguments{
13
+\item{mapping}{the aesthetic mapping}
14
+
15
+\item{data}{A layer specific dataset -
16
+only needed if you want to override he plot defaults.}
17
+
18
+\item{...}{other arguments passed on to 'layer'}
19
+
20
+\item{parse}{if TRUE, the labels will be passd into expressions}
21
+
22
+\item{nudge_x}{horizontal adjustment}
23
+
24
+\item{nudge_y}{vertical adjustment}
25
+
26
+\item{label.padding}{Amount of padding around label.}
27
+
28
+\item{label.r}{Radius of rounded corners.}
29
+
30
+\item{label.size}{Size of label border, in mm}
31
+
32
+\item{na.rm}{logical}
33
+
34
+\item{show.legend}{logical}
35
+
36
+\item{inherit.aes}{logical}
37
+}
38
+\value{
39
+label layer
40
+}
41
+\description{
42
+geom_text2 support aes(subset) via setup_data
43
+}
44
+\author{
45
+Guangchuang Yu
46
+}
47
+\seealso{
48
+\link[ggplot2]{geom_label}
49
+}
50
+
... ...
@@ -4,17 +4,14 @@
4 4
 \alias{geom_nodepoint}
5 5
 \title{geom_nodepoint}
6 6
 \usage{
7
-geom_nodepoint(mapping = NULL, data = NULL, stat = "identity",
8
-  position = "identity", na.rm = FALSE, show.legend = NA,
9
-  inherit.aes = TRUE, ...)
7
+geom_nodepoint(mapping = NULL, data = NULL, position = "identity",
8
+  na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, ...)
10 9
 }
11 10
 \arguments{
12 11
 \item{mapping}{aes mapping}
13 12
 
14 13
 \item{data}{data}
15 14
 
16
-\item{stat}{stat}
17
-
18 15
 \item{position}{position}
19 16
 
20 17
 \item{na.rm}{logical}
... ...
@@ -4,17 +4,14 @@
4 4
 \alias{geom_point2}
5 5
 \title{geom_point2}
6 6
 \usage{
7
-geom_point2(mapping = NULL, data = NULL, stat = "identity",
8
-  position = "identity", na.rm = FALSE, show.legend = NA,
9
-  inherit.aes = TRUE, ...)
7
+geom_point2(mapping = NULL, data = NULL, position = "identity",
8
+  na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, ...)
10 9
 }
11 10
 \arguments{
12 11
 \item{mapping}{aes mapping}
13 12
 
14 13
 \item{data}{data}
15 14
 
16
-\item{stat}{stat}
17
-
18 15
 \item{position}{position}
19 16
 
20 17
 \item{na.rm}{logical}
... ...
@@ -4,17 +4,14 @@
4 4
 \alias{geom_rootpoint}
5 5
 \title{geom_rootpoint}
6 6
 \usage{
7
-geom_rootpoint(mapping = NULL, data = NULL, stat = "identity",
8
-  position = "identity", na.rm = FALSE, show.legend = NA,
9
-  inherit.aes = TRUE, ...)
7
+geom_rootpoint(mapping = NULL, data = NULL, position = "identity",
8
+  na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, ...)
10 9
 }
11 10
 \arguments{
12 11
 \item{mapping}{aes mapping}
13 12
 
14 13
 \item{data}{data}
15 14
 
16
-\item{stat}{stat}
17
-
18 15
 \item{position}{position}
19 16
 
20 17
 \item{na.rm}{logical}
... ...
@@ -4,17 +4,15 @@
4 4
 \alias{geom_segment2}
5 5
 \title{geom_segment2}
6 6
 \usage{
7
-geom_segment2(mapping = NULL, data = NULL, stat = "identity",
8
-  position = "identity", arrow = NULL, lineend = "butt", na.rm = FALSE,
9
-  show.legend = NA, inherit.aes = TRUE, ...)
7
+geom_segment2(mapping = NULL, data = NULL, position = "identity",
8
+  arrow = NULL, lineend = "butt", na.rm = FALSE, show.legend = NA,
9
+  inherit.aes = TRUE, ...)
10 10
 }
11 11
 \arguments{
12 12
 \item{mapping}{aes mapping}
13 13
 
14 14
 \item{data}{data}
15 15
 
16
-\item{stat}{stat}
17
-
18 16
 \item{position}{position}
19 17
 
20 18
 \item{arrow}{arrow}
... ...
@@ -4,10 +4,9 @@
4 4
 \alias{geom_text2}
5 5
 \title{geom_text2}
6 6
 \usage{
7
-geom_text2(mapping = NULL, data = NULL, stat = "identity",
8
-  position = "identity", parse = FALSE, na.rm = TRUE, show.legend = NA,
9
-  inherit.aes = TRUE, ..., nudge_x = 0, nudge_y = 0,
10
-  check_overlap = FALSE)
7
+geom_text2(mapping = NULL, data = NULL, position = "identity",
8
+  parse = FALSE, na.rm = TRUE, show.legend = NA, inherit.aes = TRUE,
9
+  ..., nudge_x = 0, nudge_y = 0, check_overlap = FALSE)
11 10
 }
12 11
 \arguments{
13 12
 \item{mapping}{the aesthetic mapping}
... ...
@@ -15,8 +14,6 @@ geom_text2(mapping = NULL, data = NULL, stat = "identity",
15 14
 \item{data}{A layer specific dataset -
16 15
 only needed if you want to override he plot defaults.}
17 16
 
18
-\item{stat}{The statistical transformation to use on the data for this layer}
19
-
20 17
 \item{position}{The position adjustment to use for overlapping points on this layer}
21 18
 
22 19
 \item{parse}{if TRUE, the labels will be passd into expressions}
... ...
@@ -5,7 +5,7 @@
5 5
 \title{geom_tiplab}
6 6
 \usage{
7 7
 geom_tiplab(mapping = NULL, hjust = 0, align = FALSE,
8
-  linetype = "dotted", linesize = 1, ...)
8
+  linetype = "dotted", linesize = 1, geom = "text", ...)
9 9
 }
10 10
 \arguments{
11 11
 \item{mapping}{aes mapping}
... ...
@@ -18,6 +18,8 @@ geom_tiplab(mapping = NULL, hjust = 0, align = FALSE,
18 18
 
19 19
 \item{linesize}{line size of line if align = TRUE}
20 20
 
21
+\item{geom}{one of 'text' and 'label'}
22
+
21 23
 \item{...}{additional parameter}
22 24
 }
23 25
 \value{
... ...
@@ -4,17 +4,14 @@
4 4
 \alias{geom_tippoint}
5 5
 \title{geom_tippoint}
6 6
 \usage{
7
-geom_tippoint(mapping = NULL, data = NULL, stat = "identity",
8
-  position = "identity", na.rm = FALSE, show.legend = NA,
9
-  inherit.aes = TRUE, ...)
7
+geom_tippoint(mapping = NULL, data = NULL, position = "identity",
8
+  na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, ...)
10 9
 }
11 10
 \arguments{
12 11
 \item{mapping}{aes mapping}
13 12
 
14 13
 \item{data}{data}
15 14
 
16
-\item{stat}{stat}
17
-
18 15
 \item{position}{position}
19 16
 
20 17
 \item{na.rm}{logical}