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

Question

使用lattice::xyplot ，是否有一种巧妙的方法可以为下面的（简化）时间序列图中的红色和其他绿色的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提出了类似的要求（为0和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

如果一个人没有点，那么我会坚持绘图（而不是格子）并使用剪辑，就像在这里的一个答案中一样： 根据值绘制带有条件颜色的折线图

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

plot(dat, col="red")

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