1SpatialPolygons <- function(Srl, pO, proj4string=CRS(as.character(NA))) {
2#	bb <- .bboxCalcR(Srl)
3#	if (missing(pO)) {
4#		area <- sapply(Srl, function(x) x@area)
5#		pO <- as.integer(order(area, decreasing=TRUE))
6#	}
7#	Sp <- new("Spatial", bbox=bb, proj4string=proj4string)
8#	res <- new("SpatialPolygons", Sp, polygons=Srl, plotOrder=as.integer(pO))
9# RSB 091204
10	if (missing(pO))
11		pO <- NULL
12	else {
13		stopifnot(is.integer(pO))
14		stopifnot(length(pO) == length(Srl))
15	}
16	stopifnot(is.list(Srl))
17# tess to Polygons bug 121028
18	# EJP, 2/3/2015, uncomments:
19	# stopifnot(length(Srl) > 0)
20	stopifnot(is(proj4string, "CRS"))
21	res <- .Call(SpatialPolygons_c, Srl, pO, proj4string)
22	validObject(res)
23# 120416 add top-level comment to reduce comment checking
24	cSr <- as.character(all(sapply(slot(res, "polygons"),
25# 180201 change any to all after NULL comment found; https://github.com/r-spatial/sf/issues/636
26            function(x) !is.null(comment(x))), na.rm=TRUE))
27	comment(res) <- cSr
28	res
29}
30
31Polygon <- function(coords, hole=as.logical(NA)) {
32
33	coords <- coordinates(coords)
34##	if (!is.matrix(coords)) stop("coords must be a two-column matrix")
35	if (ncol(coords) != 2) stop("coords must be a two-column matrix")
36# RSB 091203
37        n <- dim(coords)[1]
38        if (n < 4L) {
39            warning("less than 4 coordinates in polygon")
40            if (n == 1L) coords <- rbind(coords, coords, coords, coords)
41            else if (n == 2L) coords <- rbind(coords, coords[1,], coords[1,])
42            else if (n == 3L) coords <- rbind(coords, coords[1,])
43            n <- dim(coords)[1]
44        }
45        stopifnot(is.logical(hole))
46        ihole <- as.integer(hole)
47# RSB 100126 fixing hole assumption
48# thanks to Javier Munoz for report
49        res <- .Call(Polygon_c, coords, n, ihole)
50#        validObject(res)
51        res
52}
53
54Polygons <- function(srl, ID) {
55# tess to Polygons bug 121028
56        stopifnot(is.list(srl))
57        stopifnot(length(srl) > 0)
58	if (any(sapply(srl, function(x) !is(x, "Polygon"))))
59		stop("srl not a list of Polygon objects")
60##	projargs <- unique(sapply(srl, proj4string))
61##	if (length(projargs) > 1)
62##		stop("differing projections among Polygon objects")
63	if (missing(ID)) stop("Single ID required")
64	if (length(ID) != 1) stop("Single ID required")
65        ID <- as.character(ID)
66        stopifnot(nzchar(ID))
67# RSB 091203
68        res <- .Call(Polygons_c, srl, ID)
69#        validObject(res)
70        res
71}
72
73bbox.Polygons <- function(obj) {
74	rx=range(c(sapply(obj@Polygons, function(x) range(x@coords[,1]))))
75	ry=range(c(sapply(obj@Polygons, function(x) range(x@coords[,2]))))
76	res=rbind(x=rx,y=ry)
77   	colnames(res) <- c("min", "max")
78	res
79}
80
81setMethod("bbox", "Polygons", bbox.Polygons)
82
83bbox.Polygon <- function(obj) {
84	rx <- range(obj@coords[,1])
85   	ry <- range(obj@coords[,2])
86	res=rbind(x=rx,y=ry)
87    colnames(res) <- c("min", "max")
88	res
89}
90
91setMethod("bbox", "Polygon", bbox.Polygon)
92
93as.SpatialPolygons.PolygonsList <- function(Srl, proj4string=CRS(as.character(NA))) {
94	if (any(sapply(Srl, function(x) !is(x, "Polygons"))))
95		stop("srl not a list of Polygons objects")
96#	projargs <- unique(sapply(Srl, proj4string))
97#	if (length(projargs) > 1)
98#		stop("differing projections among Polygons objects")
99
100#	n <- length(Srl)
101
102	res <- SpatialPolygons(Srl, proj4string=proj4string)
103	res
104}
105
106row.names.SpatialPolygons <- function(x) {
107    .Call(SpatialPolygons_getIDs_c, x)
108}
109
110"row.names<-.SpatialPolygons" <- function(x, value) {
111    spChFIDs(x, value)
112}
113
114setMethod("[", "SpatialPolygons", function(x, i, j, ..., drop = TRUE) {
115	if (is(i, "Spatial"))
116		i = !is.na(over(x, geometry(i)))
117	if (is.logical(i)) {
118		if (length(i) == 1 && i)
119			i = 1:length(x@polygons)
120		else
121			i <- which(i)
122	} else if (is.character(i))
123		i <- match(i, row.names(x))
124	if (any(is.na(i)))
125		stop("NAs not permitted in row index")
126	if (length(unique(i)) != length(i))
127		stop("SpatialPolygons selection: can't find plot order if polygons are replicated")
128	if (length(x@polygons[i]) == 0) {
129		x@polygons = x@polygons[i]
130		x@plotOrder = integer(0)
131		stopifnot(validObject(x))
132		x
133	} else {
134		y = SpatialPolygons(x@polygons[i], proj4string=rebuild_CRS(slot(x, "proj4string")))
135                if (!is.null(comment(x))) comment(y) <- comment(x)
136                y
137        }
138#	x@polygons = x@polygons[i]
139#	x@bbox <- .bboxCalcR(x@polygons)
140#	area <- sapply(slot(x, "polygons"), function(i) slot(i, "area"))
141#	x@plotOrder <- as.integer(order(area, decreasing=TRUE))
142#	x
143})
144
145setMethod("coordnames", signature(x = "SpatialPolygons"),
146	function(x) coordnames(x@polygons[[1]])
147)
148setMethod("coordnames", signature(x = "Polygons"),
149	function(x) coordnames(x@Polygons[[1]])
150)
151setMethod("coordnames", signature(x = "Polygon"),
152	function(x) dimnames(x@coords)[[2]]
153)
154setReplaceMethod("coordnames",
155	signature(x = "SpatialPolygons", value = "character"),
156	function(x, value) {
157		dimnames(x@bbox)[[1]] = value
158		#for (i in seq(along = x@polygons))
159		#	coordnames(x@polygons[[i]]) = value
160		x@polygons = lapply(x@polygons,
161			function(y) Polygons(lapply(y@Polygons,
162				function(z) { dimnames(z@coords)[[2]] = value; z }), y@ID))
163		x
164	}
165)
166setMethod("coordinates", "SpatialPolygons",
167	function(obj) {
168		ret = t(sapply(slot(obj, "polygons"), function(i) slot(i, "labpt")))
169		dimnames(ret) = list(sapply(slot(obj, "polygons"), function(i) slot(i, "ID")), NULL)
170		ret
171	}
172)
173
174getSpatialPolygonsLabelPoints = function(SP) {
175	.Deprecated("slot", package = "sp",
176            msg="use *apply and slot directly, or coordinates method")
177	ret = t(sapply(slot(SP, "polygons"), function(x) slot(x, "labpt")))
178	SpatialPoints(ret, rebuild_CRS(slot(SP, "proj4string")))
179}
180
181as.Lines.Polygons = function(from) {
182	lst = lapply(from@Polygons, function(x) as(x, "Line"))
183	Lines(lst, from@ID)
184}
185setAs("Polygons", "Lines", as.Lines.Polygons)
186
187as.SpatialLines.SpatialPolygons = function(from)
188	SpatialLines(lapply(from@polygons, function(x) as(x, "Lines")),
189		rebuild_CRS(slot(from, "proj4string")))
190
191setAs("SpatialPolygons", "SpatialLines", as.SpatialLines.SpatialPolygons)
192
193as.SpatialPolygonsDataFrame.SpatialPolygons = function(from) {
194	IDs <- sapply(slot(from, "polygons"), function(x) slot(x, "ID"))
195	df <- data.frame(dummy = rep(0, length(IDs)), row.names=IDs)
196	SpatialPolygonsDataFrame(from, df)
197}
198
199setAs("SpatialPolygons", "SpatialPolygonsDataFrame",
200	as.SpatialPolygonsDataFrame.SpatialPolygons)
201
202length.SpatialPolygons = function(x) { length(x@polygons) }
203
204names.SpatialPolygons = function(x) {
205	unlist(lapply(x@polygons, function(X) X@ID))
206}
207