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