R/geom-bagplot.r

In gggda: A 'ggplot2' Extension for Geometric Data Analysis

#' @title Bagplots
#'
#' @description Render bagplots from tagged data comprising medians, hulls,
#'   contours, and outlier specifications.

#' @details `geom_bagplot()` is designed to pair with [stat_bagplot()],
#'   analogously to the pairing of [ggplot2::geom_boxplot()] with
#'   [ggplot2::stat_boxplot()].
#'
#'   Because the optional components are more expensive to compute in this
#'   setting, they are controlled by parameters passed to the stat. Auxiliary
#'   aesthetics like `median.colour` are available that override auxiliary
#'   defaults, and these in turn override the standard defaults. Auxiliary
#'   defaults also take effect when auxiliary aesthetics are passed `NULL`, so
#'   that `stat_bagplot()` and `geom_bagplot()` have the same default behavior.
#'   Pass `sync()` (instead of `NULL`, as in [ggplot2::geom_boxplot()]) to
#'   synchronize an auxiliary aesthetic with its standard counterpart.
#'
#'   **WARNING:**
#'   The trade-off between precision and runtime is greater for depth estimation
#'   than for density estimation. At the resolution of the default \eqn{100
#'   \times 100} grid, basic examples may vary noticeably when starting from
#'   different random seeds.
#' 

#' @section Aesthetics:

#' `geom_bagplot()` understands the following aesthetics (required aesthetics
#' are in bold):

#' - **`x`**
#' - **`y`**
#' - **`component`**
#' - `linewidth`
#' - `linetype`
#' - `colour`
#' - `fill`
#' - `alpha`
#' - `shape`
#' - `stroke`
#' - `size`
#' - `label`
#' - `hjust`
#' - `vjust`
#' - `angle`
#' - `group`
#' 

#' @import ggplot2
#' @inheritParams ggplot2::layer
#' @param outlier_points Logical; whether to plot outlier markers. Defaults to
#'   `! outlier_labels`.
#' @param outlier_labels Logical; whether to plot outlier labels. Defaults to
#'   `FALSE`.
#' @param bag.linetype,bag.linewidth,bag.colour,bag.color,bag.fill,bag.alpha
#'   Default aesthetics for bags. Set to [sync()] to inherit from the data's
#'   aesthetics or to `NULL` to use the data's aesthetics.
#' @param median.shape,median.stroke,median.size,median.colour,median.color,median.fill,median.alpha
#'   Default aesthetics for medians. Set to [sync()] to inherit from the data's
#'   aesthetics or to `NULL` to use the data's aesthetics.
#' @param fence.linetype,fence.linewidth,fence.colour,fence.color,fence.fill,fence.alpha
#'   Default aesthetics for fences. Set to [sync()] to inherit from the data's
#'   aesthetics or to `NULL` to use the data's aesthetics.
#' @param outlier.shape,outlier.stroke,outlier.size,outlier.colour,outlier.color,outlier.fill,outlier.alpha
#'   Default aesthetics for outliers. Set to [sync()] to inherit from the data's
#'   aesthetics or to `NULL` to use the data's aesthetics.
#' @param text.size,text.colour,text.color,text.alpha
#'   Default aesthetics for outlier labels. Set to NULL to inherit from the
#'   data's aesthetics.
#' @template param-geom
#' @template return-layer
#' @family geom layers
#' @example inst/examples/ex-geom-bagplot.r
#' @export
geom_bagplot <- function(
    mapping = NULL, data = NULL, stat = "bagplot", position = "identity",
    outlier_points = ! outlier_labels, outlier_labels = FALSE,
    ...,
    # NB: Defaults declared here will be missed by `layer(geom = "bagplot")` and
    # `stat_bagplot()`; they must be coordinated with the internal `*_defaults`
    # lists.
    # bag_defaults
    bag.linewidth = sync(), bag.linetype = sync(),
    bag.colour = "black", bag.color = NULL,
    bag.fill = sync(), bag.alpha = NA,
    # median_defaults
    median.shape = 21L, median.stroke = sync(), median.size = 5,
    median.colour = sync(), median.color = NULL,
    median.fill = "white", median.alpha = NA,
    # fence_defaults
    fence.linewidth = 0.25, fence.linetype = 0L,
    fence.colour = sync(), fence.color = NULL,
    fence.fill = sync(), fence.alpha = 0.25,
    # outlier_defaults
    outlier.shape = sync(), outlier.stroke = sync(), outlier.size = sync(),
    outlier.colour = sync(), outlier.color = NULL,
    outlier.fill = NA, outlier.alpha = NA,
    # label_defaults
    text.size = 3.88,
    text.colour = sync(), text.color = sync(), text.alpha = sync(),
    na.rm = FALSE,
    show.legend = NA, inherit.aes = TRUE
) {
  
  bag_gp <- list(
    linewidth = bag.linewidth,
    linetype  = bag.linetype,
    colour    = bag.color %||% bag.colour,
    fill      = bag.fill,
    alpha     = bag.alpha
  )
  
  median_gp <- list(
    shape  = median.shape,
    stroke = median.stroke,
    size   = median.size,
    colour = median.color %||% median.colour,
    fill   = median.fill,
    alpha  = median.alpha
  )
  
  fence_gp <- list(
    linewidth  = fence.linewidth,
    linetype   = fence.linetype,
    colour     = fence.color %||% fence.colour,
    fill       = fence.fill,
    alpha      = fence.alpha
  )
  
  outlier_gp <- list(
    shape  = outlier.shape,
    stroke = outlier.stroke,
    size   = outlier.size,
    colour = outlier.color %||% outlier.colour,
    fill   = outlier.fill,
    alpha  = outlier.alpha
  )
  
  label_gp <- list(
    size   = text.size,
    # angle  = text.angle,
    colour = text.color %||% text.colour,
    alpha  = text.alpha
  )
  
  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomBagplot,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      outlier_points = outlier_points, outlier_labels = outlier_labels,
      bag_gp = bag_gp,
      median_gp  = median_gp,
      fence_gp   = fence_gp,
      outlier_gp = outlier_gp,
      label_gp   = label_gp,
      na.rm = na.rm,
      ...
    )
  )
}

#' @rdname gggda-ggproto
#' @format NULL
#' @usage NULL
#' @export
GeomBagplot <- ggproto(
  "GeomBagplot", GeomPolygon,
  
  required_aes = c("x", "y", "component"),
  
  default_aes = aes(
    # taken from `GeomPolygon`, `GeomPoint`, and `GeomText`;
    # required for point grobs
    linewidth = 0.5, linetype = 1L,
    shape = 19L, stroke = 0.5, size = 1.5,
    colour = "black", fill = "grey55", alpha = NA,
    angle = 0, hjust = 0.5, vjust = 0.5,
    label = "", family = "", fontface = 1L
  ),
  
  # TODO: Use `$draw_group()` instead, if bugs can be resolved.
  draw_panel = function(
    data, panel_params, coord,
    outlier_points = ! outlier_labels, outlier_labels = FALSE,
    bag_gp = NULL, median_gp = NULL, fence_gp = NULL,
    outlier_gp = NULL, label_gp = NULL,
    na.rm = FALSE
  ) {
    # save(data, panel_params, coord,
    #      outlier_points, outlier_labels,
    #      bag_gp, median_gp, fence_gp, outlier_gp, label_gp,
    #      na.rm,
    #      file = "geom-bagplot-draw-panel.rda")
    # load("geom-bagplot-draw-panel.rda")
    
    # initialize grob list; append in z-stack order
    grobs <- list()
    
    # fence data
    if (nrow(fence_data <- subset(data, component == "fence")) > 0L) {
      
      # default aesthetics
      fence_defaults <- list(
        linewidth = 0.25,
        linetype = 0L,
        alpha = 0.25
      )
      # specify independent aesthetics
      fence_aes <- GeomPolygon$aesthetics()
      for (aes_name in fence_aes) {
        fence_name <- paste0("fence.", aes_name)
        fence_data[[aes_name]] <- 
          (if (is.sync(fence_gp[[aes_name]])) 
            fence_data[[aes_name]]) %||%
          fence_gp[[aes_name]] %||%
          fence_defaults[[aes_name]] %||% 
          fence_data[[aes_name]]
      }
      fence_aes <- intersect(fence_aes, names(fence_data))
      fence_data <- subset(fence_data, select = fence_aes)
      
      # fence polygon grob
      grobs <- c(grobs, list(GeomPolygon$draw_panel(
        data = fence_data, panel_params = panel_params, coord = coord
      )))
    }
    
    # bag data
    bag_data <- subset(data, component == "bag")
    
    # default aesthetics
    bag_defaults <- list(
      colour = "black",
      alpha = NA
    )
    # specify independent aesthetics
    bag_aes <- GeomPolygon$aesthetics()
    for (aes_name in bag_aes) {
      bag_name <- paste0("bag.", aes_name)
      bag_data[[aes_name]] <- 
        (if (is.sync(bag_gp[[aes_name]])) 
          bag_data[[aes_name]]) %||%
        bag_gp[[aes_name]] %||% 
        bag_defaults[[aes_name]] %||% 
        bag_data[[aes_name]]
    }
    bag_aes <- intersect(bag_aes, names(bag_data))
    bag_data <- subset(bag_data, select = bag_aes)
    
    # bag polygon grob
    grobs <- c(grobs, list(GeomPolygon$draw_panel(
      data = bag_data, panel_params = panel_params, coord = coord
    )))
    
    # median data
    if (nrow(median_data <- subset(data, component == "median")) > 0L) {
      
      # default aesthetics
      median_defaults <- list(
        shape = 21L,
        size = 5,
        fill = "white",
        alpha = NA
      )
      # specify independent aesthetics
      median_aes <- GeomPoint$aesthetics()
      for (aes_name in median_aes) {
        median_name <- paste0("median.", aes_name)
        median_data[[aes_name]] <- 
          (if (is.sync(median_gp[[aes_name]])) 
            median_data[[aes_name]]) %||%
          median_gp[[aes_name]] %||% 
          median_defaults[[aes_name]] %||% 
          median_data[[aes_name]]
      }
      median_aes <- intersect(median_aes, names(median_data))
      median_data <- subset(median_data, select = median_aes)
      
      # median point grob
      grobs <- c(grobs, list(GeomPoint$draw_panel(
        data = median_data, panel_params = panel_params, coord = coord,
        na.rm = na.rm
      )))
    }
    
    # outliers data
    if (nrow(label_data <- outlier_data <-
             subset(data, component == "outliers")) > 0L) {
      
      # if outlier markers
      if (outlier_points) {
        
        # default aesthetics (if not to coordinate with bag and median)
        outlier_defaults <- list(
          fill = NA,
          alpha = NA
        )
        # specify independent aesthetics
        outlier_aes <- GeomPoint$aesthetics()
        for (aes_name in outlier_aes) {
          outlier_name <- paste0("outlier.", aes_name)
          outlier_data[[aes_name]] <- 
            (if (is.sync(outlier_gp[[aes_name]])) 
              outlier_data[[aes_name]]) %||%
            outlier_gp[[aes_name]] %||% 
            outlier_defaults[[aes_name]] %||% 
            outlier_data[[aes_name]]
        }
        outlier_aes <- intersect(outlier_aes, names(outlier_data))
        outlier_data <- subset(outlier_data, select = outlier_aes)
        
        # outliers point grob
        grobs <- c(grobs, list(GeomPoint$draw_panel(
          data = outlier_data, panel_params = panel_params, coord = coord,
          na.rm = na.rm
        )))
      }
      
      # if outlier labels
      if (outlier_labels) {
        
        # default aesthetics
        label_defaults <- list(
          size = 3.88
        )
        # specify independent aesthetics
        label_aes <- GeomText$aesthetics()
        for (aes_name in label_aes) {
          label_name <- paste0("outlier.", aes_name)
          label_data[[aes_name]] <- 
            (if (is.sync(label_gp[[aes_name]])) 
              label_data[[aes_name]]) %||%
            label_gp[[aes_name]] %||% 
            label_defaults[[aes_name]] %||% 
            label_data[[aes_name]]
        }
        label_aes <- intersect(label_aes, names(label_data))
        label_data <- subset(label_data, select = label_aes)
        
        # outliers text grob
        grobs <- c(grobs, list(GeomText$draw_panel(
          data = label_data, panel_params = panel_params, coord = coord,
          na.rm = na.rm
        )))
      }
    }
    
    grob <- do.call(grid::grobTree, grobs)
    grob$name <- grid::grobName(grob, "geom_bagplot")
    grob
  }
)