1SpatialPolygons <- function(Srl, pO, proj4string=CRS(as.character(NA))) { 2# bb <- .bboxCalcR(Srl) 3# if (missing(pO)) { 4# area <- sapply(Srl, function(x) x@area) 5# pO <- as.integer(order(area, decreasing=TRUE)) 6# } 7# Sp <- new("Spatial", bbox=bb, proj4string=proj4string) 8# res <- new("SpatialPolygons", Sp, polygons=Srl, plotOrder=as.integer(pO)) 9# RSB 091204 10 if (missing(pO)) 11 pO <- NULL 12 else { 13 stopifnot(is.integer(pO)) 14 stopifnot(length(pO) == length(Srl)) 15 } 16 stopifnot(is.list(Srl)) 17# tess to Polygons bug 121028 18 # EJP, 2/3/2015, uncomments: 19 # stopifnot(length(Srl) > 0) 20 stopifnot(is(proj4string, "CRS")) 21 res <- .Call(SpatialPolygons_c, Srl, pO, proj4string) 22 validObject(res) 23# 120416 add top-level comment to reduce comment checking 24 cSr <- as.character(all(sapply(slot(res, "polygons"), 25# 180201 change any to all after NULL comment found; https://github.com/r-spatial/sf/issues/636 26 function(x) !is.null(comment(x))), na.rm=TRUE)) 27 comment(res) <- cSr 28 res 29} 30 31Polygon <- function(coords, hole=as.logical(NA)) { 32 33 coords <- coordinates(coords) 34## if (!is.matrix(coords)) stop("coords must be a two-column matrix") 35 if (ncol(coords) != 2) stop("coords must be a two-column matrix") 36# RSB 091203 37 n <- dim(coords)[1] 38 if (n < 4L) { 39 warning("less than 4 coordinates in polygon") 40 if (n == 1L) coords <- rbind(coords, coords, coords, coords) 41 else if (n == 2L) coords <- rbind(coords, coords[1,], coords[1,]) 42 else if (n == 3L) coords <- rbind(coords, coords[1,]) 43 n <- dim(coords)[1] 44 } 45 stopifnot(is.logical(hole)) 46 ihole <- as.integer(hole) 47# RSB 100126 fixing hole assumption 48# thanks to Javier Munoz for report 49 res <- .Call(Polygon_c, coords, n, ihole) 50# validObject(res) 51 res 52} 53 54Polygons <- function(srl, ID) { 55# tess to Polygons bug 121028 56 stopifnot(is.list(srl)) 57 stopifnot(length(srl) > 0) 58 if (any(sapply(srl, function(x) !is(x, "Polygon")))) 59 stop("srl not a list of Polygon objects") 60## projargs <- unique(sapply(srl, proj4string)) 61## if (length(projargs) > 1) 62## stop("differing projections among Polygon objects") 63 if (missing(ID)) stop("Single ID required") 64 if (length(ID) != 1) stop("Single ID required") 65 ID <- as.character(ID) 66 stopifnot(nzchar(ID)) 67# RSB 091203 68 res <- .Call(Polygons_c, srl, ID) 69# validObject(res) 70 res 71} 72 73bbox.Polygons <- function(obj) { 74 rx=range(c(sapply(obj@Polygons, function(x) range(x@coords[,1])))) 75 ry=range(c(sapply(obj@Polygons, function(x) range(x@coords[,2])))) 76 res=rbind(x=rx,y=ry) 77 colnames(res) <- c("min", "max") 78 res 79} 80 81setMethod("bbox", "Polygons", bbox.Polygons) 82 83bbox.Polygon <- function(obj) { 84 rx <- range(obj@coords[,1]) 85 ry <- range(obj@coords[,2]) 86 res=rbind(x=rx,y=ry) 87 colnames(res) <- c("min", "max") 88 res 89} 90 91setMethod("bbox", "Polygon", bbox.Polygon) 92 93as.SpatialPolygons.PolygonsList <- function(Srl, proj4string=CRS(as.character(NA))) { 94 if (any(sapply(Srl, function(x) !is(x, "Polygons")))) 95 stop("srl not a list of Polygons objects") 96# projargs <- unique(sapply(Srl, proj4string)) 97# if (length(projargs) > 1) 98# stop("differing projections among Polygons objects") 99 100# n <- length(Srl) 101 102 res <- SpatialPolygons(Srl, proj4string=proj4string) 103 res 104} 105 106row.names.SpatialPolygons <- function(x) { 107 .Call(SpatialPolygons_getIDs_c, x) 108} 109 110"row.names<-.SpatialPolygons" <- function(x, value) { 111 spChFIDs(x, value) 112} 113 114setMethod("[", "SpatialPolygons", function(x, i, j, ..., drop = TRUE) { 115 if (is(i, "Spatial")) 116 i = !is.na(over(x, geometry(i))) 117 if (is.logical(i)) { 118 if (length(i) == 1 && i) 119 i = 1:length(x@polygons) 120 else 121 i <- which(i) 122 } else if (is.character(i)) 123 i <- match(i, row.names(x)) 124 if (any(is.na(i))) 125 stop("NAs not permitted in row index") 126 if (length(unique(i)) != length(i)) 127 stop("SpatialPolygons selection: can't find plot order if polygons are replicated") 128 if (length(x@polygons[i]) == 0) { 129 x@polygons = x@polygons[i] 130 x@plotOrder = integer(0) 131 stopifnot(validObject(x)) 132 x 133 } else { 134 y = SpatialPolygons(x@polygons[i], proj4string=rebuild_CRS(slot(x, "proj4string"))) 135 if (!is.null(comment(x))) comment(y) <- comment(x) 136 y 137 } 138# x@polygons = x@polygons[i] 139# x@bbox <- .bboxCalcR(x@polygons) 140# area <- sapply(slot(x, "polygons"), function(i) slot(i, "area")) 141# x@plotOrder <- as.integer(order(area, decreasing=TRUE)) 142# x 143}) 144 145setMethod("coordnames", signature(x = "SpatialPolygons"), 146 function(x) coordnames(x@polygons[[1]]) 147) 148setMethod("coordnames", signature(x = "Polygons"), 149 function(x) coordnames(x@Polygons[[1]]) 150) 151setMethod("coordnames", signature(x = "Polygon"), 152 function(x) dimnames(x@coords)[[2]] 153) 154setReplaceMethod("coordnames", 155 signature(x = "SpatialPolygons", value = "character"), 156 function(x, value) { 157 dimnames(x@bbox)[[1]] = value 158 #for (i in seq(along = x@polygons)) 159 # coordnames(x@polygons[[i]]) = value 160 x@polygons = lapply(x@polygons, 161 function(y) Polygons(lapply(y@Polygons, 162 function(z) { dimnames(z@coords)[[2]] = value; z }), y@ID)) 163 x 164 } 165) 166setMethod("coordinates", "SpatialPolygons", 167 function(obj) { 168 ret = t(sapply(slot(obj, "polygons"), function(i) slot(i, "labpt"))) 169 dimnames(ret) = list(sapply(slot(obj, "polygons"), function(i) slot(i, "ID")), NULL) 170 ret 171 } 172) 173 174getSpatialPolygonsLabelPoints = function(SP) { 175 .Deprecated("slot", package = "sp", 176 msg="use *apply and slot directly, or coordinates method") 177 ret = t(sapply(slot(SP, "polygons"), function(x) slot(x, "labpt"))) 178 SpatialPoints(ret, rebuild_CRS(slot(SP, "proj4string"))) 179} 180 181as.Lines.Polygons = function(from) { 182 lst = lapply(from@Polygons, function(x) as(x, "Line")) 183 Lines(lst, from@ID) 184} 185setAs("Polygons", "Lines", as.Lines.Polygons) 186 187as.SpatialLines.SpatialPolygons = function(from) 188 SpatialLines(lapply(from@polygons, function(x) as(x, "Lines")), 189 rebuild_CRS(slot(from, "proj4string"))) 190 191setAs("SpatialPolygons", "SpatialLines", as.SpatialLines.SpatialPolygons) 192 193as.SpatialPolygonsDataFrame.SpatialPolygons = function(from) { 194 IDs <- sapply(slot(from, "polygons"), function(x) slot(x, "ID")) 195 df <- data.frame(dummy = rep(0, length(IDs)), row.names=IDs) 196 SpatialPolygonsDataFrame(from, df) 197} 198 199setAs("SpatialPolygons", "SpatialPolygonsDataFrame", 200 as.SpatialPolygonsDataFrame.SpatialPolygons) 201 202length.SpatialPolygons = function(x) { length(x@polygons) } 203 204names.SpatialPolygons = function(x) { 205 unlist(lapply(x@polygons, function(X) X@ID)) 206} 207