1nowrapSpatialPolygons <- function(obj, offset=0, eps=rep(.Machine$double.eps^(1/2.5), 2), avoidGEOS=FALSE) { 2 rgeosI <- rgeosStatus() 3 if (rgeosI) { 4 if (!requireNamespace("rgeos", quietly = TRUE)) 5 stop("package rgeos required") 6# require(rgeos) 7 } else if (!avoidGEOS) { 8 if (!requireNamespace("polyclip", quietly = TRUE)) { 9 warning("package polyclip suggested") 10 stopifnot(isTRUE(gpclibPermitStatus())) 11 if (!requireNamespace("gpclib", quietly = TRUE)) 12 stop("package gpclib required") 13 } 14# require(gpclib) 15 } 16 if (!is(obj, "SpatialPolygons")) stop("obj not a SpatialPolygons object") 17 proj <- is.projected(obj) 18 if (is.na(proj)) stop("unknown coordinate reference system") 19 if (proj) stop("cannot recenter projected coordinate reference system") 20 bblong <- bbox(obj)[1,] 21 inout <- bblong[1] < offset && bblong[2] >= offset 22 if (inout) { 23 pls <- slot(obj, "polygons") 24 Srl <- lapply(pls, .nowrapPolygons, offset=offset, eps=eps, 25 rgeosI=rgeosI, avoidGEOS=avoidGEOS) 26 Srl <- Srl[!sapply(Srl, is.null)] 27 res <- as.SpatialPolygons.PolygonsList(Srl, 28 proj4string=CRS(proj4string(obj))) 29 } else res <- obj 30 res 31} 32 33.nowrapPolygons <- function(obj, offset=0, eps=rep(.Machine$double.eps^(1/2.5), 2), rgeosI, avoidGEOS=FALSE) { 34 if (!is(obj, "Polygons")) stop("not an Polygons object") 35 if (slot(obj, "area") < mean(eps)) return(NULL) 36 if (length(eps) == 1) eps <- rep(eps, 2) 37 bbo <- bbox(obj) 38 inout <- bbo[1,1] < offset && bbo[1,2] >= offset 39 if (inout) { 40 if (rgeosI && !avoidGEOS) { 41 if (!requireNamespace("rgeos", quietly = TRUE)) 42 stop("package rgeos required for .nowrapPolygons") 43 comm <- try(rgeos::createPolygonsComment(obj), silent=TRUE) 44 isV <- try(rgeos::gIsValid(SpatialPolygons(list(obj))), silent=TRUE) 45 if (!inherits(comm, "try-error") && !inherits(isV, "try-error") 46 && isV) { 47 comment(obj) <- comm 48 } else { 49 stop(paste("invalid Polygons object:", slot(obj, "ID"))) 50 } 51 bb <- bbox(obj) 52 bb <- list(x=bb[1,], y=bb[2,]) 53 bbmatW <- matrix(c(rep(bb$x[1], 2), rep(offset-eps[1], 2), 54 bb$x[1], bb$y[1], rep(bb$y[2], 2), rep(bb$y[1], 2)), 55 ncol=2) 56 bbmatE <- matrix(c(rep(offset+eps[2], 2), rep(bb$x[2], 2), 57 offset+eps[2], bb$y[1], rep(bb$y[2], 2), 58 rep(bb$y[1], 2)), ncol=2) 59 SPobj <- SpatialPolygons(list(obj)) 60 resW <- rgeos::gIntersection(SPobj, SpatialPolygons(list(Polygons( 61 list(Polygon(bbmatW)), ID="W")))) 62 resE <- rgeos::gIntersection(SPobj, SpatialPolygons(list(Polygons( 63 list(Polygon(bbmatE)), ID="E")))) 64 cparts <- c(slot(slot(resW, "polygons")[[1]], "Polygons"), 65 slot(slot(resE, "polygons")[[1]], "Polygons")) 66 res <- Polygons(cparts, ID=slot(obj, "ID")) 67 } else if (isTRUE(gpclibPermitStatus())) { 68 if (!requireNamespace("gpclib", quietly = TRUE)) 69 stop("package gpclib required for .nowrapPolygons") 70 pls <- slot(obj, "Polygons") 71 nParts <- length(pls) 72 ID <- slot(obj, "ID") 73 gpc <- as(slot(pls[[1]], "coords"), "gpc.poly") 74 if (nParts > 1) for (i in 2:nParts) gpc <- gpclib::append.poly(gpc, 75 as(slot(pls[[i]], "coords"), "gpc.poly")) 76 bb <- gpclib::get.bbox(gpc) 77 bbmat1 <- matrix(c(rep(bb$x[1], 2), rep(offset-eps[1], 2), 78 bb$x[1], bb$y[1], rep(bb$y[2], 2), rep(bb$y[1], 2)), 79 ncol=2) 80 bbmat2 <- matrix(c(rep(offset+eps[2], 2), rep(bb$x[2], 2), 81 offset+eps[2], bb$y[1], rep(bb$y[2], 2), 82 rep(bb$y[1], 2)), ncol=2) 83 gpc_left <- gpclib::intersect(gpc, as(bbmat1, "gpc.poly")) 84 gpc_right <- gpclib::intersect(gpc, as(bbmat2, "gpc.poly")) 85 gpc_res <- gpclib::append.poly(gpc_left, gpc_right) 86 nP <- length(gpc_res@pts) 87 if (nP == 0) 88 return(obj) 89 Srl <- vector(mode="list", length=nP) 90 for (j in 1:nP) { 91 crds <- cbind(gpc_res@pts[[j]]$x, gpc_res@pts[[j]]$y) 92 crds <- rbind(crds, crds[1,]) 93 if (any(crds[,1] > offset)) { 94 crds[,1] <- crds[,1] - (2*offset) 95 } else if (any(crds[,1] < -offset)){ 96 crds[,1] <- crds[,1] + (2*offset) 97 } 98 hole <- gpc_res@pts[[j]]$hole 99 rD <- .ringDirxy(crds) 100 if (rD == 1 & hole) crds <- crds[nrow(crds):1,] 101 if (rD == -1 & !hole) crds <- crds[nrow(crds):1,] 102 Srl[[j]] <- Polygon(coords=crds, hole=hole) 103 } 104 res <- Polygons(Srl, ID=ID) 105 } else { 106 if (!requireNamespace("polyclip", quietly = TRUE)) 107 stop("package polyclip required for .nowrapPolygons") 108 pls <- slot(obj, "Polygons") 109 nParts <- length(pls) 110 ID <- slot(obj, "ID") 111 pc <- list(length=nParts) 112 crds <- slot(pls[[1]], "coords") 113 pc[[1]] <- list(x=crds[,1], y=crds[,2]) 114 if (nParts > 1) for (i in 2:nParts) { 115 crds <- slot(pls[[i]], "coords") 116 pc[[i]] <- list(x=crds[,1], y=crds[,2]) 117 } 118 bb <- apply(do.call("rbind", lapply(pc, function(i) sapply(i, 119 range))), 2, range) 120 bbmat1 <- list(x=unname(c(rep(bb[1, "x"], 2), 121 rep(offset-eps[1], 2), bb[1, "x"])), 122 y=unname(c(bb[1, "y"], rep(bb[2, "y"], 2), 123 rep(bb[1, "y"], 2)))) 124 bbmat2 <- list(x=unname(c(rep(offset+eps[2], 2), 125 rep(bb[2, "x"], 2), offset+eps[2])), 126 y=unname(c(bb[1, "y"], rep(bb[2, "y"], 2), 127 rep(bb[1, "y"], 2)))) 128 pc_left <- polyclip::polyclip(pc, bbmat1, op="intersection") 129 pc_right <- polyclip::polyclip(pc, bbmat2, op="intersection") 130 pc_res <- c(pc_left, pc_right) 131 nP <- length(pc_res) 132 if (nP == 0) 133 return(obj) 134 Srl <- vector(mode="list", length=nP) 135 for (j in 1:nP) { 136 crds <- cbind(pc_res[[j]]$x, pc_res[[j]]$y) 137 crds <- rbind(crds, crds[1,]) 138 if (any(crds[,1] > offset)) { 139 crds[,1] <- crds[,1] - (2*offset) 140 } else if (any(crds[,1] < -offset)){ 141 crds[,1] <- crds[,1] + (2*offset) 142 } 143 Srl[[j]] <- Polygon(coords=crds) 144 } 145 res <- Polygons(Srl, ID=ID) 146 147 } 148 } else res <- obj 149 res 150} 151 152nowrapRecenter <- function(obj, offset=0, eps=rep(.Machine$double.eps^(1/2.5), 153 2), avoidGEOS=FALSE) { 154 res <- recenter(nowrapSpatialPolygons(obj, offset=offset, eps=eps, 155 avoidGEOS=avoidGEOS)) 156 res 157} 158 159 160nowrapSpatialLines <- function(obj, offset=0, eps=rep(.Machine$double.eps^(1/2.5), 2)) { 161 if (!requireNamespace("rgeos", quietly = TRUE)) { 162 stop("package rgeos required") 163 } 164 165 if (!is(obj, "SpatialLines")) stop("obj not a SpatialLines object") 166 proj <- is.projected(obj) 167 if (is.na(proj)) stop("unknown coordinate reference system") 168 if (proj) stop("cannot recenter projected coordinate reference system") 169 proj4CRS <- CRS(proj4string(obj)) 170 bblong <- bbox(obj)[1,] 171 inout <- bblong[1] < offset && bblong[2] >= offset 172 if (inout) { 173 pls <- slot(obj, "lines") 174 Srl <- lapply(pls, .nowrapLines, offset=offset, eps=eps) 175 res <- SpatialLines(Srl, proj4CRS) 176 } else res <- obj 177 res 178} 179 180 181.nowrapLines <- function(obj, offset=0, eps=rep(.Machine$double.eps^(1/2.5), 2)) { 182 bbo <- range(sapply(obj@Lines, function(x) range(x@coords[,1]))) 183 inout <- bbo[1] < offset && bbo[2] >= offset 184 if (inout) { 185 bb <- bbox(obj) 186 bb <- list(x=bb[1,], y=bb[2,]) 187 bbmatW <- matrix(c(rep(bb$x[1], 2), rep(offset-eps[1], 2), 188 bb$x[1], bb$y[1], rep(bb$y[2], 2), rep(bb$y[1], 2)), 189 ncol=2) 190 bbmatE <- matrix(c(rep(offset+eps[2], 2), rep(bb$x[2], 2), 191 offset+eps[2], bb$y[1], rep(bb$y[2], 2), 192 rep(bb$y[1], 2)), ncol=2) 193 SPobj <- SpatialLines(list(obj)) 194 resW <- rgeos::gIntersection(SPobj, SpatialPolygons(list( 195 Polygons(list(Polygon(bbmatW)), ID="W")))) 196 resW <- ifelse (inherits(resW, "SpatialLines"), 197 slot(slot(resW, "lines")[[1]], "Lines"), list(NULL)) 198 resE <- rgeos::gIntersection(SPobj, SpatialPolygons(list( 199 Polygons(list(Polygon(bbmatE)), ID="E")))) 200 resE <- ifelse (inherits(resE, "SpatialLines"), 201 slot(slot(resE, "lines")[[1]], "Lines"), list(NULL)) 202 cparts <- c(resW, resE) 203 cparts <- cparts[!sapply(cparts, is.null)] 204 res <- Lines(cparts, ID=slot(obj, "ID")) 205 206 } else res <- obj 207 res 208} 209 210