1readShapePoly <- function(fn, IDvar=NULL, proj4string=CRS(as.character(NA)), 2 verbose=FALSE, repair=FALSE, force_ring=FALSE, delete_null_obj=FALSE, 3 retrieve_ABS_null=FALSE) { 4 .Deprecated("", package="maptools", msg="readShapePoly is deprecated; use rgdal::readOGR or sf::st_read") 5 suppressWarnings(Map <- read.shape(filen=fn, 6 verbose=verbose, repair=repair)) 7 if (!is.null(IDvar)) { 8 IDvar <- as.character(IDvar) 9 if (!IDvar %in% names(Map$att.data)) 10 stop(paste("column not found:", IDvar)) 11 IDvar <- as.character(Map$att.data[[IDvar]]) 12 } 13 .Map2PolyDF(Map, IDs=IDvar, proj4string=proj4string, 14 force_ring=force_ring, delete_null_obj=delete_null_obj, 15 retrieve_ABS_null=retrieve_ABS_null) 16} 17 18writePolyShape <- function(x, fn, factor2char = TRUE, max_nchar=254) { 19 .Deprecated("", package="maptools", msg="writePolyShape is deprecated; use rgdal::writeOGR or sf::st_write") 20 stopifnot(is(x, "SpatialPolygonsDataFrame")) 21 df <- as(x, "data.frame") 22 df <- data.frame(SP_ID=I(row.names(df)), df) 23 pls <- .SpP2polylist(as(x, "SpatialPolygons")) 24 suppressWarnings(write.polylistShape(pls, df, file=fn, 25 factor2char = factor2char, max_nchar=max_nchar)) 26} 27 28.Map2PolyDF <- function(Map, IDs, proj4string=CRS(as.character(NA)), 29 force_ring=FALSE, delete_null_obj=FALSE, retrieve_ABS_null=FALSE) { 30# ABS null part shapefiles Graham Williams 080403 31# birds NULL part Allen H. Hurlbert 090610 32 nullParts <- sapply(Map$Shapes, function(x) x$nParts) == 0 33 if (delete_null_obj) { 34 nullParts <- which(nullParts) 35 if (length(nullParts) > 0L) { 36 if (!retrieve_ABS_null) { 37 for (i in length(nullParts):1) 38 Map$Shapes[[nullParts[i]]] <- NULL 39 attr(Map$Shapes,'nshps') <- attr(Map$Shapes,'nshps') - 40 length(nullParts) 41 Map$att.data <- Map$att.data[-nullParts,] 42 warning(paste("Null objects with the following", 43 "indices deleted:", paste(nullParts, collapse=", "))) 44 } else { 45 res <- Map$att.data[nullParts,] 46 return(res) 47 } 48 } 49 } else { 50# birds NULL part Allen H. Hurlbert 090610 51 if (any(nullParts)) 52 stop(paste("NULL geometry found:", paste(which(nullParts), collapse=", "), "\n consider using delete_null_obj=TRUE")) 53 } 54 if (is.null(IDs)) 55 IDs <- as.character(sapply(Map$Shapes, function(x) x$shpID)) 56 SR <- .asSpatialPolygonsShapes(Map$Shapes, IDs, 57 proj4string=proj4string, force_ring=force_ring) 58 df <- Map$att.data 59 rownames(df) <- IDs 60 res <- SpatialPolygonsDataFrame(Sr=SR, data=df) 61 res 62} 63 64.asSpatialPolygonsShapes <- function(shapes, IDs, 65 proj4string=CRS(as.character(NA)), force_ring=FALSE) { 66 if (attr(shapes, "shp.type") != "poly") 67 stop("Not polygon shapes") 68 if (missing(IDs)) 69 IDs <- as.character(sapply(shapes, function(x) x$shpID)) 70 if (length(IDs) != attr(shapes,'nshps')) 71 stop("Number of shapes and IDs differ") 72 tab <- table(factor(IDs)) 73 n <- length(tab) 74 IDss <- .mixedsort(names(tab)) 75# try to preserve sensible ordering 76# IDss <- names(tab) 77 reg <- match(IDs, IDss) 78 belongs <- lapply(1:n, function(x) which(x == reg)) 79# assemble the list of Srings 80 Srl <- vector(mode="list", length=n) 81 for (i in 1:n) { 82 nParts <- length(belongs[[i]]) 83 srl <- NULL 84 for (j in 1:nParts) { 85 jres <- .shp2srsI(shapes[[belongs[[i]][j]]], 86 .nParts.shpI(shapes[[belongs[[i]][j]]]), 87 force_ring=force_ring) 88 srl <- c(srl, jres) 89 } 90 Srl[[i]] <- Polygons(srl, ID=IDss[i]) 91 } 92 res <- as.SpatialPolygons.PolygonsList(Srl, proj4string=proj4string) 93 res 94} 95# Function mixedorder copied from gtools 2.2.3 LGPL Gregory R. Warnes 96.mixedsort <- function (x) { 97 x[.mixedorder(x)] 98} 99 100.mixedorder <- function (x) { 101 delim = "\\$\\@\\$" 102 numeric <- function(x) { 103 optwarn = options("warn") 104 on.exit(options(optwarn)) 105 options(warn = -1) 106 as.numeric(x) 107 } 108 nonnumeric <- function(x) { 109 optwarn = options("warn") 110 on.exit(options(optwarn)) 111 options(warn = -1) 112 ifelse(is.na(as.numeric(x)), toupper(x), NA) 113 } 114 x <- as.character(x) 115 which.nas <- which(is.na(x)) 116 which.blanks <- which(x == "") 117 if (length(which.blanks) > 0L) 118 x[which.blanks] <- -Inf 119 if (length(which.nas) > 0L) 120 x[which.nas] <- Inf 121 delimited <- gsub("([+-]{0,1}[0-9.]+([eE][+-]{0,1}[0-9.]+){0,1})", 122 paste(delim, "\\1", delim, sep = ""), x) 123 step1 <- strsplit(delimited, delim) 124 step1 <- lapply(step1, function(x) x[x > ""]) 125 step1.numeric <- lapply(step1, numeric) 126 step1.character <- lapply(step1, nonnumeric) 127 maxelem <- max(sapply(step1, length)) 128 step1.numeric.t <- lapply(1:maxelem, function(i) sapply(step1.numeric, 129 function(x) x[i])) 130 step1.character.t <- lapply(1:maxelem, function(i) sapply(step1.character, 131 function(x) x[i])) 132 rank.numeric <- sapply(step1.numeric.t, rank) 133 rank.character <- sapply(step1.character.t, 134 function(x) as.numeric(factor(x))) 135 rank.numeric[!is.na(rank.character)] <- 0 136 rank.character <- t(t(rank.character) + apply(matrix(rank.numeric), 137 2, max, na.rm = TRUE)) 138 rank.overall <- ifelse(is.na(rank.character), rank.numeric, 139 rank.character) 140 order.frame <- as.data.frame(rank.overall) 141 if (length(which.nas) > 0L) 142 order.frame[which.nas, ] <- Inf 143 retval <- do.call("order", order.frame) 144 return(retval) 145} 146 147.shp2srsI <- function(shp, nParts, force_ring=FALSE) { 148 Pstart <- shp$Pstart 149 nVerts <- nrow(shp$verts) 150 from <- integer(nParts) 151 to <- integer(nParts) 152 from[1] <- 1 153 for (j in 1:nParts) { 154 if (j == nParts) to[j] <- nVerts 155 else { 156 to[j] <- Pstart[j+1] 157 from[j+1] <- to[j]+1 158 } 159 } 160 srl <- vector(mode="list", length=nParts) 161 for (j in 1:nParts) { 162 crds <- shp$verts[from[j]:to[j],,drop=FALSE] 163 if (force_ring) { 164 if (!isTRUE(identical(crds[1,], crds[nrow(crds),]))) 165 crds <- rbind(crds, crds[1,]) 166 } 167 srl[[j]] <- Polygon(coords=crds) 168 } 169 srl 170} 171 172.nParts.shpI <- function(shp) attr(shp, "nParts") 173 174.xyList2NAmat <- function(xyList) { 175 nParts <- length(xyList) 176 res <- xyList[[1]] 177 if (nParts > 1) { 178 for(i in 2:nParts) 179 res <- rbind(res, c(NA,NA), xyList[[i]]) 180 } 181 res 182} 183 184.SpP2polylist <- function(x) { 185 pls <- slot(x, "polygons") 186 n <- length(pls) 187 res <- vector(mode="list", length=n) 188 for (i in 1:n) { 189 xyL <- lapply(slot(pls[[i]], "Polygons"), 190 function(i) slot(i, "coords")) 191 nP <- length(xyL) 192 nVs <- sapply(xyL, nrow) 193 res[[i]] <- .xyList2NAmat(xyL) 194 attr(res[[i]], "nParts") <- as.integer(nP) 195 from <- integer(nP) 196 to <- integer(nP) 197 from[1] <- 1 198 to[1] <- nVs[1] 199 if (nP > 1) for (j in 2:nP) { 200 from[j] <- to[(j-1)] + 2 201 to[j] <- from[j] + nVs[j] - 1 202 } 203 attr(res[[i]], "pstart") <- list(from=as.integer(from), 204 to=as.integer(to)) 205 attr(res[[i]], "bbox") <- c(bbox(pls[[i]])) 206 } 207 attr(res, "region.id") <- sapply(pls, function(i) slot(i, "ID")) 208 class(res) <- "polylist" 209 invisible(res) 210} 211 212.polylist2SpP <- function(pl, tol=.Machine$double.eps^(1/4)) { 213 if (!inherits(pl, "polylist")) stop("not a polylist object") 214 n <- length(pl) 215 IDs <- attr(pl, "region.id") 216 pL <- vector(mode="list", length=n) 217 for (i in 1:n) { 218 this_pl <- pl[[i]] 219 nP <- attr(this_pl, "nParts") 220 keep <- logical(nP) 221 from <- attr(this_pl, "pstart")$from 222 to <- attr(this_pl, "pstart")$to 223 for (j in 1:nP) { 224 xy <- this_pl[from[j]:to[j],] 225 keep[j] <- abs(.RingCentrd_2d(xy)$area) > tol 226 } 227 Ps <- vector(mode="list", length=sum(keep)) 228 jj <- 1 229 for (j in 1:nP) { 230 if (keep[j]) { 231 xy <- this_pl[from[j]:to[j],] 232 if (nrow(xy) < 4) xy <- rbind(xy, xy[1,]) 233 Ps[[jj]] <- Polygon(xy) 234 jj <- jj + 1 235 } 236 } 237 pL[[i]] <- Polygons(Ps, IDs[i]) 238 } 239 res <- SpatialPolygons(pL) 240 res 241} 242