Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
288 lines (270 sloc) 9.6 KB
#' 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
#' 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
#' 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
#' 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.
#' - Supply your own using `aes(geometry = my_column)`
#'
#' Unlike other aesthetics, `geometry` will never be inherited from
#' the plot.
#'
#' @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
#' take it from the first layer that defines a CRS.
#'
#' @param show.legend logical. Should this layer be included in the legends?
#' `NA`, the default, includes if any aesthetics are mapped.
#' `FALSE` never includes, and `TRUE` always includes.
#'
#' 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)
#' ggplot(nc) +
#' geom_sf(aes(fill = AREA))
#'
#' # If not supplied, coord_sf() will take the CRS from the first layer
#' # and automatically transform all other layers to use that CRS. This
#' # ensures that all data will correctly line up
#' nc_3857 <- sf::st_transform(nc, "+init=epsg:3857")
#' ggplot() +
#' geom_sf(data = nc) +
#' geom_sf(data = nc_3857, colour = "red", fill = NA)
#'
#' # Unfortunately if you plot other types of feature you'll need to use
#' # show.legend to tell ggplot2 what type of legend to use
#' nc_3857$mid <- sf::st_centroid(nc_3857$geometry)
#' ggplot(nc_3857) +
#' geom_sf(colour = "white") +
#' geom_sf(aes(geometry = mid, size = AREA), show.legend = "point")
#'
#' # You can also use layers with x and y aesthetics: these are
#' # assumed to already be in the common CRS.
#' ggplot(nc) +
#' geom_sf() +
#' annotate("point", x = -80, y = 35, colour = "red", size = 4)
#'
#' # Thanks to the power of sf, a geom_sf nicely handles varying projections
#' # setting the aspect ratio correctly.
#' library(maps)
#' world1 <- sf::st_as_sf(map('world', plot = FALSE, fill = TRUE))
#' ggplot() + geom_sf(data = world1)
#'
#' world2 <- sf::st_transform(
#' world1,
#' "+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
#' @export
#' @rdname ggsf
#' @usage NULL
#' @format NULL
GeomSf <- ggproto("GeomSf", Geom,
required_aes = "geometry",
default_aes = aes(
shape = NULL,
colour = NULL,
fill = NULL,
size = NULL,
linetype = 1,
alpha = NA,
stroke = 0.5
),
non_missing_aes = c("size", "shape", "colour"),
draw_panel = function(data, panel_params, coord, legend = NULL,
lineend = "butt", linejoin = "round", linemitre = 10) {
if (!inherits(coord, "CoordSf")) {
stop("geom_sf() must be used with coord_sf()", call. = FALSE)
}
# Need to refactor this to generate one grob per geometry type
coord <- coord$transform(data, panel_params)
sf_grob(coord, lineend = lineend, linejoin = linejoin, linemitre = linemitre)
},
draw_key = function(data, params, size) {
data <- modify_list(default_aesthetics(params$legend), data)
if (params$legend == "point") {
draw_key_point(data, params, size)
} else if (params$legend == "line") {
draw_key_path(data, params, size)
} else {
draw_key_polygon(data, params, size)
}
}
)
default_aesthetics <- function(type) {
if (type == "point") {
GeomPoint$default_aes
} else if (type == "line") {
GeomLine$default_aes
} else {
modify_list(GeomPolygon$default_aes, list(fill = "grey90", colour = "grey35"))
}
}
sf_grob <- function(x, lineend = "butt", linejoin = "round", linemitre = 10) {
# Need to extract geometry out of corresponding list column
geometry <- x$geometry
type <- sf_types[sf::st_geometry_type(geometry)]
is_point <- type %in% "point"
type_ind <- match(type, c("point", "line", "other"))
defaults <- list(
GeomPoint$default_aes,
GeomLine$default_aes,
modify_list(GeomPolygon$default_aes, list(fill = "grey90", colour = "grey35"))
)
default_names <- unique(unlist(lapply(defaults, names)))
defaults <- lapply(setNames(default_names, default_names), function(n) {
unlist(lapply(defaults, function(def) def[[n]] %||% NA))
})
alpha <- x$alpha %||% defaults$alpha[type_ind]
col <- x$colour %||% defaults$colour[type_ind]
col[is_point] <- alpha(col[is_point], alpha[is_point])
fill <- x$fill %||% defaults$fill[type_ind]
fill <- alpha(fill, alpha)
size <- x$size %||% defaults$size[type_ind]
stroke <- (x$stroke %||% defaults$stroke[1]) * .stroke / 2
fontsize <- size * .pt + stroke
lwd <- ifelse(is_point, stroke, size * .pt)
pch <- x$shape %||% defaults$shape[type_ind]
lty <- x$linetype %||% defaults$linetype[type_ind]
gp <- gpar(
col = col, fill = fill, fontsize = fontsize, lwd = lwd, lty = lty,
lineend = lineend, linejoin = linejoin, linemitre = linemitre
)
sf::st_as_grob(geometry, pch = pch, gp = gp)
}
#' @export
#' @rdname ggsf
#' @inheritParams geom_point
geom_sf <- function(mapping = aes(), data = NULL, stat = "sf",
position = "identity", na.rm = FALSE, show.legend = NA,
inherit.aes = TRUE, ...) {
c(
layer_sf(
geom = GeomSf,
data = data,
mapping = mapping,
stat = stat,
position = position,
show.legend = if (is.character(show.legend)) TRUE else show.legend,
inherit.aes = inherit.aes,
params = list(
na.rm = na.rm,
legend = if (is.character(show.legend)) show.legend else "polygon",
...
)
),
coord_sf(default = TRUE)
)
}
#' @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) {
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_sf(
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) {
if (!missing(nudge_x) || !missing(nudge_y)) {
if (!missing(position)) {
stop("You must specify either `position` or `nudge_x`/`nudge_y`.", call. = FALSE)
}
position <- position_nudge(nudge_x, nudge_y)
}
layer_sf(
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,
...
)
)
}
sf_types <- c(GEOMETRY = "other", POINT = "point", LINESTRING = "line",
POLYGON = "other", MULTIPOINT = "point", MULTILINESTRING = "line",
MULTIPOLYGON = "other", GEOMETRYCOLLECTION = "other",
CIRCULARSTRING = "line", COMPOUNDCURVE = "other", CURVEPOLYGON = "other",
MULTICURVE = "other", MULTISURFACE = "other", CURVE = "other",
SURFACE = "other", POLYHEDRALSURFACE = "other", TIN = "other",
TRIANGLE = "other")
You can’t perform that action at this time.