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)
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", ...) })
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()
If you love us? You can donate to us via Paypal or buy me a coffee so we can maintain and grow! Thank you!
Donate Us With