[R] Coloring Stripchart Points, or Better, Lattice Equivalent

[Bryan Hanson]

If anyone remains interested, the solution in base graphics is to modify
stripchart.default, the last couple of lines where the coloring of points
defaults in a way that depends on groups.  In my example, the groups are
being handled collectively with the coloring.  Code is below.

Deepayan has noted that stacking of this type is not possible in Lattice
graphics, and would have to be coded directly (probably not too much of a
modification of what I give here, but I'm a novice!).

Thanks, Bryan

stripchart.colsym <-
function(x, method="overplot", jitter=0.1, offset=1/3, vertical=FALSE,
     group.names, add = FALSE, at = NULL,
     xlim=NULL, ylim=NULL, ylab=NULL, xlab=NULL, dlab="", glab="",
     log="", pch=0, col=par("fg"), cex=par("cex"), axes=TRUE,
     frame.plot=axes, ...)
{
    method <- pmatch(method, c("overplot", "jitter", "stack"))[1]
    if(is.na(method) || method==0)
    stop("invalid plotting method")
    groups <-
    if(is.list(x)) x
    else if(is.numeric(x)) list(x)
    if(0 == (n <- length(groups)))
    stop("invalid first argument")
    if(!missing(group.names))
    attr(groups, "names") <- group.names
    else if(is.null(attr(groups, "names")))
    attr(groups, "names") <- 1:n
    if(is.null(at))
    at <- 1:n
    else if(length(at) != n)
    stop(gettextf("'at' must have length equal to the number %d of groups",
                      n), domain = NA)
    if (is.null(dlab)) dlab <- deparse(substitute(x))

    if(!add) {
    dlim <- c(NA, NA)
    for(i in groups)
        dlim <- range(dlim, i[is.finite(i)], na.rm = TRUE)
    glim <- c(1,n)# in any case, not range(at)
    if(method == 2) { # jitter
        glim <- glim + jitter * if(n == 1) c(-5, 5) else c(-2, 2)
    } else if(method == 3) { # stack
        glim <- glim + if(n == 1) c(-1,1) else c(0, 0.5)
    }
    if(is.null(xlim))
        xlim <- if(vertical) glim else dlim
    if(is.null(ylim))
        ylim <- if(vertical) dlim else glim
    plot(xlim, ylim, type="n", ann=FALSE, axes=FALSE, log=log, ...)
    if (frame.plot) box()
    if(vertical) {
        if (axes) {
        if(n > 1) axis(1, at=at, labels=names(groups), ...)
        Axis(x, side = 2, ...)
        }
        if (is.null(ylab)) ylab <- dlab
        if (is.null(xlab)) xlab <- glab
    }
    else {
        if (axes) {
        Axis(x, side = 1, ...)
        if(n > 1) axis(2, at=at, labels=names(groups), ...)
        }
        if (is.null(xlab)) xlab <- dlab
        if (is.null(ylab)) ylab <- glab
    }    
    title(xlab=xlab, ylab=ylab)
    }
    csize <- cex*
    if(vertical) xinch(par("cin")[1]) else yinch(par("cin")[2])
    for(i in 1:n) {
    x <- groups[[i]]
    y <- rep.int(at[i], length(x))
    if(method == 2) ## jitter
        y <- y + stats::runif(length(y), -jitter, jitter)
    else if(method == 3) { ## stack
        xg <- split(x, factor(x))
        xo <- lapply(xg, seq_along)
        x <- unlist(xg, use.names=FALSE)
        y <- rep.int(at[i], length(x)) +
        (unlist(xo, use.names=FALSE) - 1) * offset * csize
    }
    if(vertical) points(y, x, col=col,
                pch=pch, cex=cex)
    else points(x, y, col=col,
            pch=pch, cex=cex)
    }
}

samples <- 100 # must be even
index <- round(runif(samples, 1, 100)) # set up data
resp <- rbinom(samples, 1, 0.5)
yr <- rep(c("2005", "2006"), samples/2)
all <- data.frame(index, resp, yr)
all$sym <- ifelse(all$resp == 1, 3, 1)
all$col <- ifelse(all$yr == 2005, "red", "blue")
all$count <- rep(1, length(all$index))
all <- all[order(all$index, all$yr, all$resp),] # for easier inspection
row.names(all) <- c(1:samples) # for easier inspection

one <- all[(all$yr == 2005 & all$resp == 0),] # First 2005/0 at bottom
two <- all[(all$yr == 2005 & all$resp == 1),] # Then 2005/1
three <- all[(all$yr == 2006 & all$resp == 0),] # Now 2006/0
four <- all[(all$yr == 2006 & all$resp == 1),] # Finally 2006/1

par(mfrow = c(5, 1))
par(plt = c(0.1, 0.9, 0.25, 0.75))
stripchart(one$index, method = "stack", ylim = c(0,10), xlim = c(1,100), col
= one$col, pch = one$sym)
mtext("2005/0 only", side = 3)
stripchart(two$index, method = "stack", ylim = c(0,10), xlim = c(1,100), col
= two$col, pch = two$sym)
mtext("2005/1 only", side = 3)
stripchart(three$index, method = "stack", ylim = c(0,10), xlim = c(1,100),
col = three$col, pch = three$sym)
mtext("2006/0 only", side = 3)
stripchart(four$index, method = "stack", ylim = c(0,10), xlim = c(1,100),
col = four$col, pch = four$sym)
mtext("2006/1 only", side = 3)
stripchart.colsym(all$index, method = "stack", ylim = c(0,10), xlim =
c(1,100), col = all$col, pch = all$sym)
mtext("all data, colored and symbolized as above", side = 3)