layer-sf.R

#' Create a new sf layer that auto-maps geometry data
#'
#' The `layer_sf()` function is a variant of [`layer()`] meant to be used by
#' extension developers who are writing new sf-based geoms or stats.
#' The sf layer checks whether the data contains a geometry column, and
#' if one is found it is automatically mapped to the `geometry` aesthetic.
#' @include layer.r
#' @inheritParams layer
#' @keywords internal
#' @export
layer_sf <- function(geom = NULL, stat = NULL,
                     data = NULL, mapping = NULL,
                     position = NULL, params = list(),
                     inherit.aes = TRUE, check.aes = TRUE, check.param = TRUE,
                     show.legend = NA) {
  layer(
    geom = geom, stat = stat, data = data, mapping = mapping,
    position = position, params = params, inherit.aes = inherit.aes,
    check.aes = check.aes, check.param = check.param,
    show.legend = show.legend, layer_class = LayerSf
  )
}

LayerSf <- ggproto("LayerSf", Layer,
  setup_layer = function(self, data, plot) {
    # process generic layer setup first
    data <- ggproto_parent(Layer, self)$setup_layer(data, plot)

    # automatically determine the name of the geometry column
    # and add the mapping if it doesn't exist
    if ((isTRUE(self$inherit.aes) && is.null(self$mapping$geometry) && is.null(plot$mapping$geometry)) ||
        (!isTRUE(self$inherit.aes) && is.null(self$mapping$geometry))) {
      if (is_sf(data)) {
        geometry_col <- attr(data, "sf_column")
        self$mapping$geometry <- as.name(geometry_col)
      }
    }
    data
  }
)

# helper function to find the geometry column
geom_column <- function(data) {
  w <- which(vapply(data, inherits, TRUE, what = "sfc"))
  if (length(w) == 0) {
    "geometry" # avoids breaks when objects without geometry list-column are examined
  } else {
    # this may not be best in case more than one geometry list-column is present:
    if (length(w) > 1)
      warning("more than one geometry column present: taking the first")
    w[[1]]
  }
}

# helper function to determine whether data contains sf column
is_sf <- function(data) {
  inherits(data, "sf")
}

# needed so that sf columns can be mapped without scale

#' @export
scale_type.sfc <- function(x) "identity"