R/groupedTickLabels.R

In mwrowe/microRutils: Mike Rowe's Miscellaneous R Utility Functions

#' Label Axes With Hierarchically Organized Groups
#' 
#' groupedTickLabels() labels and divides groups along the x- or y-axis.
#' 
#' This function is useful when the data along one axis is ordered by 
#' hierarchically related groups. The most general groups are labeled farthest
#' from the axis, and by default have larger labels and heavier lines between
#' them than more specific subgroups.
#' 
#' The user must provide sufficient margin space along the axis for the labels
#' via the par("mar") value for the side to be labelled.  A suggested value may
#' be generated by calling the function with plot.labels=FALSE.
#' 
#' Spacing required by the labels is determined primarily by the las and cex 
#' arguments, as well as gaps.  In general, you may have to play with the 
#' arguments a bit to make the labels look readable.
#'
#' @param groups
#'        A data.frame() of annotations that define groupings based on their
#'        values, orderd from most general to most specific.  The ordering of 
#'        the rows must correspond to the ordering of the items plotted along 
#'        the axis which will be labeled.
#' @param side
#'        Which axis to label-- see \code{\link[graphics]{axis}}.
#' @param lwd
#'        Vector of line widths for grid lines dividing groups, with each
#'        element corresponding a column in groups.  If NA or omitted, no line
#'        will be drawn for a given grouping.
#' @param col 
#'        Vector of colors for the lines between groupings.
#' @param cex
#'        Numeric vector specifying sizing of labels for each annotation in
#'        groups.  The last element will be reused for subsequent annotations.
#'        Labels will not be printed if cex is zero or NA for a given 
#'        annotation.
#' @param las
#'        A vector of integers in the range 0 to 2 indicating how the labels
#'        for each annotation in groups should be oriented.  If fewer elements
#'        are supplied than annotations (ncol(groups)), the remaining labels
#'        will be placed perpendicular to the axis.
#' @param at
#'        Numeric vector specifying centers along the axes, to be used when 
#'        spacing not uniform or separated values other than one.  By default,
#'        at will be set at 1:nrow(groups).
#' @param gaps
#'        Numeric vector, specifying gap to leave, specified as margin lines,
#'        between successive group labels; default is rep(0.5,ncol(groups)).
#'        The last value specifies the gap between the axis line and the group
#'        closest to the axis (i.e., the last group).
#' @param plot.labels
#'        Logical; if FALSE, do not add group labels to the plot, but
#'        return placement info and print suggested margin.
#' @param group.tix
#'        Logical; if TRUE, draw lines connecting tick marks within 
#'        each group, for each grouping variable.
#' @param meta.label
#'        Logical; should variable labels be plotted at the left edge
#'        or top?
#' 
#' @return
#'    Returns a list with elements named according to the columns of groups,
#'       with elements:
#'    \itemize{
#'      \item \strong{labels} Character vector with labels for the unique 
#'         groupings at this level of the hierarchy (column of groups).
#'      \item \strong{N} Numeric vector, same length as labels, with the 
#'         number of items (rows of groups) within this group. 
#'      \item \strong{mids} Numeric vector, same length as labels, with the 
#'         midpoints of each group, used to center labels along the axis.
#'      \item \strong{breaks} Numeric vector, length(labels)+1, with midpoints
#'        between successive groups (including before first and after last).
#'      \item \strong{outerLine}, {innerLine}: numeric values specifying 
#'        position of labels and grouping lines away from the axis
#'      \item \strong{group} Numeric vector, length equal to n.rows(groups),
#'        with the group number of each row of groups.  
#'      \item \strong{par} Vector of graphics parameters applied to this level 
#'        of the hierarchy, with names "line", "cex", "las", "adj", "padj".
#'    }
#'       
#' @seealso \code{\link[graphics]{par}} for more details about plotting 
#'   parameters lwd, col, cex and las.
#'   
#' @author M.W.Rowe, \email{mwr.stats@gmail.com}
#' @export
#' @import graphics
#' @importFrom utils data 
groupedTickLabels <- 
function(groups,side,lwd=1,col="black",cex=0.7,las=0,at,gaps,plot.labels=TRUE,
      group.tix=TRUE,meta.label=TRUE){
   n.levels <- ncol(groups)
   groups[is.na(groups)] <- ""
   irreg <- !missing(at)
   if(!irreg){
      at <- 1:nrow(groups)
   }
   if(length(col)<length(lwd)){
      col[(length(col)+1):n.levels] <- col[length(col)]
   }
   if(length(cex)<n.levels){
      cex[(length(cex)+1):n.levels] <- cex[length(cex)]
   }
   cex[which(is.na(cex))] <- 0
   if(length(las)<n.levels) las[length(las)+1:n.levels] <- las[length(las)]
   las[which(side%in%c(1,3) & las==1)] <- 0
   las[which(side%in%c(2,4) & las==1)] <- 2
   las[which(side%in%c(1,3) & las==3)] <- 2
   las[which(side%in%c(2,4) & las==1)] <- 0
   if(missing(gaps)) gaps <- rep(0.5,n.levels)
   if(length(gaps)<n.levels) gaps[length(gaps)+1:n.levels] <- gaps[length(gaps)]
   gaps <- gaps[1:n.levels]
   groupSplits <- as.list(rep(NA,n.levels))
   # calculate margin lines at which to place each set of labels
   txtSpace <- rep(NA,n.levels)
   for(Gi in n.levels:1){
      if(is.factor(groups[,Gi])) groups[,Gi] <- as.character(groups[,Gi])
      # NOTE: I don't know why the 0.66 factor seems to be necessary
      txtSpace[Gi] <- ifelse(las[Gi]==0,cex[Gi],
         0.66*max(strwidth(groups[,Gi],cex=cex[Gi],units="inch")
               / strheight("M",cex=par("cex"),units="inch")))
   }
   lineOut <- rev(cumsum(rev(gaps))+cumsum(rev(txtSpace)))
   lineIn <- lineOut - txtSpace
   names(groupSplits) <- colnames(groups)
   for(Gi in n.levels:1){
      # treat the groupings as hierarchical when determining divisions
      hiergrp <- apply(groups[,1:Gi,drop=F],1,paste,collapse="|")
      breaks <- hiergrp[-1]!=hiergrp[-length(hiergrp)]
      group <- cumsum(c(1,as.numeric(breaks)))
      if(irreg){
         breaks <- apply(rbind(at[which(breaks)],at[which(breaks)+1]),2,mean)
      }else{
         breaks <- 0.5+c(0,which(breaks),nrow(groups))
      }
      breaks <- unname(breaks)
      mids <- tapply(at,group,mean)
      N <- table(group)
      labels <- tapply(groups[,Gi],group,unique)
      groupSplits[[colnames(groups)[Gi]]] <- 
         list(labels=labels,N=N,mids=mids,breaks=breaks,
            outerLine=lineOut[Gi],innerLine=lineIn[Gi],group=group,
         par=c(line=lineIn[Gi],cex=cex[Gi],las=las[Gi],
            adj=ifelse(las[Gi]==0,0.5,1),padj=ifelse(las[Gi]==0,0,0.5)))
   }
   for(Gi in n.levels:1){
      if(missing(side)) next
      group <- groupSplits[[Gi]]$group
      breaks <- groupSplits[[Gi]]$breaks
      mids <- groupSplits[[Gi]]$mids
      labels <- groupSplits[[Gi]]$labels
      if(length(lwd)>=Gi){
         if(!is.na(lwd[Gi])){
            if(side%in%c(1,3)){
               abline(v=breaks,lwd=lwd[Gi],col=col[Gi])
            }else{
               abline(h=breaks,lwd=lwd[Gi],col=col[Gi])
            }
         }
      }
      if(cex[Gi]%in%c(0,NA)) next
      if(plot.labels){
         # label the individual groups 
         mtext(labels,side=side,line=lineIn[Gi],las=las[Gi],cex=cex[Gi],
            at=mids,adj=ifelse(las[Gi]==0,0.5,1),padj=ifelse(las[Gi]==0,0,0.5))
         if(group.tix){
            # add axis lines tying the groups together
            for(gndx in names(mids)){
               if(Gi==n.levels){
                  tix <- at[which(group==gndx)]
               }else{
                  grprng <- range(at[which(group==gndx)])
                  tix <- groupSplits[[Gi+1]]$mids
                  tix <- tix[which(tix>=grprng[[1]] & tix<=grprng[[2]])]
               }
               axis(side=side,at=tix,mgp=c(0,0,lineIn[Gi]-0.5*gaps[Gi]),
                  tcl=0.05,labels=FALSE)
            }
         }
         if(meta.label){
            # add a grouping label on the top or left edge
            if(side%in%c(1,3)){
               edge <- par("usr")[1] - 0.01*diff(par("usr")[1:2])
               mtext(paste0(colnames(groups)[Gi],": "),side=side,
                  line=lineIn[Gi],adj=1,padj=0,las=0,cex=cex[Gi],at=edge)
            }else{
               edge <- par("usr")[4] - 0.01*diff(par("usr")[4:3])
               mtext(paste0(" :",colnames(groups)[Gi]),side=side,
                  line=lineIn[Gi],adj=0,padj=0,las=0,cex=cex[Gi],at=edge)
            }
         }
      }
   }
   if(!plot.labels){
      cat("Side ",side," margin should be at least ",max(lineOut),".\n",sep="")
   }
   invisible(groupSplits)
}