SCM

SCM Repository

[latticeextra] Annotation of /pkg/R/c.trellis.R
ViewVC logotype

Annotation of /pkg/R/c.trellis.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 198 - (view) (download)

1 : felix 107
2 : deepayan 198 ## Copyright (C) 2007 Felix Andrews <felix@nfrac.org>
3 : felix 34 ## GPL version 2 or newer
4 :    
5 :    
6 :     xyplot.list <-
7 :     function(x, data = NULL, ..., FUN = xyplot,
8 : felix 154 y.same = TRUE, x.same = NA, layout = NULL,
9 :     merge.legends = FALSE)
10 : felix 34 {
11 : felix 35 if (length(x) == 0) return(NULL)
12 :     ## NOTE lapply here causes problems with eval.parent and `...` later.
13 :     #objs <- lapply(x, FUN, data = data, ...)
14 :     objs <- vector(mode = "list", length = length(x))
15 :     for (i in as.numeric(seq_along(x))) {
16 : felix 159 ## this is what we had previously, but it seemed to cause failures
17 :     ## in complex call structures (e.g. pch=pch ==> object 'pch' not found)
18 :     ## (use substitute to get reasonable ylab)
19 :     #objs[[i]] <- eval.parent(substitute(FUN(x[[i]], data = data, ...)))
20 :     ## check for 'data' to avoid warnings in e.g. qqmath.numeric
21 :     objs[[i]] <-
22 :     if (!is.null(data)) FUN(x[[i]], data = data, ...) else FUN(x[[i]], ...)
23 : felix 35 }
24 :     names(objs) <- names(x)
25 : felix 34 ok <- unlist(lapply(objs, inherits, "trellis"))
26 :     if (any(!ok))
27 :     stop("FUN returned object of class ",
28 :     toString(class(objs[[ which(!ok)[1] ]])),
29 :     ", not trellis.")
30 : felix 58 ans <- do.call("c", c(objs,
31 : felix 154 list(x.same = x.same, y.same = y.same,
32 :     layout = layout, merge.legends = merge.legends)))
33 : felix 58 ans$call <- match.call()
34 :     ans
35 : felix 34 }
36 :    
37 :     c.trellis <-
38 :     function(..., x.same = NA, y.same = NA,
39 : felix 156 layout = NULL, merge.legends = FALSE,
40 : felix 154 recursive = FALSE)
41 : felix 34 {
42 :     objs <- list(...)
43 :     if (length(objs) == 0) return(NULL)
44 :     if (length(objs) == 1) {
45 :     ## only one object
46 :     obj <- objs[[1]]
47 :     ## set dimnames if given and only one panel
48 :     if (!is.null(names(objs)) && (prod(dim(obj)) == 1))
49 :     rownames(obj) <- names(objs)
50 :     return(obj)
51 :     }
52 :     if (length(objs) > 2) {
53 :     ## merge first two objects, and call again
54 :     first2Merged <-
55 : felix 39 do.call("c.trellis", c(objs[1:2],
56 : felix 154 list(x.same = x.same, y.same = y.same,
57 :     merge.legends = merge.legends)))
58 : felix 39 return(do.call("c.trellis", c(list(first2Merged), objs[-(1:2)],
59 :     list(x.same = x.same, y.same = y.same,
60 : felix 154 layout = layout, merge.legends = merge.legends))))
61 : felix 34 }
62 :     ## now exactly 2 objects
63 :     obj1 <- objs[[1]]
64 :     obj2 <- objs[[2]]
65 :     ## number of packets in object, i.e. offset
66 :     NPACK1 <- prod(dim(obj1))
67 :     NPACK2 <- prod(dim(obj2))
68 :     ## first panel function
69 :     panel <- obj1$panel
70 :     PANEL1 <- if (is.function(panel)) panel
71 :     else if (is.character(panel)) get(panel)
72 :     else eval(panel)
73 :     ## second panel function
74 :     panel <- obj2$panel
75 :     PANEL2 <- if (is.function(panel)) panel
76 :     else if (is.character(panel)) get(panel)
77 :     else eval(panel)
78 :     obj1$panel <- function(...) {
79 :     if (packet.number() <= NPACK1)
80 :     PANEL1(...)
81 :     else PANEL2(...)
82 :     }
83 :     ## TODO: treat 'prepanel' the same way as 'panel'?
84 :     ## flatten the trellis objects (make 1 dimensional)
85 :     flatIC <- function(index.cond) {
86 :     dim <- sapply(index.cond, length)
87 :     ic <- do.call(expand.grid, index.cond)
88 :     if (length(dim) >= 2)
89 :     ic[,2] <- (ic[,2] - 1) * dim[1]
90 :     if (length(dim) >= 3)
91 :     ic[,3] <- (ic[,3] - 1) * prod(dim[1:2])
92 :     rowSums(ic)
93 :     }
94 :     flatCL <- function(condlevels, newname=NULL) {
95 :     ## paste names of variables to their values (for strips)
96 :     #for (i in seq_along(condlevels))
97 :     # condlevels[[i]] <- paste(names(condlevels)[i], ## may be NULL
98 :     # condlevels[[i]], sep=" = ")
99 :     ## convert shingle levels to character strings
100 :     condlevels <- lapply(condlevels, as.character)
101 :     cl <- do.call(expand.grid, condlevels)
102 :     cl <- apply(cl, 1, paste, sep=" / ")
103 :     if (!is.null(newname) && (nchar(newname) > 0)) {
104 :     if (length(cl) == 1) cl <- newname
105 :     else cl <- paste(newname, cl, sep=": ")
106 :     }
107 :     cl
108 :     }
109 :     obj1$index.cond <- list(c(flatIC(obj1$index.cond),
110 :     flatIC(obj2$index.cond) + NPACK1))
111 :     obj1$condlevels <- list(c(flatCL(obj1$condlevels, names(objs)[1]),
112 :     flatCL(obj2$condlevels, names(objs)[2])))
113 :     obj1$perm.cond <- 1
114 :    
115 :     ## make scales nominally "free", so they look like original objects
116 :     makeFreeScales <- function(obj, npack, x.y)
117 :     {
118 :     obj[[paste(x.y, "scales", sep=".")]]$relation <- "free"
119 :     .limits <- paste(x.y, "limits", sep=".")
120 :     .num.limit <- paste(x.y, "num.limit", sep=".")
121 :     .used.at <- paste(x.y, "used.at", sep=".")
122 :     if (is.null(obj[[.limits]])) obj[[.limits]] <- NA
123 :     if (is.null(obj[[.num.limit]])) obj[[.num.limit]] <- NA
124 :     if (is.null(obj[[.used.at]])) obj[[.used.at]] <- NA
125 :     if (!is.list(obj[[.limits]])) {
126 :     obj[[.limits]] <- rep(list(obj[[.limits]]), length=npack)
127 :     obj[[.num.limit]] <- rep(list(obj[[.num.limit]]), length=npack)
128 :     obj[[.used.at]] <- rep(list(obj[[.used.at]]), length=npack)
129 :     }
130 :     obj
131 :     }
132 :     ## set relations to "free" if the first object has "free" scales
133 :     ## or if the limits in the two objects are not identical
134 :     xlimItems <- c("x.limits", "x.num.limit", "x.used.at")
135 :     ylimItems <- c("y.limits", "y.num.limit", "y.used.at")
136 :     if (is.na(x.same)) {
137 :     x.same <- FALSE
138 :     if (!is.list(obj1$x.limits) &&
139 :     identical(unclass(obj1)[xlimItems],
140 :     unclass(obj2)[xlimItems]))
141 :     x.same <- NA
142 :     }
143 :     if (is.na(y.same)) {
144 :     y.same <- FALSE
145 :     if (!is.list(obj1$y.limits) &&
146 :     identical(unclass(obj1)[ylimItems],
147 :     unclass(obj2)[ylimItems]))
148 :     y.same <- NA
149 :     }
150 :     if (identical(x.same, FALSE) ||
151 :     is.list(obj1$x.limits))
152 :     {
153 :     obj1 <- makeFreeScales(obj1, npack=NPACK1, x.y="x")
154 :     obj2 <- makeFreeScales(obj2, npack=NPACK2, x.y="x")
155 :     obj1$x.limits <- c(obj1$x.limits, obj2$x.limits)
156 :     obj1$x.num.limit <- c(obj1$x.num.limit, obj2$x.num.limit)
157 :     obj1$x.used.at <- c(obj1$x.used.at, obj2$x.used.at)
158 :     }
159 :     if (identical(y.same, FALSE) ||
160 :     is.list(obj1$y.limits))
161 :     {
162 :     obj1 <- makeFreeScales(obj1, npack=NPACK1, x.y="y")
163 :     obj2 <- makeFreeScales(obj2, npack=NPACK2, x.y="y")
164 :     obj1$y.limits <- c(obj1$y.limits, obj2$y.limits)
165 :     obj1$y.num.limit <- c(obj1$y.num.limit, obj2$y.num.limit)
166 :     obj1$y.used.at <- c(obj1$y.used.at, obj2$y.used.at)
167 :     }
168 :    
169 :     ## merge common panel args into panel.args
170 :     ## check for identical() args
171 :     commonNames <- intersect(names(obj1$panel.args.common),
172 :     names(obj2$panel.args.common))
173 :     identNames <- commonNames[unlist(lapply(commonNames, function(x)
174 :     identical(obj1$panel.args.common[[x]],
175 :     obj2$panel.args.common[[x]])))]
176 :     obj1Common <- names(obj1$panel.args.common) %in% identNames
177 :     obj2Common <- names(obj2$panel.args.common) %in% identNames
178 :     obj1$panel.args <- lapply(obj1$panel.args, c,
179 :     obj1$panel.args.common[!obj1Common])
180 :     obj2$panel.args <- lapply(obj2$panel.args, c,
181 :     obj2$panel.args.common[!obj2Common])
182 :     obj1$panel.args.common <- obj1$panel.args.common[obj1Common]
183 :     ## the actual data
184 :     obj1$panel.args <- c(obj1$panel.args, obj2$panel.args)
185 :     obj1$packet.sizes <- c(obj1$packet.sizes, obj2$packet.sizes)
186 : felix 50 ## some prepanel functions require a 'subscripts' argument in each 'panel.args'
187 : deepayan 198 fargNames <- function(f) if (is.null(f)) NULL else names(formals(f))
188 :     if ("subscripts" %in% c(fargNames(obj1$prepanel.default), fargNames(obj1$prepanel)))
189 :     {
190 :     for (i in seq_along(obj1$panel.args))
191 :     {
192 :     if (!("subscripts" %in% names(obj1$panel.args[[i]]))
193 :     {
194 : felix 50 obj1$panel.args[[i]]$subscripts <- TRUE
195 :     }
196 :     }
197 :     }
198 : felix 34
199 :     ## recalculate panel limits using all data
200 :     if ((isTRUE(x.same) || isTRUE(y.same))) {
201 :     scalesSpec <- list()
202 :     if (isTRUE(x.same)) scalesSpec$x$relation <- "same"
203 :     if (isTRUE(y.same)) scalesSpec$y$relation <- "same"
204 :     obj1 <- update(obj1, scales = scalesSpec)
205 :     }
206 :    
207 : felix 128 if (identical(obj1$strip.left, FALSE)) {
208 :     ## turn strips on if either object has strips, or names were given
209 :     if (identical(obj1$strip, FALSE) &&
210 :     !identical(obj2$strip, FALSE))
211 :     obj1$strip <- obj2$strip
212 :     if (identical(obj1$strip, FALSE) &&
213 :     !is.null(names(objs)))
214 :     obj1$strip <- "strip.default"
215 :     }
216 : felix 154
217 :     ## TODO: can use 'par.settings' from obj2 only for obj2 panels?
218 :     obj1$par.settings <- modifyList(as.list(obj2$par.settings),
219 :     as.list(obj1$par.settings))
220 :     if (merge.legends)
221 :     obj1$legend <- mergeTrellisLegends(obj1$legend, obj2$legend)
222 :    
223 : felix 41 obj1$layout <- layout
224 : felix 107 obj1$call <- call("c", obj1$call, obj2$call,
225 :     x.same = x.same, y.same = y.same,
226 :     layout = layout)
227 :     ## need this to allow further calls to update() to insert arguments:
228 :     obj1$call <- call("update", obj1$call)
229 : felix 34 obj1
230 :     }

R-Forge@R-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business University of Wisconsin - Madison Powered By FusionForge