public

plot.xts scattered smothered covered chunked and diced

  • Download Gist
plotxts with ProspectRatio.r
R
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176
#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()

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.