xyplot time series with positive values in green, negative in red, in R

Question

Is there a neat way to color negative values in red and others in green for a (simplified) time series plot below, using lattice::xyplot?

set.seed(0)
xyplot(zoo(cumsum(rnorm(100))), grid=T)

Answer 1

Lattice is based on grid so you can use grid's clipping functionality

library(lattice)
library(grid)

set.seed(0)
x <- zoo(cumsum(rnorm(100)))

xyplot(x, grid=TRUE, panel = function(x, y, ...){
       panel.xyplot(x, y, col="red", ...) 
       grid.clip(y=unit(0,"native"),just=c("bottom"))
       panel.xyplot(x, y, col="green", ...) })

Answer 2

When using type="l" you only have one "line" and it's all one color, so you might instead choose to color points:

set.seed(0); require(zoo); require(lattice)
vals <- zoo(cumsum(rnorm(100)))
png()
xyplot(vals, type=c("l","p"), col=c("red", "green")[1+( vals>0)], grid=T)
dev.off()

I found a solution by, Sundar Dorai-Rag, a fellow now at Google, to a similar request (to color the enclosed areas above and below 0, for which his approach to getting the crossing values for the X's was to invert the results of approx ) as seen here: http://r.789695.n4.nabble.com/shading-under-the-lines-in-a-lattice-xyplot-td793875.html. Instead of coloring the enclosed areas, I gave the borders of the polygons the desired colors and left the interior "transparent":

lpolygon <- function (x, y = NULL, border = NULL, col = NULL, ...) { 
   require(grid, TRUE) 
   xy <- xy.coords(x, y) 
   x <- xy$x 
   y <- xy$y 
   gp <- list(...) 
   if (!is.null(border)) gp$col <- border 
   if (!is.null(col)) gp$fill <- col 
   gp <- do.call("gpar", gp) 
   grid.polygon(x, y, gp = gp, default.units = "native") 
} 

find.zero <- function(x, y) { 
   n <- length(y) 
   yy <- c(0, y) 
   wy <- which(yy[-1] * yy[-n - 1] < 0) 
   if(!length(wy)) return(NULL) 
   xout <- sapply(wy, function(i) { 
     n <- length(x) 
     ii <- c(i - 1, i) 
     approx(y[ii], x[ii], 0)$y 
   }) 
   xout 
} 

trellis.par.set(theme = col.whitebg()) 
png();
xyplot(vals, panel = function(x,y, ...) { 
        x.zero <- find.zero(x, y) 
        y.zero <- y > 0 
        yy <- c(y[y.zero], rep(0, length(x.zero))) 
        xx <- c(x[y.zero], x.zero) 
        ord <- order(xx) 
        xx <- xx[ord] 
        xx <- c(xx[1], xx, xx[length(xx)]) 
        yy <- c(0, yy[ord], 0) 
        lpolygon(xx, yy, col="transparent", border = "green") 
        yy <- c(y[!y.zero], rep(0, length(x.zero))) 
        xx <- c(x[!y.zero], x.zero) 
        ord <- order(xx) 
        xx <- xx[ord] 
        xx <- c(xx[1], xx, xx[length(xx)]) 
        yy <- c(0, yy[ord], 0) 
        lpolygon(xx, yy, col = "transparent", border = "red") 
        panel.abline(h = 0) ;panel.grid(v=-1, h=-1 )
     }); dev.off()

Answer 3

I tried writing a custom panel function for this that will break a line on a given value

panel.breakline <- function(x,y,breakat=0,col.line,upper.col="red",lower.col="green",...){
    f <- approxfun(x,y)
    ff <- function(x) f(x)-breakat
    psign <- sign(y-breakat)
    breaks <- which(diff(psign) != 0)
    interp <- sapply(breaks, function(i) uniroot(ff,c(x[i], x[i+1]))$root)
    starts <- c(1,breaks+1)
    ends <- c(breaks, length(x))

    Map(function(start,end,left,right) {
        x <- x[start:end]
        y <- y[start:end]
        col <- ifelse(y[1]>breakat,upper.col,lower.col)
        panel.xyplot(c(left, x, right) ,c(breakat,y,breakat), col.line=col,...)
    }, starts, ends, c(NA,interp), c(interp,NA))
}

You can run with

library(zoo)
library(lattice)
set.seed(0)
zz<-zoo(cumsum(rnorm(100)))

xyplot(zz, grid=T, panel.groups=panel.breakline)

And you can change the break point or the colors as well

xyplot(zz, grid=T, panel.groups=panel.breakline, 
    breakat=2, upper.col="blue", lower.col="orange")

Answer 4

If one was to do it without points, then I'd stick to plot (instead of lattice) and use clip , like in one of the answers here : Plot a line chart with conditional colors depending on values

dat<- zoo(cumsum(rnorm(100)))

plot(dat, col="red")

clip(0,length(dat),0,max(dat) )
lines(dat, col="green")