R/style_glow.R

In teunbrand/elementalist: Extra elements for ggplot2

#' Glowing lines
#'
#' Makes copies of lines with increasing linewidth and decreasing alpha, giving an
#' glowing appearance. The functions are used in the following way: \describe{
#'   \item{\code{glow()}}{is a function factory that produces a function that is
#'   subsequently used in elements to make lines glow}
#'   \item{\code{element_rect_glow()}, \code{element_line_glow}}{are convenience
#'   wrappers around \code{element_*_seq()} that pass down the function
#'   generated by \code{glow()}.}
#'   \item{\code{glowing_geoms()}}{is a convenience theme setter for the
#'   \code{elementalist.geom_rect} and \code{elementalist.geom_line} elements.}
#' }
#'
#' @param amount A \code{numeric} larger than 0 for the amount of glow to add.
#' @inheritParams element_line_seq
#' @inheritParams element_rect_seq
#' @param fill Fill colour.
#' @param ... Arguments passed to \code{element_*_seq()}.
#'
#' @details When the elements have no colours by setting them to \code{NA}, this
#' will not draw glowing lines, as is to be expected.
#'
#' Due to the way glowing lines are constructed, having non-solid linetypes
#' may lead to awkward results.
#'
#' @return For \code{glow()}, a \code{function}.
#' @return For \code{element_rect_glow()}, an \code{element_rect_seq} type list.
#' @return For \code{element_line_glow()}, an \code{element_line_seq} type list.
#' @return For \code{glowing_geoms}, a partial \code{theme} object.
#' @export
#' @family theme styles
#'
#' @examples
#' barplot <- ggplot(mpg, aes(class)) +
#'   geom_bar_theme(aes(colour = class)) +
#'   geom_line_theme(stat = "count", aes(group = -1))
#'
#' # Making geoms glow
#' barplot + glowing_geoms()
#'
#' # Making only line geoms glow
#' barplot + theme(elementalist.geom_line = element_line_glow(colour = "magenta"))
#'
#' # Making only rect geoms glow
#' barplot + theme(elementalist.geom_rect = element_rect_glow(fill = "grey50"))
#'
#' # Let other theme elements glow
#' barplot + theme(
#'   axis.line.x = element_line_glow(colour = "magenta"),
#'   axis.line.y = element_line_glow(colour = "cyan"),
#'   legend.background = element_rect_glow(colour = "yellow")
#' )
glow <- function(amount = 3) {
  amount <- force(amount)
  function(x, y, colour, linewidth = 1, id, n) {
    if (all(is.na(colour))) {
      out <- list(
        x = x,
        y = y,
        col = colour,
        lwd = linewidth,
        id = id,
        sub_id = id
      )
      return(out)
    }
    len <- length(x)
    id <- rep(id, n)
    sub_id <- rep(seq_len(n), each = len)
    x <- rep(x, n)
    y <- rep(y, n)

    colour <- alpha(colour, NA)
    alpha <- extract_alpha(colour)
    colour <- substr(colour, 1, 7)

    # Alpha sequence based on coolbutuseless' ggblur alpha.R
    alpha <- seq(1/(n + 1), alpha, length.out = n + 1)
    alpha <- head(alpha, -1)
    ialpha <- numeric(n)
    ialpha[1] <- alpha[1]
    for (i in seq(n - 1)) {
      ialpha[i + 1] <- 1 - (1 - alpha[i + 1]) / (1 - alpha[i])
    }

    colour <- alpha(colour, rev(ialpha))
    colour <- rep(c(colour), each = len)

    linewidth <- qcauchy(seq(0.5, 0.975, length.out = n), linewidth, amount)
    linewidth <- rep(c(linewidth), each = len)

    out <- list(
      x = x,
      y = y,
      col = colour,
      lwd = linewidth,
      id = id,
      sub_id = sub_id
    )
    out[vapply(out, is.null, logical(1))] <- NULL
    out
  }
}

#' @rdname glow
#' @export
element_line_glow <- function(amount = 3, ...) {
  element_line_seq(fun = glow(amount), ...)
}

#' @rdname glow
#' @export
element_rect_glow <- function(amount = 3, ...) {
  element_rect_seq(fun = glow(amount), ...)
}

#' @rdname glow
#' @export
element_polygon_glow <- function(amount = 3, n = 50, ...) {
  params <- list(amount = amount, n = n)
  element_polygon_generic(params = params,
                          subtype = "element_polygon_glow",
                          ...)
}

#' @rdname glow
#' @export
glowing_geoms <- function(
  amount = 3, fill = NULL,
  colour = NULL, linewidth = NULL,
  linetype = NULL, color = NULL, lineend = NULL,
  sides = "tlbr",
  n = 50
) {
  theme(
    elementalist.geom_rect = element_rect_glow(
      amount = amount, fill = fill, colour = colour, linewidth = linewidth,
      linetype = linetype, color = color, n = n, sides = sides
    ),
    elementalist.geom_line = element_line_glow(
      amount = amount, colour = colour, linewidth = linewidth,
      linetype = linetype, color = color, n = n, lineend = lineend
    )
  )
}