xyplot Zeitreihe mit positiven Werten in grün, negativ in rot, in R

Question

Gibt es eine einfache Möglichkeit, negative Werte in rot und andere in grün für ein (vereinfachtes) Zeitreihendiagramm unter Verwendung von lattice::xyplot zu färben?

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

Answer 1

Lattic ändern e basiert auf grid so können Sie Clipping-Funktionalität verwenden Raster

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

Bei type = "l" verwenden Sie nur eine "Linie" haben und es ist alles eine Farbe, so dass Sie stattdessen Farbpunkte wählen könnten:

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

Ich fand eine Lösung von, Sundar Dorai-Rag, a fellow now at Google, zu einer ähnlichen Anfrage (um die eingeschlossenen Bereiche über und unter 0, für die seine Annäherung an getti zu färben ng die Kreuzungswerte für die X's war, die Ergebnisse von approx zu invertieren, wie hier zu sehen ist: http://r.789695.n4.nabble.com/shading-under-the-lines-in-a-lattice-xyplot-td793875.html. Statt die geschlossenen Bereiche das Färbens, habe ich die Grenzen der Polygone der gewünschten Farben und verließ die inneren „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() 

Answer 3

Wenn man es ohne Punkte zu tun war, dann würde ich Stick (statt Gitter) zu plotten und Clip verwenden, wie in einer der Antworten hier: 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

ich habe versucht, eine benutzerdefinierte Panel-Funktion für das Schreiben, das eine Linie auf einem bestimmten Wert brechen

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

Sie können mit

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

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

laufen Und Sie können den Haltepunkt oder die Farben als auch

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