Last active
June 13, 2019 20:00
-
-
Save MrFlick/d705d63075dd1d0c804be8e5543b9e72 to your computer and use it in GitHub Desktop.
Update lattice bwplot to use alpha
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| 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") |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment