R/image_hex.R

In palr: Colour Palettes for Data

#' Convert image data to a matrix of hex colours
#'
#' `image_hex()` turns numeric, integer, raw, logical, or character image data
#' into a character matrix of hex colours, ready for
#' [graphics::rasterImage()], writing to PNG/GeoTIFF, or use as a texture.
#' This is the colour engine shared with the 'ximage' package.
#'
#' Supported inputs are a matrix (palette mapping via 'col', 'breaks', 'zlim'),
#' a 3D array with 1 band (treated as a matrix), 2 bands (grey + alpha),
#' 3 bands (RGB), or 4 bands (RGBA), a raw matrix or array (converted to
#' integer), and a character matrix of colours (passed through, with NA
#' replaced by 'na.col').
#'
#' Behaviour guarantees:
#'
#' Non-finite values (NA, NaN, Inf) always map to 'na.col'. Colour scaling for
#' multi-band data is autodetected per image: data within [0, 1] is used
#' as-is, within [0, 255] is divided by 255, anything else is rescaled by the
#' finite range of the colour bands jointly (so hue relationships are
#' preserved); an alpha band is scaled independently. Constant (zero-range)
#' data maps to the middle of the palette. 'zlim' anchors the palette to an
#' absolute range and values outside it map to 'na.col'; 'zlim' is ignored
#' with a warning for multi-band input. 'alpha' is a constant (or recycled)
#' opacity multiplier in [0, 1] applied on top of any existing alpha.
#'
#' Use the stretch functions ([stretch_linear()] and friends) to normalize
#' high dynamic range data before colour mapping.
#'
#' @param x matrix or array of image data (see Details)
#' @param col colours to map to, a vector or a function
#' @param breaks numeric breakpoints for the colours
#' @param zlim absolute data range for the palette (single-band only)
#' @param alpha opacity multiplier in [0, 1]
#' @param na.col colour for missing values (default "transparent")
#'
#' @return character matrix of hex colours
#' @export
#'
#' @examples
#' m <- image_hex(volcano)
#' dim(m)
#' ## rgb array in 0, 255
#' arr <- array(c(volcano, volcano / 2, 255 - volcano), c(dim(volcano), 3L))
#' m <- image_hex(arr)
#' ## plot it
#' plot(NA, xlim = c(0, 1), ylim = c(0, 1), asp = 1)
#' rasterImage(image_hex(volcano, col = grDevices::hcl.colors(64)), 0, 0, 1, 1)
image_hex <- function(x, col = NULL, breaks = NULL, zlim = NULL,
                      alpha = NULL, na.col = "transparent") {
  if (is.raw(x)) {
    x <- array(as.integer(x), dim(x))
  }
  dm <- dim(x)
  if (is.null(dm) || length(dm) < 2L) {
    stop("'x' must be a matrix or an array with 2 or 3 dimensions")
  }
  if (length(dm) > 3L) {
    stop("arrays with more than 3 dimensions are not supported")
  }
  if (is.character(x)) {
    out <- matrix(x, dm[1L], dm[2L])
    out[is.na(out)] <- na.col
    return(.apply_alpha(out, alpha, na.col))
  }
  if (is.logical(x)) {
    x <- array(as.integer(x), dm)
  }
  if (!is.numeric(x)) {
    stop("'x' must be numeric, integer, raw, logical, or character")
  }
  nbands <- if (length(dm) == 2L) 1L else dm[3L]

  if (nbands == 1L) {
    if (length(dm) == 3L) x <- x[, , 1L, drop = TRUE]
    out <- .map_palette(x, col = col, breaks = breaks, zlim = zlim,
                        na.col = na.col)
    return(.apply_alpha(out, alpha, na.col))
  }

  if (!is.null(zlim)) {
    warning("'zlim' is ignored for multi-band (grey/alpha, RGB, RGBA) input")
  }
  if (nbands == 2L) {
    return(.greya_hex(x, alpha = alpha, na.col = na.col))
  }
  if (nbands %in% c(3L, 4L)) {
    return(.rgb_hex(x, alpha = alpha, na.col = na.col))
  }
  stop(sprintf("cannot interpret %i bands as image data (expected 1-4)",
               nbands))
}

## map a numeric matrix to hex colours through a palette
.map_palette <- function(x, col = NULL, breaks = NULL, zlim = NULL,
                         na.col = "transparent") {
  dm <- dim(x)
  vals <- as.vector(x)

  if (is.null(col)) col <- grDevices::hcl.colors(96L, "YlOrRd", rev = TRUE)
  if (is.function(col)) {
    col <- col(if (!is.null(breaks)) length(breaks) - 1L else 96L)
  }

  if (!is.null(zlim)) {
    zlim <- range(zlim)
    vals[vals < zlim[1L] | vals > zlim[2L]] <- NA_real_
  }
  ok <- is.finite(vals)
  if (!any(ok)) {
    return(matrix(na.col, dm[1L], dm[2L]))
  }

  if (is.null(breaks)) {
    rg <- if (!is.null(zlim) && all(is.finite(zlim))) zlim else range(vals[ok])
    if (!(diff(rg) > 0)) rg <- rg + c(-0.5, 0.5)  ## constant data
    breaks <- seq(rg[1L], rg[2L], length.out = length(col) + 1L)
  } else {
    breaks <- sort(breaks)
    if ((length(breaks) - 1L) != length(col)) {
      col <- grDevices::colorRampPalette(col)(length(breaks) - 1L)
    }
  }
  idx <- findInterval(vals, breaks, all.inside = TRUE)
  out <- col[idx]
  out[!ok] <- na.col
  matrix(out, dm[1L], dm[2L])
}

## autodetect the value convention of a band (or set of bands) and
## rescale to [0, 1]; non-finite values pass through untouched
.band_scale <- function(vals) {
  ok <- is.finite(vals)
  if (!any(ok)) return(rep(0, length(vals)))
  rg <- range(vals[ok])
  if (rg[1L] >= 0 && rg[2L] <= 1) {
    ## already 0,1
  } else if (rg[1L] >= 0 && rg[2L] <= 255) {
    vals <- vals / 255
  } else {
    if (!(diff(rg) > 0)) rg <- rg + c(-0.5, 0.5)
    vals <- (vals - rg[1L]) / diff(rg)
  }
  vals
}

## 3 or 4 band numeric array to hex
.rgb_hex <- function(x, alpha = NULL, na.col = "transparent") {
  dm <- dim(x)
  n <- dm[1L] * dm[2L]
  nbands <- dm[3L]

  bad <- !is.finite(x[, , 1L]) | !is.finite(x[, , 2L]) | !is.finite(x[, , 3L])
  a <- NULL
  if (nbands == 4L) {
    a <- as.vector(x[, , 4L])
    bad <- bad | !is.finite(x[, , 4L])
  }

  ## joint scaling of the colour bands preserves hue relationships
  rgbvals <- .band_scale(c(x[, , 1L], x[, , 2L], x[, , 3L]))
  rgbvals[!is.finite(rgbvals)] <- 0
  rgbvals <- pmin(pmax(rgbvals, 0), 1)
  r <- rgbvals[seq_len(n)]
  g <- rgbvals[n + seq_len(n)]
  b <- rgbvals[2L * n + seq_len(n)]

  if (is.null(a)) {
    a <- rep(1, n)
  } else {
    a <- .band_scale(a)
    a[!is.finite(a)] <- 0
  }
  a <- .combine_alpha(a, alpha, n)

  hex <- grDevices::rgb(r, g, b, a)
  hex[as.vector(bad)] <- na.col
  matrix(hex, dm[1L], dm[2L])
}

## 2 band numeric array (grey + alpha) to hex
.greya_hex <- function(x, alpha = NULL, na.col = "transparent") {
  dm <- dim(x)
  n <- dm[1L] * dm[2L]
  bad <- !is.finite(x[, , 1L]) | !is.finite(x[, , 2L])

  g <- .band_scale(as.vector(x[, , 1L]))
  g[!is.finite(g)] <- 0
  g <- pmin(pmax(g, 0), 1)

  a <- .band_scale(as.vector(x[, , 2L]))
  a[!is.finite(a)] <- 0
  a <- .combine_alpha(a, alpha, n)

  hex <- grDevices::rgb(g, g, g, a)
  hex[as.vector(bad)] <- na.col
  matrix(hex, dm[1L], dm[2L])
}

## multiply existing alpha by the user-supplied constant/matrix, clamp
.combine_alpha <- function(a, alpha, n) {
  if (!is.null(alpha)) {
    a <- a * rep(as.vector(alpha), length.out = n)
  }
  pmin(pmax(a, 0), 1)
}

## apply a constant alpha multiplier to an existing matrix of R colours,
## leaving 'na.col' cells untouched (missingness display is not modulated)
.apply_alpha <- function(hex, alpha, na.col = NULL) {
  if (is.null(alpha)) return(hex)
  dm <- dim(hex)
  keep <- if (is.null(na.col)) rep(FALSE, length(hex)) else hex == na.col
  vals <- hex
  vals[keep] <- "#00000000"  ## placeholder, restored below
  m <- grDevices::col2rgb(vals, alpha = TRUE) / 255
  a <- .combine_alpha(m[4L, ], alpha, ncol(m))
  out <- grDevices::rgb(m[1L, ], m[2L, ], m[3L, ], a)
  out[keep] <- na.col
  matrix(out, dm[1L], dm[2L])
}