shading under the lines in a lattice xyplot?

classic Classic list List threaded Threaded
3 messages Options
Reply | Threaded
Open this post in threaded view
|

shading under the lines in a lattice xyplot?

Andy Bunn
In the lattice plot below I want to fill-in the areas under each lines that
are greater than zero in gray. Is there a straightforward way to go about
this? Thanks, Andy

library(lattice)
foo <- data.frame(Yrs=rep(1:50,4), Y=rnorm(200),
                  Id=unlist(lapply(letters[1:4],rep,50)))
xyplot(Y~Yrs|Id, data = foo,
       panel = function(x,y) {
          panel.abline(h=0)
          panel.lines(x,y, col = "black")
       })

______________________________________________
[hidden email] mailing list
https://stat.ethz.ch/mailman/listinfo/r-help
PLEASE do read the posting guide! http://www.R-project.org/posting-guide.html
Reply | Threaded
Open this post in threaded view
|

Re: shading under the lines in a lattice xyplot?

Sundar Dorai-Raj


Andy Bunn wrote:

> In the lattice plot below I want to fill-in the areas under each lines that
> are greater than zero in gray. Is there a straightforward way to go about
> this? Thanks, Andy
>
> library(lattice)
> foo <- data.frame(Yrs=rep(1:50,4), Y=rnorm(200),
>                   Id=unlist(lapply(letters[1:4],rep,50)))
> xyplot(Y~Yrs|Id, data = foo,
>        panel = function(x,y) {
>           panel.abline(h=0)
>           panel.lines(x,y, col = "black")
>        })
>

Hi, Andy,

The following seems to work. It relies on two functions I have in my
personal package: find.zero, lpolygon. Let me know what you think.

library(lattice)

foo <- data.frame(Yrs = rep(1:50, 4), Y = rnorm(200),
                   Id = unlist(lapply(letters[1:4], rep, 50)))

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())
xyplot(Y ~ Yrs | Id, data = foo,
        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 = "gray")
           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 = "red", border = FALSE)
           panel.lines(x, y, col = "black")
           panel.abline(h = 0)
        })

______________________________________________
[hidden email] mailing list
https://stat.ethz.ch/mailman/listinfo/r-help
PLEASE do read the posting guide! http://www.R-project.org/posting-guide.html
Reply | Threaded
Open this post in threaded view
|

Re: shading under the lines in a lattice xyplot?

Andy Bunn
> -----Original Message-----
> From: Sundar Dorai-Raj [mailto:[hidden email]]
> Sent: Wednesday, February 15, 2006 1:40 PM
> To: Andy Bunn
> Cc: R-Help
> Subject: Re: [R] shading under the lines in a lattice xyplot?
>
>
>
>
> Andy Bunn wrote:
> > In the lattice plot below I want to fill-in the areas under
> each lines that
> > are greater than zero in gray. Is there a straightforward way
> to go about
> > this? Thanks, Andy
> >
> > library(lattice)
> > foo <- data.frame(Yrs=rep(1:50,4), Y=rnorm(200),
> >                   Id=unlist(lapply(letters[1:4],rep,50)))
> > xyplot(Y~Yrs|Id, data = foo,
> >        panel = function(x,y) {
> >           panel.abline(h=0)
> >           panel.lines(x,y, col = "black")
> >        })
> >
>
> Hi, Andy,
>
> The following seems to work. It relies on two functions I have in my
> personal package: find.zero, lpolygon. Let me know what you think.
>
> library(lattice)
>
> foo <- data.frame(Yrs = rep(1:50, 4), Y = rnorm(200),
>                    Id = unlist(lapply(letters[1:4], rep, 50)))
>
> 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())
> xyplot(Y ~ Yrs | Id, data = foo,
>         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 = "gray")
>            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 = "red", border = FALSE)
>            panel.lines(x, y, col = "black")
>            panel.abline(h = 0)
>         })
>

Sundar: That is exactly what I wanted. I had been trying something along
those lines and just realized I needed to find the zeros when your email
came in. That's perfect. Thanks, Andy

______________________________________________
[hidden email] mailing list
https://stat.ethz.ch/mailman/listinfo/r-help
PLEASE do read the posting guide! http://www.R-project.org/posting-guide.html