From 8ebaae191d941ebd29357f85e492194f76e48fbb Mon Sep 17 00:00:00 2001 From: Claus Wilke Date: Wed, 4 Dec 2019 12:57:14 -0600 Subject: [PATCH 1/4] rough draft for with_sf() function --- DESCRIPTION | 3 ++- NAMESPACE | 1 + R/with-sf.R | 37 +++++++++++++++++++++++++++++++++++++ man/with_sf.Rd | 14 ++++++++++++++ 4 files changed, 54 insertions(+), 1 deletion(-) create mode 100644 R/with-sf.R create mode 100644 man/with_sf.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 20143da6b5..f07e81ac0e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -250,9 +250,10 @@ Collate: 'utilities-resolution.r' 'utilities-table.r' 'utilities-tidy-eval.R' + 'with-sf.R' 'zxx.r' 'zzz.r' VignetteBuilder: knitr -RoxygenNote: 7.0.1 +RoxygenNote: 7.0.2 Roxygen: list(markdown = TRUE) Encoding: UTF-8 diff --git a/NAMESPACE b/NAMESPACE index af5d41396e..40c1fffe9f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -630,6 +630,7 @@ export(update_labels) export(update_stat_defaults) export(vars) export(waiver) +export(with_sf) export(wrap_dims) export(xlab) export(xlim) diff --git a/R/with-sf.R b/R/with-sf.R new file mode 100644 index 0000000000..956fe042e7 --- /dev/null +++ b/R/with-sf.R @@ -0,0 +1,37 @@ +#' Turn regular layers into sf layers +#' +#' @param ... Layer +#' @export +with_sf <- function(...) { + l <- list(...)[[1]] # can handle only one layer for now + parent_geom <- l$geom + ggproto(NULL, l, + geom = ggproto('SfedGeom', parent_geom, + draw_panel = function(data, panel_params, coord, na.rm = FALSE) { + sfed_coord <- ggproto('SfedCoord', coord, + transform = function(data, range) { + data <- sfed_transform(data, crs = coord$crs) + coord$transform(data, range) + } + ) + parent_geom$draw_panel(data, panel_params, sfed_coord, na.rm) + } + ) + ) +} + + +sfed_transform <- function(data, crs = NULL) { + if (is.null(crs)) { + return(data) + } + + sf_data <- sf::st_sfc( + sf::st_multipoint(cbind(data$x, data$y)), + crs = "+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs" + ) + sf_data_trans <- sf::st_transform(sf_data, crs)[[1]] + data$x <- sf_data_trans[, 1] + data$y <- sf_data_trans[, 2] + data +} diff --git a/man/with_sf.Rd b/man/with_sf.Rd new file mode 100644 index 0000000000..30eee164b1 --- /dev/null +++ b/man/with_sf.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/with-sf.R +\name{with_sf} +\alias{with_sf} +\title{Turn regular layers into sf layers} +\usage{ +with_sf(...) +} +\arguments{ +\item{...}{Layer} +} +\description{ +Turn regular layers into sf layers +} From 80604091c3bce6e74e8924156f63111458d793b1 Mon Sep 17 00:00:00 2001 From: Claus Wilke Date: Wed, 4 Dec 2019 14:59:08 -0600 Subject: [PATCH 2/4] progress --- R/with-sf.R | 50 ++++++++++++++++++++++++++++++++++++++++---------- man/with_sf.Rd | 6 +++++- 2 files changed, 45 insertions(+), 11 deletions(-) diff --git a/R/with-sf.R b/R/with-sf.R index 956fe042e7..e713a301a9 100644 --- a/R/with-sf.R +++ b/R/with-sf.R @@ -1,34 +1,64 @@ #' Turn regular layers into sf layers #' #' @param ... Layer +#' @param crs Coordinate reference system of the origin layer. Defaults to +#' longitude and latitude in WGS84 (EPSG:4326), the World Geodetic System +#' from 1984. #' @export -with_sf <- function(...) { - l <- list(...)[[1]] # can handle only one layer for now - parent_geom <- l$geom - ggproto(NULL, l, - geom = ggproto('SfedGeom', parent_geom, +with_sf <- function(..., crs = 4326) { + x <- list(...) + with_sf_impl(x, crs) +} + +with_sf_impl <- function(x, crs, ...) { + UseMethod("with_sf_impl") +} + +with_sf_impl.default <- function(x, crs, ...) { + stop( + "Can't convert object of class `", class(x), "` to an sf layer.\n", + call. = FALSE + ) +} + +with_sf_impl.list <- function(x, crs, ...) { + l <- list() + # for some reason lapply() version of this doesn't work + for (i in seq_along(x)) { + l[[i]] <- with_sf_impl(x[[i]], crs) + } + if (length(l) == 1) return(l[[1]]) + l +} + +with_sf_impl.Layer <- function(x, crs, ...) { + parent_geom <- x$geom + ggproto(NULL, x, + geom = ggproto('SfifiedGeom', parent_geom, draw_panel = function(data, panel_params, coord, na.rm = FALSE) { - sfed_coord <- ggproto('SfedCoord', coord, + sfified_coord <- ggproto('SfifiedCoord', coord, transform = function(data, range) { - data <- sfed_transform(data, crs = coord$crs) + data <- sfified_transform(data, crs = coord$crs, source_crs = crs) coord$transform(data, range) } + ## TODO: + ## need to implement backtransform_range() ) - parent_geom$draw_panel(data, panel_params, sfed_coord, na.rm) + parent_geom$draw_panel(data, panel_params, sfified_coord, na.rm) } ) ) } -sfed_transform <- function(data, crs = NULL) { +sfified_transform <- function(data, crs = NULL, source_crs = 4326) { if (is.null(crs)) { return(data) } sf_data <- sf::st_sfc( sf::st_multipoint(cbind(data$x, data$y)), - crs = "+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs" + crs = source_crs ) sf_data_trans <- sf::st_transform(sf_data, crs)[[1]] data$x <- sf_data_trans[, 1] diff --git a/man/with_sf.Rd b/man/with_sf.Rd index 30eee164b1..5c5eb8c54c 100644 --- a/man/with_sf.Rd +++ b/man/with_sf.Rd @@ -4,10 +4,14 @@ \alias{with_sf} \title{Turn regular layers into sf layers} \usage{ -with_sf(...) +with_sf(..., crs = 4326) } \arguments{ \item{...}{Layer} + +\item{crs}{Coordinate reference system of the origin layer. Defaults to +longitude and latitude in WGS84 (EPSG:4326), the World Geodetic System +from 1984.} } \description{ Turn regular layers into sf layers From 4d9ea749f9e3fe32319a1487b9f41a19db11f303 Mon Sep 17 00:00:00 2001 From: Claus Wilke Date: Wed, 4 Dec 2019 15:38:56 -0600 Subject: [PATCH 3/4] enable coord munching --- R/with-sf.R | 24 ++++++++++++++++++++---- 1 file changed, 20 insertions(+), 4 deletions(-) diff --git a/R/with-sf.R b/R/with-sf.R index e713a301a9..dedc7042cd 100644 --- a/R/with-sf.R +++ b/R/with-sf.R @@ -35,16 +35,32 @@ with_sf_impl.Layer <- function(x, crs, ...) { parent_geom <- x$geom ggproto(NULL, x, geom = ggproto('SfifiedGeom', parent_geom, - draw_panel = function(data, panel_params, coord, na.rm = FALSE) { + draw_panel = function(data, panel_params, coord, ...) { sfified_coord <- ggproto('SfifiedCoord', coord, transform = function(data, range) { data <- sfified_transform(data, crs = coord$crs, source_crs = crs) coord$transform(data, range) + }, + + backtransform_range = function(panel_params) { + # we create a bounding box, transform all four corners, and then extract the max extent + x <- panel_params$x_range + y <- panel_params$y_range + data <- list(x = c(x, x), y = c(y, rev(y))) + data <- sfified_transform(data, crs = crs, source_crs = coord$crs) + list(x = range(data$x), y = range(data$y)) + }, + + # normally coord_sf() pretends to be linear, but as used here it is not + is_linear = function() FALSE, + + distance = function(self, x, y, panel_params) { + d <- self$backtransform_range(panel_params) + max_dist <- dist_euclidean(d$x, d$y) + dist_euclidean(x, y) / max_dist } - ## TODO: - ## need to implement backtransform_range() ) - parent_geom$draw_panel(data, panel_params, sfified_coord, na.rm) + parent_geom$draw_panel(data, panel_params, sfified_coord, ...) } ) ) From bc383ee630e9e0e5a9b3a5fefda264f124e2572b Mon Sep 17 00:00:00 2001 From: Claus Wilke Date: Wed, 4 Dec 2019 16:06:28 -0600 Subject: [PATCH 4/4] add documentation, handle geom parameters correctly --- R/with-sf.R | 37 +++++++++++++++++++++++++++++++++++-- man/with_sf.Rd | 34 +++++++++++++++++++++++++++++++--- 2 files changed, 66 insertions(+), 5 deletions(-) diff --git a/R/with-sf.R b/R/with-sf.R index dedc7042cd..4439828000 100644 --- a/R/with-sf.R +++ b/R/with-sf.R @@ -1,6 +1,34 @@ -#' Turn regular layers into sf layers +#' Turn regular geoms/stats into sf-ified geoms/stats #' -#' @param ... Layer +#' This function allows you to wrap ordinary geoms and stats for use within +#' a `geom_sf()`/`coord_sf()` framework. By default, it assumes that coordinates +#' in the wrapped geoms/stats are given in standard latitude/longitude coordinates, +#' and it transforms those coordinates into those used by `coord_sf()`. However, +#' it is also possible to specify an alternative coordinate reference system (crs) +#' for the geoms/stats that are being wrapped. +#' @examples +#' \donttest{ +#' nc <- sf::st_read(system.file("shape/nc.shp", package = "sf"), quiet = TRUE) +#' +#' df <- data.frame(lat = 35.76667, long = -78.63333, name = "Raleigh") +#' +#' ggplot(df, aes(x = long, y = lat)) + +#' geom_sf(data = nc, size = 0.1, fill = "white", inherit.aes = FALSE) + +#' with_sf( +#' geom_point(), +#' geom_text(aes(label = name), hjust = -.1, vjust = 1.1) +#' ) + +#' coord_sf(crs = 2264) +#' +#' ggplot(nc) + +#' geom_sf(size = 0.1, fill = "white") + +#' with_sf( +#' geom_hline(yintercept = 34:36), +#' geom_vline(xintercept = c(-84, -80, -76)) +#' ) + +#' coord_sf(crs = 2264) +#' } +#' @param ... One or more geom/stat or lists of geoms/stats to be transformed #' @param crs Coordinate reference system of the origin layer. Defaults to #' longitude and latitude in WGS84 (EPSG:4326), the World Geodetic System #' from 1984. @@ -61,6 +89,11 @@ with_sf_impl.Layer <- function(x, crs, ...) { } ) parent_geom$draw_panel(data, panel_params, sfified_coord, ...) + }, + + parameters = function(self, extra = FALSE) { + # make sure we extract parameters of wrapped geom correctly + parent_geom$parameters(extra) } ) ) diff --git a/man/with_sf.Rd b/man/with_sf.Rd index 5c5eb8c54c..eb8dfee017 100644 --- a/man/with_sf.Rd +++ b/man/with_sf.Rd @@ -2,17 +2,45 @@ % Please edit documentation in R/with-sf.R \name{with_sf} \alias{with_sf} -\title{Turn regular layers into sf layers} +\title{Turn regular geoms/stats into sf-ified geoms/stats} \usage{ with_sf(..., crs = 4326) } \arguments{ -\item{...}{Layer} +\item{...}{One or more geom/stat or lists of geoms/stats to be transformed} \item{crs}{Coordinate reference system of the origin layer. Defaults to longitude and latitude in WGS84 (EPSG:4326), the World Geodetic System from 1984.} } \description{ -Turn regular layers into sf layers +This function allows you to wrap ordinary geoms and stats for use within +a \code{geom_sf()}/\code{coord_sf()} framework. By default, it assumes that coordinates +in the wrapped geoms/stats are given in standard latitude/longitude coordinates, +and it transforms those coordinates into those used by \code{coord_sf()}. However, +it is also possible to specify an alternative coordinate reference system (crs) +for the geoms/stats that are being wrapped. +} +\examples{ +\donttest{ +nc <- sf::st_read(system.file("shape/nc.shp", package = "sf"), quiet = TRUE) + +df <- data.frame(lat = 35.76667, long = -78.63333, name = "Raleigh") + +ggplot(df, aes(x = long, y = lat)) + + geom_sf(data = nc, size = 0.1, fill = "white", inherit.aes = FALSE) + + with_sf( + geom_point(), + geom_text(aes(label = name), hjust = -.1, vjust = 1.1) + ) + + coord_sf(crs = 2264) + +ggplot(nc) + + geom_sf(size = 0.1, fill = "white") + + with_sf( + geom_hline(yintercept = 34:36), + geom_vline(xintercept = c(-84, -80, -76)) + ) + + coord_sf(crs = 2264) +} }