[R] missing factor levels in a lattice barchart panel cause unexpected failure
Alex Brown
alex at transitive.com
Tue Dec 12 19:17:46 CET 2006
I think I've found the problem, and a sort of fix, for this issue.
It appears in the panel.barchart function
each of the clauses in the function has a set of lines roughly like:
groups <- as.numeric(groupSub(groups, ...))
vals <- sort(unique(groups))
nvals <- length(vals)
col <- rep(col, length = nvals)
border <- rep(border, length = nvals)
lty <- rep(lty, length = nvals)
lwd <- rep(lwd, length = nvals)
height <- box.ratio/(1 + nvals * box.ratio)
if (reference)
panel.abline(v = origin, col = reference.line$col,
lty = reference.line$lty, lwd = reference.line$lwd)
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]], height = rep(height,
nok), width = x[ok] - origin, just = c("left",
"centre"))
}
Which sets the parameter lty (and others) to NA in the example below.
> D = data.frame(X=1, Y=factor(letters[2], letters[1:2]))
> barchart(~ X, D, groups=Y)
This (NA) is because:
groups=[1] b
Levels: a b
thus the code then does
groups==2
vals==2
nvals==1
ok==TRUE
hence
groups[ok] == 2
but
length(lwd) == 1
thus
lwd[groups[ok]] == lwd[2] == NA
This is due to the mistaken assumption that the numeric component of
groups must be a subset of the 1:length(groups), when in fact it can
be a subset of 1:length(levels(groups)).
a silly fix:
----
replacing
groups <- as.numeric(groupSub(groups, ...))
vals <- sort(unique(groups))
nvals <- length(vals)
with
nvals <- length(levels(groups))
groups <- as.numeric(groupSub(groups, ...))
fixes my example, but it clearly short of a full solution.
This example causes the same error, with a different situation.
Q = data.frame(X=c(NaN, 1), Y=factor(letters[1:2], letters[1:2]))
barchart(~ X, Q, groups=Y)
-Alex Brown
panel.barchart.fixed =
function (x, y, box.ratio = 1, 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,
...)
{
if (!is.null(groups) && !is.factor(groups))
groups <- factor(groups)
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])
plot.polygon <- trellis.par.get("plot.polygon")
superpose.polygon <- trellis.par.get("superpose.polygon")
reference.line <- trellis.par.get("reference.line")
groupSub <- function(groups, subscripts, ...) groups[subscripts
[keep]]
if (horizontal) {
if (is.null(groups)) {
if (is.null(origin)) {
origin <- current.panel.limits()$xlim[1]
reference <- FALSE
}
height <- box.ratio/(1 + box.ratio)
if (reference)
panel.abline(v = origin, col = reference.line$col,
lty = reference.line$lty, lwd = reference.line$lwd)
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, just = c("left",
"centre"))
}
else if (stack) {
if (!is.null(origin) && origin != 0)
warning("origin forced to 0 for stacked bars")
nvals <- length(levels(groups))
groups <- as.numeric(groupSub(groups, ...))
col <- rep(col, length = nvals)
border <- rep(border, length = nvals)
lty <- rep(lty, length = nvals)
lwd <- rep(lwd, length = nvals)
height <- box.ratio/(1 + box.ratio)
if (reference)
panel.abline(v = origin, col = reference.line$col,
lty = reference.line$lty, lwd = reference.line$lwd)
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]], height = rep
(height,
nok), width = x[ok][ord][pos], just = c("left",
"centre"))
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"))
}
}
else {
if (is.null(origin)) {
origin <- current.panel.limits()$xlim[1]
reference <- FALSE
}
nvals <- length(levels(groups))
groups <- as.numeric(groupSub(groups, ...))
col <- rep(col, length = nvals)
border <- rep(border, length = nvals)
lty <- rep(lty, length = nvals)
lwd <- rep(lwd, length = nvals)
height <- box.ratio/(1 + nvals * box.ratio)
if (reference)
panel.abline(v = origin, col = reference.line$col,
lty = reference.line$lty, lwd = reference.line$lwd)
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]], height = rep(height,
nok), width = x[ok] - origin, just = c("left",
"centre"))
}
}
}
else {
if (is.null(groups)) {
if (is.null(origin)) {
origin <- current.panel.limits()$ylim[1]
reference <- FALSE
}
width <- box.ratio/(1 + box.ratio)
if (reference)
panel.abline(h = origin, col = reference.line$col,
lty = reference.line$lty, lwd = reference.line$lwd)
panel.rect(x = x, y = rep(origin, length(x)), col = col,
border = border, lty = lty, lwd = lwd, width = rep
(width,
length(x)), height = y - origin, just = c("centre",
"bottom"))
}
else if (stack) {
if (!is.null(origin) && origin != 0)
warning("origin forced to 0 for stacked bars")
nvals <- length(levels(groups))
groups <- as.numeric(groupSub(groups, ...))
col <- rep(col, length = nvals)
border <- rep(border, length = nvals)
lty <- rep(lty, length = nvals)
lwd <- rep(lwd, length = nvals)
width <- box.ratio/(1 + box.ratio)
if (reference)
panel.abline(h = origin, col = reference.line$col,
lty = reference.line$lty, lwd = reference.line$lwd)
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]], width = rep(width,
nok), height = y[ok][ord][pos], just = c
("centre",
"bottom"))
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]], width = rep(width,
nok), height = y[ok][ord][neg], just = c
("centre",
"bottom"))
}
}
else {
if (is.null(origin)) {
origin <- current.panel.limits()$ylim[1]
reference = FALSE
}
nvals <- length(levels(groups))
groups <- as.numeric(groupSub(groups, ...))
col <- rep(col, length = nvals)
border <- rep(border, length = nvals)
lty <- rep(lty, length = nvals)
lwd <- rep(lwd, length = nvals)
width <- box.ratio/(1 + nvals * box.ratio)
if (reference)
panel.abline(h = origin, col = reference.line$col,
lty = reference.line$lty, lwd = reference.line$lwd)
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]], width = rep(width, nok),
height = y[ok] - origin, just = c("centre",
"bottom"))
}
}
}
}
On 8 Dec 2006, at 12:27, Alex Brown wrote:
> Hi all - I'm trying to generate lattice barchart graphs with missing
> values, and came across the following:
>
> This does not run. I would expect it to:
>
> library(lattice)
> D = data.frame(X=1, Y=factor(letters[2], letters[1:2]))
> barchart(~ X, D, groups=Y)
>
> Error in grid.Call.graphics("L_rect", x$x, x$y, x$width, x$height,
> resolveHJust(x$just, :
> invalid line type
>
> which is simply solved by changing the factor levels:
>
> D$Y = factor(D$Y)
> barchart(~ X, D, groups=Y)
>
> or by filling factor levels from the bottom:
>
> D = data.frame(X=1, Y=factor(letters[1], letters[1:2]))
> barchart(~ X, D, groups=Y)
>
> However, the failure is important, because it causes the following to
> fail, no matter how Y is levelled
>
> E = data.frame(X=c(1,2,3,4), Y=factor(letters[c(1,2,1,2)], letters
> [1:2]), Z=factor(c("F","F","G","H")));
> barchart(~ X | Z, E, groups=Y)
>
> Which is an example of a comparison over multiple tests Z for
> different parameter Y where some Y are missing.
>
> alternative version:
>
> E = data.frame(X=c(1,2,3,4), Y=letters[c(1,2,1,2)], Z=letters[c
> (7,7,8,9)]);
> barchart(~ X | Z, E, groups=Y)
>
> I have updated to 2.4.0 and lattice 0.14-16 and the problem still
> exists.
>
> -Alex Brown
>
> ______________________________________________
> R-help at stat.math.ethz.ch mailing list
> https://stat.ethz.ch/mailman/listinfo/r-help
> PLEASE do read the posting guide http://www.R-project.org/posting-
> guide.html
> and provide commented, minimal, self-contained, reproducible code.
More information about the R-help
mailing list