| 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 |
}
|
Parent Directory
| 
Revision Log
