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