On Thursday 21 August 2003 07:42, Edzer J. Pebesma
wrote:> In the example:
>
> x = rep(c(0,0,1,1),4)
> y = rep(c(0,1,0,1),4)
> z = c(1,0,1,0,0,0,1,1,0,1,0,0,1,1,1,1)
> f =
as.factor(c(rep("a",4),rep("b",4),rep("c",4),rep("d",4)))
> levelplot(z~x+y|f,data.frame(x=x,y=y,z=z,f=f))
>
> I noted that the last ("d") plot remains empty. I guess the
> reason for this is that the values are constant (1), but I consider
> it more consistent if they would get the colour of 1, and would
> be left blank in case they were NA's.
> --
> Edzer
Redefining panel.levelplot as in the attached file should fix the problem.
Deepayan
-------------- next part --------------
panel.levelplot <-
function(x, y, z, zcol,
subscripts,
at = mean(z),
shrink,
labels = NULL,
label.style = c("mixed", "flat",
"align"),
contour = TRUE,
region = TRUE,
col = add.line$col,
lty = add.line$lty,
lwd = add.line$lwd,
cex = add.text$cex,
font = add.text$font,
col.text = add.text$col,
...,
col.regions)
{
label.style <- match.arg(label.style)
x <- as.numeric(x[subscripts])
y <- as.numeric(y[subscripts])
fullZrange <- range(as.numeric(z), na.rm = TRUE) # for shrinking
z <- as.numeric(z[subscripts])
zcol <- as.numeric(zcol[subscripts])
## Do we need a zlim-like argument ?
shrinkx <- c(1, 1)
shrinky <- c(1, 1)
if (!missing(shrink)) {
if (is.numeric(shrink)) {
shrinkx <- rep(shrink, length = 2)
shrinky <- rep(shrink, length = 2)
}
else if (is.list(shrink)) {
shrinkx <- rep(shrink[[1]], length = 2)
shrinky <- rep(shrink[[1]], length = 2)
if ("x" %in% names(shrink)) shrinkx <- rep(shrink$x,
length = 2)
if ("y" %in% names(shrink)) shrinky <- rep(shrink$y,
length = 2)
}
else warning("Invalid shrink, ignored")
}
scaleWidth <- function(z, min = .8, max = .8, zl = range(z, na.rm =
TRUE)) {
if (diff(zl) == 0) rep(.5 * (min + max), length(z))
else min + (max - min) * (z - zl[1]) / diff(zl)
}
if (any(subscripts)) {
## sorted unique values of x
ux <- sort(unique(x[!is.na(x)]))
## actual box boundaries (x axis)
bx <- c(3 * ux[1] - ux[2],
ux[-length(ux)] + ux[-1],
3 * ux[length(ux)] - ux[length(ux)-1]) / 2
## dimension of rectangles
lx <- diff(bx)
## centers of rectangles
cx <- (bx[-1] + bx[-length(bx)])/2
## same things for y
uy <- sort(unique(y[!is.na(y)]))
by <- c(3 * uy[1] - uy[2],
uy[-length(uy)] + uy[-1],
3 * uy[length(uy)] - uy[length(uy)-1]) / 2
ly <- diff(by)
cy <- (by[-1] + by[-length(by)])/2
idx <- match(x, ux)
idy <- match(y, uy)
if (region)
grid.rect(x = cx[idx],
y = cy[idy],
width = lx[idx] * scaleWidth(z, shrinkx[1], shrinkx[2],
fullZrange),
height = ly[idy] * scaleWidth(z, shrinky[1], shrinky[2],
fullZrange),
default.units = "native",
gp = gpar(fill=col.regions[zcol], col = NULL))
if (contour) {
add.line <- trellis.par.get("add.line")
add.text <- trellis.par.get("add.text")
ux <- as.double(ux)
uy <- as.double(uy)
ord <- order(x, y)
m <- z[ord] + 10e-12 ## some problems otherwise
for (i in seq(along = at)) {
val <- .Call("calculateContours", m, ux, uy,
as.double(at[i]),
length(ux), length(uy),
PACKAGE="lattice")
if (length(val[[1]]) > 3) {
if (is.null(labels))
lsegments(val[[1]], val[[2]], val[[3]], val[[4]],
col = col, lty = lty, lwd = lwd)
else {
if (label.style == "flat") {
slopes <-
(val[[4]] - val[[2]]) /
(val[[3]] - val[[1]])
textloc <- which(abs(slopes) ==
min(abs(slopes)))[1]
##skiploc <- numeric(0)
rotangle <- 0
}
else if (label.style == "align") {
rx <- range(ux)
ry <- range(uy)
depth <- pmin( (val[[1]] + val[[3]] - 2 *
rx[1])/diff(rx),
(2 * rx[2] - val[[1]] -
val[[3]])/diff(rx),
(val[[2]] + val[[4]] - 2 *
ry[1])/diff(ry),
(2 * ry[2] - val[[2]] -
val[[4]])/diff(ry))
textloc <- which(depth == max(depth))[1]
slopes <-
(val[[4]][textloc] - val[[2]][textloc]) /
(val[[3]][textloc] - val[[1]][textloc])
rotangle <- atan(slopes * diff(rx) / diff(ry)) *
180 / base::pi
}
else if (label.style == "mixed") {
slopes <-
(val[[4]] - val[[2]]) /
(val[[3]] - val[[1]])
rx <- range(ux)
ry <- range(uy)
depth <- pmin( (val[[1]] + val[[3]] - 2 *
rx[1])/diff(rx),
(2 * rx[2] - val[[1]] -
val[[3]])/diff(rx),
(val[[2]] + val[[4]] - 2 *
ry[1])/diff(ry),
(2 * ry[2] - val[[2]] -
val[[4]])/diff(ry))
textloc <- which(abs(slopes) == min(abs(slopes),
na.rm = TRUE))[1]
rotangle <- 0
if ( depth[textloc] < .05 ) {
textloc <- which(depth == max(depth))[1]
rotangle <- atan(slopes[textloc] * diff(rx) /
diff(ry)) * 180 / base::pi
}
}
else stop("Invalid label.style")
lsegments(val[[1]], val[[2]],
val[[3]], val[[4]],
col = col, lty = lty, lwd = lwd)
ltext(lab = labels$lab[i], adj = c(.5, 0),
srt = rotangle,
col = col.text, cex = cex, font = font,
x = .5 * (val[[1]][textloc]+val[[3]][textloc]),
y = .5 * (val[[2]][textloc]+val[[4]][textloc]))
}
}
}
}
}
}