SCM Repository
[latticeextra] / pkg / R / doubleYScale.R |
View of /pkg/R/doubleYScale.R
Parent Directory
|
Revision Log
Revision 184 -
(download)
(annotate)
Mon Apr 23 08:59:29 2012 UTC (10 years, 9 months ago) by deepayan
File size: 13448 byte(s)
Mon Apr 23 08:59:29 2012 UTC (10 years, 9 months ago) by deepayan
File size: 13448 byte(s)
Added parameter for symbol color in panel.segplot, plus minor fixes
## ## Copyright (c) 2008 Felix Andrews <felix@nfrac.org> ## GPL version 2 or newer doubleYScale <- function(obj1, obj2, use.style = TRUE, style1 = if (use.style) 1, style2 = if (use.style) 2, add.axis = TRUE, add.ylab2 = FALSE, text = NULL, auto.key = if (!is.null(text)) list(text, points = points, lines = lines, ...), points = FALSE, lines = TRUE, ..., under = FALSE) { stopifnot(inherits(obj1, "trellis")) stopifnot(inherits(obj2, "trellis")) if (any(style1 == 0)) style1 <- NULL if (any(style2 == 0)) style2 <- NULL ## force same x scales #xlim1 <- obj1$x.limits #if (is.list(xlim1)) # xlim1 <- rep(xlim1, length = prod(dim(obj2))) #obj2 <- update(obj2, xlim = xlim1, ylim = obj2$y.limits) ## TODO - ylim only here to workaround bug in lattice 0.17-15 if (!is.null(auto.key)) { space <- "top" if (!is.null(auto.key$space)) space <- auto.key$space auto.key$space <- NULL keyLeg <- list(space = list(fun = "drawSimpleKey", args = auto.key)) names(keyLeg) <- space obj1 <- update(obj1, legend = keyLeg) } ## merge legends obj1$legend <- mergeTrellisLegends(obj1$legend, obj2$legend) if (add.ylab2) { ## add ylab2 as a 'legend' (idea from John Maindonald) ## draw both ylabs in their style, if specified ylabStyledGrob <- function(label, style) { textGrob(label, y = 0.5, rot = 90, gp = if (!is.null(style)) gpar(col = trellis.par.get("superpose.line")$col[style])) } is.characterOrExpression <- function(x) is.character(x) || is.expression(x) if (!is.null(style1)) { ylab1 <- obj1$ylab if (is.list(ylab1)) ylab1 <- obj1$ylab.default if (is.characterOrExpression(ylab1)) { obj1$legend <- mergeTrellisLegends(obj1$legend, list(left = list(fun = ylabStyledGrob, args = list(label = ylab1, style = style1))), vertical = FALSE) obj1$ylab <- expression(NULL) } } ## TODO: use ylab.right from lattice 0.19-6 ylab2 <- obj2$ylab if (is.list(ylab2)) ylab2 <- obj2$ylab.default if (is.characterOrExpression(ylab2)) { obj1$legend <- mergeTrellisLegends(list(right = list(fun = ylabStyledGrob, args = list(label = ylab2, style = style2))), obj1$legend, vertical = FALSE) } } if (add.axis == FALSE) { ## if not drawing a second axis, nothing to do but... foo <- obj1 + as.layer(obj2, style = style2, x.same = TRUE, y.same = FALSE, axes = NULL, under = under) } else { ## need to specify padding to draw second y axis yAxPad <- list(layout.widths = list( axis.left = list(x = 2.5, units = "char"), axis.right = list(x = 3, units = "char"))) dummy <- update(obj1, panel = function(...) NULL, scales = list(y = list(draw = FALSE)), lattice.options = yAxPad) foo <- dummy + as.layer(obj1, style = style1, x.same = TRUE, y.same = FALSE, axes = "y", out = TRUE, opp = FALSE) + as.layer(obj2, style = style2, x.same = TRUE, y.same = FALSE, axes = "y", out = TRUE, opp = TRUE, under = under) } foo$call <- match.call() foo } as.layer.trellis <- function(x, x.same = TRUE, y.same = TRUE, axes = c(if (!x.same) "x", if (!y.same) "y"), opposite = TRUE, outside = FALSE, theme = x$par.settings, ...) { if (identical(axes, TRUE)) axes <- c("x", "y") if (identical(axes, FALSE)) axes <- NULL opposite <- rep(opposite, length = 2) outside <- rep(outside, length = 2) if (x.same && y.same) { ## simply run the panel function in existing panel viewport return(layer({ packet.number <- min(packet.number(), prod(dim(x))) do.call(x$panel, trellis.panelArgs(x, packet.number)) }, data = list(x = x), theme = theme, ...)) } ## else ## take one or more scales from layered object (so new viewport) ## draw panels and axes from this trellis object layer({ packet.number <- min(packet.number(), prod(dim(x))) ## axis details... ## this all copied from lattice:::plot.trellis ## TODO: this is horrible; can use the axis function instead? x.relation.same <- x$x.scales$relation == "same" y.relation.same <- x$y.scales$relation == "same" xscale.comps <- if (x.relation.same) x$xscale.components(lim = x$x.limits, top = TRUE, ## rest passed on to ## calculateAxisComponents ## in the default ## case: at = x$x.scales$at, used.at = x$x.used.at, num.limit = x$x.num.limit, labels = x$x.scales$labels, logsc = x$x.scales$log, abbreviate = x$x.scales$abbr, minlength = x$x.scales$minl, n = x$x.scales$tick.number, format.posixt = x$x.scales$format) else x$xscale.components(lim = x$x.limits[[packet.number]], top = FALSE, ## rest passed on to ## calculateAxisComponents ## in the default ## case: at = if (is.list(x$x.scales$at)) x$x.scales$at[[packet.number]] else x$x.scales$at, used.at = x$x.used.at[[packet.number]], num.limit = x$x.num.limit[[packet.number]], labels = if (is.list(x$x.scales$labels)) x$x.scales$labels[[packet.number]] else x$x.scales$labels, logsc = x$x.scales$log, abbreviate = x$x.scales$abbr, minlength = x$x.scales$minl, n = x$x.scales$tick.number, format.posixt = x$x.scales$format) yscale.comps <- if (y.relation.same) x$yscale.components(lim = x$y.limits, right = TRUE, ## rest passed on to ## calculateAxisComponents ## in the default ## case: at = x$y.scales$at, used.at = x$y.used.at, num.limit = x$y.num.limit, labels = x$y.scales$labels, logsc = x$y.scales$log, abbreviate = x$y.scales$abbr, minlength = x$y.scales$minl, n = x$y.scales$tick.number, format.posixt = x$y.scales$format) else x$yscale.components(lim = x$y.limits[[packet.number]], right = FALSE, ## rest passed on to ## calculateAxisComponents ## in the default ## case: at = if (is.list(x$y.scales$at)) x$y.scales$at[[packet.number]] else x$y.scales$at, used.at = x$y.used.at[[packet.number]], num.limit = x$y.num.limit[[packet.number]], labels = if (is.list(x$y.scales$labels)) x$y.scales$labels[[packet.number]] else x$y.scales$labels, logsc = x$y.scales$log, abbreviate = x$y.scales$abbr, minlength = x$y.scales$minl, n = x$y.scales$tick.number, format.posixt = x$y.scales$format) xscale <- xscale.comps$num.limit yscale <- yscale.comps$num.limit ## maybe over-ride with original limits if (x.same) xscale <- current.panel.limits()$xlim if (y.same) yscale <- current.panel.limits()$ylim ## do panel(); need a new viewport with scales from 'x' pushViewport(viewport(xscale = xscale, yscale = yscale)) do.call(x$panel, trellis.panelArgs(x, packet.number)) ## use axis components from the standard side only xscale.comps$top <- TRUE yscale.comps$right <- TRUE x.comp.list <- xscale.comps$bottom y.comp.list <- yscale.comps$left ## axes viewport (clip = "off" for outside axes) ## note: to draw an outside axis at top when there are stips: ## should really do it in strip.column.row.off pushViewport(viewport(xscale = xscale, yscale = yscale, clip = "off")) if (("x" %in% axes) && is.list(x.comp.list) && x$x.scales$draw) { comp.list <- x.comp.list scales.tck <- x$x.scales$tck[1] rot <- as.numeric(x$x.scales$rot)[1] if (outside[1]) { ## use axis.default where possible (i.e. where outside=TRUE) ## because it handles labels well in multi-panel layouts x$x.scales$alternating <- 3 x$axis(side = if (opposite[1]) "top" else "bottom", scales = x$x.scales, components = xscale.comps, as.table = x$as.table, rot = rot) } else { panel.axis(side = if (opposite[1]) "top" else "bottom", at = comp.list$ticks$at, labels = comp.list$labels$labels, #tick = do.ticks, #draw.labels = do.labels, check.overlap = comp.list$labels$check.overlap, outside = outside[1], half = FALSE, tck = scales.tck * comp.list$ticks$tck, rot = rot) } } if (("y" %in% axes) && is.list(y.comp.list) && x$y.scales$draw) { comp.list <- y.comp.list scales.tck <- x$y.scales$tck[1] rot <- as.numeric(x$y.scales$rot)[1] if (outside[2]) { ## use axis.default where possible (i.e. where outside=TRUE) ## because it handles labels well in multi-panel layouts x$y.scales$alternating <- 3 x$axis(side = if (opposite[2]) "right" else "left", scales = x$y.scales, components = yscale.comps, as.table = x$as.table, rot = rot) } else { panel.axis(side = if (opposite[2]) "right" else "left", at = comp.list$ticks$at, labels = comp.list$labels$labels, #tick = do.ticks, #draw.labels = do.labels, check.overlap = comp.list$labels$check.overlap, outside = outside[2], half = FALSE, tck = scales.tck * comp.list$ticks$tck, rot = rot) } } upViewport(2) }, data = list(x = x, x.same = x.same, y.same = y.same, axes = axes, opposite = opposite, outside = outside), theme = theme, ...) }
root@r-forge.r-project.org | ViewVC Help |
Powered by ViewVC 1.0.0 |