Commit 7b7e8ace authored by Andreas Tille's avatar Andreas Tille

New upstream version 0.7-6+dfsg

parent 3ae97489
Package: sf
Version: 0.7-2
Date: 2018-11-24
Version: 0.7-6
Title: Simple Features for R
Authors@R:
c(person(given = "Edzer",
......@@ -36,18 +35,22 @@ Authors@R:
comment = c(ORCID = "0000-0002-4035-0289")),
person(given = "Kirill",
family = "Müller",
role = "ctb"),
person(given = "Thomas Lin",
family = "Pedersen",
role = "ctb"))
Description: Support for simple features, a standardized way to
encode spatial vector data. Binds to 'GDAL' for reading and writing
data, to 'GEOS' for geometrical operations, and to 'PROJ' for
projection conversions and datum transformations.
License: GPL-2 | MIT + file LICENSE
URL: https://github.com/r-spatial/sf/
URL: https://github.com/r-spatial/sf/, https://r-spatial.github.io/sf/
BugReports: https://github.com/r-spatial/sf/issues/
Depends: methods, R (>= 3.3.0)
Imports: classInt (>= 0.2-1), DBI (>= 0.8), graphics, grDevices, grid,
magrittr, Rcpp, stats, tools, units (>= 0.6-0), utils
Suggests: blob, covr, dplyr (>= 0.7-0), ggplot2, knitr, lwgeom (>=
magrittr, Rcpp (>= 0.12.18), stats, tools, units (>= 0.6-0),
utils
Suggests: blob, covr, dplyr (>= 0.8-0), ggplot2, knitr, lwgeom (>=
0.1-5), maps, maptools, mapview, microbenchmark, odbc, pillar,
pool, raster, rgdal, rgeos, rlang, rmarkdown, RPostgres (>=
1.1.0), RPostgreSQL, RSQLite, sp (>= 1.2-4), spatstat, stars
......@@ -65,9 +68,10 @@ Collate: 'RcppExports.R' 'init.R' 'crs.R' 'bbox.R' 'read.R' 'db.R'
'cast_sfg.R' 'cast_sfc.R' 'graticule.R' 'datasets.R'
'aggregate.R' 'agr.R' 'maps.R' 'join.R' 'sample.R' 'valid.R'
'collection_extract.R' 'jitter.R' 'sgbp.R' 'spatstat.R'
'stars.R' 'crop.R' 'gdal_utils.R' 'nearest.R' 'deprecated.R'
'stars.R' 'crop.R' 'gdal_utils.R' 'nearest.R' 'normalize.R'
'deprecated.R'
NeedsCompilation: yes
Packaged: 2018-12-20 08:55:02 UTC; edzer
Packaged: 2019-07-05 07:47:37 UTC; edzer
Author: Edzer Pebesma [aut, cre] (<https://orcid.org/0000-0001-8049-7069>),
Roger Bivand [ctb] (<https://orcid.org/0000-0003-2392-6140>),
Etienne Racine [ctb],
......@@ -77,7 +81,8 @@ Author: Edzer Pebesma [aut, cre] (<https://orcid.org/0000-0001-8049-7069>),
Robin Lovelace [ctb],
Hadley Wickham [ctb],
Jeroen Ooms [ctb] (<https://orcid.org/0000-0002-4035-0289>),
Kirill Müller [ctb]
Kirill Müller [ctb],
Thomas Lin Pedersen [ctb]
Maintainer: Edzer Pebesma <edzer.pebesma@uni-muenster.de>
Repository: CRAN
Date/Publication: 2018-12-20 10:10:03 UTC
Date/Publication: 2019-07-05 12:30:08 UTC
This diff is collapsed.
......@@ -74,6 +74,14 @@ S3method(st_as_grob,MULTIPOLYGON)
S3method(st_as_grob,MULTISURFACE)
S3method(st_as_grob,POINT)
S3method(st_as_grob,POLYGON)
S3method(st_as_grob,sfc)
S3method(st_as_grob,sfc_CIRCULARSTRING)
S3method(st_as_grob,sfc_LINESTRING)
S3method(st_as_grob,sfc_MULTILINESTRING)
S3method(st_as_grob,sfc_MULTIPOINT)
S3method(st_as_grob,sfc_MULTIPOLYGON)
S3method(st_as_grob,sfc_POINT)
S3method(st_as_grob,sfc_POLYGON)
S3method(st_as_sf,Spatial)
S3method(st_as_sf,data.frame)
S3method(st_as_sf,lpp)
......@@ -154,6 +162,7 @@ S3method(st_coordinates,sfc)
S3method(st_coordinates,sfg)
S3method(st_crop,sf)
S3method(st_crop,sfc)
S3method(st_crs,CRS)
S3method(st_crs,Raster)
S3method(st_crs,Spatial)
S3method(st_crs,bbox)
......@@ -169,9 +178,13 @@ S3method(st_difference,sfg)
S3method(st_geometry,sf)
S3method(st_geometry,sfc)
S3method(st_geometry,sfg)
S3method(st_interpolate_aw,sf)
S3method(st_intersection,sf)
S3method(st_intersection,sfc)
S3method(st_intersection,sfg)
S3method(st_intersects,sf)
S3method(st_intersects,sfc)
S3method(st_intersects,sfg)
S3method(st_is,sf)
S3method(st_is,sfc)
S3method(st_is,sfg)
......@@ -184,6 +197,9 @@ S3method(st_nearest_points,sfg)
S3method(st_node,sf)
S3method(st_node,sfc)
S3method(st_node,sfg)
S3method(st_normalize,sf)
S3method(st_normalize,sfc)
S3method(st_normalize,sfg)
S3method(st_point_on_surface,sf)
S3method(st_point_on_surface,sfc)
S3method(st_point_on_surface,sfg)
......@@ -326,6 +342,7 @@ export(st_multipolygon)
export(st_nearest_feature)
export(st_nearest_points)
export(st_node)
export(st_normalize)
export(st_overlaps)
export(st_point)
export(st_point_on_surface)
......@@ -374,8 +391,12 @@ importFrom(Rcpp,evalCpp)
importFrom(classInt,classIntervals)
importFrom(grDevices,dev.size)
importFrom(grDevices,rgb)
importFrom(grid,convertHeight)
importFrom(grid,convertUnit)
importFrom(grid,convertWidth)
importFrom(grid,current.viewport)
importFrom(grid,gList)
importFrom(grid,gpar)
importFrom(grid,linesGrob)
importFrom(grid,nullGrob)
importFrom(grid,pathGrob)
......@@ -391,6 +412,7 @@ importFrom(methods,slotNames)
importFrom(stats,aggregate)
importFrom(stats,na.omit)
importFrom(stats,runif)
importFrom(stats,setNames)
importFrom(tools,file_ext)
importFrom(tools,file_path_sans_ext)
importFrom(units,as_units)
......
# version 0.7-5
* `as(x, "Spatial")` now gives a proper error message on empty geometries; #1093
* `st_cast` now takes care of empty polygons; #1094
* `st_nearest_*` functions now warn in case they are used with geographic coordinates; #1081
* `st_union` no longer segfaults on zero row `sf` objects; #1077
* `st_transform` no longer breaks on zero row `sf` objects; #1075
* when PROJ >= 6.1.0 is available and sf comes with datum files (as is the case with statically linked Windows and OSX CRAN binaries), `PROJ_LIB` is no longer temporarily overwritten, but the PROJ C api is used to set the datum path; #1074, suggested by Jeroen Ooms
* sf now compiles against GDAL 3.x and PROJ 6.1.0, using the new `proj.h` interface; #1070
* `st_distance` returns `NA` for empty geometries, rather than 0; #1055
# version 0.7-4
* add example on how voronoi polygons can be tied back to the points they contain; #1030
* `st_difference(x, y)`, with `x` an `sfc` with zero feature geometries, now returns `x`; #1024
* don't reset (base) plot device when `add = TRUE`
* `==` and `!=` now return `NA` when one of the operands is an empty geometry; #1013
* `st_intersects` is now a generic
* drop requiring `proj_api.h` in favor of `proj.h`, this enables compatibility to PROJ 6.0.0 and GDAL 2.5.0-dev; #988
* fix regression in binary predicates introduced in #855; #999 reported by Barry Rowlingson
* fix bug in `gdal_utils` util `warper` on certain GDAL/OS combinations; https://github.com/r-spatial/stars/issues/117
* `c.sfc` now ignores the type (class) of empty `sfc` objects when choosing the result type; #985, #982
* rename the default value for `distance` to `"Eucledian"`, rather than `"distance"` in `st_distance`
# version 0.7-3
* add argument `exact` to `st_sample`, for now defaulting to `FALSE`; #896
* fixed n-ary `st_difference` for cases where geometries are entirely contained in others; #975, by Jonathan Marshall
* faster `Ops.sfc`, added `st_normalize`; #973 by Thomas Lin Pedersen
* new grob constructor for sfc objects; #971 by Thomas Lin Pedersen (now contributor)
* add `group_split` and `group_map` methods for `sf` objects (experimental); #969
* make `st_interpolate_aw` a generic;
* argument `col` for `plot` of `GEOMETRY` `sfc`'s now is `NA` (open) for (multi) polygon geometries
# version 0.7-2
* feature IDs are no longer returned as names on the geometry list column, but optionally returned by `st_read` as attribute column; #812
* plot.sf adds a (single, common) key if `key.pos` is set
* when plotting multiple attributes, plot.sf now adds a (single, common) key if `key.pos` is set
* allow for setting precision in distance units; #901
* precision can now be specified in distance units; #901
* support log-scale in color legend by setting `logz` to `TRUE` in `plot.sf`
......
......@@ -141,6 +141,10 @@ CPL_gdalgrid <- function(src, dst, options) {
.Call('_sf_CPL_gdalgrid', PACKAGE = 'sf', src, dst, options)
}
CPL_gdal_warper <- function(infile, outfile, options) {
.Call('_sf_CPL_gdal_warper', PACKAGE = 'sf', infile, outfile, options)
}
CPL_write_ogr <- function(obj, dsn, layer, driver, dco, lco, geom, dim, fids, quiet = FALSE, update = FALSE, delete_dsn = FALSE, delete_layer = FALSE) {
.Call('_sf_CPL_write_ogr', PACKAGE = 'sf', obj, dsn, layer, driver, dco, lco, geom, dim, fids, quiet, update, delete_dsn, delete_layer)
}
......@@ -225,6 +229,14 @@ CPL_raw_to_hex <- function(raw) {
.Call('_sf_CPL_raw_to_hex', PACKAGE = 'sf', raw)
}
opp_sfc <- function(geom, value, mult, crs) {
.Call('_sf_opp_sfc', PACKAGE = 'sf', geom, value, mult, crs)
}
normalize_sfc <- function(geom, min, range, crs) {
.Call('_sf_normalize_sfc', PACKAGE = 'sf', geom, min, range, crs)
}
CPL_polygonize <- function(raster, mask_name, raster_driver, vector_driver, vector_dsn, options, iPixValField, contour_options, use_contours = FALSE, use_integer = TRUE) {
.Call('_sf_CPL_polygonize', PACKAGE = 'sf', raster, mask_name, raster_driver, vector_driver, vector_dsn, options, iPixValField, contour_options, use_contours, use_integer)
}
......@@ -233,6 +245,10 @@ CPL_rasterize <- function(raster, raster_driver, sfc, values, options, NA_value)
.Call('_sf_CPL_rasterize', PACKAGE = 'sf', raster, raster_driver, sfc, values, options, NA_value)
}
CPL_set_data_dir <- function(data_dir) {
.Call('_sf_CPL_set_data_dir', PACKAGE = 'sf', data_dir)
}
CPL_proj_version <- function(b = FALSE) {
.Call('_sf_CPL_proj_version', PACKAGE = 'sf', b)
}
......
......@@ -88,25 +88,29 @@ aggregate.sf = function(x, by, FUN, ..., do_union = TRUE, simplify = TRUE,
}
}
#' Areal-weighted interpolation of polygon data
#'
#' Areal-weighted interpolation of polygon data
#' @param x object of class \code{sf}, for which we want to aggregate attributes
#' @param to object of class \code{sf} or \code{sfc}, with the target geometries
#' @param extensive logical; if TRUE, the attribute variables are assumed to be spatially extensive (like population) and the sum is preserved, otherwise, spatially intensive (like population density) and the mean is preserved.
#' @param ... ignored
#' @examples
#' nc = st_read(system.file("shape/nc.shp", package="sf"))
#' g = st_make_grid(nc, n = c(20,10))
#' a1 = st_interpolate_aw(nc["BIR74"], g, extensive = FALSE)
#' sum(a1$BIR74) / sum(nc$BIR74) # not close to one: property is assumed spatially intensive
#' a2 = st_interpolate_aw(nc["BIR74"], g, extensive = TRUE)
#' # verify mass preservation (pycnophylactic) property:
#' sum(a2$BIR74) / sum(nc$BIR74)
#' a1$intensive = a1$BIR74
#' a1$extensive = a2$BIR74
#' plot(a1[c("intensive", "extensive")])
#' plot(a1[c("intensive", "extensive")], key.pos = 4)
#' @export
st_interpolate_aw = function(x, to, extensive, ...) UseMethod("st_interpolate_aw")
#' @export
st_interpolate_aw = function(x, to, extensive) {
st_interpolate_aw.sf = function(x, to, extensive, ...) {
if (!inherits(to, "sf") && !inherits(to, "sfc"))
stop("st_interpolate_aw requires geometries in argument to")
if (! all_constant(x))
......@@ -130,6 +134,5 @@ st_interpolate_aw = function(x, to, extensive) {
x = aggregate(x, list(idx[,2]), sum)
df = st_sf(x, geometry = st_geometry(to)[x$Group.1])
df$...area_t = df$...area_st = df$...area_s = NULL
st_agr(df) = "aggregate"
df
st_set_agr(df, "aggregate")
}
......@@ -54,7 +54,12 @@ Ops.sfg <- function(e1, e2) {
if (!(prd || pm || mod || set || lgcl))
stop(paste("operation", .Generic, "not supported for sfg objects"))
if (st_is_empty(e1))
e1_empty = st_is_empty(e1)
e2_empty = inherits(e2, "sfg") && st_is_empty(e2)
if (lgcl && (e1_empty || e2_empty))
return(NA)
if (e1_empty && (.Generic %in% c("*", "+", "-", "%%")))
return(e1)
if (inherits(e2, "sfg")) {
......@@ -122,13 +127,24 @@ Ops.sfc <- function(e1, e2) {
if (length(e1) == 0) # empty set
return(e1)
if (is.numeric(e2) && !is.matrix(e2) && length(e2) <= 2 && .Generic %in% c("+", "-")) {
if (.Generic == "-")
e2 <- -e2
return(opp_sfc(e1, as.numeric(e2), 0L, NA_crs_))
} else if (.Generic %in% c("*", "/") && is.numeric(e2) && (length(e2) == 1 || is_only_diag(e2))) {
if (is.matrix(e2)) e2 <- diag(e2)
if (.Generic == "/")
e2 <- 1 / e2
return(opp_sfc(e1, as.numeric(e2), 1L, NA_crs_))
}
if ((is.matrix(e2) && ncol(e2) == 2) || (is.numeric(e2) && length(e2) == 2))
e1 = st_zm(e1) # drop z and/or m
if (!is.list(e2) && ((.Generic %in% c("+", "-") && length(e2) == 2) || is.matrix(e2)))
e2 = list(e2)
ret = switch(.Generic,
ret = switch(
.Generic,
"&" = mapply(function(x, y) { x & y }, e1, e2, SIMPLIFY = FALSE),
"|" = mapply(function(x, y) { x | y }, e1, e2, SIMPLIFY = FALSE),
"%/%" = mapply(function(x, y) { x %/% y}, e1, e2, SIMPLIFY = FALSE),
......@@ -150,3 +166,6 @@ Ops.sfc <- function(e1, e2) {
} else
ret
}
is_only_diag <- function(x) {
is.matrix(x) && all(`diag<-`(x, 0) == 0) # nocov
}
......@@ -6,7 +6,7 @@ is.na.bbox = function(x) identical(x, NA_bbox_)
bb_wrap = function(bb) {
stopifnot(is.numeric(bb) && length(bb) == 4)
structure(bb, names = c("xmin", "ymin", "xmax", "ymax"), class = "bbox")
structure(as.double(bb), names = c("xmin", "ymin", "xmax", "ymax"), class = "bbox")
}
bbox.Set = function(obj, ...) {
......
......@@ -197,6 +197,7 @@ st_cast.sf = function(x, to, ..., warn = TRUE, do_split = TRUE) {
all_const = all_constant(x)
sf_column = attr(x, "sf_column") # keep name
st_geometry(x) = NULL
# class(x) = setdiff(class(x), "sf")
ids = attr(geom, "ids") # e.g. 3 2 4
if (!is.null(ids)) { # split:
if (warn && ! all_const)
......
......@@ -118,7 +118,15 @@ st_cast.MULTIPOINT <- function(x, to, ...) {
POLYGON = st_polygon(list(unclass(ClosePol(x)))),
LINESTRING = st_linestring(unclass(x)),
## loss, drop to first coordinate
POINT = {warning("point from first coordinate only"); st_point(unclass(x)[1L, , drop = TRUE])},
POINT = {
if (st_is_empty(x)) {
row <- NA_integer_
} else {
warning("point from first coordinate only")
row <- 1L
}
st_point(unclass(x)[row, , drop = TRUE])
},
GEOMETRYCOLLECTION = st_geometrycollection(list(x))
)
}
......
......@@ -100,6 +100,10 @@ st_crs.bbox = function(x, ...) {
attr(x, "crs")
}
#' @name st_crs
#' @export
st_crs.CRS = function(x, ...) st_crs(x@projargs)
#' @name st_crs
#' @export
st_crs.crs = function(x, ...) x
......@@ -140,6 +144,10 @@ valid_proj4string = function(p4s) {
# return crs object from crs, integer, or character string
make_crs = function(x, wkt = FALSE) {
if (inherits(x, "CRS"))
x = x@projargs
if (wkt)
CPL_crs_from_wkt(x)
else if (is.na(x))
......@@ -205,8 +213,18 @@ st_is_longlat = function(x) {
crs = st_crs(x)
if (is.na(crs))
NA
else
isTRUE(crs$proj == "longlat")
else {
ret = isTRUE(crs$proj == "longlat")
if (ret && inherits(x, c("sf", "sfc", "stars"))) {
bb = st_bbox(x)
# check for potentially meaningless value range:
eps = sqrt(.Machine$double.eps)
if (all(!is.na(unclass(bb))) &&
(bb["xmin"] < (-180-eps) || bb["xmax"] > (360+eps) || bb["ymin"] < (-90-eps) || bb["ymax"] > (90+eps)))
warning("bounding box has potentially an invalid value range for longlat data")
}
ret
}
}
# a = "b" => a is the proj.4 unit (try: cs2cs -lu); "b" is the udunits2 unit
......@@ -285,8 +303,8 @@ is.na.crs = function(x) {
#' @examples
#' st_crs("+init=epsg:3857")$epsg
#' st_crs("+init=epsg:3857")$proj4string
#' st_crs("+init=epsg:3857 +units=km")$b # numeric
#' st_crs("+init=epsg:3857 +units=km")$units # character
#' st_crs("+init=epsg:3857 +units=m")$b # numeric
#' st_crs("+init=epsg:3857 +units=m")$units # character
#' @export
`$.crs` = function(x, name) {
if (is.numeric(name) || name %in% names(x))
......
#' This is data included in sf
#' North Carolina SIDS data
#'
#' @name bgMap
#' @aliases g
#' Sudden Infant Death Syndrome (SIDS) sample data for North Carolina counties,
#' two time periods (1974-78 and 1979-84). The details of the columns can be
#' found on the seealso URL, spdep package's vignette. Please note that,
#' though this is basically the same as \code{nc.sids} dataset in spData
#' package, \code{nc} only contains a subset of variables. The differences are
#' also discussed on the vignette.
#'
#' @name nc
#' @docType data
#' @keywords data
#' @seealso \url{https://r-spatial.github.io/spdep/articles/sids.html}
NULL
......@@ -32,6 +32,7 @@ st_read.DBIObject = function(dsn = NULL,
EWKB = TRUE,
quiet = TRUE,
as_tibble = FALSE,
geometry_column = NULL,
...) {
if (is.null(dsn))
stop("no connection provided") # nocov
......@@ -101,10 +102,28 @@ st_read.DBIObject = function(dsn = NULL,
stop("Query `", query, "` returned no results.", call. = FALSE) #nocov
}
# check for simple features column
if (is.null(geometry_column)) {
# scan table for simple features column
geometry_column = is_geometry_column(dsn, tbl)
tbl[geometry_column] <- lapply(tbl[geometry_column], try_postgis_as_sfc, EWKB = EWKB, conn = dsn)
} else {
if (!all(geometry_column %in% names(tbl))) {
# prepare error message
nm <- names(tbl)
prefix <- ""
new_line <- ""
if(length(nm) > 1) {
prefix <- " *"
new_line <- "\n"
}
stop("Could not find `geometry_column` (\"", paste(geometry_column, collapse = "\", \""), "\") ",
"in column names. Available names are:",
new_line,
paste(prefix, nm, collapse = "\n", sep = " "),
call. = FALSE)
}
tbl[geometry_column] <- lapply(tbl[geometry_column], postgis_as_sfc, EWKB = EWKB, conn = dsn)
}
# if there are no simple features geometries, return a data frame
if (! any(vapply(tbl, inherits, logical(1), "sfc"))) {
......@@ -129,7 +148,7 @@ st_read.DBIObject = function(dsn = NULL,
if (!quiet) print(x, n = 0) # nocov
if (as_tibble) {
x <- tibble::as_tibble(x)
x <- tibble::new_tibble(x, nrow = nrow(x), class = "sf")
}
return(x)
}
......
# nocov start
resampling_method = function(option = "near") {
if (length(option) != 1)
stop("warper options should have length 1")
switch(option,
near = 0,
bilinear = 1,
cubic = 2,
cubicspline = 3,
lanczos = 4,
average = 5,
mode = 6,
max = 8,
min = 9,
med = 10,
q1 = 11,
q3 = 12,
stop(paste("unknown option:", options))
)
}
# nocov end
#' Native interface to gdal utils
#' @name gdal_utils
#' @param util character; one of \code{info}, \code{warp}, \code{rasterize}, \code{translate}, \code{vectortranslate}, \code{buildvrt}, \code{demprocessing}, \code{nearblack}, \code{grid}
......@@ -14,6 +37,7 @@ gdal_utils = function(util = "info", source, destination, options = character(0)
ret = switch(util,
info = CPL_gdalinfo(source, options),
warp = CPL_gdalwarp(source, destination, options),
warper = CPL_gdal_warper(source, destination, as.integer(resampling_method(options))), # nocov
rasterize = CPL_gdalrasterize(source, destination, options),
translate = CPL_gdaltranslate(source, destination, options),
vectortranslate = CPL_gdalvectortranslate(source, destination, options),
......@@ -21,7 +45,7 @@ gdal_utils = function(util = "info", source, destination, options = character(0)
demprocessing = CPL_gdaldemprocessing(source, destination, options, processing, colorfilename),
nearblack = CPL_gdalnearblack(source, destination, options),
grid = CPL_gdalgrid(source, destination, options),
stop(paste("unknown value for util:", util))
stop(paste("unknown util value for gdal_utils:", util))
)
if (util == "info") {
......@@ -31,7 +55,7 @@ gdal_utils = function(util = "info", source, destination, options = character(0)
} else {
# ret indicates error:
if (ret)
stop("gdal_utils: an error occured")
stop(paste0("gdal_utils ", util, ": an error occured"))
invisible(! ret) # success
}
}
This diff is collapsed.
......@@ -168,7 +168,8 @@ st_graticule = function(x = c(-180,-90,180,90), crs = st_crs(x),
if (! missing(x)) # cut out box:
df = suppressMessages(st_intersection(df, st_polygonize(box[1])))
graticule_attributes(st_cast(df, "MULTILINESTRING"))
df = st_cast(st_cast(df, "MULTILINESTRING"), "LINESTRING", warn = FALSE)
graticule_attributes(df)
}
graticule_attributes = function(df) {
......@@ -179,22 +180,18 @@ graticule_attributes = function(df) {
xy = matrix(NA, nrow = length(object), ncol = 4)
for (i in seq_along(object)) {
o = object[[i]]
if (length(o) == 1) {
pts = o[[1]]
pts = unclass(object[[i]])
xy[i, 1:2] = pts[1,] # start
xy[i, 3:4] = pts[nrow(pts),] # end
} else
xy[i, ] = st_bbox(o)
}
df$x_start = xy[,1]
df$y_start = xy[,2]
df$x_end = xy[,3]
df$y_end = xy[,4]
dxdy = do.call(rbind, lapply(object, function(x) { y = x[[1]]; apply(y[1:2,], 2, diff) } ))
dxdy = do.call(rbind, lapply(object, function(x) { apply(x[1:2,], 2, diff) } ))
df$angle_start = apply(dxdy, 1, function(x) atan2(x[2], x[1])*180/pi)
dxdy = do.call(rbind, lapply(object,
function(x) { y = x[[length(x)]]; n = nrow(y); apply(y[(n-1):n,], 2, diff) } ))
function(x) { n = nrow(x); apply(x[(n-1):n,], 2, diff) } ))
df$angle_end = apply(dxdy, 1, function(x) atan2(x[2], x[1])*180/pi)
bb = st_bbox(df)
selE = df$type == "E" & df$y_start < min(df$y_start) + 0.001 * (bb[3] - bb[1])
......@@ -223,7 +220,7 @@ trim_bb = function(bb = c(-180, -90, 180, 90), margin, wrap=c(-180,180)) {
degreeLabelsNS = function(x) {
pos = sign(x) + 2
dir = c("*S", "", "*N")
paste0(abs(x), "*degree", dir[pos])
paste0('"', abs(x), '"', "*degree", dir[pos])
}
degreeLabelsEW = function(x) {
......@@ -234,5 +231,5 @@ degreeLabelsEW = function(x) {
if (any(x == 180))
pos[x == 180] = 2
dir = c("*W", "", "*E")
paste0(abs(x), "*degree", dir[pos])
paste0('"', abs(x), '"', "*degree", dir[pos])
}
# grid graphics utilities
#' Convert sf* object to a grob
#'
#' Convert sf* object to an grid graphics object (grob)
#' @param x object to be converted into an object class \code{grob}
#' @param units units; see \link[grid]{unit}
#' @param ... passed on to the xxxGrob function, e.g. \code{gp = gpar(col = 'red')}
#' @export
st_as_grob = function(x, ..., units = "native") UseMethod("st_as_grob")
st_as_grob = function(x, ...) UseMethod("st_as_grob")
#' @export
st_as_grob.POINT = function(x, ..., default.units = "native") {
st_as_grob.POINT = function(x, pch = 1, size = unit(1, "char"), default.units = "native", name = NULL, gp = gpar(), vp = NULL, ...) {
if (any(is.na(x)))
nullGrob()
else
pointsGrob(x[1], x[2], ..., default.units = default.units)
pointsGrob(x[1], x[2], pch = pch, size = size, default.units = default.units, name = name, gp = gp, vp = vp)
}
#' @export
st_as_grob.MULTIPOINT = function(x, ..., default.units = "native") {
st_as_grob.MULTIPOINT = function(x, pch = 1, size = unit(1, "char"), default.units = "native", name = NULL, gp = gpar(), vp = NULL, ...) {
if (nrow(x) == 0)
nullGrob()
else
pointsGrob(x[,1], x[,2], ..., default.units = default.units)
pointsGrob(x[,1], x[,2], pch = pch, size = size, default.units = default.units, name = name, gp = gp, vp = vp)
}
#' @export
st_as_grob.LINESTRING = function(x, ..., default.units = "native") {
st_as_grob.LINESTRING = function(x, arrow = NULL, default.units = "native", name = NULL, gp = gpar(), vp = NULL, ...) {
if (nrow(x) == 0)
nullGrob()
else
linesGrob(x[,1], x[,2], ..., default.units = default.units)
linesGrob(x[,1], x[,2], arrow = NULL, default.units = default.units, name = name, gp = gp, vp = vp)
}
#' @export
......@@ -39,46 +36,46 @@ st_as_grob.CIRCULARSTRING = function(x, y, ...) {
}
#' @export
st_as_grob.MULTILINESTRING = function(x, ..., default.units = "native") {
st_as_grob.MULTILINESTRING = function(x, arrow = NULL, default.units = "native", name = NULL, gp = gpar(), vp = NULL, ...) {
if (length(x) == 0)
nullGrob()
else {
get_x = function(x) unlist(sapply(x, function(y) y[,1]))
get_y = function(x) unlist(sapply(x, function(y) y[,2]))
polylineGrob(get_x(x), get_y(x), id.lengths = vapply(x, nrow, 0L), ...,
default.units = default.units)
polylineGrob(get_x(x), get_y(x), id.lengths = vapply(x, nrow, 0L), arrow = NULL,
default.units = default.units, name = name, gp = gp, vp = vp)
}
}
#' @export
st_as_grob.POLYGON = function(x, ..., default.units = "native", rule = "evenodd") {
st_as_grob.POLYGON = function(x, default.units = "native", rule = "evenodd", name = NULL, gp = gpar(), vp = NULL, ...) {
if (length(x) == 0)
nullGrob()
else {
get_x = function(x) unlist(sapply(x, function(y) y[,1]))
get_y = function(x) unlist(sapply(x, function(y) y[,2]))
pathGrob(get_x(x), get_y(x), id.lengths = vapply(x, nrow, 0L), ..., default.units = default.units, rule = rule)
pathGrob(get_x(x), get_y(x), id.lengths = vapply(x, nrow, 0L), default.units = default.units, rule = rule, name = name, gp = gp, vp = vp)
}
}
#' @export
st_as_grob.MULTIPOLYGON = function(x, ..., default.units = "native", rule = "evenodd") {
st_as_grob.MULTIPOLYGON = function(x, default.units = "native", rule = "evenodd", name = NULL, gp = gpar(),