1# Copyright 2000-2001 (c) Nicholas Lewin-Koh 2# modifications 2001-2008 Roger Bivand 3# reads an ESRI shapefile into a map object 4# set the variables for the header info 5 6 7read.shape <- function(filen, dbf.data=TRUE, verbose=TRUE, repair=FALSE) { 8 filen <- path.expand(filen) 9 .Deprecated("", package="maptools", msg="use readShapeSpatial:\nobjects other than Spatial objects defined in the sp package are deprecated") 10 if (length(grep("\\.shp$", tolower(filen))) == 0L) 11 filen <- paste(filen, "shp", sep=".") 12 shinfo <- getinfo.shape(filen) 13 if (dbf.data) { 14# library(foreign) 15# filename wrong assumption BDR 100403 16# df <- read.dbf(filen) 17 bn <- basename(filen) 18 dn <- dirname(filen) 19 sbn <- strsplit(bn, "\\.")[[1]] 20 lsbn <- length(sbn) 21 if (lsbn > 1 && tolower(sbn[lsbn]) == "shp") sbn[lsbn] <- "dbf" 22 filen1 <- paste(sbn, collapse=".") 23 if (length(grep("\\.dbf$", filen1)) == 0L) 24 filen1 <- paste(filen1, "dbf", sep=".") 25 if (length(dn) > 0L) { 26 filen1 <- paste(dn, filen1, sep=.Platform$file.sep) 27 } 28 df <- read.dbf(filen1) 29 ndf <- as.integer(nrow(df)) 30 } else ndf <- as.integer(NA) 31 if (shinfo[[2]] == 8) { 32 if (!dbf.data) stop("to test for multipoint compliance, set dbf.data=TRUE") 33 if (ndf != shinfo[[3]]) stop("noncompliant multipoint shapefile") 34 } 35 shp.lst <- .Call("Rshapeget", as.character(filen), as.logical(repair), 36 PACKAGE="maptools") 37 if (verbose) { 38 print(shinfo) 39 } 40 n <- length(shp.lst) 41 for (i in 1:n) { 42 attr(shp.lst[[i]], "nVerts") <- as.integer(shp.lst[[i]]$nVerts) 43 attr(shp.lst[[i]], "nParts") <- as.integer(shp.lst[[i]]$nParts) 44 attr(shp.lst[[i]], "shp.type") <- as.integer(shp.lst[[i]]$shp.type) 45 attr(shp.lst[[i]], "bbox") <- as.double(shp.lst[[i]]$bbox) 46 } 47 class(shp.lst) <- "ShapeList" 48 if (dbf.data) { 49 map <- list(Shapes=shp.lst, att.data=df) 50 class(map) <- "Map" 51 return(map) 52 } 53 else { 54 return(shp.lst) 55 } 56} 57 58getinfo.shape <- function(filen) { 59 shapehead <-.Call("Rshapeinfo1", as.character(path.expand(filen)), PACKAGE="maptools") 60 class(shapehead) <- "shapehead" 61 shapehead 62} 63 64print.shapehead <- function(x, ...) { 65 types <- c("Point", NA, "PolyLine", NA, "Polygon", NA, NA, "MultiPoint", NA, NA, "PointZ", NA, "PolyLineZ", NA, "PolygonZ", NA, NA, "MultiPointZ", NA, NA, "PointM", NA, "PolyLineM", NA, "PolygonM", NA, NA, "MultiPointM", NA, NA, "MultiPatch") 66 cat("Shapefile type: ", types[x[[2]]], ", (", x[[2]], "), # of Shapes: ", 67 x[[3]], "\n", sep="") 68} 69 70 71#write.pointShape <- function(object, file, coordinates, factor2char=TRUE, 72write.pointShape <- function(coordinates, df, file, factor2char=TRUE, 73 strictFilename=FALSE, max_nchar=254) { 74 .Deprecated("", package="maptools", msg="use writeSpatialShape:\nobjects other than Spatial objects defined in the sp package are deprecated") 75 file <- path.expand(file) 76 dirnm <- dirname(file) 77 bnm0 <- basename(file) 78 bnm1 <- strsplit(bnm0, "\\.")[[1]] 79 if (bnm1[length(bnm1)] == "shp") 80 bnm <- paste(bnm1[-length(bnm1)], collapse=".") 81 else bnm <- bnm0 82 file <- paste(dirnm, bnm, sep=.Platform$file.sep) 83 if (strictFilename && nchar(basename(file)) > 8) 84 stop("shapefile names must conform to the 8.3 format") 85 if (!is.matrix(coordinates)) stop("coordinates must be a matrix") 86 if (!is.numeric(coordinates)) stop("coordinates must be numeric") 87 ncolcrds <- ncol(coordinates) 88 if (ncolcrds < 2) stop("coordinates must have at least 2 columns") 89 if (ncolcrds > 3) stop("coordinates must have 2 or 3 columns") 90 if (nrow(df) != nrow(coordinates)) 91 stop("different number of rows in coordinates and data frame") 92# library(foreign) 93 write.dbf(df, paste(file, ".dbf", sep=""), factor2char=factor2char, max_nchar=max_nchar) 94 storage.mode(coordinates) <- "double" 95 res <- .Call("shpwritepoint", as.character(file), coordinates, 96 as.integer(ncolcrds), PACKAGE="maptools") 97 invisible(res) 98} 99 100.isValidPolylist <- function(polylist, verbose=FALSE) { 101 if (!inherits(polylist, "polylist")) stop("not a polylist object") 102 res <- TRUE 103 if (length(polylist) < 1L) { 104 if (verbose) cat("zero length polylist\n") 105 res <- FALSE 106 } 107 if (is.null(attr(polylist, "nDims"))) { 108 if (verbose) cat("null polylist nDims attribute\n") 109 res <- FALSE 110 } else { 111 if (attr(polylist, "nDims") < 2 || attr(polylist, "nDims") > 3) { 112 if (verbose) cat("polylist nDims attribute neither 2 nor 3\n") 113 res <- FALSE 114 } 115 if (!is.integer(attr(polylist, "nDims"))) { 116 if (verbose) cat("nDims not all integer\n") 117 res <- FALSE 118 } 119 } 120 if (!all(sapply(polylist, function(x) is.double(x)))) { 121 if (verbose) cat("coordinates not all double\n") 122 res <- FALSE 123 } 124 if (any(sapply(polylist, function(x) is.null(attr(x, "nParts"))))) { 125 if (verbose) cat("null polylist nParts attribute\n") 126 res <- FALSE 127 } else { 128 if (any(sapply(polylist, function(x) attr(x, "nParts") < 1))) { 129 if (verbose) cat("polylist nParts attribute less than 1\n") 130 res <- FALSE 131 } 132 if (!all(sapply(polylist, function(x) is.integer(attr(x, "nParts"))))) { 133 if (verbose) cat("nParts not all integer\n") 134 res <- FALSE 135 } 136 } 137 if (any(sapply(polylist, function(x) is.null(attr(x, "pstart"))))) { 138 if (verbose) cat("null polylist pstart attribute\n") 139 res <- FALSE 140 } else { 141 if (any(sapply(polylist, function(x) is.null(attr(x, "pstart")$from)))) { 142 if (verbose) cat("null polylist pstart$from attribute\n") 143 res <- FALSE 144 } else { 145 if (!all(sapply(polylist, function(x) is.integer(attr(x, 146 "pstart")$from)))) { 147 if (verbose) cat("pstart$from not all integer\n") 148 res <- FALSE 149 } 150 } 151 if (any(sapply(polylist, function(x) is.null(attr(x, "pstart")$to)))) { 152 if (verbose) cat("null polylist pstart$to attribute\n") 153 res <- FALSE 154 } else { 155 if (!all(sapply(polylist, function(x) is.integer(attr(x, 156 "pstart")$to)))) { 157 if (verbose) cat("pstart$to not all integer\n") 158 res <- FALSE 159 } 160 } 161 } 162 res 163} 164 165.makePolylistValid <- function(polylist) { 166 if (!inherits(polylist, "polylist")) stop("not a polylist object") 167 if (length(polylist) < 1L) stop("zero length polylist") 168 n <- length(polylist) 169 if (is.null(attr(polylist, "nDims")) || 170 !is.integer(attr(polylist, "nDims")) || 171 (attr(polylist, "nDims") < 2 || attr(polylist, "nDims") > 3)) { 172 nD <- unique(sapply(polylist, function(x) dim(x)[2])) 173 if (length(nD) > 1L) stop("multiple dimension polylist components") 174 nD <- as.integer(nD) 175 attr(polylist, "nDims") <- nD 176 } 177 if (!all(sapply(polylist, function(x) is.double(x)))) { 178 for (i in 1:n) { 179 a <- attributes(polylist[[i]]) 180 polylist[[i]] <- matrix(as.double(polylist[[i]]), ncol=nD) 181 attributes(polylist[[i]]) <- a 182 } 183 warning("coordinates changed to double") 184 } 185 if (any(sapply(polylist, function(x) is.null(attr(x, "nParts"))))) { 186 for (i in 1:n) { 187 if (any(is.na(c(polylist[[i]])))) { 188 xy <- polylist[[i]] 189 NAs <- unclass(attr(na.omit(xy), "na.action")) 190 if (NAs[length(NAs)] == nrow(xy)) { 191 NAs <- NAs[-length(NAs)] 192 xy <- xy[1:(nrow(xy)-1),] 193 } 194 nParts <- length(NAs) + 1L 195 from <- integer(nParts) 196 to <- integer(nParts) 197 from[1] <- 1 198 to[nParts] <- nrow(xy) 199 if (nParts > 1) { 200 for (j in 2:nParts) { 201 to[(j-1)] <- NAs[(j-1)]-1 202 from[j] <- NAs[(j-1)]+1 203 } 204 } 205 attr(polylist[[i]], "nParts") <- as.integer(nParts) 206 a <- list() 207 a$from <- as.integer(from) 208 a$to <- as.integer(to) 209 attr(polylist[[i]], "pstart") <- a 210 } else { 211 attr(polylist[[i]], "nParts") <- as.integer(1) 212 a <- list() 213 a$from <- as.integer(1) 214 a$to <- as.integer(nrow(polylist[[i]])) 215 attr(polylist[[i]], "pstart") <- a 216 } 217 attr(polylist[[i]], "ringDir") <- as.integer(rep(1, 218 attr(polylist[[i]], "nParts"))) 219 attr(polylist[[i]], "plotOrder") <- 220 as.integer(1:attr(polylist[[i]], "nParts")) 221 } 222 warning("nParts and pstart added") 223 } 224 if (any(sapply(polylist, function(x) attr(x, "nParts") < 1))) 225 stop("polylist nParts attribute less than 1") 226 if (!all(sapply(polylist, function(x) is.integer(attr(x, "nParts"))))) { 227 for (i in 1:n) attr(polylist[[i]], "nParts") <- 228 as.integer(attr(polylist[[i]], "nParts")) 229 warning("nParts changed to integer") 230 } 231 if (any(sapply(polylist, function(x) is.null(attr(x, "pstart"))))) { 232 for (i in 1:n) { 233 if (any(is.na(c(polylist[[i]])))) { 234 xy <- polylist[[i]] 235 NAs <- unclass(attr(na.omit(xy), "na.action")) 236 nParts <- length(NAs) + 1L 237 from <- integer(nParts) 238 to <- integer(nParts) 239 from[1] <- 1 240 to[nParts] <- nrow(xy) 241 if (nParts > 1) { 242 for (j in 2:nParts) { 243 to[(j-1)] <- NAs[(j-1)]-1 244 from[j] <- NAs[(j-1)]+1 245 } 246 } 247 attr(polylist[[i]], "nParts") <- as.integer(nParts) 248 a <- list() 249 a$from <- as.integer(from) 250 a$to <- as.integer(to) 251 attr(polylist[[i]], "pstart") <- a 252 } else { 253 attr(polylist[[i]], "nParts") <- as.integer(1) 254 a <- list() 255 a$from <- as.integer(1) 256 a$to <- as.integer(nrow(polylist[[i]])) 257 attr(polylist[[i]], "pstart") <- a 258 } 259 attr(polylist[[i]], "ringDir") <- as.integer(rep(1, 260 attr(polylist[[i]], "nParts"))) 261 attr(polylist[[i]], "plotOrder") <- 262 as.integer(1:attr(polylist[[i]], "nParts")) 263 } 264 warning("nParts and pstart added") 265 } 266 if (!all(sapply(polylist, function(x) is.integer(attr(x, "pstart")$from)))) { 267 for (i in 1:n) attr(polylist[[i]], "pstart")$from <- 268 as.integer(attr(polylist[[i]], "pstart")$from) 269 warning("pstart$from changed to integer") 270 } 271 if (!all(sapply(polylist, function(x) is.integer(attr(x, "pstart")$to)))) { 272 for (i in 1:n) attr(polylist[[i]], "pstart")$to <- 273 as.integer(attr(polylist[[i]], "pstart")$to) 274 warning("pstart$to changed to integer") 275 } 276 polylist 277} 278 279write.polylistShape <- function(polylist, df, file, factor2char=TRUE, 280 strictFilename=FALSE, force=TRUE, max_nchar=254) { 281 .Deprecated("", package="maptools", msg="use writeSpatialShape:\nobjects other than Spatial objects defined in the sp package are deprecated") 282 file <- path.expand(file) 283 dirnm <- dirname(file) 284 bnm0 <- basename(file) 285 bnm1 <- strsplit(bnm0, "\\.")[[1]] 286 if (bnm1[length(bnm1)] == "shp") 287 bnm <- paste(bnm1[-length(bnm1)], collapse=".") 288 else bnm <- bnm0 289 file <- paste(dirnm, bnm, sep=.Platform$file.sep) 290 if (strictFilename && nchar(basename(file)) > 8) 291 stop("shapefile names must conform to the 8.3 format") 292 if (!inherits(polylist, "polylist")) stop("not a polylist object") 293 if (length(polylist) < 1L) stop("zero length polylist") 294 if (nrow(df) != length(polylist)) 295 stop("different number of rows in polylist and data frame") 296 if (!.isValidPolylist(polylist)) { 297 if (!force) 298 stop("Invalid polylist - set force=TRUE to coerce to validity") 299 else polylist <- .makePolylistValid(polylist) 300 } 301# library(foreign) 302 write.dbf(df, paste(file, ".dbf", sep=""), factor2char=factor2char, max_nchar=max_nchar) 303 res <- .Call("shpwritepolys", as.character(file), polylist, 304 PACKAGE="maptools") 305 invisible(res) 306} 307 308write.linelistShape <- function(linelist, df, file, factor2char=TRUE, 309 strictFilename=FALSE, max_nchar=254) { 310 .Deprecated("", package="maptools", msg="use writeSpatialShape:\nobjects other than Spatial objects defined in the sp package are deprecated") 311 file <- path.expand(file) 312 dirnm <- dirname(file) 313 bnm0 <- basename(file) 314 bnm1 <- strsplit(bnm0, "\\.")[[1]] 315 if (bnm1[length(bnm1)] == "shp") 316 bnm <- paste(bnm1[-length(bnm1)], collapse=".") 317 else bnm <- bnm0 318 file <- paste(dirnm, bnm, sep=.Platform$file.sep) 319 if (strictFilename && nchar(basename(file)) > 8) 320 stop("shapefile names must conform to the 8.3 format") 321 if (length(linelist) < 1L) stop("zero length linelist") 322 if (nrow(df) != length(linelist)) 323 stop("different number of rows in linelist and data frame") 324 if (!any(sapply(linelist, function(x) is.integer(attr(x, "nParts"))))) { 325 for (i in 1:length(linelist)) { 326 attr(linelist[[i]], "nParts") <- as.integer(attr(linelist[[i]], "nParts")) 327 } 328 warning("nParts changed to integer") 329 } 330 if (!any(sapply(linelist, function(x) is.integer(attr(x, "pstart")[[1]])))) { 331 for (i in 1:length(linelist)) { 332 attr(linelist[[i]], "pstart")[[1]] <- as.integer(attr(linelist[[i]], 333 "pstart")[[1]]) 334 } 335 warning("pstart changed to integer") 336 } 337 if (!any(sapply(linelist, function(x) is.integer(attr(x, "pstart")[[2]])))) { 338 for (i in 1:length(linelist)) { 339 attr(linelist[[i]], "pstart")[[2]] <- as.integer(attr(linelist[[i]], 340 "pstart")[[2]]) 341 } 342 warning("pstart changed to integer") 343 } 344# if (!all(sapply(linelist, function(x) all(!is.na(x))))) 345# stop("NAs in line coordinate data") 346 if (!any(sapply(linelist, function(x) is.double(x)))) { 347 for (i in 1:length(linelist)) { 348 linelist[[i]] <- matrix(as.double(linelist[[i]]), ncol=2) 349 } 350 warning("coordinates changed to double") 351 } 352# library(foreign) 353 write.dbf(df, paste(file, ".dbf", sep=""), factor2char=factor2char, max_nchar=max_nchar) 354 res <- .Call("shpwritelines", as.character(file), linelist, 355 PACKAGE="maptools") 356 invisible(res) 357} 358 359readMAP2polylist = function(filename){ 360 zz=file(filename,"rb") 361 # 362 # header of .map 363 # 364 versao = readBin(zz,"integer",1,size=2) # 100 = versao 1.00 365 #Bounding Box 366 Leste = readBin(zz,"numeric",1,size=4) 367 Norte = readBin(zz,"numeric",1,size=4) 368 Oeste = readBin(zz,"numeric",1,size=4) 369 Sul = readBin(zz,"numeric",1,size=4) 370 371 geocodigo = "" 372 nome = "" 373 xleg = 0 374 yleg = 0 375 sede = FALSE 376 poli = list() 377 i = 0 378 379 # 380 # repeat of each object in file 381 # 382 repeat{ 383 tipoobj = readBin(zz,"integer",1,size=1) # 0=Poligono, 1=PoligonoComSede, 2=Linha, 3=Ponto 384 385 if (length(tipoobj) == 0) break 386 i = i + 1 387 388 Len = readBin(zz,"integer",1,size=1) # length byte da string Pascal 389 geocodigo[i] = rawToChar(readBin(zz, "raw", 10, size = 1))#readChar(zz,10) 390 Len = readBin(zz,"integer",1,size=1) # length byte da string Pascal 391 inp <- readBin(zz, "raw", 25, size = 1) 392 inp[inp > 127] <- charToRaw(" ") 393 nome[i] = substr(rawToChar(inp), 1, Len) 394 xleg[i] = readBin(zz,"numeric",1,size=4) 395 yleg[i] = readBin(zz,"numeric",1,size=4) 396 numpontos = readBin(zz,"integer",1,size=2) 397 398 sede = sede || (tipoobj = 1) 399 400 x=0 401 y=0 402 for (j in 1:numpontos){ 403 x[j] = readBin(zz,"numeric",1,size=4) 404 y[j] = readBin(zz,"numeric",1,size=4) 405 } 406 407 408 # separate polygons 409 xInic = x[1] 410 yInic = y[1] 411 for (j in 2:numpontos){ 412 if (x[j] == xInic & y[j] == yInic) {x[j]=NA; y[j] = NA} 413 } 414 415 poli[[i]] = c(x,y) 416 dim(poli[[i]]) = c(numpontos,2) 417 } 418 419 class(poli) = "polylist" 420 attr(poli,"region.id") = geocodigo 421 attr(poli,"region.name") = nome 422 attr(poli,"centroid") = list(x=xleg,y=yleg) 423 attr(poli,"sede") = sede 424 attr(poli,"maplim") = list(x=c(Oeste,Leste),y=c(Sul,Norte)) 425 426 close(zz) 427 return(poli) 428} 429 430