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