R/facet-.r

In SahaRahul/ggplot2: Create Elegant Data Visualisations Using the Grammar of Graphics

#' @include ggproto.r
NULL

#' @section Facets:
#'
#' All `facet_*` functions returns a `Facet` object or an object of a
#' `Facet` subclass. This object describes how to assign data to different
#' panels, how to apply positional scales and how to lay out the panels, once
#' rendered.
#'
#' Extending facets can range from the simple modifications of current facets,
#' to very laborious rewrites with a lot of [gtable()] manipulation.
#' For some examples of both, please see the extension vignette.
#'
#' `Facet` subclasses, like other extendible ggproto classes, have a range
#' of methods that can be modified. Some of these are required for all new
#' subclasses, while other only need to be modified if need arises.
#'
#' The required methods are:
#'
#'   - `compute_layout`: Based on layer data compute a mapping between
#'   panels, axes, and potentially other parameters such as faceting variable
#'   level etc. This method must return a data.frame containing at least the
#'   columns `PANEL`, `SCALE_X`, and `SCALE_Y` each containing
#'   integer keys mapping a PANEL to which axes it should use. In addition the
#'   data.frame can contain whatever other information is necessary to assign
#'   observations to the correct panel as well as determining the position of
#'   the panel.
#'
#'   - `map_data`: This method is supplied the data for each layer in
#'   turn and is expected to supply a `PANEL` column mapping each row to a
#'   panel defined in the layout. Additionally this method can also add or
#'   subtract data points as needed e.g. in the case of adding margins to
#'   `facet_grid`.
#'
#'   - `draw_panels`: This is where the panels are assembled into a
#'   `gtable` object. The method recieves, among others, a list of grobs
#'   defining the content of each panel as generated by the Geoms and Coord
#'   objects. The responsibility of the method is to decorate the panels with
#'   axes and strips as needed, as well as position them relative to each other
#'   in a gtable. For some of the automatic functions to work correctly, each
#'   panel, axis, and strip grob name must be prefixed with "panel", "axis", and
#'   "strip" respectively.
#'
#' In addition to the methods described above, it is also possible to override
#' the default behaviour of one or more of the following methods:
#'
#'   - `setup_params`:
#'   - `init_scales`: Given a master scale for x and y, create panel
#'   specific scales for each panel defined in the layout. The default is to
#'   simply clone the master scale.
#'
#'   - `train_scales`: Based on layer data train each set of panel
#'   scales. The default is to train it on the data related to the panel.
#'
#'   - `finish_data`: Make last-minute modifications to layer data
#'   before it is rendered by the Geoms. The default is to not modify it.
#'
#'   - `draw_back`: Add a grob in between the background defined by the
#'   Coord object (usually the axis grid) and the layer stack. The default is to
#'   return an empty grob for each panel.
#'
#'   - `draw_front`: As above except the returned grob is placed
#'   between the layer stack and the foreground defined by the Coord object
#'   (usually empty). The default is, as above, to return an empty grob.
#'
#'   - `draw_labels`: Given the gtable returned by `draw_panels`,
#'   add axis titles to the gtable. The default is to add one title at each side
#'   depending on the position and existance of axes.
#'
#' All extension methods recieve the content of the params field as the params
#' argument, so the constructor function will generally put all relevant
#' information into this field. The only exception is the `shrink`
#' parameter which is used to determine if scales are retrained after Stat
#' transformations has been applied.
#'
#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
Facet <- ggproto("Facet", NULL,
  shrink = FALSE,
  params = list(),

  compute_layout = function(data, params) {
    stop("Not implemented", call. = FALSE)
  },
  map_data = function(data, layout, params) {
    stop("Not implemented", call. = FALSE)
  },
  init_scales = function(layout, x_scale = NULL, y_scale = NULL, params) {
    scales <- list()
    if (!is.null(x_scale)) {
      scales$x <- plyr::rlply(max(layout$SCALE_X), x_scale$clone())
    }
    if (!is.null(y_scale)) {
      scales$y <- plyr::rlply(max(layout$SCALE_Y), y_scale$clone())
    }
    scales
  },
  train_scales = function(x_scales, y_scales, layout, data, params) {
    # loop over each layer, training x and y scales in turn
    for (layer_data in data) {
      match_id <- match(layer_data$PANEL, layout$PANEL)

      if (!is.null(x_scales)) {
        x_vars <- intersect(x_scales[[1]]$aesthetics, names(layer_data))
        SCALE_X <- layout$SCALE_X[match_id]

        scale_apply(layer_data, x_vars, "train", SCALE_X, x_scales)
      }

      if (!is.null(y_scales)) {
        y_vars <- intersect(y_scales[[1]]$aesthetics, names(layer_data))
        SCALE_Y <- layout$SCALE_Y[match_id]

        scale_apply(layer_data, y_vars, "train", SCALE_Y, y_scales)
      }
    }
  },
  draw_back = function(data, layout, x_scales, y_scales, theme, params) {
    rep(list(zeroGrob()), length(unique(layout$PANEL)))
  },
  draw_front = function(data, layout, x_scales, y_scales, theme, params) {
    rep(list(zeroGrob()), length(unique(layout$PANEL)))
  },
  draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, params) {
    stop("Not implemented", call. = FALSE)
  },
  draw_labels = function(panels, layout, x_scales, y_scales, ranges, coord, data, theme, labels, params) {
    panel_dim <-  find_panel(panels)

    xlab_height_top <- grobHeight(labels$x[[1]])
    panels <- gtable_add_rows(panels, xlab_height_top, pos = 0)
    panels <- gtable_add_grob(panels, labels$x[[1]], name = "xlab-t",
      l = panel_dim$l, r = panel_dim$r, t = 1, clip = "off")

    xlab_height_bottom <- grobHeight(labels$x[[2]])
    panels <- gtable_add_rows(panels, xlab_height_bottom, pos = -1)
    panels <- gtable_add_grob(panels, labels$x[[2]], name = "xlab-b",
      l = panel_dim$l, r = panel_dim$r, t = -1, clip = "off")

    panel_dim <-  find_panel(panels)

    ylab_width_left <- grobWidth(labels$y[[1]])
    panels <- gtable_add_cols(panels, ylab_width_left, pos = 0)
    panels <- gtable_add_grob(panels, labels$y[[1]], name = "ylab-l",
      l = 1, b = panel_dim$b, t = panel_dim$t, clip = "off")

    ylab_width_right <- grobWidth(labels$y[[2]])
    panels <- gtable_add_cols(panels, ylab_width_right, pos = -1)
    panels <- gtable_add_grob(panels, labels$y[[2]], name = "ylab-r",
      l = -1, b = panel_dim$b, t = panel_dim$t, clip = "off")

    panels
  },
  setup_params = function(data, params) {
    params
  },
  setup_data = function(data, params) {
    data
  },
  finish_data = function(data, layout, x_scales, y_scales, params) {
    data
  },
  vars = function() {
    character(0)
  }
)

# Helpers -----------------------------------------------------------------

#' Quote faceting variables
#'
#' @description
#'
#' Just like [aes()], `vars()` is a [quoting function][rlang::quotation]
#' that takes inputs to be evaluated in the context of a dataset.
#' These inputs can be:
#'
#' * variable names
#' * complex expressions
#'
#' In both cases, the results (the vectors that the variable
#' represents or the results of the expressions) are used to form
#' faceting groups.
#'
#' @param ... Variables or expressions automatically quoted. These are
#'   evaluated in the context of the data to form faceting groups. Can
#'   be named (the names are passed to a [labeller][labellers]).
#'
#' @seealso [aes()], [facet_wrap()], [facet_grid()]
#' @export
#' @examples
#' p <- ggplot(diamonds) + geom_point(aes(carat, price))
#' p + facet_wrap(vars(cut, clarity))
#'
#' # vars() makes it easy to pass variables from wrapper functions:
#' wrap_by <- function(...) {
#'   facet_wrap(vars(...), labeller = label_both)
#' }
#' p + wrap_by(cut)
#' p + wrap_by(cut, clarity)
#'
#'
#' # You can also supply expressions to vars(). In this case it's often a
#' # good idea to supply a name as well:
#' p + wrap_by(depth = cut_number(depth, 3))
#'
#' # Let's create another function for cutting and wrapping a
#' # variable. This time it will take a named argument instead of dots,
#' # so we'll have to use the "enquote and unquote" pattern:
#' wrap_cut <- function(var, n = 3) {
#'   # Let's enquote the named argument `var` to make it auto-quoting:
#'   var <- enquo(var)
#'
#'   # `quo_name()` will create a nice default name:
#'   nm <- quo_name(var)
#'
#'   # Now let's unquote everything at the right place. Note that we also
#'   # unquote `n` just in case the data frame has a column named
#'   # `n`. The latter would have precedence over our local variable
#'   # because the data is always masking the environment.
#'   wrap_by(!!nm := cut_number(!!var, !!n))
#' }
#'
#' # Thanks to tidy eval idioms we now have another useful wrapper:
#' p + wrap_cut(depth)
vars <- function(...) {
  rlang::quos(...)
}


#' Is this object a faceting specification?
#'
#' @param x object to test
#' @keywords internal
#' @export
is.facet <- function(x) inherits(x, "Facet")

# A "special" value, currently not used but could be used to determine
# if faceting is active
NO_PANEL <- -1L

unique_combs <- function(df) {
  if (length(df) == 0) return()

  unique_values <- plyr::llply(df, ulevels)
  rev(expand.grid(rev(unique_values), stringsAsFactors = FALSE,
    KEEP.OUT.ATTRS = TRUE))
}

df.grid <- function(a, b) {
  if (is.null(a) || nrow(a) == 0) return(b)
  if (is.null(b) || nrow(b) == 0) return(a)

  indexes <- expand.grid(
    i_a = seq_len(nrow(a)),
    i_b = seq_len(nrow(b))
  )
  plyr::unrowname(cbind(
    a[indexes$i_a, , drop = FALSE],
    b[indexes$i_b, , drop = FALSE]
  ))
}

# A facets spec is a list of facets. A grid facetting needs two facets
# while a wrap facetting flattens all dimensions and thus accepts any
# number of facets.
#
# A facets is a list of grouping variables. They are typically
# supplied as variable names but can be expressions.
#
# as_facets() is complex due to historical baggage but its main
# purpose is to create a facets spec from a formula: a + b ~ c + d
# creates a facets list with two components, each of which bundles two
# facetting variables.

as_facets_list <- function(x) {
  if (inherits(x, "mapping")) {
    stop("Please use `vars()` to supply facet variables")
  }
  if (inherits(x, "quosures")) {
    x <- rlang::quos_auto_name(x)
    return(list(x))
  }

  # This needs to happen early because we might get a formula.
  # facet_grid() directly converted strings to a formula while
  # facet_wrap() called as.quoted(). Hence this is a little more
  # complicated for backward compatibility.
  if (rlang::is_string(x)) {
    x <- rlang::parse_expr(x)
  }

  # At this level formulas are coerced to lists of lists for backward
  # compatibility with facet_grid(). The LHS and RHS are treated as
  # distinct facet dimensions and `+` defines multiple facet variables
  # inside each dimension.
  if (rlang::is_formula(x)) {
    return(f_as_facets_list(x))
  }

  # For backward-compatibility with facet_wrap()
  if (!rlang::is_bare_list(x)) {
    x <- as_quoted(x)
  }

  # If we have a list there are two possibilities. We may already have
  # a proper facet spec structure. Otherwise we coerce each element
  # with as_quoted() for backward compatibility with facet_grid().
  if (is.list(x)) {
    x <- lapply(x, as_facets)
  }

  if (sum(vapply(x, length, integer(1))) == 0L) {
    stop("Must specify at least one variable to facet by", call. = FALSE)
  }

  x
}

# Compatibility with plyr::as.quoted()
as_quoted <- function(x) {
  if (is.character(x)) {
    return(rlang::parse_exprs(x))
  }
  if (is.null(x)) {
    return(list())
  }
  if (rlang::is_formula(x)) {
    return(simplify(x))
  }
  list(x)
}
# From plyr:::as.quoted.formula
simplify <- function(x) {
  if (length(x) == 2 && rlang::is_symbol(x[[1]], "~")) {
    return(simplify(x[[2]]))
  }
  if (length(x) < 3) {
    return(list(x))
  }
  op <- x[[1]]; a <- x[[2]]; b <- x[[3]]

  if (rlang::is_symbol(op, c("+", "*", "~"))) {
    c(simplify(a), simplify(b))
  } else if (rlang::is_symbol(op, "-")) {
    c(simplify(a), expr(-!!simplify(b)))
  } else {
    list(x)
  }
}

f_as_facets_list <- function(f) {
  lhs <- function(x) if (length(x) == 2) NULL else x[-3]
  rhs <- function(x) if (length(x) == 2) x else x[-2]

  rows <- f_as_facets(lhs(f))
  cols <- f_as_facets(rhs(f))

  if (length(rows) + length(cols) == 0) {
    stop("Must specify at least one variable to facet by", call. = FALSE)
  }

  if (length(rows)) {
    list(rows, cols)
  } else {
    list(cols)
  }
}

as_facets <- function(x) {
  if (is_facets(x)) {
    return(x)
  }

  if (rlang::is_formula(x)) {
    # Use different formula method because plyr's does not handle the
    # environment correctly.
    f_as_facets(x)
  } else {
    vars <- as_quoted(x)
    rlang::as_quosures(vars, globalenv(), named = TRUE)
  }
}
f_as_facets <- function(f) {
  if (is.null(f)) {
    return(rlang::as_quosures(list()))
  }

  env <- rlang::f_env(f) %||% globalenv()

  # as.quoted() handles `+` specifications
  vars <- plyr::as.quoted(f)

  # `.` in formulas is ignored
  vars <- discard_dots(vars)

  rlang::as_quosures(vars, env, named = TRUE)
}
discard_dots <- function(x) {
  x[!vapply(x, identical, logical(1), as.name("."))]
}

is_facets <- function(x) {
  if (!is.list(x)) {
    return(FALSE)
  }
  if (!length(x)) {
    return(FALSE)
  }
  all(vapply(x, rlang::is_quosure, logical(1)))
}


# When evaluating variables in a facet specification, we evaluate bare
# variables and expressions slightly differently. Bare variables should
# always succeed, even if the variable doesn't exist in the data frame:
# that makes it possible to repeat data across multiple factors. But
# when evaluating an expression, you want to see any errors. That does
# mean you can't have background data when faceting by an expression,
# but that seems like a reasonable tradeoff.
eval_facets <- function(facets, data, env = globalenv()) {
  vars <- compact(lapply(facets, eval_facet, data, env = env))
  tibble::as_tibble(vars)
}
eval_facet <- function(facet, data, env = emptyenv()) {
  if (rlang::quo_is_symbol(facet)) {
    facet <- as.character(rlang::quo_get_expr(facet))

    if (facet %in% names(data)) {
      out <- data[[facet]]
    } else {
      out <- NULL
    }
    return(out)
  }

  rlang::eval_tidy(facet, data, env)
}

layout_null <- function() {
  # PANEL needs to be a factor to be consistent with other facet types
  data.frame(PANEL = factor(1), ROW = 1, COL = 1, SCALE_X = 1, SCALE_Y = 1)
}

check_layout <- function(x) {
  if (all(c("PANEL", "SCALE_X", "SCALE_Y") %in% names(x))) {
    return()
  }

  stop(
    "Facet layout has bad format. ",
    "It must contain columns 'PANEL', 'SCALE_X', and 'SCALE_Y'",
    call. = FALSE
  )
}


#' Get the maximal width/length of a list of grobs
#'
#' @param grobs A list of grobs
#'
#' @return The largest value. measured in cm as a unit object
#'
#' @keywords internal
#' @export
max_height <- function(grobs) {
  unit(max(unlist(lapply(grobs, height_cm))), "cm")
}
#' @rdname max_height
#' @export
max_width <- function(grobs) {
  unit(max(unlist(lapply(grobs, width_cm))), "cm")
}
#' Find panels in a gtable
#'
#' These functions help detect the placement of panels in a gtable, if they are
#' named with "panel" in the beginning. `find_panel` returns the extend of
#' the panel area, while `panel_cols` and `panel_rows` returns the
#' columns and rows that contains panels respectively.
#'
#' @param table A gtable
#'
#' @return A data.frame with some or all of the columns t(op), r(ight),
#' b(ottom), and l(eft)
#'
#' @keywords internal
#' @export
find_panel <- function(table) {
  layout <- table$layout
  panels <- layout[grepl("^panel", layout$name), , drop = FALSE]

  data.frame(
    t = min(panels$t),
    r = max(panels$r),
    b = max(panels$b),
    l = min(panels$l)
  )
}
#' @rdname find_panel
#' @export
panel_cols = function(table) {
  panels <- table$layout[grepl("^panel", table$layout$name), , drop = FALSE]
  unique(panels[, c('l', 'r')])
}
#' @rdname find_panel
#' @export
panel_rows <- function(table) {
  panels <- table$layout[grepl("^panel", table$layout$name), , drop = FALSE]
  unique(panels[, c('t', 'b')])
}
#' Take input data and define a mapping between faceting variables and ROW,
#' COL and PANEL keys
#'
#' @param data A list of data.frames, the first being the plot data and the
#' subsequent individual layer data
#' @param env The environment the vars should be evaluated in
#' @param vars A list of quoted symbols matching columns in data
#' @param drop should missing combinations/levels be dropped
#'
#' @return A data.frame with columns for PANEL, ROW, COL, and faceting vars
#'
#' @keywords internal
#' @export
combine_vars <- function(data, env = emptyenv(), vars = NULL, drop = TRUE) {
  if (length(vars) == 0) return(data.frame())

  # For each layer, compute the facet values
  values <- compact(plyr::llply(data, eval_facets, facets = vars, env = env))

  # Form the base data frame which contains all combinations of faceting
  # variables that appear in the data
  has_all <- unlist(plyr::llply(values, length)) == length(vars)
  if (!any(has_all)) {
    stop("At least one layer must contain all variables used for faceting")
  }

  base <- unique(plyr::ldply(values[has_all]))
  if (!drop) {
    base <- unique_combs(base)
  }

  # Systematically add on missing combinations
  for (value in values[!has_all]) {
    if (empty(value)) next;

    old <- base[setdiff(names(base), names(value))]
    new <- unique(value[intersect(names(base), names(value))])
    if (drop) {
      new <- unique_combs(new)
    }
    base <- rbind(base, df.grid(old, new))
  }

  if (empty(base)) {
    stop("Faceting variables must have at least one value", call. = FALSE)
  }

  base
}
#' Render panel axes
#'
#' These helpers facilitates generating theme compliant axes when
#' building up the plot.
#'
#' @param x,y A list of ranges as available to the draw_panel method in
#' `Facet` subclasses.
#' @param coord A `Coord` object
#' @param theme A `theme` object
#' @param transpose Should the output be transposed?
#'
#' @return A list with the element "x" and "y" each containing axis
#' specifications for the ranges passed in. Each axis specification is a list
#' with a "top" and "bottom" element for x-axes and "left" and "right" element
#' for y-axis, holding the respective axis grobs. Depending on the content of x
#' and y some of the grobs might be zeroGrobs. If `transpose=TRUE` the
#' content of the x and y elements will be transposed so e.g. all left-axes are
#' collected in a left element as a list of grobs.
#'
#' @keywords internal
#' @export
#'
render_axes <- function(x = NULL, y = NULL, coord, theme, transpose = FALSE) {
  axes <- list()
  if (!is.null(x)) {
    axes$x <- lapply(x, coord$render_axis_h, theme)
  }
  if (!is.null(y)) {
    axes$y <- lapply(y, coord$render_axis_v, theme)
  }
  if (transpose) {
    axes <- list(
      x = list(
        top = lapply(axes$x, `[[`, "top"),
        bottom = lapply(axes$x, `[[`, "bottom")
      ),
      y = list(
        left = lapply(axes$y, `[[`, "left"),
        right = lapply(axes$y, `[[`, "right")
      )
    )
  }
  axes
}
#' Render panel strips
#'
#' All positions are rendered and it is up to the facet to decide which to use
#'
#' @param x,y A data.frame with a column for each variable and a row for each
#' combination to draw
#' @param labeller A labeller function
#' @param theme a `theme` object
#'
#' @return A list with an "x" and a "y" element, each containing a "top" and
#' "bottom" or "left" and "right" element respectively. These contains a list of
#' rendered strips as gtables.
#'
#' @keywords internal
#' @export
render_strips <- function(x = NULL, y = NULL, labeller, theme) {
  list(
    x = build_strip(x, labeller, theme, TRUE),
    y = build_strip(y, labeller, theme, FALSE)
  )
}


check_coord_freedom <- function(coord) {
  # Check first element of class vector because this is a hideous hack on
  # top of another hideous hack
  class <- class(coord)[[1]]

  if (class %in% c("CoordCartesian", "CoordFlip")) {
    return()
  }

  stop(
    "Free scales are only supported with `coord_cartesian()` and `coord_flip()`",
    call. = FALSE
  )
}