timelyportfolio / plotxts with ProspectRatio.r

Created August 30, 2012

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