R/aggregateColorPlot.R

In ncss-tech/sharpshootR: A Soil Survey Toolkit

#' @title Plot aggregate soil color data
#' 
#' @description Generate a plot from summaries generated by `aqp::aggregateColor()`.
#'
#' @param x a `list`, results from `aqp::aggregateColor()`
#' @param print.label logical, print Munsell color labels inside of rectangles, only if they fit 
#' @param label.font font specification for color labels
#' @param label.cex font size for color labels
#' @param label.orientation label orientation, `v` for vertical or `h` for horizontal
#' @param buffer.pct extra space between labels and color rectangles
#' @param print.n.hz optionally print the number of horizons below Munsell color labels
#' @param rect.border color for rectangle border
#' @param horizontal.borders optionally add horizontal borders between bands of color
#' @param horizontal.border.lwd line width for horizontal borders
#' @param x.axis logical, add a scale and label to x-axis?
#' @param y.axis logical, add group labels to y-axis?
#' @param ... additional arguments passed to `plot`
#'
#' @details Tutorial at \url{http://ncss-tech.github.io/AQP/sharpshootR/aggregate-soil-color.html}.
#' 
#' @author D.E. Beaudette
#'
#' @return nothing, function called for graphical output
#' @export
#' 
#' @keywords hplots
#'
#' @examples
#' 
#' \donttest{
#' 
#' if(require(aqp) &
#'    require(soilDB)) {
#'   
#'   data(loafercreek, package = 'soilDB')
#'   
#'   # generalize horizon names using REGEX rules
#'   n <- c('Oi', 'A', 'BA','Bt1','Bt2','Bt3','Cr','R')
#'   p <- c('O', '^A$|Ad|Ap|AB','BA$|Bw', 
#'          'Bt1$|^B$','^Bt$|^Bt2$','^Bt3|^Bt4|CBt$|BCt$|2Bt|2CB$|^C$','Cr','R')
#'   loafercreek$genhz <- generalize.hz(loafercreek$hzname, n, p)
#'   
#'   # remove non-matching generalized horizon names
#'   loafercreek$genhz[loafercreek$genhz == 'not-used'] <- NA
#'   loafercreek$genhz <- factor(loafercreek$genhz)
#'   
#'   # aggregate color data, this function is from the `aqp` package
#'   a <- aggregateColor(loafercreek, 'genhz')
#'   
#'   # plot
#'   op <- par(no.readonly = TRUE)
#'   
#'   par(mar=c(4,4,1,1))
#'   
#'   # vertical labels, the default
#'   aggregateColorPlot(a, print.n.hz = TRUE)
#'   
#'   # horizontal labels
#'   aggregateColorPlot(a, print.n.hz = TRUE, label.orientation = 'h')
#'   
#'   par(op)
#'   
#' }
#' 
#' }
aggregateColorPlot <- function(x, print.label=TRUE, label.font=1, label.cex=0.65, label.orientation = c('v', 'h'), buffer.pct=0.02, print.n.hz=FALSE, rect.border='black', horizontal.borders=FALSE, horizontal.border.lwd=2, x.axis=TRUE, y.axis=TRUE, ...) {
 
  # sanity check
  label.orientation <- match.arg(label.orientation)
  
  # extract just the scaled data from the results of aggregateColor()
  s.scaled <- x$scaled.data
  
  # get max re-scaled summation for xlim
  max.plot <- max(sapply(s.scaled, function(i) sum(i$weight)))
  
  # setup plot
  plot(1, 1, type = 'n', xlim = c(0, max.plot), ylim = c(length(names(s.scaled))+0.5, 0.5), axes = FALSE, ylab = '', xlab = 'Cumulative Proportion', col.main = par('fg'), col.lab = par('fg'), ...)
  
  # iterate over horizons
  for(i in seq_along(names(s.scaled))) {
    
    # current iteration
    s.i <- s.scaled[[i]]
    n.colors <- nrow(s.i)
    
    if(n.colors > 0) {
      # get an index to the last weight
      last.weight <- length(s.i$weight)
      # compute cumulative left / right rectangle boundaries
      x.left <- cumsum(c(0, s.i$weight[-last.weight]))
      x.right <- c(x.left[-1], x.left[last.weight] + s.i$weight[last.weight])
      
      # plot rectangles from vectorized coordinates / colors
      # first column in each chunk is the R color
      rect(xleft=x.left, ybottom=i-0.5, xright=x.right, ytop=i+0.5, col=s.i[, 1], border=rect.border)
      
      # compute center point for color labels
      centers <- (x.right + x.left) / 2
      
      # create label
      if(print.n.hz) {
        # with number of horizons
        color.labels <- paste0(s.i$munsell, '\n', '(', s.i$n.hz, ')')
      } else {
        # just colors
        color.labels <- s.i$munsell
      }
        
      
      # determine if there is enough room to label colors: some % of visible space on plot
      # first, get the plot aspect ratio
      plot.w <- par("pin")[1]/diff(par("usr")[1:2])
      plot.h <- par("pin")[2]/diff(par("usr")[3:4])
      plot.asp <- abs(plot.w / plot.h)
      
      # determine if label will fit within a reasonable buffer percentage
      if(label.orientation == 'v') {
        # vertical calculation
        
        # get text heights, as we will be printing labels at 90 deg
        text.heights <- abs(strheight(color.labels, cex = label.cex, font = label.font))
        # convert text heights into equivalent widths
        text.heights <- text.heights / plot.asp
        # compare re-scaled text heights with rectangle widths (weights) + some buffer
        label.fits <- which(text.heights < (s.i$weight - buffer.pct) )
        
      } else {
        # horizontal calculation
        
        # get text heights, as we will be printing labels at 90 deg
        text.widths <- abs(strwidth(color.labels, cex = label.cex, font = label.font))
        
        # compare re-scaled text widths with rectangle widths (weights) + some buffer
        label.fits <- which(text.widths < (s.i$weight - buffer.pct) )
      }
      
      
      # print labels
      if(print.label & (length(label.fits) > 0)) {
        
        # adjust label color based on background
        # from aqp
        label.col <- invertLabelColor(s.i[, 1])
        
        # adjust label angle based argument
        label.srt <- switch(label.orientation, v = 90, h = 0)
        
        text(
          x = centers[label.fits], 
          y = i, 
          labels = color.labels[label.fits], 
          col = label.col[label.fits], 
          font = label.font, 
          cex = label.cex, 
          srt = label.srt
        )
      }
        
    }
  }
  
  # add horizontal separator lines, typically used when rectange borders are not drawn
  if(horizontal.borders){
    hz.line.y <- 1:(length(names(s.scaled))-1) + 0.5
    segments(x0 = 0, y0 = hz.line.y, x1 = 1, y1 = hz.line.y, lwd=horizontal.border.lwd)
  }
  
  # label x-axis with a scale
  if(x.axis) {
    axis(1, at=round(seq(0, 1, length.out = 11), 2), col=par('fg'), col.axis=par('fg'))
  }
    
  
  # label x-axis with group names
  if(y.axis) {
    axis(2, at = seq_along(names(s.scaled)), labels = names(s.scaled), las=2, tick=FALSE, font=2, hadj=1, line=-2.125, cex.axis=1, col=par('fg'), col.axis=par('fg'))
  }
  
}