Friday, June 29, 2012

Horizon Plot Already Available

When I wrote Cubism Horizon Charts in R, I should have known that horizon plot functionality already exists in R http://rgm2.lab.nig.ac.jp/RGM2/func.php?rd_id=latticeExtra:horizonplot and in this case in one of my already favorite packages latticeExtra.

I think I like my version a little better, but I’m sure the horizonplot function from latticeExtra can be amended to look similar, and that function is much more robust than mine.  Also, since it incorporates strip functionality, scaling is much better.

From TimelyPortfolio

R code from GIST: (do raw version for copy/paste)

#should have known R already has horizon plot functionality
#latticeExtra (already a favorite package of mine) has it sitting right there
#http://rgm2.lab.nig.ac.jp/RGM2/func.php?rd_id=latticeExtra:horizonplot
require(lattice)
require(latticeExtra)
require(reshape2)
require(quantmod)
tckrs <- c("^W0DOW","^GSPC","^RUT","^E1DOW","^P1DOW","^DJUBS")
getSymbols(tckrs,from="2011-12-31")
#combine prices together
prices <- na.omit(merge(W0DOW[,4],GSPC[,4],RUT[,4],E1DOW[,4],P1DOW[,4],DJUBS[,4]))
#get change since beginning of period
change <- prices/matrix(rep(prices[1,],NROW(prices)),nrow=NROW(prices),ncol=NCOL(prices),byrow=TRUE) -1
colnames(change) <- tckrs
#using the example as presented in horizonplot documentation
horizonplot(change,layout=c(1,NCOL(change)),
scale=0.05,
par.settings=theEconomist.theme(box="transparent"),
#if you want y labels in the graph uncomment
# panel = function (x,y,...) {
# panel.horizonplot(x,y,...)
# panel.text(x=x[1],y=0,label=colnames(change)[panel.number()],pos=3)
# },
strip.left = FALSE,
scales = list(y = list(draw = FALSE,relation = "same",alternating=FALSE)),
main="World Indexes Change Since 2011",
xlab=NULL,
ylab = list(rev(colnames(change)), rot = 0, cex = 0.8)) +
#add some separation between graphs with small white band
layer(panel.xblocks(height=0.001,col="white",...))

Tuesday, June 26, 2012

Turning 100,000

Way back in December 2010, I started blogging here at Timely Portfolio, and as you can see, turning 100,000 pageviews was something I never expected.  Thanks to all the readers who have motivated me to continue and who have taught me along the way.

Wednesday, December 8, 2010

Reading->Writing

I am determined to play not spectate. After 20 years of voracious reading, I have decided to write, and this blog represents my commitment. More than likely it will be a reflection of me, so a lot about my work/passion money management and markets but also hopefully some worthwhile thoughts and observations. I will be the writer and possibly the only reader ultimately but I know that I will benefit immensely from this project. Any benefit to others will be extremely gratifying and help resolve my debt to all the wonderful authors that have entertained and enlightened me over the years.

The stats look like this.

clip_image001

Crazy RUT in Academic Context Why Trend is Not Your Friend

In response to Where are the Fat Tails?, reader vonjd very helpfully referred me to this paper The Trend is Not Your Friend! Why Empirical Timing Success is Determined by the Underlying’s Price Characteristics and Market Efficiency is Irrelevant by Peter Scholz and Ursula Walther.  The authors conclude

“Our study on the basis of real data clearly confirms the hypothesis that the asset price characteristics of the underlying price process have a crucial impact on timing results. This allows us to forecast the timing success depending on the market's parameters. An OLS
regression analysis supports our predictions and verifies our assumption that the drift has the
strongest influence on timing success. By contrast, the higher moments (skewness, kurtosis)
seem not to have any significant impact on the timing result in the empirical sample. As we
presumed, the level of market development, and hence the degree of efficiency, does not play
any role. Trading worked coincidentally rather well in the developed world and quite poorly in
the emerging markets. The driving factor for the timing success is the parametric environment the trading system stumbles on…

Our study contributes to the discussion by providing a structured analysis of the relevance of the most important price process parameters. As a result, the traditional explanations for timing success can be abandoned: we find that it is very likely for the SMA trading rule to generate excess returns over its benchmark if the underlying price path exhibits negative drifts, high serial autocorrelation, low volatilities of returns, and highly clustered volatilities. Drift and autocorrelation of the underlying asset seem to have the largest impact, though.”

They go a long way toward answering my puzzle “Why has the Russell 2000 been so difficult to beat over the last decade?”  I have made a lot of progress in replicating their research in R, but for now, let’s have a messy look at their Table 2: Descriptive statistics of 35 leading equity indices with ggplot2.

From TimelyPortfolio

Now let’s combine Table 2 with their Table 21: Average excess return from timing in the 35 selected leading equity indices with a little graphical help from R.  The colors in the chart indicate the sum of all outperformance by the multiple moving averages.  Red, such as China and Russia, demonstrates drastic underperformance of the moving average strategies versus buy and hold.  If excess return was symmetrical, we would expect bright green similar to the bright red, but instead we only see dull gray in the bottom left indicating slight outperformance.

From TimelyPortfolio

Now that we have established the context, we will explore in future posts where the Russell 2000 fits in terms of statistical properties and see if the this fits the authors discoveries.

Thanks again to reader vonjd for leading me to this fine work by Peter Scholz and Ursula Walther.

R code from GIST (choose raw for copy/paste):

#do preliminary exploration of paper Why Trend is Not Your Friend
#http://www.frankfurt-school.de/clicnetclm/fileDownload.do?goid=000000311260AB4
#by Peter Scholz and Ursula Walther
#load table 2:Descriptive statistics of 35 leading equity indices
table2 <- read.csv("https://raw.github.com/gist/2996948/31d22bf58aad9f8421f419d659da90c4b3e0bcf0/table2.csv")
#load table 21: Average excess return from timing in the 35 selected leading equity indices
table21 <- read.csv("https://raw.github.com/gist/2996948/8ee5c1d6680fc592c99a68027d2381701c66bb22/table21.csv")
#I included the source at the end of attribution, so let's get rid of that
table2 <- table2[1:(NROW(table2)-2),]
table21 <- table21[1:(NROW(table21)-2),]
require(ggplot2)
require(reshape2)
require(directlabels)
require(RColorBrewer)
#the authors identify low/negative drift (mean) and high serial autocorrelation
#as main parameters allowing dominance of simple moving average
table2.melt <- melt(table2)
#name columns for easy reference while charting
colnames(table2.melt) <- c("country","statistic","value")
direct.label(ggplot(aes(x=statistic,y=value,group=country,colour=country),data=table2.melt) +
geom_point() + facet_wrap(~statistic, scales="free",nrow=2) +
theme_bw()+
opts(axis.title.x = theme_blank()) +
opts(axis.title.y = theme_blank()) +
opts(title="Statistics of 35 Indexes from Table 2"),
list("last.points",cex=0.5))
#dotchart(x=table2.melt$value,labels=table2.melt$country,group=table2.melt$statistic,cex=0.5)
#do a simple plot of mean(drift) versus serial autocorrelation
#color based on sum of outperformance of moving average strategies
#long way around but I cannot figure out a quicker way
#get colors to use for heat map
brew <- brewer.pal(name="RdYlGn",n=6)
#get color ramp
cc.brew <- colorRampPalette(brew)
#apply color ramp
cc <- cc.brew(35)
#do colors based on level of outperformance but with gray so visible when labelling
cc.palette <- colorRampPalette(c(cc[1],"antiquewhite4",cc[length(cc)]))
cc.levpalette <- cc.palette(35)
cc.levels <- level.colors(x=apply(table21[,2:NCOL(table21)],MARGIN=1,sum), do.breaks(c(-1.5,1.5),35),
col.regions = cc.levpalette)
plot(table2[,2]~table2[,7],type="p",pch=19,bty="l",col=cc.levels,
ylab = "mean (drift)",
xlab = "autocorrelation ARMA(1)")
text(y=table2[,2], x=table2[,7],labels = table2[,1], adj=0, cex=0.65,col=cc.levels)
title(main="Analysis of Outperformance (color) by Mean and Autocorrelation",adj=0,cex.main=0.9, outer=TRUE,font=1,line=-2)
Country mean stddev skew kurt JB(p) autocorr estAR1 autoret autovol
Argentina 6.05E-04 0.0224 -0.0577 7.74 0.001 0.0426 0.0975 0.8775 1.16E-05
Australia 1.44E-04 0.0103 -0.6469 10.23 0.001 -0.0332 0.0939 0.9021 6.96E-07
Austria 3.08E-04 0.01532 -0.3286 11.43 0.001 0.0529 0.137 0.8476 3.56E-06
Belgium -7.85E-05 0.01366 0.043 9.58 0.001 0.0645 0.1478 0.8436 2.33E-06
Brazil 5.97E-04 0.01999 -0.1052 6.74 0.001 0.0056 0.0671 0.906 9.74E-06
Canada 4.20E-05 0.01365 -0.6975 12.1 0.001 -0.0828 0.0692 0.9263 8.37E-07
China 8.20E-04 0.02232 0.0289 8.34 0.001 0.0746 0.0816 0.912 3.67E-06
Europe -2.50E-04 0.01618 0.0715 7.71 0.001 -0.0549 0.1081 0.8861 2.16E-06
France -2.39E-04 0.01588 0.0945 8.33 0.001 -0.0545 0.1023 0.8929 1.88E-06
Germany -5.82E-05 0.01672 0.0458 7.42 0.001 -0.0393 0.0993 0.894 2.24E-06
Greece -4.64E-04 0.01777 -0.0031 7.26 0.001 0.0879 0.0996 0.8951 2.77E-06
Hong Kong 1.18E-04 0.01675 0.0482 10.8 0.001 -0.0233 0.0679 0.9274 1.35E-06
Hungary 3.72E-04 0.01694 -0.0608 9.15 0.001 0.0678 0.0995 0.8767 6.40E-06
India 5.53E-04 0.01715 -0.3047 10.75 0.001 0.08 0.1492 0.8269 8.42E-06
Indonesia 6.59E-04 0.0154 -0.636 8.77 0.001 0.1251 0.1341 0.8046 1.47E-05
Italy -3.30E-04 0.01498 0.038 9.5 0.001 -0.01 0.1101 0.886 1.62E-06
Japan -2.76E-04 0.01639 -0.3009 9.11 0.001 -0.0356 0.0943 0.8963 2.89E-06
Mexico 5.97E-04 0.01456 0.0355 7.3 0.001 0.1038 0.0769 0.9049 3.66E-06
The Netherlands -2.85E-04 0.01661 -0.0356 8.72 0.001 -0.0259 0.1146 0.8813 1.81E-06
Pakistan 6.36E-04 0.01573 -0.2356 5.51 0.001 0.1007 0.17 0.7871 1.13E-05
Peru 9.03E-04 0.01497 -0.3824 13.5 0.001 0.2064 0.241 0.735 6.99E-06
The Phillipines 2.81E-04 0.01444 0.5627 19.16 0.001 0.1195 0.1219 0.8106 1.52E-05
Poland 6.62E-05 0.01683 -0.066 4.8 0.001 0.0463 0.05 0.9424 2.28E-06
Russia 7.52E-04 0.02407 -0.4505 11.56 0.001 0.0933 0.1241 0.8511 1.37E-05
Saudi Arabia 4.62E-04 0.01745 -0.9722 10.99 0.001 0.0477 0.1511 0.8489 2.86E-06
Singapore 1.23E-04 0.01332 -0.1447 6.99 0.001 0.0146 0.1026 0.892 1.66E-06
South Africa 4.62E-04 0.01465 -0.0542 6.15 0.001 0.0388 0.0912 0.8941 3.22E-06
South Korea 3.32E-04 0.0179 -0.4825 7.35 0.001 0.0172 0.0752 0.918 2.73E-06
Spain -3.09E-05 0.01545 0.1533 9.39 0.001 -0.0329 0.111 0.8839 2.12E-06
Sweden -9.24E-05 0.01681 0.136 6.14 0.001 -0.0259 0.0861 0.9085 2.03E-06
Switzerland -7.66E-05 0.01323 0.0254 9.1 0.001 0.0084 0.1298 0.8585 2.34E-06
Thailand 2.80E-04 0.01514 -0.708 12.29 0.001 0.0299 0.1053 0.7956 2.16E-05
Turkey 5.45E-04 0.0249 -0.0271 9.43 0.001 0.0069 0.1062 0.8762 1.22E-05
UK -8.17E-05 0.0133 -0.1267 9.63 0.001 -0.0733 0.1148 0.8813 1.22E-06
U.S.A. -1.21E-04 0.01384 -0.0985 11.03 0.001 -0.1027 0.0765 0.9172 1.12E-06
source: Table 2 http://www.frankfurt-school.de/clicnetclm/fileDownload.do?goid=000000311260AB4
view raw table2.csv hosted with ❤ by GitHub
Country 5 10 20 38 50 100 200
Argentina -0.1576 -0.1591 -0.1519 -0.1447 -0.1516 -0.1587 -0.153
Australia -0.0222 -0.0195 -0.0211 -0.0206 -0.0199 -0.0198 -0.0189
Austria -0.1075 -0.0897 -0.0824 -0.0621 -0.0665 -0.0585 -0.0563
Belgium -0.0309 -0.0351 -0.0357 -0.0389 -0.0321 -0.0364 -0.0316
Brazil -0.1468 -0.1391 -0.1335 -0.128 -0.121 -0.1159 -0.1055
Canada -0.0296 -0.0291 -0.0273 -0.0334 -0.031 -0.0254 -0.0256
China -0.2277 -0.2004 -0.2012 -0.1608 -0.1707 -0.1627 -0.1233
Europe 0.0215 0.0158 0.0184 0.0172 0.0163 0.0195 0.0297
France 0.0004 0.0112 0.0051 0.0162 0.0119 0.0116 0.0106
Germany -0.024 -0.0296 -0.0161 -0.0269 -0.0343 -0.0298 -0.0342
Greece -0.0034 0.0109 0.0088 0.0178 0.0121 0.0167 0.0136
Hong Kong -0.0431 -0.0533 -0.0483 -0.056 -0.0548 -0.0508 -0.0629
Hungary -0.1007 -0.0875 -0.0853 -0.0805 -0.0769 -0.0709 -0.0671
India -0.0938 -0.0948 -0.0967 -0.095 -0.087 -0.0772 -0.0585
Indonesia -0.0797 -0.07 -0.0658 -0.0607 -0.0558 -0.0478 -0.0348
Italy 0.0333 0.0336 0.038 0.0355 0.0394 0.0385 0.0431
Japan 0.0315 0.0322 0.0402 0.0443 0.0353 0.0471 0.0427
Mexico -0.0634 -0.0664 -0.0573 -0.0469 -0.0467 -0.0438 -0.0338
The Netherlands 0.0134 0.0147 0.0053 0.015 0.0013 0.003 0.0147
Pakistan -0.0695 -0.0631 -0.059 -0.0555 -0.0496 -0.0441 -0.036
Peru -0.1021 -0.0942 -0.0779 -0.0654 -0.0645 -0.0505 -0.0306
The Phillipines -0.0463 -0.0441 -0.0392 -0.0405 -0.04 -0.0376 -0.041
Poland -0.0631 -0.0621 -0.0649 -0.0585 -0.0632 -0.0534 -0.0572
Russia -0.2313 -0.2127 -0.2011 -0.1821 -0.1853 -0.1471 -0.1066
Saudi Arabia -0.1347 -0.1312 -0.1105 -0.1027 -0.0996 -0.0806 -0.045
Singapore -0.0265 -0.0247 -0.0251 -0.0296 -0.0284 -0.0283 -0.029
South Africa -0.0699 -0.0687 -0.0582 -0.0584 -0.0542 -0.0603 -0.0492
South Korea -0.0749 -0.0814 -0.0717 -0.0717 -0.0738 -0.0606 -0.0654
Spain -0.0255 -0.0195 -0.0243 -0.0328 -0.0227 -0.0351 -0.029
Sweden -0.0221 -0.0354 -0.0392 -0.0251 -0.0355 -0.0303 -0.0268
Switzerland 0.0057 0.004 0.0032 0.0081 0.0021 0.0053 0.0027
Thailand -0.0536 -0.054 -0.0475 -0.0458 -0.0417 -0.0432 -0.0381
Turkey -0.1969 -0.199 -0.206 -0.2015 -0.2054 -0.1748 -0.176
UK 0.0022 0.0045 0.0017 0.004 0.0046 0.0046 -0.0009
U.S.A. 0.0078 0.007 0.0088 0.0023 0.005 0.0085 0.0037
source: Table 21 http://www.frankfurt-school.de/clicnetclm/fileDownload.do?goid=000000311260AB4
view raw table21.csv hosted with ❤ by GitHub

Tuesday, June 19, 2012

Where are the Fat Tails?

In Crazy RUT, I started to explore why the moving average strategy has failed for the last 2 decades on the Russell 2000.  I still do not have an answer, but I thought looking at skewness and kurtosis might help explain some of the challenge of beating this index.  I think--but don’t have as much rigid objective evidence as I would like--that moving average systems work best when skew is negative and kurtosis is positive because that implies that the bad stuff happens below the mean when you would be out.

The Russell 2000 has been remarkably tame in terms of skewness and kurtosis even including 2008-2009.

From TimelyPortfolio
From TimelyPortfolio

R code from GIST (do raw for copy/paste):

require(lattice)
require(latticeExtra)
require(directlabels)
require(reshape2)
require(quantmod)
require(PerformanceAnalytics)
#I will use a csv file of weekly returns to get more history
#but if you do not have access to that then use getSymbols for data to 1987
#getSymbols("^RUT",from="1900-01-01")
#then get weekly ROC
#rut.return <- ROC(to.weekly(RUT)[,4],type="discrete",n=1)
RUT <- read.csv("rut.csv",stringsAsFactors=FALSE)
RUT <- as.xts(RUT[,2],order.by=as.Date(RUT[,1]))
rut.return <- ROC(RUT,type="discrete",n=1)
#get skewness for short and long rolling periods
skew.short <- apply.rolling(rut.return,FUN=skewness,width=20,trim=FALSE)
colnames(skew.short) <- "roll20w"
skew.long <- apply.rolling(rut.return,FUN=skewness,width=250,trim=FALSE)
colnames(skew.long) <- "roll250w"
#do the same for kurtosis
kurtosis.short <- apply.rolling(rut.return,FUN=kurtosis,width=20,trim=FALSE)
colnames(kurtosis.short) <- "roll20w"
kurtosis.long <- apply.rolling(rut.return,FUN=kurtosis,width=250,trim=FALSE)
colnames(kurtosis.long) <- "roll250w"
#combine into data frame so we can melt as plot with lattice
skew <- as.data.frame(cbind(index(skew.short),coredata(merge(skew.short,skew.long))))
#melt to please lattice
skew.melt <- melt(skew,id.vars=1)
#clean up with good column names as properly formatted dates
colnames(skew.melt) <- c("date","measure","skew")
skew.melt[,"date"] <- as.Date(skew.melt[,"date"])
direct.label(asTheEconomist(xyplot(skew~date,groups=measure,data=skew.melt,type="l",lwd=c(1,3),
main="Russell 2000 Rolling Skewness")),"last.qp")
#combine into data frame so we can melt as plot with lattice
kurtosis <- as.data.frame(cbind(index(kurtosis.short),coredata(merge(kurtosis.short,kurtosis.long))))
#melt to please lattice
kurtosis.melt <- melt(kurtosis,id.vars=1)
#clean up with good column names as properly formatted dates
colnames(kurtosis.melt) <- c("date","measure","kurtosis")
kurtosis.melt[,"date"] <- as.Date(kurtosis.melt[,"date"])
direct.label(asTheEconomist(xyplot(kurtosis~date,groups=measure,data=kurtosis.melt,type="l",lwd=c(1,3),
main="Russell 2000 Rolling Kurtosis")),"last.qp")

Friday, June 15, 2012

Cubism Horizon Charts in R

Like many, I have been in awe of the d3.js and cubism.js visualization packages created by Mike Bostock.

Mike Bostock @ Square talks about Time Series Visualization from Librato on Vimeo.

The charts are beautiful and extraordinarily functional, so I thought it would be fun to at least replicate the horizon chart (unfortunately without the helpful overlays and real-time updating).  I was so happy with the result that I thought I would wrap it up in a function as a gift to my loyal readers.

From TimelyPortfolio

And here in the mirrored form.

From TimelyPortfolio

R code from GIST:

require(lattice)
require(latticeExtra)
require(reshape2)
require(quantmod)
#set up horizon plots as a function
horizonplot <- function(prices,horizon.type="offset",scale=0.05,title=NA,alpha=0.4){
#get change in prices since beginning or 1st row
prices.change <- prices[,4]/as.numeric(prices[1,4])-1
#get as a data.frame so it will work well with melt and lattice
prices.change.df <- as.data.frame(cbind(as.Date(index(prices.change)),coredata(prices.change)))
#get date back to recognizable date form
prices.change.df[,1] <- as.Date(prices.change.df[,1])
#names columns for easier access
colnames(prices.change.df) <- c("date","change")
#smooth line for better appearance
prices.smooth <- spline(as.numeric(prices.change.df$change)~as.numeric(prices.change.df$date))
#do mirror graph
pmirror <-
xyplot(y~as.Date(x),data=prices.smooth,ylim=c(0,scale),origin=0,
par.settings=theEconomist.theme(box="transparent"),
lattice.options=theEconomist.opts(),
xlab=NULL,ylab=NULL,
#do function for an area chart
panel = function(x,y,...){
#divide by the scale specified and go through each time until no more left
#each pass will darken the graph with alpha
#first for loop will do the positive in green
for (i in 0:round(max(y)/scale,0))
panel.xyarea(x,y=ifelse(y>0,y,NA)-(scale * i),col="green",border="green",alpha=alpha,lwd=2,...)
#second for loop handles the negatives in red
#will take absolute value of y to mirror
for (i in 0:round(max(ifelse(y < 0,abs(y),0))/scale,0))
panel.xyarea(x,y=ifelse(y<0,abs(y),NA)-(scale * i),col="red",border="red",lwd=2,alpha=alpha,...)
},
main=title)
#get the positive and negative plots for the offset chart
#very similar to the mirror chart above
#except the negative values will be moved to the top of y range
#and inverted
ppos<-
xyplot(y~as.Date(x),data=prices.smooth,ylim=c(0,scale),origin=0,
par.settings=theEconomist.theme(box="transparent"),
lattice.options=theEconomist.opts(),
xlab=NULL,ylab=NULL,
panel = function(x,y,...){
#
for (i in 0:round(max(y)/scale,0))
panel.xyarea(x,y=ifelse(y>0,y,NA)-(scale * i),col="green",border="green",alpha=alpha,lwd=2,...)
},
main=title)
pneg <-
xyplot(y~as.Date(x),data=prices.smooth,ylim=c(0,scale),origin=scale,
panel=function(x,y,...){
for (i in 0:round(min(y)/-scale,0)) {
panel.xyarea(x,y=scale+ifelse(y<0,y,NA)+(scale*i),col="red",border="red",lwd=2,alpha=alpha,...)
}
})
ifelse(horizon.type=="mirror", return(pmirror), return(ppos+pneg))
}
getSymbols("^W0DOW",from="2011-12-31")
getSymbols("^GSPC",from="2011-12-31")
getSymbols("^DJUBS",from="2011-12-31")
#do the default offset
p1<-horizonplot(prices=W0DOW,horizon.type="offset",title="Dow Jones World Ex Americas")
p2<-horizonplot(prices=GSPC,horizon.type="offset",title="S&P 500")
p3<-horizonplot(prices=DJUBS,horizon.type="offset",title="Dow Jones UBS Commodity Index")
print(p1,position=c(0,0.66,1,1),more=TRUE)
print(p2,position=c(0,0.33,1,0.66),more=TRUE)
print(p3,position=c(0,0,1,0.33))
#do again but this time as mirror
p1<-horizonplot(prices=W0DOW,horizon.type="mirror",title="Dow Jones World Ex Americas")
p2<-horizonplot(prices=GSPC,horizon.type="mirror",title="S&P 500")
p3<-horizonplot(prices=DJUBS,horizon.type="mirror",title="Dow Jones UBS Commodity Index")
print(p1,position=c(0,0.66,1,1),more=TRUE)
print(p2,position=c(0,0.33,1,0.66),more=TRUE)
print(p3,position=c(0,0,1,0.33))
view raw horizon plot.r hosted with ❤ by GitHub

Thursday, June 14, 2012

Pretty Correlation Map of PIMCO Funds

As PIMCO expands beyond fixed income, I thought it might be helpful to look at correlation of PIMCO mutual funds to the S&P 500.  Unfortunately due to the large number of funds, I cannot use the chart.Correlation from PerformanceAnalytics.  I think I have made a pretty correlation heatmap of PIMCO institutional share funds with inception prior to 5 years ago.  Of course this eliminates many of the new strategies, but it is easy in the code to adjust the list.  I added the Vanguard S&P 500 fund (VFINX) as a reference point.  Then, I orderded the correlation heat map by correlation to VFINX.

As expected there are two fairly distinct groups of funds: those (mostly fixed income) with negative/low correlation to the S&P 500 and those with strong positive correlation.

From TimelyPortfolio

Here is the more standard heat map with dendrogram ordering, which has its purpose but gets a little busy.

From TimelyPortfolio

If we are only interested in the correlation to the S&P 500 (VFINX), then this might be more helpful.

From TimelyPortfolio

R code from GIST:

#do a pretty correlation on heat map on all Pimco Funds (institutional share class) that have existed longer 5 years
#symbol list obtained from
#http://investments.pimco.com/Products/pages/PlOEF.aspx?Level1=ulProducts&Center=ulProducts&Level2=liulProductsMutualFunds
#pasted into Excel and sorted by 5 yr return
#then copied and pasted transpose
#saved to csv
#and pasted in this ticker list eliminating the money fund and adding Vanguard S&P 500 for reference
tckrs <- c("PISIX","PSKIX","PSDIX","PSTKX","PCRIX","PFIIX","PHMIX","PFCIX","PCDIX","PTSHX","PFMIX","PLMIX","PSPTX","PCIMX","PSTIX","PNYIX","PLDTX","PLDIX","PTLDX","PAAIX","PXTIX","PHIYX","PSCSX","PAUIX","PTRIX","PGBIX","PFORX","PELBX","PDMIX","PMDRX","PEBIX","PDIIX","PRRSX","PMBIX","PTSAX","PTTRX","PIGLX","PRRIX","PFUIX","PIMIX","PIGIX","PRAIX","PLRIX","PGOVX","PEDIX","VFINX")
for (i in 1:length(tckrs)) {
ifelse (i == 1,
pimco <- get(getSymbols(tckrs[i],from="2000-01-01",adjust=TRUE))[,4],
pimco <- merge(pimco,get(getSymbols(tckrs[i],get="all",from="2000-01-01",adjust=TRUE))[,4]))
}
#remove .close from each of the symbols
colnames(pimco) <- tckrs
pimco.clean <- na.omit(pimco)
pimco.roc <- ROC(pimco.clean,n=1,type="discrete")
pimco.roc[1,] <- 0
#do correlation table
ca <- cor(pimco.roc)
#get colors to use for heat map
brew <- brewer.pal(name="RdBu",n=5)
#get color ramp
cc.brew <- colorRampPalette(brew)
#apply color ramp
cc <- cc.brew(nrow(ca))
#do heatmap and sort by degree of correlation to VFINX (Vanguard S&P 500)
heatmap(ca[order(ca[,ncol(ca)]),order(ca[,ncol(ca)])],symm=TRUE,Rowv=NA,Colv=NA,col=cc,RowSideColors=cc,main="")
title(main="Correlation Table (Ordered by Correlation with Vanguard S&P 500-VFINX)",font.main=1,outer=TRUE,line=-1,cex.main=1.3)
heatmap(ca[order(ca[,ncol(ca)]),order(ca[,ncol(ca)])],symm=TRUE,col=cc,RowSideColors=cc,main="")
title(main="Correlation Table (Ordered by Dendrogram)",font.main=1,outer=TRUE,line=-1,cex.main=1.3)
#do colors based on correlation but with gray so visible when labelling
cc.palette <- colorRampPalette(c(cc[1],"gray60",cc[length(cc)]))
cc.levpalette <- cc.palette(nrow(ca))
cc.levels <- level.colors(ca[order(ca[,ncol(ca)-1]),ncol(ca)-1], at = do.breaks(c(-1,1),nrow(ca)),
col.regions = cc.levpalette)
dotchart(ca[order(ca[,ncol(ca)]),ncol(ca)],col=cc.levels,pch=19,cex=0.75)
title(main="Correlation to Vanguard S&P 500 (VFINX)",font.main=1,outer=TRUE,line=-1,cex.main=1.3)

Monday, June 11, 2012

Statistics of Drawdown–paper and post

Thank so much to Patrick Burns’ post Variability in maximum drawdown.  He starts with “Maximum drawdown is blazingly variable,” which I say is why money management is so blazingly difficult.  After spending a lot of time thinking about his post and trying to replicate the referenced paper

Casati, Alessandro, About the Statistics of the Maximum Drawdown in Financial Time Series (May 1, 2012). Available at SSRN: http://ssrn.com/abstract=2049584 or http://dx.doi.org/10.2139/ssrn.2049584

I think that the cumulative statistics, both total return and drawdown, fit well with the comment “The pictures imply that the maximum drawdown could have been pretty much anything.” Here is one of the figures that leads to this conclusion, and the predicted confidence interval from 20% to 90% is incredibly wide and not all that helpful.  If someone was willing to pay me for the bet that over the next 1,000 days, the S&P 500 or really any equity index drawdown falls between 20% and 90%, I would be happy to take that bet, and I would not need sophisticated statistical techniques to give me that insight.

image

Although I do not replicate the paper exactly with the most obvious difference that I use monthly returns 1950-May 2012 rather than daily returns 2002-2009, we can evaluate both return and drawdown through density plots with multiple distribution methods.  I limited my simulation to 10,000 samples so that I would not be up all night, but 10,000 is sufficient to show that over 62 years, both cumulative return and max drawdown can be virtually anything and both are “blazingly variable.”  I wonder how this would compare with life with sickness/death as drawdown and age of death as cumulative return.

From TimelyPortfolio
From TimelyPortfolio

To be fair, let’s annualize the cumulative returns (actually probably better to do over 5 to 20 year periods).

From TimelyPortfolio

Independent of the outcome, I really enjoyed the paper’s Figures 8, 9, and 10 getting me one step closer to the question posed in my post Is Drawdown the Biggest Determinant of System Success?

image

image

image

We do see a relationship between return and drawdown.

From TimelyPortfolio

If nothing else, I was delighted to see a discussion of the often ignored drawdown statistic, which is the key to every investment decision I make.

R code from GIST:

require(fGarch)
require(ttrTests)
require(quantmod)
require(PerformanceAnalytics)
getSymbols("^GSPC",from="1900-01-01")
#get monthly close prices from daily
price.monthly<-to.monthly(GSPC)[,4]
#get dates in yyyy-mm-01 format
index(price.monthly) <- as.Date(index(price.monthly))
#get arithmetic one month rate of change
roc.monthly <-ROC(price.monthly,n=1,type="discrete")
#change NA from first month to 0
roc.monthly[1,] <- 0
#get vector of prices for use with ttrTests
price.vector<-as.vector(price.monthly)
#fit historical to skewed student t
sstd.fit <- sstdFit(as.vector(roc.monthly))
#fit historical to student t
std.fit <- stdFit(as.vector(roc.monthly))
#this takes a while; choose smaller for playing
bsamples=10000
#prepopulate drawdowns matrix with NA
#for quicker filling later
drawdowns <- matrix(nrow=bsamples,ncol=3)
returns <- drawdowns
#will generate samples for bootstrap and stationary bootstrap
#to evaluate the maxDrawdown differences between the distributions
colnames(drawdowns) <- c("student.t","skew.student.t","ttrTests.stat.boot")
colnames(returns) <- colnames(drawdowns)
for (i in 1:bsamples) {
std.sample <- as.xts(rstd(n=NROW(roc.monthly),mean=std.fit$par[1],sd=std.fit$par[2],nu=std.fit$par[3]),
order.by=index(roc.monthly))
sstd.sample <- as.xts(rsstd(n=NROW(roc.monthly),mean=sstd.fit$estimate[1],sd=sstd.fit$estimate[2],nu=sstd.fit$estimate[3],xi=sstd.fit$estimate[4]),
order.by=index(roc.monthly))
boot.sample <- ROC(
as.xts(generateSample(price.vector,"stationaryBootstrap"),
order.by=index(price.monthly)),
n=1,type="discrete")
drawdowns[i,1] <- maxDrawdown(std.sample)
returns[i,1] <- Return.cumulative(std.sample)
drawdowns[i,2] <- maxDrawdown(sstd.sample)
returns[i,2] <- Return.cumulative(sstd.sample)
drawdowns[i,3] <- maxDrawdown(boot.sample)
returns[i,3] <- Return.cumulative(boot.sample)
}
#do the density plot for drawdown
d1 <- density(drawdowns[,1])
d2 <- density(drawdowns[,2])
d3 <- density(drawdowns[,3])
plot( d1, col=2, lwd=3, main="Density Plot of Drawdown by Distribution Method")
lines( d2, col=4, lwd=3)
lines( d3, col=3, lwd=3)
abline(v=maxDrawdown(ROC(price.monthly,type="discrete",n=1)),col="grey70")
#label experienced drawdown for the historical price series
text(x=maxDrawdown(ROC(price.monthly,type="discrete",n=1)), y=3.7, pos=3,
labels="SP500",srt=90,col="grey70", cex=0.75)
legend("topright",legend=colnames(drawdowns),col=c(2,4,3),lwd=3,bty="n")
#do the density plot for cumulative return
d1 <- density(returns[,1])
d2 <- density(returns[,2])
d3 <- density(returns[,3])
plot( d1, col=2, lwd=3, main="Density Plot of Cumulative Return by Distribution Method")
lines( d2, col=4, lwd=3)
lines( d3, col=3, lwd=3)
abline(v=Return.cumulative(ROC(price.monthly,type="discrete",n=1)),col="grey70")
#label experienced drawdown for the historical price series
text(x=Return.cumulative(ROC(price.monthly,type="discrete",n=1)), y=3.7, pos=3,
labels="SP500",srt=90,col="grey70", cex=0.75)
legend("topright",legend=colnames(returns),col=c(2,4,3),lwd=3,bty="n")
#do the density plot for annualized cumulative return
d1 <- density((returns[,1]+1)^(1/(NROW(price.monthly)/12))-1)
d2 <- density((returns[,2]+1)^(1/(NROW(price.monthly)/12))-1)
d3 <- density((returns[,3]+1)^(1/(NROW(price.monthly)/12))-1)
plot( d1, col=2, lwd=3, main="Density Plot of Cumulative Ann. Return by Distribution Method")
lines( d2, col=4, lwd=3)
lines( d3, col=3, lwd=3)
abline(v=Return.cumulative(ROC(price.monthly,type="discrete",n=1)),col="grey70")
#label experienced drawdown for the historical price series
text(x=Return.cumulative(ROC(price.monthly,type="discrete",n=1)), y=3.7, pos=3,
labels="SP500",srt=90,col="grey70", cex=0.75)
legend("topright",legend=colnames(returns),col=c(2,4,3),lwd=3,bty="n")
#plot Annualized Return vs Drawdown
plot((((returns[,1]+1)^(1/(NROW(price.monthly)/12))-1)~drawdowns[,1]),col=2,
main="Annualized Return and Max Drawdown",ylab="Annualized Return",xlab="Max Drawdown")
points(((returns[,2]+1)^(1/(NROW(price.monthly)/12))-1)~drawdowns[,2],col=4)
points(((returns[,3]+1)^(1/(NROW(price.monthly)/12))-1)~drawdowns[,3],col=3)
legend("topright",legend=colnames(returns),col=c(2,4,3),lwd=3,bty="n")

Friday, June 8, 2012

knitr Performance Report 4

please see knitR Performance Report 3 (really with knitr) and dprint, knitr Performance Report–Attempt 3, knitr Performance Report-Attempt 2 and knitr Performance Report-Attempt 1

Here is another iteration of the ongoing performance reporting attempts using R, knitr, and latex.  In this version, I used the dev=”tikz” option (don’t like but show for an example) and work hard with lattice to get what I believe is a very nice overview page.  I’ll revert back to my second example and use the tufte-handout package for a little cleaner and more modern layout. These examples are intended to stimulate thought and comment. Please let me know what you think.

R code in GIST ( use the line knit2pdf(“pathtofile.rnw”) ) to create the pdf:

\documentclass[nohyper,justified]{tufte-handout}
%\documentclass{article}
%great guides at epslatex.pdf
%check miniplot for potential use
%\usepackage{graphics}
%\usepackage{caption}
%\usepackage{sidecap}
%\usepackage{textpos}
%\usepackage[section]{placeins}
\title{Performance Report from knitr}
\author{Timely Portfolio}
\begin{document}
\maketitle
\begin{abstract}
We will pretend that HAM1 is real and investable with a marketing team that can raise billions of dollars. In reality, HAM1 is imaginary. HAM1 uses proprietary techniques built from decades of experience and centuries of historical data to identify high return opportunities.
\end{abstract}
\SweaveOpts{concordance=TRUE}
<<eval=TRUE,echo=FALSE,results='hide',warning=FALSE>>=
#do requires and set up environment for reporting
require(ggplot2)
require(directlabels)
require(reshape2)
require(lattice)
require(latticeExtra)
require(xtable)
require(dprint)
require(quantmod)
require(PerformanceAnalytics)
#trying some new colors out
mycolors=c(brewer.pal(9,"Blues")[c(7,5)],brewer.pal(9,"Greens")[6])
#mycolors=c(brewer.pal(6,"Blues)[c(3,5)],"slategray4")
#function to get numbers in percent format
#will use \\ to play well with tikz
percent <- function(x, digits = 2, format = "f", ...)
{
paste(formatC(100 * x, format = format, digits = digits, ...), "\\%", sep = "")
}
data(managers)
#get xts in df form so that we can melt with the reshape package
#will use just manager 1, sp500, and 10y treasury
managers <- managers[,c(1,8,9)]
#add 0 at beginning so cumulative returns start at 1
#also cumulative will match up datewise with returns
managers <- as.xts(rbind(rep(0,NCOL(managers)),coredata(managers)),
order.by=c(as.Date(format(index(managers)[1],"%Y-%m-01"))-1,index(managers)))
managers.df <- as.data.frame(cbind(index(managers),coredata(managers)),stringsAsFactors=FALSE)
#melt data which puts in a form that lattice and ggplot enjoy
managers.melt <- melt(managers.df,id.vars=1)
colnames(managers.melt) <- c("date","account","return")
managers.melt[,1] <- as.Date(managers.melt[,1])
#get cumulative returns starting at 1
managers.cumul <- as.xts(
apply(managers+1,MARGIN=2,FUN=cumprod),
#add end of first month to accommodate the 1 that we add
order.by=index(managers))
managers.cumul.df <- as.data.frame(cbind(index(managers.cumul),
coredata(managers.cumul)),
stringsAsFactors=FALSE)
managers.cumul.melt <- melt(managers.cumul.df,id.vars=1)
colnames(managers.cumul.melt) <- c("date","account","return")
managers.cumul.melt[,1] <- as.Date(managers.cumul.melt[,1])
#this is tricky but necessary
#reorder accounts and indexes to preserve order with manager and then benchmarks
managers.cumul.melt$account <- factor(as.character(managers.cumul.melt$account),colnames(managers)[c(2,3,1)],ordered=TRUE)
#get rolling returns for 1y, 3y, 5y, since inception
trailing <- table.TrailingPeriods(managers[,c(2,3,1)], periods=c(12,36,60,NROW(managers)),FUNCS=c("Return.annualized"),funcs.names=c("return"))
trailing.df <- as.data.frame(cbind(c("1y","3y","5y",paste("Since Inception ",format(index(managers)[1],"%b %Y"),sep="")),
c(rep("return",4)), #will allow for multiple measures if we decide to include later
coredata(trailing)),
stringsAsFactors=TRUE)
trailing.melt <- melt(trailing.df,id.vars=1:2)
colnames(trailing.melt) <- c("period","measure","account","value")
#this is tricky but necessary
#reorder the period so that they will be in correct chronological order
trailing.melt$period <- factor(as.character(trailing.melt$period),rev(c("1y","3y","5y",paste("Since Inception ",format(index(managers),"%b %Y"),sep=""))),ordered=TRUE)
#reorder accounts and indexes to preserve order with manager and then benchmarks
trailing.melt$account <- factor(as.character(trailing.melt$account),colnames(managers)[c(3,2,1)],ordered=TRUE)
#get drawdown by date for drawdown graph
drawdown <- Drawdowns(managers)
drawdown.df <- as.data.frame(cbind(index(drawdown),coredata(drawdown)),
stringsAsFactors=FALSE)
drawdown.melt <- melt(drawdown.df,id.vars=1)
colnames(drawdown.melt) <- c("date","account","drawdown")
drawdown.melt[,1] <- as.Date(drawdown.melt[,1])
#this is tricky but necessary
#reorder accounts and indexes to preserve order with manager and then benchmarks
drawdown.melt$account <- factor(as.character(drawdown.melt$account),colnames(managers)[c(2,3,1)],ordered=TRUE)
@
%\newpage
\section{Overview}
\begin{figure}[!htb]
<<echo=FALSE,eval=TRUE,fig=TRUE,fig.width=13,fig.height=13,out.width='1.25\\linewidth',results='hide',dev="tikz">>=
#while latticeExtra theEconomist.theme is beautiful
#I wanted to stretch my knowledge, so I will start from scratch
#example given to left justify strip
#http://maths.anu.edu.au/~johnm/r-book/xtras/boxcontrol.pdf
stripfun <- function(which.given, which.panel,factor.levels, ...){
grid.rect(name = trellis.grobname("bg", type = "strip"),
gp = gpar(fill = "seashell3", col = "seashell3"))
panel.text(x=0.10, y=0.5,
lab = factor.levels[which.panel[which.given]],
adj=0, font=3, cex=1.3)
}
#heavily stripped and modified theEconomist.axis() from latticeExtra
timely.axis <- function (side = c("top", "bottom", "left", "right"), scales,
components, ..., labels = c("default", "yes", "no"), ticks = c("default",
"yes", "no"), line.col, noleft=TRUE)
{
side <- match.arg(side)
if (side == "top") return()
labels <- match.arg(labels)
ticks <- match.arg(ticks)
if (side %in% c("left", "right")) {
if (side == "right") {
scales$draw=TRUE
labels <- "no"
ticks <- "no"
}
if (side == "left") {
labels <- "yes"
ticks <- "yes"
}
}
axis.default(side, scales = scales, components = components,
..., labels = labels, ticks = ticks, line.col = "black")
if (side == "right" ) {#& panel.number()==1) {
comp.list <- components[["right"]]
if (!is.list(comp.list))
comp.list <- components[["left"]]
panel.refline(h = comp.list$ticks$at)
lims <- current.panel.limits()
panel.abline(h = lims$y[1], col = "black")
}
}
#set up ylimits to use for the two scales
ylimits<-c(pretty(c(min(managers.cumul.melt$return),
max(managers.cumul.melt$return)),4),as.numeric(round(last(managers.cumul)[,order(last(managers.cumul))],2)))
ylabels<-c(ylimits[1:(length(ylimits)-3)],colnames(managers)[order(last(managers.cumul))])
returns <- list(
bar = barchart(account~value|period,col=mycolors,data=trailing.melt,
layout=c(1,4),
box.ratio=0.10,
origin=0,
reference=TRUE,
border = NA,
par.settings=
list(
par.main.text = list(font = 1, cex=1.5, just = "left",x = grid::unit(5, "mm")),
axis.line = list(col = NA)),
scales=list(x=list(
limits=c(0,max(trailing.melt$value)+0.05), #snug labels right up to bars by setting to 0
at=pretty(trailing.melt$value),
labels=paste(round(100*as.numeric(pretty(trailing.melt$value)), 2), "\\%", sep="")
)),
xlab=NULL,
axis = timely.axis,
strip=stripfun,
strip.left=FALSE,
panel=function(...) {
panel.barchart(...)
tmp <- list(...)
tmp <- data.frame(x=tmp$x, y=tmp$y)
# add text labels
panel.text(x=tmp$x, y=tmp$y,
label=percent(tmp$x , 2 ),
cex=1, col=mycolors, pos=4)
},
main="Annualized Returns"),
cumulgrowth =
xyplot(return~date,groups=account,data=managers.cumul.melt,
# col=mycolors,
type="l",lwd=3,
xlab=NULL,
ylab=NULL,
par.settings=
list(
par.main.text = list(font = 1, cex=1.5, just = "left",x = grid::unit(5, "mm")),
axis.line = list(col = "transparent"),
superpose.line=list(col=mycolors)), #do this for direct.label
scales=list(x=list(alternating=1,at=index(managers)[endpoints(managers,"years")],
labels=format(index(managers)[endpoints(managers,"years")],"%Y")),
y=list(alternating=3,at=ylimits,labels=ylabels)),
axis=function (side = c("top", "bottom", "left", "right"), scales,
components, ..., labels = c("default", "yes", "no"), ticks = c("default",
"yes", "no"), line.col){
side <- match.arg(side)
labels <- match.arg(labels)
ticks <- match.arg(ticks)
axis.text <- trellis.par.get("axis.text")
if(side == "top") return()
if(side == "right") {
components[["right"]]<-components[["left"]]
components[["right"]]$ticks$at <- components[["right"]]$ticks$at[5:7]
components[["right"]]$labels$at <- components[["right"]]$labels$at[5:7]
components[["right"]]$labels$labels <- components[["right"]]$labels$labels[5:7]
}
if(side %in% c("bottom","right")){
axis.default(side, scales = scales, components = components,
..., labels = labels, ticks = ticks, line.col = axis.text$col)
if (side == "right") {
comp.list <- components[["left"]]
panel.refline(h = comp.list$ticks$at[1:4])
lims <- current.panel.limits()
panel.abline(h = lims$y[1], col = axis.text$col)
comp.list.left<-components[["left"]]
comp.list.left$ticks$at <- components[["left"]]$ticks$at[1:4]
comp.list.left$labels$at <- components[["left"]]$labels$at[1:4]
comp.list.left$labels$labels <- components[["left"]]$labels$labels[1:4]
panel.axis(side="left",at=comp.list.left$ticks$at,outside=TRUE)
}
}
},
main=paste("Cumulative Growth Since Inception ",format(index(managers)[1],"%B %Y"),sep=""))
)
#set up ylimits to use for the two scales
ylimits<-c(pretty(c(min(drawdown.melt$drawdown),
max(drawdown.melt$drawdown)),4),as.numeric(round(last(drawdown)[,order(last(drawdown))],2)))
ylabels<-c(percent(ylimits[1:(length(ylimits)-3)],digits=0),colnames(managers)[order(last(drawdown))])
risk=list(
drawdown=
xyplot(drawdown~date,group=account,data=drawdown.melt,
type="l",lwd=3,
xlab=NULL,
ylab=NULL,
par.settings=
list(
par.main.text = list(font = 1, cex=1.5, just = "left",x = grid::unit(5, "mm")),
axis.line = list(col = "transparent"),
superpose.line=list(col=mycolors)), #do this for direct.label
scales=list(x=list(alternating=1,at=index(managers)[endpoints(managers,"years")],
labels=format(index(managers)[endpoints(managers,"years")],"%Y")),
y=list(alternating=3,at=ylimits,labels=ylabels)),
axis=function (side = c("top", "bottom", "left", "right"), scales,
components, ..., labels = c("default", "yes", "no"), ticks = c("default",
"yes", "no"), line.col){
side <- match.arg(side)
labels <- match.arg(labels)
ticks <- match.arg(ticks)
axis.text <- trellis.par.get("axis.text")
if(side == "top") return()
if(side == "right") {
components[["right"]]<-components[["left"]]
components[["right"]]$ticks$at <- components[["right"]]$ticks$at[6:8]
components[["right"]]$labels$at <- components[["right"]]$labels$at[6:8]
components[["right"]]$labels$labels <- #components[["right"]]$labels$labels[6:8]
NULL
}
if(side %in% c("bottom","right")){
if(side=="bottom") {
axis.default(side, scales = scales, components = components,
..., labels = labels, ticks = ticks, line.col = axis.text$col)
}
if (side == "right") {
comp.list <- components[["left"]]
panel.refline(h = comp.list$ticks$at[1:5])
lims <- current.panel.limits()
panel.abline(h = lims$y[1], col = axis.text$col)
comp.list.left<-components[["left"]]
comp.list.left$ticks$at <- components[["left"]]$ticks$at[1:5]
comp.list.left$labels$at <- components[["left"]]$labels$at[1:5]
comp.list.left$labels$labels <- components[["left"]]$labels$labels[1:5]
panel.axis(side="left",at=comp.list.left$ticks$at,labels=comp.list.left$labels$labels,outside=TRUE)
}
}
},
main=paste("Drawdown Since Inception ",format(index(managers)[1],"%B %Y"),sep=""))
)
risk$drawdown <- direct.label(risk$drawdown,list("smart.grid",cex=0.75))
print(returns$cumulgrowth,position=c(0,0.6,0.6,1),more=TRUE)
#print(returns$bar,position=c(0,0,0.6,0.6),more=TRUE)
print(risk$drawdown,position=c(0,0,0.6,0.6),more=TRUE)
#print(risk$drawdown,position=c(0.6,0,1,1))
print(returns$bar,position=c(0.6,0,1,1))
@
%\end{minipage}
%\begin{center}
<<echo=FALSE,eval=TRUE,results='tex'>>=
trailingtable <- apply(trailing,MARGIN=2,FUN=percent)
rownames(trailingtable) <- c("1y","3y","5y",paste("Since Inception ",format(index(managers)[1],"%b %Y")))
#commented out because I like the dprint better than xtable
#print(xtable(trailingtable), floating=FALSE)
@
%\end{center}
\end{figure}
\newpage
\section{Returns}
Unfortunately, the Return section is generally the focus of the sales pitch and also is often the biggest concern for the prospect. Although it easiest to sell on return in the short-term, long-term success requires much more focus on the graphs presented in the Overview and Risk sections.
\begin{figure}[!htb]
<<returns,echo=FALSE,eval=TRUE,fig=TRUE,warning=FALSE,results='hide',dev="tikz",out.width='1\\linewidth'>>=
win.graph(width=6,height=6)
cal_returns <- table.CalendarReturns(managers)[-1,13:15]
cal_returns.df <- as.data.frame(cbind(rownames(cal_returns),apply(cal_returns/100,MARGIN=2,percent)))
colnames(cal_returns.df)[1] <- "Date"
dprint(data=cal_returns.df,label="Date",pg.dim=c(6,6),fit=TRUE,margins=c(0,0,0,0),
main="Returns By Year",row.hl=row.hl(which(cal_returns[,1]<0),col="indianred1"))
dev.off()
@
\caption{Unbelieveable returns with only one negative year. SEC loves language like this.\label{fig:returns}}
\end{figure}
\newpage
\section{Risk}
\end{document}

Evaluation of Tactical Approaches

Tactical approaches are often chosen based on the best cumulative return which implicitly incorporates significant hindsight bias.  Just because an approach dominates for a period of time does not indicate that it will be the best approach.  As the investment community abandons buy-and-hold and embraces tactical allocation, my guess is that the best cumulative return gathers the most assets.

Mebane Faber’s 10-month moving average system explored in

A Quantitative Approach to Tactical Asset Allocation
Journal of Wealth Management, Spring 2007

and further refined in his book

offers a simple method for achieving what most would deem as a good result—respectable cumulative returns with significantly less risk regardless of risk measure.  Let’s play with degrees of freedom and make slight changes to the system to see how they performed in the past.  Let’s then try to decide which approach we should pursue in the future given very incomplete information.  Once we decide, let’s then decide how confident we can be in the future result.

I will test 4 systems that are all very similar in approach:

NOT INVESTMENT ADVICE.  PLEASE DO NOT USE AS THE RESULT WILL BE LARGE AND PAINFUL LOSSES.

  1. Mebane Faber 10 month moving average
  2. Rolling Proprietary (say with a smile but don’t use emoticon) Sharpe ratio > 10 month moving average
  3. Rolling Proprietary Sharpe ratio > 0
  4. Rolling Proprietary Sharpe ratio > 6 months ago Rolling Proprietary Sharpe ratio

With a little help from the fine examples given in Download and parse EDHEC hedge fund indexes, we can visualize the cumulative returns and drawdowns of each approach.  I have denoted with a line 1985 which is a time when we might have chosen approach #2 since it offered significantly better cumulative returns from 1950-1985.  However, the result after our 1985 choice was not as good as we would have expected.

From TimelyPortfolio

Again using Download and parse EDHEC hedge fund indexes, we can use some more sophisticated measure of risk.  The middle (MovAvgSharpe or approach #2) offers the lowest level of historical risk on a cumulative basis.  Even though performance lagged since its 1985 first place finish, this might encourage us to still pick this approach.

From TimelyPortfolio

To continue our move away from cumulative return towards other statistics, we can check the distribution of the monthly changes and also some higher-moment statistics skewness and kurtosis.

From TimelyPortfolio
From TimelyPortfolio

Even after all this exploration, we can predict nothing.  For more confidence, we might use ttrTests (explained in posts http://timelyportfolio.blogspot.com/search/label/ttrTests), use random portfolios as advocated and explained very well by http://portfolioprobe.com, and/or let relative strength decide as advocated and explained very well by http://systematicrelativestrength.com/.  However in 30 years, we have no idea what will do best or even what best means.

R code in GIST:

require(lattice)
require(latticeExtra)
require(reshape2)
require(directlabels)
require(quantmod)
require(PerformanceAnalytics)
getSymbols("^GSPC",from="1900-01-01")
GSPC.monthly <- GSPC[endpoints(GSPC,"months"),4]
GSPC.roc <- ROC(GSPC.monthly,type="discrete",n=1)
#apply.rolling with SharpeRatio as FUN gives error
#so I started playing with variations of Sharpe
sharpe <- (apply.rolling(GSPC.roc+1,FUN=prod,width=12)-1)/(runMax(abs(GSPC.roc),n=3))
systems <- merge(GSPC.roc,
lag(ifelse(GSPC.monthly > runMean(GSPC.monthly,n=10),1,0))*GSPC.roc,
lag(ifelse(sharpe > runMean(sharpe,n=10),1,0))*GSPC.roc,
lag(ifelse(sharpe > 0,1,0))*GSPC.roc,
lag(ifelse(sharpe > lag(sharpe,k=6),1,0))*GSPC.roc)
colnames(systems) <- c("SP500","MovAvgPrice","MovAvgSharpe","Sharpe>0","Sharpe>6moPrior")
#publicize the fine work at http://tradeblotter.wordpress.com/2012/06/04/download-and-parse-edhec-hedge-fund-indexes/
#all code for next two charts comes from the post
#I deserve no credit
# Cumulative returns and drawdowns
par(cex.lab=.8) # should set these parameters once at the top
op <- par(no.readonly = TRUE)
layout(matrix(c(1, 2)), height = c(2, 1.3), width = 1)
par(mar = c(1, 4, 4, 2))
chart.CumReturns(systems, main = "S&P 500 with Tactical Overlays",
xaxis = FALSE, legend.loc = "topleft", ylab = "Cumulative Return",
#use colors from latticeExtra theEconomist theme so colors will be consistent
colorset= theEconomist.theme()$superpose.line$col, ylog=TRUE,
wealth.index=TRUE, cex.legend=.7, cex.axis=.6, cex.lab=.7)
abline(v=which(index(systems)=="1985-12-31"),col="red",lty=2)
text(x=which(index(systems)=="1985-12-31")+2,y=1,labels="Dividing Line in Result",adj=0,srt=90,cex=0.7,col="red")
par(mar = c(5, 4, 0, 2))
chart.Drawdown(systems, main = "", ylab = "Drawdown", colorset = theEconomist.theme()$superpose.line$col, cex.axis=.6, cex.lab=.7)
abline(v=which(index(systems)=="1985-12-31"),col="red",lty=2)
par(op)
# Generate charts of with ETL and VaR through time
#caution: this takes about 10 minutes to complete
par(mar=c(3, 4, 0, 2) + 0.1) #c(bottom, left, top, right)
charts.BarVaR(systems, p=(1-1/12), gap=36, main="", show.greenredbars=TRUE,
methods=c("ModifiedES", "ModifiedVaR"), show.endvalue=TRUE,
colorset=rep("Black",7), ylim=c(-.1,.15))
par(op)
#do a lattice density plot so we can look at the distributions
#of monthly changes for each approach
systems.df <- as.data.frame(cbind(index(systems),coredata(systems)))
systems.melt <- melt(systems.df,id.vars=1)
colnames(systems.melt) <- c("date","system","monthROC")
dp <- densityplot(~monthROC,groups=system,data=systems.melt,
par.settings = theEconomist.theme(box = "transparent"),
lattice.options = theEconomist.opts(),
ylim=c(0,125),
xlab=NULL,
main="Density Plot of Monthly Change in S&P 500 with Tactical Overlays")
direct.label(dp,top.bumptwice)
#density plot reveals very different distributions
#so get the skew and kurtosis for each approach
skew.kurtosis <- rbind(skewness(systems),kurtosis(systems))
skew.kurtosis.melt <- melt(cbind(rownames(skew.kurtosis),skew.kurtosis))
colnames(skew.kurtosis.melt) <- c("variable","system","value")
barchart(value~variable,group=system,data=skew.kurtosis.melt,
origin=0,
par.settings = theEconomist.theme(box = "transparent"),
lattice.options = theEconomist.opts(),
auto.key=list(space="right"),
ylab=NULL,
main="Skewness and Kurtosis of S&P 500 with Tactical Overlays")

Friday, June 1, 2012

System from Trend Following Factors

As I thought more about Trend Following Factors from Hsieh and Fung, I thought that the trend following factors might indicate a state/regime for the equity markets that could potentially offer momentum-style timing signals for a system on the S&P 500.  Now, THIS ABSOLUTELY SHOULD NOT BE CONSIDERED INVESTMENT ADVICE, especially since the factor data is very lagged and the testing is nowhere near comprehensive enough.  I will however try to replicate the factor methodology to get a more real-time indicator extended to any index in another post. What is most interesting to me is that this is ex-ante intuitive and the signal is just basic statistics.

From TimelyPortfolio
From TimelyPortfolio
From TimelyPortfolio
Comments have been very light. Please let me know your thoughts.

R code from GIST:

###########NOT INVESTMENT ADVICE######################
#extend the trend following factors into a system for trading S&P 500
#Hsieh, David A. and Fung, William,
#The Risk in Hedge Fund Strategies: Theory and Evidence from Trend Followers.
#The Review of Financial Studies, Vol. 14, No. 2, Summer 2001 .
#Available at SSRN: http://ssrn.com/abstract=250542
#http://faculty.fuqua.duke.edu/~dah7/DataLibrary/TF-Fac.xls
require(gdata)
require(quantmod)
require(PerformanceAnalytics)
require(FactorAnalytics)
URL <- "http://faculty.fuqua.duke.edu/~dah7/DataLibrary/TF-Fac.xls"
#get xls sheet TF-Fac starting at the row with yyyymm
hsieh_factor <- read.xls(URL,sheet="TF-Fac",pattern="yyyymm",stringsAsFactors=FALSE)
hsieh_factor.clean <- hsieh_factor
#clean up date to get to yyyy-mm-dd
hsieh_factor.clean[,1] <- as.Date(paste(substr(hsieh_factor[,1],1,4),
substr(hsieh_factor[,1],5,6),
"01",sep="-"))
#remove percent sign and make numeric
hsieh_factor.clean[,2:6] <- apply(
apply(hsieh_factor[,2:6],
MARGIN=2,
FUN=function(x) {gsub("%", "", x)}),
MARGIN=2,
as.numeric)/100
#get rid of NAs
hsieh_factor.clean <- hsieh_factor.clean[,1:6]
hsieh_factor.xts <- as.xts(hsieh_factor.clean[,2:6],order.by=hsieh_factor.clean[,1])
chart.CumReturns(hsieh_factor.xts,
main="Hsieh and Fung Trend Following Factors",
xlab=NA,
legend.loc="topleft")
mtext(text="Source: http://faculty.fuqua.duke.edu/~dah7/DataLibrary/TF-Fac.xls",
side=3,adj=0.10,outer=TRUE, col="purple",cex=0.75,line=-4)
chart.Correlation(hsieh_factor.xts,main="Hsieh and Fung Trend Following Factors")
mtext(text="Source: http://faculty.fuqua.duke.edu/~dah7/DataLibrary/TF-Fac.xls",
side=1,adj=0.10,outer=TRUE, col="purple",cex=0.75,line=-1.5)
#get edhec data for sample factor analysis
data(edhec)
cta <- edhec[,1]
index(cta)=as.Date(format(index(cta),"%Y-%m-01"))
cta.factors <- na.omit(merge(cta,hsieh_factor.xts))
chart.RollingStyle(cta.factors[,1],cta.factors[,2:NCOL(cta.factors)],
width=36,
colorset=c("darkseagreen1","darkseagreen3","darkseagreen4","slateblue1","slateblue3","slateblue4"),
main="Edhec CTA by Trend Following Factors Rolling 36 Months")
mtext(text="Source: http://faculty.fuqua.duke.edu/~dah7/DataLibrary/TF-Fac.xls",
side=1,adj=0.10,outer=TRUE, col="purple",cex=0.75,line=-5)
#in one line get SP500 data, convert to monthly, and get 1-month rate of change
GSPC.roc <- ROC(to.monthly(get(getSymbols("^GSPC",from="1900-01-01")))[,4],n=1,type="discrete")
colnames(GSPC.roc) <- "SP500"
#convert date to yyyy-mm-01 so we can merge properly
index(GSPC.roc) <- as.Date(index(GSPC.roc))
#merge factor data with ROC data
roc.factors <- na.omit(merge(GSPC.roc,hsieh_factor.xts))
#graph 6 month rolling correlation
chart.RollingCorrelation(roc.factors[,2:NCOL(roc.factors)],roc.factors[,1],n=6,
legend.loc="topleft",main="Correlation (Rolling 6-month)")
chart.RollingCorrelation(roc.factors[,6],roc.factors[,1],n=6,
legend.loc="topleft",main="PTFSSTK (Stock) Correlation (Rolling 6-month)")
abline(h=-0.6,col="red")
abline(h=0.5,col="green")
#get rolling 6 month correlation versus all the factors
correl <- as.xts(
apply(roc.factors[,2:NCOL(roc.factors)],MARGIN=2,runCor,y=roc.factors[,1],n=6),
order.by=index(roc.factors))
#do simple system where long if correlation with stock trend following factor is low
#as defined by a band of -0.6 and 0.5
system <- lag(ifelse(correl[,5] > -0.6 & correl[,5] < 0.5,1,0)) * GSPC.roc
#see how it works
charts.PerformanceSummary(merge(system,GSPC.roc))