R help - Dec 2006 - missing factor levels in a lattice barchart panel cause unexpected failure

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

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.