R/ColorBarDiscrete.R

In esviz: Plotting Functions for Climate Science and Services

#' Draw a Discrete Color Bar
#' 
#' Generates a color bar to use as colouring function for map plots and 
#' optionally draws it (horizontally or vertically) to be added to map 
#' multipanels or plots. A 
#' number of options is provided to adjust the colours and the position and 
#' size of the components. The drawn colour bar spans a whole figure region 
#' and is compatible with figure layouts.\cr\cr 
#' The generated colour bar consists of a set of breaks that define the 
#' length(brks) - 1 intervals to classify each of the values in each of the 
#' grid cells of a two-dimensional field. The corresponding grid cell of a 
#' given value of the field will be coloured in function of the interval it 
#' belongs to.\cr\cr
#' 
#' @param brks Can be provided in two formats:
#' \itemize{
#'   \item{A single value with the number of breaks to be generated 
#'   automatically, between the minimum and maximum specified in 'var_limits' 
#'   (both inclusive). Hence the parameter 'var_limits' is mandatory if 'brks' 
#'   is provided with this format. If 'bar_limits' is additionally provided, 
#'   values only between 'bar_limits' will be generated. The higher the value 
#'   of 'brks', the smoother the plot will look.}
#'   \item{A vector with the actual values of the desired breaks. Values will 
#'   be reordered by force to ascending order. If provided in this format, no 
#'   other parameters are required to generate/plot the colour bar.}
#' }
#'   This parameter is optional if 'var_limits' is specified. If 'brks' not 
#'   specified but 'cols' is specified, it will take as value length(cols) + 1. 
#'   If 'cols' is not specified either, 'brks' will take 21 as value.
#' @param cols Vector of length(brks) - 1 valid colour identifiers, for each 
#'   interval defined by the breaks. This parameter is optional and will be 
#'   filled in with a vector of length(brks) - 1 colours generated with the 
#'   function provided in 'color_fun' (\code{clim.colors} by default).\cr 'cols' 
#'   can have one additional colour at the beginning and/or at the end with the 
#'   aim to colour field values beyond the range of interest represented in the 
#'   colour bar. If any of these extra colours is provided, parameter 
#'   'triangle_ends' becomes mandatory in order to disambiguate which of the 
#'   ends the colours have been provided for.
#' @param vertical TRUE/FALSE for vertical/horizontal colour bar 
#'   (disregarded if plot = FALSE).
#' @param subsampleg The first of each subsampleg breaks will be ticked on the 
#'   colorbar. Takes by default an approximation of a value that yields a 
#'   readable tick arrangement (extreme breaks always ticked). If set to 0 or 
#'   lower, no labels are drawn. See the code of the function for details or 
#'   use 'bar_extra_labels' for customized tick arrangements.
#' @param bar_limits Vector of two numeric values with the extremes of the 
#'   range of values represented in the colour bar. If 'var_limits' go beyond 
#'   this interval, the drawing of triangle extremes is triggered at the 
#'   corresponding sides, painted in 'col_inf' and 'col_sup'. Either of them 
#'   can be set as NA and will then take as value the corresponding extreme in 
#'   'var_limits' (hence a triangle end won't be triggered for these sides). 
#'   Takes as default the extremes of 'brks' if available, else the same values 
#'   as 'var_limits'.
#' @param var_limits Vector of two numeric values with the minimum and maximum 
#'   values of the field to represent. These are used to know whether to draw 
#'   triangle ends at the extremes of the colour bar and what colour to fill 
#'   them in with. If not specified, take the same value as the extremes of 
#'   'brks'. Hence the parameter 'brks' is mandatory if 'var_limits' is not 
#'   specified.
#' @param color_fun Function to generate the colours of the color bar. Must 
#'   take an integer and must return as many colours. The returned colour vector 
#'   can have the attribute 'na_color', with a colour to draw NA values. This 
#'   parameter is set by default to ClimPalette().
#' @param plot Logical value indicating whether to only compute its breaks and 
#'   colours (FALSE) or to also draw it on the current device (TRUE).
#' @param draw_bar_ticks Whether to draw ticks for the labels along the colour bar 
#'  (TRUE) or not (FALSE). TRUE by default. Disregarded if 'plot = FALSE'.
#' @param draw_separators Whether to draw black lines in the borders of each of 
#'   the colour rectancles of the colour bar (TRUE) or not (FALSE). FALSE by 
#'   default. Disregarded if 'plot = FALSE'.
#' @param labels A charater string vector of the names of colors. Must be the
#'   same length as 'cols'. 
#' @param bar_extra_labels Numeric vector of extra labels to draw along axis of 
#'   the colour bar. The number of provided decimals will be conserved. 
#'   Disregarded if 'plot = FALSE'.
#' @param extra_labels Deprecated. Use 'bar_extra_labels' instead.
#' @param title Title to draw on top of the colour bar, most commonly with the 
#'   units of the represented field in the neighbour figures. Empty by default.
#' @param title_scale Scale factor for the 'title' of the colour bar. 
#'   Takes 1 by default.
#' @param bar_label_scale Scale factor for the labels of the colour bar. 
#'   Takes 1 by default.
#' @param label_scale Deprecated. Use 'bar_label_scale' instead.
#' @param bar_tick_scale Scale factor for the length of the ticks of the labels 
#'   along the colour bar. Takes 1 by default.
#' @param tick_scale Deprecated. Use 'bar_tick_scale' instead.
#' @param bar_extra_margin Extra margins to be added around the colour bar, 
#'   in the format c(y1, x1, y2, x2). The units are margin lines. Takes 
#'   rep(0, 4) by default.
#' @param extra_margin Deprecated. Use 'bar_extra_margin' instead.
#' @param bar_label_digits Number of significant digits to be displayed in the 
#'   labels of the colour bar, usually to avoid too many decimal digits 
#'   overflowing the figure region. This does not have effect over the labels 
#'   provided in 'bar_extra_labels'. Takes 4 by default.
#' @param label_digits Deprecated. Use 'bar_label_digits' instead.
#' @param ... Arguments to be passed to the method. Only accepts the following 
#'   graphical parameters:\cr adj ann ask bg bty cex.lab cex.main cex.sub cin 
#'   col.axis col.lab col.main col.sub cra crt csi cxy err family fg fig fin 
#'   font font.axis font.lab font.main font.sub lend lheight ljoin lmitre lty 
#'   lwd mai mex mfcol mfrow mfg mkh oma omd omi page pch pin plt pty smo srt 
#'   tck tcl usr xaxp xaxs xaxt xlog xpd yaxp yaxs yaxt ylbias ylog.\cr For more 
#'  information about the parameters see `par`.
#' 
#' @return 
#' \item{brks}{
#'   Breaks used for splitting the range in intervals.
#' }
#' \item{cols}{
#'   Colours generated for each of the length(brks) - 1 intervals. 
#'   Always of length length(brks) - 1.
#' }
#' 
#' @examples
#' cb <- ColorBarDiscrete(
#'   brks = 0:4, cols = c("green1", "green2", "green3", "green4"),
#'   vertical = FALSE, labels = paste0('lev ', 1:4), bar_label_scale = 1.5, 
#'   bar_extra_margin = c(0.5, 2, 0.5, 2), plot = FALSE)
#' 
#' @import utils
#' @importFrom grDevices col2rgb rgb
#' @export
ColorBarDiscrete <- function(brks = NULL, cols = NULL, vertical = TRUE, 
                     subsampleg = NULL, bar_limits = NULL, var_limits = NULL, 
                     color_fun = ClimPalette(), plot = TRUE, 
                     draw_bar_ticks = FALSE, draw_separators = TRUE,
                     labels = NULL, bar_extra_labels = NULL,
                     extra_labels = NULL, title = NULL, title_scale = 1, 
                     bar_label_scale = 1, label_scale = NULL,
                     bar_tick_scale = 1, tick_scale = NULL,
                     bar_extra_margin = rep(0, 4), extra_margin = NULL,
                     bar_label_digits = 4, label_digits = NULL, ...) {
  # Sanity checks
  if ((is.null(brks) || length(brks) < 2) && is.null(bar_limits) && is.null(var_limits)) {
    stop("At least one of 'brks' with the desired breaks, 'bar_limits' or ",
         "'var_limits' must be provided to generate the colour bar.")
  }

  ## brks
  if (!is.null(brks)) {
    if (!is.numeric(brks)) {
      stop("Parameter 'brks' must be numeric if specified.")
    } else if (length(brks) > 1) {
      reorder <- sort(brks, index.return = TRUE)
      if (!is.null(cols)) {
        cols <- cols[reorder$ix[which(reorder$ix <= length(cols))]]
      }
      brks <- reorder$x
    } 
  }

  ## bar_limits
  if (!is.null(bar_limits)) {
    if (!(all(is.na(bar_limits) | is.numeric(bar_limits)) && (length(bar_limits) == 2))) {
      stop("Parameter 'bar_limits' must be a vector of two numeric elements or NAs.")
    }
  }

  ## var_limits
  if (!is.null(var_limits)) {
    if (!(is.numeric(var_limits) && (length(var_limits) == 2))) {
      stop("Parameter 'var_limits' must be a numeric vector of length 2.")
    } else if (anyNA(var_limits)) {
      stop("Parameter 'var_limits' must not contain NA values.")
    } else if (any(is.infinite(var_limits))) {
      stop("Parameter 'var_limits' must not contain infinite values.")
    }
  }

  ## cols
  if (!is.null(cols)) {
    if (!is.character(cols)) {
      stop("Parameter 'cols' must be a vector of character strings.")
    } else if (any(!sapply(cols, .IsColor))) {
      stop("Parameter 'cols' must contain valid colour identifiers.")
    }
  }
  
  ## color_fun
  if (!is.function(color_fun)) {
    stop("Parameter 'color_fun' must be a colour-generator function.")
  }

  ## integrity among brks, bar_limits and var_limits
  if (is.null(brks) || (length(brks) < 2)) {
    if (is.null(brks)) {
      if (is.null(cols)) {
        brks <- 21
      } else {
        brks <- length(cols) + 1
      }
    }
    if (is.null(bar_limits) || anyNA(bar_limits)) {
      # var_limits is defined
      if (is.null(bar_limits)) {
        bar_limits <- c(NA, NA)
      }
      half_width <- 0.5 * (var_limits[2] - var_limits[1]) / (brks - 1)  
      bar_limits[which(is.na(bar_limits))] <- c(var_limits[1] - half_width, var_limits[2] + half_width)[which(is.na(bar_limits))]
      brks <- seq(bar_limits[1], bar_limits[2], length.out = brks)
    } else if (is.null(var_limits)) {
      # bar_limits is defined
      var_limits <- bar_limits
      half_width <- 0.5 * (var_limits[2] - var_limits[1]) / (brks - 1)  
      brks <- seq(bar_limits[1], bar_limits[2], length.out = brks)
      var_limits[1] <- var_limits[1] + half_width / 50
    } else {
      # both bar_limits and var_limits are defined
      brks <- seq(bar_limits[1], bar_limits[2], length.out = brks)
    }
  } else if (is.null(bar_limits)) {
    if (is.null(var_limits)) {
      # brks is defined
      bar_limits <- c(head(brks, 1), tail(brks, 1))
      var_limits <- bar_limits
      half_width <- 0.5 * (var_limits[2] - var_limits[1]) / (length(brks) - 1)  
      var_limits[1] <- var_limits[1] + half_width / 50
    } else {
      # brks and var_limits are defined
      bar_limits <- c(head(brks, 1), tail(brks, 1))
    }
  } else {
    # brks and bar_limits are defined
    # or
    # brks, bar_limits and var_limits are defined
    if (head(brks, 1) != bar_limits[1] || tail(brks, 1) != bar_limits[2]) {
      stop("Parameters 'brks' and 'bar_limits' are inconsistent.")
    }
  }   

  # Generate colours if needed
  if (is.null(cols)) {
    cols <- color_fun(length(brks) - 1)
    attr_bk <- attributes(cols)
    attributes(cols) <- attr_bk
  } else if ((length(cols) != (length(brks) - 1))) {
    stop("Incorrect number of 'brks' and 'cols'. There must be one more break than the number of colours.")
  }

  ## vertical
  if (!is.logical(vertical)) {
    stop("Parameter 'vertical' must be TRUE or FALSE.")
  }

  ## bar_extra_labels
  if (missing(bar_extra_labels) && !missing(extra_labels)) {
    warning("The parameter 'extra_labels' is deprecated. Use 'bar_extra_labels' instead.")
    bar_extra_labels <- extra_labels
  }
  if (is.null(bar_extra_labels)) {
    bar_extra_labels <- numeric(0)
  }
  if (!is.numeric(bar_extra_labels)) {
    stop("Parameter 'bar_extra_labels' must be numeric.")
  } else {
    if (any(bar_extra_labels > bar_limits[2]) || any(bar_extra_labels < bar_limits[1])) {
      stop("Parameter 'bar_extra_labels' must not contain ticks beyond the color bar limits.")
    }
  }
  bar_extra_labels <- sort(bar_extra_labels)
  
  ## bar_label_digits
  if (missing(bar_label_digits) && !missing(label_digits)) {
    warning("The parameter 'label_digits' is deprecated. Use 'bar_label_digits' instead.")
    bar_label_digits <- label_digits
  }
  if (!is.numeric(bar_label_digits)) {
    stop("Parameter 'bar_label_digits' must be numeric.")
  }
  bar_label_digits <- round(bar_label_digits)

  ## labels
  if (is.null(labels)) {
    labels <- rep(NA, length(cols))
    tmp <- signif(brks, bar_label_digits)
    for (i_brks in 1:length(cols)) {
      labels[i_brks] <- paste0("(", tmp[i_brks], ", ", tmp[i_brks + 1], "]")
    }
  } else if (length(labels) != length(cols)) {
    stop("Parameter 'labels' must have the same length as 'cols'.")
  }

  ## subsampleg
  primes <- function(x) {
    # Courtesy of Chase. See http://stackoverflow.com/questions/6424856/r-function-for-returning-all-factors
    x <- as.integer(x)
    div <- seq_len(abs(x))
    factors <- div[x %% div == 0L]
    factors <- list(neg = -factors, pos = factors)
    return(factors)
  }
  remove_final_tick <- FALSE
  added_final_tick <- TRUE
  if (is.null(subsampleg)) {
    subsampleg <- 1
    while (length(brks) / subsampleg > 15 - 1) {
      next_factor <- primes((length(brks) - 1) / subsampleg)$pos
      next_factor <- next_factor[length(next_factor) - ifelse(length(next_factor) > 2, 1, 0)]
      subsampleg <- subsampleg * next_factor
    }
    if (subsampleg > (length(brks) - 1) / 4) {
      subsampleg <- max(1, round(length(brks) / 4))
      bar_extra_labels <- c(bar_extra_labels, bar_limits[2])
      added_final_tick <- TRUE
      if ((length(brks) - 1) %% subsampleg < (length(brks) - 1) / 4 / 2) {
        remove_final_tick <- TRUE
      }
    }
  } else if (!is.numeric(subsampleg)) {
    stop("Parameter 'subsampleg' must be numeric.")
  }
  subsampleg <- round(subsampleg)
  draw_labels <- TRUE
  if ((subsampleg) < 1) {
    draw_labels <- FALSE
  }

  ## plot
  if (!is.logical(plot)) {
    stop("Parameter 'plot' must be logical.")
  }

  ## draw_separators
  if (!is.logical(draw_separators)) {
    stop("Parameter 'draw_separators' must be logical.")
  }

  ## draw_bar_ticks
  if (!is.logical(draw_bar_ticks)) {
    stop("Parameter 'draw_bar_ticks' must be logical.")
  }

  ## title
  if (is.null(title)) {
    title <- ''
  }
  if (!is.character(title)) {
    stop("Parameter 'title' must be a character string.")
  }

  ## title_scale
  if (!is.numeric(title_scale)) {
    stop("Parameter 'title_scale' must be numeric.")
  }

  ## bar_label_scale
  if (missing(bar_label_scale) && !missing(label_scale)) {
    warning("The parameter 'label_scale' is deprecated. Use 'bar_label_scale' instead.")
    bar_label_scale <- label_scale
  }
  if (!is.numeric(bar_label_scale)) {
    stop("Parameter 'bar_label_scale' must be numeric.")
  }

  ## bar_tick_scale
  if (missing(bar_tick_scale) && !missing(tick_scale)) {
    warning("The parameter 'tick_scale' is deprecated. Use 'bar_tick_scale' instead.")
    bar_tick_scale <- tick_scale
  }
  if (!is.numeric(bar_tick_scale)) {
    stop("Parameter 'bar_tick_scale' must be numeric.")
  }

  ## bar_extra_margin
  if (missing(bar_extra_margin) && !missing(extra_margin)) {
    warning("The parameter 'extra_margin' is deprecated. Use 'bar_extra_margin' instead.")
    bar_extra_margin <- extra_margin
  }
  if (!is.numeric(bar_extra_margin) || length(bar_extra_margin) != 4) {
    stop("Parameter 'bar_extra_margin' must be a numeric vector of length 4.")
  }

  # Process the user graphical parameters that may be passed in the call
  ## Graphical parameters to exclude
  excludedArgs <- c("cex", "cex.axis", "col", "lab", "las", "mar", "mgp", "new", "ps")
  userArgs <- .FilterUserGraphicArgs(excludedArgs, ...)

  #
  #  Plotting colorbar
  # ~~~~~~~~~~~~~~~~~~~
  #
  if (plot) {
    pars_to_save <- c('mar', 'cex', names(userArgs), 'mai', 'mgp', 'las', 'xpd')
    saved_pars <- par(pars_to_save)
    on.exit(par(saved_pars), add = TRUE)
    par(mar = c(0, 0, 0, 0), cex = 1)
    image(1, 1, t(t(1)), col = rgb(0, 0, 0, 0), axes = FALSE, xlab = '', ylab = '')
    # Get the availale space
    figure_size <- par('fin')
    cs <- par('csi')
    # This allows us to assume we always want to plot horizontally
    if (vertical) {
      figure_size <- rev(figure_size)
    }
#    pannel_to_redraw <- par('mfg')
#    .SwitchToFigure(pannel_to_redraw[1], pannel_to_redraw[2])
    # Load the user parameters
    par(new = TRUE)
    par(userArgs)
    # Set up color bar plot region
    margins <- c(0.0, 0, 0.0, 0)
    cex_title <- 1 * title_scale
    cex_labels <- 0.9 * label_scale
    cex_ticks <- -0.3 * tick_scale
    spaceticklab <- max(-cex_ticks, 0)
    if (vertical) {
      margins[1] <- margins[1] + (1.2 * cex_labels * 3 + spaceticklab) * cs
      margins <- margins + extra_margin[c(4, 1:3)] * cs
    } else {
      margins[1] <- margins[1] + (1.2 * cex_labels * 1 + spaceticklab) * cs
      margins <- margins + extra_margin * cs
    }
    if (title != '') {
      margins[3] <- margins[3] + (1.0 * cex_title) * cs
    }
    margins[3] <- margins[3] + sqrt(figure_size[2] / (margins[1] + margins[3])) * 
                               figure_size[2] / 6 * ifelse(title != '', 0.5, 0.8)
    # Set side margins
    margins[2] <- margins[2] + figure_size[1] / 16
    margins[4] <- margins[4] + figure_size[1] / 16
    ncols <- length(cols)
    # Set up the points of triangles
    # Compute the proportion of horiz. space occupied by one plot unit
    prop_unit <- (1 - (margins[2] + margins[4]) / figure_size[1]) / ncols
    # Draw the color squares and title
    if (vertical) {
      par(mai = c(margins[2:4], margins[1]), 
          mgp = c(0, spaceticklab + 0.2, 0), las = 1)
      d <- 4
      image(1, 1:ncols, t(1:ncols), axes = FALSE, col = cols, 
            xlab = '', ylab = '')
      title(ylab = title, line = cex_title * (0.2 + 0.1), cex.lab = cex_title)
      # Draw top and bottom border lines    
      lines(c(0.6, 0.6), c(1 - 0.5, ncols + 0.5))
      lines(c(1.4, 1.4), c(1 - 0.5, ncols + 0.5))
    } else {
      # The term - cex_labels / 4 * (3 / cex_labels - 1) was found by
      # try and error
      par(mai = margins, 
          mgp = c(0, cex_labels / 2 + spaceticklab 
                     - cex_labels / 4 * (3 / cex_labels - 1), 0),
          las = 1)
      d <- 1
      image(1:ncols, 1, t(t(1:ncols)), axes = FALSE, col = cols, 
            xlab = '', ylab = '')
      title(title, line = cex_title * (0.2 + 0.1), cex.main = cex_title)
      # Draw top and bottom border lines    
      lines(c(1 - 0.5, ncols + 0.5), c(0.6, 0.6))
      lines(c(1 - 0.5, ncols + 0.5), c(1.4, 1.4))
      tick_length <- -0.4
    }

    # Put the separators
    if (vertical) {
      if (draw_separators) {
        for (i in 1:(ncols - 1)) {
          lines(c(0.6, 1.4), c(i, i) + 0.5)
        }
      }
      # Draw horizontal border lines
      lines(c(0.6, 1.4), c(0.5, 0.5))
      lines(c(0.6, 1.4), c(ncols + 0.5, ncols + 0.5))
    } else {
      if (draw_separators) {
        for (i in 1:(ncols - 1)) {
          lines(c(i, i) + 0.5, c(0.6, 1.4))
        }
      }
      # Draw vertical border lines
      lines(c(0.5, 0.5), c(0.6, 1.4))
      lines(c(ncols + 0.5, ncols + 0.5), c(0.6, 1.4))
    }

    # Put the ticks
    plot_range <- length(brks) - 1
    var_range <- tail(brks, 1) - head(brks, 1)
    bar_extra_labels_at <- ((bar_extra_labels - head(brks, 1)) / var_range) * plot_range + 0.5
    at <- seq(1, length(cols), subsampleg)
#    at <- seq(1, length(brks), subsampleg)
#    labels <- brks[at]
#    # Getting rid of next-to-last tick if too close to last one
#    if (remove_final_tick) {
#      at <- at[-length(at)]
#      labels <- labels[-length(labels)]
#    }
#    labels <- signif(labels, bar_label_digits)
    if (added_final_tick) {
      bar_extra_labels[length(bar_extra_labels)] <- signif(tail(bar_extra_labels, 1), bar_label_digits)
    }
#    at <- at - 0.5
    at <- c(at, bar_extra_labels_at)
    labels <- c(labels, bar_extra_labels)
    tick_reorder <- sort(at, index.return = TRUE)
    at <- tick_reorder$x
    if (draw_labels) {
      labels <- labels[tick_reorder$ix]
    } else {
      labels <- FALSE
    }
    # Put box labels
    axis(d, at = at, tick = draw_bar_ticks, labels = labels, cex.axis = cex_labels, tcl = cex_ticks)
  }
  invisible(list(brks = brks, cols = cols))
}