1SpatialPolygonsDataFrame <- function(Sr, data, match.ID = TRUE) {
2# Barry comment 110610
3        if (length(Sr@polygons) != nrow(data))
4          stop(paste("Object length mismatch:\n    ", deparse(substitute(Sr)),
5            "has", length(Sr@polygons), "Polygons objects, but",
6            deparse(substitute(data)), "has", nrow(data), "rows", sep=" "))
7	if (is.character(match.ID)) {
8		row.names(data) = data[, match.ID[1]]
9		match.ID = TRUE
10	}
11	if (match.ID) {
12#		Sr_IDs <- sapply(slot(Sr, "polygons"),
13#                    function(i) slot(i, "ID"))
14                Sr_IDs <- .Call(SpatialPolygons_getIDs_c, Sr)
15		data_IDs <- row.names(data)
16		mtch <- match(Sr_IDs, data_IDs)
17                if (!identical(Sr_IDs, data_IDs)) {
18		    if (any(is.na(mtch)))
19			stop("row.names of data and Polygons IDs do not match")
20		    if (length(unique(mtch)) != length(Sr_IDs))
21			stop("row.names of data and Polygons IDs do not match")
22		   data <- data[mtch, , drop = FALSE]
23               }
24	}
25	res <- new("SpatialPolygonsDataFrame")
26        res@bbox <- Sr@bbox
27        res@proj4string <- Sr@proj4string
28        res@plotOrder <- Sr@plotOrder
29        res@data <- data
30        res@polygons <- Sr@polygons
31# 120416 add top-level comment to reduce comment checking
32        cSr <- comment(Sr)
33        if (is.null(cSr))
34            comment(res) <- as.character(all(sapply(slot(res, "polygons"),
35# 180201 change any to all after NULL comment found
36                function(x) !is.null(comment(x))), na.rm=TRUE))
37        else {
38            if (!is.character(cSr) || is.na(cSr) || length(cSr) != 1)
39            cSr <- as.character(all(sapply(slot(res, "polygons"),
40# 180201 change any to all after NULL comment found
41                function(x) !is.null(comment(x))), na.rm=TRUE))
42            comment(res) <- cSr
43        }
44        res
45}
46
47setReplaceMethod("polygons", signature(object = "data.frame", value = "SpatialPolygons"),
48	function(object, value) SpatialPolygonsDataFrame(value, object))
49
50setMethod("polygons", signature(obj = "SpatialPolygons"),
51	function(obj) as(obj, "SpatialPolygons"))
52
53setMethod("addAttrToGeom", signature(x = "SpatialPolygons", y = "data.frame"),
54	function(x, y, match.ID, ...)
55		SpatialPolygonsDataFrame(x, y, match.ID = match.ID, ...)
56)
57
58names.SpatialPolygonsDataFrame = function(x) names(x@data)
59"names<-.SpatialPolygonsDataFrame" = function(x,value) { checkNames(value); names(x@data) = value; x }
60
61as.data.frame.SpatialPolygonsDataFrame = function(x, row.names, optional, ...) x@data
62
63setAs("SpatialPolygonsDataFrame", "data.frame", function(from)
64    as.data.frame.SpatialPolygonsDataFrame(from))
65
66row.names.SpatialPolygonsDataFrame <- function(x) {
67    .Call(SpatialPolygons_getIDs_c, x)
68}
69
70"row.names<-.SpatialPolygonsDataFrame" <- function(x, value) {
71    spChFIDs(x, value)
72}
73
74setMethod("[", "SpatialPolygonsDataFrame", function(x, i, j, ... , drop = TRUE) {
75    missing.i = missing(i)
76    missing.j = missing(j)
77    nargs = nargs() # e.g., a[3,] gives 2 for nargs, a[3] gives 1.
78    if (missing.i && missing.j) {
79        i = TRUE
80        j = TRUE
81    } else if (missing.j && !missing.i) {
82        if (nargs == 2) {
83            j = i
84            i = TRUE
85        } else {
86            j = TRUE
87        }
88    } else if (missing.i && !missing.j)
89        i = TRUE
90    if (is.matrix(i))
91        stop("matrix argument not supported in SpatialPolygonsDataFrame selection")
92	if (is(i, "Spatial"))
93		i = !is.na(over(x, geometry(i)))
94    if (any(is.na(i)))
95		stop("NAs not permitted in row index")
96	if (is.logical(i)) {
97		if (length(i) == 1 && i)
98			i = 1:length(x@polygons)
99		else
100			i <- which(i)
101	}
102	if (is.character(i))
103		i <- match(i, row.names(x))
104    #SpatialPolygonsDataFrame(as(x, "SpatialPolygons")[i, , drop = FALSE],
105    #    data = x@data[i, j, drop = FALSE], match.ID = FALSE)
106	y <- new("SpatialPolygonsDataFrame")
107	y@proj4string <- x@proj4string
108	y@data = x@data[i, j, ..., drop = FALSE]
109
110	y@polygons = x@polygons[i]
111#	x@bbox <- .bboxCalcR(x@polygons)
112	if (length(i) > 0) {
113            y@bbox <- .Call(bboxCalcR_c, y@polygons)
114            if (is.numeric(i) && any(i < 0)) {
115#                 area <- sapply(x@polygons, function(y) y@area)
116#                 x@plotOrder <- as.integer(order(area, decreasing=TRUE))
117                  y@plotOrder <- .Call(SpatialPolygons_plotOrder_c, y@polygons)
118            } else {
119	        y@plotOrder = order(match(i, x@plotOrder))
120            }
121	} else
122	    y@bbox = x@bbox
123        if (!is.null(comment(x))) comment(y) <- comment(x)
124	y
125###
126### RSB: do something with labelpoints here? How can I check they are present?
127### (label points belong to the Polygons objects, not the SpatialPolygons object)
128})
129
130setAs("SpatialPolygonsDataFrame", "SpatialLinesDataFrame",
131	function(from) SpatialLinesDataFrame(as(from, "SpatialLines"),
132		from@data, match.ID = FALSE))
133
134dim.SpatialPolygonsDataFrame = function(x) dim(x@data)
135
136setMethod("split", "SpatialPolygonsDataFrame", split.data.frame)
137
138setMethod("geometry", "SpatialPolygonsDataFrame",
139	function(obj) as(obj, "SpatialPolygons"))
140
141length.SpatialPolygonsDataFrame = function(x) { length(x@polygons) }
142
143# RSB 151030 override default coerce to preserve top-level comment
144setAs("SpatialPolygonsDataFrame", "SpatialPolygons",
145    function(from) {
146        value <- new("SpatialPolygons")
147        for (what in c("polygons", "plotOrder", "bbox", "proj4string"
148            )) slot(value, what) <- slot(from, what)
149        if (!is.null(comment(from))) comment(value) <- comment(from)
150        value
151    }
152)
153