Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 260 lines (207 sloc) 7.906 kb
953fe47 @hadley Convert all documentation to roxygen
authored
1 # Create a new layer
2 # Layer objects store the layer of an object.
1244716 @hadley Trim whitespace
authored
3 #
953fe47 @hadley Convert all documentation to roxygen
authored
4 # They have the following attributes:
1244716 @hadley Trim whitespace
authored
5 #
953fe47 @hadley Convert all documentation to roxygen
authored
6 # * data
7 # * geom + parameters
8 # * statistic + parameters
9 # * position + parameters
10 # * aesthetic mapping
f86530b @kohske In layer object, parameter `guide` is changed to `show_guide`.
kohske authored
11 # * flag for display guide: TRUE/FALSE/NA. in the case of NA, decision depends on a guide itself.
1244716 @hadley Trim whitespace
authored
12 #
953fe47 @hadley Convert all documentation to roxygen
authored
13 # Can think about grob creation as a series of data frame transformations.
1244716 @hadley Trim whitespace
authored
14 Layer <- proto(expr = {
6198457 @hadley Add ggplot
authored
15 geom <- NULL
16 geom_params <- NULL
17 stat <- NULL
18 stat_params <- NULL
19 data <- NULL
20 mapping <- NULL
21 position <- NULL
22 params <- NULL
f6ce47d @hadley More work on abline, hline, vline
authored
23 inherit.aes <- FALSE
1244716 @hadley Trim whitespace
authored
24
f86530b @kohske In layer object, parameter `guide` is changed to `show_guide`.
kohske authored
25 new <- function (., geom=NULL, geom_params=NULL, stat=NULL, stat_params=NULL, data=NULL, mapping=NULL, position=NULL, params=NULL, ..., inherit.aes = TRUE, legend = NA, subset = NULL, show_guide = NA) {
db88744 @kohske guide specification in stat_XXX and geom_XXX: moves from legend to gu…
kohske authored
26
27 # now, as for the guide, we can choose only if the layer is included or not in the guide: guide = TRUE or guide = FALSE
28 # in future, it may be better if we can choose which aes of this layer is included in the guide, e.g.: guide = c(colour = TRUE, size = FALSE)
29 if (!is.na(legend)) {
64d0f5a @wch Add gg_dep function for gradual deprecation
wch authored
30 gg_dep("0.8.9", "\"legend\" argument in geom_XXX and stat_XXX is deprecated. Use show_guide = TRUE or show_guide = FALSE for display or suppress the guide display.")
f86530b @kohske In layer object, parameter `guide` is changed to `show_guide`.
kohske authored
31 show_guide = legend
db88744 @kohske guide specification in stat_XXX and geom_XXX: moves from legend to gu…
kohske authored
32 }
33
f86530b @kohske In layer object, parameter `guide` is changed to `show_guide`.
kohske authored
34 if (!is.na(show_guide) && !is.logical(show_guide)) {
35 warning("`show_guide` in geom_XXX and stat_XXX must be logical.")
36 show_guide = FALSE
db88744 @kohske guide specification in stat_XXX and geom_XXX: moves from legend to gu…
kohske authored
37 }
38
1244716 @hadley Trim whitespace
authored
39
6198457 @hadley Add ggplot
authored
40 if (is.null(geom) && is.null(stat)) stop("Need at least one of stat and geom")
1244716 @hadley Trim whitespace
authored
41
376fb86 @hadley New annotation function, plus changes to support it.
authored
42 data <- fortify(data)
6198457 @hadley Add ggplot
authored
43 if (!is.null(mapping) && !inherits(mapping, "uneval")) stop("Mapping should be a list of unevaluated mappings created by aes or aes_string")
1244716 @hadley Trim whitespace
authored
44
6198457 @hadley Add ggplot
authored
45 if (is.character(geom)) geom <- Geom$find(geom)
46 if (is.character(stat)) stat <- Stat$find(stat)
fea6679 @hadley Further improvement to digest algorithm
authored
47 if (is.character(position)) position <- Position$find(position)$new()
1244716 @hadley Trim whitespace
authored
48
6198457 @hadley Add ggplot
authored
49 if (is.null(geom)) geom <- stat$default_geom()
50 if (is.null(stat)) stat <- geom$default_stat()
fea6679 @hadley Further improvement to digest algorithm
authored
51 if (is.null(position)) position <- geom$default_pos()$new()
6198457 @hadley Add ggplot
authored
52
53 match.params <- function(possible, params) {
54 if ("..." %in% names(possible)) {
55 params
56 } else {
57 params[match(names(possible), names(params), nomatch=0)]
58 }
59 }
0c98379 @hadley Convert American spelling and old R abbreviations to ggplot2 names.
authored
60
6198457 @hadley Add ggplot
authored
61 if (is.null(geom_params) && is.null(stat_params)) {
62 params <- c(params, list(...))
0c98379 @hadley Convert American spelling and old R abbreviations to ggplot2 names.
authored
63 params <- rename_aes(params) # Rename American to British spellings etc
1244716 @hadley Trim whitespace
authored
64
6198457 @hadley Add ggplot
authored
65 geom_params <- match.params(geom$parameters(), params)
66 stat_params <- match.params(stat$parameters(), params)
0c98379 @hadley Convert American spelling and old R abbreviations to ggplot2 names.
authored
67 stat_params <- stat_params[setdiff(names(stat_params),
68 names(geom_params))]
1244716 @hadley Trim whitespace
authored
69 } else {
0c98379 @hadley Convert American spelling and old R abbreviations to ggplot2 names.
authored
70 geom_params <- rename_aes(geom_params)
6198457 @hadley Add ggplot
authored
71 }
1244716 @hadley Trim whitespace
authored
72
73 proto(.,
74 geom=geom, geom_params=geom_params,
75 stat=stat, stat_params=stat_params,
d1fe9b7 @hadley Subset argument for layers
authored
76 data=data, mapping=mapping, subset=subset,
3c9064a @hadley Add flag to ignore extra aesthetics
authored
77 position=position,
f6ce47d @hadley More work on abline, hline, vline
authored
78 inherit.aes = inherit.aes,
f86530b @kohske In layer object, parameter `guide` is changed to `show_guide`.
kohske authored
79 show_guide = show_guide,
3c9064a @hadley Add flag to ignore extra aesthetics
authored
80 )
6198457 @hadley Add ggplot
authored
81 }
1244716 @hadley Trim whitespace
authored
82
0aa2482 @hadley Add more documentation. Fix bug in scale and layer cloning
authored
83 clone <- function(.) as.proto(.$as.list(all.names=TRUE))
1244716 @hadley Trim whitespace
authored
84
6198457 @hadley Add ggplot
authored
85 use_defaults <- function(., data) {
87b7474 @hadley Fix bug in use_defaults
authored
86 df <- aesdefaults(data, .$geom$default_aes(), NULL)
1244716 @hadley Trim whitespace
authored
87
87b7474 @hadley Fix bug in use_defaults
authored
88 # Override mappings with atomic parameters
72ff2c2 @hadley Minor cleaning and bug fixes
authored
89 gp <- intersect(c(names(df), .$geom$required_aes), names(.$geom_params))
87b7474 @hadley Fix bug in use_defaults
authored
90 gp <- gp[unlist(lapply(.$geom_params[gp], is.atomic))]
b25b52b @hadley Fix weird legend bug
authored
91
d92a316 @hadley Set aesthetics no longer need to be length 1.
authored
92 # Check that mappings are compatable length: either 1 or the same length
93 # as the data
94 param_lengths <- vapply(.$geom_params[gp], length, numeric(1))
95 bad <- param_lengths != 1L & param_lengths != nrow(df)
96 if (any(bad)) {
1244716 @hadley Trim whitespace
authored
97 stop("Incompatible lengths for set aesthetics: ",
d92a316 @hadley Set aesthetics no longer need to be length 1.
authored
98 paste(names(bad), collapse = ", "), call. = FALSE)
99 }
100
6198457 @hadley Add ggplot
authored
101 df[gp] <- .$geom_params[gp]
102 df
103 }
1244716 @hadley Trim whitespace
authored
104
b19ff3f @hadley Port over the last changes. Now to get it working
authored
105 layer_mapping <- function(., mapping = NULL) {
106 # For certain geoms, it is useful to be able to ignore the default
107 # aesthetics and only use those set in the layer
108 if (.$inherit.aes) {
1244716 @hadley Trim whitespace
authored
109 aesthetics <- compact(defaults(.$mapping, mapping))
b19ff3f @hadley Port over the last changes. Now to get it working
authored
110 } else {
111 aesthetics <- .$mapping
112 }
1244716 @hadley Trim whitespace
authored
113
b19ff3f @hadley Port over the last changes. Now to get it working
authored
114 # Drop aesthetics that are set or calculated
67939c1 @hadley Compare names of aesthetics, not their values.
authored
115 set <- names(aesthetics) %in% names(.$geom_params)
b19ff3f @hadley Port over the last changes. Now to get it working
authored
116 calculated <- is_calculated_aes(aesthetics)
1244716 @hadley Trim whitespace
authored
117
e4247b4 @hadley Fix errors in free scales in facet_grid
authored
118 aesthetics[!set & !calculated]
2c8d2b6 @hadley Don't draw legends when aesthetic overridden by NULL or by fixed para…
authored
119 }
1244716 @hadley Trim whitespace
authored
120
6198457 @hadley Add ggplot
authored
121 pprint <- function(.) {
122 if (is.null(.$geom)) {
123 cat("Empty layer\n")
124 return(invisible());
125 }
f187976 @hadley Improve summary
authored
126 if (!is.null(.$mapping)) {
1244716 @hadley Trim whitespace
authored
127 cat("mapping:", clist(.$mapping), "\n")
f187976 @hadley Improve summary
authored
128 }
6198457 @hadley Add ggplot
authored
129 .$geom$print(newline=FALSE)
ff99338 @hadley Improve summary output
authored
130 cat(clist(.$geom_params), "\n")
6198457 @hadley Add ggplot
authored
131 .$stat$print(newline=FALSE)
ff99338 @hadley Improve summary output
authored
132 cat(clist(.$stat_params), "\n")
6198457 @hadley Add ggplot
authored
133 .$position$print()
134 }
1244716 @hadley Trim whitespace
authored
135
136
b19ff3f @hadley Port over the last changes. Now to get it working
authored
137 compute_aesthetics <- function(., data, plot) {
138 aesthetics <- .$layer_mapping(plot$mapping)
1244716 @hadley Trim whitespace
authored
139
b19ff3f @hadley Port over the last changes. Now to get it working
authored
140 if (!is.null(.$subset)) {
158a61a @hadley Evalute subsetting in plot environment.
authored
141 include <- data.frame(eval.quoted(.$subset, data, plot$env))
b19ff3f @hadley Port over the last changes. Now to get it working
authored
142 data <- data[rowSums(include, na.rm = TRUE) == ncol(include), ]
f6ce47d @hadley More work on abline, hline, vline
authored
143 }
1244716 @hadley Trim whitespace
authored
144
145 # Override grouping if set in layer.
6198457 @hadley Add ggplot
authored
146 if (!is.null(.$geom_params$group)) {
147 aesthetics["group"] <- .$geom_params$group
b19ff3f @hadley Port over the last changes. Now to get it working
authored
148 }
7c64c0e @hadley Get basic pipeline working for a simple plot
authored
149
150 scales_add_defaults(plot$scales, data, aesthetics, plot$plot_env)
1244716 @hadley Trim whitespace
authored
151
d1fe9b7 @hadley Subset argument for layers
authored
152 # Evaluate aesthetics in the context of their data frame
b19ff3f @hadley Port over the last changes. Now to get it working
authored
153 evaled <- compact(
154 eval.quoted(aesthetics, data, plot$plot_env))
d1fe9b7 @hadley Subset argument for layers
authored
155
7d23078 @wch Code cleanup for empty data
wch authored
156 lengths <- vapply(evaled, length, integer(1))
157 n <- if (length(lengths) > 0) max(lengths) else 0
946b136 @wch Allow empty data frame while passing in vectors for aesthetics
wch authored
158
7d23078 @wch Code cleanup for empty data
wch authored
159 wrong <- lengths != 1 & lengths != n
160 if (any(wrong)) {
161 stop("Aesthetics must either be length one, or the same length as the data",
162 "Problems:", paste(aesthetics[wrong], collapse = ", "), call. = FALSE)
946b136 @wch Allow empty data frame while passing in vectors for aesthetics
wch authored
163 }
7d23078 @wch Code cleanup for empty data
wch authored
164
165 if (empty(data) && n > 0) {
166 # No data, and vectors suppled to aesthetics
167 evaled$PANEL <- 1
168 } else {
169 evaled$PANEL <- data$PANEL
946b136 @wch Allow empty data frame while passing in vectors for aesthetics
wch authored
170 }
7d23078 @wch Code cleanup for empty data
wch authored
171 data.frame(evaled)
6198457 @hadley Add ggplot
authored
172 }
1244716 @hadley Trim whitespace
authored
173
6198457 @hadley Add ggplot
authored
174
175 calc_statistic <- function(., data, scales) {
376fb86 @hadley New annotation function, plus changes to support it.
authored
176 if (empty(data)) return(data.frame())
1244716 @hadley Trim whitespace
authored
177
178 check_required_aesthetics(.$stat$required_aes,
179 c(names(data), names(.$stat_params)),
1732bfb @hadley Check for stat required aesthetics
authored
180 paste("stat_", .$stat$objname, sep=""))
1244716 @hadley Trim whitespace
authored
181
9925fd3 @hadley Wrap stat computation in try block
authored
182 res <- NULL
183 try(res <- do.call(.$stat$calculate_groups, c(
1244716 @hadley Trim whitespace
authored
184 list(data=as.name("data"), scales=as.name("scales")),
6198457 @hadley Add ggplot
authored
185 .$stat_params)
9925fd3 @hadley Wrap stat computation in try block
authored
186 ))
54de29d @hadley Fix propagation of NULLs - replace with data.frame()
authored
187 if (is.null(res)) return(data.frame())
1244716 @hadley Trim whitespace
authored
188
54de29d @hadley Fix propagation of NULLs - replace with data.frame()
authored
189 res
1244716 @hadley Trim whitespace
authored
190
6198457 @hadley Add ggplot
authored
191 }
192
b19ff3f @hadley Port over the last changes. Now to get it working
authored
193
6198457 @hadley Add ggplot
authored
194 map_statistic <- function(., data, plot) {
376fb86 @hadley New annotation function, plus changes to support it.
authored
195 if (empty(data)) return(data.frame())
1732bfb @hadley Check for stat required aesthetics
authored
196
7d6ebf5 @hadley Respect inherit.aes in stat transforms
authored
197 # Assemble aesthetics from layer, plot and stat mappings
198 aesthetics <- .$mapping
199 if (.$inherit.aes) {
e79c075 @hadley Import plyr into namespace
authored
200 aesthetics <- defaults(aesthetics, plot$mapping)
7d6ebf5 @hadley Respect inherit.aes in stat transforms
authored
201 }
e79c075 @hadley Import plyr into namespace
authored
202 aesthetics <- defaults(aesthetics, .$stat$default_aes())
203 aesthetics <- compact(aesthetics)
1244716 @hadley Trim whitespace
authored
204
9df71ea @hadley Fix bugs in mapping transformed values to aesthetics
authored
205 new <- strip_dots(aesthetics[is_calculated_aes(aesthetics)])
9789f49 @hadley Improve geom_histogram examples
authored
206 if (length(new) == 0) return(data)
4cb2af3 @hadley Output from stats now correctly transformed by scales
authored
207
208 # Add map stat output to aesthetics
209 stat_data <- as.data.frame(lapply(new, eval, data, baseenv()))
210 names(stat_data) <- names(new)
1244716 @hadley Trim whitespace
authored
211
4cb2af3 @hadley Output from stats now correctly transformed by scales
authored
212 # Add any new scales, if needed
b7d7bfc @hadley Major revamp of scales to use new scales package.
authored
213 scales_add_defaults(plot$scales, data, new, plot$plot_env)
1244716 @hadley Trim whitespace
authored
214 # Transform the values, if the scale say it's ok
307a3be @hadley Fix stat_spoke scale_reverse bug
authored
215 # (see stat_spoke for one exception)
216 if (.$stat$retransform) {
b7d7bfc @hadley Major revamp of scales to use new scales package.
authored
217 stat_data <- scales_transform_df(plot$scales, stat_data)
307a3be @hadley Fix stat_spoke scale_reverse bug
authored
218 }
1244716 @hadley Trim whitespace
authored
219
d501870 @hadley Fix stat combining bug
authored
220 cunion(stat_data, data)
6198457 @hadley Add ggplot
authored
221 }
222
c30a96e @hadley Better name for add_defaults function -> reparameterise
authored
223 reparameterise <- function(., data) {
b19ff3f @hadley Port over the last changes. Now to get it working
authored
224 if (empty(data)) return(data.frame())
1244716 @hadley Trim whitespace
authored
225 .$geom$reparameterise(data, .$geom_params)
cbeacb6 @hadley Massive rewrite to better deal with xmin, xmax, xend etc
authored
226 }
227
2cc78f4 @hadley Move ordering code earlier so that it also affects position adjustments
authored
228
b19ff3f @hadley Port over the last changes. Now to get it working
authored
229 adjust_position <- function(., data) {
230 ddply(data, "PANEL", function(data) {
3267be6 @hadley Train position scales using all position aesthetics
authored
231 .$position$adjust(data)
6198457 @hadley Add ggplot
authored
232 })
233 }
1244716 @hadley Trim whitespace
authored
234
6198457 @hadley Add ggplot
authored
235 make_grob <- function(., data, scales, cs) {
7f12f21 @hadley Rename nullGrob to zeroGrob
authored
236 if (empty(data)) return(zeroGrob())
1244716 @hadley Trim whitespace
authored
237
b7d23a4 @hadley Minor tweaks to facet_grid
authored
238 data <- .$use_defaults(data)
1244716 @hadley Trim whitespace
authored
239
2cc78f4 @hadley Move ordering code earlier so that it also affects position adjustments
authored
240 check_required_aesthetics(.$geom$required_aes,
1244716 @hadley Trim whitespace
authored
241 c(names(data), names(.$geom_params)),
2cc78f4 @hadley Move ordering code earlier so that it also affects position adjustments
authored
242 paste("geom_", .$geom$objname, sep=""))
1244716 @hadley Trim whitespace
authored
243
6198457 @hadley Add ggplot
authored
244 do.call(.$geom$draw_groups, c(
1244716 @hadley Trim whitespace
authored
245 data = list(as.name("data")),
246 scales = list(as.name("scales")),
247 coordinates = list(as.name("cs")),
6198457 @hadley Add ggplot
authored
248 .$geom_params
249 ))
250 }
251
252 class <- function(.) "layer"
253 })
254
08461b8 @hadley Fix documentation cross-refs.
authored
255 #' Create a new layer
1244716 @hadley Trim whitespace
authored
256 #'
08461b8 @hadley Fix documentation cross-refs.
authored
257 #' @keywords internal
258 #' @export
6198457 @hadley Add ggplot
authored
259 layer <- Layer$new
Something went wrong with that request. Please try again.