1# transform a SpatialPolygons[DataFrame] into a list of polygons for map()
2SpatialPolygons2map <- function(database, namefield=NULL){
3  if(!inherits(database,"SpatialPolygons")) stop("database must be a SpatialPolygons[DataFrame] object.")
4
5  region.names <- NULL
6  if (inherits(database,"SpatialPolygonsDataFrame") & !is.null(namefield) ) {
7    namcol <- lapply(namefield, function(x) which(tolower(names(database)) == tolower(x)))
8    if (any(lapply(namcol, length) != 1)) {
9      zz <- which(lapply(namcol, length) != 1)
10      warning(paste0("database does not (uniquely) contain the field '",namefield[zz],"'."))
11    } else {
12      zz <- as.data.frame(lapply(database@data[unlist(namcol)], as.character), stringsAsFactors=FALSE)
13      region.names <- vapply(1:dim(zz)[1], function(x) paste(zz[x,],collapse=":"),FUN.VALUE="a")
14    }
15  }
16  if (is.null(region.names)) region.names <- unlist(lapply(database@polygons, function(x) x@ID))
17
18  nregions <- length(region.names)
19
20  # count the number of polygons in every "region"
21  ngon <- vapply(1:nregions,
22                 FUN=function(i) length(database@polygons[[i]]@Polygons),
23                 FUN.VALUE=1)
24  # if a region contains several polygons, an index is added to the name: "region:n"
25  gon.names <- unlist(lapply(1:dim(database)[1], function(i) {
26             if (ngon[i]==1) region.names[i]
27             else paste(region.names[i],1:ngon[i],sep=":")}))
28
29  # extract all polygon data to a list
30  allpoly <- lapply(database@polygons,
31                    function(x) lapply(x@Polygons, function(y) y@coords))
32## allpoly is a list of lists of Nx2 matrices (not data frames)
33## first flatten the list, then add NA to every row, then rbind and remove one NA
34#  p1 <- do.call(c, allpoly)
35#  p2 <- lapply(p1, function(x) rbind(c(NA,NA),x))
36#  p3 <- do.call(rbind,p2)[-1,]
37  mymap <- do.call(rbind, lapply(do.call(c,allpoly),
38                                  function(x) rbind(c(NA,NA),x)))[-1,]
39  result <- list(x = mymap[,1], y = mymap[,2], names = gon.names,
40       range = c(range(mymap[,1], na.rm = TRUE),range(mymap[,2], na.rm = TRUE)))
41  class(result) <- "map"
42  result
43}
44
45# transform a SpatialLines[DataFrame] into a list of polylines for map()
46SpatialLines2map <- function(database, namefield=NULL){
47  if(!inherits(database,"SpatialLines")) stop("database must be a SpatialLines[DataFrame] object.")
48
49  line.names <- NULL
50  if (inherits(database,"SpatialLinesDataFrame") & !is.null(namefield) ) {
51    namcol <- lapply(namefield, function(x) which(tolower(names(database)) == tolower(x)))
52    if (any(lapply(namcol, length) != 1)) {
53      zz <- which(lapply(namcol, length) != 1)
54      warning(paste0("database does not (uniquely) contain the field '",namefield[zz],"'."))
55    } else {
56      zz <- as.data.frame(lapply(database@data[unlist(namcol)], as.character), stringsAsFactors=FALSE)
57      line.names <- vapply(1:dim(zz)[1], function(x) paste(zz[x,],collapse=":"),FUN.VALUE="a")
58    }
59  }
60  if (is.null(line.names)) line.names <- unlist(lapply(database@lines, function(x) x@ID))
61
62  nlines <- length(line.names)
63
64  # count the number of line segments in every "line"
65  nseg <- vapply(1:nlines,
66                 FUN=function(i) length(database@lines[[i]]@Lines),
67                 FUN.VALUE=1)
68  # if a line contains several sub-lines (segments), an index is added to the name: "line:n"
69  line.names <- unlist(lapply(1:dim(database)[1], function(i) {
70             if (nseg[i]==1) line.names[i]
71             else paste(line.names[i],1:nseg[i],sep=":")}))
72
73  # extract all polyline data to a list
74  allpoly <- lapply(database@lines,
75                    function(x) lapply(x@Lines, function(y) y@coords))
76## allpoly is a list of lists of Nx2 matrices (not data frames)
77## first flatten the list, then add NA to every row, then rbind and remove one NA
78#  p1 <- do.call(c, allpoly)
79#  p2 <- lapply(p1, function(x) rbind(c(NA,NA),x))
80#  p3 <- do.call(rbind,p2)[-1,]
81  mymap <- do.call(rbind, lapply(do.call(c,allpoly),
82                                  function(x) rbind(c(NA,NA),x)))[-1,]
83  result <- list(x = mymap[,1], y = mymap[,2], names = line.names,
84       range = c(range(mymap[,1], na.rm = TRUE),range(mymap[,2], na.rm = TRUE)))
85  class(result) <- "map"
86  result
87}
88
89