R/layout.R

In glyph: A Grammar of Interactive Graphics

#' @title Layout Composition
#' @name layout
#' @description Built-in multi-plot composition. No external packages needed.
#'   Layouts can express grids, stacks, insets, marginal plots, and
#'   arbitrary nesting. Composed plots can share selections for
#'   cross-filtering (linked brushing).
NULL

#' Compose multiple glyph specs into a layout
#'
#' @param ... glyph_spec objects or layout objects (for nesting)
#' @param type Layout type: "hstack", "vstack", "grid", "wrap"
#' @param widths Relative widths for columns (e.g. c(2, 1) for 2:1 split)
#' @param heights Relative heights for rows
#' @param gap Gap between plots in px
#' @param shared_scales Share axis scales across plots: TRUE, FALSE,
#'   "x", "y", or "both"
#' @param linked_selections Share interaction selections across plots
#' @param title Overall layout title
#' @return A `glyph_layout` object
#' @export
#'
#' @examples
#' p1 <- glyph(mtcars, x = wt, y = mpg) |> mark_point()
#' p2 <- glyph(mtcars, x = wt, y = hp) |> mark_point()
#' p3 <- glyph(mtcars, x = hp, y = mpg) |> mark_line()
#'
#' # Horizontal stack
#' compose(p1, p2, type = "hstack")
#'
#' # Grid with linked brushing
#' compose(p1, p2, p3, type = "wrap",
#'         linked_selections = TRUE, shared_scales = "x")
compose <- function(...,
                    type = "hstack",
                    widths = NULL,
                    heights = NULL,
                    gap = 10,
                    shared_scales = FALSE,
                    linked_selections = FALSE,
                    title = NULL) {
  plots <- list(...)

  # Validate inputs
  valid <- vapply(plots, function(p) {
    inherits(p, "glyph_spec") || inherits(p, "glyph_layout")
  }, logical(1))

  if (!all(valid)) {
    cli::cli_abort("All arguments must be glyph_spec or glyph_layout objects.")
  }

  type <- match.arg(type, c("hstack", "vstack", "grid", "wrap"))

  structure(
    list(
      plots             = plots,
      type              = type,
      widths            = widths,
      heights           = heights,
      gap               = gap,
      shared_scales     = shared_scales,
      linked_selections = linked_selections,
      title             = title
    ),
    class = "glyph_layout"
  )
}

#' Add a marginal plot (histogram/density on axes)
#'
#' @description Draws the distribution of the x and y variables along the
#'   edges of the plot, as a histogram, density curve or boxplot.
#'
#' @param spec A glyph_spec
#' @param x Marginal type for x-axis: "histogram", "density", "boxplot", NULL
#' @param y Marginal type for y-axis: "histogram", "density", "boxplot", NULL
#' @param size Proportion of plot area for marginals (0.0 to 0.4)
#' @return Modified glyph_spec
#' @export
#'
#' @examples
#' glyph(mtcars, x = wt, y = mpg) |>
#'   mark_point(color = cyl) |>
#'   marginals(x = "histogram", y = "density")
marginals <- function(spec, x = "histogram", y = "histogram", size = 0.15) {
  stopifnot(inherits(spec, "glyph_spec"))
  spec$layout <- list(
    type = "marginals",
    x    = x,
    y    = y,
    size = size
  )
  spec
}

#' Add an inset plot
#'
#' @param spec The main glyph_spec
#' @param inset A glyph_spec to place as an inset
#' @param position Where to place: "top-right", "top-left", "bottom-right",
#'   "bottom-left", or a list(x, y, width, height) with proportions 0-1
#' @return Modified glyph_spec
#' @export
inset <- function(spec, inset, position = "top-right") {
  stopifnot(inherits(spec, "glyph_spec"))
  stopifnot(inherits(inset, "glyph_spec"))

  if (is.character(position)) {
    position <- match.arg(position, c("top-right", "top-left",
                                       "bottom-right", "bottom-left"))
  }

  spec$layout <- list(
    type     = "inset",
    inset    = inset,
    position = position
  )
  spec
}

#' Facet a plot by one or two variables
#'
#' @description Splits a plot into small multiples, one panel for each value of
#'   `rows`, `cols`, or both. Panels share their axes unless `free_scales`
#'   lets them vary. With a single faceting variable, `wrap` sets how many
#'   panels go in each row.
#'
#' @param spec A glyph_spec
#' @param rows Row faceting variable: a bare column name, a computed
#'   expression (e.g. \code{factor(cyl)}), or \code{NULL}
#' @param cols Column faceting variable: a bare column name, a computed
#'   expression, or \code{NULL}
#' @param free_scales "none", "x", "y", "both"
#' @param wrap If only one variable, wrap into a grid with this many columns
#' @return Modified glyph_spec
#' @export
facet <- function(spec, rows = NULL, cols = NULL,
                  free_scales = "none", wrap = NULL) {
  stopifnot(inherits(spec, "glyph_spec"))

  # Like aesthetic mappings (capture_mappings()), keep the quosure alongside
  # its label so a computed expression (e.g. `cols = factor(cyl)`) can be
  # evaluated at compile time instead of being used verbatim as a column
  # name that doesn't exist in the data.
  rows_q <- if (!missing(rows)) rlang::enquo(rows) else NULL
  cols_q <- if (!missing(cols)) rlang::enquo(cols) else NULL

  spec$facets <- list(
    rows        = if (!is.null(rows_q)) list(expr = rlang::as_label(rows_q), quosure = rows_q) else NULL,
    cols        = if (!is.null(cols_q)) list(expr = rlang::as_label(cols_q), quosure = cols_q) else NULL,
    free_scales = match.arg(free_scales, c("none", "x", "y", "both")),
    wrap        = wrap
  )
  spec
}

#' Draw a glyph layout when it is printed
#'
#' @description A printed layout draws itself, the same way a single plot
#'   does. At the console it opens in the viewer, and in R Markdown, Quarto
#'   and vignettes it is embedded in the document. Call [render()] only to
#'   set the width and height, and use [summary()][summary.glyph_layout]
#'   for a text description.
#'
#'   In a non-interactive session that isn't knitting a document, such as
#'   `Rscript`, there is nowhere to draw, so printing gives a one-line
#'   description instead.
#' @param x A glyph_layout object
#' @param ... Passed on to knitr when knitting; otherwise ignored.
#' @param options knitr chunk options, supplied by knitr.
#' @return `print()` invisibly returns `x`. `knit_print()` returns the
#'   rendered widget's HTML for knitr to include in the document.
#' @export
print.glyph_layout <- function(x, ...) {
  if (is_interactive()) {
    print(render(x))
  } else {
    cat(sprintf("<glyph_layout: %s, %d panel(s)>\n", x$type, length(x$plots)))
  }
  invisible(x)
}

#' @rdname print.glyph_layout
#' @exportS3Method knitr::knit_print
knit_print.glyph_layout <- function(x, ..., options = NULL) {
  knitr::knit_print(render(x), ..., options = options)
}

#' Summarize a glyph layout
#'
#' @param object A glyph_layout object
#' @param ... Additional arguments (ignored)
#' @return No return value, called for side effects (prints a summary
#'   of the layout to the console)
#' @export
summary.glyph_layout <- function(object, ...) {
  cli::cli_h1("Glyph Layout")
  cli::cli_bullets(c(
    "*" = "Type: {object$type}",
    "*" = "Panels: {length(object$plots)}",
    "*" = "Linked selections: {object$linked_selections}"
  ))
  invisible(object)
}