## utility functions, patterns that are either used elsewhere or can be
## replaced by other changes
##
## worker functions from the internals of c.sfg
## to unclass the underlying coordinates
Paste0 <- function(lst) lapply(lst, unclass)
##
## drop the tail coordinate of a polygon ring
Tail1 <- function(lst) lapply(lst, head, -1)
ClosePol <- function(mtrx) {
stopifnot(is.matrix(mtrx))
if (!all(mtrx[1,] == mtrx[nrow(mtrx),]))
mtrx = rbind(mtrx, mtrx[1,])
if (nrow(mtrx) < 4)
stop("polygons require at least 4 points")
mtrx
}
## multi-polygon and polygon constructor, allow unclosed (but don't apply auto-closing)
## note use of local constructor below, not the sf-API one
#st_multipolygon_close <- function(x = list(), dim = "XYZ") {
# MtrxSetSet(x, dim, type = "MULTIPOLYGON", needClosed = FALSE)
#}
#st_polygon_close <- function(x = list(), dim = "XYZ") {
# MtrxSet(x, dim, type = "POLYGON", needClosed = FALSE)
#}
# TODO
# FIXME: warn on multi-part loss only if there are multiple parts
# disallow auto-polygon-closure for two-point inputs: st_cast(st_linestring(cbind(0, 1:2)), "POLYGON")
# -> that should give an error
# check discussions, holes become lines, those lines become overlapping islands, or does polygonize auto-detect nesting
## and assign holes to islands as sp-comments did?
# test on holes
# warnings on these individual tests as here, or on detection of loss higher up?
# geometrycollection conversions?
# check comments and warnings are consistent in each case below
#' @name st_cast
#' @export
#' @examples
#' # example(st_read)
#' nc = st_read(system.file("shape/nc.shp", package="sf"))
#' mpl <- st_geometry(nc)[[4]]
#' #st_cast(x) ## error 'argument "to" is missing, with no default'
#' cast_all <- function(xg) {
#' lapply(c("MULTIPOLYGON", "MULTILINESTRING", "MULTIPOINT", "POLYGON", "LINESTRING", "POINT"),
#' function(x) st_cast(xg, x))
#' }
#' st_sfc(cast_all(mpl))
#' ## no closing coordinates should remain for multipoint
#' any(duplicated(unclass(st_cast(mpl, "MULTIPOINT")))) ## should be FALSE
#' ## number of duplicated coordinates in the linestrings should equal the number of polygon rings
#' ## (... in this case, won't always be true)
#' sum(duplicated(do.call(rbind, unclass(st_cast(mpl, "MULTILINESTRING"))))
#' ) == sum(unlist(lapply(mpl, length))) ## should be TRUE
#'
#' p1 <- structure(c(0, 1, 3, 2, 1, 0, 0, 0, 2, 4, 4, 0), .Dim = c(6L, 2L))
#' p2 <- structure(c(1, 1, 2, 1, 1, 2, 2, 1), .Dim = c(4L, 2L))
#' st_polygon(list(p1, p2))
st_cast.MULTIPOLYGON <- function(x, to, ...) {
switch(to,
MULTIPOLYGON = x,
MULTILINESTRING = st_multilinestring( unlist(Paste0(x), recursive = FALSE, use.names = FALSE)),
MULTIPOINT = st_multipoint(do.call(rbind, Tail1(unlist(Paste0(x), recursive = FALSE, use.names = FALSE)))),
## loss, drop to first part
POLYGON = {
if (length(x) > 1)
warning("polygon from first part only")
st_polygon(x[[1L]])
},
LINESTRING = {warning("line from first ring only"); st_linestring(x[[1L]][[1L]])},
## loss, drop to first coordinate of first ring of first part
POINT = {warning("point from first coordinate only"); st_point(x[[1L]][[1L]][1L, , drop = TRUE])},
GEOMETRYCOLLECTION = st_geometrycollection(list(x))
)
}
#' @name st_cast
#' @export
#' @examples
#' mls <- st_cast(st_geometry(nc)[[4]], "MULTILINESTRING")
#' st_sfc(cast_all(mls))
st_cast.MULTILINESTRING <- function(x, to, ...) {
switch(to,
MULTIPOLYGON = st_multipolygon(list(lapply(x, ClosePol))),
MULTILINESTRING = x,
MULTIPOINT = st_multipoint(do.call(rbind, Paste0(x))),
## loss, drop to first line
#POLYGON = {warning("keeping first linestring only"); st_polygon(x[1L])},
POLYGON = st_polygon(lapply(x, ClosePol)),
LINESTRING = {
if (length(x) > 1)
warning("keeping first linestring only")
st_linestring(x[[1L]])
},
## loss, drop to first coordinate of first line
POINT = {
warning("keeping first coordinate only")
st_point(x[[1L]][1L, , drop = TRUE])
},
GEOMETRYCOLLECTION = st_geometrycollection(list(x))
)
}
#' @name st_cast
#' @export
#' @examples
#' mpt <- st_cast(st_geometry(nc)[[4]], "MULTIPOINT")
#' st_sfc(cast_all(mpt))
st_cast.MULTIPOINT <- function(x, to, ...) {
switch(to,
## DANGER: polygon, linestring forms unlikely to be valid
MULTIPOLYGON = st_multipolygon(list(list(ClosePol(unclass(x))))),
MULTILINESTRING = st_multilinestring(list(unclass(x))),
MULTIPOINT = x,
POLYGON = st_polygon(list(unclass(ClosePol(x)))),
LINESTRING = st_linestring(unclass(x)),
## loss, drop to first coordinate
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))
)
}
#' @name st_cast
#' @export
#' @examples
#' pl <- st_cast(st_geometry(nc)[[4]], "POLYGON")
#' st_sfc(cast_all(pl))
st_cast.POLYGON <- function(x, to, ...) {
switch(to,
MULTIPOLYGON = {
if (length(x))
x = list(lapply(Paste0(x), ClosePol))
st_multipolygon(x)
},
MULTILINESTRING = st_multilinestring(unclass(x)),
MULTIPOINT = st_multipoint(Tail1(unclass(x))[[1L]]),
POLYGON = x,
LINESTRING = st_linestring(unclass(x)[[1L]]),
POINT = {warning("point from first coordinate only"); st_point(unclass(x)[[1L]][1L, , drop = TRUE])},
GEOMETRYCOLLECTION = st_geometrycollection(list(x))
)
}
#' @name st_cast
#' @export
#' @examples
#' ls <- st_cast(st_geometry(nc)[[4]], "LINESTRING")
#' st_sfc(cast_all(ls))
st_cast.LINESTRING <- function(x, to, ...) {
switch(to,
MULTIPOLYGON = st_multipolygon(list(list(ClosePol(unclass(x))))),
MULTILINESTRING = st_multilinestring(list(unclass(x))),
MULTIPOINT = st_multipoint(unclass(x)),
POLYGON = st_polygon(list(unclass(ClosePol(x)))),
LINESTRING = x,
POINT = {warning("point from first coordinate only"); st_point(unclass(x)[1L, , drop = TRUE])},
GEOMETRYCOLLECTION = st_geometrycollection(list(x))
)
}
#' @name st_cast
#' @export
#' @examples
#' pt <- st_cast(st_geometry(nc)[[4]], "POINT")
#' ## st_sfc(cast_all(pt)) ## Error: cannot create MULTIPOLYGON from POINT
#' st_sfc(lapply(c("POINT", "MULTIPOINT"), function(x) st_cast(pt, x)))
st_cast.POINT <- function(x, to, ...) {
switch(to,
MULTIPOLYGON = stop("cannot create MULTIPOLYGON from POINT"),
MULTILINESTRING = stop("cannot create MULTILINESTRING from POINT"),
MULTIPOINT = st_multipoint(matrix(unclass(x), nrow = 1L)),
POLYGON = stop("cannot create POLYGON from POINT"),
LINESTRING = stop("cannot create LINESTRING from POINT"),
POINT = x,
GEOMETRYCOLLECTION = st_geometrycollection(list(x))
)
}
#' @name st_cast
#' @export
st_cast.GEOMETRYCOLLECTION <- function(x, to, ...) {
switch(to,
GEOMETRYCOLLECTION = x,
{
if (length(x) > 1)
warning("only first part of geometrycollection is retained")
st_cast(x[[1]], to, ...)
}
)
}
#' @name st_cast
#' @export
st_cast.CIRCULARSTRING <- function(x, to, ...) {
if (to != "LINESTRING")
stop("CIRCULARSTRING can only be converted into LINESTRING")
CPL_circularstring_to_linestring(structure(list(x), crs = NA_crs_, precision = 0.0,
class = c("sfc_CIRCULARSTRING", "sfc")))[[1]]
}
#' @name st_cast
#' @export
st_cast.MULTISURFACE <- function(x, to, ...) {
if (! missing(to) && to != "MULTIPOLYGON")
stop("MULTISURFACE can only be converted into MULTIPOLYGON")
CPL_multisurface_to_multipolygon(structure(list(x), crs = NA_crs_, precision = 0.0,
class = c("sfc_MULTISURFACE", "sfc")))[[1]]
}
#' @name st_cast
#' @export
st_cast.COMPOUNDCURVE <- function(x, to, ...) {
if (! missing(to) && to != "LINESTRING")
stop("to should be missing or LINESTRING")
CPL_compoundcurve_to_linear(structure(list(x), crs = NA_crs_, precision = 0.0,
class = c("sfc_COMPOUNDCURVE", "sfc")))[[1]]
}
#' @name st_cast
#' @export
st_cast.MULTICURVE <- function(x, to, ...) {
if (! missing(to) && to != "MULTILINESTRING")
stop("to should be missing or MULTILINESTRING")
st_multilinestring(lapply(x, st_cast, to = "LINESTRING"))
}
#' @name st_cast
#' @export
st_cast.CURVE <- function(x, to, ...) { # nocov start
if (! missing(to) && to != "LINESTRING")
stop("CURVE can only be converted into LINESTRING")
CPL_curve_to_linestring(structure(list(x), crs = NA_crs_, precision = 0.0,
class = c("sfc_CURVE", "sfc")))[[1]]
} # nocov end
# st_cast.class <- function(x, to) {
# switch(to,
# MULTIPOLYGON = x,
# MULTILINESTRING = x,
# MULTIPOINT = x,
# POLYGON = x,
# LINESTRING = x,
# POINT = x
# )
# }
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.