R/pander.R

In jrnold/ggthemes: Extra Themes, Scales and Geoms for 'ggplot2'

#' A ggplot theme originated from the pander package
#'
#' The \pkg{pander} ships with a default theme when the 'unify plots' option is
#' enabled via \code{panderOptions}, which is now also available outside of \pkg{pander} internals, like \code{evals},
#' \code{eval.msgs} or \code{Pandoc.brew}.
#' @inheritParams ggplot2::theme_bw
#' @param nomargin suppress the white space around the plot (boolean)
#' @param ff font family, like \code{sans}. Deprecated: use \code{base_family} instead.
#' @param fc font color (name or hexa code)
#' @param fs font size (integer). Deprecated: use \code{base_size} instead.
#' @param gM major grid (boolean)
#' @param gm minor grid (boolean)
#' @param gc grid color (name or hexa code)
#' @param gl grid line type (\code{lty})
#' @param boxes to render a border around the plot or not
#' @param bc background color (name or hexa code)
#' @param pc panel background color (name or hexa code)
#' @param lp legend position
#' @param axis axis angle as defined in \code{par(les)}
#' @export
#' @example inst/examples/ex-theme_pander.R
theme_pander <- function(base_size = 12,  # nolint: cyclocomp_linter
                         base_family = "sans",
                         nomargin = TRUE,
                         ff = NULL,
                         fc = "black",
                         fs = NULL,
                         gM = TRUE, # nolint: object_name_linter
                         gm = TRUE,
                         gc = "grey",
                         gl = "dashed",
                         boxes = FALSE,
                         bc = "white",
                         pc = "transparent",
                         lp = "right",
                         axis = 1) {
  if (hasArg(ff)) {
    base_family <- ff
    warning("Argument `ff` deprecated. Use `base_family` instead.")
  }
  if (hasArg(fs)) {
    base_size <- fs
    warning("Argument `fs` deprecated. Use `base_size` instead.")
  }


  if (requireNamespace("pander", quietly = TRUE)) {
    if (missing(nomargin)) {
      nomargin <- pander::panderOptions("graph.nomargin")
    }
    if (missing(base_family)) {
      base_family <- pander::panderOptions("graph.fontfamily")
    }
    if (missing(fc)) {
      fc <- pander::panderOptions("graph.fontcolor")
    }
    if (missing(base_size)) {
      base_size <- pander::panderOptions("graph.fontsize")
    }
    if (missing(gM)) {
      gM <- pander::panderOptions("graph.grid")  # nolint: object_name_linter
    }
    if (missing(gm)) {
      gm <- pander::panderOptions("graph.grid.minor")
    }
    if (missing(gc)) {
      gc <- pander::panderOptions("graph.grid.color")
    }
    if (missing(gl)) {
      gl <- pander::panderOptions("graph.grid.lty")
    }
    if (missing(boxes)) {
      boxes <- pander::panderOptions("graph.boxes")
    }
    if (missing(bc)) {
      bc <- pander::panderOptions("graph.background")
    }
    if (missing(pc)) {
      pc <- pander::panderOptions("graph.panel.background")
    }
    if (missing(lp)) {
      lp <- pander::panderOptions("graph.legend.position")
    }
    if (missing(axis)) {
      axis <- pander::panderOptions("graph.axis.angle")
    }
  }

  ## DRY
  tc <- ifelse(pc == "transparent", bc, pc) # 'transparent' color

  ## default colors, font and legend position
  res <- theme(
    text = element_text(family = base_family),
    plot.background = element_rect(fill = bc, colour = NA),
    panel.grid = element_line(
      colour = gc,
      linewidth = 0.2, linetype = gl
    ),
    panel.grid.minor = element_line(linewidth = 0.1),
    axis.ticks = element_line(
      colour = gc,
      linewidth = 0.2
    ),
    plot.title = element_text(
      colour = fc,
      face = "bold",
      size = base_size * 1.2
    ),
    axis.text = element_text(
      colour = fc,
      face = "plain", size = base_size * 0.8
    ),
    legend.text = element_text(
      colour = fc, face = "plain",
      size = base_size * 0.8
    ),
    legend.title = element_text(
      colour = fc,
      face = "italic",
      size = base_size
    ),
    axis.title.x = element_text(
      colour = fc,
      face = "plain",
      size = base_size
    ),
    strip.text.x = element_text(
      colour = fc,
      face = "plain",
      size = base_size
    ),
    axis.title.y = element_text(
      colour = fc,
      face = "plain",
      size = base_size,
      angle = 90
    ),
    strip.text.y = element_text(
      colour = fc,
      face = "plain",
      size = base_size,
      angle = -90
    ),
    legend.key = element_rect(colour = gc, fill = "transparent"),
    strip.background = element_rect(
      colour = gc,
      fill = "transparent"
    ),
    panel.border = element_rect(fill = NA, colour = gc),
    panel.background = element_rect(fill = pc, colour = gc),
    legend.position = lp
  )

  ## disable box(es) around the plot
  if (!isTRUE(boxes)) {
    res <- res + theme(
      legend.key = element_rect(
        colour = "transparent",
        fill = "transparent"
      ),
      strip.background = element_rect(
        colour = "transparent",
        fill = "transparent"
      ),
      panel.border = element_rect(
        fill = NA,
        colour = tc
      ),
      panel.background = element_rect(
        fill = pc,
        colour = tc
      )
    )
  }

  ## disable grid
  if (!isTRUE(gM)) {
    res <- res + theme(
      panel.grid = element_blank(),
      panel.grid.major = element_blank(),
      panel.grid.minor = element_blank()
    )
  }
  ## disable minor grid
  if (!isTRUE(gm)) {
    res <- res + theme(panel.grid.minor = element_blank())
  }

  ## margin
  if (nomargin) {
    res <- res + theme(plot.margin = unit(c(0.1, 0.1, 0.1, 0), "lines"))
  }

  ## axis angle (TODO: DRY with ifelse in the default color etc. section)
  if (axis == 0) {
    res <- res + theme(axis.text.y = element_text(
      colour = fc,
      family = base_family,
      face = "plain",
      size = base_size * 0.8,
      angle = 90
    ))
  }

  if (axis == 2) {
    res <- res + theme(axis.text.x = element_text(
      colour = fc,
      family = base_family,
      face = "plain",
      size = base_size * 0.8,
      angle = 90,
      hjust = 1
    ))
  }

  if (axis == 3) {
    res <- res + theme(
      axis.text.y = element_text(
        colour = fc,
        family = base_family,
        face = "plain",
        size = base_size * 0.8,
        angle = 90
      ),
      axis.text.x = element_text(
        colour = fc,
        family = base_family,
        face = "plain",
        size = base_size * 0.8,
        angle = 90,
        hjust = 1
      )
    )
  }

  res
}


#' Color palette from the pander package
#'
#' The \pkg{pander} ships with a default colorblind and printer-friendly
#' color palette borrowed from \verb{https://jfly.iam.u-tokyo.ac.jp/color/}.
#'
#' @param n number of colors. This palette supports up to eight colors.
#' @param random_order if the palette should be reordered randomly before
#'  rendering each plot to get colorful images
#' @export
#' @family colour pander
#' @example inst/examples/ex-palette_pander.R
palette_pander <- function(n, random_order = FALSE) {
  ## default (colorblind and printer-friendly) colors
  cols <- c(
    "#56B4E9", "#009E73", "#F0E442", "#0072B2",
    "#D55E00", "#CC79A7", "#999999", "#E69F00"
  )

  if (requireNamespace("pander", quietly = TRUE)) {
    cols <- pander::panderOptions("graph.colors")
  }

  if (isTRUE(random_order)) {
    cols <- sample(cols)
  }

  if (length(cols) < n) {
    cols <- rep(cols, length.out = n)
  }

  cols[1:n]
}


#' Color scale from the pander package
#'
#' The \pkg{pander} ships with a default colorblind and printer-friendly color
#' palette borrowed from \verb{https://jfly.iam.u-tokyo.ac.jp/color/}.
#' @inheritParams ggplot2::scale_colour_hue
#' @inheritParams palette_pander
#' @family colour pander
#' @rdname scale_pander
#' @seealso \code{\link{theme_pander}()}
#' @export
scale_color_pander <- function(...) {
  discrete_scale("colour", "pander", palette_pander, ...)
}


#' @rdname scale_pander
#' @export
scale_colour_pander <- scale_color_pander


#' @rdname scale_pander
#' @export
scale_fill_pander <- function(...) {
  discrete_scale("fill", "pander", palette_pander, ...)
}