R/geom_cartogram.r

In hrbrmstr/ggalt: Extra Coordinate Systems, 'Geoms', Statistical Transformations, Scales and Fonts for 'ggplot2'

#' Map polygons layer enabling the display of show statistical information
#'
#' This replicates the old behaviour of \code{geom_map()}, enabling specifying of
#' \code{x} and \code{y} aesthetics.
#'
#' @section Aesthetics:
#' \code{geom_cartogram} understands the following aesthetics (required aesthetics are in bold):
#' \itemize{
#'   \item \code{map_id}
#'   \item \code{alpha}
#'   \item \code{colour}
#'   \item \code{fill}
#'   \item \code{group}
#'   \item \code{linetype}
#'   \item \code{size}
#'   \item \code{x}
#'   \item \code{y}
#' }
#'
#' @export
#' @param map Data frame that contains the map coordinates.  This will
#'   typically be created using \code{\link{fortify}} on a spatial object.
#'   It must contain columns \code{x}, \code{long} or \code{longitude},
#'   \code{y}, \code{lat} or \code{latitude} and \code{region} or \code{id}.
#' @inheritParams ggplot2::layer
#' @inheritParams ggplot2::geom_point
#' @examples \dontrun{
#' # When using geom_polygon, you will typically need two data frames:
#' # one contains the coordinates of each polygon (positions),  and the
#' # other the values associated with each polygon (values).  An id
#' # variable links the two together
#'
#' ids <- factor(c("1.1", "2.1", "1.2", "2.2", "1.3", "2.3"))
#'
#' values <- data.frame(
#'   id = ids,
#'   value = c(3, 3.1, 3.1, 3.2, 3.15, 3.5)
#' )
#'
#' positions <- data.frame(
#'   id = rep(ids, each = 4),
#'   x = c(2, 1, 1.1, 2.2, 1, 0, 0.3, 1.1, 2.2, 1.1, 1.2, 2.5, 1.1, 0.3,
#'   0.5, 1.2, 2.5, 1.2, 1.3, 2.7, 1.2, 0.5, 0.6, 1.3),
#'   y = c(-0.5, 0, 1, 0.5, 0, 0.5, 1.5, 1, 0.5, 1, 2.1, 1.7, 1, 1.5,
#'   2.2, 2.1, 1.7, 2.1, 3.2, 2.8, 2.1, 2.2, 3.3, 3.2)
#' )
#'
#' ggplot() +
#'   geom_cartogram(aes(x, y, map_id = id), map = positions, data=positions)
#'
#' ggplot() +
#'   geom_cartogram(aes(x, y, map_id = id), map = positions, data=positions) +
#'   geom_cartogram(data=values, map=positions, aes(fill = value, map_id=id))
#'
#' ggplot() +
#'   geom_cartogram(aes(x, y, map_id = id), map = positions, data=positions) +
#'   geom_cartogram(data=values, map=positions, aes(fill = value, map_id=id)) +
#'   ylim(0, 3)
#'
#' # Better example
#' crimes <- data.frame(state = tolower(rownames(USArrests)), USArrests)
#' crimesm <- reshape2::melt(crimes, id = 1)
#'
#' if (require(maps)) {
#'
#'   states_map <- map_data("state")
#'
#'   ggplot() +
#'     geom_cartogram(aes(long, lat, map_id = region), map = states_map, data=states_map) +
#'     geom_cartogram(aes(fill = Murder, map_id = state), map=states_map, data=crimes)
#'
#'   last_plot() + coord_map("polyconic")
#'
#'   ggplot() +
#'     geom_cartogram(aes(long, lat, map_id=region), map = states_map, data=states_map) +
#'     geom_cartogram(aes(fill = value, map_id=state), map = states_map, data=crimesm) +
#'     coord_map("polyconic") +
#'     facet_wrap( ~ variable)
#' }
#' }
geom_cartogram <- function(mapping = NULL, data = NULL,
                     stat = "identity",
                     ...,
                     map,
                     na.rm = FALSE,
                     show.legend = NA,
                     inherit.aes = TRUE) {

  # Get map input into correct form

  stopifnot(is.data.frame(map))

  if (!is.null(map$latitude)) map$y <- map$latitude
  if (!is.null(map$lat)) map$y <- map$lat

  if (!is.null(map$longitude)) map$x <- map$longitude
  if (!is.null(map$long)) map$x <- map$long

  if (!is.null(map$region)) map$id <- map$region

  stopifnot(all(c("x", "y", "id") %in% names(map)))

  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomCartogram,
    position = PositionIdentity,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      map = map,
      na.rm = na.rm,
      ...
    )
  )
}

#' Geom Cartogram
#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
GeomCartogram <- ggproto("GeomCartogram", GeomPolygon,
  draw_panel = function(data, panel_scales, coord, map) {
    # Only use matching data and map ids
    common <- intersect(data$map_id, map$id)
    data <- data[data$map_id %in% common, , drop = FALSE]
    map <- map[map$id %in% common, , drop = FALSE]

    # Munch, then set up id variable for polygonGrob -
    # must be sequential integers
    coords <- coord_munch(coord, map, panel_scales)
    coords$group <- coords$group %||% coords$id
    grob_id <- match(coords$group, unique(coords$group))

    # Align data with map
    data_rows <- match(coords$id[!duplicated(grob_id)], data$map_id)
    data <- data[data_rows, , drop = FALSE]

    grid::polygonGrob(coords$x, coords$y, default.units = "native", id = grob_id,
      gp = gpar(
        col = data$colour, fill = alpha(data$fill, data$alpha),
        lwd = data$size * .pt
      )
    )
  },

  optional_aes = c("x", "y"),
  required_aes = c("map_id")

)