Extra Coordinate Systems, 'Geoms', Statistical Transformations, Scales and Fonts for 'ggplot2'
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

142 lines
3.6 KiB

"%||%" <- 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
)
}