SCM

SCM Repository

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

Annotation of /pkg/R/doubleYScale.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 184 - (view) (download)

1 : felix 34 ##
2 :     ## Copyright (c) 2008 Felix Andrews <felix@nfrac.org>
3 :     ## GPL version 2 or newer
4 :    
5 :     doubleYScale <-
6 : felix 58 function(obj1, obj2, use.style = TRUE,
7 :     style1 = if (use.style) 1, style2 = if (use.style) 2,
8 :     add.axis = TRUE, add.ylab2 = FALSE,
9 : felix 34 text = NULL, auto.key = if (!is.null(text))
10 :     list(text, points = points, lines = lines, ...),
11 : felix 152 points = FALSE, lines = TRUE, ..., under = FALSE)
12 : felix 34 {
13 :     stopifnot(inherits(obj1, "trellis"))
14 :     stopifnot(inherits(obj2, "trellis"))
15 :    
16 : felix 58 if (any(style1 == 0)) style1 <- NULL
17 :     if (any(style2 == 0)) style2 <- NULL
18 : felix 34 ## force same x scales
19 : felix 51 #xlim1 <- obj1$x.limits
20 :     #if (is.list(xlim1))
21 :     # xlim1 <- rep(xlim1, length = prod(dim(obj2)))
22 :     #obj2 <- update(obj2, xlim = xlim1, ylim = obj2$y.limits)
23 : felix 34 ## TODO - ylim only here to workaround bug in lattice 0.17-15
24 :    
25 :     if (!is.null(auto.key)) {
26 :     space <- "top"
27 :     if (!is.null(auto.key$space))
28 :     space <- auto.key$space
29 :     auto.key$space <- NULL
30 :     keyLeg <- list(space = list(fun = "drawSimpleKey",
31 :     args = auto.key))
32 :     names(keyLeg) <- space
33 :     obj1 <- update(obj1, legend = keyLeg)
34 :     }
35 : felix 154
36 :     ## merge legends
37 :     obj1$legend <- mergeTrellisLegends(obj1$legend, obj2$legend)
38 :    
39 : felix 34 if (add.ylab2) {
40 :     ## add ylab2 as a 'legend' (idea from John Maindonald)
41 :     ## draw both ylabs in their style, if specified
42 :     ylabStyledGrob <- function(label, style) {
43 :     textGrob(label, y = 0.5, rot = 90,
44 : felix 58 gp = if (!is.null(style))
45 : felix 34 gpar(col = trellis.par.get("superpose.line")$col[style]))
46 :     }
47 :     is.characterOrExpression <- function(x)
48 :     is.character(x) || is.expression(x)
49 :    
50 : felix 58 if (!is.null(style1)) {
51 : felix 34 ylab1 <- obj1$ylab
52 :     if (is.list(ylab1))
53 :     ylab1 <- obj1$ylab.default
54 :     if (is.characterOrExpression(ylab1)) {
55 : felix 154 obj1$legend <-
56 :     mergeTrellisLegends(obj1$legend,
57 :     list(left =
58 :     list(fun = ylabStyledGrob,
59 : felix 34 args = list(label = ylab1,
60 : felix 154 style = style1))),
61 :     vertical = FALSE)
62 : felix 34 obj1$ylab <- expression(NULL)
63 :     }
64 :     }
65 : felix 154 ## TODO: use ylab.right from lattice 0.19-6
66 : felix 34 ylab2 <- obj2$ylab
67 :     if (is.list(ylab2))
68 :     ylab2 <- obj2$ylab.default
69 :     if (is.characterOrExpression(ylab2)) {
70 : felix 154 obj1$legend <-
71 :     mergeTrellisLegends(list(right =
72 : felix 34 list(fun = ylabStyledGrob,
73 :     args = list(label = ylab2,
74 : felix 154 style = style2))),
75 :     obj1$legend,
76 :     vertical = FALSE)
77 : felix 34 }
78 :     }
79 :    
80 :     if (add.axis == FALSE) {
81 :     ## if not drawing a second axis, nothing to do but...
82 : felix 154 foo <- obj1 + as.layer(obj2, style = style2,
83 :     x.same = TRUE, y.same = FALSE,
84 :     axes = NULL, under = under)
85 : felix 107 } else {
86 :     ## need to specify padding to draw second y axis
87 :     yAxPad <- list(layout.widths = list(
88 :     axis.left = list(x = 2.5, units = "char"),
89 :     axis.right = list(x = 3, units = "char")))
90 :    
91 :     dummy <- update(obj1, panel = function(...) NULL,
92 :     scales = list(y = list(draw = FALSE)),
93 :     lattice.options = yAxPad)
94 : felix 154
95 : felix 107 foo <-
96 :     dummy +
97 :     as.layer(obj1, style = style1,
98 :     x.same = TRUE, y.same = FALSE,
99 :     axes = "y", out = TRUE, opp = FALSE) +
100 :     as.layer(obj2, style = style2,
101 :     x.same = TRUE, y.same = FALSE,
102 : felix 154 axes = "y", out = TRUE, opp = TRUE,
103 :     under = under)
104 : felix 34 }
105 : felix 154 foo$call <- match.call()
106 : felix 107 foo
107 : felix 34 }
108 :    
109 :     as.layer.trellis <-
110 :     function(x,
111 : felix 51 x.same = TRUE,
112 :     y.same = TRUE,
113 :     axes = c(if (!x.same) "x", if (!y.same) "y"),
114 : felix 34 opposite = TRUE,
115 :     outside = FALSE,
116 : felix 152 theme = x$par.settings,
117 : felix 34 ...)
118 :     {
119 :     if (identical(axes, TRUE)) axes <- c("x", "y")
120 :     if (identical(axes, FALSE)) axes <- NULL
121 :     opposite <- rep(opposite, length = 2)
122 :     outside <- rep(outside, length = 2)
123 : felix 51 if (x.same && y.same) {
124 :     ## simply run the panel function in existing panel viewport
125 : felix 152 return(layer({
126 : felix 51 packet.number <- min(packet.number(), prod(dim(x)))
127 :     do.call(x$panel, trellis.panelArgs(x, packet.number))
128 : felix 152 }, data = list(x = x), theme = theme, ...))
129 : felix 51 }
130 :     ## else
131 :     ## take one or more scales from layered object (so new viewport)
132 : felix 34 ## draw panels and axes from this trellis object
133 :     layer({
134 :     packet.number <- min(packet.number(), prod(dim(x)))
135 :     ## axis details...
136 :     ## this all copied from lattice:::plot.trellis
137 : felix 154 ## TODO: this is horrible; can use the axis function instead?
138 : felix 34 x.relation.same <- x$x.scales$relation == "same"
139 :     y.relation.same <- x$y.scales$relation == "same"
140 :     xscale.comps <-
141 :     if (x.relation.same)
142 :     x$xscale.components(lim = x$x.limits,
143 :     top = TRUE,
144 :     ## rest passed on to
145 :     ## calculateAxisComponents
146 :     ## in the default
147 :     ## case:
148 :     at = x$x.scales$at,
149 :     used.at = x$x.used.at,
150 :     num.limit = x$x.num.limit,
151 : deepayan 184 labels = x$x.scales$labels,
152 : felix 34 logsc = x$x.scales$log,
153 :     abbreviate = x$x.scales$abbr,
154 :     minlength = x$x.scales$minl,
155 :     n = x$x.scales$tick.number,
156 :     format.posixt = x$x.scales$format)
157 :     else
158 :     x$xscale.components(lim = x$x.limits[[packet.number]],
159 :     top = FALSE,
160 :     ## rest passed on to
161 :     ## calculateAxisComponents
162 :     ## in the default
163 :     ## case:
164 :     at = if (is.list(x$x.scales$at))
165 :     x$x.scales$at[[packet.number]]
166 :     else x$x.scales$at,
167 :     used.at = x$x.used.at[[packet.number]],
168 :     num.limit = x$x.num.limit[[packet.number]],
169 :     labels =
170 : deepayan 184 if (is.list(x$x.scales$labels))
171 :     x$x.scales$labels[[packet.number]]
172 :     else x$x.scales$labels,
173 : felix 34 logsc = x$x.scales$log,
174 :     abbreviate = x$x.scales$abbr,
175 :     minlength = x$x.scales$minl,
176 :     n = x$x.scales$tick.number,
177 :     format.posixt = x$x.scales$format)
178 :    
179 :     yscale.comps <-
180 :     if (y.relation.same)
181 :     x$yscale.components(lim = x$y.limits,
182 :     right = TRUE,
183 :     ## rest passed on to
184 :     ## calculateAxisComponents
185 :     ## in the default
186 :     ## case:
187 :     at = x$y.scales$at,
188 :     used.at = x$y.used.at,
189 :     num.limit = x$y.num.limit,
190 : deepayan 184 labels = x$y.scales$labels,
191 : felix 34 logsc = x$y.scales$log,
192 :     abbreviate = x$y.scales$abbr,
193 :     minlength = x$y.scales$minl,
194 :     n = x$y.scales$tick.number,
195 :     format.posixt = x$y.scales$format)
196 :     else
197 :     x$yscale.components(lim = x$y.limits[[packet.number]],
198 :     right = FALSE,
199 :     ## rest passed on to
200 :     ## calculateAxisComponents
201 :     ## in the default
202 :     ## case:
203 :     at = if (is.list(x$y.scales$at))
204 :     x$y.scales$at[[packet.number]]
205 :     else x$y.scales$at,
206 :     used.at = x$y.used.at[[packet.number]],
207 :     num.limit = x$y.num.limit[[packet.number]],
208 :     labels =
209 : deepayan 184 if (is.list(x$y.scales$labels))
210 :     x$y.scales$labels[[packet.number]]
211 :     else x$y.scales$labels,
212 : felix 34 logsc = x$y.scales$log,
213 :     abbreviate = x$y.scales$abbr,
214 :     minlength = x$y.scales$minl,
215 :     n = x$y.scales$tick.number,
216 :     format.posixt = x$y.scales$format)
217 :     xscale <- xscale.comps$num.limit
218 :     yscale <- yscale.comps$num.limit
219 : felix 51 ## maybe over-ride with original limits
220 :     if (x.same)
221 : felix 152 xscale <- current.panel.limits()$xlim
222 : felix 51 if (y.same)
223 : felix 152 yscale <- current.panel.limits()$ylim
224 : felix 34 ## do panel(); need a new viewport with scales from 'x'
225 :     pushViewport(viewport(xscale = xscale, yscale = yscale))
226 :     do.call(x$panel, trellis.panelArgs(x, packet.number))
227 :     ## use axis components from the standard side only
228 :     xscale.comps$top <- TRUE
229 :     yscale.comps$right <- TRUE
230 :     x.comp.list <- xscale.comps$bottom
231 :     y.comp.list <- yscale.comps$left
232 :     ## axes viewport (clip = "off" for outside axes)
233 :     ## note: to draw an outside axis at top when there are stips:
234 :     ## should really do it in strip.column.row.off
235 :     pushViewport(viewport(xscale = xscale, yscale = yscale,
236 :     clip = "off"))
237 :     if (("x" %in% axes) && is.list(x.comp.list) && x$x.scales$draw) {
238 :     comp.list <- x.comp.list
239 :     scales.tck <- x$x.scales$tck[1]
240 :     rot <- as.numeric(x$x.scales$rot)[1]
241 :     if (outside[1]) {
242 :     ## use axis.default where possible (i.e. where outside=TRUE)
243 :     ## because it handles labels well in multi-panel layouts
244 :     x$x.scales$alternating <- 3
245 :     x$axis(side = if (opposite[1]) "top" else "bottom",
246 :     scales = x$x.scales,
247 :     components = xscale.comps,
248 :     as.table = x$as.table,
249 :     rot = rot)
250 :     } else {
251 :     panel.axis(side = if (opposite[1]) "top" else "bottom",
252 :     at = comp.list$ticks$at,
253 :     labels = comp.list$labels$labels,
254 :     #tick = do.ticks,
255 :     #draw.labels = do.labels,
256 :     check.overlap = comp.list$labels$check.overlap,
257 :     outside = outside[1],
258 :     half = FALSE,
259 :     tck = scales.tck * comp.list$ticks$tck,
260 :     rot = rot)
261 :     }
262 :     }
263 :     if (("y" %in% axes) && is.list(y.comp.list) && x$y.scales$draw) {
264 :     comp.list <- y.comp.list
265 :     scales.tck <- x$y.scales$tck[1]
266 :     rot <- as.numeric(x$y.scales$rot)[1]
267 :     if (outside[2]) {
268 :     ## use axis.default where possible (i.e. where outside=TRUE)
269 :     ## because it handles labels well in multi-panel layouts
270 :     x$y.scales$alternating <- 3
271 :     x$axis(side = if (opposite[2]) "right" else "left",
272 :     scales = x$y.scales,
273 :     components = yscale.comps,
274 :     as.table = x$as.table,
275 :     rot = rot)
276 :     } else {
277 :     panel.axis(side = if (opposite[2]) "right" else "left",
278 :     at = comp.list$ticks$at,
279 :     labels = comp.list$labels$labels,
280 :     #tick = do.ticks,
281 :     #draw.labels = do.labels,
282 :     check.overlap = comp.list$labels$check.overlap,
283 :     outside = outside[2],
284 :     half = FALSE,
285 :     tck = scales.tck * comp.list$ticks$tck,
286 :     rot = rot)
287 :     }
288 :     }
289 :     upViewport(2)
290 : felix 51 }, data = list(x = x, x.same = x.same, y.same = y.same,
291 :     axes = axes, opposite = opposite, outside = outside),
292 : felix 152 theme = theme, ...)
293 : felix 34 }

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