R/VizMatrix.R

In esviz: Plotting Functions for Climate Science and Services

#' Function to convert any numerical table to a grid of coloured squares.
#' 
#' This function converts a numerical data matrix into a coloured 
#' grid. It is useful for a slide or article to present tabular results as 
#' colors instead of numbers.
#' 
#' @param data A numerical matrix containing the values to be displayed in a 
#'   colored image.
#' @param var Deprecated. Use 'data' instead.
#' @param brks A vector of the color bar intervals. The length must be one more 
#'   than the parameter 'cols'. Use ColorBarContinuous() to generate default
#'   values.
#' @param cols A vector of valid color identifiers for color bar. The length
#'   must be one less than the parameter 'brks'. Use ColorBarContinuous() to 
#'   generate default values.
#' @param toptitle A string of the title of the grid. Set NULL as default. 
#' @param title.color A string of valid color identifier to decide the title 
#'   color. Set "royalblue4" as default.
#' @param xtitle A string of title of the x-axis. Set NULL as default.
#' @param ytitle A string of title of the y-axis. Set NULL as default.
#' @param xlabels A vector of labels of the x-axis. The length must be 
#'   length of the column of parameter 'data'. Set the sequence from 1 to the 
#'   length of the column of parameter 'data' as default.
#' @param xvert A logical value to decide whether to place x-axis labels 
#'   vertically. Set FALSE as default, which keeps the labels horizontally. 
#' @param ylabels A vector of labels of the y-axis The length must be 
#'   length of the row of parameter 'data'. Set the sequence from 1 to the 
#'   length of the row of parameter 'data' as default.
#' @param line An integer specifying the distance between the title of the 
#'   x-axis and the x-axis. Set 3 as default. Adjust if the x-axis labels 
#'   are long.
#' @param figure.width A positive number as a ratio adjusting the width of the 
#'   grids. Set 1 as default.
#' @param drawleg A logical value to decide to draw the grid color legend or not. 
#'   Set TRUE as default.
#' @param legend Deprecated. Use 'drawleg' instead.
#' @param legend.width A number between 0 and 0.5 to adjust the legend width.
#'   Set 0.15 as default.
#' @param xlab_dist A number specifying the distance between the x labels and 
#'   the x axis. If not specified, it equals to -1 - (nrow(data) / 10 - 1).
#' @param ylab_dist A number specifying the distance between the y labels and 
#'   the y axis. If not specified, it equals to 0.5 - ncol(data) / 10.
#' @param fileout A string of full directory path and file name indicating where 
#'   to save the plot. If not specified (default), a graphics device will pop up. 
#' @param size_units A string indicating the units of the size of the device 
#'   (file or window) to plot in. Set 'px' as default. See ?Devices and the 
#'   creator function of the corresponding device.
#' @param res A positive number indicating resolution of the device (file or window) 
#'   to plot in. See ?Devices and the creator function of the corresponding device.
#' @param ... The additional parameters to be passed to function 
#'   ColorBarContinuous() in s2dv for color legend creation.
#'   
#' @return A figure in popup window by default, or saved to the specified path.
#' via \code{fileout}.
#' 
#' @examples
#'  # Example with random data
#'  VizMatrix(data = matrix(rnorm(n = 120, mean = 0.3), 10, 12),
#'            cols = c('white','#fef0d9','#fdd49e','#fdbb84','#fc8d59',
#'                      '#e34a33','#b30000', '#7f0000'),
#'            brks = c(-1, 0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 1),
#'            toptitle = "Mean Absolute Error", 
#'            xtitle = "Forecast time (month)", ytitle = "Start date",
#'            xlabels = c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", 
#'                        "Aug", "Sep", "Oct", "Nov", "Dec"))
#' 
#' @importFrom grDevices dev.new dev.off dev.cur 
#' @export
VizMatrix <- function(data, brks = NULL, cols = NULL, toptitle = NULL,
                      title.color = "royalblue4", xtitle = NULL, ytitle = NULL,
                      xlabels = NULL, xvert = FALSE, ylabels = NULL, line = 3,
                      figure.width = 1, drawleg = TRUE, legend = NULL,
                      legend.width = 0.15, xlab_dist = NULL, ylab_dist = NULL,
                      fileout = NULL, size_units = 'px', res = 100, var = NULL,
                      ...) {

  # Check data:
  if (missing(data) || is.null(data)) {
    if (!is.null(var)) {
      data <- var
      warning("The parameter 'var' is deprecated. Use 'data' instead.")
    } else {
      stop("Parameter 'data' cannot be NULL.")
    }
  } else if (!is.null(var)) {
    warning("The parameter 'var' is deprecated. 'data' will be used instead.")
  }
  if (!is.matrix(data)) {
    stop("Input values are not a matrix")
  }
  if (!is.numeric(data)){
    stop("Input values are not always numbers")
  }
  
  # Check drawleg
  if (missing(drawleg) && !missing(legend)) {
    warning("The parameter 'legend' is deprecated. Use 'drawleg' instead.")
    drawleg <- legend
  }
  if (!is.logical(drawleg) || length(drawleg) != 1) {
    stop("Parameter 'drawleg' must be a single logical value")
  }

  # Build: brks, cols 
  colorbar <- ColorBarContinuous(brks = brks, cols = cols, vertical = FALSE, 
                                 plot = FALSE, ...) 
  brks <- colorbar$brks
  cols <- colorbar$cols

  n.cols <- length(cols) ## number of colours
  n.brks <- length(brks) ## number of intervals

  if (n.brks != n.cols + 1)
    stop("There must be one break more than the number of colors")
  ncols <- ncol(data) ## number of columns of the image
  nrows <- nrow(data) ## number of rows of the image
  if (ncols < 2)
    stop("Matrix must have at least two columns")
  if (nrows < 2)
    stop("Matrix must have at least two rows")
  if (!is.null(xlabels) && length(xlabels) != ncols)
      stop(paste0("The number of x labels must be equal to the number of ",
                  "columns of the data matrix"))
  if (!is.null(ylabels) && length(ylabels) != nrows)
      stop(paste0("The number of y labels must be equal to the number of ",
                  "rows of the data matrix"))
  if (!is.numeric(figure.width) || figure.width < 0)
      stop("figure.width must be a positive number")
  if (!is.numeric(legend.width) || legend.width < 0 || legend.width > 0.5)
      stop("legend.width must be a number from 0 to 0.5")


  # If there is any filenames to store the graphics, process them
  # to select the right device 
  if (!is.null(fileout)) {
    deviceInfo <- .SelectDevice(fileout = fileout,
                                width = 80 * ncols * figure.width, 
                                height = 80 * nrows,
                                units = size_units, res = res)
    saveToFile <- deviceInfo$fun
    fileout <- deviceInfo$files
  }

  # Open connection to graphical device
  if (!is.null(fileout)) {
    saveToFile(fileout)
  } else if (names(dev.cur()) == 'null device') {
    dev.new(units = size_units, res = res,
            width = 8 * figure.width, height = 5)
  }
  oldpar <- par(c("mar", "fig", "xpd"))
  on.exit(par(oldpar), add = TRUE)

  if (!is.null(fileout)) {

  # Draw empty plot:
    par(mar = c(4, 4, 1, 0), fig = c(0.1, 1 - legend.width, 0.1, 0.9))
    plot(1, 1, type = "n", xaxt = "n", yaxt = "n", ylim = c(0.5, nrows + 0.5), 
         xlim = c(-0.5, ncols - 1 + 0.5), ann = F,  bty = "n")
    
  # Add axes titles:
    label.size <- 1.2 * (max(ncols, nrows) / 10) ^ 0.5  
    mtext(side = 1, text = xtitle, line = line, cex = label.size, font = 3)
    mtext(side = 2, text = ytitle, line = 3, cex = label.size, font = 3)

  # Add plot title:
    if (is.null(title.color)) title.color <- "royalblue4"
    mtext(side = 3, text = toptitle, cex = 1.75 * (nrows / 10) ^ 0.7, 
          col = title.color)

  # Add axis labels:
    axis.size <- (max(ncols, nrows) / 10) ^ 0.3
    if (is.null(xlabels)) xlabels = 1:ncols
    if (is.null(ylabels)) ylabels = 1:nrows

   if(is.null(xlab_dist)) { ## Add x axis labels
        axis(1, at = seq(0, ncols - 1), las = ifelse(xvert, 2, 1), labels = xlabels, 
             cex.axis = axis.size, tck = 0, lwd = 0, line = - 1 - (nrows / 10 - 1))  
    } else {
        axis(1, at = seq(0, ncols - 1), las = ifelse(xvert, 2, 1), labels = xlabels, 
             cex.axis = axis.size, tck = 0, lwd = 0, line = xlab_dist) 
    }
    if(is.null(ylab_dist)) { ## Add y axis labels
        axis(2, at = seq(1, nrows), las = 1, labels = rev(ylabels), 
             cex.axis = axis.size, tck = 0, lwd = 0, line = 0.5 - ncols / 10)
    } else {
        axis(2, at = seq(1, nrows), las = 1, labels = rev(ylabels), 
             cex.axis = axis.size, tck = 0, lwd = 0, line = ylab_dist)
    }

  } else {

  # Draw empty plot:
    par(mar = c(4, 4, 1, 0), fig = c(0.1, 1 - legend.width, 0.1, 0.9))
    plot(1, 1, type = "n", xaxt = "n", yaxt = "n", ylim = c(0.5, nrows + 0.5),
         xlim = c(-0.5, ncols - 1 + 0.5), ann = F,  bty = "n")

  # Add axes titles:
    label.size <- 1.2 # * (max(ncols, nrows) / 10) ^ 0.5
    mtext(side = 1, text = xtitle, line = line, cex = label.size, font = 3)
    mtext(side = 2, text = ytitle, line = 3, cex = label.size, font = 3)

  # Add plot title:
    if (is.null(title.color)) title.color <- "royalblue4"
    mtext(side = 3, text = toptitle, cex = 1.5,  #* (nrows / 10) ^ 0.7, 
          col = title.color)

  # Add axis labels:
    axis.size <- 1 #(max(ncols, nrows) / 10) ^ 0.3
    if (is.null(xlabels)) xlabels = 1:ncols
    if (is.null(ylabels)) ylabels = 1:nrows

    if(is.null(xlab_dist)){  ## Add x axis labels
        axis(1, at = seq(0, ncols - 1), las = ifelse(xvert, 2, 1), labels = xlabels, 
             cex.axis = axis.size, tck = 0, lwd = 0, line = - 1 - (nrows / 10 - 1))
    } else {
        axis(1, at = seq(0, ncols - 1), las = ifelse(xvert, 2, 1), labels = xlabels, 
             cex.axis = axis.size, tck = 0, lwd = 0, line = xlab_dist)  
    }
    if(is.null(ylab_dist)){ ## Add y axis labels
        axis(2, at = seq(1, nrows), las = 1, labels = rev(ylabels),
             cex.axis = axis.size, tck = 0, lwd = 0, line = 0.5 - ncols / 10)  
    } else { 
        axis(2, at = seq(1, nrows), las = 1, labels = rev(ylabels),
             cex.axis = axis.size, tck = 0, lwd = 0, line = ylab_dist)  
    }

  }

  # Create an array of colors instead of numbers (it starts all gray):                
  array.colors <- array("gray", c(nrows, ncols))
  for (int in n.cols:1) array.colors[data <= brks[int + 1]] <- cols[int]

  # fill with colors the cells in the figure:
  for (p in 1:nrows) {
    for (l in 0:(ncols - 1)) {
      polygon(c(0.5 + l - 1, 0.5 + l - 1, 1.5 + l - 1, 1.5 + l - 1),
              c(-0.5 + nrows + 1 - p, 0.5 + nrows + 1 - p, 
                 0.5 + nrows + 1 - p, -0.5 + nrows + 1 - p), 
                 col = array.colors[p, 1 + l], border = "black")
    }
  }

  # Draw color legend:
  if (drawleg) {
    par(fig = c(1 - legend.width - 0.01, 
                1 - legend.width + legend.width * min(1, 10 / ncols), 
                0.3, 0.8), new = TRUE)
    #legend.label.size <- (max(ncols, nrows) / 10) ^ 0.4
    ColorBarContinuous(brks = brks, cols = cols, vertical = TRUE, ...)
  }
    
  # If the graphic was saved to file, close the connection with the device
  if (!is.null(fileout)) dev.off()
   invisible(list(brks = brks, cols = cols))
 
}