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