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