R/text-details.R

In gridtext: Improved Text Rendering Support for 'Grid' Graphics

#' Calculate text details for a given text label
#'
#' Calculate text details for a given text label
#' @param label Character vector containing the label. Can handle only one label at a time.
#' @param gp Grid graphical parameters defining the font (`fontfamily`, `fontface`, and
#'   `fontsize` should be defined).
#' @examples
#' text_details("Hello world!", grid::gpar(fontfamily = "", fontface = "plain", fontsize = 12))
#' text_details("Hello world!", grid::gpar(fontfamily = "", fontface = "plain", fontsize = 24))
#' text_details(
#'   "Hello world\nwith newline",
#'   grid::gpar(fontfamily = "", fontface = "plain", fontsize = 12)
#' )
#' @noRd
text_details <- function(label, gp = gpar()) {
  fontfamily <- gp$fontfamily %||% grid::get.gpar("fontfamily")$fontfamily
  font <- gp$font %||% grid::get.gpar("font")$font
  fontsize <- gp$fontsize %||% grid::get.gpar("fontsize")$fontsize

  devname <- names(grDevices::dev.cur())
  fontkey <- paste0(devname, fontfamily, font, fontsize)
  if (devname == "null device") {
    cache <- FALSE   # don't cache if no device open
  } else {
    cache <- TRUE
  }

  if (length(fontkey) != 1 || length(label) != 1) {
    stop("Function `text_details()` is not vectorized.", call. = FALSE)
  }

  # ascent and width depend on label and font
  l1 <- text_info(label, fontkey, fontfamily, font, fontsize, cache)
  # descent and space width depend only on font
  l2 <- font_info(fontkey, fontfamily, font, fontsize, cache)

  # concatenate, result is a list with four members, width_pt, ascent_pt, descent_pt, space_pt
  c(l1, l2)
}

font_info_cache <- new.env(parent = emptyenv())
font_info <- function(fontkey, fontfamily, font, fontsize, cache) {
  info <- font_info_cache[[fontkey]]

  if (is.null(info)) {
    descent_pt <- convertHeight(grobDescent(textGrob(
      label = "gjpqyQ",
      gp = gpar(
        fontsize = fontsize,
        fontfamily = fontfamily,
        font = font,
        cex = 1
      )
    )), "pt", valueOnly = TRUE)

    space_pt <- convertWidth(grobWidth(textGrob(
      label = " ",
      gp = gpar(
        fontsize = fontsize,
        fontfamily = fontfamily,
        font = font,
        cex = 1
      )
    )), "pt", valueOnly = TRUE)

    info <- list(descent_pt = descent_pt, space_pt = space_pt)

    if (cache) {
      font_info_cache[[fontkey]] <- info
    }
  }
  info
}

text_info_cache <- new.env(parent = emptyenv())
text_info <- function(label, fontkey, fontfamily, font, fontsize, cache) {
  key <- paste0(label, fontkey)
  info <- text_info_cache[[key]]

  if (is.null(info)) {
    ascent_pt <- convertHeight(grobHeight(textGrob(
      label = label,
      gp = gpar(
        fontsize = fontsize,
        fontfamily = fontfamily,
        font = font,
        cex = 1
      )
    )), "pt", valueOnly = TRUE)

    width_pt <- convertWidth(grobWidth(textGrob(
      label = label,
      gp = gpar(
        fontsize = fontsize,
        fontfamily = fontfamily,
        font = font,
        cex = 1
      )
    )), "pt", valueOnly = TRUE)

    info <- list(width_pt = width_pt, ascent_pt = ascent_pt)

    if (cache) {
      text_info_cache[[key]] <- info
    }
  }
  info
}