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 :
- 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.
- 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) #######################################################################################################
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) #######################################################################################################
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) #######################################################################################################
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) #######################################################################################################
So far the table drawer works fine for medium sized data frames. The following pdf file contains further implementations :
By and large it seems to work fine. Good enough for a quick table here and there.