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