October 16, 2014
Asset Pricing, Experiments
Leave a comment

Tidbits & Reminders [1]

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

Leave a Reply

Fill in your details below or click an icon to log in:

Gravatar
WordPress.com Logo

You are commenting using your WordPress.com account. ( Log Out /  Change )

Google+ photo

You are commenting using your Google+ account. ( Log Out /  Change )

Twitter picture

You are commenting using your Twitter account. ( Log Out /  Change )

Facebook photo

You are commenting using your Facebook account. ( Log Out /  Change )

Cancel

Connecting to %s

%d bloggers like this: