R/z_utilities.R

In benja0x40/Barbouille: Visualisation of empirical distributions

# COMMON #######################################################################

# =============================================================================.
#' Localise safe numeric observations (i.e. not NA, NaN, Inf)
# -----------------------------------------------------------------------------.
#' @seealso
#'   \link{is.finite}
# -----------------------------------------------------------------------------.
#' @param x
#' numeric vector or matrix.
#'
#' @return
#' \code{FiniteValues} returns a logical vector.
# -----------------------------------------------------------------------------.
#' @keywords internal
#' @export
FiniteValues <- function(x) {

  x <- is.finite(x)

  if(! is.null(dim(x))) {
    # x <- Rfast::rowsums(x, parallel = TRUE) == ncol(x)
    x <- matrixStats::rowSums2(x) == ncol(x)
  }

  x
}

# =============================================================================.
#' Rescale x linearly into [0, 1]
# -----------------------------------------------------------------------------.
#' @seealso
#'   \link{RankScore},
#'   \link{SX2Y}
# -----------------------------------------------------------------------------.
#' @description
#' rescale values linearly to the unit interval.
#'
#' @param x
#' numeric vector or matrix.
#'
#' @return
#' \code{S01} returns x linearly rescaled such that range(x) = [0, 1].
# -----------------------------------------------------------------------------.
#' @keywords internal
#' @export
S01 <- function(x) {
  (x - min(x)) / diff(range(x))
}

# =============================================================================.
#' SX2Y
# -----------------------------------------------------------------------------.
#' @seealso
#'   \link{RankScore},
#'   \link{S01}
# -----------------------------------------------------------------------------.
#' @description
#' rescale x values linearly to match the range of y.
#'
#' @param x
#' numeric vector.
#'
#' @param y
#' numeric vector.
#'
#' @return
#' \code{SX2Y} returns x rescaled such that range(x) = range(y).
# -----------------------------------------------------------------------------.
#' @keywords internal
#' @export
SX2Y <- function(x, y) {
  S01(x) * diff(range(y)) + min(y)
}

# =============================================================================.
#' Rescale x non-linearly into ]0, 1[
# -----------------------------------------------------------------------------.
#' @seealso
#'   \link{S01},
#'   \link{SX2Y}
# -----------------------------------------------------------------------------.
#' @description
#' rescale values non-linearly to the unit interval using rank scores \eqn{q}
#' given by \eqn{q = (rank(x) - 0.5) / N} where \eqn{N} = length(x).
#'
#' @param x
#' numeric vector.
#'
#' @return
#' \code{RankScore} returns a numeric vector of rank scores.
# -----------------------------------------------------------------------------.
#' @keywords internal
#' @export
RankScore <- function(x) {
  d <- dim(x)
  n <- colnames(x)
  x <- (rank(x) - 0.5) / length(x)
  if(! is.null(d)) x <- array(x, dim = d)
  if(! is.null(n)) colnames(x) <- n
  x
}



# HIDDEN #######################################################################

# =============================================================================.
#' Quick and dirty color mapping
# -----------------------------------------------------------------------------.
#' @seealso
#'   \link{autoscale},
#'   \link{AutoColorParameters},
#'   \link{ColorLegend}
# -----------------------------------------------------------------------------.
#' @inheritParams autoscale
#' @inheritParams AutoColorParameters
#'
#' @param clr.prm
#' a ColorParameter object defined by \link{DefineColorMap}.
#'
#' @param ...
#' optional arguments forwarded to the \link{AutoColorParameters} function.
#'
#' @return
#' \code{colorize} returns a vector of RGBA colors.
# -----------------------------------------------------------------------------.
#' @keywords internal
#' @export
colorize <- function(x, mode = NULL, clr.prm = NULL, ...) {

  if(is.null(clr.prm)) clr.prm <- AutoColorParameters(...)
  clr <- MakeColors(autoscale(x, mode = mode), parameters = clr.prm)

  clr
}

# =============================================================================.
#' As the name suggests...
# -----------------------------------------------------------------------------.
#' @param axes
#' logical, show axes (default = TRUE, yes)
#'
#' @param xlab
#' character, name of the horizontal axis (default = none).
#'
#' @param ylab
#' character, name of the vertical axis (default = none).
#'
#' @param ...
#' optional arguments forwarded to the \link{plot.default} function.
#'
#' @return NULL
# -----------------------------------------------------------------------------.
#' @keywords internal
#' @export
EmptyPlot <- function(axes = TRUE, xlab = '', ylab = '', ...) {
  # plot(0, 0, type='n', bty='n', xaxt='n', yaxt='n')
  graphics::plot.default(
    0, type = 'n', axes = axes, xlab = xlab, ylab = ylab, ...
  )
}

# =============================================================================.
#' Plot a matrix of colors
# -----------------------------------------------------------------------------.
#' @param m
#' matrix of color values.
#'
#' @param x
#' coordinates of the x axis bins.
#'
#' @param y
#' coordinates of the y axis bins.
#'
#' @return NULL
# -----------------------------------------------------------------------------.
#' @keywords internal
#' @export
PlotImage <- function(m, x = NULL, y = NULL, ...) {
  image(
    x = x,
    y = y,
    z = matrix(1:length(m), nrow(m), ncol(m)),
    col = m, ...
  )
}

# =============================================================================.
#' Make plot limits including space for legends
# -----------------------------------------------------------------------------.
#' @param x
#' numeric vector or matrix with two columns.
#'
#' @param y
#' numeric vector (default = NULL).
#'
#' @param symetric
#' logical (default = FALSE, no)
#'
#' @param spacing
#' numeric.
#'
#' @param margin
#' numeric.
#'
#' @return
#' \code{xylim} returns a list.
# -----------------------------------------------------------------------------.
#' @keywords internal
#' @export
xylim <- function(x, y = NULL, symetric = FALSE, spacing = 0, margin = 0) {

  if(is.null(y)) {
    y <- x[, 2]
    x <- x[, 1]
  }

  xlim <- range(x[FiniteValues(x)])
  ylim <- range(y[FiniteValues(y)])
  if(symetric) {
    xlim <- ylim <- range(xlim, ylim)
  }

  spacing <- rep(spacing, length.out = 2)
  margin  <- rep(margin,  length.out = 2)

  sgn <- sign(spacing)
  spacing <- abs(spacing)

  xlim <- xlim * (1 + spacing[1]) + sgn[1] * diff(xlim) * spacing[1] / 2
  ylim <- ylim * (1 + spacing[2]) + sgn[2] * diff(ylim) * spacing[2] / 2

  xlim <- xlim * (1 + margin[1])
  ylim <- ylim * (1 + margin[2])

  list(x = xlim, y = ylim)
}

# =============================================================================.
#' As the name suggests...
# -----------------------------------------------------------------------------.
#' @seealso
#'   \link{colorize},
#'   \link{S01},
#'   \link{RankScore}
# -----------------------------------------------------------------------------.
#' @param x
#' numeric vector.
#'
#' @param mode
#' either \code{"rank"} or \code{"01"} (default).
#'
#' @return
#' \code{autoscale} returns a numeric vector.
# -----------------------------------------------------------------------------.
#' @keywords internal
#' @export
autoscale <- function(x, mode = NULL) {

  if(is.null(mode)) mode <- "01"

  if(mode == "rank") {
    x <- RankScore(x)
  }

  if(mode == "01") {
    x <- S01(x)
    # => prevent use of the "above" color
    x <- x * (1 - .Machine$double.neg.eps)
  }

  x
}

# =============================================================================.
#' Quick and dirty color mapping parameters
# -----------------------------------------------------------------------------.
#' @seealso
#'   \link{colorize},
#'   \link{DefineColorMap}
# -----------------------------------------------------------------------------.
#' @param colors
#' vector of colors (optional).
#'
#' @return
#' \code{AutoColorParameters} returns a ColorParameters object.
# -----------------------------------------------------------------------------.
#' @keywords internal
#' @export
AutoColorParameters <- function(colors = NULL) {

  # W, B, G => white, black, grey
  # r, g, b => red, green, blue
  # c, m, y => cyan, magenta, yellow

  if(is.null(colors)) colors <- grey(c(0.8, 0.7, 0.5, 0))

  chk <- length(colors) == 1
  if(chk & colors[1] == "WB") colors <- grey(1:0)
  if(chk & colors[1] == "BW") colors <- grey(0:1)

  if(chk & colors[1] == "rW") colors <- c(grey(c(0.8, 0.4)), rgb(1:1, 0:1, 0:1))
  if(chk & colors[1] == "gW") colors <- c(grey(c(0.8, 0.4)), rgb(0:1, 1:1, 0:1))
  if(chk & colors[1] == "bW") colors <- c(grey(c(0.8, 0.4)), rgb(0:1, 0:1, 1:1))

  if(chk & colors[1] == "Br") colors <- c(grey(c(0.8, 0.5, 0.2)), rgb(1, 0, 0))
  if(chk & colors[1] == "Bg") colors <- c(grey(c(0.8, 0.5, 0.2)), rgb(0, 1, 0))

  if(chk & colors[1] == "Bc") colors <- c(grey(c(0.8, 0.5, 0.2)), rgb(0, 1, 1))
  if(chk & colors[1] == "Bm") colors <- c(grey(c(0.8, 0.5, 0.2)), rgb(1, 0, 1))
  if(chk & colors[1] == "By") colors <- c(grey(c(0.8, 0.5, 0.2)), rgb(1, 1, 0))

  if(chk & colors[1] == "ry") colors <- c(grey(c(0.8, 0.4)), rgb(1:1, 0:1, 0:0))
  if(chk & colors[1] == "yr") colors <- c(grey(c(0.8, 0.4)), rgb(1:1, 1:0, 0:0))

  if(chk & colors[1] == "gy") colors <- c(grey(c(0.8, 0.4)), rgb(0:1, 1:1, 0:0))
  if(chk & colors[1] == "yg") colors <- c(grey(c(0.8, 0.4)), rgb(1:0, 1:1, 0:0))

  if(chk & colors[1] == "bc") colors <- c(grey(c(0.8, 0.4)), rgb(0:0, 0:1, 1:1))
  if(chk & colors[1] == "cb") colors <- c(grey(c(0.8, 0.4)), rgb(0:0, 1:0, 1:1))

  n <- length(colors)
  q <- 0:(n-1)/(n-1)

  if(chk & colors[1] == "Wry") {
    colors <- c(
      grey(c(1.0, 0.9, 0.4)), rgb(1, 0, 0), rgb(1, 0.5, 0), rgb(1, 1, 0.5)
    )
    n <- 5
    q <- c(0, 0.01, 1:(n-1)/(n-1))
  }
  if(chk & colors[1] == "Wgy") {
    colors <- c(
      grey(c(1.0, 0.9, 0.4)), rgb(0, 1, 0), rgb(0.5, 1, 0.5), rgb(1, 1, 0.5)
    )
    n <- 5
    q <- c(0, 0.01, 1:(n-1)/(n-1))
  }
  if(chk & colors[1] == "WGy") {
    colors <- c(
      grey(c(1.0, 0.9, 0.4)), rgb(0.3, 0.3, 0.1), rgb(0.8, 0.8, 0.2), rgb(1, 1, 0.5)
    )
    n <- 5
    q <- c(0, 0.01, 1:(n-1)/(n-1))
  }
  if(chk & colors[1] == "Wbc") {
    colors <- c(
      grey(c(1.0, 0.9, 0.4)), rgb(0, 0, 1), rgb(0.5, 0.5, 1), rgb(0.5, 1, 1)
    )
    n <- 5
    q <- c(0, 0.01, 1:(n-1)/(n-1))
  }
  if(chk & colors[1] == "WBW") {
    colors <- grey(c(1.0, 0.9, 0.3, 0.5, 0.7, 0.9))
    n <- 5
    q <- c(0, 0.01, 1:(n-1)/(n-1))
  }
  if(chk & colors[1] == "WGB") {
    colors <- grey(c(1.0, 0.9, 0.5, 0.3, 0))
    n <- 4
    q <- c(0, 0.01, 1:(n-1)/(n-1))
  }
  DefineColorMap(thresholds = q, colors = colors)
}

# NOT EXPORTED #################################################################

# =============================================================================.
#' ** RESERVED FOR INTERNAL USE **
# -----------------------------------------------------------------------------.
#' @description
#' Compute legend coordinates
# -----------------------------------------------------------------------------.
#' @keywords internal
#' @export
resolve.legend.position <- function(pos) {
  p <- c(-1, 0, 1)
  p <- data.frame(
    id = c("bl", "b", "br", "l", "c", "r", "tl", "t", "tr"),
    name = "", x = rep(p, 3), y = p[gl(3, 3)], stringsAsFactors = FALSE
  )
  p$name <- c(
    "bottomleft", "bottom", "bottomright", "left", "center", "right",
    "topleft", "top", "topright"
  )
  if(pos %in% p$id)   pos <- match(pos, p$id)
  if(pos %in% p$name) pos <- match(pos, p$name)
  if(! (is.numeric(pos) & length(pos) == 1 & pos > 0 & pos < 10)) {
    stop("Unknown pos value")
  }
  p <- p[pos,]
  p
}