#' @import methods
NULL
#' @importFrom magrittr "%>%"
#' @export "%>%"
NULL
#' @importFrom scales alpha
#' @export alpha
NULL
### aide d'typing
###
#' Unquited character concatenation
#'
#' Allows character strings to be concatenated without quotes, unless
#' the string itself is a non-standard R name
#'
#' @param ... names, normally unquoted, used as strings to be concatenated. Strings must be quoted if non-standard R names.
#'
#' @return A character string vector
#' @export
#'
#' @examples
#' vars <- cq(alpha, beta, gamma, "_delta_")
cq <- function(...) { ## quoted concatenation: any non-standard name must be in "..."
as.character(sys.call()[-1])
}
#' Check colour string
#'
#' Check if character strings can be used as colour specifications
#'
#' @param x A character string vector
#'
#' @return A logical vector indicating validity
#' @export
#'
#' @examples
#' is.colour(c("dark grey", "horrible yellow", 1))
#' is.colour(1)
is.colour <- function(x) {
if(is.character(x)) {
sapply(x, function(x) !inherits(try(col2rgb(x), silent = TRUE), "try-error"))
} else {
structure(FALSE, names = class(x))
}
}
#' @rdname is.colour
#' @export
is.color <- is.colour
## Miscellaneous bits and pieces of general usefulness
##
#' Colour palette functions
#'
#' @param n desired number of colours
#'
#' @return character string vector of colour strings
#' @name palettes
#' @examples
#' barplot(1:15, fill = pal_sea2sand, colour = "red", axes = FALSE) -> bp
#' z <- complex(real = bp,imaginary = seq_along(bp))
#' points(z, xpd = NA)
#' arrows(z[-length(z)], z[-1], gap = 1.5, col = "black")
#' labels <- c("sea", gsub(" ", "0", format(2:14)), "sand")
#' text(z, labels, pos = 3, xpd = NA, col = pal_blue2red(15))
NULL
#' @rdname palettes
#' @export
pal_cool <- colorRampPalette(c("#FFFFBFFF", "#FFFF40FF", "#FFFF00FF", "#FFCC00FF",
"#FF9900FF", "#FF6600FF", "#FF3300FF", "#FF0000FF"))
#' @rdname palettes
#' @export
pal_heat_hcl <- colorRampPalette(c("#D33F6A", "#D54865", "#D85161", "#DB595C", "#DD6157", "#DF6852",
"#E1704C", "#E37747", "#E57E41", "#E6853B", "#E78C36", "#E89330",
"#E99A2C", "#E9A129", "#EAA828", "#EAAF29", "#E9B62D", "#E9BD34",
"#E8C33C", "#E7CA45", "#E6D050", "#E5D75D", "#E4DD6B", "#E3E37C",
"#E2E6BD"))
#' @rdname palettes
#' @export
pal_cool_hcl <- colorRampPalette(c("#E2E6BD", "#E3E37C", "#E4DD6B", "#E5D75D", "#E6D050", "#E7CA45",
"#E8C33C", "#E9BD34", "#E9B62D", "#EAAF29", "#EAA828", "#E9A129",
"#E99A2C", "#E89330", "#E78C36", "#E6853B", "#E57E41", "#E37747",
"#E1704C", "#DF6852", "#DD6157", "#DB595C", "#D85161", "#D54865",
"#D33F6A"))
#' @rdname palettes
#' @export
pal_pastels <- colorRampPalette(c("#A7FF7E", "#45FFB2", "#00FFE4", "#00FFFF", "#00FFFF",
"#86FBFF"))
#' @rdname palettes
#' @export
pal_blue2red <- colorRampPalette(c("steel blue", "beige", "orange red"))
#' @rdname palettes
#' @export
pal_sea2sand <- colorRampPalette(c("cadet blue", "lemon chiffon", "sandy brown"))
#' @rdname palettes
#' @export
pal_desert <- colorRampPalette(c("dark green", "dark sea green", "#FFDD74",
"sandy brown", "saddle brown"))
#' @rdname palettes
#' @export
pal_green2brown <- colorRampPalette(c("#418A78", "#548F98", "#6899B1", "#79A7C5",
"#89B6D2", "#ECEBA4", "#F2E27F", "#F6D054",
"#FAAC2F", "#FC7115"))
#' @rdname palettes
#' @export
pal_green2pink <- colorRampPalette(c(`Jungle green` = "#29AB87", `Neon carrot` = "#FFA343",
`Neon fuchsia` = "#FE4164", `Deep pink 4` = "#8B0A50"))
#' @rdname palettes
#' @export
pal_grey <- function(n) {
rev(grDevices::grey.colors(n))
}
#' @rdname palettes
#' @export
pal_gray <- function(n) {
rev(grDevices::grey.colors(n))
}
#' @rdname palettes
#' @export
pal_namatjira <- colorRampPalette(c("#D8F0F0FF", "#786060FF",
"#D8C0A8FF", "#A86030FF",
"#A890A8FF", "#486090FF",
"#A89078FF", "#F0A860FF"))
#' @rdname palettes
#' @export
pal_dark_rainbow <- colorRampPalette(c("#ff0000", # red =
"#ffa500", # orange =
"#ffff00", # yellow =
"#008000", # green =
"#0000ff", # blue =
"#4b0082", # indigo =
"#ee82ee")) # violet = ## added 2021-01-26
#' Extended colour sets
#'
#' Search an extended database for more colours using a regular
#' expression on their given names
#' @param description A regular expression fot the colour name
#' @param database Either \code{"Set1"} (the default) or \code{"Set2"}.
#' @param ignore.case Logical. Should case be ignored in the \code{description}?
#'
#' @return A vector of colours matching the \code{description}, or \code{character(0)}.
#' @export
#'
#' @examples
#' getColors("french") ## Any colour names with "French" as a component.
getColors <- function(description, database = c("Set1", "Set2", "set1", "set2", "1", "2"),
ignore.case = TRUE) {
stopifnot(is.character(description) && length(description) == 1)
database <- as.character(database)
database <- match.arg(database)
choices <- c("Set1" = "Set1", "Set2" = "Set2",
"set1" = "Set1", "set2" = "Set2",
"1" = "Set1", "2" = "Set2")
database <- choices[database]
with(get(database), {
k <- grep(description, Color, ignore.case = ignore.case)
if(length(k) == 0)
return(character())
structure(Hex[k], names = Color[k])
})
}
#' @rdname getColors
#' @export
getColours <- getColors
#' Complex vector property replacement functions
#'
#' @param x a complex vector to be altered
#' @param value the numerical value vector to be used in the alteration
#'
#' @return An appropriately modified complex vector
#' @name complexReplacement
NULL
#' @rdname complexReplacement
#' @export
`Re<-` <- function(x, value) {
do.call(structure,
c(list(complex(real = value, imaginary = Im(as.complex(x)))), attributes(x)))
}
#' @rdname complexReplacement
#' @export
`Im<-` <- function(x, value) {
do.call(structure,
c(list(complex(real = Re(as.complex(x)), imaginary = value)), attributes(x)))
}
#' @rdname complexReplacement
#' @export
`Mod<-` <- function(x, value) {
do.call(structure,
c(list(complex(modulus = value, argument = Arg(as.complex(x)))), attributes(x)))
}
#' @rdname complexReplacement
#' @export
`Arg<-` <- function(x, value) {
do.call(structure,
c(list(complex(modulus = Mod(as.complex(x)), argument = value)), attributes(x)))
}
### cycle function
#' Circular cycle function
#'
#' Permute the components of a vector or vector-like object in a circular pattern
#'
#' @param z Any object with indexed components
#' @param k integer. The number of steps to cycle: positive: first-to-last, negative: last-to-first
#'
#' @return a structure similar to \code{z} with its components re-ordered by cycling
#' @export
#'
#' @examples
#' cyc(letters, -3)
cyc <- function(z, k = 1) {
stopifnot(is.numeric(k) && length(k) == 1)
if(k == 0)
return(z)
m <- ifelse(k > 0, 1, -length(z))
for(j in seq_len(abs(k) %% length(z)))
z <- c(z[-m], z[m])
z
}
#' Bivariate medians
#'
#' @param x,y any of the known ways to specify bivariate points in traditional graphics
#' @param na.rm logical: should any missing values be removed prior to the computation?
#'
#' @return a complex number giving the bivariate median as its real and complex parts
#' @name bivariateMedian
NULL
#' @rdname bivariateMedian
#' @export
coordinateMedian <- function(x, y = NULL, na.rm = FALSE) {
with(grDevices::xy.coords(x, y), {
if(na.rm)
if(any(k <- is.na(x) | is.na(y))) {
x <- x[!k]
y <- y[!k]
}
complex(real = median(x), imaginary = median(y))
})
}
#' @rdname bivariateMedian
#' @export
spatialMedian <- function(x, y=NULL, na.rm = FALSE) {
z <- with(grDevices::xy.coords(x, y), complex(real = x, imaginary = y))
if(na.rm) z <- na.omit(z)
fun <- function(theta)
sum(Mod(z - complex(real = theta[1], imaginary = theta[2])))
t0 <- c(median(Re(z)), median(Im(z)))
with(optim(t0, fun, method = "BFGS"),
complex(real = par[1], imaginary = par[2]))
}
#' @rdname bivariateMedian
#' @export
ojaMedian <- function(x, y = NULL, na.rm = FALSE) {
xy <- grDevices::xy.coords(x, y, recycle = TRUE)[c("x", "y")]
if(na.rm) xy <- na.omit(as.data.frame(xy))
B <- with(xy, {
ij <- utils::combn(length(x), 2)
x1 <- x[ij[1,]]
x2 <- x[ij[2,]]
y1 <- y[ij[1,]]
y2 <- y[ij[2,]]
cbind(x1*y2 - x2*y1, -(y2 - y1), (x2 - x1))
})
oja <- function(M)
sum(abs(B %*% c(1, M)))
M0 <- sapply(xy, median)
with(optim(M0, oja, method = "BFGS"),
complex(real = par[1], imaginary = par[2]))
}
#' Display colours in a collection
#'
#' @param fill either a palette function or a vector of colours to display
#' @param ... additional arguments passed on to methods
#' @param border,colour,color alternative names to use for the colour of the borders
#' @param edges integer: no of edges to use for the inner circle
#' @param radius numeric: value to use for the radius of the circular display
#' @param ... arguments to be passed on to methods
#' @param n number of colours to use for a palette display
#'
#' @return the vector of colours used in the display, invisibly.
#' @export
#'
#' @examples
#' showColors(pal_desert)
#' pal <- myPalette(pink, beige, 'sky blue')
#' showColours(pal)
#' showColours(pal, n = 50)
showColors <- function (fill, ...) {
UseMethod("showColors")
}
#' @rdname showColors
#' @export
showColors.default <- function(fill,
labels = if(length(fill) <= 25) {
if(!is.null(names(fill)))
names(fill) else fill
} else NA,
border = colour,
colour = color,
color = if(length(fill) <= 20) "grey" else
"transparent",
edges = 1000, radius = 1, ...,
n = length(fill)) {
oldPar <- par(bg = "white", mar = rep(1,4))
on.exit(par(oldPar))
if(length(fill) == 0) {
fill <- structure("white", names = " ")
}
v <- rep(1, length(fill))
pie(v, col = fill, labels = labels, edges = edges,
radius = radius, border = border, ...)
z <- complex(modulus = 0.3*radius,
argument = seq(-pi, pi, length=edges))
polygon(z, col = par("bg"))
invisible(fill)
}
#' @rdname showColors
#' @export
showColors.function <- function (fill, ..., n = 20) {
fill <- structure(fill(n),
names = paste0(abbreviate(deparse(substitute(fill))),
"_", gsub(" ", "0", format(1:n))))
NextMethod()
}
#' @rdname showColors
#' @export
showColours <- showColors
#' Generate a colour palette
#'
#' @param ... colour names for the palette, possibly unquoted
#'
#' @return a colour palette function
#' @export
#'
#' @examples
#' pal <- myPalette(pink, beige, 'sky blue')
#' showColours(pal, n = 50)
myPalette <- function(...) {
colorRampPalette(as.character(sys.call()[-1]))
}
#' Surface colours for rgl
#'
#' Generate colours for use in a surface display with package rgl
#'
#' @param z A numeric matrix of heights
#' @param pal a colour palette to use
#' @param no the number of colours to use
#' @param col,fill Alternative names for the colours to use
#'
#' @return a colour vector suitable for use with rgl surface displays
#' @export
#'
#' @examples
#' cols <- rglColors(volcano)
rglColors <- function(z, pal = pal_pastels, no = length(unique(z)),
col = fill, fill = pal(no)) {
fill[1 + floor((z-min(z))/diff(range(z))*length(col))]
}
#' Surface colours for perspective plots
#'
#' Generates a suitable colour vector for use with \code{graphics::persp}
#'
#' @param z matrix or list structure to specify surface
#' @param pal a palette function to use
#' @param no the number of colours to use
#' @param col,fill alternative names for the vector of colours
#' @param rgl logical: should \code{rgl} protocols be used rather than \code{persp}?
#' @param ... additional arguments passed on to methods (currently not used)
#'
#' @return a suitable vector of colours
#' @export
#'
#' @examples
#' cols <- surfaceColors(volcano, pal = pal_blue2red)
surfaceColors <- function(z, ...) {
UseMethod("surfaceColors")
}
#' @rdname surfaceColors
#' @export
surfaceColors.list <- function(z, ...)
if("z" %in% names(z) && is.matrix(z$z)) {
surfaceColors(z$z, ...)
} else {
stop("no matrix component named 'z' found")
}
#' @rdname surfaceColors
#' @export
surfaceColors.matrix <- function(z,
pal = colorRampPalette(c("steel blue",
"beige", "orange red")),
no = min(250, length(unique(z))),
col = fill, fill = pal(no), rgl = FALSE, ...) {
nr <- nrow(z)
nc <- ncol(z)
if(rgl) {
matrix(col[cut(z, length(col), include.lowest = TRUE, labels = FALSE)],
nr, nc)
} else {
az <- z[-1, -1] + z[-1, -nc] + z[-nr, -1] + z[-nr, -nc]
matrix(col[cut(az, length(col), include.lowest = TRUE, labels = FALSE)],
nr - 1, nc - 1)
}
}
#' @rdname surfaceColors
#' @export
surfaceColours <- surfaceColors
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.