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