R/shape_text.R

In textshaping: Bindings to the 'HarfBuzz' and 'Fribidi' Libraries for Text Shaping

#' Calculate glyph positions for strings
#'
#' @description
#' `r lifecycle::badge('experimental')`
#'
#' Do basic text shaping of strings. This function will use freetype to
#' calculate advances, doing kerning if possible. It will not perform any font
#' substitution or ligature resolving and will thus be much in line with how
#' the standard graphic devices does text shaping. Inputs are recycled to the
#' length of `strings`.
#'
#' @param strings A character vector of strings to shape
#' @param id A vector grouping the strings together. If strings share an id the
#' shaping will continue between strings
#' @inheritParams systemfonts::font_info
#' @param lineheight A multiplier for the lineheight
#' @param align Within text box alignment, either `'left'`, `'center'`, or
#' `'right'`
#' @param hjust,vjust The justification of the textbox surrounding the text
#' @param width The requested with of the string in inches. Setting this to
#' something other than `NA` will turn on word wrapping.
#' @param tracking Tracking of the glyphs (space adjustment) measured in 1/1000
#' em.
#' @param indent The indent of the first line in a paragraph measured in inches.
#' @param hanging The indent of the remaining lines in a paragraph measured in
#' inches.
#' @param space_before,space_after The spacing above and below a paragraph,
#' measured in points
#' @param path,index path an index of a font file to circumvent lookup based on
#' family and style
#'
#' @return
#' A list with two element: `shape` contains the position of each glyph,
#' relative to the origin in the enclosing textbox. `metrics` contain metrics
#' about the full strings.
#'
#' `shape` is a data.frame with the following columns:
#' \describe{
#'   \item{glyph}{The glyph as a character}
#'   \item{index}{The index of the glyph in the font file}
#'   \item{metric_id}{The index of the string the glyph is part of (referencing a row in the `metrics` data.frame)}
#'   \item{string_id}{The index of the string the glyph came from (referencing an element in the `strings` input)}
#'   \item{x_offset}{The x offset in pixels from the origin of the textbox}
#'   \item{y_offset}{The y offset in pixels from the origin of the textbox}
#'   \item{x_mid}{The x offset in pixels to the middle of the glyph, measured from the origin of the glyph}
#' }
#'
#' `metrics` is a data.frame with the following columns:
#' \describe{
#'   \item{string}{The text the string consist of}
#'   \item{width}{The width of the string}
#'   \item{height}{The height of the string}
#'   \item{left_bearing}{The distance from the left edge of the textbox and the leftmost glyph}
#'   \item{right_bearing}{The distance from the right edge of the textbox and the rightmost glyph}
#'   \item{top_bearing}{The distance from the top edge of the textbox and the topmost glyph}
#'   \item{bottom_bearing}{The distance from the bottom edge of the textbox and the bottommost glyph}
#'   \item{left_border}{The position of the leftmost edge of the textbox related to the origin}
#'   \item{top_border}{The position of the topmost edge of the textbox related to the origin}
#'   \item{pen_x}{The horizontal position of the next glyph after the string}
#'   \item{pen_y}{The vertical position of the next glyph after the string}
#' }
#'
#' @export
#'
#' @examples
#' string <- "This is a long string\nLook; It spans multiple lines\nand all"
#'
#' # Shape with default settings
#' shape_text(string)
#'
#' # Mix styles within the same string
#' string <- c(
#'   "This string will have\na ",
#'   "very large",
#'   " text style\nin the middle"
#' )
#'
#' shape_text(string, id = c(1, 1, 1), size = c(12, 24, 12))
#'
shape_text <- function(strings, id = NULL, family = '', italic = FALSE,
                       bold = FALSE, size = 12, res = 72, lineheight = 1,
                       align = 'left', hjust = 0, vjust = 0, width = NA,
                       tracking = 0, indent = 0, hanging = 0, space_before = 0,
                       space_after = 0, path = NULL, index = 0) {
  n_strings = length(strings)
  if (is.null(id)) id <- seq_len(n_strings)
  id <- rep_len(id, n_strings)
  id <- match(id, unique(id))
  if (anyNA(id)) {
    stop('id must be a vector of valid integers', call. = FALSE)
  }
  ido <- order(id)
  id <- id[ido]
  strings <- as.character(strings)[ido]

  if (is.null(path)) {
    if (all(c(length(family), length(italic), length(bold)) == 1)) {
      loc <- systemfonts::match_font(family, italic, bold)
      path <- loc$path
      index <- loc$index
    } else {
      family <- rep_len(family, n_strings)
      italic <- rep_len(italic, n_strings)
      bold <- rep_len(bold, n_strings)
      loc <- Map(systemfonts::match_font, family = family, italic = italic, bold = bold)
      path <- vapply(loc, `[[`, character(1L), 1, USE.NAMES = FALSE)[ido]
      index <- vapply(loc, `[[`, integer(1L), 2, USE.NAMES = FALSE)[ido]
    }
  } else {
    if (!all(c(length(path), length(index)) == 1)) {
      path <- rep_len(path, n_strings)[ido]
      index <- rep_len(index, n_strings)[ido]
    }
  }
  if (length(size) != 1) size <- rep_len(size, n_strings)[ido]
  if (length(res) != 1) res <- rep_len(res, n_strings)[ido]
  if (length(lineheight) != 1) lineheight <- rep_len(lineheight, n_strings)[ido]
  align <- match.arg(align, c('left', 'center', 'right'), TRUE)
  align <- match(align, c('left', 'center', 'right'))
  if (length(align) != 1) align <- rep_len(align, n_strings)[ido]
  if (length(hjust) != 1) hjust <- rep_len(hjust, n_strings)[ido]
  if (length(vjust) != 1) vjust <- rep_len(vjust, n_strings)[ido]
  if (length(width) != 1) width <- rep_len(width, n_strings)[ido]
  width[is.na(width)] <- -1
  if (length(tracking) != 1) tracking <- rep_len(tracking, n_strings)[ido]
  if (length(indent) != 1) indent <- rep_len(indent, n_strings)[ido]
  if (length(hanging) != 1) hanging <- rep_len(hanging, n_strings)[ido]
  if (length(space_before) != 1) space_before <- rep_len(space_before, n_strings)[ido]
  if (length(space_after) != 1) space_after <- rep_len(space_after, n_strings)[ido]

  width <- width * res
  indent <- indent * res
  hanging <- hanging * res

  if (!all(file.exists(path))) stop("path must point to a valid file", call. = FALSE)
  shape <- get_string_shape_c(
    strings, id, path, as.integer(index), as.numeric(size), as.numeric(res),
    as.numeric(lineheight), as.integer(align) - 1L, as.numeric(hjust),
    as.numeric(vjust), as.numeric(width), as.numeric(tracking),
    as.numeric(indent), as.numeric(hanging), as.numeric(space_before),
    as.numeric(space_after)
  )
  if (nrow(shape$shape) == 0) return(shape)

  shape$metrics$string <- vapply(split(strings, id), paste, character(1), collapse = '')
  shape$shape$string_id <- ido[shape$shape$string_id]
  shape$shape <- shape$shape[order(shape$shape$string_id), , drop = FALSE]
  #shape$shape$glyph <- intToUtf8(shape$shape$glyph, multiple = TRUE)
  shape$shape$x_offset <- shape$shape$x_offset * (72 / res)
  shape$shape$y_offset <- shape$shape$y_offset * (72 / res)
  shape$shape$x_midpoint <- shape$shape$x_midpoint * (72 / res)
  shape
}
#' Calculate the width of a string, ignoring new-lines
#'
#' This is a very simple alternative to [shape_string()] that simply calculates
#' the width of strings without taking any newline into account. As such it is
#' suitable to calculate the width of words or lines that has already been
#' splitted by `\n`. Input is recycled to the length of `strings`.
#'
#' @inheritParams systemfonts::font_info
#' @param strings A character vector of strings
#' @param include_bearing Logical, should left and right bearing be included in
#' the string width?
#'
#' @return A numeric vector giving the width of the strings in pixels. Use the
#' provided `res` value to convert it into absolute values.
#'
#' @export
#'
#' @examples
#' strings <- c('A short string', 'A very very looong string')
#' text_width(strings)
#'
text_width <- function(strings, family = '', italic = FALSE, bold = FALSE,
                       size = 12, res = 72, include_bearing = TRUE, path = NULL,
                       index = 0) {
  n_strings <- length(strings)
  if (is.null(path)) {
    if (all(c(length(family), length(italic), length(bold)) == 1)) {
      loc <- systemfonts::match_font(family, italic, bold)
      path <- loc$path
      index <- loc$index
    } else {
      family <- rep_len(family, n_strings)
      italic <- rep_len(italic, n_strings)
      bold <- rep_len(bold, n_strings)
      loc <- Map(systemfonts::match_font, family = family, italic = italic, bold = bold)
      path <- vapply(loc, `[[`, character(1L), 1, USE.NAMES = FALSE)
      index <- vapply(loc, `[[`, integer(1L), 2, USE.NAMES = FALSE)
    }
  } else {
    if (!all(c(length(path), length(index)) == 1)) {
      path <- rep_len(path, n_strings)
      index <- rep_len(index, n_strings)
    }
  }
  if (length(size) != 1) size <- rep_len(size, n_strings)
  if (length(res) != 1) res <- rep_len(res, n_strings)
  if (length(include_bearing) != 1) include_bearing <- rep_len(include_bearing, n_strings)
  if (!all(file.exists(path))) stop("path must point to a valid file", call. = FALSE)
  get_line_width_c(
    as.character(strings), path, as.integer(index), as.numeric(size),
    as.numeric(res), as.logical(include_bearing)
  )
}