1gpclibPermit <- function() { 2 if ("gpclib" %in% .packages(all.available = TRUE)) 3 assign("gpclib", TRUE, envir=.MAPTOOLS_CACHE) 4 if (gpclibPermitStatus()) warning("support for gpclib will be withdrawn from maptools at the next major release") 5 gpclibPermitStatus() 6} 7 8gpclibPermitStatus <- function() get("gpclib", envir=.MAPTOOLS_CACHE) 9 10setRgeosStatus <- function() { 11 rgeosI <- "rgeos" %in% .packages(all.available = TRUE) 12# if (rgeosI) { 13# ldNS <- loadedNamespaces() 14# if (!("rgeos" %in% ldNS)) { 15# oo <- try(loadNamespace("rgeos"), silent=TRUE) 16# if (class(oo) == "try-error") rgeosI <- FALSE 17# else unloadNamespace("rgeos") 18# } 19# } 20 assign("rgeos", rgeosI, envir=.MAPTOOLS_CACHE) 21} 22 23rgeosStatus <- function() get("rgeos", envir=.MAPTOOLS_CACHE) 24 25checkPolygonsHoles <- function(x, properly=TRUE, avoidGEOS=FALSE, 26 useSTRtree=FALSE) { 27 if (rgeosStatus() && !avoidGEOS) { 28 # require(rgeos) # xxx 29 if (!requireNamespace("rgeos", quietly = TRUE)) 30 stop("package rgeos required") 31# version check rgeos 32 if (compareVersion(as.character(packageVersion("rgeos")), "0.1-4") < 0) 33 useSTRtree <- FALSE 34 return(checkPolygonsGEOS(x, properly=properly, useSTRtree=useSTRtree)) 35 } else { 36 stopifnot(isTRUE(gpclibPermitStatus())) 37 # require(gpclib) 38 if (!requireNamespace("gpclib", quietly = TRUE)) 39 stop("package gpclib required") 40 if (!is(x, "Polygons")) stop("not an Polygons object") 41 pls <- slot(x, "Polygons") 42 nParts <- length(pls) 43 ID <- slot(x, "ID") 44 gpc <- as(slot(pls[[1]], "coords"), "gpc.poly") 45 if (nParts > 1) for (i in 2:nParts) gpc <- gpclib::append.poly(gpc, 46 as(slot(pls[[i]], "coords"), "gpc.poly")) 47 bb <- gpclib::get.bbox(gpc) 48 bbmat <- matrix(c(rep(bb$x[1], 2), rep(bb$x[2], 2), bb$x[1], bb$y[1], 49 rep(bb$y[2], 2), rep(bb$y[1], 2)), ncol=2) 50 gpc_bb <- as(bbmat, "gpc.poly") 51 gpc_res <- gpclib::intersect(gpc, gpc_bb) 52 nP <- length(gpc_res@pts) 53 Srl <- vector(mode="list", length=nP) 54 for (j in 1:nP) { 55 crds <- cbind(gpc_res@pts[[j]]$x, gpc_res@pts[[j]]$y) 56 crds <- rbind(crds, crds[1,]) 57 hole <- gpc_res@pts[[j]]$hole 58 rD <- .ringDirxy_gpc(crds) 59 if (rD == 1 & hole) crds <- crds[nrow(crds):1,] 60 if (rD == -1 & !hole) crds <- crds[nrow(crds):1,] 61 Srl[[j]] <- Polygon(coords=crds, hole=hole) 62 } 63 res <- Polygons(Srl, ID=ID) 64 res 65 } 66} 67 68.ringDirxy_gpc <- function(xy) { 69 a <- xy[,1] 70 b <- xy[,2] 71 nvx <- length(b) 72 73 if((a[1] == a[nvx]) && (b[1] == b[nvx])) { 74 a <- a[-nvx] 75 b <- b[-nvx] 76 nvx <- nvx - 1 77 } 78 if (nvx < 3) return(1) 79 80 tX <- 0.0 81 dfYMax <- max(b) 82 ti <- 1 83 for (i in 1:nvx) { 84 if (b[i] == dfYMax && a[i] > tX) ti <- i 85 } 86 if ( (ti > 1) & (ti < nvx) ) { 87 dx0 = a[ti-1] - a[ti] 88 dx1 = a[ti+1] - a[ti] 89 dy0 = b[ti-1] - b[ti] 90 dy1 = b[ti+1] - b[ti] 91 } else if (ti == nvx) { 92 dx0 = a[ti-1] - a[ti] 93 dx1 = a[1] - a[ti] 94 dy0 = b[ti-1] - b[ti] 95 dy1 = b[1] - b[ti] 96 } else { 97# /* if the tested vertex is at the origin then continue from 0 (1) */ 98 dx1 = a[2] - a[1] 99 dx0 = a[nvx] - a[1] 100 dy1 = b[2] - b[1] 101 dy0 = b[nvx] - b[1] 102 } 103 v3 = ( (dx0 * dy1) - (dx1 * dy0) ) 104 if ( v3 > 0 ) return(as.integer(1)) 105 else return(as.integer(-1)) 106} 107 108 109checkPolygonsGEOS <- function(obj, properly=TRUE, force=TRUE, useSTRtree=FALSE) { 110 if (!is(obj, "Polygons")) 111 stop("not a Polygons object") 112 if (!requireNamespace("rgeos", quietly = TRUE)) 113 stop("package rgeos required for checkPolygonsGEOS") 114 comm <- try(rgeos::createPolygonsComment(obj), silent=TRUE) 115# isVal <- try(gIsValid(SpatialPolygons(list(obj))), silent=TRUE) 116# if (class(isVal) == "try-error") isVal <- FALSE 117 if (!inherits(comm, "try-error") && !force) { 118 comment(obj) <- comm 119 return(obj) 120 } 121 pls <- slot(obj, "Polygons") 122 IDs <- slot(obj, "ID") 123 n <- length(pls) 124 if (n < 1) stop("Polygon list of zero length") 125 uniqs <- rep(TRUE, n) 126 if (n > 1) { 127 if (useSTRtree) tree1 <- rgeos::gUnarySTRtreeQuery(obj) 128 SP <- SpatialPolygons(lapply(1:n, function(i) 129 Polygons(list(pls[[i]]), ID=i))) 130 for (i in 1:(n-1)) { 131 if (useSTRtree) { 132 if (!is.null(tree1[[i]])) { 133 res <- try(rgeos::gEquals(SP[i,], SP[tree1[[i]],], byid=TRUE), 134 silent=TRUE) 135 if (inherits(res, "try-error")) { 136 warning("Polygons object ", IDs, ", Polygon ", 137 i, ": ", res) 138 next 139 } 140 if (any(res)) { 141 uniqs[as.integer(rownames(res)[res])] <- FALSE 142 } 143 } 144 } else { 145 res <- try(rgeos::gEquals(SP[i,], SP[uniqs,], byid=TRUE), silent=TRUE) 146 if (inherits(res, "try-error")) { 147 warning("Polygons object ", IDs, ", Polygon ", 148 i, ": ", res) 149 next 150 } 151 res[i] <- FALSE 152 if (any(res)) { 153 wres <- which(res) 154 uniqs[wres[wres > i]] <- FALSE 155 } 156 } 157 } 158 } 159 if (any(!uniqs)) warning(paste("Duplicate Polygon objects dropped:", 160 paste(wres, collapse=" "))) 161 pls <- pls[uniqs] 162# IDs <- IDs[uniqs] 163 n <- length(pls) 164 if (n < 1) stop("Polygon list of zero length") 165 if (n == 1) { 166 oobj <- Polygons(pls, ID=IDs) 167 comment(oobj) <- rgeos::createPolygonsComment(oobj) 168 return(oobj) 169 } 170 areas <- sapply(pls, slot, "area") 171 pls <- pls[order(areas, decreasing=TRUE)] 172 oholes <- sapply(pls, function(x) slot(x, "hole")) 173 holes <- rep(FALSE, n) 174 SP <- SpatialPolygons(lapply(1:n, function(i) 175 Polygons(list(pls[[i]]), ID=i))) 176 if (useSTRtree) tree2 <- rgeos::gUnarySTRtreeQuery(SP) 177 for (i in 1:(n-1)) { 178 if (useSTRtree) { 179 if (!is.null(tree2[[i]])) { 180 if (properly) res <- rgeos::gContainsProperly(SP[i,], SP[tree2[[i]],], 181 byid=TRUE) 182 else res <- rgeos::gContains(SP[i,], SP[tree2[[i]],], byid=TRUE) 183 } else { 184 res <- FALSE 185 } 186 } else { 187 if (properly) res <- rgeos::gContainsProperly(SP[i,], SP[-(1:i),], 188 byid=TRUE) 189 else res <- rgeos::gContains(SP[i,], SP[-(1:i),], byid=TRUE) 190 } 191 wres <- which(res) 192 if (length(wres) > 0L) { 193 nres <- as.integer(rownames(res)) 194 holes[nres[wres]] <- ! holes[nres[wres]] 195 } 196 } 197 for (i in 1:n) { 198 if (oholes[i] != holes[i]) 199 pls[[i]] <- Polygon(slot(pls[[i]], "coords"), hole=holes[i]) 200 } 201 oobj <- Polygons(pls, ID=IDs) 202 comment(oobj) <- rgeos::createPolygonsComment(oobj) 203 oobj 204} 205