Archive

Asset Pricing

I have grown a bit tired of R and the blind ritual of haphazardly replicating things here and there. In this post I will collect some tidbits and reminders so as to make it easier for myself to pick this language up again if and when I can force myself to do so.

[1] GGplot Table Drawer

In the previous series of posts I used the custom (sometimes problematic) table plotter function to visualise model results in tabulated form. I have since made some changes to this function which i shall summarise here.

Implementation is simple :

  1. ggTableSpec() function is used to specify various elements of the table we wish to create :
    • interpretation of function arguments is straightforward. The only issue here worth mentioning is that the hlt.row / hlt.col arguments are swapped.If one wants to highlight rows (cols) then hlt.col (hlt.row) should be specified. Just a quirk that I cannot be bothered to change at the moment. This function returns a list object.
  2. ggTableDrawer() function uses the output of the ggTableSpec() function to plot the desired table using ggplot2 functions.

The code for both functions is given here :

l

#################################################################################################################
# Specify Elements Of the Table
#################################################################################################################
ggTableSpec <- function(columns.exist,columns.txt,columns.font,columns.col,columns.fill,columns.alpha,
		                    rows.exist,rows.txt,rows.font,rows.col,rows.fill,rows.alpha,
		                    data.obj,data.col,data.title,
		                    hlt.col.exist,hl.col.which,hl.col.fill,hl.col.alpha,
		                    hlt.row.exist,hl.row.which,hl.row.fill,hl.row.alpha
		                    ){
#Construct the Title Layer
	Title.Layer <- list()

		Title.Layer$Columns <- list()
			if(columns.exist){
				Title.Layer$Columns$Exist <- TRUE
				Title.Layer$Columns$Txt  <- columns.txt
  			Title.Layer$Columns$Font <- columns.font
  			Title.Layer$Columns$Col <- columns.col
  			Title.Layer$Columns$Fill <- columns.fill
  			Title.Layer$Columns$Alpha <- columns.alpha
			}else{
				Title.Layer$Columns$Exist <- FALSE

		  }

	  Title.Layer$Rows <- list()
	  	if(rows.exist){
	  		Title.Layer$Rows$Exist <- TRUE
				Title.Layer$Rows$Txt  <- rows.txt
  			Title.Layer$Rows$Font <- rows.font
  			Title.Layer$Rows$Col <- rows.col
  			Title.Layer$Rows$Fill <- rows.fill
  			Title.Layer$Rows$Alpha <- rows.alpha
	  	}else{
	  		Title.Layer$Rows$Exist <- FALSE
	  }

#Construct Data Layer
	Data.Layer <- list()
	 Data.Layer$Txt <- data.obj
	 Data.Layer$Col <- data.col
	 Data.Layer$Title <- data.title

#Construct Highlight Layer
	Highlight.Layer <- list()

		Highlight.Layer$Columns <- list()
			if(hlt.col.exist){
				Highlight.Layer$Columns$Exist <- TRUE
				Highlight.Layer$Columns$Which <- hl.col.which
				Highlight.Layer$Columns$Fill  <- hl.col.fill
				Highlight.Layer$Columns$Alpha <- hl.col.alpha
			}else{
				Highlight.Layer$Columns$Exist <- FALSE
			}

		Highlight.Layer$Rows <- list()
			if(hlt.row.exist){
				Highlight.Layer$Rows$Exist <- TRUE
				Highlight.Layer$Rows$Which <- hl.row.which
				Highlight.Layer$Rows$Fill  <- hl.row.fill
				Highlight.Layer$Rows$Alpha <- hl.row.alpha
			}else{
				Highlight.Layer$Rows$Exist <- FALSE
			}

gg.table.spec <- list(Title.Layer=Title.Layer,Data.Layer=Data.Layer,Highlight.Layer=Highlight.Layer)
return(gg.table.spec)
}
########################################################################################################

#################################################################################################################
# Draw Table
#################################################################################################################

ggTableDrawer <- function(gg.table.spec){
	#Data Coordinates & Dataframe
	  e<- environment()
	  data.obj <- apply(gg.table.spec$Data.Layer$Txt,2,rev)
	  data.col <- gg.table.spec$Data.Layer$Col

		xmin <- 1
	  ymin <- 1

	  xmax <- ncol(gg.table.spec$Data.Layer$Txt)
	  ymax <- nrow(gg.table.spec$Data.Layer$Txt)

	  x.adj <-1
	  y.adj <-1
	 	lab.adj <- 0.05

	 if(gg.table.spec$Title.Layer$Rows$Exist){
	 	txt.temp <- gg.table.spec$Title.Layer$Rows$Txt
	 	max.char <- max(nchar(txt.temp))
	 	empty.adj.min<-0.1*max.char

	 	}else{
	 		empty.adj.min<-0
	 	}

	  empty.layer.adj <- 1
	  temp.seq <- seq(xmin,xmax,length=xmax)

	  DataLayer.df <- data.frame(data.obj,ycoord=1:ymax,stringsAsFactors=F)
			for(i in 1:length(temp.seq)){
				DataLayer.df <- cbind(DataLayer.df,rep(temp.seq[i]+5*lab.adj,ymax))
			}
	  colnames(DataLayer.df)[(xmax+2):(xmax+2+length(temp.seq)-1)] <- paste('xcoord',1:xmax,sep='')

	  parse.temp <- colnames(DataLayer.df)[(xmax+2):(ncol(DataLayer.df))]
	  parse.coord <- paste('c(',paste(parse.temp,collapse=','),')',sep='')

	  parse.temp <- colnames(gg.table.spec$Data.Layer$Txt)
		parse.lbl <- paste('c(',paste(parse.temp,collapse=','),')',sep='')

	  parse.ycoord <- paste('c(',paste(rep('ycoord',xmax),collapse=','),')',sep='')

	  EmptyLayer <- ggplot(data=DataLayer.df)+
		                geom_blank()+
		                xlim(xmin-empty.adj.min,xmax+empty.layer.adj)+
		                labs(title=gg.table.spec$Data.Layer$Title)+
                    theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank(),panel.border = element_blank(), panel.background = element_blank(), axis.title.x = element_blank(),axis.title.y = element_blank(), axis.text.x = element_blank(), axis.text.y = element_blank(),axis.ticks = element_blank())

	  DataLayer <- geom_text(data=DataLayer.df,aes_string(y=parse.ycoord,x=parse.coord,label=parse.lbl,hjust=0,vjust=1),size=rel(3),colour=data.col)

	#Title coordinates & Dataframe
  	#Columns
			if(!gg.table.spec$Title.Layer$Columns$Exist){
				Title.Column.Layer <- NULL
				Rect.Column.Layer <- NULL
				Rect.Column.df <- data.frame(xmin=xmin,xmax=xmax+empty.layer.adj,ymin=ymax,ymax=ymax+0.5)
			}else{
				col.title.adj <- 0.5
				col.title.xmin <- xmin
				col.title.xmax <- xmax
				col.title.ymin <- ymax
				col.title.ymax <- col.title.ymin+col.title.adj
				col.y <- (col.title.ymax+col.title.ymin)/2

				col.lbls <- gg.table.spec$Title.Layer$Columns$Txt
				col.font <- gg.table.spec$Title.Layer$Columns$Font
				fill <- gg.table.spec$Title.Layer$Columns$Fill
				alpha<- gg.table.spec$Title.Layer$Columns$Alpha
				col.colour <- gg.table.spec$Title.Layer$Columns$Col

			  Title.Column.df <- data.frame(lab.x=seq(col.title.xmin,col.title.xmax,length=length(col.lbls)),lab.y=rep(col.y,length(col.lbls)),Text=col.lbls,Font=col.font)
			  Rect.Column.df <- data.frame(xmin=col.title.xmin,xmax=col.title.xmax+empty.layer.adj,ymin=col.title.ymin,ymax=col.title.ymax,fill=fill,alpha=alpha)

				Title.Column.Layer <- geom_text(data=Title.Column.df,aes(x=lab.x,y=lab.y,label=Text,fontface=Font,hjust=0,vjust=0),size=rel(3),colour=col.colour)
				Rect.Column.Layer <- geom_rect(data=Rect.Column.df,aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=+Inf),alpha=alpha,fill=fill)

			}

#Rows
			if(!gg.table.spec$Title.Layer$Rows$Exist){
				Title.Row.Layer <- NULL
				Rect.Row.Layer <- NULL
				Rect.Row.df <- data.frame(xmax=1,ymax=Rect.Column.df$ymin)
			}else{
				row.lbls <- rev(gg.table.spec$Title.Layer$Rows$Txt)
				row.font <- gg.table.spec$Title.Layer$Rows$Font
				fill <- gg.table.spec$Title.Layer$Rows$Fill
				alpha<- gg.table.spec$Title.Layer$Rows$Alpha
				row.colour <- gg.table.spec$Title.Layer$Rows$Col

				quo <- 1/15
				row.title.adj <- max(nchar(row.lbls))*quo
				row.title.xmin <- xmin-row.title.adj
				row.title.xmax <- xmin
				row.title.ymin <- ymin-1
				row.title.ymax <- Rect.Column.df$ymin

			  Title.Row.df <- data.frame(lab.y=DataLayer.df$ycoord,lab.x=rep(row.title.xmin,length(row.lbls)),Text=row.lbls,Font=row.font,stringsAsFactors=F)
				Rect.Row.df <- data.frame(xmin=row.title.xmin,xmax=row.title.xmax,ymin=row.title.ymin,ymax=row.title.ymax,fill=fill,alpha=alpha,stringsAsFactors=F)

				Title.Row.Layer <- geom_text(data=Title.Row.df,aes(x=lab.x,y=lab.y,label=Text,fontface=Font,hjust=0,vjust=1),size=rel(3),colour=row.colour)
				Rect.Row.Layer <- geom_rect(data=Rect.Row.df,aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax),alpha=alpha,fill=fill)
			}

#column highlights
			if(!gg.table.spec$Highlight.Layer$Columns$Exist){
		    Highlight.Column.Layer <- NULL
			}else{
				hl.col.dyn <- 0
			  hl.col.ymin <- ymax-gg.table.spec$Highlight.Layer$Columns$Which+hl.col.dyn
				hl.col.adj <- Rect.Column.df$ymin-ymax

				hl.col.xmin <- Rect.Column.df$xmin
			  hl.col.xmax <- Rect.Column.df$xmax
	      hl.col.ymax <- hl.col.ymin+1

				n.hl <- length(hl.col.ymin)

				fill <- gg.table.spec$Highlight.Layer$Columns$Fill
				alpha<- gg.table.spec$Highlight.Layer$Columns$Alpha

				Highlight.Column.df <- data.frame(xmin=rep(hl.col.xmin,n.hl),xmax=rep(hl.col.xmax,n.hl),ymin=hl.col.ymin,ymax=hl.col.ymax,fill=fill,alpha=alpha,stringsAsFactors=F)
	      Highlight.Column.Layer <- geom_rect(data=Highlight.Column.df,aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax),fill=fill,alpha=alpha)

			}

#row highlights
			if(!gg.table.spec$Highlight.Layer$Rows$Exist){
		    Highlight.Row.Layer <- NULL
			}else{
				hl.row.adj <- 1-Rect.Row.df$xmax
				hl.row.xmin <- rev(gg.table.spec$Highlight.Layer$Rows$Which)-hl.row.adj
			  hl.row.xmax <- rev(gg.table.spec$Highlight.Layer$Rows$Which)+1-hl.row.adj
				hl.row.ymin <- 0
	      hl.row.ymax <- Rect.Row.df$ymax
				n.hl <- length(hl.row.xmin)

				fill <- rev(gg.table.spec$Highlight.Layer$Rows$Fill)
				alpha<- gg.table.spec$Highlight.Layer$Rows$Alpha

				Highlight.Row.df <- data.frame(xmin=hl.row.xmin,xmax=hl.row.xmax,ymin=hl.row.ymin,ymax=hl.row.ymax,fill=fill,alpha=alpha,stringsAsFactors=F)
	      Highlight.Row.Layer <- geom_rect(data=Highlight.Row.df,aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax),fill=fill,alpha=alpha)

			}	

ggtbl <- EmptyLayer +
						Rect.Column.Layer +
						Title.Column.Layer +
						Rect.Row.Layer +
						Title.Row.Layer +
						Highlight.Column.Layer +
						Highlight.Row.Layer +
						DataLayer

return(ggtbl)
}
########################################################################################################

h
Example of implementations on the basis of :
l

#######################################################################################################
# Sample Data Frame
#######################################################################################################
Feed.list <- c('caviar','cayenne pepper','celery','cereal','chard','cheddar','cheese','cheesecake','chef','cherry','chew','chicken','chick peas','chili','chips','chives','chocolate','chopsticks','chow','chutney')
debug.df <- data.frame(Feed=Feed.list,Cats=round(runif(20),2),Dogs=round(runif(20),2),Pigs=round(runif(20),2),Smaug_the_dragon=1000*round(runif(20),2))
rownames(debug.df) <- paste('MODEL',1:20,sep='-')
which.idx <- which(debug.df[,'Smaug_the_dragon']>900)
which.idx2 <- which(debug.df[,'Smaug_the_dragon']<=900)
#######################################################################################################

l
Implementation 1 : Rows and Columns exist
l

#######################################################################################################
# Example 1
#######################################################################################################
debug.spec <- ggTableSpec(columns.exist=T,columns.txt=colnames(debug.df),columns.font=rep('bold',5),columns.col='black',columns.fill='grey',columns.alpha=0.7,
		                      rows.exist=T,rows.txt=rownames(debug.df),rows.font=rep('bold',20),rows.col='black',rows.fill='grey',rows.alpha=0.7,
		                      data.obj=debug.df,data.col='black',data.title='The hunger games',
		                    	hlt.col.exist=T,hl.col.which=c(which.idx,which.idx2),hl.col.fill=c(rep('green',length(which.idx)),rep('red',length(which.idx2))),hl.col.alpha=c(rep(0.4,length(which.idx)),rep(0.4,,length(which.idx2))),
		                    	hlt.row.exist=F,hl.row.which=c(5),hl.row.fill=c('red'),hl.row.alpha=c(0.4)
                )
ggTableDrawer(debug.spec)
#######################################################################################################

l
za

Smaug the dragon appears to love his chopsticks. Can’t blame him for that.

 

Implementation 2 : Neither Rows or Columns
l

#######################################################################################################
# Example 2
#######################################################################################################
debug.spec <- ggTableSpec(columns.exist=F,columns.txt=colnames(debug.df),columns.font=rep('bold',5),columns.col='black',columns.fill='grey',columns.alpha=0.7,
		                      rows.exist=F,rows.txt=rownames(debug.df),rows.font=rep('bold',20),rows.col='black',rows.fill='grey',rows.alpha=0.7,
		                      data.obj=debug.df,data.col='black',data.title='The hunger games',
		                    	hlt.col.exist=T,hl.col.which=c(which.idx,which.idx2),hl.col.fill=c(rep('green',length(which.idx)),rep('red',length(which.idx2))),hl.col.alpha=c(rep(0.4,length(which.idx)),rep(0.4,,length(which.idx2))),
		                    	hlt.row.exist=F,hl.row.which=c(5),hl.row.fill=c('red'),hl.row.alpha=c(0.4)
                )
ggTableDrawer(debug.spec)
#######################################################################################################

l
zb

 

Implementation 3 : Highlight Columns instead
l

#######################################################################################################
# Example 3
#######################################################################################################
debug.spec <- ggTableSpec(columns.exist=T,columns.txt=colnames(debug.df),columns.font=rep('bold',5),columns.col='black',columns.fill='grey',columns.alpha=0.7,
		                      rows.exist=T,rows.txt=rownames(debug.df),rows.font=rep('bold',20),rows.col='black',rows.fill='grey',rows.alpha=0.7,
		                      data.obj=debug.df,data.col='black',data.title='The hunger games',
		                    	hlt.col.exist=F,hl.col.which=c(which.idx),hl.col.fill=c(rep('green',length(which.idx))),hl.col.alpha=c(rep(0.4,length(which.idx))),
		                    	hlt.row.exist=T,hl.row.which=c(1,2,3,4,5),hl.row.fill=c('red','blue','green','yellow','purple'),hl.row.alpha=rep(0.4,5)
                )
ggTableDrawer(debug.spec)
#######################################################################################################

l
zc

 

 

Implementation 4 : Highlight Row and Column
l

#######################################################################################################
# Example 4
#######################################################################################################
debug.spec <- ggTableSpec(columns.exist=T,columns.txt=colnames(debug.df),columns.font=rep('bold',5),columns.col='black',columns.fill='grey',columns.alpha=0.7,
		                      rows.exist=T,rows.txt=rownames(debug.df),rows.font=rep('bold',20),rows.col='black',rows.fill='grey',rows.alpha=0.7,
		                      data.obj=debug.df,data.col='black',data.title='The hunger games',
		                    	hlt.col.exist=T,hl.col.which=c(which.idx),hl.col.fill=rep('green',length(which.idx)),hl.col.alpha=c(rep(0.4,length(which.idx))),
		                    	hlt.row.exist=T,hl.row.which=c(5),hl.row.fill=c('red'),hl.row.alpha=c(0.4)
                )
ggTableDrawer(debug.spec)
#######################################################################################################

l
zd

 

So far the table drawer works fine for medium sized data frames. The following pdf file contains further implementations :

ze

 

 

By and large it seems to work fine. Good enough for a quick table here and there.

Advertisements

The previous post ended with the creation of a matrix that contains an unlisted version of the selection criteria for each fund & model combination. From this object let’s create three data frames which we then manipulate and use as data inputs to the ggplot function.

[6] Make a facet plot of Selection Criteria across non-problematic funds

Here we simply make a dodged barchart plot for both AIC and SBC criteria across the 9 remaining non-problematic funds.

#ggplot across all funds
df.1 <- data.frame(Fund=rep(subfund.names,n.models),AIC=as.numeric(temp[,1]),SBC=as.numeric(temp[,2]),Model=temp[,5],stringsAsFactors=T)
df.1<-gather(df.1,Selection.Criteria,values,-c(Fund,Model))
miny <- min(df.1[,'values'])
maxy <- max(df.1[,'values'])

all.plot <- ggplot(data = df.1)+
	 						geom_bar(aes(x=Model,y=values,fill=Selection.Criteria),stat = "identity",position='dodge')+
	 						scale_fill_brewer(palette='Set1')+
	 						theme(axis.text.x = element_text(angle=90, hjust=1),legend.position='bottom',legend.key.size=unit(0.2, "cm"),legend.key.width=unit(2,'cm'),legend.direction='horizontal')+
	 						labs(title='Comparison of Selection Information for Lognormal, Autoregressive, \nand Regime Switching Models across Funds')+
	 						facet_wrap(~Fund,shrink=T)+
	 						coord_cartesian(ylim=c(miny,maxy+1))

l
nnnn

Interpretation of the selection criteria is straightforward : the higher the value the better the model. Although model differences are not very significant within each fund,the values for the selection criteria do show some variation across funds (thankfully). Models seem to do particularly well for the Equity.Market.Neutral and Fixed.Income.Arbitrage cases.

To gain a better view of how individual models performed,let’s take a look at the results for a particular fund & selection criterion combination.

[7] Snap plot function for the chosen fund and selection criterion

The FundSnap() function provides [1] a dodged barchart plot of models ranked according to the selected criterion (AIC,SBC) in descending order as well as [2]  a tabulation of numeric values (Likelihood,degree of freedom,AIC,SBC) with maximum/minimum values highlighted.

########################################################################################
# Fund snap across models
########################################################################################

FundSnap <- function(fund,df.obj,order.by){

	e<-environment()

	tbl.df <- df.obj%>%
		        filter(Fund==fund)%>%
		        select(Model,DF,Likelihood,AIC,SBC)

  temp.sel <- paste('df.obj$',order.by,sep='')

	plot.df <- df.obj%>%
		         arrange(desc(eval(parse(text=temp.sel))))%>%
		         filter(Fund==fund)%>%
		         select(c(Fund,Model,eval(parse(text=order.by))))

#plot
	miny<-min(plot.df[,3])
	maxy <-max(plot.df[,3])

	snap.plot <- ggplot(data = plot.df,environment=e)+theme_tufte()+
	 					 			geom_bar(aes(x=reorder(Model,desc(eval(parse(text=order.by)))),y=eval(parse(text=order.by)),fill=(eval(parse(text=order.by)))),stat = "identity",position='dodge',alpha=0.4)+
	 	              scale_fill_continuous(low="lightgreen", high="darkgreen")+
		              coord_cartesian(ylim=c(miny-1,maxy+1))+
		              theme(legend.position='none',legend.key.size=unit(0.2, "cm"),legend.key.width=unit(2,'cm'),legend.direction='horizontal',axis.text.x = element_text(angle=90, hjust=1),panel.grid.major = element_blank(), panel.grid.minor = element_blank())+
		              labs(title=paste('Snapshot for : ',fund,' & ',order.by,'\nacross models',sep=''))+
		              xlab('Models')+
		              ylab('Values')

#table
	tbl.df$Model <- as.character(tbl.df$Model)
	tbl.df$Likelihood <- round(tbl.df$Likelihood,2)
	tbl.df$AIC <- round(tbl.df$AIC,2)
	tbl.df$SBC <- round(tbl.df$SBC,2)

	parse.str <- paste('tbl.df$',order.by,sep='')
  row.max.idx <- which(eval(parse(text=parse.str))==max(eval(parse(text=parse.str))))
  row.min.idx <- which(eval(parse(text=parse.str))==min(eval(parse(text=parse.str))))

	debug.spec <- ggTableSpec(columns.exist=T,columns.txt=colnames(tbl.df),columns.font=rep('bold',ncol(tbl.df)),columns.col='blue',columns.fill='grey',columns.alpha=0.7,
		                      rows.exist=F,rows.txt=paste('row',1:10,sep=''),rows.font=rep('bold',10),rows.col='green',rows.fill='grey',rows.alpha=0.7,
		                      data.obj=tbl.df,
		                    	hlt.col.exist=T,hl.col.which=c(row.min.idx,row.max.idx),hl.col.fill=c('lightgreen','darkgreen'),hl.col.alpha=c(0.4,0.4),
		                    	hlt.row.exist=F,hl.row.which=row.idx,hl.row.fill='skyblue',hl.row.alpha=0.45
                )
  tbl.plot <- ggTableDrawer(debug.spec)

	layOut(
		     list(snap.plot,1,1),
		     list(tbl.plot,2,1)
	)
}
########################################################################################

ll

Implementation is simple once we have the proper data frame in place:

#ggplot for specific funds
df.2 <- data.frame(Fund=rep(subfund.names,n.models),DF=as.numeric(temp[,3]),Likelihood=as.numeric(temp[,4]),AIC=as.numeric(temp[,1]),SBC=as.numeric(temp[,2]),Model=temp[,5],stringsAsFactors=T)
FundSnap(fund='Emerging.Markets',df.obj=df.2,order.by='SBC')

l
hhhh

Above shows the case of the Emerging.Markets & SBC combination.The AR.GARCH model provides the maximal SBC value while the ILN.Reg3 model is least useful here.

[8] Percentage of funds for which a model has maximal AIC

The final plot is a bar chart plot with text annotations showing how often a particular model is the best performer across the remaining non problematic funds.

#Percentages
df.3 <- data.frame(Fund=rep(subfund.names,n.models),AIC=as.numeric(temp[,1]),Model=temp[,5],stringsAsFactors=T)
df.3 <- spread(df.3,Model,AIC)

col.idx <- apply(df.3,1,function(x) which(x==max(x[-1]),arr.ind=TRUE))
col.names <- colnames(df.3)[col.idx]

df.percentages <- df.3%>%
										mutate(Best.Model=col.names)%>%
                    group_by(Best.Model)%>%
                    summarise(count=n()/length(df.3)*100)

perc.plot <- ggplot(data = df.percentages)+
	 							geom_bar(aes(x=Best.Model,y=count,fill=Best.Model),stat = "identity",position='dodge')+
	 							scale_fill_brewer(palette='Set1')+
	 							theme(axis.text.x = element_blank(),legend.position='bottom',legend.key.size=unit(0.2, "cm"),legend.key.width=unit(2,'cm'),legend.direction='horizontal')+
	 							labs(title='Best performing models')+
                geom_text(aes(x=Best.Model,y=count/2,label=paste(round(count,2),'%',sep=''),fontface=rep('bold',4)),size=rel(4))+
	 							xlab('')+
	 							ylab('Percentage')

ll

gh

It appears that the AR.GARCH and ILN.Reg3 models provide the highest AIC values a third of the time.The simplest model,the independent log normal model fares relatively badly in comparison. Complicated models do seem to work better in our data.

Continuing with the list of tasks defined in the previous post, let’s load the edhec data set,fit each of the nine models to each of the funds and store results in a nested list object :

[4] Load data and store results

For each model and fund combination, I store the following information :

  1. The Log-Likelihood value
  2. The Degree of freedom
  3. The AIC criterion
  4. The SBC criterion

The code follows :

########################################################################################
# Load dataset
########################################################################################

orig.csv <- read.csv('edhecfinal.csv',header=T,stringsAsFactors=F)
edhec.xts <- xts(order.by=seq(as.Date('1997-01-31'),as.Date('2014-07-31'),by='1 month'),orig.csv[,-1])
edhec.xts <- log(edhec.xts+1)

########################################################################################
# Nested Lists and Regression results
########################################################################################

n.funds <- ncol(edhec.xts)
fund.names <- names(edhec.xts)
n.obs <- nrow(edhec.xts)

n.models <- 9

edhec.ret <- list()
	for(i in 1:n.funds){
		edhec.ret[[i]] <- list()
		names(edhec.ret)[i] <- fund.names[i]
		edhec.ret[[i]]$Ret.xts <- edhec.xts[,i]
    logret <- Return.clean(edhec.ret[[i]]$Ret.xts,method='boudt')

			#Independent Log-normal model
			edhec.ret[[i]]$ILN <- lm(logret~1)
		  edhec.ret[[i]]$ILN$Stat <- StatComp(edhec.ret[[i]]$ILN,n.obs)

		  edhec.ret[[i]]$ILN$LogLik <- edhec.ret[[i]]$ILN$Stat['model.loglik']
		  edhec.ret[[i]]$ILN$df <- edhec.ret[[i]]$ILN$Stat['model.df']
		  edhec.ret[[i]]$ILN$AIC <- edhec.ret[[i]]$ILN$Stat['model.aic']
		  edhec.ret[[i]]$ILN$SBC <- edhec.ret[[i]]$ILN$Stat['model.sbc']

		  #Autoregressive model
		  edhec.ret[[i]]$AR1 <- arima(x=logret,order=c(1,0,0))
		  edhec.ret[[i]]$AR1$Stat <- StatComp(edhec.ret[[i]]$AR1,n.obs)

		  edhec.ret[[i]]$AR1$LogLik <- edhec.ret[[i]]$AR1$Stat['model.loglik']
		  edhec.ret[[i]]$AR1$df <- edhec.ret[[i]]$AR1$Stat['model.df']
		  edhec.ret[[i]]$AR1$AIC <- edhec.ret[[i]]$AR1$Stat['model.aic']
		  edhec.ret[[i]]$AR1$SBC <- edhec.ret[[i]]$AR1$Stat['model.sbc']

		  #ARCH model
			arch.spec <- ugarchspec(variance.model=list(garchOrder=c(1,0)),mean.model = list(armaOrder=c(0,0)))
		  arch.fit<- ugarchfit(spec=arch.spec, data=logret,solver.control=list(trace = 1))

		  edhec.ret[[i]]$ARCH$LogLik <- likelihood(arch.fit)
		  edhec.ret[[i]]$ARCH$df <- 3
		  edhec.ret[[i]]$ARCH$AIC <- edhec.ret[[i]]$ARCH$LogLik-edhec.ret[[i]]$ARCH$df
		  edhec.ret[[i]]$ARCH$SBC <- edhec.ret[[i]]$ARCH$LogLik-0.5*edhec.ret[[i]]$ARCH$df*log(n.obs)

	    #AR-ARCH model
			arch.spec <- ugarchspec(variance.model=list(garchOrder=c(1,0)),mean.model = list(armaOrder=c(1,0)))
		  arch.fit<- ugarchfit(spec=arch.spec, data=logret,solver.control=list(trace = 1))

		  edhec.ret[[i]]$AR.ARCH$LogLik <- likelihood(arch.fit)
		  edhec.ret[[i]]$AR.ARCH$df <- 4
		  edhec.ret[[i]]$AR.ARCH$AIC <- edhec.ret[[i]]$AR.ARCH$LogLik-edhec.ret[[i]]$AR.ARCH$df
		  edhec.ret[[i]]$AR.ARCH$SBC <- edhec.ret[[i]]$AR.ARCH$LogLik-0.5*edhec.ret[[i]]$AR.ARCH$df*log(n.obs)

	    #GARCH model
			garch.spec <- ugarchspec(variance.model=list(garchOrder=c(1,1)),mean.model = list(armaOrder=c(0,0)))
		  garch.fit<- ugarchfit(spec=garch.spec, data=logret,solver.control=list(trace = 1))

		  edhec.ret[[i]]$GARCH$LogLik <- likelihood(garch.fit)
		  edhec.ret[[i]]$GARCH$df <- 4
		  edhec.ret[[i]]$GARCH$AIC <- edhec.ret[[i]]$GARCH$LogLik-edhec.ret[[i]]$GARCH$df
		  edhec.ret[[i]]$GARCH$SBC <- edhec.ret[[i]]$GARCH$LogLik-0.5*edhec.ret[[i]]$GARCH$df*log(n.obs)

		  #AR-GARCH model
			garch.spec <- ugarchspec(variance.model=list(garchOrder=c(1,1)),mean.model = list(armaOrder=c(1,0)))
		  garch.fit<- ugarchfit(spec=garch.spec, data=logret,solver.control=list(trace = 1))

		  edhec.ret[[i]]$AR.GARCH$LogLik <- likelihood(garch.fit)
		  edhec.ret[[i]]$AR.GARCH$df <- 5
		  edhec.ret[[i]]$AR.GARCH$AIC <- edhec.ret[[i]]$AR.GARCH$LogLik-edhec.ret[[i]]$AR.GARCH$df
		  edhec.ret[[i]]$AR.GARCH$SBC <- edhec.ret[[i]]$AR.GARCH$LogLik-0.5*edhec.ret[[i]]$AR.GARCH$df*log(n.obs)

		  #ILN 2 regimes
		  model.spec <- depmix(eval(parse(text=fund.names[i]))~1,nstates=2,data=logret)
	    model.fit <- fit(model.spec)
		  edhec.ret[[i]]$ILN.Reg2$Stat <- StatComp(model.fit,n.obs)

      edhec.ret[[i]]$ILN.Reg2$LogLik <- edhec.ret[[i]]$ILN.Reg2$Stat['model.loglik']
		  edhec.ret[[i]]$ILN.Reg2$df <- edhec.ret[[i]]$ILN.Reg2$Stat['model.df']
		  edhec.ret[[i]]$ILN.Reg2$AIC <- edhec.ret[[i]]$ILN.Reg2$Stat['model.aic']
		  edhec.ret[[i]]$ILN.Reg2$SBC <- edhec.ret[[i]]$ILN.Reg2$Stat['model.sbc']

	    #ILN 3 regimes
		  model.spec <- depmix(eval(parse(text=fund.names[i]))~1,nstates=3,data=logret)
	    model.fit <- fit(model.spec)
	  	edhec.ret[[i]]$ILN.Reg3$Stat <- StatComp(model.fit,n.obs)

      edhec.ret[[i]]$ILN.Reg3$LogLik <- edhec.ret[[i]]$ILN.Reg3$Stat['model.loglik']
		  edhec.ret[[i]]$ILN.Reg3$df <- edhec.ret[[i]]$ILN.Reg3$Stat['model.df']
		  edhec.ret[[i]]$ILN.Reg3$AIC <- edhec.ret[[i]]$ILN.Reg3$Stat['model.aic']
		  edhec.ret[[i]]$ILN.Reg3$SBC <- edhec.ret[[i]]$ILN.Reg3$Stat['model.sbc']

      #AR-Regime switch model
		  temp.df <- data.frame(logret[2:n.obs],logret[2:n.obs-1])
		  names(temp.df) <- c('left','right')

		  model.spec <- depmix(left~right,nstates=2,data=temp.df)
	    model.fit <- fit(model.spec)

			edhec.ret[[i]]$AR.Reg2$Stat <- StatComp(model.fit,n.obs)

      edhec.ret[[i]]$AR.Reg2$LogLik <- edhec.ret[[i]]$AR.Reg2$Stat['model.loglik']
		  edhec.ret[[i]]$AR.Reg2$df <- edhec.ret[[i]]$AR.Reg2$Stat['model.df']
		  edhec.ret[[i]]$AR.Reg2$AIC <- edhec.ret[[i]]$AR.Reg2$Stat['model.aic']
		  edhec.ret[[i]]$AR.Reg2$SBC <- edhec.ret[[i]]$AR.Reg2$Stat['model.sbc']

	}

l
To give an idea of the output,consider the case of CTA.Global fund and the Autoregressive-Regime switching model :

ff

 

The StatComp() function used to calculate these values is simply :

########################################################################################
# Calculating Stats for Comparison across models
########################################################################################

StatComp <- function(fitted.model,n.obs){
	    model.df <- attr(logLik(fitted.model),which='df')
			model.loglik <- as.numeric(logLik(fitted.model))
		  model.aic <- model.loglik-model.df
		  model.sbc <- model.loglik-0.5*model.df*log(n.obs)

	return(c(model.df=model.df,model.loglik=model.loglik,model.aic=model.aic,model.sbc=model.sbc))
}

ll
Once we have fitted each of the nine models to the data for each of the 13 funds in the edhec dataset,let’s summarise this information in a new list object by saving across models.

 

[5] Saving across models and making data ggplot friendly

The purpose of this step in the process is to summarise the data contained in the edhec.ret list object above into something that can be conveniently used in ggplot functions. Problematic funds are subsequently identified and deleted.

# Saving across models & removing problematic funds
model.names <- names(edhec.ret[[1]])[-1]
model.list <- list()
problems <- NULL

for(i in 1:n.models){
	model.list[[i]] <- list()
	names(model.list)[i] <- model.names[i]
	model.list[[i]] <- do.call(rbind,lapply(edhec.ret,function(x) eval(parse(text=paste('x$',model.names[i],sep='')))))[,c('AIC','SBC','df','LogLik')]
  problems <- c(problems,which(is.na(model.list[[i]]==0) | model.list[[i]]<0))
  model.list[[i]] <- cbind(model.list[[i]],Model=rep(model.names[i],n.funds))
}

problem.funds <- unique(problems)[-which(problems>13)][-5]
model.list<-lapply(model.list,function(x) x[-problem.funds,])
subfund.names <- rownames(model.list[[1]])

temp <- apply(do.call(rbind,model.list),2,unlist)

ll
By problematic funds, i mean those for which the following error messages occurred in the fitting process:

gff

 

For me the problematic funds are the ones corresponding to the following indices :

kli

 

Ultimately,our model.list object looks like this :

jjuk

 

This is the first element of the list. It continues this way for all other models listed in the previous post. The last line of code creates a matrix called temp which contains the unlisted version of the data contained in model.list. In the next post we will use this temp object to create three data frames, each of which we will manipulate using the tidyR package to produce the desired data structure for ggplotting purposes.

In my attempt to replicate some of the methodologies of the Kritzman paper, I stumbled across an article by Hardy (2001) which I thought I might try to tinker with as well. To summarise :  the paper itself is concerned with the following issues [1] A comparison of the fit of Regime Switching Log Normal (RSLN) model with other conventional models in common use for the SP500 / TSE 300 indices ; [2] Derivation of the distribution function for the RSLN model ; [3] Derivation of the European option price using the RSLN model ; [4] Application of the model to calculate risk measures.

As usual I only replicate the most basic issues,in this case a comparison of the fit across a host of models on the basis of the edhec data series from previous blog entries (as opposed to the broad market indices used in the paper).

To make this write up easier on me, this and subsequent posts shall deal with the following tasks :

  1. Provide a summary of the models examined by the paper.
  2. Provide a summary of the selection criteria (used to rank fitted results across models within and across fund returns).
  3. Attempt to make a custom ggplot table maker function to simplify text plotting.
  4. Load the edhec data set and store model results in a nested list object such that :
    • We fit 9 models to each of the 13 funds in the data set.
    • We store the estimated parameters and calculate values for chosen selection criteria for each model & fund combination.
    • We can access ILN model in fund CTA.Global by : Nested_List$CTA.Global$ILN.
  5. Save across models & remove problematic funds (funds that had strange values in the fitting process)  such that :
    •  We have a list object of 9 elements :
      • with each element being named after one of the 9 models.
      • with each element containing a data frame of non problematic funds and their selection criteria, formatted in a ggplot friendly way.
  6. Make a facet plot of Selection Criteria across non-problematic funds of the edhec dataset.
  7. Make a snap plot function for the chosen fund and selection criteria such that :
    • We provide a ranking of models for the particular fund and selection criteria combination in tabular as well as graphic form.
  8. Make a plot showing how often each model is the best performer across non-problematic funds.

 

[1] Summary of the models used

(1) The Independent Log Normal Model (ILN)

s1

(2) The First-order autoregressive model (AR1)

s2

(3) The autoregressive conditionally heteroskedastic model (ARCH1)

s3

(4) Combination of AR and ARCH model (AR.ARCH)

s4

(5) The generalized autoregressive conditionally heteroskedastic model (GARCH)

s5

(6) Combination of AR and GARCH model (AR.GARCH)

s7

(7) Regime Switching AR(1) model (AR.Reg2)

s8

(8) Regime Switching ILN model with 2 regimes (ILN.Reg2)

(9) Regime Switching ILN model with 3 regimes (ILN.Reg3)

 

[2] Summary of the Selection Criteria used

While the paper uses the (1) Likelihood ratio test, (2) Akaike Information Criterion and (3) Schwartz Bayes Criterion, I only used the the last two. The AIC uses the model that maximises the difference between the likelihood and the degree of freedom. The SBC uses the model that maximises the following :

lm

where I is the likelihood ; k the degree of freedom ; n the sample size ; j represents the model.

 

[3] Custom ggplot Table Maker

Since it is often useful to be able to plot tabular data on the fly,I have written a simple function for this purpose which allows one to specify typical elements of a basic table :

  • Is there a column and/or row?
  • What is the column title and/or row title?
  • What is the font for these titles?
  • What is the colour of the background of those titles?
  • What is the alpha value?
  • Is there a highlight for the column and/or row?
  • Which column and/or row should be highlighted?
  • What are the colours and alpha values for each highlight?

Mine is of course a fairly naive implementation,hardcoding certain coordinate adjustments instead of dynamically scaling them somehow (don’t know how) and only useful when there are not too many/little rows and columns. In any case,usage is fairly simple :

  1. Specify elements using the ggTableSpec function.
  2. Draw table using the ggTableDrawer function.

l

Example 1 : No highlighting whatsoever

l

  smpl.data <- data.frame(Col1=round(runif(20),3),Col2=round(runif(20),3),Col3=round(runif(20),3),Col4=round(runif(20),3),Col5=round(runif(20),3))
  rownames(smpl.data) <- paste('Row',1:20,sep='')

	smpl.spec <- ggTableSpec(columns.exist=T,columns.txt=colnames(smpl.data),columns.font=rep('bold',ncol(smpl.data)),columns.col='blue',columns.fill='grey',columns.alpha=0.7,
		                      rows.exist=T,rows.txt=rownames(smpl.data),rows.font=rep('bold',10),rows.col='green',rows.fill='blue',rows.alpha=0.7,
		                      data.obj=smpl.data,
		                    	hlt.col.exist=F,hl.col.which=c(1,5,20),hl.col.fill=c('lightgreen','darkgreen','red'),hl.col.alpha=c(0.4,0.4,0.4),
		                    	hlt.row.exist=F,hl.row.which=c(1,2,5),hl.row.fill=c('skyblue','red','yellow'),hl.row.alpha=c(0.4,0.4,0.4)
                )
  ggTableDrawer(smpl.spec)

a1

 

Example 2 : Column Highlighting
l

  smpl.data <- data.frame(Col1=round(runif(20),3),Col2=round(runif(20),3),Col3=round(runif(20),3),Col4=round(runif(20),3),Col5=round(runif(20),3))
  rownames(smpl.data) <- paste('Row',1:20,sep='')

	smpl.spec <- ggTableSpec(columns.exist=T,columns.txt=colnames(smpl.data),columns.font=rep('bold',ncol(smpl.data)),columns.col='blue',columns.fill='grey',columns.alpha=0.7,
		                      rows.exist=T,rows.txt=rownames(smpl.data),rows.font=rep('bold',10),rows.col='green',rows.fill='blue',rows.alpha=0.7,
		                      data.obj=smpl.data,
		                    	hlt.col.exist=F,hl.col.which=c(1,5,20),hl.col.fill=c('lightgreen','darkgreen','red'),hl.col.alpha=c(0.4,0.4,0.4),
		                    	hlt.row.exist=T,hl.row.which=c(1,2,5),hl.row.fill=c('skyblue','red','yellow'),hl.row.alpha=c(0.4,0.4,0.4)
                )
  ggTableDrawer(smpl.spec)

a2

Some alignment issues for the last column there.

 

Example 3 : Row Highlighting
l

  smpl.data <- data.frame(Col1=round(runif(20),3),Col2=round(runif(20),3),Col3=round(runif(20),3),Col4=round(runif(20),3),Col5=round(runif(20),3))
  rownames(smpl.data) <- paste('Row',1:20,sep='')

	smpl.spec <- ggTableSpec(columns.exist=T,columns.txt=colnames(smpl.data),columns.font=rep('bold',ncol(smpl.data)),columns.col='blue',columns.fill='grey',columns.alpha=0.7,
		                      rows.exist=T,rows.txt=rownames(smpl.data),rows.font=rep('bold',10),rows.col='green',rows.fill='blue',rows.alpha=0.7,
		                      data.obj=smpl.data,
		                    	hlt.col.exist=T,hl.col.which=c(1,5,20),hl.col.fill=c('lightgreen','darkgreen','red'),hl.col.alpha=c(0.4,0.4,0.4),
		                    	hlt.row.exist=F,hl.row.which=c(1,2,5),hl.row.fill=c('skyblue','red','yellow'),hl.row.alpha=c(0.4,0.4,0.4)
                )
  ggTableDrawer(smpl.spec)

a3

Again some alignment problems at the top and bottom. Maybe I will correct these issues later,for the time being I do not care. My suspicion is that the extreme coordinates for the column and row title panels are -/+ Inf whereas the coordinates for the highlights are not,hence their alignment should not be expected. Changing the Inf values to concrete ones should do the trick (maybe).

 

Example 4 : Row and Column Highlighting
l

 smpl.data <- data.frame(Col1=round(runif(20),3),Col2=round(runif(20),3),Col3=round(runif(20),3),Col4=round(runif(20),3),Col5=round(runif(20),3))
  rownames(smpl.data) <- paste('Row',1:20,sep='')

	smpl.spec <- ggTableSpec(columns.exist=T,columns.txt=colnames(smpl.data),columns.font=rep('bold',ncol(smpl.data)),columns.col='blue',columns.fill='grey',columns.alpha=0.7,
		                      rows.exist=T,rows.txt=rownames(smpl.data),rows.font=rep('bold',10),rows.col='green',rows.fill='blue',rows.alpha=0.7,
		                      data.obj=smpl.data,
		                    	hlt.col.exist=T,hl.col.which=c(1,5,20),hl.col.fill=c('lightgreen','darkgreen','red'),hl.col.alpha=c(0.4,0.4,0.4),
		                    	hlt.row.exist=T,hl.row.which=c(1,2,5),hl.row.fill=c('skyblue','red','yellow'),hl.row.alpha=c(0.4,0.4,0.4)
                )
  ggTableDrawer(smpl.spec)

l
a5Again same issues as above.Do not really see when i would want to highlight so many rows and columns anyways.

 

Example 5 : Problem

As an example of a problem consider the case where columns and rows do not exist but highlight do :
l

	smpl.spec <- ggTableSpec(columns.exist=F,columns.txt=colnames(smpl.data),columns.font=rep('bold',ncol(smpl.data)),columns.col='blue',columns.fill='grey',columns.alpha=0.7,
		                      rows.exist=F,rows.txt=rownames(smpl.data),rows.font=rep('bold',10),rows.col='green',rows.fill='blue',rows.alpha=0.7,
		                      data.obj=smpl.data,
		                    	hlt.col.exist=T,hl.col.which=c(1,5,20),hl.col.fill=c('lightgreen','darkgreen','red'),hl.col.alpha=c(0.4,0.4,0.4),
		                    	hlt.row.exist=T,hl.row.which=c(1,2,5),hl.row.fill=c('skyblue','red','yellow'),hl.row.alpha=c(0.4,0.4,0.4)
                )
  ggTableDrawer(smpl.spec)

l
dd

Clearly there are many issues that still need to be cleared up,but for the purposes of replicating the basic results of the paper I will leave the functions as they are for now. Instead of having me fumble around, I wish that the ggplot2 package creator would add table plotting functions to his package !

The final task we have set ourselves, and which also happens to be a welcome initiation to the excellent ggplot2 package for me, is concerned with summarising the previously saved plots and tables into a single (and hopefully useful) dashboard. I have attempted to reduce clutter as much as possible by omitting axis ticks,values and legends in those cases where interpretation is forthcoming. After exhausting the template themes available from the ggthemes package, I have settled on the economist theme for all the plots in the dashboard,finding it to be the most pleasing on the eyes. The function that collects and arranges all the outputs from previous steps is the custom DashboardPlot() function which accepts as arguments the following :[1] List object of dashboard elements,[2]Fund name of choice ,[3] Regime name of choice.
l

#[7.3.3] Dashboard
dashboard.list <- list(FundRet.list=edhec.ret,
	                     Turbulence.plot=Turbulence.plot,
	                     Turbulence1.tbl=Turbulence1.tbl,
	                     Turbulence2.tbl=Turbulence2.tbl,
	                     plot.list=plot.list,
	                     CompareCumu=CompareCumu,
	                     FacetPlot=FacetPlot.list,
	                     FacetObj=Facet.obj,
	                     MarkovPlots=MarkovEstPlots)

#Dashboard for Global Macro fund in Inflation regime
# DashboardPlot(Inputs=dashboard.list,
# 	            Fund='Global.Macro',
# 	            Regime='Inflation')

#Dashboard for all regimes/fund combinations
for(i in fund.names){
	for(j in regimes.names){
		DashboardPlot(Inputs=dashboard.list,
			            Fund=i,
		              Regime=j
		)
	}
}
########################################################################################

l
This results in n.funds(13)*n.regimes(4)= 52 pdf files, each representing a unique combination of a particular fund and a particular regime.

I have uploaded the pdf files into wordpress and they should be available for viewing by clicking on the links in the following table :

l

Funds | Regimes Equity Currency Inflation Growth
Convertible Arbitrage C&EQ C&FX C&Inf C&G
CTA Global CTA&EQ CTA&FX CTA&Inf CTA.&G
Distressed Securities D&EQ D&FX D&Inf D&G
Emerging Markets Em&EQ Em&FX Em&Inf Em&G
Equity Market Neutral Eq&EQ Eq&FX Eq&Inf Eq&G
Event Driven Ev&EQ Ev&FX Ev&Inf Ev&G
Fixed Income Arbitrage Fix&EQ Fix&FX Fix&Inf Fix&G
Funds of Funds Fun&EQ Fun&FX Fun&Inf Fun&G
Global Macro Glo&EQ Glo&FX Glo&Inf Glo&G
Long Short Equity Lon&EQ Lon&FX Lon&Inf Lon&G
Merger Arbitrage Me&EQ Me&FX Me&Inf Me&G
Relative Value Rel&EQ Rel&FX Rel&Inf Rel&G
Short Selling Sh&EQ Sh&FX Sh&Inf Sh&G

l

This html table was generated using The Tables Generator with Compact mode ticked and Do not Generate CSS unticked.

To give an example of the information contained in a dashboard,consider the case of  Global Macro x Inflation and relevant points of interest below :

l

mkl

l

Points of interest :

[Barcharts & Table of estimates in top rows]

  1. The Inflation economic regime variable begins in the normal state,with a high probability of remaining in this state (Persistence : 90.1%) and a low probability of transitioning to the event state (Transition : 9.9%).The estimated mean and sigma for this normal state are 0.2559 and 0.275 respectively.
  2. The Event state for all regime variable is characterised by higher estimated sigmas and means than corresponding values for the normal state.
  3. The persistence of normal states across all economic regime variables is higher than that that of event states. The corollary is found in transition estimates where we are more likely to transition from the event state to the normal state than from the normal state to the event state for all regime variables.
  4. The dodged barchart in the final column seeks to answer the question : What is the average return for fund x when regime y is in state a or state b? For our example, the mean return to the Global Macro strategy when the inflation regime is in the normal state exceeds the corresponding value in the event state.

 

[Selection & Performance plots in bottom rows]

  1. The list of funds and regime variables are given as strips of text in two separate ggplots with a green rectangle beneath the chosen fund and a red rectangle beneath the chosen regime. They are here mainly for eye candy, filling in space and horsing around with the ggplot package!
  2. The monthly,cumulative returns and drawdowns are also drawn.It seems that that for the Global Macro x Inflation case,knowledge of Markov states does not translate to higher cumulative returns.The drawdowns however seem more favourable.
  3. We also have a time series plot of the chosen economic regime variable along with an overlay of event versus non-event states.The thin red bars signify moments in time where the regime variable is in the event state.The blue bars show when that variable is in its normal state.There are some strange discrepancies between the pdf file and this zoomed image above.The pdf file is a better option here even though the colour is strangely off depending on the zoom.Also there is some sort of white taper in the pdf version of this plot which is probably due to the jagged lines I mentioned in the previous post.
  4. The final barchart in the bottom right corner shows the scaled difference in means across states for the chosen regime variable. If I understood this correctly,this should answer the question : By how many standard deviations is a particular fund’s performance higher/lower during the event/normal regime? In our case,the Global Macro strategy performs worse in the event regime than the normal regime by -0.10 standard deviations (?) I suppose this corroborates the previous finding that the mean performance of the chosen fund,when seen in the context of the inflation regime variable,is superior in the normal state versus the event state.

Whether these results are consistent or my interpretations correct I do not know.Any mistakes are of course mine.Although the code for the function is a bit of a mess and for the most part just arranges the plots in the desired layout,I include it here for the sake of completeness :
l

#########################################################################################
# Dashboard
#########################################################################################

DashboardPlot <- function(Inputs,Fund,Regime){

#Set up data
	regime.map <- data.frame(regime=c('Equity','Currency','Inflation','Growth'),idx=c(1:4),stringsAsFactors=F)
	fund.names <- names(Inputs$FundRet.list)
  reg.names <- regime.map[,1]

#regime strip
  lbl.font <- c(rep('bold',4))
	reg.df<-data.frame(lab.x=rep(20,4),lab.y=seq(2,26,length=4),lab.txt=reg.names,lab.font=lbl.font,stringsAsFactors=F)
	empty.df <- data.frame(x=-2:26,y=-2:26)
	ymin <- filter(reg.df,lab.txt==Regime)$lab.y-2
	ymax<-ymin+diff(reg.df$lab.y)[1]-1.5
	rect.df <- data.frame(xmin=-4,xmax=28,ymin=ymin,ymax=ymax)

	gg.reg.list <-  ggplot(empty.df)+geom_blank()+theme_economist(base_size=5)+
                      theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank(),
   	 									panel.border = element_blank(), panel.background = element_blank(), axis.title.x = element_blank(),
    									axis.title.y = element_blank(), axis.text.x = element_blank(), axis.text.y = element_blank(),
    									axis.ticks = element_blank(),legend.position='none')+
                   		geom_rect(data=rect.df,aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax),fill='red',alpha=0.4)+
		                  geom_text(data=reg.df,aes(x=lab.x,y=(lab.y),label=lab.txt,fontface=lab.font,hjust=1,vjust=0),size=rel(3))

#fund strip
  lbl.font <- c(rep('bold',13))
	fund.df<-data.frame(lab.x=rep(20,13),lab.y=seq(0,26,length=13),lab.txt=fund.names,lbl.font=lbl.font,stringsAsFactors=F)
	empty.df <- data.frame(x=-2:26,y=-2:26)
	ymin <- filter(fund.df,lab.txt==Fund)$lab.y-0.5
	ymax<-ymin+diff(fund.df$lab.y)[1]-0.5
	rect.df <- data.frame(xmin=-4,xmax=28,ymin=ymin,ymax=ymax)
	gg.fund.list <-  ggplot(empty.df)+geom_blank()+theme_economist(base_size=5)+
                      theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank(),
   	 									panel.border = element_blank(), panel.background = element_blank(), axis.title.x = element_blank(),
    									axis.title.y = element_blank(), axis.text.x = element_blank(), axis.text.y = element_blank(),
    									axis.ticks = element_blank(),legend.position='none')+
                   		geom_rect(data=rect.df,aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax),fill='green',alpha=0.4)+
		                  geom_text(data=fund.df,aes(x=lab.x,y=(lab.y),label=lab.txt,fontface=lbl.font,hjust=1,vjust=0),size=rel(3))

#Data table
	reg.str <- paste(filter(regime.map,regime==Regime)[2],']]',sep='')
	tbl1 <- Inputs$Turbulence1.tbl
	tbl2 <- Inputs$Turbulence2.tbl
	initial.state <- tbl1[unlist(filter(regime.map,regime==Regime)[2]),1]

	mean.s1 <- round(tbl1[unlist(filter(regime.map,regime==Regime)[2]),4],3)
        mean.s2 <- round(tbl2[unlist(filter(regime.map,regime==Regime)[2]),4],3)
	mean.df <- data.frame(State=c('Normal','Event'),Mean=c(mean.s1,mean.s2),stringsAsFactors=F)

	sd.s1 <- round(tbl1[unlist(filter(regime.map,regime==Regime)[2]),5],3)
        sd.s2 <- round(tbl2[unlist(filter(regime.map,regime==Regime)[2]),5],3)
	sd.df <- data.frame(State=c('Normal','Event'),StDev=c(sd.s1,sd.s2),stringsAsFactors=F)

	#Check State and store fitted information
	if(initial.state=='State 1'){
		temp <-Inputs$Turbulence1.tbl
		state.type <-'Normal'
	}else{
		temp<-Inputs$Turbulence2.tbl
    state.type <- 'Event'
	}

	pers <- temp[unlist(filter(regime.map,regime==Regime)[2]),2]
	trans <- temp[unlist(filter(regime.map,regime==Regime)[2]),3]
	mean.f <- round(temp[unlist(filter(regime.map,regime==Regime)[2]),4],3)
	stddev <- round(temp[unlist(filter(regime.map,regime==Regime)[2]),5],3)

#Create Plots

	gg.ret.plot <- eval(parse(text=paste('Inputs$FundRet.list$',Fund,sep='')))
	gg.turb.plot <- eval(parse(text=paste('Inputs$Turbulence.plot[[',reg.str,sep='')))

	gg.turb.map1 <- eval(parse(text=paste('Inputs$Turbulence.map2[[',reg.str,'[[1]]',sep='')))
	gg.turb.map2 <- eval(parse(text=paste('Inputs$Turbulence.map2[[',reg.str,'[[2]]',sep='')))

	gg.avg.plot <- eval(parse(text=paste('Inputs$plot.list[[',reg.str,sep='')))
	gg.cumu.plot1 <- eval(parse(text=paste('Inputs$CompareCumu$',Fund,'[[',reg.str,'$plot[[1]]',sep='')))
	gg.cumu.plot2 <- eval(parse(text=paste('Inputs$CompareCumu$',Fund,'[[',reg.str,'$plot[[2]]',sep=''))) 

	gg.facet.plot <- eval(parse(text=paste('Inputs$FacetPlot$',Fund,sep='')))
	gg.mkv.mean <- Inputs$MarkovPlots[[1]]
	gg.mkv.sd <- Inputs$MarkovPlots[[3]]
	gg.mkv.p <- Inputs$MarkovPlots[[5]]
	gg.mkv.t <- Inputs$MarkovPlots[[6]]

#Dashboard table
	lab1 <- paste("~Fund   :  ",Fund,sep=' ')
	lab2 <- paste('~Regime   :  ',Regime,sep=' ')
        lab3 <- paste('       |__Initial State :  ',state.type,sep=' ')
        lab4 <- paste('       |__Persistence :  ',pers,sep=' ')
        lab5 <- paste('       |__Transition :  ',trans,sep=' ')
        lab6 <- paste('       |__Mean  :  ',mean.f,sep=' ')
        lab7 <- paste('       |__StDev  :  ',stddev,sep=' ')
        lbl.cols <- c('green','red','white','white','white','white','white')
        lbl.font <- c('bold','bold','bold','bold','bold','bold','bold')
        lbl.df <-data.frame(lab.x=rep(-2,7),lab.y=seq(-1,8,length=7),lab.txt=c(lab1,lab2,lab3,lab4,lab5,lab6,lab7),lbl.font=lbl.font,lbl.cols=lbl.cols,stringsAsFactors=F)

	empty.df <- data.frame(x=-2:12,y=-2:12)
	gg.empty.plot <-  ggplot(empty.df,aes(x=x,y=y))+geom_blank()+geom_hline(y=11,colour='white',size=1)+theme_tufte(base_size=5)+
                      theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank(),
   	 									panel.border = element_blank(), panel.background = element_blank(), axis.title.x = element_blank(),
    									axis.title.y = element_blank(), axis.text.x = element_blank(), axis.text.y = element_blank(),
    									axis.ticks = element_blank(),plot.title = element_text(size = rel(4),colour='white'),plot.background = element_rect(colour = "skyblue4", fill = "skyblue4"))+
		                  labs(title='\n.:: Dashboard ::.')+
		                  geom_text(data=lbl.df,aes(x=lab.x,y=rev(lab.y),label=lab.txt,hjust=0,vjust=1,fontface=lbl.font),size=rel(3),colour=lbl.cols)

	gg.empty2.plot <-  ggplot(empty.df,aes(x=x,y=y))+geom_blank()+theme_tufte(base_size=5)+
                      theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank(),
   	 									panel.border = element_blank(), panel.background = element_blank(), axis.title.x = element_blank(),
    									axis.title.y = element_blank(), axis.text.x = element_blank(), axis.text.y = element_blank(),
    									axis.ticks = element_blank(),plot.title = element_text(size = rel(4)),plot.background = element_rect(colour = "skyblue4", fill = "skyblue4"))

#Data table
  temptbl <- eval(parse(text=paste('Inputs$FacetObj$',Fund,'$df',sep='')))
	gg.tbl.plot <- QuickTbl(temptbl,title='Averaging Returns')

#Markov estimate tables
	gg.mkv.mean.tbl <- Inputs$MarkovPlots[[2]]
   	gg.mkv.sd.tbl <- Inputs$MarkovPlots[[4]]
	gg.mkv.p.tbl <- Inputs$MarkovPlots[[7]]
        gg.mkv.t.tbl <- Inputs$MarkovPlots[[8]]

#Arrange multiple plots and save as pdf
pdf(file = paste(Fund,'&',Regime,'.pdf',sep=''), width = 30, height = 17)
  layOut(
  	     list(gg.empty.plot,1:2,1),
  	     list(gg.empty2.plot,3:6,1),
  	     list(gg.reg.list,3,2),
  	     list(gg.fund.list,4:6,2),
   	  	 list(gg.mkv.mean,1,2),
  	     list(gg.mkv.sd,1,3),
  	     list(gg.mkv.p,1,4),
  	     list(gg.mkv.t,1,5),
  	  	 list(gg.facet.plot,1,6),
  	     list(gg.mkv.mean.tbl,2,2),
  	     list(gg.mkv.sd.tbl,2,3),
         list(gg.mkv.p.tbl,2,4),
  	     list(gg.mkv.t.tbl,2,5),
  	     list(gg.tbl.plot,2,6),
  	     list(gg.ret.plot,3:4,3:4),
  	     list(gg.cumu.plot1,5,3:4),
   	     list(gg.cumu.plot2,6,3:4),
  	     list(gg.avg.plot,5:6,5:6),
  	  	 list(gg.turb.plot,3:4,5:6)
   	)
dev.off()
}
#########################################################################################

l
Wish I could make this collapsable but wordpress seems to need a plugin for that.