Implement geom_sf_label() and geom_sf_text()

DESCRIPTION

@@ -212,6 +212,7 @@ Collate:
     'stat-qq-line.R'
     'stat-qq.r'
     'stat-quantile.r'
+    'stat-sf-coordinates.R'
     'stat-smooth-methods.r'
     'stat-smooth.r'
     'stat-sum.r'

NAMESPACE

@@ -217,6 +217,7 @@ export(StatQq)
 export(StatQqLine)
 export(StatQuantile)
 export(StatSf)
+export(StatSfCoordinates)
 export(StatSmooth)
 export(StatSum)
 export(StatSummary)
@@ -335,6 +336,8 @@ export(geom_ribbon)
 export(geom_rug)
 export(geom_segment)
 export(geom_sf)
+export(geom_sf_label)
+export(geom_sf_text)
 export(geom_smooth)
 export(geom_spoke)
 export(geom_step)
@@ -527,6 +530,7 @@ export(stat_qq)
 export(stat_qq_line)
 export(stat_quantile)
 export(stat_sf)
+export(stat_sf_coordinates)
 export(stat_smooth)
 export(stat_spoke)
 export(stat_sum)

NEWS.md

@@ -35,6 +35,11 @@
     is now always internally converted to "colour", even when part of a longer
     aesthetic name (e.g., `point_color`) (@clauswilke, #2649).
 
+*   New `geom_sf_label()` and `geom_sf_text()` draw labels and text on sf objects.
+    Under the hood, new `stat_sf_coordinates()` calculates the x and y from the
+    coordinates of the geometries. You can customize the calculation method via
+    `fun.geometry` argument (@yutannihilation, #2761).
+
 # ggplot2 3.0.0
 
 ## Breaking changes

R/sf.R

@@ -1,18 +1,19 @@
 #' Visualise sf objects
 #'
 #' This set of geom, stat, and coord are used to visualise simple feature (sf)
-#' objects. For simple plots, you will only need `geom_sf` as it
-#' uses `stat_sf` and adds `coord_sf` for you. `geom_sf` is
+#' objects. For simple plots, you will only need `geom_sf()` as it
+#' uses `stat_sf()` and adds `coord_sf()` for you. `geom_sf()` is
 #' an unusual geom because it will draw different geometric objects depending
 #' on what simple features are present in the data: you can get points, lines,
 #' or polygons.
+#' For text and labels, you can use `geom_sf_text()` and `geom_sf_label()`.
 #'
 #' @section Geometry aesthetic:
-#' `geom_sf` uses a unique aesthetic: `geometry`, giving an
+#' `geom_sf()` uses a unique aesthetic: `geometry`, giving an
 #' column of class `sfc` containing simple features data. There
 #' are three ways to supply the `geometry` aesthetic:
 #'
-#'   - Do nothing: by default `geom_sf` assumes it is stored in
+#'   - Do nothing: by default `geom_sf()` assumes it is stored in
 #'     the `geometry` column.
 #'   - Explicitly pass an `sf` object to the `data` argument.
 #'     This will use the primary geometry column, no matter what it's called.
@@ -23,7 +24,7 @@
 #'
 #' @section CRS:
 #' `coord_sf()` ensures that all layers use a common CRS. You can
-#' either specify it using the `CRS` param, or `coord_sf` will
+#' either specify it using the `CRS` param, or `coord_sf()` will
 #' take it from the first layer that defines a CRS.
 #'
 #' @param show.legend logical. Should this layer be included in the legends?
@@ -32,6 +33,7 @@
 #'
 #'   You can also set this to one of "polygon", "line", and "point" to
 #'   override the default legend.
+#' @seealso [stat_sf_coordinates()]
 #' @examples
 #' if (requireNamespace("sf", quietly = TRUE)) {
 #' nc <- sf::st_read(system.file("shape/nc.shp", package = "sf"), quiet = TRUE)
@@ -70,6 +72,11 @@
 #'   "+proj=laea +y_0=0 +lon_0=155 +lat_0=-90 +ellps=WGS84 +no_defs"
 #' )
 #' ggplot() + geom_sf(data = world2)
+#'
+#' # To add labels, use geom_sf_label().
+#' ggplot(nc_3857[1:3, ]) +
+#'    geom_sf(aes(fill = AREA)) +
+#'    geom_sf_label(aes(label = NAME))
 #' }
 #' @name ggsf
 NULL
@@ -249,6 +256,114 @@ geom_sf <- function(mapping = aes(), data = NULL, stat = "sf",
   )
 }
 
+#' @export
+#' @rdname ggsf
+#' @inheritParams geom_label
+#' @inheritParams stat_sf_coordinates
+geom_sf_label <- function(mapping = aes(), data = NULL,
+                          stat = "sf_coordinates", position = "identity",
+                          ...,
+                          parse = FALSE,
+                          nudge_x = 0,
+                          nudge_y = 0,
+                          label.padding = unit(0.25, "lines"),
+                          label.r = unit(0.15, "lines"),
+                          label.size = 0.25,
+                          na.rm = FALSE,
+                          show.legend = NA,
+                          inherit.aes = TRUE,
+                          fun.geometry = NULL) {
+
+  # Automatically determin name of geometry column
+  if (!is.null(data) && is_sf(data)) {
+    geometry_col <- attr(data, "sf_column")
+  } else {
+    geometry_col <- "geometry"
+  }
+  if (is.null(mapping$geometry)) {
+    mapping$geometry <- as.name(geometry_col)
+  }
+
+  if (!missing(nudge_x) || !missing(nudge_y)) {
+    if (!missing(position)) {
+      stop("Specify either `position` or `nudge_x`/`nudge_y`", call. = FALSE)
+    }
+
+    position <- position_nudge(nudge_x, nudge_y)
+  }
+
+  layer(
+    data = data,
+    mapping = mapping,
+    stat = stat,
+    geom = GeomLabel,
+    position = position,
+    show.legend = show.legend,
+    inherit.aes = inherit.aes,
+    params = list(
+      parse = parse,
+      label.padding = label.padding,
+      label.r = label.r,
+      label.size = label.size,
+      na.rm = na.rm,
+      fun.geometry = fun.geometry,
+      ...
+    )
+  )
+}
+
+#' @export
+#' @rdname ggsf
+#' @inheritParams geom_text
+#' @inheritParams stat_sf_coordinates
+geom_sf_text <- function(mapping = aes(), data = NULL,
+                         stat = "sf_coordinates", position = "identity",
+                         ...,
+                         parse = FALSE,
+                         nudge_x = 0,
+                         nudge_y = 0,
+                         check_overlap = FALSE,
+                         na.rm = FALSE,
+                         show.legend = NA,
+                         inherit.aes = TRUE,
+                         fun.geometry = NULL) {
+  # Automatically determin name of geometry column
+  if (!is.null(data) && is_sf(data)) {
+    geometry_col <- attr(data, "sf_column")
+  } else {
+    geometry_col <- "geometry"
+  }
+  if (is.null(mapping$geometry)) {
+    mapping$geometry <- as.name(geometry_col)
+  }
+
+  if (!missing(nudge_x) || !missing(nudge_y)) {
+    if (!missing(position)) {
+      stop("Specify either `position` or `nudge_x`/`nudge_y`", call. = FALSE)
+    }
+
+    position <- position_nudge(nudge_x, nudge_y)
+  }
+
+  layer(
+    data = data,
+    mapping = mapping,
+    stat = stat,
+    geom = GeomText,
+    position = position,
+    show.legend = show.legend,
+    inherit.aes = inherit.aes,
+    params = list(
+      parse = parse,
+      check_overlap = check_overlap,
+      na.rm = na.rm,
+      fun.geometry = fun.geometry,
+      ...
+    )
+  )
+}
+
+
 #' @export
 scale_type.sfc <- function(x) "identity"
 

R/stat-sf-coordinates.R

@@ -0,0 +1,112 @@
+#' Extract coordinates from 'sf' objects
+#'
+#' `stat_sf_coordinates()` extracts the coordinates from 'sf' objects and
+#' summarises them to one pair of coordinates (x and y) per geometry. This is
+#' convenient when you draw an sf object as geoms like text and labels (so
+#' [geom_sf_text()] and [geom_sf_label()] relies on this).
+#'
+#' @rdname stat_sf_coordinates
+#' @details
+#' coordinates of an `sf` object can be retrieved by `sf::st_coordinates()`.
+#' But, we cannot simply use `sf::st_coordinates()` because, whereas text and
+#' labels require exactly one coordinate per geometry, it returns multiple ones
+#' for a polygon or a line. Thus, these two steps are needed:
+#'
+#' 1. Choose one point per geometry by some function like `sf::st_centroid()`
+#'    or `sf::st_point_on_surface()`.
+#' 2. Retrieve coordinates from the points by `sf::st_coordinates()`.
+#'
+#' For the first step, you can use an arbitrary function via `fun.geometry`.
+#' By default, `function(x) sf::st_point_on_surface(sf::st_zm(x))` is used;
+#' `sf::st_point_on_surface()` seems more appropriate than `sf::st_centroid()`
+#' since lables and text usually are intended to be put within the polygon or
+#' the line. `sf::st_zm()` is needed to drop Z and M dimension beforehand,
+#' otherwise `sf::st_point_on_surface()` may fail when the geometries have M
+#' dimension.
+#' 
+#' @section Computed variables:
+#' \describe{
+#'   \item{x}{X dimension of the simple feature}
+#'   \item{y}{Y dimension of the simple feature}
+#' }
+#'
+#' @examples
+#' if (requireNamespace("sf", quietly = TRUE)) {
+#' nc <- sf::st_read(system.file("shape/nc.shp", package="sf"))
+#' 
+#' ggplot(nc) +
+#'   stat_sf_coordinates()
+#' 
+#' ggplot(nc) +
+#'   geom_errorbarh(
+#'     aes(geometry = geometry,
+#'         xmin = stat(x) - 0.1,
+#'         xmax = stat(x) + 0.1,
+#'         y = stat(y),
+#'         height = 0.04),
+#'     stat = "sf_coordinates"
+#'   )
+#' }
+#' 
+#' @export
+#' @inheritParams stat_identity
+#' @inheritParams geom_point
+#' @param fun.geometry
+#'   A function that takes a `sfc` object and returns a `sfc_POINT` with the
+#'   same length as the input. If `NULL`, `function(x) sf::st_point_on_surface(sf::st_zm(x))`
+#'   will be used. Note that the function may warn about the incorrectness of
+#'   the result if the data is not projected, but you can ignore this except
+#'   when you really care about the exact locations.
+stat_sf_coordinates <- function(mapping = aes(), data = NULL, geom = "point",
+                                position = "identity", na.rm = FALSE,
+                                show.legend = NA, inherit.aes = TRUE,
+                                fun.geometry = NULL,
+                                ...) {
+  # Automatically determin name of geometry column
+  if (!is.null(data) && is_sf(data)) {
+    geometry_col <- attr(data, "sf_column")
+  } else {
+    geometry_col <- "geometry"
+  }
+  if (is.null(mapping$geometry)) {
+    mapping$geometry <- as.name(geometry_col)
+  }
+
+  layer(
+    stat = StatSfCoordinates,
+    data = data,
+    mapping = mapping,
+    geom = geom,
+    position = position,
+    show.legend = show.legend,
+    inherit.aes = inherit.aes,
+    params = list(
+      na.rm = na.rm,
+      fun.geometry = fun.geometry,
+      ...
+    )
+  )
+}
+
+#' @rdname stat_sf_coordinates
+#' @usage NULL
+#' @format NULL
+#' @export
+StatSfCoordinates <- ggproto(
+  "StatSfCoordinates", Stat,
+  compute_group = function(data, scales, fun.geometry = NULL) {
+    if (is.null(fun.geometry)) {
+      fun.geometry <- function(x) sf::st_point_on_surface(sf::st_zm(x))
+    }
+
+    points_sfc <- fun.geometry(data$geometry)
+    coordinates <- sf::st_coordinates(points_sfc)
+    data$x <- coordinates[, "X"]
+    data$y <- coordinates[, "Y"]
+
+    data
+  },
+
+  default_aes = aes(x = stat(x), y = stat(y)),
+  required_aes = c("geometry")
+)