R/colorChart.R

In aqp: Algorithms for Quantitative Pedology

#' @title Visualize soil colors in Munsell notation according to within-group frequency.
#' @param m character vector of color in Munsell notation ('10YR 4/6')
#' 
#' @param g factor describing group membership, typically a generalization of horizon designation, default value will generate a fake grouping that covers all of the colors in `m`
#' 
#' @param size logical, encode group-wise frequency with chip size
#' 
#' @param annotate logical, annotate color chip frequency
#' 
#' @param launderColors logical, fix common errors with encoding neutral colors, see [launderMunsell()]
#' 
#' @param chip.cex scaling factor applied to each color chip
#' 
#' @param chip.cex.min lower limit for color chip frequency depiction
#' 
#' @param chip.cex.max lower limit for color chip frequency depiction
#' 
#' @param chip.border.col color for chip borders (outline)
#' 
#' @param annotate.cex scaling factor for chip frequency annotation
#' 
#' @param annotate.type character, within-group `count` or `percentage`
#'
#' @param threshold numeric within 0-1, color chips with proportion `< threshold` are removed
#'
#' @return a `trellis` object
#' 
#' @export
#' 
#' @examplesIf requireNamespace('latticeExtra') && requireNamespace('scales')
#' 
#' library(lattice)
#' 
#' # two hue pages
#' ric <- expand.grid(
#'   hue = c('5YR', '7.5YR'),
#'   value = 2:8,
#'   chroma = 2:8
#' )
#' 
#' # combine hue, value, chroma into standard Munsell notation
#' ric <- formatMunsell(ric$hue, ric$value, ric$chroma)
#' 
#' # note that chip frequency-based size is disabled
#' # because all chips have equal frequency
#' colorChart(ric, chip.cex = 4, size = TRUE)
#' 
#' # annotation of frequency
#' colorChart(ric, chip.cex = 4, annotate = TRUE)
#' 
#' # bootstrap to larger size
#' ric.big <- sample(ric, size = 100, replace = TRUE)
#' 
#' # frequency can be encoded in size
#' colorChart(ric.big, chip.cex = 3)
#' colorChart(ric.big, chip.cex = 5, annotate = TRUE)
#' 
#' # constant size
#' colorChart(ric.big, chip.cex = 3, size = FALSE)
#' colorChart(ric.big, chip.cex = 3, size = FALSE, chip.border.col = 'NA')
#' 
#' # simulate colors based dE00 thresholding
#' p <- list(
#'   list(m = '10YR 4/4', thresh = 10, hues = c('10YR', '7.5YR'))
#' )
#' 
#' # perform 500 simulations
#' s <- simulateColor(method = 'dE00', n = 500, parameters = p)
#' 
#' # result is a list, use the first element
#' colorChart(s[[1]], chip.cex = 4)
#' 
#' # increase the possible range of color chip sizes
#' colorChart(s[[1]], chip.cex = 4, chip.cex.min = 0.01, chip.cex.max = 2)
#' 
#' # demonstrate support for neutral chips
#' N <- sprintf('N %s/', 2:8)
#' cols <- c(rep(N, times = 5), ric.big)
#' 
#' # note special panel used to show neutral chips
#' colorChart(cols, size = FALSE, annotate = TRUE)
#' 
#' # filter proportions below given threshold
#' colorChart(cols, size = FALSE, annotate = TRUE, threshold = 0.01,
#'            chip.cex = 4, annotate.type = 'percentage')
#'            
#' # extreme values
#' colorChart(c('N 8/', '10YR 4/12', '10YR 3/1', '10YR 10/4'))
#' 
#' # unusual notation, 10YR 4/0 --> effectively N 4/
#' colorChart(c('N 8/', 'N 4/', '10YR 4/0', '5G 6/6', '5Y 10/4'))
#' 
#' # demonstrate groups
#' m <- c('10YR 4/4', 'N 2/', 'N 3/', '5Y 6/6', '5P 4/4')
#' g <- factor(c(1, 1, 2, 2, 2))
#' colorChart(m, g)
#' 
colorChart <- function(m, g = factor('All'), size = TRUE, annotate = FALSE, launderColors = TRUE, chip.cex = 3, chip.cex.min = 0.1, chip.cex.max = 1.5, chip.border.col = 'black', annotate.cex = chip.cex * 0.25, annotate.type = c('count', 'percentage'), threshold = NULL) {
  
  # requires latticeExtra and scales
  if(!requireNamespace('latticeExtra', quietly = TRUE) || !requireNamespace('scales', quietly = TRUE)) {
    stop('please install the `latticeExtra` and `scales` packages.', call. = FALSE)
  }
  
  # custom panel function defined here, so that it can "find" data within the colorChart function scope
  panel.colorChart <- function(x, y, subscripts = subscripts, ...) {
    
    # panel-wise subset of required data
    p.data <- tab[subscripts, ]
    p.data$x <- x
    p.data$y <- y
    
    # grid lines: use original data
    if(nrow(p.data) > 0) {
      panel.abline(
        v = unique(p.data$x), 
        h = unique(p.data$y), 
        col = grey(0.85), 
        lty = 3
      )
    }
    
    
    # plot single instances of each chip, transparency weighted by frequency
    panel.points(
      p.data$x, 
      p.data$y, 
      pch = 22, 
      col = chip.border.col,
      fill = p.data$transformed.col, 
      cex =  p.data$chip.size
    )
    
    # annotate chips
    if(annotate) {
      
      # count or percentage
      # these are computed by group NOT by panel
      ann.txt <- switch(
        annotate.type,
        'count' = round(p.data$count),
        'percentage' = signif(100 * p.data$prop, 2)
      )
      
      # adjust based on lightness
      anno.col <- invertLabelColor(p.data$.color)
      
      # within-group frequency
      panel.text(
        x = p.data$x, 
        y = p.data$y, 
        labels = ann.txt, 
        cex = annotate.cex, 
        col = anno.col
      )
    }
    
  }
  
  
  # annotation type
  if(annotate) {
    annotate.type <- match.arg(annotate.type)
  }
  
  # optionally launder Munsell notation:
  #  - interpret poorly specified N chips
  m <- launderMunsell(m)
  
  
  # extract pieces / convert colors
  z <- data.frame(
    .munsell = m,
    .groups = g
  )
  
  # remove obvious NA in colors or groups
  z <- na.omit(z)
  
  # bogus colors can creep-in when composing Munsell notation from pieces
  idx <- which(validateMunsell(z$.munsell))
  z <- z[idx, ]
  
  # within-group counts + proportions
  tab <- as.data.frame(table(z$.groups, z$.munsell))
  names(tab) <- c('.groups', '.munsell', 'count')
  
  # group totals
  group.totals <- as.data.frame(table(z$.groups))
  names(group.totals) <- c('.groups', 'total')
  
  # combine
  tab <- merge(tab, group.totals, by = '.groups', all.x = TRUE, sort = FALSE)
  
  # within-group proportions
  tab$prop <- tab$count / tab$total
  
  # filter 0s
  tab$prop <- ifelse(is.na(tab$prop), 0, tab$prop)
  tab <- tab[which(tab$prop > 0), ]
  
  # apply optional threshold on proportions
  if( !is.null(threshold) ) {
    # sanity check
    if(threshold < 0 && threshold > 1) {
      message('ignoring out of bounds threshold')
    } else {
     # apply threshold
      tab <- tab[which(tab$prop > threshold), ]
    }
  }
  
  # check for 0 rows (too much filtering)
  if(nrow(tab) < 1) {
    stop('all rows have been removed, consider setting `threshold` higher', call. = FALSE)
  }
  
  # convert colors
  tab$.color <- parseMunsell(tab$.munsell)
  
  ## TODO: probably a cleaner way
  pm <- parseMunsell(munsellColor = tab$.munsell, convertColors = FALSE)
  tab$hue <- pm$hue
  tab$value <- pm$value
  tab$chroma <- pm$chroma
  
  # remove missing colors / groups
  idx <- which(complete.cases(tab[, c('hue', 'value', 'chroma', '.groups')]))
  tab <- tab[idx, ]
  
  # encode hue as factor using standard hue order
  # second call to factor() drops unused levels
  # note special argument to include neutral hues
  # N is in position 41, we need it in position 1
  hp <- huePosition(returnHues = TRUE, includeNeutral = TRUE)
  N.idx <- match('N', hp)
  hp <- c(hp[N.idx], hp[-N.idx])
  
  tab$hue <- factor(
    factor(tab$hue, levels = hp)
  )
  
  # disable variable size when all frequencies are the same (no useful information)
  if(length(unique(tab$count)) == 1) {
    no.differeneces <- TRUE
  } else {
    no.differeneces <- FALSE
  }
  

  # variable chip size
  if(size) {
    if(no.differeneces) {
      tab$chip.size <- chip.cex
    } else {
      tab$chip.size <- sqrt(scales::rescale(tab$prop, to = c(chip.cex.min, chip.cex.max))) * chip.cex
    }
  } else {
    tab$chip.size <- chip.cex
  }
  
  ## TODO: thematic coloring based on density
  ## needs to be adjusted a group at a time
  # .f <- scales::col_numeric(viridis::viridis(100), domain = c(0, max(tab$prop)))
  # tab$transformed.col <- .f(tab$prop)
  
  # chip color is not modified for now
  tab$transformed.col <- tab$.color
  
  ## TODO: 
  # * consider reporting Shannon entropy / group
  #   print(shannonEntropy(tab$prop))
  
  
  # set reasonable [x, y] limits: 
  # value / chroma: 2-8 unless data extend beyond those limits
  # exception for N hues (chroma 0), typical min value is chroma of 1 (not always)
  x.lim <- c(
    pmin(min(tab$chroma[which(!tab$hue == 'N')]), 2) - 0.5,
    pmax(max(tab$chroma), 8) + 0.5
  )
  
  y.lim <- c(
    pmin(min(tab$value), 2) - 0.5,
    pmax(max(tab$value), 8) + 0.5
  )
  
  # assemble basic plot
  pp <- lattice::xyplot(
    value ~ chroma | hue + .groups, 
    data = tab,
    drop = TRUE, 
    as.table = TRUE,
    subscripts = TRUE, 
    # this works until we attempt to use neutral hues
    xlim = x.lim,
    ylim = y.lim,
    # simple version when no neutral hues
    scales = list(
      x = list(alternating = 1), 
      y = list(rot = 0, alternating = 3)
    ), 
    main = '', 
    xlab = 'Chroma', 
    ylab = 'Value', 
    panel = panel.colorChart
  )
  
  
  ## get hues to iterate over
  ll <- levels(tab$hue)
  
  ## in the presence of N chips, custom x-axis and limits, and panel size required
  if('N' %in% ll) {
    
    ## NOTE: with complex hue x group structure, in the presence of N chips
    #        we need to compute panel-specific limits and axes labels
    #        applying these custom parameters won't work if any panel has no data
    #        therefore, generate fake data for every combination of hue x groups
    # 
    #        see:
    #        https://stackoverflow.com/questions/11161739/how-to-specify-different-ylim-values-for-each-panel-in-xyplot
    #
    #
    # side-effect: unused levels must be removed prior to calling colorChart()
    #
    # solution:    keep track of panels with data, then assigning scales / limits accordingly
    
    # (hue x group) combinations before adding fake obs
    int.b <- levels(interaction(tab$hue, tab$.groups, drop = TRUE))
    
    ## HACK: add a single bogus point for every hue x group combination
    #        this ensures that limits are correctly established
    #        only required when there are neutral colors
    .fake <- expand.grid(hue = levels(tab$hue), .groups = levels(tab$.groups))
    
    .fake <- data.frame(
      .groups = .fake$.groups,
      .munsell = '', 
      count = 1, 
      total = 1, 
      prop = 0,
      .color = '#FFFFFFFF',
      hue = .fake$hue,
      value = 100, 
      chroma = 100,
      chip.size = 0.1,
      transformed.col = '#FFFFFFFF'
    )
    
    tab <- rbind(tab, .fake)
    
    ## end HACK
    
    # (hue x group) combinations after adding fake obs
    int.a <- levels(interaction(tab$hue, tab$.groups))
    
    
    # standards x-limits
    x.at <- seq(x.lim[1] + 0.5, x.lim[2] - 0.5, by = 1)
    
    # replicate as many times are there are columns
    # first column (N) gets no axes
    x.at.list <- c(
      list(''), 
      lapply(1:(length(ll)-1), FUN = function(i) {x.at})
    )
    
    # limits for as many columns
    x.limits.list <- c(
      list(c(0, 0)), 
      lapply(1:(length(ll)-1), FUN = function(i) {x.lim})
    )
    
    
    # replicate scales to cover all columns * rows
    n.groups <- length(levels(tab$.groups))
    x.at.list <- rep(x.at.list, times = n.groups)
    x.limits.list <- rep(x.limits.list, times = n.groups)
    
    # index just those panels (hue x group) with no data (before adding fake obs)
    nd.idx <- which(is.na(match(int.a, int.b, nomatch = NA)))
    
    # suppress scales in these panels
    x.at.list[nd.idx] <- list('')
    
    pp <- lattice::xyplot(
      value ~ chroma | hue + .groups, 
      data = tab,
      as.table = TRUE,
      subscripts = TRUE, 
      # panel-specific limits gets complicated
      scales = list(
        alternating = 3, 
        y = list(rot = 0, limits = y.lim), 
        x = list(
          relation = 'free', 
          at = x.at.list,
          limits = x.limits.list
        )
      ), 
      main = '', 
      xlab = 'Chroma', 
      ylab = 'Value', 
      panel = panel.colorChart
    )
    
    # proportional panel sizes, neutral gets 20% of normal space
    pp <- latticeExtra::resizePanels(pp, w = c(0.2, rep(1, times = length(ll) - 1)))
  }
  
  # move paneling by groups to outer panels
  pp <- latticeExtra::useOuterStrips(
    pp, 
    strip = strip.custom(bg = grey(0.85), par.strip.text = list(cex=0.85)), 
    strip.left = strip.custom(bg = grey(0.85), par.strip.text = list(rot=0))
  )
  
  if(annotate) {
    sub.txt <- sprintf('chip labels represent %ss', annotate.type)
    pp <- update(pp, sub = list(sub.txt, font = 1))
  }
  
  return(pp)  
}