R/font_feature.R

In systemfonts: System Native Font Finding

#' Define OpenType font feature settings
#'
#' This function encapsulates the specification of OpenType font features. Some
#' specific features have named arguments, but all available features can be
#' set by using its specific 4-letter tag For a list of the 4-letter tags
#' available see e.g. the overview on
#' [Wikipedia](https://en.wikipedia.org/wiki/List_of_typographic_features).
#'
#' @param ligatures Settings related to ligatures. One or more types of
#' ligatures to turn on (see details).
#' @param letters Settings related to the appearance of single
#' letters (as opposed to ligatures that substitutes multiple letters). See
#' details for supported values.
#' @param numbers Settings related to the appearance of numbers. See details for
#' supported values.
#' @param ... key-value pairs with the key being the 4-letter tag and the value
#' being the setting (usually `TRUE` to turn it on).
#'
#' @details
#' OpenType features are defined by a 4-letter tag along with an integer value.
#' Often that value is a simple `0` (off) or `1` (on), but some features support
#' additional values, e.g. stylistic alternates (`salt`) where a font may
#' provide multiple variants of a letter and the value will be used to chose
#' which one to use.
#'
#' Common features related to appearance may be given with a long form name to
#' either the `ligatures`, `letters`, or `numbers` argument to avoid remembering
#' the often arbitrary 4-letter tag. Providing a long form name is the same as
#' setting the tag to `1` and can thus not be used to set tags to other values.
#'
#' The possible long form names are given below with the tag in parenthesis:
#'
#' **Ligatures**
#' - `standard` (*liga*): Turns on standard multiple letter substitution
#' - `historical` (*hlig*): Use obsolete historical ligatures
#' - `contextual` (*clig*): Apply secondary ligatures based on the character
#'   patterns surrounding the potential ligature
#' - `discretionary` (*dlig*): Use ornamental ligatures
#'
#' **Letters**
#' - `swash` (*cswh*): Use contextual swashes (ornamental decorations)
#' - `alternates` (*calt*): Use alternate letter forms based on the sourrounding
#'   pattern
#' - `historical` (*hist*): Use obsolete historical forms of the letters
#' - `localized` (*locl*): Use alternate forms preferred by the script language
#' - `randomize` (*rand*): Use random variants of the letters (e.g. to mimick
#'   handwriting)
#' - `alt_annotation` (*nalt*): Use alternate annotations (e.g. circled digits)
#' - `stylistic` (*salt*): Use a stylistic alternative form of the letter
#' - `subscript` (*subs*): Set letter in subscript
#' - `superscript` (*sups*): Set letter in superscript
#' - `titling` (*titl*): Use letter forms well suited for large text and titles
#' - `small_caps` (*smcp*): Use small caps variants of the letters
#'
#' **Numbers**
#' - `lining` (*lnum*): Use number variants that rest on the baseline
#' - `oldstyle` (*onum*): Use old style numbers that use descender and ascender
#'   for various numbers
#' - `proportional` (*pnum*): Let numbers take up width based on the visual
#'   width of the glyph
#' - `tabular` (*tnum*): Enforce all numbers to take up the same width
#' - `fractions` (*frac*): Convert numbers separated by `/` into a fraction
#'   glyph
#' - `fractions_alt` (*afrc*): Use alternate fraction form with a horizontal
#'   divider
#'
#' @return A `font_feature` object
#'
#' @export
#'
#' @examples
#' font_feature(letters = "stylistic", numbers = c("lining", "tabular"))
#'
#' # Use the tag directly to access additional stylistic variants
#' font_feature(numbers = c("lining", "tabular"), salt = 2)
#'
font_feature <- function(
  ligatures = NULL,
  letters = NULL,
  numbers = NULL,
  ...
) {
  features <- list(...)
  if (!is.null(ligatures)) {
    for (lig in ligatures) {
      features[get_ligature_tag(lig)] <- 1L
    }
  }
  if (!is.null(letters)) {
    for (let in letters) {
      features[get_letter_tag(let)] <- 1L
    }
  }
  if (!is.null(numbers)) {
    for (num in numbers) {
      features[get_number_tag(num)] <- 1L
    }
  }
  if (length(features) == 0) {
    features <- list(character(), integer())
  } else {
    feature_names <- names(features)
    if (any(vapply(features, length, integer(1)) != 1)) {
      stop("A feature setting can only be of length 1", call. = FALSE)
    }
    if (anyDuplicated(feature_names)) {
      stop("Features can only be given once", call. = FALSE)
    }
    if (any(nchar(feature_names) != 4)) {
      stop("Feature tags must be 4 character long", call. = FALSE)
    }
    feature_settings <- vapply(features, as.integer, integer(1))
    features <- list(feature_names, feature_settings)
  }
  class(features) <- "font_feature"
  features
}
is_font_feature <- function(x) inherits(x, "font_feature")

#' @export
length.font_feature <- function(x) {
  length(x[[1]])
}
#' @export
print.font_feature <- function(x, ...) {
  if (length(x) == 0) {
    cat("An empty font_feature object\n")
  } else {
    cat("A list of OpenType font feature settings\n")
    cat(paste(paste0("- ", x[[1]], ": ", x[[2]]), collapse = "\n"))
  }
  invisible(x)
}
#' @export
format.font_feature <- function(x, ...) {
  if (length(x) == 0) {
    return("<empty>")
  }
  paste(x[[1]], ': ', x[[2]], collapse = '; ', sep = '')
}
#' @export
c.font_feature <- function(x, ...) {
  features <- rev(list(x, ...))
  names <- unlist(lapply(features, `[[`, 1))
  keep <- !duplicated(names)
  values <- unlist(lapply(features, `[[`, 2))[keep]
  structure(list(names[keep], values), class = "font_feature")
}

get_ligature_tag <- function(x) {
  name <- c("standard", "historical", "contextual", "discretionary")
  tags <- c("liga", "hlig", "clig", "dlig")
  ind <- match(tolower(x), name)
  if (is.na(ind)) {
    stop(
      "No ligature setting called '",
      x,
      "'. Use one of ",
      paste(name, collapse = ", "),
      call. = FALSE
    )
  }
  tags[ind]
}
get_letter_tag <- function(x) {
  name <- c(
    "swash",
    "alternates",
    "historical",
    "localized",
    "randomize",
    "alt_annotation",
    "stylistic",
    "subscript",
    "superscript",
    "titling",
    "small_caps"
  )
  tags <- c(
    "cswh",
    "calt",
    "hist",
    "locl",
    "rand",
    "nalt",
    "salt",
    "subs",
    "sups",
    "titl",
    "smcp"
  )
  ind <- match(tolower(x), name)
  if (is.na(ind)) {
    stop(
      "No letter setting called '",
      x,
      "'. Use one of ",
      paste(name, collapse = ", "),
      call. = FALSE
    )
  }
  tags[ind]
}
get_number_tag <- function(x) {
  name <- c(
    "lining",
    "oldstyle",
    "proportional",
    "tabular",
    "fractions",
    "fractions_alt"
  )
  tags <- c("lnum", "onum", "pnum", "tnum", "frac", "afrc")
  ind <- match(tolower(x), name)
  if (is.na(ind)) {
    stop(
      "No number setting called '",
      x,
      "'. Use one of ",
      paste(name, collapse = ", "),
      call. = FALSE
    )
  }
  tags[ind]
}