Skip to content

Instantly share code, notes, and snippets.

@MrFlick

MrFlick/panel.barchart.alpha.R

Last active June 13, 2019 20:00
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save MrFlick/d705d63075dd1d0c804be8e5543b9e72 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save MrFlick/d705d63075dd1d0c804be8e5543b9e72 to your computer and use it in GitHub Desktop.
Download ZIP
Update lattice bwplot to use alpha
Raw
panel.barchart.alpha.R
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