geom-point-sorted.R

#' Points
#'
#' The point geom is used to create scatterplots. The scatterplot is most
#' useful for displaying the relationship between two continuous variables.
#' It can be used to compare one continuous and one categorical variable, or
#' two categorical variables, but a variation like [geom_jitter()],
#' [geom_count()], or [geom_bin2d()] is usually more
#' appropriate. A _bubblechart_ is a scatterplot with a third variable
#' mapped to the size of points.
#'
#' @section Overplotting:
#' The biggest potential problem with a scatterplot is overplotting: whenever
#' you have more than a few points, points may be plotted on top of one
#' another. This can severely distort the visual appearance of the plot.
#' There is no one solution to this problem, but there are some techniques
#' that can help. You can add additional information with
#' [geom_smooth()], [geom_quantile()] or
#' [geom_density_2d()]. If you have few unique `x` values,
#' [geom_boxplot()] may also be useful.
#'
#' Alternatively, you can
#' summarise the number of points at each location and display that in some
#' way, using [geom_count()], [geom_hex()], or
#' [geom_density2d()].
#'
#' Another technique is to make the points transparent (e.g.
#' `geom_point(alpha = 0.05)`) or very small (e.g.
#' `geom_point(shape = ".")`).
#'
#' @inheritParams ggplot2::geom_point
#' @param na.rm If `FALSE`, the default, missing values are removed with
#'   a warning. If `TRUE`, missing values are silently removed.
#' @param ... Other arguments passed on to [layer()]. These are
#'   often aesthetics, used to set an aesthetic to a fixed value, like
#'   `colour = "red"` or `size = 3`. They may also be parameters
#'   to the paired geom/stat.
#' @examples
#' p <- ggplot(mtcars, aes(wt, mpg))
#' p + geom_point()
#'
#' # Add aesthetic mappings
#' p + geom_point(aes(colour = factor(cyl)))
#' p + geom_point(aes(shape = factor(cyl)))
#' # A "bubblechart":
#' p + geom_point(aes(size = qsec))
#'
#' # Set aesthetics to fixed value
#' ggplot(mtcars, aes(wt, mpg)) + geom_point(colour = "red", size = 3)
#'
#' \donttest{
#' # Varying alpha is useful for large datasets
#' d <- ggplot(diamonds, aes(carat, price))
#' d + geom_point(alpha = 1/10)
#' d + geom_point(alpha = 1/20)
#' d + geom_point(alpha = 1/100)
#' }
#'
#' # For shapes that have a border (like 21), you can colour the inside and
#' # outside separately. Use the stroke aesthetic to modify the width of the
#' # border
#' ggplot(mtcars, aes(wt, mpg)) +
#'   geom_point(shape = 21, colour = "black", fill = "white", size = 5, stroke = 5)
#'
#' \donttest{
#' # You can create interesting shapes by layering multiple points of
#' # different sizes
#' p <- ggplot(mtcars, aes(mpg, wt, shape = factor(cyl)))
#' p +
#'   geom_point(aes(colour = factor(cyl)), size = 4) +
#'   geom_point(colour = "grey90", size = 1.5)
#' p +
#'   geom_point(colour = "black", size = 4.5) +
#'   geom_point(colour = "pink", size = 4) +
#'   geom_point(aes(shape = factor(cyl)))
#'
#' # geom_point warns when missing values have been dropped from the data set
#' # and not plotted, you can turn this off by setting na.rm = TRUE
#' set.seed(1)
#' mtcars2 <- transform(mtcars, mpg = ifelse(runif(32) < 0.2, NA, mpg))
#' ggplot(mtcars2, aes(wt, mpg)) +
#'   geom_point()
#' ggplot(mtcars2, aes(wt, mpg)) +
#'   geom_point(na.rm = TRUE)
#' }
#' @importFrom grid pointsGrob gpar grobName grob
#' @importFrom ggplot2 ggproto aes draw_key_point
#' @importFrom vctrs vec_unique
#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL

# ggplot2 utilites.grid.R
ggname <- function(prefix, grob) { # yeah I know its not great practice to put it here, but its only for this
  grob$name <- grobName(grob, prefix)
  grob
}

unique0 <- function(x, ...) if (is.null(x)) x else vec_unique(x, ...)


geom_point_sorted <- function(mapping = NULL, data = NULL,
                              stat = "identity", position = "identity",
                              ...,
                              na.rm = FALSE,
                              show.legend = NA,
                              inherit.aes = TRUE) {
  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomPointSorted,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list2(
      na.rm = na.rm,
      ...
    )
  )
}

GeomPointSorted <- ggproto("GeomPointSorted", ggplot2::Geom,
                           required_aes = c("x", "y"),
                           non_missing_aes = c("size", "shape", "colour"),
                           default_aes = aes(
                             shape = 19, colour = "black", size = 1.5, fill = NA,
                             alpha = NA, stroke = 0.5
                           ),
                           
                           setup_data = function(data, params) {
                             data <- data[order(data$PANEL, data$group, data$x), ]
                           },
                           
                           
                           draw_panel = function(self, data, panel_params, coord, na.rm = FALSE) {
                             if (is.character(data$shape)) {
                               data$shape <- translate_shape_string(data$shape)
                             }
                             
                             coords <- coord$transform(data, panel_params)
                             stroke_size <- coords$stroke
                             stroke_size[is.na(stroke_size)] <- 0
                             ggname("geom_point",
                                    pointsGrob(
                                      coords$x, coords$y,
                                      pch = coords$shape,
                                      gp = gpar(
                                        col = alpha(coords$colour, coords$alpha),
                                        fill = alpha(coords$fill, coords$alpha),
                                        # Stroke is added around the outside of the point
                                        fontsize = coords$size * .pt + stroke_size * .stroke / 2,
                                        lwd = coords$stroke * .stroke / 2
                                      )
                                    )
                             )
                           },
                           
                           draw_key = draw_key_point
)

translate_shape_string <- function(shape_string) {
  # strings of length 0 or 1 are interpreted as symbols by grid
  if (nchar(shape_string[1]) <= 1) {
    return(shape_string)
  }
  
  pch_table <- c(
    "square open"           = 0,
    "circle open"           = 1,
    "triangle open"         = 2,
    "plus"                  = 3,
    "cross"                 = 4,
    "diamond open"          = 5,
    "triangle down open"    = 6,
    "square cross"          = 7,
    "asterisk"              = 8,
    "diamond plus"          = 9,
    "circle plus"           = 10,
    "star"                  = 11,
    "square plus"           = 12,
    "circle cross"          = 13,
    "square triangle"       = 14,
    "triangle square"       = 14,
    "square"                = 15,
    "circle small"          = 16,
    "triangle"              = 17,
    "diamond"               = 18,
    "circle"                = 19,
    "bullet"                = 20,
    "circle filled"         = 21,
    "square filled"         = 22,
    "diamond filled"        = 23,
    "triangle filled"       = 24,
    "triangle down filled"  = 25
  )
  
  shape_match <- charmatch(shape_string, names(pch_table))
  
  invalid_strings <- is.na(shape_match)
  nonunique_strings <- shape_match == 0
  
  if (any(invalid_strings)) {
    bad_string <- unique0(shape_string[invalid_strings])
    cli::cli_abort("Shape aesthetic contains invalid value{?s}: {.val {bad_string}}")
  }
  
  if (any(nonunique_strings)) {
    bad_string <- unique0(shape_string[nonunique_strings])
    cli::cli_abort(c(
      "shape names must be given unambiguously",
      "i" = "Fix {.val {bad_string}}"
    ))
  }
  
  unname(pch_table[shape_match])
}