R/geometry.R

In ggraph: An Implementation of Grammar of Graphics for Graphs and Networks

#' Define simple shapes for line capping
#'
#' This set of functions makes it easy to define shapes at the terminal points
#' of edges that are used to shorten the edges. The shapes themselves are not
#' drawn, but the edges will end at the boundary of the shape rather than at
#' the node position. This is especially relevant when drawing arrows at the
#' edges as the arrows will be partly obscured by the node unless the edge is
#' shortened. Edge shortening is dynamic and will update as the plot is resized,
#' making sure that the capping remains at an absolute distance to the end
#' point.
#'
#' @details
#' `geometry` is the base constructor, while the rest are helpers to save
#' typing. `circle` creates circles width a given radius, `square`
#' creates squares at a given side length, `ellipsis` creates ellipses with
#' given a and b values (width and height radii), and `rectangle` makes
#' rectangles of a given width and height. label_rect is a helper that, given
#' a list of strings and potentially formatting options creates a rectangle that
#' encloses the string.
#'
#' @param type The type of geometry to use. Currently `'circle'` and
#' `'rect'` is supported.
#'
#' @param width,height,length,radius,a,b The dimensions of the shape.
#'
#' @param unit,width_unit,height_unit,a_unit,b_unit The unit for the numbers
#' given.
#'
#' @return A geometry object encoding the specified shape.
#'
#' @examples
#' geometry(c('circle', 'rect', 'rect'), 1:3, 3:1)
#'
#' circle(1:4, 'mm')
#'
#' label_rect(c('some', 'different', 'words'), fontsize = 18)
#' @export
#'
geometry <- function(type = 'circle', width = 1, height = width,
                     width_unit = 'cm', height_unit = width_unit) {
  l <- max(length(type), length(width), length(height))
  g <- rep_len(vec_cast(type, character()), l)
  g_na <- is.na(g)
  g[g_na] <- 'circle'
  width <- rep_len(vec_cast(width, double()), l)
  width[g_na] <- 0
  height <- rep_len(vec_cast(height, double()), l)
  height[g_na] <- 0
  uwidth <- rep_len(vec_cast(width_unit, character()), l)
  uheight <- rep_len(vec_cast(height_unit, character()), l)
  new_geometry(
    geometry = g,
    width = width,
    height = height,
    width_unit = uwidth,
    height_unit = uheight
  )
}
new_geometry <- function(geometry = character(), width = numeric(),
                         height = numeric(), width_unit = character(),
                         height_unit = character()) {
  vec_assert(geometry, character())
  vec_assert(width, double())
  vec_assert(height, double())
  vec_assert(width_unit, character())
  vec_assert(height_unit, character())
  new_rcrd(list(
    geometry = geometry,
    width = width,
    height = height,
    width_unit = width_unit,
    height_unit = height_unit
  ), class = 'ggraph_geometry')
}
#' @rdname geometry
#'
#' @export
circle <- function(radius = 1, unit = 'cm') {
  geometry('circle', width = radius * 2, width_unit = unit)
}
#' @rdname geometry
#'
#' @export
square <- function(length = 1, unit = 'cm') {
  geometry('rect', width = length, width_unit = unit)
}
#' @rdname geometry
#'
#' @export
ellipsis <- function(a = 1, b = 1, a_unit = 'cm', b_unit = a_unit) {
  geometry('circle',
    width = a * 2, height = b * 2, width_unit = a_unit,
    height_unit = b_unit
  )
}
#' @rdname geometry
#'
#' @export
rectangle <- function(width = 1, height = 1, width_unit = 'cm',
                      height_unit = width_unit) {
  geometry('rect',
    width = width, height = height, width_unit = width_unit,
    height_unit = height_unit
  )
}
#' @rdname geometry
#'
#' @param label The text to be enclosed
#'
#' @param padding extra size to be added around the text using the
#' [ggplot2::margin()] function
#'
#' @param ... Passed on to [grid::gpar()]
#'
#' @export
#' @importFrom grid convertWidth convertHeight textGrob grobWidth grobHeight
label_rect <- function(label, padding = margin(1, 1, 1.5, 1, 'mm'), ...) {
  grobs <- lapply(label, textGrob, gp = gpar(...))
  width <- abs_width(grobs)
  height <- abs_height(grobs)
  width <- width + sum(convertWidth(padding[c(2, 4)], 'cm', TRUE))
  height <- height + sum(convertHeight(padding[c(1, 3)], 'cm', TRUE))
  geometry('rect', width = width, height = height)
}
#' @rdname geometry
#'
#' @param x An object to test for geometry inheritance
#'
#' @export
is.geometry <- function(x) inherits(x, 'ggraph_geometry')
#' @export
format.ggraph_geometry <- function(x, ...) {
  paste0(
    field(x, 'geometry'), '(', field(x, 'width'), field(x, 'width_unit'),
    ', ', field(x, 'height'), field(x, 'height_unit'), ')'
  )
}
#' @export
is.na.ggraph_geometry <- function(x) {
  is.na(field(x, 'geometry'))
}
geo_type <- function(x) {
  if (!is.geometry(x)) cli::cli_abort('{.arg x} must be a {.cls ggraph_geometry} object')
  field(x, 'geometry')
}
geo_width <- function(x) {
  if (!is.geometry(x)) cli::cli_abort('{.arg x} must be a {.cls geometry} object')
  unit(field(x, 'width'), field(x, 'width_unit'))
}
geo_height <- function(x) {
  if (!is.geometry(x)) cli::cli_abort('{.arg x} must be a {.cls geometry} object')
  unit(field(x, 'height'), field(x, 'height_unit'))
}
#' @importFrom grid convertHeight grobHeight
abs_height <- function(grobs) {
  vapply(grobs, function(g) convertHeight(grobHeight(g), 'cm', TRUE), numeric(1))
}
#' @importFrom grid convertWidth grobWidth
abs_width <- function(grobs) {
  vapply(grobs, function(g) convertWidth(grobWidth(g), 'cm', TRUE), numeric(1))
}

#' @export
vec_ptype2.ggraph_geometry.ggraph_geometry <- function(x, y, ...) new_geometry()
#' @export
vec_ptype2.ggraph_geometry.character <- function(x, y, ...) character()
#' @export
vec_ptype2.character.ggraph_geometry <- function(x, y, ...) character()
#' @export
vec_cast.character.ggraph_geometry <- function(x, to, ...) as.character(field(x, 'geometry'))

#' Define default scale type for geometry
#'
#' This function is quite useless as geometry is not meant to be scaled, but it
#' is a requirement for ggplot2 to handle it correctly.
#'
#' @export
#'
#' @keywords internal
scale_type.ggraph_geometry <- function(x) 'identity'