Nothing
#' Get the angle of nodes and edges
#'
#' These helper functions makes it easy to calculate the angle associated with
#' nodes and edges. For nodes the angle is defined as the angle of the vector
#' pointing towards the node position, and is thus mainly suited for circular
#' layouts where it can be used to calculate the angle of labels. For edges it
#' is simply the angle of the vector describing the edge.
#'
#' @param x,y A vector of positions
#'
#' @param xend,yend The end position of the edge
#'
#' @param degrees Logical. Should the angle be returned in degree (`TRUE`)
#' or radians (`FALSE`). Defaults to `TRUE`.
#'
#' @param avoid_flip Logical. Should the angle be adjusted so that text is
#' always upside-down
#'
#' @return A vector with the angle of each node/edge
#'
#' @examples
#' require(tidygraph)
#' flareGraph <- tbl_graph(flare$vertices, flare$edges)
#'
#' ggraph(flareGraph, 'dendrogram', circular = TRUE) +
#' geom_edge_diagonal0() +
#' geom_node_text(aes(filter = leaf, angle = node_angle(x, y), label = shortName),
#' hjust = 'outward', size = 2
#' ) +
#' expand_limits(x = c(-1.3, 1.3), y = c(-1.3, 1.3))
#' @export
#'
node_angle <- function(x, y, degrees = TRUE, avoid_flip = TRUE) {
angles <- atan2(y, x)
angles[angles < 0] <- angles[angles < 0] + 2 * pi
if (avoid_flip) {
needs_flip <- angles > pi/2 & angles < 3*pi/2
angles[needs_flip] <- angles[needs_flip] + pi
}
if (degrees) {
angles * 360 / (2 * pi)
} else {
angles
}
}
#' @rdname node_angle
#'
#' @export
edge_angle <- function(x, y, xend, yend, degrees = TRUE, avoid_flip = TRUE) {
x <- xend - x
y <- yend - y
node_angle(x, y, degrees, avoid_flip = avoid_flip)
}
### COPY FROM GGPLOT2 NON-EXPORTS
#' @importFrom grid grobName
ggname <- function(prefix, grob) {
grob$name <- grobName(grob, prefix)
grob
}
rename_aes <- function(x) {
names(x) <- standardise_aes_names(names(x))
duplicated_names <- names(x)[duplicated(names(x))]
if (length(duplicated_names) > 0L) {
cli::cli_warn("Duplicated aesthetics after name standardisation: {.field {unique0(duplicated_names)}}")
}
x
}
flip_names <- c(
x = "y",
y = "x",
width = "height",
height = "width",
hjust = "vjust",
vjust = "hjust",
margin_x = "margin_y",
margin_y = "margin_x"
)
flip_element_grob <- function(..., flip = FALSE) {
if (!flip) {
ans <- element_grob(...)
return(ans)
}
args <- list(...)
translate <- names(args) %in% names(flip_names)
names(args)[translate] <- flip_names[names(args)[translate]]
do.call(element_grob, args)
}
#' @importFrom viridis scale_color_viridis
#' @export
viridis::scale_color_viridis
#' @importFrom viridis scale_fill_viridis
#' @export
viridis::scale_fill_viridis
# Wrapping vctrs data_frame constructor with no name repair
data_frame0 <- function(...) data_frame(..., .name_repair = "minimal")
# Wrapping unique0() to accept NULL
unique0 <- function(x, ...) if (is.null(x)) x else vec_unique(x, ...)
# Adapted from plyr:::id_vars
# Create a unique id for elements in a single vector
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
}
#' Create an unique integer id for each unique row in a data.frame
#'
#' Properties:
#' - `order(id)` is equivalent to `do.call(order, df)`
#' - rows containing the same data have the same value
#' - if `drop = FALSE` then room for all possibilites
#'
#' @param .variables list of variables
#' @param drop Should unused factor levels be dropped?
#'
#' @return An integer vector with attribute `n` giving the total number of
#' possible unique rows
#'
#' @keywords internal
#' @noRd
#'
id <- function(.variables, drop = FALSE) {
nrows <- NULL
if (is.data.frame(.variables)) {
nrows <- nrow(.variables)
.variables <- unclass(.variables)
}
lengths <- vapply(.variables, length, integer(1))
.variables <- .variables[lengths != 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 <- inject(paste(!!!ids, sep = '\r'))
res <- match(char_id, unique0(char_id))
}
else {
combs <- c(1, cumprod(ndistinct[-p]))
mat <- 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
}
}
# Use chartr() for safety since toupper() fails to convert i to I in Turkish locale
lower_ascii <- "abcdefghijklmnopqrstuvwxyz"
upper_ascii <- "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
to_lower_ascii <- function(x) chartr(upper_ascii, lower_ascii, x)
to_upper_ascii <- function(x) chartr(lower_ascii, upper_ascii, x)
tolower <- function(x) {
cli::cli_abort("Please use {.fn to_lower_ascii}, which works fine in all locales.")
}
toupper <- function(x) {
cli::cli_abort("Please use {.fn to_upper_ascii}, which works fine in all locales.")
}
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)
to_lower_ascii(x)
}
snake_class <- function(x) {
snakeize(class(x)[1])
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.