|
|
|
"%||%" <- function(a, b) {
|
|
|
|
if (!is.null(a)) a else b
|
|
|
|
}
|
|
|
|
|
|
|
|
"%|W|%" <- function(a, b) {
|
|
|
|
if (!is.waive(a)) a else b
|
|
|
|
}
|
|
|
|
|
|
|
|
is.waive <- function(x) inherits(x, "waiver")
|
|
|
|
|
|
|
|
# Compute central angle between two points.
|
|
|
|
# Multiple by radius of sphere to get great circle distance
|
|
|
|
# @arguments longitude
|
|
|
|
# @arguments latitude
|
|
|
|
dist_central_angle <- function(lon, lat) {
|
|
|
|
# Convert to radians
|
|
|
|
lat <- lat * pi / 180
|
|
|
|
lon <- lon * pi / 180
|
|
|
|
|
|
|
|
hav <- function(x) sin(x / 2) ^ 2
|
|
|
|
ahav <- function(x) 2 * asin(x)
|
|
|
|
|
|
|
|
n <- length(lat)
|
|
|
|
ahav(sqrt(hav(diff(lat)) + cos(lat[-n]) * cos(lat[-1]) * hav(diff(lon))))
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
expand_default <- function(scale, discrete = c(0, 0.6), continuous = c(0.05, 0)) {
|
|
|
|
scale$expand %|W|% if (scale$is_discrete()) discrete else continuous
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
# Col union
|
|
|
|
# Form the union of columns in a and b. If there are columns of the same name in both a and b, take the column from a.
|
|
|
|
#
|
|
|
|
# @param data frame a
|
|
|
|
# @param data frame b
|
|
|
|
# @keyword internal
|
|
|
|
cunion <- function(a, b) {
|
|
|
|
if (length(a) == 0) return(b)
|
|
|
|
if (length(b) == 0) return(a)
|
|
|
|
|
|
|
|
cbind(a, b[setdiff(names(b), names(a))])
|
|
|
|
}
|
|
|
|
|
|
|
|
# Given a theme object and element name, return a grob for the element
|
|
|
|
element_render <- function(theme, element, ..., name = NULL) {
|
|
|
|
|
|
|
|
# Get the element from the theme, calculating inheritance
|
|
|
|
el <- calc_element(element, theme)
|
|
|
|
if (is.null(el)) {
|
|
|
|
message("Theme element ", element, " missing")
|
|
|
|
return(zeroGrob())
|
|
|
|
}
|
|
|
|
|
|
|
|
ggname(paste(element, name, sep = "."), element_grob(el, ...))
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
# Name ggplot grid object
|
|
|
|
# Convenience function to name grid objects
|
|
|
|
#
|
|
|
|
# @keyword internal
|
|
|
|
ggname <- function(prefix, grob) {
|
|
|
|
grob$name <- grobName(grob, prefix)
|
|
|
|
grob
|
|
|
|
}
|
|
|
|
|
|
|
|
# Convert a snake_case string to camelCase
|
|
|
|
camelize <- function(x, first = FALSE) {
|
|
|
|
x <- gsub("_(.)", "\\U\\1", x, perl = TRUE)
|
|
|
|
if (first) x <- firstUpper(x)
|
|
|
|
x
|
|
|
|
}
|
|
|
|
|
|
|
|
snakeize <- function(x) {
|
|
|
|
x <- gsub("([A-Za-z])([A-Z])([a-z])", "\\1_\\2\\3", x)
|
|
|
|
x <- gsub(".", "_", x, fixed = TRUE)
|
|
|
|
x <- gsub("([a-z])([A-Z])", "\\1_\\2", x)
|
|
|
|
tolower(x)
|
|
|
|
}
|
|
|
|
|
|
|
|
firstUpper <- function(s) {
|
|
|
|
paste(toupper(substring(s, 1,1)), substring(s, 2), sep = "")
|
|
|
|
}
|
|
|
|
|
|
|
|
snake_class <- function(x) {
|
|
|
|
snakeize(class(x)[1])
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
# Look for object first in parent environment and if not found, then in
|
|
|
|
# ggplot2 namespace environment. This makes it possible to override default
|
|
|
|
# scales by setting them in the parent environment.
|
|
|
|
find_global <- function(name, env, mode = "any") {
|
|
|
|
if (exists(name, envir = env, mode = mode)) {
|
|
|
|
return(get(name, envir = env, mode = mode))
|
|
|
|
}
|
|
|
|
|
|
|
|
nsenv <- asNamespace("ggalt")
|
|
|
|
if (exists(name, envir = nsenv, mode = mode)) {
|
|
|
|
return(get(name, envir = nsenv, mode = mode))
|
|
|
|
}
|
|
|
|
|
|
|
|
NULL
|
|
|
|
}
|
|
|
|
|
|
|
|
find_subclass <- function (super, class, env) {
|
|
|
|
name <- paste0(super, camelize(class, first = TRUE))
|
|
|
|
obj <- find_global(name, env = env)
|
|
|
|
if (is.null(name)) {
|
|
|
|
stop("No ", tolower(super), " called ", name, ".", call. = FALSE)
|
|
|
|
}
|
|
|
|
else if (!inherits(obj, super)) {
|
|
|
|
stop("Found object is not a ", tolower(super), ".", call. = FALSE)
|
|
|
|
}
|
|
|
|
obj
|
|
|
|
}
|
|
|
|
|
|
|
|
alt_aesthetics <- function(type, name) {
|
|
|
|
obj <- switch(type,
|
|
|
|
geom = find_subclass("Geom", name, globalenv()),
|
|
|
|
stat = find_subclass("Stat", name, globalenv())
|
|
|
|
)
|
|
|
|
aes <- alt_aesthetics_item(obj)
|
|
|
|
|
|
|
|
paste("\\code{", type, "_", name, "} ",
|
|
|
|
"understands the following aesthetics (required aesthetics are in bold):\n\n",
|
|
|
|
"\\itemize{\n",
|
|
|
|
paste(" \\item \\code{", aes, "}", collapse = "\n", sep = ""),
|
|
|
|
"\n}\n", sep = "")
|
|
|
|
}
|
|
|
|
|
|
|
|
alt_aesthetics_item <- function(x) {
|
|
|
|
req <- x$required_aes
|
|
|
|
all <- union(req, sort(x$aesthetics()))
|
|
|
|
|
|
|
|
ifelse(all %in% req,
|
|
|
|
paste0("\\strong{", all, "}"),
|
|
|
|
all
|
|
|
|
)
|
|
|
|
}
|