Временные ряды xyplot с положительными значениями в зеленом, отрицательные по красному, в R

Question

Есть ли опрятный способ окрашивания отрицательных значений в красный цвет, а другие - зеленым цветом для (упрощенного) графика временных рядов ниже, используя lattice::xyplot?

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

Answer 1

Lattic е основано на grid поэтому вы можете использовать функциональные возможности подрезки 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

При использовании типа = "л" у вас есть только один "линию", и это все один цвет, так что вы могли бы вместо того, чтобы выбрать цвета точек:

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, для которых его подход к getti ng значения пересечения для 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

Если один должен был сделать это без очков, то я бы придерживайтесь участок (вместо решетки) и использовать скрепку, как в одном из ответов здесь: 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

Я пытался писать пользовательскую функцию панели для этого, что будет разорвать линию на заданном значении

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