# These are functions copied straight from the ggplot2 package to avoid issues
# with depending directly on ggplot2 internals. The functions and objects below
# are copied due to the MIT licence that ggplot2 wields.
# nocov start
add_margins <- function(
grob,
height,
width,
margin = NULL,
gp = gpar(),
margin_x = FALSE,
margin_y = FALSE
) {
if (is.null(margin)) {
margin <- margin(0, 0, 0, 0)
}
if (margin_x && margin_y) {
widths <- unit.c(margin[4], width, margin[2])
heights <- unit.c(margin[1], height, margin[3])
vp <- viewport(
layout = grid.layout(3, 3, heights = heights, widths = widths),
gp = gp
)
child_vp <- viewport(layout.pos.row = 2, layout.pos.col = 2)
} else if (margin_x) {
widths <- unit.c(margin[4], width, margin[2])
heights <- unit(1, "null")
vp <- viewport(
layout = grid.layout(1, 3, widths = widths),
gp = gp
)
child_vp <- viewport(layout.pos.col = 2)
} else if (margin_y) {
widths <- unit(1, "null")
heights <- unit.c(margin[1], height, margin[3])
vp <- viewport(
layout = grid.layout(3, 1, heights = heights),
gp = gp
)
child_vp <- viewport(layout.pos.row = 2)
} else {
widths <- width
heights <- height
return(
gTree(
children = grob, widths = widths, heights = heights, cl = "titleGrob"
)
)
}
gTree(
children = grob,
vp = vpTree(vp, vpList(child_vp)),
widths = widths, heights = heights,
cl = "titleGrob"
)
}
axis_label_element_overrides <- function(axis_position, angle = NULL) {
if (is.null(angle)) {
return(
element_text(angle = NULL, hjust = NULL, vjust = NULL)
)
}
if (angle > 90 || angle < -90) {
cli::cli_abort("{.arg angle} must be between 90 and -90")
}
if (axis_position == "bottom") {
element_text(
angle = angle,
hjust = if (angle > 0) 1 else if (angle < 0) 0 else 0.5,
vjust = if (abs(angle) == 90) 0.5 else 1
)
} else if (axis_position == "left") {
element_text(
angle = angle,
hjust = if (abs(angle) == 90) 0.5 else 1,
vjust = if (angle > 0) 0 else if (angle < 0) 1 else 0.5
)
} else if (axis_position == "top") {
element_text(
angle = angle,
hjust = if (angle > 0) 0 else if (angle < 0) 1 else 0.5,
vjust = if (abs(angle) == 90) 0.5 else 0
)
} else if (axis_position == "right") {
element_text(
angle = angle,
hjust = if (abs(angle) == 90) 0.5 else 0,
vjust = if (angle > 0) 1 else if (angle < 0) 0 else 0.5
)
} else {
cli::cli_abort(c(
"Unrecognised {.arg axis_position}: {.val {axis_position}}.",
i = "Use one of {.val top}, {.val bottom}, {.val left} or {.val right}"
))
}
}
check_labeller <- function(labeller) {
labeller <- match.fun(labeller)
is_deprecated <- all(c("varaible", "value") %in% names(formals(labeller)))
if (is_deprecated) {
old_labeller <- labeller
labeller <- function(labels) {
Map(old_labeller, names(labels), labels)
}
cli::cli_warn(c(
"The {.arg labeller} API has been updated. Labellers taking \\
{.arg variable} and {.arg value} arguments are now deprecated.",
i = "See labellers documentation."
))
}
labeller
}
unrowname <- function(x) {
if (is.data.frame(x)) {
attr(x, "row.names") <- .set_row_names(.row_names_info(x, 2L))
} else if (is.matrix(x)) {
dimnames(x)[1] <- list(NULL)
} else {
cli::cli_abort(
"Can only remove rownames from {.cls data.frame} and \\
{.cls matrix} objects."
)
}
x
}
df.grid = function(a, b) {
if (is.null(a) || nrow(a) == 0) {
return(b)
}
if (is.null(b) || nrow(b) == 0) {
return(a)
}
indexes <- expand.grid(i_a = seq_len(nrow(a)), i_b = seq_len(nrow(b)))
vec_cbind(
unrowname(a[indexes$i_a, , drop = FALSE]),
unrowname(b[indexes$i_b, , drop = FALSE])
)
}
draw_axis_labels = function(
break_positions,
break_labels,
label_element,
is_vertical,
check.overlap = FALSE
) {
position_dim <- if (is_vertical) "y" else "x"
label_margin_name <- if (is_vertical) "margin_x" else "margin_y"
n_breaks <- length(break_positions)
break_positions <- unit(break_positions, "native")
if (check.overlap) {
priority <- axis_label_priority(n_breaks)
break_labels <- break_labels[priority]
break_positions <- break_positions[priority]
}
labels_grob <- rlang::exec(
element_grob,
label_element,
`:=`(!!position_dim, break_positions),
`:=`(!!label_margin_name, TRUE),
label = break_labels,
check.overlap = check.overlap
)
}
axis_label_priority <- function(n) {
if (n <= 0) {
return(numeric(0))
}
c(1, n, axis_label_priority_between(1, n))
}
axis_label_priority_between <- function(x, y) {
n <- y - x + 1
if (n <= 2) {
return(numeric(0))
}
mid <- x - 1 + (n + 1) %/% 2
c(mid,
axis_label_priority_between(x, mid),
axis_label_priority_between(mid, y))
}
reshape_add_margins = function(df, vars, margins = TRUE, margin_nm = "(all)") {
margin_vars <- reshape_margins(vars, margins)
if (length(margin_vars) == 0) {
return(df)
}
add_all <- function(x) {
x <- addNA(x, TRUE)
factor(x, levels = c(levels(x), margin_nm), exclude = NULL)
}
vars <- unique0(unlist(margin_vars))
df[vars] <- lapply(df[vars], add_all)
rownames(df) <- NULL
margin_dfs <- lapply(
margin_vars,
function(vars) {
df[vars] <- rep(list(factor(margin_nm)), length(vars))
df
}
)
vec_rbind(!!!margin_dfs)
}
reshape_margins = function(vars, margins = NULL) {
if (is.null(margins) || identical(margins, FALSE)) {
return(NULL)
}
all_vars <- unlist(vars)
if (isTRUE(margins)) {
margins <- all_vars
}
dims <- lapply(vars, intersect, margins)
dims <- Map(function(vars, margin) {
lapply(margin, downto, vars)
}, vars, dims, USE.NAMES = FALSE)
seq_0 <- function(x) c(0, seq_along(x))
indices <- expand.grid(lapply(dims, seq_0), KEEP.OUT.ATTRS = FALSE)
lapply(seq_nrow(indices), function(i) {
unlist(Map("[", dims, indices[i, ]))
})
}
downto <- function(a, b) rev(upto(a, rev(b)))
upto <- function(a, b) b[seq_len(match(a, b, nomatch = 0))]
# defaults <- function(x, y) c(x, y[setdiff(names(y), names(x))])
id <- function(.variables, drop = FALSE) {
nrows <- NULL
if (is.data.frame(.variables)) {
nrows <- nrow(.variables)
.variables <- unclass(.variables)
}
.variables <- .variables[lengths(.variables) > 0]
if (length(.variables) == 0) {
n <- nrows %||% 0L
id <- seq_len(n)
attr(id, "n") <- n
return(id)
}
if (length(.variables) == 1) {
return(id_var(.variables[[1]], drop = drop))
}
ids <- rev(lapply(.variables, id_var, drop = drop))
p <- length(ids)
ndistinct <- vapply(ids, attr, "n", FUN.VALUE = numeric(1),
USE.NAMES = FALSE)
n <- prod(ndistinct)
if (n > 2^31) {
char_id <- rlang::inject(paste(!!!ids, sep = "'\r"))
res <- match(char_id, unique0(char_id))
} else {
combs <- c(1, cumprod(ndistinct[-p]))
mat <- rlang::inject(cbind(!!!ids))
res <- c((mat - 1L) %*% combs + 1L)
}
if (drop) {
id_var(res, drop = TRUE)
} else {
res <- as.integer(res)
attr(res, "n") <- n
res
}
}
id_var <- function(x, drop = FALSE) {
if (length(x) == 0) {
id <- integer()
n <- 0L
} else if (!is.null(attr(x, "n")) && !drop) {
return(x)
} else if (is.factor(x) && !drop) {
x <- addNA(x, ifany = TRUE)
id <- as.integer(x)
n <- length(levels(x))
} else {
levels <- sort(unique0(x), na.last = TRUE)
id <- match(x, levels)
n <- max(id)
}
attr(id, "n") <- n
id
}
empty <- function(df) {
is.null(df) || nrow(df) == 0 || ncol(df) == 0 || inherits(df, "waiver")
}
eval_facets <- function(facets, data, possible_columns = NULL) {
vars <- lapply(facets, eval_facet, data, possible_columns = possible_columns)
vars <- vars[lengths(vars) > 0]
data_frame(!!!vars)
}
eval_facet <- function(facet, data, possible_columns = NULL) {
if (rlang::quo_is_symbol(facet)) {
facet <- as.character(rlang::quo_get_expr(facet))
if (facet %in% names(data)) {
out <- data[[facet]]
} else {
out <- NULL
}
return(out)
}
env <- rlang::new_environment(data)
missing_columns <- setdiff(possible_columns, names(data))
undefined_error <- function(e) {
cli::cli_abort("", class = "ggplot2_missing_facet_var")
}
bindings <- rlang::rep_named(missing_columns, list(undefined_error))
rlang::env_bind_active(env, !!!bindings)
mask <- rlang::new_data_mask(env)
mask$.data <- rlang::as_data_pronoun(mask)
tryCatch(
eval_tidy(facet, mask),
ggplot2_missing_facet_var = function(e) NULL
)
}
ggname <- function(prefix, grob) {
grob$name <- grobName(grob, prefix)
grob
}
is.zero <- function(x) {
is.null(x) || inherits(x, "zeroGrob")
}
snake_class <- function(x) {
x <- class(x)[1]
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)
chartr(
paste0(LETTERS, collapse = ""),
paste0(letters, collapse = ""),
x
)
}
ulevels <- function(x) {
if (is.factor(x)) {
x <- addNA(x, TRUE)
factor(levels(x), levels(x), exclude = NULL)
} else {
sort(unique0(x))
}
}
unique_combs <- function(df) {
if (length(df) == 0) {
return()
}
unique_values <- lapply(df, ulevels)
rev(expand.grid(
rev(unique_values), stringsAsFactors = FALSE, KEEP.OUT.ATTRS = TRUE
))
}
warn_for_guide_position <- function(guide) {
breaks_are_unique <- !duplicated(guide$key$.value)
if (empty(guide$key) || sum(breaks_are_unique) == 1) {
return()
}
if (guide$position %in% c("top", "bottom")) {
position_aes <- "x"
} else if (guide$position %in% c("left", "right")) {
position_aes <- "y"
} else {
return()
}
if (length(unique0(guide$key[[position_aes]][breaks_are_unique])) == 1) {
cli::cli_warn(c(
"Position guide is perpendicular to the intended axis.",
i = "Did you mean to specify a different guide {.arg position}?"
))
}
}
weave_tables_col <- function(table, table2, col_shift, col_width, name, z = 1,
clip = "off") {
panel_col <- panel_cols(table)$l
panel_row <- panel_rows(table)$t
for (i in rev(seq_along(panel_col))) {
col_ind <- panel_col[i] + col_shift
table <- gtable_add_cols(table, col_width[i], pos = col_ind)
if (!missing(table2)) {
table <- gtable_add_grob(
table, table2[, i],
t = panel_row, l = col_ind + 1,
clip = clip, name = paste0(
name, "-", seq_along(panel_row), "-", i
),
z = z
)
}
}
table
}
weave_tables_row <- function(table, table2, row_shift, row_height, name, z = 1,
clip = "off") {
panel_col <- panel_cols(table)$l
panel_row <- panel_rows(table)$t
for (i in rev(seq_along(panel_row))) {
row_ind <- panel_row[i] + row_shift
table <- gtable_add_rows(table, row_height[i], pos = row_ind)
if (!missing(table2)) {
table <- gtable_add_grob(
table, table2[i, ], t = row_ind + 1,
l = panel_col, clip = clip, name = paste0(
name, "-", seq_along(panel_col), "-", i
), z = z
)
}
}
table
}
join_keys <- function(x, y, by) {
joint <- vec_rbind(x[by], y[by])
keys <- id(joint, drop = TRUE)
list(
x = keys[seq_nrow(x)],
y = keys[nrow(x) + seq_nrow(y)],
n = attr(keys, "n")
)
}
interleave <- function(x, ...) {
if (is.unit(x)) {
units <- c(as.list(x), lapply(list(...), as.list))
interleaved_list <- vec_interleave(!!!units)
rlang::inject(unit.c(!!!interleaved_list))
} else {
vec_interleave(x, ...)
}
}
justify_grobs <- function(
grobs,
x = NULL, y = NULL,
hjust = 0.5, vjust = 0.5,
int_angle = 0, debug = FALSE
) {
if (!inherits(grobs, "grob")) {
if (is.list(grobs)) {
return(
lapply(grobs, justify_grobs, x, y, hjust, vjust, int_angle, debug)
)
} else {
cli::cli_abort(
"{.arg grobs} must be an individual {.cls grob} or list of \\
{.cls grob} objects."
)
}
}
if (inherits(grobs, "zeroGrob")) {
return(grobs)
}
just <- rotate_just(int_angle, hjust, vjust)
x <- x %||% unit(just$hjust, "npc")
y <- y %||% unit(just$vjust, "npc")
if (isTRUE(debug)) {
children <- gList(
rectGrob(gp = gpar(fill = "lightcyan", col = NA)),
grobs
)
} else {
children <- gList(grobs)
}
result_grob <- gTree(
children = children,
vp = viewport(
x = x, y = y,
width = grobWidth(grobs),
height = grobHeight(grobs),
just = unlist(just)
)
)
if (isTRUE(debug)) {
grobTree(
result_grob,
pointsGrob(x, y, pch = 20, gp = gpar(col = "mediumturquoise"))
)
} else {
result_grob
}
}
rotate_just <- function(angle, hjust, vjust) {
angle <- (angle %||% 0) %% 360
if (0 <= angle & angle < 90) {
hnew <- hjust
vnew <- vjust
} else if (90 <= angle & angle < 180) {
hnew <- 1 - vjust
vnew <- hjust
} else if (180 <= angle & angle < 270) {
hnew <- 1 - hjust
vnew <- 1 - vjust
} else if (270 <= angle & angle < 360) {
hnew <- vjust
vnew <- 1 - hjust
}
list(hjust = hnew, vjust = vnew)
}
compute_just <- function(just, a, b = a, angle = 0) {
if (any(grepl("outward|inward", just))) {
angle <- angle %% 360
angle <- ifelse(angle > 180, angle - 360, angle)
angle <- ifelse(angle < -180, angle + 360, angle)
rotated_forward <- grepl("outward|inward", just) &
(angle > 45 & angle < 135)
rotated_backwards <- grepl("outward|inward", just) &
(angle < -45 & angle > -135)
ab <- ifelse(rotated_forward | rotated_backwards, b, a)
just_swap <- rotated_backwards | abs(angle) > 135
inward <- (just == "inward" & !just_swap | just == "outward" & just_swap)
just[inward] <- c("left", "middle", "right")[just_dir(ab[inward])]
outward <- (just == "outward" & !just_swap) | (just == "inward" & just_swap)
just[outward] <- c("right", "middle", "left")[just_dir(ab[outward])]
}
unname(c(
left = 0, center = 0.5, right = 1,
bottom = 0, middle = 0.5, top = 1
)[just])
}
just_dir <- function(x, tol = 0.001) {
out <- rep(2L, length(x))
out[x < 0.5 - tol] <- 1L
out[x > 0.5 + tol] <- 3L
out
}
`%|W|%` <- function(a, b) {
if (!inherits(a, "waiver")) a else b
}
# nocov end
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.