#' colour_mat
#'
#' Generates a 2D matrix of graduated colours by interpolating between the given
#' colours specifying the four corners.
#'
#' @param cols vector of length >= 4 of colors (example, default = \code{rainbow
#' (4)}, or \code{RColorBrewer::brewer.pal (4, 'Set1')}).
#' \code{cols} are wrapped clockwise around the corners from top left to bottom
#' left.
#' @param n number of rows and columns of colour matrix (default = 10; if length
#' 2, then dimensions of rectangle).
#' @param rotate rotates the entire colour matrix by the specified angle (in
#' degrees).
#' @param plot plots the colour matrix.
#' @return \code{Matrix} of colours.
#'
#' @seealso \code{\link{add_osm_groups}}.
#'
#' @examples
#' cm <- colour_mat (n = 5, cols = rainbow (4), rotate = 90, plot = TRUE)
#'
#' # 'colour_mat' is intended primarily for use in colouring groups added with
#' # 'add_osm_groups' using the 'colmat = TRUE' option:
#' bbox <- get_bbox (c (-0.13, 51.5, -0.11, 51.52))
#' # Generate random points to serve as group centres
#' set.seed (2)
#' ngroups <- 6
#' x <- bbox [1, 1] + runif (ngroups) * diff (bbox [1, ])
#' y <- bbox [2, 1] + runif (ngroups) * diff (bbox [2, ])
#' groups <- cbind (x, y)
#' groups <- apply (groups, 1, function (i) {
#' sp::SpatialPoints (matrix (i, nrow = 1, ncol = 2))
#' })
#' # plot a basemap and add groups
#' map <- osm_basemap (bbox = bbox, bg = "gray20")
#' map <- add_osm_groups (map,
#' obj = london$dat_BNR, group = groups,
#' cols = rainbow (4), colmat = TRUE, rotate = 90
#' )
#' print_osm_map (map)
#' @family colours
#' @export
colour_mat <- function (cols, n = c (10, 10), rotate = NULL, plot = FALSE) {
# --------------- sanity checks and warnings ---------------
cols <- colourmat_input_cols (cols)
n <- colourmat_input_n (n)
rotate <- colourmat_input_rotate (rotate)
# --------------- end sanity checks and warnings ---------------
if (!is.null (rotate)) {
cols <- rotate_colourmat (cols, rotate)
}
tl <- cols [, 1] # top left
tr <- cols [, 2] # top right
br <- cols [, 3] # bottom right
bl <- cols [, 4] # bottom left
# Then interpolate, starting with top and bottom rows
ih <- t (array (seq (n [2]) - 1, dim = c (n [2], 3))) / (n [2] - 1)
top <- (1 - ih) * tl + ih * tr
bot <- (1 - ih) * bl + ih * br
arr <- array (NA, dim = n)
col_arrs <- list (r = arr, g = arr, b = arr)
for (i in seq (3)) {
col_arrs [[i]] [1, ] <- top [i, ]
col_arrs [[i]] [n [1], ] <- bot [i, ]
}
# Then fill intervening rows
indx <- (seq (n [1]) - 1) / (n [1] - 1)
for (i in seq (3)) {
col_arrs [[i]] <- apply (col_arrs [[i]], 2, function (x) {
(1 - indx) * x [1] + indx * tail (x, 1)
})
}
# Then fill the actual colourmat with RGB colours composed of the 3 indices:
carr <- array (rgb (col_arrs [[1]], col_arrs [[2]], col_arrs [[3]],
maxColorValue = 255
), dim = n)
if (plot) {
plot_colourmat (carr)
}
return (carr)
} # end function colour.mat
colourmat_input_cols <- function (cols) {
if (missing (cols)) stop ("cols must be provided")
if (is.null (cols)) {
return (NULL)
} else if (length (cols) < 4) {
stop ("cols must have length >= 4")
}
if (any (is.na (cols))) stop ("One or more cols is NA")
if (!methods::is (cols, "matrix")) {
cols <- sapply (cols, function (i) {
tryCatch (
col2rgb (i),
error = function (e) {
e$message <- paste0 ("Invalid colours: ", i)
}
)
})
} else if (rownames (cols) != c ("red", "green", "blue")) {
stop ("Colour matrix has unknown format")
}
if (any (grep ("Invalid colours", cols))) {
stop (cols [grep ("Invalid colours", cols) [1]])
}
indx <- floor (1:4 * ncol (cols) / 4)
indx [1] <- 1
cols <- cols [, indx]
return (cols)
}
colourmat_input_n <- function (n) {
if (length (n) == 1) {
n <- rep (n, 2)
}
if (!all (is.numeric (n))) stop ("n must be numeric")
if (any (is.na (n))) stop ("n can not be NA")
if (any (n < 2)) stop ("n must be > 1")
return (n)
}
colourmat_input_rotate <- function (rotate = NULL) {
if (!is.null (rotate)) {
if (length (rotate) > 1) {
warning ("rotate has length > 1; using only first element")
rotate <- rotate [1]
}
if (!is.numeric (rotate)) stop ("rotate must be numeric")
if (is.na (rotate)) stop ("rotate can not be NA")
}
return (rotate)
}
rotate_colourmat <- function (cols, rotate) {
# rotation generally lowers RGB values, so they are increased following
# rotation according to the following value:
max_int <- max (cols)
while (rotate < 0) {
rotate <- rotate + 360
}
while (rotate > 360) {
rotate <- rotate - 360
}
cols <- cbind (cols, cols)
# Clockwise rotation shifts the top left to the top right, meaning the
# index of four colours must move *down* or *to the left* of cols
i <- floor (rotate / 90) # number of columns to move
i1 <- 1:4 - i
if (min (i1) < 1) {
i1 <- i1 + 4
}
i2 <- i1 + 1
x <- (rotate %% 90) / 360
cols <- (1 - x) * cols [, i1] + x * cols [, i2]
cols <- apply (cols, 2, function (x) {
if (max (x) == 0) {
rep (0, 3)
} else {
x * max_int / max (x)
}
})
return (cols)
}
plot_colourmat <- function (carr) {
plot.new ()
par (mar = rep (0, 4))
plot (NULL, NULL,
xlim = c (0, dim (carr) [2]),
ylim = c (0, dim (carr) [1])
)
for (i in seq (dim (carr) [1])) {
for (j in seq (dim (carr) [2])) {
rect (j - 1, i - 1, j, i, col = carr [i, j])
}
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.