# 如何在R中制作渐变颜色填充的时间序列图

==从 白色 红色的 间隔。

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

`gridSVG` 软件包的作者之一Simon Potter的 MSc论文 的第7章中很好地描述了 `grob` 梯度的操作。

``````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

# 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

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

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

• 绘制一个空图，在其上放置后续元素的画布。 （首先执行此操作，还可以检索后续步骤所需的绘图用户坐标。）

• 使用对 `rect()` 的矢量化调用来设置背景色。 实际上，获取颜色渐变的细节是最困难的部分。

• rgeos中 使用拓扑函数 首先 找到图中的闭合矩形，然后找到它们的补码。 在背景洗液上用白色填充绘制补色可以覆盖 多边形 之外 的所有颜色，这正是您想要的。

• 最后，使用 `plot(..., add=TRUE)``lines()``abline()` 等来放置您希望显示的其他细节。

``````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

## 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)
abline(h = hh)
lines(my.spline\$x, my.spline\$y, col = "red", lwd = 1.5)``````

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

``````xy <- curve(sin, -10, 10, n = 1000)
``shade(xy\$x, xy\$y, heat.colors, 1000)``
``````xy <- approx(my.spline\$x, my.spline\$y, n=1000)