Cómo hacer un diagrama de series de tiempo lleno de color degradado en R

time-series gradient

Question

¿Cómo llenar el área debajo y arriba (sp) de la línea con degradado de color ?

Este ejemplo se ha dibujado en Inkscape, PERO NECESITO gradiente vertical , NO horizontal.

Intervalo de cero a positivo == de blanco a rojo .

Intervalo de cero a negativo == de blanco a rojo .

¿Hay algún paquete que pueda hacer esto?

He fabricado algunos datos fuente ...

set.seed(1)
x<-seq(from = -10, to = 10, by = 0.25)
data <- data.frame(value = sample(x, 25, replace = TRUE), time = 1:25)
plot(data$time, data$value, type = "n")
my.spline <- smooth.spline(data$time, data$value, df = 15)
lines(my.spline$x, my.spline$y, lwd = 2.5, col = "blue")
abline(h = 0)

Answer 1

Aquí hay un enfoque, que se basa en gran medida en varios paquetes espaciales R.

La idea básica es:

• Trace una parcela vacía, el lienzo sobre el que se colocarán los elementos posteriores. (Hacer esto primero también le permite recuperar las coordenadas de usuario de la trama, necesarias en los pasos posteriores).

• Use una llamada vectorizada a rect() para establecer un lavado de color de fondo. Obtener los detalles complicados del gradiente de color es en realidad la parte más difícil de hacer esto.

• Use las funciones de topología en rgeos para encontrar primero los rectángulos cerrados en su figura, y luego su complemento. Trazar el complemento con un relleno blanco sobre el lavado de fondo cubre el color en todas partes, excepto dentro de los polígonos, justo lo que desea.

• Finalmente, use plot(..., add=TRUE) , lines() , abline() , etc. para establecer cualquier otro detalle que desee que muestre el gráfico.

library(sp)
library(rgeos)
library(raster)
library(grid)

## Extract some coordinates
x <- my.spline$x
y <- my.spline$y
hh <- 0
xy <- cbind(x,y)

## Plot an empty plot to make its coordinates available
## for next two sections
plot(data$time, data$value, type = "n", axes=FALSE, xlab="", ylab="")

## Prepare data to be used later by rect to draw the colored background
COL <- colorRampPalette(c("red", "white", "red"))(200)
xx <- par("usr")[1:2]
yy <- c(seq(min(y), hh, length.out=100), seq(hh, max(y), length.out=101))

## Prepare a mask to cover colored background (except within polygons)
## (a) Make SpatialPolygons object from plot''s boundaries
EE <- as(extent(par("usr")), "SpatialPolygons")
## (b) Make SpatialPolygons object containing all closed polygons
SL1 <- SpatialLines(list(Lines(Line(xy), "A")))
SL2 <- SpatialLines(list(Lines(Line(cbind(c(0,25),c(0,0))), "B")))
polys <- gPolygonize(gNode(rbind(SL1,SL2)))
## (c) Find their difference
mask <- EE - polys

## Put everything together in a plot
plot(data$time, data$value, type = "n")
rect(xx[1], yy[-201], xx[2], yy[-1], col=COL, border=NA)
plot(mask, col="white", add=TRUE)
abline(h = hh)
plot(polys, border="red", lwd=1.5, add=TRUE)
lines(my.spline$x, my.spline$y, col = "red", lwd = 1.5)

Answer 2

Esta es una forma terrible de engañar a ggplot para que haga lo que quiera. Esencialmente, hago una cuadrícula gigante de puntos que están debajo de la curva. Como no hay forma de establecer un gradiente dentro de un solo polígono, debe crear polígonos separados, de ahí la cuadrícula. Será lento si configura los píxeles demasiado bajos.

gen.bar <- function(x, ymax, ypixel) {
  if (ymax < 0) ypixel <- -abs(ypixel)
  else ypixel <-  abs(ypixel)
  expand.grid(x=x, y=seq(0,ymax, by = ypixel))
}

# data must be in x order.
find.height <- function (x, data.x, data.y) {
  base <- findInterval(x, data.x)
  run <- data.x[base+1] - data.x[base]
  rise <- data.y[base+1] - data.y[base]
  data.y[base] + ((rise/run) * (x - data.x[base]))
}

make.grid.under.curve <- function(data.x, data.y, xpixel, ypixel) {
  desired.points <- sort(unique(c(seq(min(data.x), max(data.x), xpixel), data.x)))
  desired.points <- desired.points[-length(desired.points)]

  heights <- find.height(desired.points, data.x, data.y)
  do.call(rbind, 
          mapply(gen.bar, desired.points, heights, 
                 MoreArgs = list(ypixel), SIMPLIFY=FALSE))
}

xpixel = 0.01
ypixel = 0.01
library(scales)
grid <- make.grid.under.curve(data$time, data$value, xpixel, ypixel)
ggplot(grid, aes(xmin = x, ymin = y, xmax = x+xpixel, ymax = y+ypixel, 
                 fill=abs(y))) + geom_rect() 

Los colores no son lo que deseabas, pero de todos modos es demasiado lento para un uso serio.

Answer 3

Otra posibilidad que utiliza funciones de paquetes grid y gridSVG .

Comenzamos generando puntos de datos adicionales por interpolación lineal, de acuerdo con los métodos descritos por @ kohske here . La gráfica básica consistirá en dos polígonos separados, uno para valores negativos y otro para valores positivos.

Una vez que se ha procesado la trama, grid.ls se usa para mostrar una lista de grob s, es decir, todos los componentes grob de la trama. En la lista encontraremos (entre otras cosas) dos geom_area.polygon s; uno que representa el polígono para valores <= 0 y otro para valores >= 0 .

El relleno de los grobs polígono se manipula utilizando gridSVG funciones gridSVG : los gradientes de color personalizados se crean con linearGradient , y el relleno de los grobs se reemplaza con grid.gradientFill .

La manipulación de gradientes grob se describe muy bien en el capítulo 7 de la tesis de maestría de Simon Potter, uno de los autores del paquete gridSVG .

library(grid)
library(gridSVG)
library(ggplot2)

# create a data frame of spline values
d <- data.frame(x = my.spline$x, y = my.spline$y)

# create interpolated points
d <- d[order(d$x),]
new_d <- do.call("rbind",
                 sapply(1:(nrow(d) -1), function(i){
                   f <- lm(x ~ y, d[i:(i+1), ])
                   if (f$qr$rank < 2) return(NULL)
                   r <- predict(f, newdata = data.frame(y = 0))
                   if(d[i, ]$x < r & r < d[i+1, ]$x)
                     return(data.frame(x = r, y = 0))
                   else return(NULL)
                 })
)

# combine original and interpolated data
d2 <- rbind(d, new_d)
d2  

# set up basic plot
ggplot(data = d2, aes(x = x, y = y)) +
  geom_area(data = subset(d2, y <= 0)) +
  geom_area(data = subset(d2, y >= 0)) +
  geom_line() +
  geom_abline(intercept = 0, slope = 0) +
  theme_bw()

# list the name of grobs and look for relevant polygons
# note that the exact numbers of the grobs may differ
grid.ls()
# GRID.gTableParent.878
# ...
#   panel.3-4-3-4
# ...
#     areas.gTree.834
#       geom_area.polygon.832 <~~ polygon for negative values
#     areas.gTree.838
#       geom_area.polygon.836 <~~ polygon for positive values

# create a linear gradient for negative values, from white to red
col_neg <- linearGradient(col = c("white", "red"),
                          x0 = unit(1, "npc"), x1 = unit(1, "npc"),
                          y0 = unit(1, "npc"), y1 = unit(0, "npc"))

# replace fill of ''negative grob'' with a gradient fill
grid.gradientFill("geom_area.polygon.832", col_neg, group = FALSE)

# create a linear gradient for positive values, from white to red
col_pos <- linearGradient(col = c("white", "red"),
                          x0 = unit(1, "npc"), x1 = unit(1, "npc"),
                          y0 = unit(0, "npc"), y1 = unit(1, "npc"))

# replace fill of ''positive grob'' with a gradient fill
grid.gradientFill("geom_area.polygon.836", col_pos, group = FALSE)


# generate SVG output
grid.export("myplot.svg")

Puede crear fácilmente diferentes gradientes de color para polígonos positivos y negativos. Por ejemplo, si desea que los valores negativos se ejecuten de blanco a azul, reemplace col_pos arriba con:

col_pos <- linearGradient(col = c("white", "blue"),
                          x0 = unit(1, "npc"), x1 = unit(1, "npc"),
                          y0 = unit(0, "npc"), y1 = unit(1, "npc"))

Answer 4

Y aquí hay un enfoque en la base R, donde llenamos el área de la trama completa con rectángulos de color graduado, y luego rellenamos el inverso del área de interés con blanco.

shade <- function(x, y, col, n=500, xlab=''x'', ylab=''y'', ...) {
  # x, y: the x and y coordinates
  # col: a vector of colours (hex, numeric, character), or a colorRampPalette
  # n: the vertical resolution of the gradient
  # ...: further args to plot()
  plot(x, y, type=''n'', las=1, xlab=xlab, ylab=ylab, ...)
  e <- par(''usr'')
  height <- diff(e[3:4])/(n-1)
  y_up <- seq(0, e[4], height)
  y_down <- seq(0, e[3], -height)
  ncolor <- max(length(y_up), length(y_down))
  pal <- if(!is.function(col)) colorRampPalette(col)(ncolor) else col(ncolor)
  # plot rectangles to simulate colour gradient
  sapply(seq_len(n),
         function(i) {
           rect(min(x), y_up[i], max(x), y_up[i] + height, col=pal[i], border=NA)
           rect(min(x), y_down[i], max(x), y_down[i] - height, col=pal[i], border=NA)
         })
  # plot white polygons representing the inverse of the area of interest
  polygon(c(min(x), x, max(x), rev(x)),
          c(e[4], ifelse(y > 0, y, 0), 
            rep(e[4], length(y) + 1)), col=''white'', border=NA)     
  polygon(c(min(x), x, max(x), rev(x)),
          c(e[3], ifelse(y < 0, y, 0), 
            rep(e[3], length(y) + 1)), col=''white'', border=NA)      
  lines(x, y)
  abline(h=0)
  box()  
}

Aquí hay unos ejemplos:

xy <- curve(sin, -10, 10, n = 1000)
shade(xy$x, xy$y, c(''white'', ''blue''), 1000)

O con el color especificado por una paleta de rampa de color:

shade(xy$x, xy$y, heat.colors, 1000)

Y aplicado a sus datos, aunque primero interpolamos los puntos a una resolución más fina (si no hacemos esto, el gradiente no sigue de cerca la línea donde cruza cero).

xy <- approx(my.spline$x, my.spline$y, n=1000)
shade(xy$x, xy$y, c(''white'', ''red''), 1000)