Area di riempimento tra due linee, con alta/bassa e date

Question

Forword: Fornisco una risposta ragionevolmente soddisfacente alla mia domanda. Capisco che questa è una pratica accettabile. Naturalmente la mia speranza è di invitare suggerimenti e miglioramenti.

Il mio scopo è tracciare due serie temporali (memorizzate in un dataframe con le date memorizzate come classe 'Data') e per riempire l'area tra i punti dati con due colori diversi a seconda che uno sia sopra l'altro. Per esempio, per tracciare un indice di Obbligazioni e un indice di Azioni, e per riempire l'area in rosso quando l'indice azionario è sopra l'indice obbligazionario, e per riempire l'area in blu altrimenti.

Ho usato ggplot2 per questo scopo, perché sono abbastanza familiare con il pacchetto (autore: Hadley Wickham), ma sentitevi liberi di suggerire altri approcci. Ho scritto una funzione personalizzata basata sulla funzione geom_ribbon() del pacchetto ggplot2. All'inizio ho dovuto affrontare problemi relativi alla mia mancanza di esperienza nella gestione della funzione geom_ribbon() e degli oggetti della classe 'Date'. La funzione sotto rappresenta il mio sforzo per risolvere questi problemi, quasi sicuramente è rotonda, inutilmente complicata, maldestra, ecc. Quindi la mia domanda è: Si prega di suggerire miglioramenti e/o approcci alternativi. In definitiva, sarebbe bello avere una funzione generale disponibile qui.

dati:

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

funzione personalizzata:

## 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) 
} 

Usage:

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

Risultato:

Mentre ci sono domande e risposte su StackOverflow legate, non ho trovato uno che era sufficientemente dettagliata per il mio scopo. Ecco una selezione di scambi utili:

1. create-geom-ribbon-for-min-max-range: fa una domanda simile, ma fornisce meno dettagli di quelli che stavo cercando.
2. possible-bug-in-geom-ribbon: strettamente correlati, ma mancano passaggi intermedi su come calcolare il massimo/minimo.
3. fill-region-between-two-loess-smoothed-lines-in-r-with-ggplot: strettamente correlato, ma si concentra sulle linee loess. Eccellente.
4. ggplot-colouring-areas-between-density-lines-according-to-relative-position: strettamente correlato, ma focalizzato sulle densità. Questo post mi ha ispirato molto.

Answer 1

Forse non sto capendo il tuo problema completo ma sembra che un approccio abbastanza diretto sarebbe quello di definire una terza linea come il minimo delle due serie temporali in ogni momento. geom_ribbon viene quindi chiamato due volte (una volta per ciascun valore univoco di Asset) per tracciare i nastri formati da ciascuna serie e dalla linea minima. Codice potrebbe essere simile:

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) 

Questo produce seguente tabella:

Answer 2

Ho effettivamente avuto la stessa domanda qualche tempo fa ed ecco lo related post.Si definisce una funzione trovare le intersezioni tra due linee e un'altra funzione che prende un dataframe in ingresso e poi colori lo spazio tra le due colonne utilizzando matplot e polygon

EDIT

Ecco il codice, modificato un po 'per permettere l'ultimo poligono da tracciare

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) 

ed il risultato finale è questo (con gli stessi dati utilizzati per la domanda)