SCM

SCM Repository

[latticeextra] Annotation of /pkg/R/layer.R
ViewVC logotype

Annotation of /pkg/R/layer.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 204 - (view) (download)

1 : felix 34 ##
2 :     ## Copyright (c) 2008 Felix Andrews <felix@nfrac.org>
3 :     ## GPL version 2 or newer
4 :    
5 :     as.layer <- function(x, ...)
6 :     UseMethod("as.layer")
7 :    
8 : felix 57 as.layer.layer <- function(x, ...)
9 :     x
10 :    
11 : felix 63 layer <-
12 : felix 132 function(..., data = NULL,
13 :     magicdots = TRUE, exclude = NULL,
14 :     packets = NULL,
15 :     rows = NULL, columns = NULL,
16 :     groups = NULL,
17 :     style = NULL, force = FALSE,
18 :     theme = if (force) trellis.par.get() else NULL,
19 : felix 164 under = FALSE, superpose = FALSE)
20 : felix 34 {
21 :     ## set layer to quoted expressions in `...`
22 : felix 57 foo <- eval(substitute(expression(...)))
23 : felix 164 if (magicdots) {
24 : felix 132 ## The dots `...` are magic:
25 :     ## pass on only those arguments not named in each call
26 : felix 164 foo <- as.expression(lapply(foo, magicDots, exclude = exclude))
27 : felix 63 }
28 : deepayan 204 ## FIXME: should we have
29 :     ##
30 :     ## if (missing(data)) data <- parent.frame()
31 :     ##
32 :     ## ? See tests/layer.R for a non-obvious failure. But not sure
33 :     ## how best to fix.
34 : felix 57 mostattributes(foo) <-
35 :     list(data = data,
36 :     under = under,
37 :     packets = packets,
38 :     rows = rows,
39 :     columns = columns,
40 :     groups = groups,
41 :     superpose = superpose,
42 :     style = style,
43 : felix 147 theme = theme)
44 : felix 34 lay <- list(foo)
45 :     class(lay) <- c("layer", "trellis")
46 :     lay
47 :     }
48 :    
49 : felix 132 ## convert a call containing `...` to only pass on arguments
50 :     ## not named in the call
51 :     magicDots <- function(ocall, exclude = NULL, assume.xy = TRUE)
52 :     {
53 : felix 164 if (!is.call(ocall)) stop("arguments to layer() should be calls")
54 : felix 132 ## call recursively with any calls inside this one
55 :     for (i in seq_along(ocall)[-1]) {
56 :     thisArg <- ocall[[i]]
57 : felix 146 if (missing(thisArg)) ## eg x[,1]
58 :     next
59 : felix 132 if (is.call(thisArg)) {
60 :     ## skip function definitions
61 :     if (identical(thisArg[[1]], as.symbol("function")))
62 :     next
63 :     ocall[[i]] <- Recall(thisArg, exclude = exclude, assume.xy = assume.xy)
64 :     }
65 :     }
66 :     Args <- as.list(ocall)[-1]
67 :     ## nothing to do if there are no dots in the call
68 :     idots <- sapply(Args, identical, as.symbol("..."))
69 :     if (!any(idots))
70 :     return(ocall)
71 :     Args <- Args[!idots]
72 :     ## nothing to do if there are only dots in the call (unless exclude)
73 :     if ((length(Args) == 0) && (length(exclude) == 0))
74 :     return(ocall)
75 :     ## assume first argument is 'x' if is un-named, and second 'y'
76 :     if (assume.xy && (length(Args) > 0)) {
77 :     if (is.null(names(Args)))
78 :     names(Args) <- rep("", length = length(Args))
79 :     if (identical(names(Args)[1], ""))
80 :     names(Args)[1] <- "x"
81 :     if (identical(names(Args)[2], ""))
82 :     names(Args)[2] <- "y"
83 :     }
84 :     if (length(exclude) == 0) {
85 :     ## simple case
86 :     mcall <-
87 :     substitute(do.call(FUN,
88 :     modifyList(list(...), Args)),
89 :     list(FUN = ocall[[1]], Args = Args))
90 :     } else {
91 :     ## exclude named arguments from dots
92 :     mcall <-
93 :     substitute(do.call(FUN,
94 :     modifyList(list(...)[!(names(list(...)) %in% exclude)],
95 :     Args)),
96 :     list(FUN = ocall[[1]], Args = Args, exclude = exclude))
97 :     }
98 :     mcall
99 :     }
100 :    
101 : felix 57 layer_ <- function(...)
102 : felix 53 {
103 :     ccall <- match.call()
104 : felix 57 ccall$under <- TRUE
105 : felix 53 ccall[[1]] <- quote(layer)
106 :     eval.parent(ccall)
107 :     }
108 :    
109 : felix 57 glayer <- function(...)
110 :     {
111 :     ccall <- match.call()
112 :     ccall$superpose <- TRUE
113 :     ccall[[1]] <- quote(layer)
114 :     eval.parent(ccall)
115 :     }
116 :    
117 :     glayer_ <- function(...)
118 :     {
119 :     ccall <- match.call()
120 :     ccall$superpose <- TRUE
121 :     ccall$under <- TRUE
122 :     ccall[[1]] <- quote(layer)
123 :     eval.parent(ccall)
124 :     }
125 :    
126 : felix 34 ## to avoid print.trellis
127 : deepayan 184 print.layer <- function(x, ...) print.default(x, ...)
128 : felix 34
129 : felix 57 ## to avoid [.trellis and to keep the class attribute
130 :     "[.layer" <- function (x, i, ...)
131 :     structure(unclass(x)[i], class = class(x))
132 :    
133 :     "+.trellis" <- function(object, lay)
134 : felix 34 {
135 : felix 107 ocall <- sys.call(sys.parent()); ocall[[1]] <- quote(`+`)
136 : deepayan 187 if (missing(object) || missing(lay)) stop("Only one argument supplied to binary operator + which requires two.")
137 : felix 57 stopifnot(inherits(object, "trellis"))
138 :     lay <- as.layer(lay)
139 :     if (inherits(object, "layer")) {
140 : felix 34 ## just concatenate lists
141 : felix 57 return(structure(c(unclass(object), unclass(lay)),
142 :     class = c("layer", "trellis")))
143 : felix 34 }
144 : felix 171 panel <- if ("panel" %in% names(object$panel.args.common))
145 : felix 34 object$panel.args.common$panel
146 :     else object$panel
147 :     panel <- if (is.function(panel)) panel
148 :     else if (is.character(panel)) {
149 :     ## could be just get(panel), but for flattenPanel:
150 :     ## do not expand original panel function eg panel.xyplot(...)
151 :     tmp <- function(...) NA
152 :     body(tmp) <- call(panel, quote(...))
153 :     environment(tmp) <- globalenv()
154 :     tmp
155 :     } else eval(panel)
156 :     ## a flag to indicate this panel function has layers
157 :     ## (used by flattenPanel and undoLayer)
158 :     .is.a.layer <- TRUE
159 : felix 168 newpanel <- function(...) {
160 : felix 57 .UNDER <- unlist(lapply(lay, attr, "under"))
161 : felix 168 ## underlaying items only
162 :     drawLayer(lay[.UNDER], list(...))
163 : felix 57 ## original panel function:
164 : felix 168 panel(...)
165 :     ## overlaying items only
166 :     drawLayer(lay[.UNDER == FALSE], list(...))
167 : felix 57 }
168 : felix 171 if ("panel" %in% names(object$panel.args.common))
169 : felix 168 object$panel.args.common$panel <- newpanel
170 :     else object$panel <- newpanel
171 : felix 107 ## need this to allow further calls to update() to insert arguments:
172 : felix 57 object$call <- call("update", ocall)
173 :     object
174 :     }
175 :    
176 : felix 168 drawLayer <- function(lay, panelArgs = trellis.panelArgs())
177 : felix 57 {
178 :     lay <- as.layer(lay)
179 :     .UNDER <- unlist(lapply(lay, attr, "under"))
180 :     ## underlayers, in reverse order
181 :     for (.ITEM in rev(lay[.UNDER]))
182 : felix 168 drawLayerItem(.ITEM, panelArgs)
183 : felix 57 ## overlayers
184 :     for (.ITEM in lay[.UNDER == FALSE])
185 : felix 168 drawLayerItem(.ITEM, panelArgs)
186 : felix 57 invisible()
187 :     }
188 :    
189 : felix 168 drawLayerItem <- function(layer.item, panelArgs)
190 : felix 57 {
191 :     stopifnot(is.expression(layer.item))
192 :     ## check that any restrictions on packets/rows/columns are met
193 : felix 67 matchesok <- function(spec, value) {
194 :     if (is.null(spec)) return(TRUE)
195 : felix 126 if (is.numeric(spec) && all(spec <= 0))
196 : felix 67 ## negative indexes exclude items
197 :     return(value %in% -spec == FALSE)
198 :     else
199 :     return(value %in% spec)
200 :     }
201 : felix 57 matchesallok <-
202 : felix 67 with(list(a = attributes(layer.item)),
203 :     matchesok(a$packets, packet.number()) &&
204 : felix 57 matchesok(a$rows, current.row()) &&
205 :     matchesok(a$columns, current.column()))
206 :     if (!matchesallok) return()
207 : felix 67 ## set given theme for duration of this function
208 :     if (!is.null(attr(layer.item, "theme"))) {
209 :     .TRELLISPAR <- trellis.par.get()
210 :     trellis.par.set(attr(layer.item, "theme"))
211 :     on.exit(trellis.par.set(.TRELLISPAR))
212 :     }
213 : felix 57 ## define a layer drawing function, which may be per group
214 :     drawLayerItemPerGroup <- function(...)
215 :     {
216 :     ## Note: layer.item is found in this function's environment
217 : felix 34 dots <- list(...)
218 : felix 57 ## restrict to specified group numbers
219 : felix 126 groupok <- (matchesok(attr(layer.item, "groups"), dots$group.number) ||
220 :     matchesok(attr(layer.item, "groups"), as.character(dots$group.value)))
221 :     if (!groupok)
222 : felix 67 return()
223 : felix 57 if (!is.null(attr(layer.item, "style"))) {
224 :     ## extract plot style attributes from given index into superpose.*
225 : felix 67 .TRELLISPAR <- trellis.par.get()
226 : felix 138 local({
227 :     i <- attr(layer.item, "style")
228 :     line <- Rows(trellis.par.get("superpose.line"), i)
229 :     symbol <- Rows(trellis.par.get("superpose.symbol"), i)
230 :     polygon <- Rows(trellis.par.get("superpose.polygon"), i)
231 :     trellis.par.set(plot.line = line,
232 :     superpose.line = line,
233 :     add.line = line,
234 :     add.text = line,
235 :     plot.symbol = symbol,
236 :     superpose.symbol = symbol,
237 :     plot.polygon = polygon,
238 :     superpose.polygon = polygon,
239 :     axis.text = line,
240 :     axis.line = line
241 :     )
242 :     })
243 : felix 57 on.exit(trellis.par.set(.TRELLISPAR))
244 :     }
245 :     with(dots,
246 :     eval(layer.item, attr(layer.item, "data"),
247 : felix 34 environment()))
248 :     }
249 : felix 57 ## call panel.superpose for group layers
250 :     if (isTRUE(attr(layer.item, "superpose"))) {
251 :     do.call("panel.superpose",
252 : felix 168 modifyList(panelArgs,
253 : felix 57 list(panel.groups = drawLayerItemPerGroup)))
254 :     } else {
255 : felix 168 do.call("drawLayerItemPerGroup", panelArgs)
256 : felix 57 }
257 : felix 34 }
258 :    
259 : felix 57 flattenPanel <- function(object)
260 : felix 34 {
261 :     flattenFun <- function(fun)
262 :     {
263 :     env <- environment(fun)
264 :     ## check if this panel function is simple or has layers
265 :     if (is.null(env) ||
266 : felix 57 !exists(".is.a.layer", env, inherits = FALSE))
267 : felix 34 return(as.expression(body(fun)))
268 :     ## merge: under layers, existing panel, over layers
269 : felix 57 .UNDER <- sapply(env$lay, attr, "under")
270 :     c(do.call("c", rev(env$lay[.UNDER])),
271 : felix 34 flattenFun(env$panel),
272 : felix 57 do.call("c", env$lay[.UNDER == FALSE]))
273 : felix 34 }
274 : felix 57 flat <- flattenFun(object$panel)
275 : felix 34 ## wrap in braces, as in a function body
276 :     as.call(c(quote(`{`), flat))
277 :     }
278 :    
279 :     ## not exported -- I do not think this is really useful
280 :     undoLayer <- function(x)
281 :     {
282 :     stopifnot(is.function(x$panel))
283 :     env <- environment(x$panel)
284 :     if (!exists(".is.a.layer", env, inherits=FALSE))
285 :     stop("does not look like a layer")
286 :     update(x, panel=env$panel)
287 :     }
288 :    

root@r-forge.r-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business Powered By FusionForge