1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
|
#' Given an object with geometries of type \code{GEOMETRY} or \code{GEOMETRYCOLLECTION},
#' return an object consisting only of elements of the specified type.
#'
#' Similar to ST_CollectionExtract in PostGIS. If there are no sub-geometries
#' of the specified type, an empty geometry is returned.
#'
#' @param x an object of class \code{sf}, \code{sfc} or \code{sfg} that has
#' mixed geometry (\code{GEOMETRY} or \code{GEOMETRYCOLLECTION}).
#' @param type character; one of "POLYGON", "POINT", "LINESTRING"
#' @param warn logical; if \code{TRUE}, warn if attributes are assigned to
#' sub-geometries when casting (see \code{\link{st_cast}})
#'
#' @return An object having the same class as \code{x}, with geometries
#' consisting only of elements of the specified type.
#' For \code{sfg} objects, an \code{sfg} object is returned if there is only
#' one geometry of the specified type, otherwise the geometries are combined
#' into an \code{sfc} object of the relevant type. If any subgeometries in the
#' input are MULTI, then all of the subgeometries in the output will be MULTI.
#'
#' @export
#'
#' @examples
#' pt <- st_point(c(1, 0))
#' ls <- st_linestring(matrix(c(4, 3, 0, 0), ncol = 2))
#' poly1 <- st_polygon(list(matrix(c(5.5, 7, 7, 6, 5.5, 0, 0, -0.5, -0.5, 0), ncol = 2)))
#' poly2 <- st_polygon(list(matrix(c(6.6, 8, 8, 7, 6.6, 1, 1, 1.5, 1.5, 1), ncol = 2)))
#' multipoly <- st_multipolygon(list(poly1, poly2))
#'
#' i <- st_geometrycollection(list(pt, ls, poly1, poly2))
#' j <- st_geometrycollection(list(pt, ls, poly1, poly2, multipoly))
#'
#' st_collection_extract(i, "POLYGON")
#' st_collection_extract(i, "POINT")
#' st_collection_extract(i, "LINESTRING")
#'
#' ## A GEOMETRYCOLLECTION
#' aa <- rbind(st_sf(a=1, geom = st_sfc(i)),
#' st_sf(a=2, geom = st_sfc(j)))
#'
#' ## With sf objects
#' st_collection_extract(aa, "POLYGON")
#' st_collection_extract(aa, "LINESTRING")
#' st_collection_extract(aa, "POINT")
#'
#' ## With sfc objects
#' st_collection_extract(st_geometry(aa), "POLYGON")
#' st_collection_extract(st_geometry(aa), "LINESTRING")
#' st_collection_extract(st_geometry(aa), "POINT")
#'
#' ## A GEOMETRY of single types
#' bb <- rbind(
#' st_sf(a = 1, geom = st_sfc(pt)),
#' st_sf(a = 2, geom = st_sfc(ls)),
#' st_sf(a = 3, geom = st_sfc(poly1)),
#' st_sf(a = 4, geom = st_sfc(multipoly))
#' )
#'
#' st_collection_extract(bb, "POLYGON")
#'
#' ## A GEOMETRY of mixed single types and GEOMETRYCOLLECTIONS
#' cc <- rbind(aa, bb)
#'
#' st_collection_extract(cc, "POLYGON")
#'
st_collection_extract = function(x, type = c("POLYGON", "POINT", "LINESTRING"), warn = FALSE) {
UseMethod("st_collection_extract")
}
#' @name st_collection_extract
#'
#' @export
st_collection_extract.sfg = function(x, type = c("POLYGON", "POINT", "LINESTRING"), warn = FALSE) {
type = match.arg(type)
types = c(type, paste0("MULTI", type))
if (inherits(x, types)) {
warning("x is already of type ", type, ".")
return(x)
}
if (!inherits(x, "GEOMETRYCOLLECTION")) {
stop("x is of singular geometry type that is different to supplied type: ", type) # nocov
}
# Find the geometries of the specified type and extract into a list
matches = vapply(x, st_is, types, FUN.VALUE = logical(1))
x_types = x[which(matches)]
if (length(x_types) == 0L) {
## return an empty sfg of the specified type
warning("x contains no geometries of specified type")
return(typed_empty(paste0("sfc_", type)))
} else if (length(x_types) == 1L) {
# Get the contents of the first (only) list element which is an sfg
return(x_types[[1]])
} else {
# turn list into an sfc, and cast it to single type. Will be multi
# if any are multi
return(st_cast(st_sfc(x_types), warn = warn))
}
}
#' @name st_collection_extract
#'
#' @export
st_collection_extract.sfc = function(x, type = c("POLYGON", "POINT", "LINESTRING"), warn = FALSE) {
type = match.arg(type)
types = c(type, paste0("MULTI", type))
if (length(x) == 0)
return(x)
# Check it's not already what user is asking for
if (inherits(st_geometry(x), paste0("sfc_", types))) {
warning("x is already of type ", type, ".") # nocov
return(x) # nocov
}
if (!inherits(st_geometry(x), c("sfc_GEOMETRY", "sfc_GEOMETRYCOLLECTION"))) {
stop("x is of singular geometry type that is different to supplied type: ", type)
}
# Cast to GEOMETRYCOLLECTION if is GEOMETRY)
if (inherits(st_geometry(x), "sfc_GEOMETRY")) {
x = st_cast(x, "GEOMETRYCOLLECTION")
}
## Cast GEOMETRYCOLLECTION into all components
gc_casted = st_cast(x, warn = warn)
## Keep only components that match input type
if (inherits(gc_casted, "sf")) {
gc_types = gc_casted[st_is(gc_casted, types), ]
} else {
gc_types = gc_casted[st_is(gc_casted, types)]
}
## Cast to specified (MULTI) type
if (length(st_geometry(gc_types)) == 0L) {
warning("x contains no geometries of specified type")
return(gc_types)
}
st_cast(gc_types, warn = warn)
}
#' @name st_collection_extract
#'
#' @export
st_collection_extract.sf = st_collection_extract.sfc
|
