R/graphics.R

In davidearn/epigrowthfit: Nonlinear Mixed Effects Models of Epidemic Growth

##' Better Axis
##'
##' A replacement for \code{axis} allowing the user to define the
##' extent of the axis line.
##'
##' @param side,at,labels,\dots
##'   arguments to \code{axis}.
##' @param a,b
##'   lower and upper limits of the axis line in user coordinates.
##'   The default is to take limits from \code{par("usr")}.
##'
##' @return
##' A numeric vector identical to that returned by
##' \code{axis(side, at, labels, \dots)}.

baxis <-
function(side, a = NULL, b = NULL, at = NULL, labels = TRUE, ...) {
	dots <- list(...)
	if (is.null(a) || is.null(b)) {
		gp <- par("usr", "xlog", "ylog")
		if (side %% 2L == 1L) {
			usr <- gp[["usr"]][1:2]
			log <- gp[["xlog"]]
		}
		else {
			usr <- gp[["usr"]][3:4]
			log <- gp[["ylog"]]
		}
		if (log)
			usr <- 10^usr
		if (is.null(a))
			a <- usr[1L]
		if (is.null(b))
			b <- usr[2L]
	}
	args <- list(side = side, at = c(a, b), labels = c("", ""))
	do.call(axis, c(args, replace(dots, "lwd.ticks", list(0))))
	args <- list(side = side, at = at, labels = labels)
	do.call(axis, c(args, replace(dots, c("lwd", "lwd.ticks"), list(0, dots[["lwd.ticks"]]))))
}

##' Date Axis
##'
##' Adds an axis to the current plot and labels it with day, month,
##' and year, taking care to ensure that labels are nicely spaced.
##'
##' @param side
##'   an integer indicating a side of the plot on which to draw the
##'   axis, passed to \code{axis}.
##' @param origin
##'   a \code{Date} vector of length 1.  Horizontal user coordinates
##'   measure time as a number of days since \code{julian(origin)}
##'   days after 1970-01-01 00:00:00.
##' @param minor,major
##'   named lists of arguments to \code{axis}, affecting the appearance
##'   of the minor (day or month) and major (month or year) axes,
##'   respectively.  \code{NULL} suppresses the corresponding axis.
##'
##' @return
##' A list of numeric vectors \code{minor} and \code{major} giving
##' the positions of minor and major axis labels in user coordinates.

Daxis <-
function(side, origin = .Date(0), minor = list(), major = list()) {
	usr <- origin + par("usr")[if (side %% 2L == 1L) 1:2 else 3:4]
	D0 <- min(.ceiling.Date(usr[1L]), .floor.Date(usr[2L]))
	D1 <- max(.ceiling.Date(usr[1L]), .floor.Date(usr[2L]), D0 + 1)
	t0 <- julian(D0, origin = origin)
	t1 <- julian(D1, origin = origin)
	delta <- t1 - t0

	## Determine tick coordinates and labels
	if (delta <= 210) {
		## Days
		by <- c(1, 2, 4, 7, 14)[delta <= c(14, 28, 56, 112, 210)][1L]
		minor.at.Date <- seq(D0, D1, by = by)
		minor.at <- julian(minor.at.Date, origin = D0)
		minor.labels <- ymd(minor.at.Date, "d")

		## Months
		if (ymd(D0, "m") == ymd(D1, "m")) {
			major.at.Date <- D0
			major.at <- 0
		}
		else {
			major.at.Date <- seq(.ceiling.Date(D0, "m"), D1, by = "m")
			major.at <- julian(major.at.Date, origin = D0)
			if (major.at[1L] > delta / 8) {
				major.at.Date <- c(D0, major.at.Date)
				major.at <- c(0, major.at)
			}
		}
		major.labels <- months(major.at.Date, abbreviate = TRUE)
	}
	else if (delta <= 3 * 365) {
		## Months
		by <- c(1L, 2L, 3L)[delta <= c(1, 2, 3) * 365][1L]
		minor.at.Date <- seq(.ceiling.Date(D0, "m"), D1, by = paste(by, "m"))
		minor.at <- julian(minor.at.Date, origin = D0)
		minor.labels <- months(minor.at.Date, abbreviate = TRUE)

		## Years
		if (ymd(D0, "y") == ymd(D1, "y")) {
			major.at.Date <- D0
			major.at <- 0
		}
		else {
			major.at.Date <- seq(.ceiling.Date(D0, "y"), D1, by = "y")
			major.at <- julian(major.at.Date, origin = D0)
			if (major.at[1L] > delta / 8) {
				major.at.Date <- c(D0, major.at.Date)
				major.at <- c(0, major.at)
			}
		}
		major.labels <- ymd(major.at.Date, "y")
	}
	else {
		## Years
		by <- ceiling(ceiling(delta / 365) / 7)
		minor.at.Date <- seq(.ceiling.Date(D0, "y"), D1 + (by + 1) * 365, by = paste(by, "y"))
		minor.at <- julian(minor.at.Date, origin = D0)
		minor.labels <- ymd(minor.at.Date, "y")
		minor.at <- c(minor.at, 0.5 * (minor.at[-1L] + minor.at[-length(minor.at)]))
		length(minor.labels) <- length(minor.at)

		major.at <- double(0L)
		major <- NULL
	}

	if (!is.null(minor)) {
		args <- list(side = side, at = t0 + minor.at, labels = minor.labels)
		do.call(baxis, c(args, minor))
	}
	if (!is.null(major)) {
		args <- list(side = side, at = t0 + major.at, labels = major.labels)
		do.call(baxis, c(args, major))
	}
	list(minor = t0 + minor.at, major = t0 + major.at)
}

##' Scientific Labels for Axis Ticks
##'
##' Generates nice \code{"mantissa x 10^power"} labels for axis ticks,
##' at least for count data.
##'
##' @param at
##'   a double vector listing tick positions in user coordinates,
##'   probably generated by \code{\link{axTicks}}.
##'
##' @return
##' an expression vector of length \code{length(at)} listing tick labels.

get_scientific_labels <-
function(at) {
	## Exponential notation split into mantissa and power
	mp <- matrix(unlist1(strsplit(sprintf("%.6e", at), "e")),
	             ncol = 2L, byrow = TRUE)

	## Greatest number of digits after mantissa decimal,
	## ignoring trailing zeros
	digits <- max(nchar(sub("0+$", "", mp[, 1L]))) - 2L

	## Mantissa reformatted with exactly 'digits' digits after decimal
	man <- sprintf("%.*e", digits, as.double(mp[, 1L]))
	man. <- as.double(man)

	## Power reformatted without leading zeros
	pow <- as.character(as.double(mp[, 2L]))

	## Format nonzero labels as "mantissa x 10^power".
	## Shorten to "10^power" if nonzero mantissas are all 1.
	## Use "0" if mantissa is 0.
	replace(if (all(man. == 0 | man. == 1))
	        	parse(text = sprintf("10^%s", pow))
	        else parse(text = sprintf("%s %%*%% 10^%s", man, pow)),
	        at == 0,
	        expression(0))
}

##' Space-Filling Character Expansion
##'
##' Finds the character expansion factor (what is multiplied by
##' \code{par("cex")} to obtain the actual magnification) necessary
##' for text to span a given width or height.
##'
##' @param text
##'   a character or expression vector.  Only the element with
##'   the greatest width or height is used to calculate the result.
##' @param target
##'   a positive number indicating a target width or height.
##' @param units
##'   a character string indicating the units of \code{target}.
##' @param horizontal
##'   a logical.  If \code{TRUE}, then \code{target} represents
##'   a width rather than a height.
##' @param \dots
##'   graphical parameters passed to \code{strwidth} or \code{strheight}.
##'
##' @return
##' A positive number.

get_sfcex <-
function(text, target, units = c("lines", "inches", "user"),
         horizontal = TRUE, ...) {
	if (length(text) == 0L)
		return(1)
	measure <- if (horizontal) strwidth else strheight
	current <- max(measure(text, units = "inches", ...))
	if (current == 0)
		return(1)
	convert <- if (horizontal) grconvertX else grconvertY
	target <- target * diff(convert(c(0, 1), match.arg(units), "inches"))
	target / current
}

##' Modify Colour Transparency
##'
##' @param col
##'   a numeric or character vector listing colours;
##'   see \code{\link{col2rgb}}.
##' @param alpha
##'   a numeric vector with elements in the interval \eqn{[0,1]}
##'   listing alpha channel values.
##'
##' @return
##' A character vector listing colours with indicated transparency.

alpha <-
function(col, alpha) {
	m <- t(col2rgb(col = col, alpha = FALSE))
	rgb(m[, 1:3, drop = FALSE], alpha = 255 * alpha, maxColorValue = 255)
}