### Copyright (C) 2001-2006 Deepayan Sarkar ### ### ### This file is part of the lattice package for R. ### It is made available under the terms of the GNU General Public ### License, version 2, or at your option, any later version, ### incorporated herein by reference. ### ### This program is distributed in the hope that it will be ### useful, but WITHOUT ANY WARRANTY; without even the implied ### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ### PURPOSE. See the GNU General Public License for more ### details. ### ### You should have received a copy of the GNU General Public ### License along with this program; if not, write to the Free ### Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, ### MA 02110-1301, USA ## convenient shortcut to create custom strip functions from ## strip.default. Looks a bit dicey, may not always work :-/ strip.custom <- function(...) { args <- list(...) function(...) { dots <- list(...) do.call("strip.default", updateList(dots, args)) } } paste.and.draw <- function(left, right, sep = " : ", horizontal = TRUE, center = TRUE, showl = TRUE, showr = TRUE, gp = gpar()) { ## We are already in a viewport. Essentially want to draw ## paste(left, right, sep = sep) in the middle. The catch is, ## left and right (maybe even sep) may be expressions. The easy ## solution is to draw sep in the middle and left and right on ## either side. The better solution is to combine and then ## center. if (showl || showr) { shows <- showl && showr wsep <- unit(0.5 * shows, "strwidth", list(sep)) offset <- unit(0.5, "npc") if (center) offset <- offset + (if (showl) unit(0.5, "strwidth", list(left)) else unit(0, "mm")) - (if (showr) unit(0.5 * showr, "strwidth", list(right)) else unit(0, "mm")) if (horizontal) { if (shows) grid.text(sep, x = offset, gp = gp) if (showl) grid.text(left, x = offset - wsep, gp = gp, just = "right") if (showr) grid.text(right, x = offset + wsep, gp = gp, just = "left") } else { if (shows) grid.text(sep, y = offset, gp = gp, rot = 90) if (showl) grid.text(left, y = offset - wsep, gp = gp, just = "right", rot = 90) if (showr) grid.text(right, y = offset + wsep, gp = gp, just = "left", rot = 90) } } } strip.default <- function(which.given, which.panel, ## packet.number, ## panel.number, var.name, factor.levels, shingle.intervals = NULL, strip.names = c(FALSE, TRUE), strip.levels = c(TRUE, FALSE), sep = " : ", style = 1, horizontal = TRUE, ## FIXME: not sure how to incorporate alpha in strip colors bg = trellis.par.get("strip.background")$col[which.given], fg = trellis.par.get("strip.shingle")$col[which.given], par.strip.text = trellis.par.get("add.text")) { if (horizontal) pushViewport(viewport(y = (which.given-0.5)/length(which.panel), height = 1/length(which.panel), clip = trellis.par.get("clip")$strip, name = paste("strip.default", which.given, sep = "."))) else pushViewport(viewport(x = 1 - (which.given-0.5)/length(which.panel), width = 1/length(which.panel), clip = trellis.par.get("clip")$strip, name = paste("strip.default", which.given, sep = "."))) gp.text <- gpar(col = par.strip.text$col, alpha = par.strip.text$alpha, lineheight = par.strip.text$lineheight, fontfamily = par.strip.text$fontfamily, fontface = chooseFace(par.strip.text$fontface, par.strip.text$font), cex = par.strip.text$cex) name <- var.name[which.given] level <- which.panel[which.given] strip.names <- rep(strip.names, length.out = 2) strip.levels <- rep(strip.levels, length.out = 2) ## str(shingle.intervals) formatLabel <- function(s, abbreviate = par.strip.text$abbr, minlength = par.strip.text$minl, dot = par.strip.text$dot) { if (is.null(abbreviate)) abbreviate <- FALSE if (is.null(minlength)) minlength <- 4 if (is.null(dot)) dot <- FALSE if (abbreviate) abbreviate(s, minlength = minlength, dot = dot) else s } factor.levels <- formatLabel(factor.levels) if (!is.null(shingle.intervals)) { ## This usually indicates shingles, as opposed to factors. ## 'style' will be completely ignored, and shingle.intervals ## encoded using bg and fg. Names and levels are both game. grid.rect(gp = gpar(fill = bg, col = bg)) t <- range(shingle.intervals) r <- (range(shingle.intervals[level,]) - t[1]) / diff(t) if (horizontal) grid.rect(x = unit(r %*% c(.5,.5),"npc"), width = max(unit(c(diff(r), 1), c("npc", "mm"))), gp = gpar(col = fg, fill = fg)) else grid.rect(y = unit(r %*% c(.5,.5),"npc"), height = max(unit( c(diff(r), 1), c("npc", "mm"))), gp = gpar(col = fg, fill = fg)) paste.and.draw(name, factor.levels[level], sep = sep, horizontal = horizontal, showl = strip.names[2], showr = strip.levels[2], gp = gp.text) } else { ## Behaviour depends on 'style'. Will separate out coloring ## and text based on 'style'. num <- length(factor.levels) ## coloring: ## background: all except style = 2 if (style != 2) grid.rect(gp = gpar(fill = bg, col = bg)) ## foreground: needed only for style = 2, 3 and 4 if (num > 0 && style %in% c(2, 3, 4)) { if (horizontal) { grid.rect(x = unit((2*level-1)/(2*num), "npc"), width = unit(1/num, "npc"), gp = gpar(fill = fg, col = fg)) } else { grid.rect(y = unit((2*level-1)/(2*num), "npc"), height = unit(1/num, "npc"), gp = gpar(fill = fg, col = fg)) } } ## text: [names|levels] centered only if style = 1 or 3 if (style %in% c(1, 3)) { paste.and.draw(name, factor.levels[level], sep = sep, horizontal = horizontal, showl = strip.names[1], showr = strip.levels[1], gp = gp.text) } ## remaining cases else if (num > 0) { ## either all levels or only one lid <- if (style %in% c(2, 4)) 1:num else level if (horizontal) { grid.text(label = factor.levels[lid], x = (2 * lid - 1) / (2 * num), gp = gp.text) } else { grid.text(label = factor.levels[lid], y = (2 * lid - 1) / (2 * num), rot = 90, gp = gp.text) } } } upViewport() ## border is drawn with clipping off if (horizontal) pushViewport(viewport(y = (which.given-0.5)/length(which.panel), height = 1/length(which.panel), clip = "off", name = paste("strip.default.off", which.given, sep = "."))) else pushViewport(viewport(x = 1 - (which.given-0.5)/length(which.panel), width = 1/length(which.panel), clip = "off", name = paste("strip.default.off", which.given, sep = "."))) strip.border <- trellis.par.get("strip.border") ## draw border for strip grid.rect(gp = gpar(col = rep(strip.border$col, length.out = which.given)[which.given], lty = rep(strip.border$lty, length.out = which.given)[which.given], lwd = rep(strip.border$lwd, length.out = which.given)[which.given], alpha = rep(strip.border$alpha, length.out = which.given)[which.given], fill = "transparent")) upViewport() }