xyplot 时间序列，绿色为正值，红色为负值，R 中

Question

对于下面的（简化的）时间序列图，是否有一种简洁的方法可以使用lattice::xyplot 将负值着色为红色，而将其他负值着色为绿色？

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

Answer 1

Lattice 基于grid，因此您可以使用网格的裁剪功能

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

当使用 type="l" 时，你只有一个“线”，而且都是一种颜色，所以你可以选择给点着色：

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

我通过 Sundar Dorai-Rag, a fellow now at Google, 找到了一个类似请求的解决方案（为 0 上方和下方的封闭区域着色，为此他获取 X 的交叉值的方法是反转 approx 的结果）为在这里看到：http://r.789695.n4.nabble.com/shading-under-the-lines-in-a-lattice-xyplot-td793875.html。我没有为封闭区域着色，而是为多边形的边界赋予了所需的颜色，并使内部保持“透明”：

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

我尝试为此编写一个自定义面板函数，该函数将在给定值上换行

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

你可以运行

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

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

您也可以更改断点或颜色

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

Answer 4

如果要在没有点的情况下进行，那么我会坚持使用 plot （而不是 lattice）并使用 clip ，就像这里的答案之一一样： 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")