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