Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- panel.barchart.alpha <- function (x, y, box.ratio = 1, box.width = box.ratio/(1 + box.ratio),
- horizontal = TRUE, origin = NULL, reference = TRUE, stack = FALSE,
- groups = NULL, col = if (is.null(groups)) plot.polygon$col else superpose.polygon$col,
- border = if (is.null(groups)) plot.polygon$border else superpose.polygon$border,
- lty = if (is.null(groups)) plot.polygon$lty else superpose.polygon$lty,
- lwd = if (is.null(groups)) plot.polygon$lwd else superpose.polygon$lwd,
- alpha = if (is.null(groups)) plot.polygon$alpha else superpose.polygon$alpha,
- ..., identifier = "barchart")
- {
- plot.polygon <- trellis.par.get("plot.polygon")
- superpose.polygon <- trellis.par.get("superpose.polygon")
- reference.line <- trellis.par.get("reference.line")
- keep <- (function(x, y, groups, subscripts, ...) {
- !is.na(x) & !is.na(y) & if (is.null(groups))
- TRUE
- else !is.na(groups[subscripts])
- })(x = x, y = y, groups = groups, ...)
- if (!any(keep))
- return()
- x <- as.numeric(x[keep])
- y <- as.numeric(y[keep])
- if (!is.null(groups)) {
- groupSub <- function(groups, subscripts, ...) groups[subscripts[keep]]
- if (!is.factor(groups))
- groups <- factor(groups)
- nvals <- nlevels(groups)
- groups <- as.numeric(groupSub(groups, ...))
- }
- if (horizontal) {
- if (is.null(groups)) {
- if (is.null(origin)) {
- origin <- current.panel.limits()$xlim[1]
- reference <- FALSE
- }
- height <- box.width
- if (reference)
- panel.abline(v = origin, col = reference.line$col,
- lty = reference.line$lty, lwd = reference.line$lwd,
- identifier = paste(identifier, "abline",
- sep = "."))
- panel.rect(x = rep(origin, length(y)), y = y, height = rep(height,
- length(y)), width = x - origin, border = border,
- col = col, lty = lty, lwd = lwd, alpha=alpha,
- just = c("left", "centre"), identifier = identifier)
- }
- else if (stack) {
- if (!is.null(origin) && origin != 0)
- warning("'origin' forced to 0 for stacked bars")
- col <- rep(col, length.out = nvals)
- border <- rep(border, length.out = nvals)
- lty <- rep(lty, length.out = nvals)
- lwd <- rep(lwd, length.out = nvals)
- alpha <- rep(alpha, length.out = nvals)
- height <- box.width
- if (reference)
- panel.abline(v = origin, col = reference.line$col,
- lty = reference.line$lty, lwd = reference.line$lwd,
- identifier = paste(identifier, "abline",
- sep = "."))
- for (i in unique(y)) {
- ok <- y == i
- ord <- sort.list(groups[ok])
- pos <- x[ok][ord] > 0
- nok <- sum(pos, na.rm = TRUE)
- if (nok > 0)
- panel.rect(x = cumsum(c(0, x[ok][ord][pos][-nok])),
- y = rep(i, nok), col = col[groups[ok][ord][pos]],
- border = border[groups[ok][ord][pos]], lty = lty[groups[ok][ord][pos]],
- lwd = lwd[groups[ok][ord][pos]], alpha = alpha[groups[ok][ord][pos]],
- height = rep(height, nok), width = x[ok][ord][pos], just = c("left",
- "centre"), identifier = paste(identifier,
- "pos", i, sep = "."))
- neg <- x[ok][ord] < 0
- nok <- sum(neg, na.rm = TRUE)
- if (nok > 0)
- panel.rect(x = cumsum(c(0, x[ok][ord][neg][-nok])),
- y = rep(i, nok), col = col[groups[ok][ord][neg]],
- border = border[groups[ok][ord][neg]], lty = lty[groups[ok][ord][neg]],
- lwd = lwd[groups[ok][ord][neg]], height = rep(height,
- nok), width = x[ok][ord][neg], just = c("left",
- "centre"), identifier = paste(identifier,
- "neg", i, sep = "."))
- }
- }
- else {
- if (is.null(origin)) {
- origin <- current.panel.limits()$xlim[1]
- reference <- FALSE
- }
- col <- rep(col, length.out = nvals)
- border <- rep(border, length.out = nvals)
- lty <- rep(lty, length.out = nvals)
- lwd <- rep(lwd, length.out = nvals)
- alpha <- rep(alpha, length.out = nvals)
- height <- box.width/nvals
- if (reference)
- panel.abline(v = origin, col = reference.line$col,
- lty = reference.line$lty, lwd = reference.line$lwd,
- identifier = paste(identifier, "abline",
- sep = "."))
- for (i in unique(y)) {
- ok <- y == i
- nok <- sum(ok, na.rm = TRUE)
- panel.rect(x = rep(origin, nok), y = (i + height *
- (groups[ok] - (nvals + 1)/2)), col = col[groups[ok]],
- border = border[groups[ok]], lty = lty[groups[ok]],
- lwd = lwd[groups[ok]], alpha = alpha[groups[ok]],
- height = rep(height,
- nok), width = x[ok] - origin, just = c("left",
- "centre"), identifier = paste(identifier,
- "y", i, sep = "."))
- }
- }
- }
- else {
- if (is.null(groups)) {
- if (is.null(origin)) {
- origin <- current.panel.limits()$ylim[1]
- reference <- FALSE
- }
- width <- box.width
- if (reference)
- panel.abline(h = origin, col = reference.line$col,
- lty = reference.line$lty, lwd = reference.line$lwd,
- identifier = paste(identifier, "abline",
- sep = "."))
- panel.rect(x = x, y = rep(origin, length(x)), col = col,
- border = border, lty = lty, lwd = lwd, alpha = alpha,
- width = rep(width, length(x)), height = y - origin, just = c("centre",
- "bottom"), identifier = identifier)
- }
- else if (stack) {
- if (!is.null(origin) && origin != 0)
- warning("'origin' forced to 0 for stacked bars")
- col <- rep(col, length.out = nvals)
- border <- rep(border, length.out = nvals)
- lty <- rep(lty, length.out = nvals)
- lwd <- rep(lwd, length.out = nvals)
- alpha <- rep(alpha, length.out = nvals)
- width <- box.width
- if (reference)
- panel.abline(h = origin, col = reference.line$col,
- lty = reference.line$lty, lwd = reference.line$lwd,
- identifier = paste(identifier, "abline",
- sep = "."))
- for (i in unique(x)) {
- ok <- x == i
- ord <- sort.list(groups[ok])
- pos <- y[ok][ord] > 0
- nok <- sum(pos, na.rm = TRUE)
- if (nok > 0)
- panel.rect(x = rep(i, nok), y = cumsum(c(0,
- y[ok][ord][pos][-nok])), col = col[groups[ok][ord][pos]],
- border = border[groups[ok][ord][pos]], lty = lty[groups[ok][ord][pos]],
- lwd = lwd[groups[ok][ord][pos]], alpha = alpha[groups[ok][ord][pos]],
- width = rep(width,
- nok), height = y[ok][ord][pos], just = c("centre",
- "bottom"), identifier = paste(identifier,
- "pos", i, sep = "."))
- neg <- y[ok][ord] < 0
- nok <- sum(neg, na.rm = TRUE)
- if (nok > 0)
- panel.rect(x = rep(i, nok), y = cumsum(c(0,
- y[ok][ord][neg][-nok])), col = col[groups[ok][ord][neg]],
- border = border[groups[ok][ord][neg]], lty = lty[groups[ok][ord][neg]],
- lwd = lwd[groups[ok][ord][neg]], alpha = alpha[groups[ok][ord][neg]],
- width = rep(width,
- nok), height = y[ok][ord][neg], just = c("centre",
- "bottom"), identifier = paste(identifier,
- "neg", i, sep = "."))
- }
- }
- else {
- if (is.null(origin)) {
- origin <- current.panel.limits()$ylim[1]
- reference = FALSE
- }
- col <- rep(col, length.out = nvals)
- border <- rep(border, length.out = nvals)
- lty <- rep(lty, length.out = nvals)
- lwd <- rep(lwd, length.out = nvals)
- alpha <- rep(alpha, length.out = nvals)
- width <- box.width/nvals
- if (reference)
- panel.abline(h = origin, col = reference.line$col,
- lty = reference.line$lty, lwd = reference.line$lwd,
- identifier = paste(identifier, "abline",
- sep = "."))
- for (i in unique(x)) {
- ok <- x == i
- nok <- sum(ok, na.rm = TRUE)
- panel.rect(x = (i + width * (groups[ok] - (nvals +
- 1)/2)), y = rep(origin, nok), col = col[groups[ok]],
- border = border[groups[ok]], lty = lty[groups[ok]],
- lwd = lwd[groups[ok]], alpha = alpha[groups[ok]],
- width = rep(width, nok),
- height = y[ok] - origin, just = c("centre",
- "bottom"), identifier = paste(identifier,
- "x", i, sep = "."))
- }
- }
- }
- }
- environment(panel.barchart.alpha) <- asNamespace("lattice")
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement