-
Notifications
You must be signed in to change notification settings - Fork 0
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
add elide from maptools, see pdil/usmap#57
- Loading branch information
Showing
4 changed files
with
308 additions
and
1 deletion.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,218 @@ | ||
## 11/21/07 dhm | ||
## version where shift works for lines and polygons | ||
## adding option to rotate | ||
|
||
if (!isGeneric("elide")) { | ||
setGeneric("elide", function(obj, ...) { | ||
standardGeneric("elide") | ||
}) | ||
} | ||
|
||
elide.points <- function(obj, bb=NULL, shift=c(0, 0), reflect=c(FALSE, FALSE), | ||
scale=NULL, flip=FALSE, rotate=0, center=NULL, unitsq=FALSE) { | ||
if (length(shift) != 2L) | ||
stop("Two coordinate shift in input units required") | ||
if (!is.numeric(shift)) stop("shift not numeric") | ||
if (!is.logical(reflect)) stop("reflect must be logical") | ||
if (length(reflect) != 2L) stop("Two coordinate reflect required") | ||
if (!is.logical(flip)) stop("flip must be logical") | ||
if (!is.numeric(rotate)) stop("rotate not numeric") | ||
if (!is.null(center) && length(center) != 2L) | ||
stop("center must be numeric of length two") | ||
if (!is.logical(unitsq)) stop("unitsq must be logical") | ||
crds <- coordinates(obj) | ||
if (is.null(bb)) bb <- bbox(obj) | ||
if (rotate != 0 && is.null(center)) center <- bb[,1] | ||
if (rotate != 0) crds <- rotateCoords(crds, rotate, center) | ||
if (flip) { | ||
y <- crds[,1] + shift[1] | ||
x <- crds[,2] + shift[2] | ||
yr <- bb[1,] + shift[1] | ||
xr <- bb[2,] + shift[2] | ||
} else { | ||
x <- crds[,1] + shift[1] | ||
y <- crds[,2] + shift[2] | ||
xr <- bb[1,] + shift[1] | ||
yr <- bb[2,] + shift[2] | ||
} | ||
bb <- NULL | ||
if (!is.null(scale) && is.logical(scale) && scale && unitsq) { | ||
bb <- rbind(c(0,1), c(0,1)) | ||
colnames(bb) <- c("min", "max") | ||
} | ||
scale <- scaleCoords(scale=scale, xr=xr, yr=yr) | ||
crds <- elideCoords(x=x, y=y, xr=xr, yr=yr, reflect=reflect, scale=scale) | ||
res <- SpatialPoints(crds, bbox=bb) | ||
res | ||
} | ||
|
||
elide.pointsdf <- function(obj, bb=NULL, shift=c(0, 0), | ||
reflect=c(FALSE, FALSE), scale=NULL, flip=FALSE, rotate=0, center=NULL) { | ||
res <- elide(as(obj, "SpatialPoints"), bb=bb, shift=shift, | ||
reflect=reflect, scale=scale, flip=flip, rotate=rotate, center=center) | ||
# df <- as(obj, "data.frame")[,-c(1,2)] | ||
# df <- as(obj, "data.frame") | ||
df <- slot(obj, "data") | ||
res <- SpatialPointsDataFrame(res, data=df) | ||
res | ||
} | ||
|
||
setMethod("elide", signature(obj="SpatialPoints"), elide.points) | ||
|
||
setMethod("elide", signature(obj="SpatialPointsDataFrame"), elide.pointsdf) | ||
|
||
## rotate angle degrees clockwise around center | ||
rotateCoords <- function(crds, angle=0, center= c(min(crds[,1]),min(crds[,2]))) { | ||
co <- cos(-angle*pi/180) | ||
si <- sin(-angle*pi/180) | ||
adj <- matrix(rep(center,nrow(crds)),ncol=2,byrow=TRUE) | ||
crds <- crds-adj | ||
cbind(co * crds[,1] - si * crds[,2], | ||
si * crds[,1] + co * crds[,2]) + adj | ||
} | ||
|
||
scaleCoords <- function(scale, xr, yr) { | ||
if (!is.null(scale)) { | ||
if (is.logical(scale) && scale) scale <- 1 | ||
else if (!is.numeric(scale)) stop("scale neither TRUE nor numeric") | ||
dx <- abs(diff(xr)) | ||
dy <- abs(diff(yr)) | ||
md <- max(dx, dy) | ||
scale <- scale * (1/md) | ||
} else scale <- 1 | ||
scale | ||
} | ||
|
||
elideCoords <- function(x, y, xr, yr, reflect, scale, rotate, center) { | ||
if (reflect[1]) { | ||
x <- xr[2] - x + xr[1] | ||
} | ||
if (reflect[2]) { | ||
y <- yr[2] - y + yr[1] | ||
} | ||
if (!isTRUE(all.equal(scale, 1))) { | ||
x <- (x - xr[1]) * scale | ||
y <- (y - yr[1]) * scale | ||
} | ||
crds <- cbind(x, y) | ||
crds | ||
} | ||
|
||
elide.lines <- function(obj, bb=NULL, shift=c(0, 0), reflect=c(FALSE, FALSE), | ||
scale=NULL, inverse=FALSE, flip=FALSE, rotate=0, center=NULL) { | ||
if (length(shift) != 2L) | ||
stop("Two coordinate shift in input units required") | ||
if (!is.numeric(shift)) stop("shift not numeric") | ||
if (!is.logical(reflect)) stop("reflect must be logical") | ||
if (length(reflect) != 2L) stop("Two coordinate reflect required") | ||
if (!is.logical(flip)) stop("flip must be logical") | ||
if (!is.numeric(rotate)) stop("rotate not numeric") | ||
if (!is.null(center) && length(center) != 2L) | ||
stop("center must be numeric of length two") | ||
if (is.null(bb)) bb <- bbox(obj) | ||
if (rotate != 0 && is.null(center)) center <- bb[,1] | ||
if (flip) { | ||
yr <- bb[1,] + shift[1] | ||
xr <- bb[2,] + shift[2] | ||
} else { | ||
xr <- bb[1,] + shift[1] | ||
yr <- bb[2,] + shift[2] | ||
} | ||
scale <- scaleCoords(scale=scale, xr=xr, yr=yr) | ||
lns <- slot(obj, "lines") | ||
new_lns <- lapply(lns, function(x) { | ||
Lns <- slot(x, "Lines") | ||
new_Lns <- lapply(Lns, function(y) { | ||
crds <- slot(y, "coords") | ||
## rotate first, then elide (shift) [side effects if bb, scale or others supplied] | ||
if (rotate != 0) crds <- rotateCoords(crds, rotate, center) | ||
if (flip) { | ||
yc <- crds[,1] + shift[1] | ||
xc <- crds[,2] + shift[2] | ||
} else { | ||
xc <- crds[,1] + shift[1] | ||
yc <- crds[,2] + shift[2] | ||
} | ||
new_crds <- elideCoords(x=xc, y=yc, xr=xr, yr=yr, | ||
reflect=reflect, scale=scale) | ||
## if want to elide first, then rotate: | ||
## new_crds <- rotcrds(new_crds,rotate,center) | ||
Line(new_crds)}) | ||
Lines(new_Lns, ID=slot(x, "ID"))}) | ||
res <- SpatialLines(new_lns) | ||
res | ||
} | ||
|
||
elide.linesdf <- function(obj, bb=NULL, shift=c(0, 0), reflect=c(FALSE, FALSE), | ||
scale=NULL, inverse=FALSE, flip=FALSE, rotate=0, center=NULL) { | ||
res <- elide(as(obj, "SpatialLines"), bb=bb, shift=shift, | ||
reflect=reflect, scale=scale, flip=flip, rotate=rotate, center=center) | ||
df <- as(obj, "data.frame") | ||
res <- SpatialLinesDataFrame(res, data=df) | ||
res | ||
} | ||
|
||
setMethod("elide", signature(obj="SpatialLines"), elide.lines) | ||
|
||
setMethod("elide", signature(obj="SpatialLinesDataFrame"), elide.linesdf) | ||
|
||
elide.polygons <- function(obj, bb=NULL, shift=c(0, 0), reflect=c(FALSE, FALSE), | ||
scale=NULL, inverse=FALSE, flip=FALSE, rotate=0, center=NULL) { | ||
if (length(shift) != 2L) | ||
stop("Two coordinate shift in input units required") | ||
if (!is.numeric(shift)) stop("shift not numeric") | ||
if (!is.logical(reflect)) stop("reflect must be logical") | ||
if (length(reflect) != 2L) stop("Two coordinate reflect required") | ||
if (!is.logical(flip)) stop("flip must be logical") | ||
if (!is.numeric(rotate)) stop("rotate not numeric") | ||
if (!is.null(center) && length(center) != 2L) | ||
stop("center must be numeric of length two") | ||
if (is.null(bb)) bb <- bbox(obj) | ||
if (rotate != 0 && is.null(center)) center <- bb[,1] | ||
if (flip) { | ||
yr <- bb[1,] + shift[1] | ||
xr <- bb[2,] + shift[2] | ||
} else { | ||
xr <- bb[1,] + shift[1] | ||
yr <- bb[2,] + shift[2] | ||
} | ||
scale <- scaleCoords(scale=scale, xr=xr, yr=yr) | ||
pls <- slot(obj, "polygons") | ||
new_pls <- lapply(pls, function(x) { | ||
Pls <- slot(x, "Polygons") | ||
new_Pls <- lapply(Pls, function(y) { | ||
crds <- slot(y, "coords") | ||
if (rotate != 0) crds <- rotateCoords(crds,rotate,center) | ||
if (flip) { | ||
yc <- crds[,1] + shift[1] | ||
xc <- crds[,2] + shift[2] | ||
} else { | ||
xc <- crds[,1] + shift[1] | ||
yc <- crds[,2] + shift[2] | ||
} | ||
new_crds <- elideCoords(x=xc, y=yc, xr=xr, yr=yr, | ||
reflect=reflect, scale=scale) | ||
Polygon(new_crds)}) | ||
pres <- Polygons(new_Pls, ID=slot(x, "ID")) | ||
if (!is.null(comment(x))) comment(pres) <- comment(x) | ||
pres}) | ||
res <- SpatialPolygons(new_pls) | ||
res | ||
} | ||
|
||
elide.polygonsdf <- function(obj, bb=NULL, shift=c(0, 0), | ||
reflect=c(FALSE, FALSE), scale=NULL, inverse=FALSE, flip=FALSE, | ||
rotate=0, center=NULL) { | ||
res <- elide(as(obj, "SpatialPolygons"), bb=bb, shift=shift, | ||
reflect=reflect, scale=scale, flip=flip, rotate=rotate, center=center) | ||
df <- as(obj, "data.frame") | ||
res <- SpatialPolygonsDataFrame(res, data=df) | ||
res | ||
} | ||
|
||
setMethod("elide", signature(obj="SpatialPolygons"), elide.polygons) | ||
|
||
setMethod("elide", signature(obj="SpatialPolygonsDataFrame"), elide.polygonsdf) | ||
|
||
|
||
|
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,85 @@ | ||
\name{elide-methods} | ||
\docType{methods} | ||
\alias{elide-methods} | ||
\alias{elide,SpatialPoints-method} | ||
\alias{elide,SpatialPointsDataFrame-method} | ||
\alias{elide,SpatialLines-method} | ||
\alias{elide,SpatialLinesDataFrame-method} | ||
\alias{elide,SpatialPolygons-method} | ||
\alias{elide,SpatialPolygonsDataFrame-method} | ||
\alias{elide} | ||
\title{Methods for Function elide in Package `maptools'} | ||
\description{ | ||
Methods for function \code{elide} to translate and disguise coordinate placing in the real world. | ||
} | ||
\section{Methods}{ | ||
\describe{ | ||
\item{obj = "SpatialPoints"}{elides object} | ||
\item{obj = "SpatialPointsDataFrame"}{elides object} | ||
\item{obj = "SpatialLines"}{elides object} | ||
\item{obj = "SpatialLinesDataFrame"}{elides object} | ||
\item{obj = "SpatialPolygons"}{elides object} | ||
\item{obj = "SpatialPolygonsDataFrame"}{elides object} | ||
}} | ||
\usage{ | ||
elide(obj, ...) | ||
% (obj, bb=NULL, shift=c(0, 0), reflect=c(FALSE, FALSE), scale=NULL, flip=FALSE) | ||
} | ||
\arguments{ | ||
\item{obj}{object to be elided} | ||
\item{...}{other arguments: | ||
\describe{ | ||
\item{bb}{if NULL, uses bounding box of object, otherwise the given bounding box} | ||
\item{shift}{values to shift the coordinates of the input object; this is made ineffective by the scale argument} | ||
\item{reflect}{reverse coordinate axes} | ||
\item{scale}{if NULL, coordinates not scaled; if TRUE, the longer dimension is scaled to lie within [0,1] and aspect maintained; if a scalar, the output range of [0,1] is multiplied by scale} | ||
\item{flip}{translate coordinates on the main diagonal} | ||
\item{rotate}{default 0, rotate angle degrees clockwise around center} | ||
\item{center}{default NULL, if not NULL, the rotation center, numeric of length two} | ||
\item{unitsq}{logical, default FALSE, if TRUE and scale TRUE, impose unit square bounding box (currently only points)} | ||
}} | ||
} | ||
\value{ | ||
The methods return objects of the input class object with elided coordinates; the coordinate reference system is not set. Note that if the input coordinates or centroids are in the data slot data.frame of the input object, they should be removed before the use of these methods, otherwise they will betray the input positions. | ||
} | ||
\note{Rotation code kindly contributed by Don MacQueen} | ||
\examples{ | ||
data(meuse) | ||
coordinates(meuse) <- c("x", "y") | ||
proj4string(meuse) <- CRS("+init=epsg:28992") | ||
data(meuse.riv) | ||
river_polygon <- Polygons(list(Polygon(meuse.riv)), ID="meuse") | ||
rivers <- SpatialPolygons(list(river_polygon)) | ||
proj4string(rivers) <- CRS("+init=epsg:28992") | ||
rivers1 <- elide(rivers, reflect=c(TRUE, TRUE), scale=TRUE) | ||
meuse1 <- elide(meuse, bb=bbox(rivers), reflect=c(TRUE, TRUE), scale=TRUE) | ||
opar <- par(mfrow=c(1,2)) | ||
plot(rivers, axes=TRUE) | ||
plot(meuse, add=TRUE) | ||
plot(rivers1, axes=TRUE) | ||
plot(meuse1, add=TRUE) | ||
par(opar) | ||
meuse1 <- elide(meuse, shift=c(10000, -10000)) | ||
bbox(meuse) | ||
bbox(meuse1) | ||
rivers1 <- elide(rivers, shift=c(10000, -10000)) | ||
bbox(rivers) | ||
bbox(rivers1) | ||
meuse1 <- elide(meuse, rotate=-30, center=apply(bbox(meuse), 1, mean)) | ||
bbox(meuse) | ||
bbox(meuse1) | ||
plot(meuse1, axes=TRUE) | ||
} | ||
\keyword{methods} | ||
\keyword{spatial} |