xaringanthemer/R/ggplot2.R

#' A Plot Theme for ggplot2 by xaringanthemer
#'
#' Creates [ggplot2] themes to match the xaringanthemer theme used in the
#' [xaringan] slides that seamlessly matches the "normal" slide colors and
#' styles.
#'
#' @param text_color Color for text and foreground, inherits from `text_color`
#' @param background_color Color for background, inherits from
#'   `background_color`
#' @param accent_color Color for titles and accents, inherits from
#'   `header_color`
#' @param accent_secondary_color Color for secondary accents, inherits from
#'   `text_bold_color`
#' @inheritDotParams theme_xaringan_base
#'
#' @examples
#' if (requireNamespace("ggplot2", quietly = TRUE)) {
#'   # Set xaringanthemer theme but save to tempfile
#'   duo_accent(outfile = tempfile())
#'
#'   library(ggplot2)
#'   ggplot(iris) +
#'     aes(Petal.Length, Petal.Width) +
#'     geom_point() +
#'     theme_xaringan()
#' }
#'
#' @family xaringanthemer ggplot2 themes
#' @export
theme_xaringan <- function(
  text_color = NULL,
  background_color = NULL,
  accent_color = NULL,
  accent_secondary_color = NULL,
  ...
) {
  requires_xaringanthemer_env()
  requires_package(fn = "xaringan_theme")

  background_color <- background_color %||% xaringanthemer_env$background_color
  text_color <- text_color %||% xaringanthemer_env$text_color
  accent_color <- accent_color %||% xaringanthemer_env$header_color
  accent_secondary_color <- accent_secondary_color %||% xaringanthemer_env$text_bold_color %||% accent_color

  theme_xaringan_base(text_color, background_color,
                      accent_color = accent_color,
                      accent_secondary_color = accent_secondary_color,
                      ...)
}

#' An Inverse Plot Theme for ggplot2 by xaringanthemer
#'
#' A [ggplot2] xaringanthemer plot theme to seamlessly match the "inverse"
#' [xaringan] slide colors and styles as styled by [xaringanthemer].
#'
#' @param text_color Color for text and foreground, inherits from `text_color`
#' @param background_color Color for background, inherits from
#'   `background_color`
#' @param accent_color Color for titles and accents, inherits from
#'   `header_color`
#' @param accent_secondary_color Color for secondary accents, inherits from
#'   `text_bold_color`
#' @inheritDotParams theme_xaringan_base
#'
#' @examples
#' if (requireNamespace("ggplot2", quietly = TRUE)) {
#'   # Set xaringanthemer theme but save to tempfile
#'   duo_accent(outfile = tempfile())
#'
#'   library(ggplot2)
#'   ggplot(iris) +
#'     aes(Petal.Length, Petal.Width) +
#'     geom_point() +
#'     theme_xaringan()
#' }
#'
#' @family xaringanthemer ggplot2 themes
#' @export
theme_xaringan_inverse <- function(
  text_color = NULL,
  background_color = NULL,
  accent_color = NULL,
  accent_secondary_color = NULL,
  ...
) {
  requires_xaringanthemer_env()
  requires_package(fn = "xaringan_theme")

  background_color <- background_color %||% xaringanthemer_env$inverse_background_color
  text_color <- text_color %||% xaringanthemer_env$inverse_text_color
  accent_color <- accent_color %||% xaringanthemer_env$inverse_header_color
  accent_secondary_color <- accent_secondary_color %||% accent_color

  theme_xaringan_base(text_color, background_color,
                      accent_color = accent_color,
                      accent_secondary_color = accent_secondary_color,
                      ...)
}

#' The ggplot2 xaringanthemer base plot theme
#'
#' Provides a base plot theme for [ggplot2] to match the [xaringan] slide theme
#' created by [xaringanthemer]. The theme is designed to create a general plot
#' style from two colors, a `background_color` and a `text_color` (or foreground
#' color). Also accepts an `accent_color` and an `accent_secondary_color` that are
#' [xaringanthemer] is not required for the base theme. Use
#' [theme_xaringan()] or [theme_xaringan_inverse()] in xaringan slides styled by
#' xaringanthemer for a plot theme that matches the slide style.
#'
#' @param text_color Color for text and foreground
#' @param background_color Color for background
#' @param accent_color Color for titles and accents, inherits from
#'   `header_color` or `text_color`. Used for the `title` base setting in
#'   [ggplot2::theme()], and additionally for setting the `color` or `fill` of
#'   [ggplot2] geom defaults.
#' @param accent_secondary_color Color for secondary accents, inherits from
#'   `text_bold_color` or `accent_color`. Used only when setting [ggplot2] geom
#'   defaults.
#' @param set_ggplot_defaults Should defaults be set for [ggplot2] _geoms_?
#'   Defaults to TRUE. To restore ggplot's defaults, or the previously set geom
#'   defaults, see [theme_xaringan_restore_defaults()].
#' @param text_font Font to use for text elements, passed to
#'   [sysfonts::font_add_google()], if available and `text_font_use_google` is
#'   `TRUE`. Inherits from `text_font_family`.
#' @param text_font_use_google Is `text_font` available on [Google
#'   Fonts](https://fonts.google.com)?
#' @param text_font_size Base text font size, inherits from `text_font_size`, or
#'   defaults to 11.
#' @param title_font Font to use for title elements, passed to
#'   [sysfonts::font_add_google()], if available and `title_font_use_google` is
#'   `TRUE`. Inherits from `title_font_family`.
#' @param title_font_use_google Is `title_font` available on [Google
#'   Fonts](https://fonts.google.com)?
#' @param title_font_size Base text font size, inherits from `title_font_size`,
#'   or defaults to 14.
#' @param ... Ignored
#'
#' @examples
#' if (requireNamespace("ggplot2", quietly = TRUE)) {
#'   library(ggplot2)
#'   ggplot(iris) +
#'     aes(Petal.Length, Petal.Width) +
#'     geom_point() +
#'     theme_xaringan_base(
#'       text_color = "#e1e5f2",
#'       background_color = "#021c25",
#'       accent_color = "#1f7a8c",
#'       set_ggplot_defaults = TRUE) +
#'       labs(title = "Basic Iris Plot",
#'            subtitle = "+ theme_xaringan_base()",
#'            caption = "{xaringanthemer}")
#'
#'    ggplot(iris) +
#'     aes(Petal.Length, Petal.Width) +
#'     geom_point() +
#'     theme_xaringan_base(
#'       text_color = "#021c25",
#'       background_color = "#e1e5f2",
#'       accent_color = "#1f7a8c",
#'       set_ggplot_defaults = TRUE) +
#'       labs(title = "Basic Iris Plot",
#'            subtitle = "+ theme_xaringan_base()",
#'            caption = "{xaringanthemer}")
#' }
#'
#' @family xaringanthemer ggplot2 themes
#' @export
theme_xaringan_base <- function(
  text_color,
  background_color,
  ...,
  set_ggplot_defaults = TRUE,
  accent_color = NULL,
  accent_secondary_color = NULL,
  text_font = NULL,
  text_font_use_google = NULL,
  text_font_size = NULL,
  title_font = NULL,
  title_font_use_google = NULL,
  title_font_size = NULL
) {
  blend <- color_blender(text_color, background_color)

  text_font_size <- text_font_size %||% web_to_point(xaringanthemer_env$text_font_size, scale = 1.25) %||% 11
  title_font_size <- title_font_size %||% web_to_point(xaringanthemer_env$header_h3_font_size, scale = 0.8) %||% 14

  text_font <- if (!is.null(text_font)) {
    register_font(text_font, identical(text_font_use_google, TRUE))
  } else get_theme_font("text")
  title_font <- if (!is.null(title_font)) {
    register_font(title_font, identical(title_font_use_google, TRUE))
  } else get_theme_font("header")

  text_font %||% "sans"
  title_font %||% "sans"

  if (set_ggplot_defaults) {
    accent_color <- accent_color %||% xaringanthemer_env$header_color %||% text_color
    accent_secondary_color <- accent_secondary_color %||% xaringanthemer_env$text_bold_color %||% accent_color
    theme_xaringan_set_defaults(text_color, background_color, accent_color, accent_secondary_color)
  }

  ggplot2::theme(
    line = ggplot2::element_line(color = blend(0.2)),
    rect = ggplot2::element_rect(fill = background_color),
    text = ggplot2::element_text(
      color  = blend(0.1),
      family = text_font,
      size   = text_font_size),
    title = ggplot2::element_text(
      color  = accent_color,
      family = title_font,
      size   = title_font_size),
    plot.background  = ggplot2::element_rect(
      fill  = background_color,
      color = background_color),
    panel.background = ggplot2::element_rect(
      fill  = background_color,
      color = background_color),
    panel.grid.major = ggplot2::element_line(
      color = blend(0.8),
      inherit.blank = TRUE),
    panel.grid.minor = ggplot2::element_line(
      color = blend(0.9),
      inherit.blank = TRUE),
    axis.title = ggplot2::element_text(size = title_font_size * 0.8),
    axis.ticks = ggplot2::element_line(color = blend(0.8)),
    axis.text  = ggplot2::element_text(color = blend(0.4)),
    plot.caption = ggplot2::element_text(
      size  = text_font_size * 0.8,
      color = blend(0.3))
  )
}

#' Set and Restore ggplot2 geom Defaults
#'
#' Set [ggplot2] _geom_ defaults to match [theme_xaringan()] with
#' `theme_xaringan_set_defaults()` and restore the standard or previously-set
#' defaults with `theme_xaringan_restore_defaults()`. By default,
#' `theme_xaringan_set_defaults()` is run with [theme_xaringan()] or
#' [theme_xaringan_inverse()].
#'
#' @family xaringanthemer ggplot2 themes
#' @inheritParams theme_xaringan
#' @export
theme_xaringan_set_defaults <- function(
  text_color = NULL,
  background_color = NULL,
  accent_color = text_color,
  accent_secondary_color = accent_color,
  text_family = NULL
) {
  requires_package("ggplot2")

  blend <- color_blender(text_color, background_color)

  xaringan_theme_defaults <- list(
    "line"       = list(color  = text_color),
    "vline"      = list(color  = accent_secondary_color),
    "hline"      = list(color  = accent_secondary_color),
    "abline"     = list(color  = accent_secondary_color),
    "segment"    = list(color  = text_color),
    "bar"        = list(fill   = accent_color),
    "col"        = list(fill   = accent_color),
    "boxplot"    = list(color  = text_color),
    "contour"    = list(color  = text_color),
    "density"    = list(color  = text_color,
                        fill   = text_color,
                        alpha  = 0.1),
    "dotplot"    = list(color  = accent_color),
    "errorbarh"  = list(color  = text_color),
    "crossbar"   = list(color  = text_color),
    "errorbar"   = list(color  = text_color),
    "linerange"  = list(color  = text_color),
    "pointrange" = list(color  = text_color),
    "map"        = list(color  = text_color),
    "path"       = list(color  = text_color),
    "line"       = list(color  = text_color),
    "step"       = list(color  = text_color),
    "point"      = list(color  = accent_color),
    "polygon"    = list(color  = accent_color,
                        fill   = accent_color),
    "quantile"   = list(color  = text_color),
    "rug"        = list(color  = blend(0.5)),
    "segment"    = list(color  = text_color),
    "smooth"     = list(fill   = blend(0.75),
                        color  = accent_secondary_color),
    "spoke"      = list(color  = text_color),
    "label"      = list(color  = text_color,
                        family = text_family %||% get_theme_font("text")),
    "text"       = list(color  = text_color,
                        family = text_family %||% get_theme_font("text")),
    "rect"       = list(fill   = text_color),
    "tile"       = list(fill   = text_color),
    "violin"     = list(fill   = text_color),
    "sf"         = list(color  = text_color)
  )

  geom_names <- setNames(nm = names(xaringan_theme_defaults))

  previous_defaults <- lapply(
    geom_names,
    function(geom) safely_set_geom(geom, xaringan_theme_defaults[[geom]])
  )

  if (is.null(xaringanthemer_env$old_ggplot_defaults)) {
    xaringanthemer_env$old_ggplot_defaults <- previous_defaults
  }

  invisible(previous_defaults)
}

#' @describeIn theme_xaringan_set_defaults Restore previous or standard [ggplot2] _geom_ defaults.
#' @inheritParams theme_xaringan
#' @export
xaringan_theme_restore_defaults <- function() {
  requires_package("ggplot2")
  requires_xaringanthemer_env()

  if (is.null(xaringanthemer_env$old_ggplot_defaults)) return(invisible())


  old_default <- xaringanthemer_env$old_ggplot_defaults
  old_default_not_std <- vapply(old_default, function(x) length(x) > 0, logical(1))
  old_default <- old_default[old_default_not_std]

  restore_default <- utils::modifyList(xaringanthemer_env$std_ggplot_defaults, old_default)

  geom_names <- setNames(nm = names(restore_default))
  previous_defaults <- lapply(
    geom_names,
    function(geom) safely_set_geom(geom, restore_default[[geom]])
  )

  invisible(previous_defaults)
}

safely_set_geom <- function(geom, new) {
  tryCatch({
    ggplot2::update_geom_defaults(geom, new)
  },
  error = function(e) invisible(),
  warning = function(w) invisible())
}

blend_colors <- function(x, y, alpha = 0.5) {
  x <- colorspace::hex2RGB(x)
  y <- colorspace::hex2RGB(y)
  z <- colorspace::mixcolor(alpha, x, y)
  colorspace::hex(z)
}

color_blender <- function(x, y) function(alpha = 0.5) blend_colors(x, y, alpha)

get_theme_font <- function(element = c("text", "header", "code")) {
  element <- match.arg(element)

  element_family <- paste0(element, "_font_family")
  element_google <- paste0(element, "_font_google")
  element_url    <- paste0(element, "_font_url")

  family <- xaringanthemer_env[[element_family]]
  is_google_font <- !is.null(xaringanthemer_env[[element_google]]) ||
    grepl("fonts.google", xaringanthemer_env[[element_url]], fixed = TRUE)

  register_font(family, google = is_google_font, fn = sys.calls()[[max(1, length(sys.calls()) - 1)]])
}

register_font <- function(
  family,
  google = TRUE,
  fn = sys.calls()[[max(1, length(sys.calls()) - 1)]][[1]],
  ...
) {
  if (is.null(family)) return(NULL)
  family <- gsub("['\"]", "", family)

  if (!identical(xaringanthemer_env$showtext_auto, TRUE)) {
    if (requires_package(pkg = "showtext", fn, required = FALSE)) {
      showtext::showtext_auto()
    } else return(family)
    xaringanthemer_env$showtext_auto <- TRUE
  }

  if (!requires_package(pkg = "sysfonts", fn, required = FALSE)) {
    return(family)
  } else if (!family %in% sysfonts::font_families()) {
    is_default_font <- family %in% c(
      "Roboto", "Source Code Pro", "Yanone Kaffeesatz"
    )
    if (identical(google, TRUE) || is_default_font) {
      sysfonts::font_add_google(family, ...)
    } else {
      warning(paste(
        "Please manually register fonts not served by Google Fonts.",
        "See `sysfonts::font_add()` for more information."))
    }
  }
  family
}

requires_package <- function(pkg = "ggplot2", fn = "", required = TRUE) {
  raise <- if (required) stop else warning
  if (!requireNamespace(pkg, quietly = TRUE)) {
    msg <- paste0(
      "`", pkg, "` is ",
      if (required) "required " else "suggested ",
      if (fn != "") paste0("by ", fn, "() ")[1],
      "but is not installed."
    )
    raise(msg, call. = FALSE)
    invisible(FALSE)
  }
  invisible(TRUE)
}

requires_xaringanthemer_env <- function() {
  if (!exists("xaringanthemer_env") || is.null(xaringanthemer_env$header_color)) {
    stop("Please call a xaringanthemer theme function first.")
  }
}

#' Get the Value of xaringanthemer Style Setting
#'
#' A helper function to retrieve the value of style settings as set by a
#' xaringanthemer style function, for use in plotting and other circumstances.
#'
#' @param setting A xaringanthemer style setting
#' @export
get_xaringanthemer_value <- function(
  setting = c(
    "header_background_content_padding_top", "table_row_border_color",
    "text_bold_color", "code_highlight_color", "footnote_color",
    "text_slide_number_color", "table_row_even_background_color",
    "title_slide_text_color", "background_color", "extra_fonts",
    "header_background_ignore_classes", "header_font_weight", "title_slide_background_image",
    "background_size", "header_h2_font_size", "code_inline_font_size",
    "text_font_google", "header_h1_font_size", "header_background_padding",
    "header_font_family", "code_font_url", "text_font_url", "footnote_position_bottom",
    "title_slide_background_position", "code_inline_color", "link_color",
    "left_column_selected_color", "header_background_text_color",
    "inverse_text_color", "text_color", "code_inline_background_color",
    "extra_css", "outfile", "footnote_font_size", "header_h3_font_size",
    "text_font_base", "code_font_google", "code_font_size", "title_slide_background_size",
    "text_font_size", "padding", "text_font_family", "code_font_family",
    "text_font_family_fallback", "blockquote_left_border_color",
    "left_column_subtle_color", "table_border_color", "inverse_background_color",
    "header_color", "inverse_header_color", "title_slide_background_color",
    "header_background_color", "text_font_weight",
    "background_image", "header_font_google", "text_slide_number_font_size",
    "inverse_text_shadow", "code_font_family_fallback", "header_font_url",
    "background_position", "header_background_auto")
) {
  requires_xaringanthemer_env()
  setting <- match.arg(setting)
  xaringanthemer_env[[setting]]
}

web_to_point <- function(x, px_per_em = 16, scale = 1) {
  if (is.null(x)) return(NULL)
  if (grepl("pt$", x)) {
    return(as.numeric(sub("pt$", "", x)))
  } else if (grepl("px$", x)) {
    x <- as.numeric(sub("px$", "", x))
    return(x * 0.75)
  } else if (grepl("em$", x)) {
    x <- as.numeric(sub("em$", "", x))
    return(x * px_per_em * 0.75)
  } else {
    return()
  }
}