R/fonts.R

In davidgohel/gdtools: Utilities for Graphical Rendering and Fonts Management

#' @importFrom htmltools htmlDependency
#' @importFrom utils packageVersion
#' @export
#' @title 'Google Font' HTML dependency
#' @description Create an HTML dependency ready
#' to be used in 'Shiny' or 'R Markdown'.
#' @details
#' It allows users to use fonts from 'Google Fonts' in an HTML page generated by 'shiny' or 'R Markdown'.
#' At the first request, the font files will be downloaded and stored in a cache on the
#' user's machine, thus avoiding many useless downloads or allowing to work with
#' these fonts afterwards without an Internet connection, in a docker image for example.
#' See [fonts_cache_dir()].
#'
#' The server delivering the font files should not be too busy. That's
#' why a one second pause is added after each download to respect the server's
#' limits. This time can be set with the option `GFONTS_DOWNLOAD_SLEEPTIME` which
#' must be a number of seconds.
#' @param family family name of a 'Google Fonts', for example, "Open Sans", "Roboto",
#' "Fira Code" or "Fira Sans Condensed". Complete list is available with the
#' following command:
#'
#' ```
#' gfonts::get_all_fonts()$family |>
#'   unlist() |>
#'   unique() |>
#'   sort()
#' ```
#' @param subset font subset, a character vector, it defaults to only "latin" and
#' "latin-ext" and can contains values such as "greek", "emoji", "chinese-traditional",
#'
#' Run the following code to get a complete list:
#' ```
#' gfonts::get_all_fonts()$subsets |> unlist() |> unique() |> sort()
#' ```
#'
#' @family functions for font management
#' @return an object defined with [htmlDependency()].
#' @examples
#' \dontrun{
#' if (curl::has_internet()) {
#'   dummy_setup()
#'   gfontHtmlDependency(family = "Open Sans")
#' }
#' }
gfontHtmlDependency <- function(family = "Open Sans", subset = c("latin", "latin-ext")) {
  pkg_version <- packageVersion("gdtools")
  pkg_version_str <- format(pkg_version)

  font_id <- get_font_id(family)
  register_gfont(family = family, subset = subset)

  htmlDependency(
    all_files = TRUE,
    name = font_id,
    version = pkg_version_str,
    src = file.path(fonts_cache_dir(), font_id),
    stylesheet = paste0("css/", font_id, ".css")
  )
}

#' @export
#' @importFrom htmltools tags attachDependencies
#' @title Use a font in Shiny or Markdown
#' @description Add an empty HTML element attached
#' to an 'HTML Dependency' containing
#' the css and the font files so that the font is available
#' in the HTML page. Multiple families are supported.
#'
#' The htmlDependency is defined with function [gfontHtmlDependency()].
#' @inherit gfontHtmlDependency params details
#' @return an HTML object
#' @family functions for font management
#' @examples
#' \dontrun{
#' if (curl::has_internet()) {
#'   dummy_setup()
#'   addGFontHtmlDependency(family = "Open Sans")
#' }
#' }
addGFontHtmlDependency <- function(family = "Open Sans", subset = c("latin", "latin-ext")) {
  attachDependencies(
    x = tags$style(""),
    lapply(family, gfontHtmlDependency, subset = subset)
  )
}

get_font_id <- function(family) {
  x <- gfonts_summary()

  if (!family %in% x$family) {
    stop("Font family ", shQuote(family), " has not been found.",
         call. = FALSE)
  }
  x[x$family %in% family, ]$id
}

#' @importFrom systemfonts register_font
#' @export
#' @title Register a 'Google Fonts'
#' @description Register a font from 'Google Fonts' so that it can be used
#' with devices using the 'systemfonts' package, i.e. the 'flextable'
#' package and graphic outputs generated with the 'ragg', 'svglite'
#' and 'ggiraph' packages.
#' @inherit gfontHtmlDependency params details
#' @return TRUE if the operation went ok.
#' @family functions for font management
#' @examples
#' \dontrun{
#' if (curl::has_internet()) {
#'   dummy_setup()
#'   register_gfont(family = "Roboto")
#' }
#' }
register_gfont <- function(family = "Open Sans", subset = c("latin", "latin-ext")) {
  font_id <- get_font_id(family)
  x <- gfonts_summary()
  faces <- reduce_faces(x[x$id %in% font_id, ]$variants[[1]])

  font_to_cache(family = family, faces = faces, subset = subset)

  files <- lapply(faces, function(face) {
    list.files(
      path = font_dir(font_id),
      pattern = paste0(font_id, "(.*)-", face, "\\.ttf"),
      full.names = TRUE
    )
  })

  if (!font_family_exists(family)) {
    files[["name"]] <- family
    do.call(register_font, files)
  }

  font_family_exists(family)
}

#' @export
#' @title Shell command to install a font from 'Google Fonts'
#' @description Create a string containing a system command to execute
#' so that the font from 'Google Fonts' is installed on the system.
#' Its execution may require root permissions, in dockerfile for example.
#' @inherit gfontHtmlDependency params details
#' @param platform "debian" and "windows" and "macos" are supported.
#' @param file script file to generate, optional. If the parameter is
#' specified, a file will be generated ready for execution. If the
#' platform is Windows, administration rights are required to run
#' the script.
#' @return the 'shell' or 'PowerShell' command as a string
#' @family functions for font management
#' @examples
#' \dontrun{
#' if (curl::has_internet()) {
#'   dummy_setup()
#'   install_gfont_script(family = "Roboto", platform = "macos")
#' }
#' }
install_gfont_script <- function(family = "Open Sans",
                                 subset = c("latin", "latin-ext"),
                                 platform = c("debian", "windows", "macos"),
                                 file = NULL) {
  platform <- match.arg(platform)
  font_id <- get_font_id(family)
  x <- gfonts_summary()
  faces <- reduce_faces(x[x$id %in% font_id, ]$variants[[1]])

  font_to_cache(family = family, faces = faces, subset = subset)

  if ("debian" %in% platform) {
    str <- debian_sysinstall_command(font_id, dir = "custom-fonts")
  } else if ("windows" %in% platform) {
    str <- windows_sysinstall_command(font_id)
  } else {
    str <- macos_sysinstall_command(font_id, dir = if (user_cache_exists()) "~/Library/Fonts" else "/Library/Fonts")
  }

  if (!is.null(file)) {
    writeLines(str, file, useBytes = TRUE)
    Sys.chmod(file, mode = "755")
  }

  invisible(str)
}

#' @export
#' @title List installed 'Google Fonts'
#' @description List installed 'Google Fonts' that can be
#' found in the user cache directory.
#' @return families names as a character vector
#' @family functions for font management
#' @examples
#' \dontrun{
#' if (curl::has_internet()) {
#'   dummy_setup()
#'   register_gfont(family = "Roboto")
#'   installed_gfonts()
#' }
#' }
installed_gfonts <- function() {
  x <- gfonts_summary()
  fonts_ids <- basename(list.dirs(fonts_cache_dir(), recursive = FALSE))
  x$family[x$id %in% fonts_ids]
}

# utils ----
windows_sysinstall_command <- function(font_id) {
  #https://www.jordanmalcolm.com/deploying-windows-10-fonts-at-scale/
  id_dir <- font_dir(font_id)
  install_cmd <- c(
    sprintf("$FontFolder = \"%s\"", id_dir),
    "$FontItem = Get-Item -Path $FontFolder",
    "$FontList = Get-ChildItem -Path \"$FontItem\\*\" -Include ('*.otf','*.ttc','*.ttf')",
    "",
    "foreach ($Font in $FontList) {",
    "  Copy-Item $Font \"C:\\Windows\\Fonts\"",
    "  New-ItemProperty -Name $Font.BaseName -Path \"HKLM:\\Software\\Microsoft\\Windows NT\\CurrentVersion\\Fonts\" -PropertyType string -Value $Font.name",
    "}", "")
  install_cmd <- paste0(install_cmd, collapse = "\n")
  install_cmd
}


debian_sysinstall_command <- function(font_id, dir = "custom-fonts") {
  id_dir <- font_dir(font_id)
  create_dir <- sprintf("mkdir -p /usr/share/fonts/truetype/%s", dir)
  id_dir <- font_dir(font_id)
  install_cmd <- sprintf(
    "find %s -name \"*.ttf\" -exec install -m644 {} /usr/share/fonts/truetype/%s/ \\; || return 1",
    gsub(" ", "\\ ", id_dir, fixed = TRUE), dir
  )

  paste(create_dir, install_cmd, "fc-cache -f", sep = ";")
}


macos_sysinstall_command <- function(font_id, dir = "~/Library/Fonts") {
  id_dir <- font_dir(font_id)
  sprintf("cp %s/* %s", gsub(" ", "\\ ", id_dir, fixed = TRUE), dir)
}