R/geom_rangeframe.R

In vandenman/JASPgraphs: Custom Graphs for JASP

#' @importFrom grid gpar segmentsGrob gTree gList unit
#' @importFrom ggplot2 .pt

# geom_rangeframe is adapted from ggthemes::geom_rangeframe, but it uses the panel_scales
# to compute the endpoints of the lines rather than the data (as ggthemes::geom_rangeframe does)

ggname <- function(prefix, grob) {
  # copy of ggthemes:::ggname
  grob$name <- grid::grobName(grob, prefix)
  grob
}

#' Add base R's bty = 'n' to ggplot2 objects.
#'
#' @description Axis lines which extend to the maximum and minimum of the axis breaks. The implementation and documentation is largely adapted from \code{\link[ggthemes]{geom_rangeframe}}.
#'
#'@section Aesthetics:
#' \itemize{
#' \item colour
#' \item size
#' \item linetype
#' \item alpha
#' }
#'
#' @inheritParams ggplot2::geom_point
#' @param sides A string that controls which sides of the plot the frames appear on.
#'   It can be set to a string containing any of \code{'trbl'}, for top, right,
#'   bottom, and left. By default, only the bottom and left axes lines are drawn.
#'   Note that this is checked at drawing time, so 'b' always means bottom even when using \code{\link[ggplot2]{coord_flip}}.
#' @param panelInfo A list that specifies what information is drawn from what component of panel_scales.
#' Usually, \code{x.major} corresponds to the bottom axis. However, if a scale is used to move e.g.,
#' the x-axis to be above the plot then this needs to be adjusted to \code{x.sec.major_source}. By default,
#' this argument assumes that axis lines above and right of a plot use \code{\link[ggplot2]{sec_axis}} and are
#' therefore draw information from \code{*.sec.major_source}. You can partially set this list; if e.g.,
#' \code{"t"} is missing it will be filled with its default value.
#'
#'
#' @references Tufte, Edward R. (2001) The Visual Display of Quantitative Information, Chapter 6.
#' @references Jeffrey B. Arnold (2019). ggthemes: Extra Themes, Scales and Geoms for 'ggplot2'. R package version 4.2.0. https://CRAN.R-project.org/package=ggthemes
#'
#' @export
#'
#' @example inst/examples/ex-geom_rangeframe.R
geom_rangeframe <- function(mapping = NULL,
                            data = NULL,
                            stat = "identity",
                            position = "identity",
                            ...,
                            sides = "bl",
                            panelInfo = list("t" = "x.sec.major", "r" = "y.sec.major",
                                             "b" = "x.major", "l" = "y.major"),
                            na.rm = FALSE,
                            show.legend = NA,
                            inherit.aes = FALSE) {

  layer(
    # we need to pass some data, otherwise the layer is skipped when no data is inherited
    data = if (is.null(data)) data.frame(x = 1) else data,
    mapping = mapping,
    stat = stat,
    geom = GeomRangeFrame,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      sides     = sides,
      panelInfo = panelInfo,
      na.rm     = na.rm,
      ...
    )
  )
}

getMajor <- function(x) {
  if (getGraphOption("ggVersion") >= "3.3.0")
    x$break_positions()
  else
    x
}

correctPanelInfo <- function(panelInfo) {

  if (getGraphOption("ggVersion") >= "3.3.0") {
    panelInfo <- lapply(panelInfo, function(x) {
      return(switch(x,
                    "x.major"     = "x",
                    "x.sec.major" = "x.sec",
                    "y.major"     = "y",
                    "y.sec.major" = "y.sec",
                    x
      ))
    })
  }

  return(panelInfo)
}

#' @rdname geom_rangeframe
#' @usage NULL
#' @format NULL
#' @export
GeomRangeFrame <- ggplot2::ggproto("GeomRangeFrame", ggplot2::Geom,
  optional_aes = c("x", "y"),

  draw_panel = function(data, panel_scales, coord, sides = "bl",
                        panelInfo = if (getGraphOption("ggVersion") >= "3.3.0") {
                          list("t" = "x.sec", "r" = "y.sec", "b" = "x", "l" = "y")
                        } else {
                          list("t" = "x.sec.major", "r" = "y.sec.major", "b" = "x.major", "l" = "y.major")
                        },
                        lineend = "butt", color = "black",
                        alpha = 1, linetype = 1, size = getGraphOption("bty")[["lwdX"]],
                        adj = getGraphOption("axisTickWidth"), extendForAxisTicks = TRUE) {

    panelInfo <- if (getGraphOption("ggVersion") >= "3.3.0") {
      setDefaults(lst = panelInfo,
                  "t" = "x.sec", "r" = "y.sec", "b" = "x", "l" = "y")

    } else {
      setDefaults(lst = panelInfo,
                  "t" = "x.sec.major", "r" = "y.sec.major", "b" = "x.major", "l" = "y.major")
    }

    # correct any mistakes caused by people have multiple versions of ggplot2 on their system...
    panelInfo <- correctPanelInfo(panelInfo)

    rugs <- list()
    data <- coord[["transform"]](data, panel_scales)
    gp <- gpar(col = scales::alpha(color, alpha),
               lty = linetype,
               lwd = size * ggplot2::.pt,
               lineend = lineend)

    # magic conversion size
    adj <- unit(0.375 * .pt * adj, "pt")

    if (grepl("b", sides)) {

      major <- getMajor(panel_scales[[panelInfo[["b"]]]])

      if (!is.null(major)) {

        rr <- range(major, na.rm = TRUE)

        rugs[["x_b"]] <- ggname(
          "range_x_b",
          segmentsGrob(x0 = unit(rr[1L], "native") - adj,
                       x1 = unit(rr[2L], "native") + adj,
                       y0 = unit(0, "npc"),
                       y1 = unit(0, "npc"),
                       gp = gp))
      }
    }

    if (grepl("t", sides)) {

      major <- getMajor(panel_scales[[panelInfo[["t"]]]])

      if (!is.null(major)) {

        rr <- range(major, na.rm = TRUE)

        rugs[["x_t"]] <- ggname(
          "range_x_t",
          segmentsGrob(x0 = unit(rr[1L], "native") - adj,
                       x1 = unit(rr[2L], "native") + adj,
                       y0 = unit(1, "npc"),
                       y1 = unit(1, "npc"),
                       gp = gp))
      }
    }

    if (grepl("l", sides)) {

      major <- getMajor(panel_scales[[panelInfo[["l"]]]])

      if (!is.null(major)) {

        rr <- range(major, na.rm = TRUE)

        rugs[["y_l"]] <- ggname(
          "range_y_l",
          segmentsGrob(y0 = unit(rr[1L], "native") - adj,
                       y1 = unit(rr[2L], "native") + adj,
                       x0 = unit(0, "npc"),
                       x1 = unit(0, "npc"),
                       gp = gp))
      }
    }

    if (grepl("r", sides)) {

      major <- getMajor(panel_scales[[panelInfo[["r"]]]])

      if (!is.null(major)) {

        rr <- range(major, na.rm = TRUE)

        rugs[["y_r"]] <- ggname(
          "range_y_r",
          segmentsGrob(y0 = unit(rr[1L], "native") - adj,
                       y1 = unit(rr[2L], "native") + adj,
                       x0 = unit(1, "npc"),
                       x1 = unit(1, "npc"),
                       gp = gp))
      }
    }
    ggname("geom_rangeframe", gTree(children = do.call("gList", rugs)))
  },
  default_aes = aes(colour = "black", size = 0.5, linetype = 1, alpha = NA),

  draw_key = ggplot2::draw_key_path
)