填寫兩行之間的區域，高/低和日期

Question

前言：我對自己的問題提供了一個合理滿意的答案。我明白這是可以接受的做法。當然，我的希望是邀請建議和改進。

我的目的是繪製兩個時間序列（存儲在數據框中，日期存儲爲「Date」類），並根據兩個數據點之間的區域是否高於另一個來填充數據點之間的區域。例如，繪製債券指數和股票指數，並在股票指數高於債券指數時填充紅色區域，否則用藍色填充該區域。

爲了達到這個目的，我使用了ggplot2，因爲我對這個軟件包非常熟悉（作者：Hadley Wickham），但隨時可以推薦其他方法。我編寫了一個基於ggplot2包的geom_ribbon()函數的自定義函數。早期我遇到了與我在處理geom_ribbon()功能和'Date'類對象方面缺乏經驗有關的問題。下面的功能代表了我努力解決這些問題，幾乎肯定它是迂迴，不必要的複雜，笨拙等。所以我的問題是：請建議改進​​和/或替代方法。最終，在這裏提供通用功能將是非常好的。

數據：

set.seed(123456789) 
df <- data.frame(
    Date = seq.Date(as.Date("1950-01-01"), by = "1 month", length.out = 12*10), 
    Stocks = 100 + c(0, cumsum(runif(12*10-1, -30, 30))), 
    Bonds = 100 + c(0, cumsum(runif(12*10-1, -5, 5)))) 
library('reshape2') 
df <- melt(df, id.vars = 'Date') 

自定義功能：

## Function to plot geom_ribbon for class Date 
geom_ribbon_date <- function(data, group, N = 1000) { 
    # convert column of class Date to numeric 
    x_Date <- as.numeric(data[, which(sapply(data, class) == "Date")]) 
    # append numeric date to dataframe 
    data$Date.numeric <- x_Date 
    # ensure fill grid is as fine as data grid 
    N <- max(N, length(x_Date)) 
    # generate a grid for fill 
    seq_x_Date <- seq(min(x_Date), max(x_Date), length.out = N) 
    # ensure the grouping variable is a factor 
    group <- factor(group) 
    # create a dataframe of min and max 
    area <- Map(function(z) { 
     d <- data[group == z,]; 
     approxfun(d$Date.numeric, d$value)(seq_x_Date); 
    }, levels(group)) 
    # create a categorical variable for the max 
    maxcat <- apply(do.call('cbind', area), 1, which.max) 
    # output a dataframe with x, ymin, ymax, is. max 'dummy', and group 
    df <- data.frame(x = seq_x_Date, 
     ymin = do.call('pmin', area), 
     ymax = do.call('pmax', area), 
     is.max = levels(group)[maxcat], 
     group = cumsum(c(1, diff(maxcat) != 0)) 
    ) 
    # convert back numeric dates to column of class Date 
    df$x <- as.Date(df$x, origin = "1970-01-01") 
    # create and return the geom_ribbon 
    gr <- geom_ribbon(data = df, aes(x, ymin = ymin, ymax = ymax, fill = is.max, group = group), inherit.aes = FALSE) 
    return(gr) 
} 

用法：

ggplot(data = df, aes(x = Date, y = value, group = variable, colour = variable)) + 
    geom_ribbon_date(data = df, group = df$variable) + 
    theme_bw() + 
    xlab(NULL) + 
    ylab(NULL) + 
    ggtitle("Bonds Versus Stocks (Fake Data!)") + 
    scale_fill_manual('is.max', breaks = c('Stocks', 'Bonds'), 
         values = c('darkblue','darkred')) + 
    theme(legend.position = 'right', legend.direction = 'vertical') + 
    theme(legend.title = element_blank()) + 
    theme(legend.key = element_blank()) 

結果：

雖然有相關的問題和答案，計算器，我還沒有找到，這就是一個足夠詳細的爲我的目的。這裏有一些有用的交流：

1. create-geom-ribbon-for-min-max-range：問一個類似的問題，但提供的細節比我想找的要少。
2. possible-bug-in-geom-ribbon：密切相關，但如何計算最大/最小值的中間步驟丟失。
3. fill-region-between-two-loess-smoothed-lines-in-r-with-ggplot：密切相關，但側重於黃土線。優秀。
4. ggplot-colouring-areas-between-density-lines-according-to-relative-position：密切相關，但重點關注密度。這篇文章極大地鼓舞了我。

Answer 1

也許我並不瞭解你的完整問題，但似乎相當直接的做法是將第三行定義爲每個時間點兩個時間序列的最小值。然後調用geom_ribbon兩次（每個唯一值爲Asset一次），以繪製每個系列和最小線條形成的色帶。代碼可能看起來像：

set.seed(123456789) 
df <- data.frame(
    Date = seq.Date(as.Date("1950-01-01"), by = "1 month", length.out = 12*10), 
    Stocks = 100 + c(0, cumsum(runif(12*10-1, -30, 30))), 
    Bonds = 100 + c(0, cumsum(runif(12*10-1, -5, 5)))) 

library(reshape2) 
library(ggplot2) 
df <- cbind(df,min_line=pmin(df[,2],df[,3])) 
df <- melt(df, id.vars=c("Date","min_line"), variable.name="Assets", value.name="Prices") 

sp <- ggplot(data=df, aes(x=Date, fill=Assets)) 
sp <- sp + geom_ribbon(aes(ymax=Prices, ymin=min_line)) 
sp <- sp + scale_fill_manual(values=c(Stocks="darkred", Bonds="darkblue")) 
sp <- sp + ggtitle("Bonds Versus Stocks (Fake Data!)") 
plot(sp) 

這將產生如下圖：

Answer 2

我前段時間實際上有同樣的問題，這裏是related post。它定義了一個函數使用matplot和polygon

EDIT

這裏是代碼找到兩列之間的兩個線和其它函數，它接受一個數據幀中的輸入，然後顏色空間之間的交叉，改性一個位，以允許最後的多邊形被繪製

set.seed(123456789) 
dat <- data.frame(
Date = seq.Date(as.Date("1950-01-01"), by = "1 month", length.out = 12*10), 
Stocks = 100 + c(0, cumsum(runif(12*10-1, -30, 30))), 
Bonds = 100 + c(0, cumsum(runif(12*10-1, -5, 5)))) 

intersects <- function(x1, x2) { 
    seg1 <- which(!!diff(x1 > x2))  # location of first point in crossing segments 
    above <- x2[seg1] > x1[seg1]  # which curve is above prior to crossing 
    slope1 <- x1[seg1+1] - x1[seg1] 
    slope2 <- x2[seg1+1] - x2[seg1] 
    x <- seg1 + ((x2[seg1] - x1[seg1])/(slope1 - slope2)) 
    y <- x1[seg1] + slope1*(x - seg1) 
    data.frame(x=x, y=y, pindex=seg1, pabove=(1:2)[above+1L]) 
# pabove is greater curve prior to crossing 
} 

fillColor <- function(data, addLines=TRUE) { 
## Find points of intersections 
ints <- intersects(data[,2], data[,3]) # because the first column is for Dates 
intervals <- findInterval(1:nrow(data), c(0, ints$x)) 

## Make plot 
matplot(data, type="n", col=2:3, lty=1, lwd=4,xaxt='n',xlab='Date') 
axis(1,at=seq(1,dim(data)[1],length.out=12), 
labels=data[,1][seq(1,dim(data)[1],length.out=12)]) 
legend("topright", c(colnames(data)[2], colnames(data)[3]), col=3:2, lty=1, lwd=2) 

## Draw the polygons 
for (i in seq_along(table(intervals))) { 
    xstart <- ifelse(i == 1, 0, ints$x[i-1]) 
    ystart <- ifelse(i == 1, data[1,2], ints$y[i-1]) 
    xend <- ints$x[i] 
    yend <- ints$y[i] 
    x <- seq(nrow(data))[intervals == i] 
    polygon(c(xstart, x, xend, rev(x)), c(ystart, data[x,2], yend, rev(data[x,3])), 
col=ints$pabove[i]%%2+2) 
} 

# add end of plot 

xstart <- ints[dim(ints)[1],1] 
ystart <- ints[dim(ints)[1],2] 
xend <- nrow(data) 
yend <- data[dim(data)[1],2] 
x <- seq(nrow(data))[intervals == max(intervals)] 
polygon(c(xstart, x, xend, rev(x)), c(ystart, data[x,2], yend, rev(data[x,3])), 
col=ints[dim(ints)[1]-1,4]%%2+2) 

## Add lines for curves 
if (addLines) 
    invisible(lapply(1:2, function(x) lines(seq(nrow(data)), data[,x], col=x%%2+2, lwd=2))) 
} 

## Plot the data 
fillColor(dat,FALSE) 

和最終結果是這樣的（與用於問題相同的數據）