Another Great Google Summer of Code 2012 R Project
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.
Tradeblotter announced the very nice features that will be added to the PerformanceAnalytics package as a result of the Google Summer of Code (GSOC) 2012 project:
“…Matthieu commenced to produce dozens of new functions, extend several more existing ones, and add more than 40 pages of additional documentation (complete with formulae and examples) to PerformanceAnalytics. He’s included Bacon’s small data set and several new
table.*
functions for testing and demonstrating that the functions match the published results. All on plan, I would add.He also wrote a very nice overview of the functions developed from Bacon (2008) that are included in PerformanceAnalytics, which should be helpful to readers or teachers of Bacon’s work. Matthieu’s summary document will also be distributed as a vignette in the package, accessible using
vignette('PA-Bacon')
. Additional detail is included in the documentation for each function, as well. I’ll highlight some of those functions in later posts…”
Although the Bacon vignette is very helpful, I highly recommend reading the book also. For those of you on O’Reilly’s Safari, you can add the book to your bookshelf.
or buy it from Amazon.
Since I saw the announcement (been patiently waiting) when I was also reading this very good article “Tomatoes and the Low Vol Effect” by Research Affiliates, I was already working on some R to explore the Sharpe and Information Ratio between a buy/hold on the S&P 500 and a 10 month moving average strategy. When you look at the code, you might enjoy some of the other charts and methods, but I decided to change directions with my research and integrate a new PerformanceAnalytics function and continue to push the limits with another fine Google Summer of Code 2012 addition xtsExtra plot.xts. I was not real selective and opted for ProspectRatio, since it is a formula I do not often hear discussed. On page 20, the Bacon vignette describes ProspectRatio as
I basically tried to include absolutely everything possible (scattered, smothered, covered, chunked, and diced) from xtsExtra plot.xts in this chart. The chart includes cumulative growth of buy/hold and 10 month moving average on the S&P 500 in the top panel, shows drawdown in the middle, and then adds a horizon plot of Prospect Ratio for the ma strategy – Prospect Ratio for the buy/hold. Since plot.xts also allows for blocks, I thought it would be helpful to also shade those periods when the 36 month rolling Sharpe Ratio of the ma strategy outperforms buy/hold. While this is probably a bit much for a single chart, I think it demonstrates clearly how powerful these tools are.
![]() |
From TimelyPortfolio |
R code from GIST (do raw for copy/paste):
#integrate 2 Google Summer of Code 2012 Projects | |
#plot.xts and PerformanceAnalytics both received very nice additions | |
#wish I knew the exact link but believe this section came from stackoverflow | |
#this allows you to work with the code straight from r-forge SVN | |
## If you want to source() a bunch of files, something like | |
## the following may be useful: | |
#path="C:\\Program Files\\R\\R-2.15.1\\sandbox\\svnsource\\returnanalytics\\pkg\\PerformanceAnalytics\\r" | |
#sourceDir <- function(path, trace = TRUE, ...) { | |
# for (nm in list.files(path, pattern = "\\.[RrSsQq]$")) { | |
# if(trace) cat(nm,":") | |
# source(file.path(path, nm), ...) | |
# if(trace) cat("\n") | |
# } | |
#} | |
#sourceDir(path) | |
require(RColorBrewer) | |
require(quantmod) | |
require(xtsExtra) | |
getSymbols("^GSPC",from="1890-01-01") | |
sp500.monthly <- GSPC[endpoints(GSPC, "months"),4] | |
roc <- ROC(sp500.monthly, type = "discrete", n = 1) | |
n = 10 #set n for number of periods; this is 10 for 10 months | |
roc.ma <- lag(ifelse(sp500.monthly > runMean(sp500.monthly, n = n), 1, 0), k = 1) * roc | |
returns <- merge(roc, roc.ma) | |
returns <- as.xts(apply(returns, MARGIN = 2, na.fill, fill = 0), order.by = index(returns)) | |
colnames(returns) <- c("SP500.buyhold", "SP500.ma") | |
charts.PerformanceSummary(returns, ylog = TRUE) | |
sr <- SharpeRatio.annualized(returns) | |
ir <- InformationRatio(returns, returns[,1]) | |
applyacross <- function(x,rollFun=Omega,width=12,by=1,Rb,...) { | |
if(missing(Rb)) { #add this so we can also use for InformationRatio | |
result <- apply.rolling(x,FUN=rollFun,width,by,...) | |
} else { | |
result <- apply.rolling(x,FUN=rollFun,width,by,Rb=Rb,...) | |
} | |
result <- merge(x,result)[,2] #merge to pad with NA and then get second column | |
colnames(result) <- colnames(x) | |
return(result) | |
} | |
stat = "SharpeRatio.annualized" #ES, KellyRatio, Omega, skewness, kurtosis, VaR, SharpeRatio, CalmarRatio | |
width = 36 | |
sharpe.rolling <- as.xts(matrix(unlist(lapply(returns,FUN=applyacross,rollFun=get(stat),width=width)),byrow=FALSE,nrow=NROW(returns)), order.by = index(returns)) | |
sharpe.rolling <- as.xts(apply(sharpe.rolling,MARGIN=2,FUN=na.fill,fill=0),order.by=index(sharpe.rolling)) | |
colnames(sharpe.rolling) <- colnames(returns) | |
plot.xts(sharpe.rolling,screens=1) | |
plot.xts(sharpe.rolling[,2] - sharpe.rolling[,1],screens=1) | |
plot(x=coredata(sharpe.rolling[,1]),y=coredata(sharpe.rolling[,2]),pch=19, | |
col=ifelse(sharpe.rolling[,2]>0,"green","red")) | |
abline(lm(SP500.ma ~ SP500.buyhold, data=as.data.frame(sharpe.rolling))) | |
text(x=coredata(sharpe.rolling[,1]),y=coredata(sharpe.rolling[,2]),labels=format(as.Date(index(sharpe.rolling)),"%Y"),cex=0.5, pos = 2 ) | |
plot(lm(SP500.ma ~ SP500.buyhold, data=as.data.frame(sharpe.rolling)),which=2) | |
stat = "InformationRatio" | |
#this allows multiple columns if we have more than one index or comparison | |
ir.rolling <- as.xts(matrix(unlist(lapply(returns,FUN=applyacross,rollFun=get(stat),width=width,Rb=returns[,1])),byrow=FALSE,nrow=NROW(returns)), order.by = index(returns)) | |
colnames(ir.rolling) <- colnames(returns) | |
#could also do this if we only have one column | |
#ir.rolling <- apply.rolling(returns[,2],FUN=InformationRatio,width=width,by=1,Rb=returns[,1]) | |
plot.xts(na.omit(merge(ir.rolling[,2],ROC(sp500.monthly,type="discrete",n=36))),screens=1) | |
plot(x=coredata(ROC(sp500.monthly,type="discrete",n=36)),y=coredata(ir.rolling[,2]), | |
pch=19, | |
col=ifelse(ir.rolling[,2]>0,"green","red"), | |
las=1) | |
abline(h=0) | |
abline(v=0) | |
plot(x = coredata(sharpe.rolling[,1]),y=coredata(ir.rolling[,2]), | |
pch = 19, | |
col = ifelse(ir.rolling[,2]>0,"green","red"), | |
las = 1) | |
abline(h=0) | |
abline(lm(coredata(ir.rolling[,2])~coredata(sharpe.rolling[,1]))) | |
plot(lm(coredata(ir.rolling[,2])~coredata(sharpe.rolling[,1])))#,which=2) | |
#use the new ProspectRatio function in PerfomranceAnalytics | |
stat = "ProspectRatio" #ES, KellyRatio, Omega, skewness, kurtosis, VaR, SharpeRatio, CalmarRatio | |
width = 36 | |
pr.rolling <- as.xts(matrix(unlist(lapply(returns,FUN=applyacross,rollFun=get(stat),width=width,MAR=0.025)),byrow=FALSE,nrow=NROW(returns)), order.by = index(returns)) | |
pr.rolling <- as.xts(apply(pr.rolling,MARGIN=2,FUN=na.fill,fill=0),order.by=index(pr.rolling)) | |
colnames(pr.rolling) <- colnames(returns) | |
#set up horizon plot functionality | |
horizon.panel <- function(index,x,...) { | |
#get some decent colors from RColorBrewer | |
#we will use colors on the edges so 2:4 for red and 7:9 for blue | |
require(RColorBrewer) | |
col.brew <- brewer.pal(name="RdBu",n=10) | |
#ease this reference later | |
n=NROW(x) | |
#clean up NA with either of the two methods below | |
#x[which(is.na(x),arr.ind=TRUE)[,1], | |
# unique(which(is.na(x),ar.ind=TRUE)[,2])] <- 0 | |
x <- apply(x,MARGIN=2,FUN=na.fill,fill=0) | |
#get number of bands for the loop | |
#limit to 3 | |
nbands = 3 | |
#first tried this but will not work since each series needs to have same number of bands | |
#min(4,ceiling(max(abs(coredata(x)))/horizonscale)) | |
par(usr=c(index[1],par("usr")[2],origin,horizonscale)) | |
for (i in 1:nbands) { | |
#draw positive | |
polygon( | |
c(index[1], index, index[n]), | |
c(origin, coredata(x) - (i-1) * horizonscale,origin), | |
col=col.brew[length(col.brew)-nbands+i-1], | |
border=NA | |
) | |
#draw negative | |
polygon( | |
c(index[1], index, index[n]), | |
c(origin, -coredata(x) - (i-1) * horizonscale,origin), | |
col=col.brew[nbands-i+1], | |
border=NA | |
) | |
} | |
#delete trash drawn below origin that we keep so no overlap between positive and negative | |
polygon( | |
c(index[1], index, index[n]), | |
c(origin, -ifelse(coredata(x)==origin,horizonscale*5,abs(coredata(x))),origin), | |
col=par("bg"), | |
border=NA | |
) | |
#draw a line at the origin | |
abline(h=origin,col="black") | |
#draw line at top of plot or otherwise polygons will cover boxes | |
abline(h=par("usr")[4],col="black") | |
#mtext("ProspectRatio Difference", side = 3, adj = 0.02, line = -1.5, cex = 0.75) | |
} | |
horizonscale = 0.25 | |
origin = 0 | |
#trying this to color sections or color lines based on sharpe | |
rle.sharpe <- rle(as.vector(sharpe.rolling[,2]>sharpe.rolling[,1])) | |
dates <- index(returns)[cumsum(rle.sharpe$lengths)] | |
start.i=ifelse(na.omit(rle.sharpe$values)[1],2,1) | |
#png("plotxts with everything and ProspectRatio.png",height=600, width=640) | |
plot.xts(merge(log(cumprod(1+returns)),Drawdowns(returns),pr.rolling[,2] - pr.rolling[,1]), | |
screens = c(1,1,2,2,3), #since 2 columns for cumul and drawdown repeat screens | |
layout.screens = c(1,1,1,1,2,2,3), #make screen 1 4/7 of total 2 2/7 and 3 (horizon) 1/7 | |
col = brewer.pal(9,"Blues")[c(5,8)], #get two blues that will look ok | |
lwd = c(1.5,2), #line width; will do smaller 1.5 for benchmark buy/hold | |
las = 1, #do not rotate y axis labels | |
ylim = matrix(c(0,5,-0.55,0,origin,horizonscale),byrow=TRUE,ncol=2), #plot.xts accepts ylim in matrix form; print matrix to see how it works | |
auto.legend = TRUE, #let plot.xts do the hard work on the legend | |
legend.loc = c("topleft",NA, NA), #just do legend on the first screen | |
legend.pars = list(bty = "n", horiz=TRUE), #make legend box transparent and legend horizontal | |
panel = c(default.panel,default.panel,horizon.panel), #specify panels for each screen | |
main = NA, #will do title later so we have more control | |
#log="y", #log scale does not work with blocks | |
blocks = list(start.time=dates[seq(start.i,NROW(dates),2)], #overlay blocks in which 36-mo sharpe ratio of ma exceeds buy/hold | |
end.time=dates[-1][seq(start.i,NROW(dates),2)],col="gray90")) #darkolivegreen2")) | |
title(main = "Strategy Comparison on S&P 500 - Buy Hold versus Moving Average", adj = 0.05, line = -1.5, outer = TRUE, cex.main = 1.1, font.main = 3) | |
#dev.off() |
R-bloggers.com offers daily e-mail updates about R news and tutorials about learning R and many other topics. Click here if you're looking to post or find an R/data-science job.
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.