[Raster-commits] r270 - pkg/raster/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Feb 10 17:28:59 CET 2009
Author: rhijmans
Date: 2009-02-10 17:28:58 +0100 (Tue, 10 Feb 2009)
New Revision: 270
Added:
pkg/raster/R/bboxUnion.R
pkg/raster/R/cellsFromBbox.R
pkg/raster/R/drawPoly.R
pkg/raster/R/setBbox.R
Modified:
pkg/raster/R/Merge.R
pkg/raster/R/bounding.box.R
pkg/raster/R/click.R
pkg/raster/R/crop.R
Log:
Modified: pkg/raster/R/Merge.R
===================================================================
--- pkg/raster/R/Merge.R 2009-02-10 14:58:58 UTC (rev 269)
+++ pkg/raster/R/Merge.R 2009-02-10 16:28:58 UTC (rev 270)
@@ -1,5 +1,4 @@
-# R code for changing rasters (spatial data)
-# Authors: Robert J. Hijmans and Jacob van Etten
+# Authors: Robert J. Hijmans
# International Rice Research Institute
#contact: r.hijmans at gmail.com
# Date : October 2008
@@ -7,39 +6,7 @@
# Licence GPL v3
-bbUnion <- function(objects) {
- if (length(objects) == 1) {
- return(getBbox(objects))
- }
- bb <- getBbox(objects[[1]])
- for (i in 2:length(objects)) {
- bb2 <- getBbox(objects[[i]])
- bb at xmin <- min(xmin(bb), xmin(bb2))
- bb at xmax <- max(xmax(bb), xmax(bb2))
- bb at ymin <- min(ymin(bb), ymin(bb2))
- bb at ymax <- max(ymax(bb), ymax(bb2))
- }
- return(bb)
-}
-bbIntersect <- function(objects) {
- if (length(objects) == 1) {
- return(getBbox(objects))
- }
- bb <- getBbox(objects[[1]])
- for (i in 2:length(objects)) {
- bb2 <- getBbox(objects[[i]])
- bb at xmin <- max(xmin(bb), xmin(bb2))
- bb at xmax <- min(xmax(bb), xmax(bb2))
- bb at ymin <- max(ymin(bb), ymin(bb2))
- bb at ymax <- min(ymax(bb), ymax(bb2))
- }
- validObject(bb)
- return(bb)
-}
-
-
-
if (!isGeneric("merge")) {
setGeneric("merge", function(x, y, ...)
standardGeneric("merge"))
Added: pkg/raster/R/bboxUnion.R
===================================================================
--- pkg/raster/R/bboxUnion.R (rev 0)
+++ pkg/raster/R/bboxUnion.R 2009-02-10 16:28:58 UTC (rev 270)
@@ -0,0 +1,38 @@
+# Authors: Robert J. Hijmans
+# International Rice Research Institute
+# contact: r.hijmans at gmail.com
+# Date : October 2008
+# Version 0.8
+# Licence GPL v3
+
+bbUnion <- function(objects) {
+ if (length(objects) == 1) {
+ return(getBbox(objects))
+ }
+ bb <- getBbox(objects[[1]])
+ for (i in 2:length(objects)) {
+ bb2 <- getBbox(objects[[i]])
+ bb at xmin <- min(xmin(bb), xmin(bb2))
+ bb at xmax <- max(xmax(bb), xmax(bb2))
+ bb at ymin <- min(ymin(bb), ymin(bb2))
+ bb at ymax <- max(ymax(bb), ymax(bb2))
+ }
+ return(bb)
+}
+
+bbIntersect <- function(objects) {
+ if (length(objects) == 1) {
+ return(getBbox(objects))
+ }
+ bb <- getBbox(objects[[1]])
+ for (i in 2:length(objects)) {
+ bb2 <- getBbox(objects[[i]])
+ bb at xmin <- max(xmin(bb), xmin(bb2))
+ bb at xmax <- min(xmax(bb), xmax(bb2))
+ bb at ymin <- max(ymin(bb), ymin(bb2))
+ bb at ymax <- min(ymax(bb), ymax(bb2))
+ }
+ validObject(bb)
+ return(bb)
+}
+
Modified: pkg/raster/R/bounding.box.R
===================================================================
--- pkg/raster/R/bounding.box.R 2009-02-10 14:58:58 UTC (rev 269)
+++ pkg/raster/R/bounding.box.R 2009-02-10 16:28:58 UTC (rev 270)
@@ -8,11 +8,14 @@
-polygonFromBbox <- function(bndbox) {
- bb <- getBbox(bndbox)
- p <- rbind(c(bb at xmin, bb at ymin), c(bb at xmin, bb at ymax), c(bb at xmax, bb at ymax), c(bb at xmax, bb at ymin), c(bb at xmin, bb at ymin) )
- pol <- SpatialPolygons(list(Polygons(list(Polygon(p)), 1)))
- return(pol)
+
+changeBbox <- function(object, xmn=xmin(object), xmx=xmax(object), ymn=ymin(object), ymx = ymax(object), keepres=FALSE) {
+ bb <- newBbox(xmn, xmx, ymn, ymx)
+ if (class(object) == 'BoundingBox') {
+ return(bb)
+ }
+ object <- setBbox(object, bb, keepres=keepres)
+ return(object)
}
@@ -98,95 +101,3 @@
-cellsFromBbox <- function(object, bndbox) {
- bndbox <- getBbox(bndbox)
-# bndbox at xmax - 0.01 * xres(object)
-# bndbox at ymin - 0.01 * yres(object)
- srow <- rowFromY(object, bndbox at ymax)
- if (trunc((ymin(object) - bndbox at ymin)/yres(object)) == (ymin(object) - bndbox at ymin)/yres(object)) {
- bndbox at ymin <- bndbox at ymin + 0.5 * yres(object)
- }
- erow <- rowFromY(object, bndbox at ymin)
- scol <- colFromX(object, bndbox at xmin)
- if (trunc((xmax(object) - bndbox at xmax)/xres(object)) == (xmax(object) - bndbox at xmax)/xres(object)) {
- bndbox at xmax <- bndbox at xmax - 0.5 * xres(object)
- }
- ecol <- colFromX(object, bndbox at xmax)
- cell <- cellFromRowCol(object, srow, scol):cellFromRowCol(object, srow, ecol)
- if (erow > srow) {
- # ouch, vectorize, please
- for (r in (srow+1):erow) {
- cell2 <- cellFromRowCol(object, r, scol):cellFromRowCol(object, r, ecol)
- cell <- c(cell, cell2)
- }
- }
- return(cell)
-}
-
-setBbox <- function(object, bndbox, keepres=FALSE, snap=FALSE) {
- oldbb <- getBbox(object)
- bb <- getBbox(bndbox)
- newobj <- clearValues(object)
-
- if (snap) {
- bb at xmin <- max(bb at xmin, oldbb at xmin)
- bb at xmax <- min(bb at xmax, oldbb at xmax)
- bb at ymin <- max(bb at ymin, oldbb at ymin)
- bb at ymax <- min(bb at ymax, oldbb at ymax)
- col <- colFromX(object, bb at xmin)
- mn <- xFromCol(object, col) - 0.5 * xres(object)
- mx <- xFromCol(object, col) + 0.5 * xres(object)
- if (abs(bb at xmin - mn) > abs(bb at xmin - mx)) { bb at xmin <- mx } else { bb at xmin <- mn }
- col <- colFromX(object, bb at xmax)
- mn <- xFromCol(object, col) - 0.5 * xres(object)
- mx <- xFromCol(object, col) + 0.5 * xres(object)
- if (abs(bb at xmax - mn) > abs(bb at xmax - mx)) { bb at xmax <- mx } else { bb at xmax <- mn }
- row <- rowFromY(object, bb at ymin)
- mn <- yFromRow(object, row) - 0.5 * yres(object)
- mx <- yFromRow(object, row) + 0.5 * yres(object)
- if (abs(bb at ymin - mn) > abs(bb at ymin - mx)) { bb at ymin <- mx } else { bb at ymin <- mn }
- row <- rowFromY(object, bb at ymax)
- mn <- yFromRow(object, row) - 0.5 * yres(object)
- mx <- yFromRow(object, row) + 0.5 * yres(object)
- if (abs(bb at ymax - mn) > abs(bb at ymax - mx)) { bb at ymax <- mx } else { bb at ymax <- mn }
- }
-
- newobj at bbox <- bb
-
- if (keepres) {
- xrs <- xres(object)
- yrs <- yres(object)
- nc <- as.integer(round( (xmax(newobj) - xmin(newobj)) / xrs ))
- if (nc < 1) { stop( "xmin and xmax are less than one cell apart" )
- } else { newobj at ncols <- nc }
- nr <- as.integer(round( (ymax(newobj) - ymin(newobj)) / xrs ) )
- if (nr < 1) { stop( "ymin and ymax are less than one cell apart" )
- } else { newobj at nrows <- nr }
- newobj at bbox@xmax <- newobj at bbox@xmin + ncol(newobj) * xrs
- newobj at bbox@ymax <- newobj at bbox@ymin + nrow(newobj) * yrs
-
- if (dataContent(object) == 'all') {
- indices <- cellsFromBbox(object, bb)
- newobj <- setValues(newobj, values(object)[indices])
- }
- } else if (class(object) != "BasicRaster") {
- if (ncol(object)==ncol(newobj) & nrow(object)==nrow(newobj)) {
- if (dataContent(object) == 'all') {
- newobj <- setValues(newobj, values(object))
- }
- }
- }
- return(newobj)
-}
-
-
-
-changeBbox <- function(object, xmn=xmin(object), xmx=xmax(object), ymn=ymin(object), ymx = ymax(object), keepres=FALSE) {
- bb <- newBbox(xmn, xmx, ymn, ymx)
- if (class(object) == 'BoundingBox') {
- return(bb)
- }
- object <- setBbox(object, bb, keepres=keepres)
- return(object)
-}
-
Added: pkg/raster/R/cellsFromBbox.R
===================================================================
--- pkg/raster/R/cellsFromBbox.R (rev 0)
+++ pkg/raster/R/cellsFromBbox.R 2009-02-10 16:28:58 UTC (rev 270)
@@ -0,0 +1,35 @@
+# R function for the raster package
+# Author: Robert J. Hijmans
+# International Rice Research Institute. Philippines
+# contact: r.hijmans at gmail.com
+# Date : January 2009
+# Version 0.8
+# Licence GPL v3
+
+
+
+cellsFromBbox <- function(object, bndbox) {
+ bndbox <- getBbox(bndbox)
+# bndbox at xmax - 0.01 * xres(object)
+# bndbox at ymin - 0.01 * yres(object)
+ srow <- rowFromY(object, bndbox at ymax)
+ if (trunc((ymin(object) - bndbox at ymin)/yres(object)) == (ymin(object) - bndbox at ymin)/yres(object)) {
+ bndbox at ymin <- bndbox at ymin + 0.5 * yres(object)
+ }
+ erow <- rowFromY(object, bndbox at ymin)
+ scol <- colFromX(object, bndbox at xmin)
+ if (trunc((xmax(object) - bndbox at xmax)/xres(object)) == (xmax(object) - bndbox at xmax)/xres(object)) {
+ bndbox at xmax <- bndbox at xmax - 0.5 * xres(object)
+ }
+ ecol <- colFromX(object, bndbox at xmax)
+ cell <- cellFromRowCol(object, srow, scol):cellFromRowCol(object, srow, ecol)
+ if (erow > srow) {
+ # ouch, vectorize, please
+ for (r in (srow+1):erow) {
+ cell2 <- cellFromRowCol(object, r, scol):cellFromRowCol(object, r, ecol)
+ cell <- c(cell, cell2)
+ }
+ }
+ return(cell)
+}
+
Modified: pkg/raster/R/click.R
===================================================================
--- pkg/raster/R/click.R 2009-02-10 14:58:58 UTC (rev 269)
+++ pkg/raster/R/click.R 2009-02-10 16:28:58 UTC (rev 270)
@@ -7,6 +7,7 @@
# Licence GPL v3
+
clickBbox <- function(show=TRUE, col="red") {
loc <- locator(n=2, type="p")
bb <- newBbox(min(loc$x), max(loc$x), min(loc$y), max(loc$y))
@@ -20,9 +21,7 @@
click <- function(object, n=1, xy=FALSE, type="n", ...) {
loc <- locator(n, type, ...)
- x <- loc$x
- y <- loc$y
- xyCoords <- cbind(x, y)
+ xyCoords <- cbind(loc$x, loc$y)
if (missing(object)) {
return(cbind(xyCoords))
}
@@ -46,4 +45,3 @@
return(value)
}
}
-
Modified: pkg/raster/R/crop.R
===================================================================
--- pkg/raster/R/crop.R 2009-02-10 14:58:58 UTC (rev 269)
+++ pkg/raster/R/crop.R 2009-02-10 16:28:58 UTC (rev 270)
@@ -16,6 +16,7 @@
crop <- function(raster, bndbox, filename="", overwrite=FALSE) {
# we could also allow the raster to expand but for now let's not and first make a separate expand function
bb <- bbIntersect(c(raster, bndbox))
+ bb <- snapBbox(bb, raster)
outraster <- setRaster(raster, filename)
outraster <- setBbox(outraster, bb, keepres=T)
Added: pkg/raster/R/drawPoly.R
===================================================================
--- pkg/raster/R/drawPoly.R (rev 0)
+++ pkg/raster/R/drawPoly.R 2009-02-10 16:28:58 UTC (rev 270)
@@ -0,0 +1,31 @@
+# R function for the raster package
+# Author: Robert J. Hijmans
+# International Rice Research Institute. Philippines
+# contact: r.hijmans at gmail.com
+# Date : January 2009
+# Version 0.8
+# Licence GPL v3
+
+
+drawPoly <- function(col='red') {
+ xy <- locator(n=10000, type="l", col=col)
+ xy <- cbind(xy$x, xy$y)
+ xy <- rbind(xy, xy[1,])
+ lines(xy[(length(xy[,1])-1):length(xy[,1]),], col=col)
+ return( SpatialPolygons(list(Polygons(list(Polygon(xy)), 1))) )
+}
+
+
+drawLine <- function(col='red') {
+ xy <- locator(n=10000, type="l", col=col)
+ xy <- cbind(xy$x, xy$y)
+ return( SpatialLines(list(Lines(list(Line(xy)), "1"))) )
+}
+
+
+polygonFromBbox <- function(bndbox) {
+ bb <- getBbox(bndbox)
+ p <- rbind(c(bb at xmin, bb at ymin), c(bb at xmin, bb at ymax), c(bb at xmax, bb at ymax), c(bb at xmax, bb at ymin), c(bb at xmin, bb at ymin) )
+ return( SpatialPolygons(list(Polygons(list(Polygon(p)), 1))) )
+}
+
Added: pkg/raster/R/setBbox.R
===================================================================
--- pkg/raster/R/setBbox.R (rev 0)
+++ pkg/raster/R/setBbox.R 2009-02-10 16:28:58 UTC (rev 270)
@@ -0,0 +1,73 @@
+# R function for the raster package
+# Author: Robert J. Hijmans
+# International Rice Research Institute. Philippines
+# contact: r.hijmans at gmail.com
+# Date : January 2009
+# Version 0.8
+# Licence GPL v3
+
+
+
+snapBbox <- function(bb, object) {
+ oldbb <- getBbox(object)
+ bb at xmin <- max(bb at xmin, oldbb at xmin)
+ bb at xmax <- min(bb at xmax, oldbb at xmax)
+ bb at ymin <- max(bb at ymin, oldbb at ymin)
+ bb at ymax <- min(bb at ymax, oldbb at ymax)
+ col <- colFromX(object, bb at xmin)
+ mn <- xFromCol(object, col) - 0.5 * xres(object)
+ mx <- xFromCol(object, col) + 0.5 * xres(object)
+ if (abs(bb at xmin - mn) > abs(bb at xmin - mx)) { bb at xmin <- mx } else { bb at xmin <- mn }
+ col <- colFromX(object, bb at xmax)
+ mn <- xFromCol(object, col) - 0.5 * xres(object)
+ mx <- xFromCol(object, col) + 0.5 * xres(object)
+ if (abs(bb at xmax - mn) > abs(bb at xmax - mx)) { bb at xmax <- mx } else { bb at xmax <- mn }
+ row <- rowFromY(object, bb at ymin)
+ mn <- yFromRow(object, row) - 0.5 * yres(object)
+ mx <- yFromRow(object, row) + 0.5 * yres(object)
+ if (abs(bb at ymin - mn) > abs(bb at ymin - mx)) { bb at ymin <- mx } else { bb at ymin <- mn }
+ row <- rowFromY(object, bb at ymax)
+ mn <- yFromRow(object, row) - 0.5 * yres(object)
+ mx <- yFromRow(object, row) + 0.5 * yres(object)
+ if (abs(bb at ymax - mn) > abs(bb at ymax - mx)) { bb at ymax <- mx } else { bb at ymax <- mn }
+ return(bb)
+}
+
+
+
+setBbox <- function(object, bndbox, keepres=FALSE, snap=FALSE) {
+ oldbb <- getBbox(object)
+ bb <- getBbox(bndbox)
+ newobj <- clearValues(object)
+
+ if (snap) {
+ bb <- snapBbox(bb, newobj)
+ }
+
+ newobj at bbox <- bb
+
+ if (keepres) {
+ xrs <- xres(object)
+ yrs <- yres(object)
+ nc <- as.integer(round( (xmax(newobj) - xmin(newobj)) / xrs ))
+ if (nc < 1) { stop( "xmin and xmax are less than one cell apart" )
+ } else { newobj at ncols <- nc }
+ nr <- as.integer(round( (ymax(newobj) - ymin(newobj)) / xrs ) )
+ if (nr < 1) { stop( "ymin and ymax are less than one cell apart" )
+ } else { newobj at nrows <- nr }
+ newobj at bbox@xmax <- newobj at bbox@xmin + ncol(newobj) * xrs
+ newobj at bbox@ymax <- newobj at bbox@ymin + nrow(newobj) * yrs
+
+ if (dataContent(object) == 'all') {
+ indices <- cellsFromBbox(object, bb)
+ newobj <- setValues(newobj, values(object)[indices])
+ }
+ } else if (class(object) != "BasicRaster") {
+ if (ncol(object)==ncol(newobj) & nrow(object)==nrow(newobj)) {
+ if (dataContent(object) == 'all') {
+ newobj <- setValues(newobj, values(object))
+ }
+ }
+ }
+ return(newobj)
+}
More information about the Raster-commits
mailing list