Annotation of /pkg/R/layer.R

Parent Directory | 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