[R] levelplot behaviour for panel with constants

[Deepayan Sarkar]

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]))

                    }
                }
            }
        }
    }
}