public
Last active

The Financial Crisis on Tape Part II

  • Download Gist
FinCrisisPartII.R
R
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184
rm(list=ls())
#install the superb quantmod library
#we will use it to download the data and compute returns
library(quantmod)
#install various other libraries for the data manipulation and graphing.
library(ggplot2)
library(scales)
library(RColorBrewer)
library(reshape2)
library(grid)
library(gridExtra)
 
# load historical prices from Yahoo Finance
# I use a set that I saw used by Systematic Investor
symbols = c('SPY','QQQ','EEM','IWM','EFA','TLT','IYR','GLD')
symbols.names = c('S&P 500,Nasdaq 100,Emerging Markets,Russell 2000,EAFE,20 Year
Treasury,U.S. Real Estate,Gold')
 
#Download the data from yahoo (default choice of getSymbols)
#It loads directly to the environment which depending on your R background may seem surprising
#One can use the 'get' function below to obtain the results.
getSymbols(symbols, src = 'yahoo', from = '2005-01-01')
 
#obtain the daily closing price for each and form into a data frame
#and compute the returns of the adjusted prices
hist.returns =
do.call(cbind,
lapply(symbols, function(symbol){
symbol.data = get(symbol) #get yahoo data from the environment
symbol.data.adj = Ad(symbol.data) #extract the adjusted prices
symbols.data.adjret = ROC(symbol.data.adj, n=1, type="continuous", na.pad=TRUE) #compute the simple returns
symbols.data.adjret
})
)
 
#we will also need to get the plain adjusted prices which we will use later
hist.prices =
do.call(cbind,
lapply(symbols, function(symbol){
symbol.data = get(symbol) #get yahoo data from the environment
symbol.data.adj = Ad(symbol.data) #extract the adjusted price
symbol.data.adj
})
)
 
#a little prep for plotting with ggplot later
hist.prices = data.frame(this.date = index(hist.prices),hist.prices)
colnames(hist.prices) = gsub(".Adjusted","",colnames(hist.prices))
hist.prices.melt = melt(hist.prices,id.vars="this.date")
 
#define preferred order of the assets in the graphs.
pref.order = c("SPY","QQQ","EEM","IWM","EFA","IYR","GLD","TLT")
hist.prices.melt$variable = factor(hist.prices.melt$variable,pref.order)
 
###########################################################
##############Compute Rolling Correlations#################
###########################################################
#there are many ways to apply a function to a rolling historical window
#I'm going to roll a very simple one of my own
 
#Function to compute the correlation matrix from an dataframe of returns:
DataFrameCorOutput<-function(hist.returns){
require(reshape2)
correls = melt(cor(as.matrix(na.omit(hist.returns)))) #r's built in correlation function returns the correlation matrix
colnames(correls) = c("Var1","Var2","Correl") #label the melted correlation matrix
 
#rename some of the series to make obtaining a pretty plot a little easier!
correls$Var1 = factor(gsub(".Adjusted","",correls$Var1),rev(pref.order))
correls$Var2 = factor(gsub(".Adjusted","",correls$Var2),rev(pref.order))
list(correls = correls,min.date = min(index(hist.returns)),max.date = max(index(hist.returns))) #return all three objects
}
 
#choose the window length over which we will compute the correlation
window.length = 120 #~6M of business days
 
#calculate the dates on which we have sufficient data to compute the correlation (i.e. a window.length of history)
dates.to.do = tail(index(hist.returns),-(window.length - 1)) #these are the dates to right of the first window
 
#calculate the correlation for an N day window before each of these dates
rolling.correls = lapply(dates.to.do,FUN<-function(this.date){
return(DataFrameCorOutput(tail(hist.returns[index(hist.returns)<=this.date,],window.length)))
})
names(rolling.correls) = dates.to.do
 
#function to extract the correlation matrix from rolling.correls
#and plot it using the ggplot package.
PlotCorrelsForThisDate<-function(this.date){
#extract the relevant correlmatrix from the list of correl matrices
correlmatrix = rolling.correls[[as.character(this.date)]][["correls"]]
#I want to use a bespoke colour pallete see Part I of "The Financial Crisis on Tape" for an explanation.
my.col.vec = c(
rev(brewer.pal(8,"Blues")),
colorRampPalette(
c(
colorRampPalette(c("white",brewer.pal(9,"Set3")[2],
brewer.pal(9,"Set1")[c(6,5,1)]))(10),
rev(brewer.pal(9,"PRGn")[1])
)
)(9)
)
#plot a simple heat-map using ggplot
correl.plot<-ggplot(correlmatrix, aes(x = Var1, y = Var2, fill = Correl)) +
geom_tile() +
scale_fill_gradientn(colours = my.col.vec
,limits = c(-1,1)) +
theme_bw()+
theme(panel.grid.major.x = element_blank(),
panel.grid.major.y = element_blank(),
axis.title.x = element_blank(),
axis.title.y = element_blank(),
axis.text.x=element_text(angle=90))
return(correl.plot)
}
 
#The below is a funtion that given an index, j, produces the graphic for the date dates.to.do[j]
ProduceFilmStill<-function(j){
#the main reason I use j rather than lapplying to a list of dates
#is I wish to call the output Plot_j.png, so I need to record j.
this.date = dates.to.do[j]
#use the previous function to produce the correlation heatmap
correlplot = PlotCorrelsForThisDate(this.date)
 
#the strip.data highlights the period of time used to compute the correlation
strip.data = data.frame(xmin=rolling.correls[[as.character(this.date)]][["min.date"]], xmax=this.date,ymin=-Inf,ymax=Inf)
#Plot the timeseries plots:
#the idea of these is that the dot shows the current point in time whilst the period used is shaded grey.
#this gives context to the the correlation calculation
timeseries.plot = ggplot(hist.prices.melt,aes(x=this.date,y=value,colour=variable))+
geom_line()+
geom_rect(data=strip.data,aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax),fill="grey", alpha=0.2, inherit.aes = FALSE)+
geom_point(data = hist.prices.melt[hist.prices.melt$this.date == this.date,],size=3.5)+
theme_bw() +
scale_y_continuous("Price")+
scale_colour_brewer("",palette="Set1")+
facet_grid(variable~.,scales="free_y")+
theme(axis.title.x = element_blank(),
axis.title.y = element_blank(),
axis.text.y = element_blank(),
axis.ticks.y = element_blank(),
plot.margin = unit(c(0.53,0.2,0.75,0), "cm"))+
guides(colour=FALSE)
library(gtable)
#Combine the two ggplots using gtable into a single graphic.
#thanks to numerous stack-overflow posters
#for your help with learning about gtable!
gA <- ggplot_gtable(ggplot_build(timeseries.plot))
gB <- ggplot_gtable(ggplot_build(correlplot))
maxWidth = grid::unit.pmax(gA$widths[2:3], gB$widths[2:3])
gA$widths[2:3] <- as.list(maxWidth)
gB$widths[2:3] <- as.list(maxWidth)
gt <- gtable(widths = unit(c(0.8, 1), "null"), height = unit(1, "null"))
gt <- gtable_add_grob(gt, gA, 1, 1)
gt <- gtable_add_grob(gt, gB, 1, 2)
#save the graphic as png
#this will form a single frame in the video
base.graphpath = "~\\FilmStills_"
graphpath = paste(base.graphpath,j,".png",sep="")
png(graphpath,
width = 1500,
height = 750,
res = 150
)
grid.newpage()
grid.draw(gt)
dev.off()
 
return (graphpath)
}
 
#produce a graphic for each date in the date range
FilmStillPaths = lapply(1:length(dates.to.do),ProduceFilmStill)
 
#use the ffmpeg program to combine the pngs to make an mpeg.
#ffmpeg -y -r 50 -s 1500X750 -f image2 -i "FilmStills_%d.png" FinancialCrisisOnTape.mpg

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.