plot.xts scattered smothered covered chunked and diced
#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() |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment