Another Great Google Summer of Code 2012 R Project

[This article was first published on Timely Portfolio, and kindly contributed to R-bloggers]. (You can report issue about the content on this page here)
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.

Preview

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

image

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

To leave a comment for the author, please follow the link and comment on their blog: Timely Portfolio.

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.

Never miss an update!
Subscribe to R-bloggers to receive
e-mails with the latest R posts.
(You will not see this message again.)

Click here to close (This popup will not appear again)