szereg czasowy xyplot z dodatnimi wartościami na zielono, ujemny na czerwono, w R

Question

Czy istnieje sposób na kolorowanie wartości ujemnych na czerwono, a na zielono na (uproszczonym) wykresie szeregu czasowego poniżej, używając lattice::xyplot?

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

Answer 1

Lattic e opiera się na grid więc można użyć funkcji przycinania dla siatki

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

Podczas korzystania type = "L" masz tylko jedno "linia" i to wszystko w jednym kolorze, więc może zamiast tego wybrać do punktów kolorystycznych:

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

Znalazłem rozwiązanie przez, Sundar Dorai-Rag, a fellow now at Google, do podobnego wniosku (do pokolorowania obszarów zamkniętych powyżej i poniżej 0, dla których jego podejście do getti ng wartości skrzyżowania dla X były odwrócić wyniki approx), jak widać tutaj: http://r.789695.n4.nabble.com/shading-under-the-lines-in-a-lattice-xyplot-td793875.html. Zamiast barwienia zamknięte obszary, dałem granicami poligonów żądane kolory i opuścił wnętrze „przezroczysty”:

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

Jeśli był to zrobić bez punktów, wtedy bym trzymać się wykreślić (zamiast kraty) i używać klipu, jak w jednym z tutejszych odpowiada: 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") 

Answer 4

próbowałem pisząc funkcję niestandardowego panelu na to, że będzie złamać linię na danej wartości

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

można uruchomić z

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

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

I można zmienić punkt przerwania lub kolory oraz

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