[Raster-commits] r421 - in pkg/raster: R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Apr 20 13:28:53 CEST 2009
Author: rhijmans
Date: 2009-04-20 13:28:52 +0200 (Mon, 20 Apr 2009)
New Revision: 421
Added:
pkg/raster/R/NAvalue.R
pkg/raster/R/addHistory.R
pkg/raster/R/aggold.R
pkg/raster/R/ext.R
pkg/raster/R/roundCoords.R
pkg/raster/R/trim.R
pkg/raster/man/newCRS.Rd
pkg/raster/man/roundExtent.Rd
Removed:
pkg/raster/R/set.R
pkg/raster/man/utils.Rd
Modified:
pkg/raster/R/aggregate.R
pkg/raster/R/filenames.R
pkg/raster/R/polygonToRaster.R
Log:
Added: pkg/raster/R/NAvalue.R
===================================================================
--- pkg/raster/R/NAvalue.R (rev 0)
+++ pkg/raster/R/NAvalue.R 2009-04-20 11:28:52 UTC (rev 421)
@@ -0,0 +1,16 @@
+# Author: Robert J. Hijmans, r.hijmans at gmail.com
+# International Rice Research Institute
+# Date : June 2008
+# Version 0.8
+# Licence GPL v3
+
+
+
+'NAvalue<-' <- function(x, value) {
+ x at file@nodatavalue <- value
+ return(x)
+}
+
+'NAvalue' <- function(x, value) {
+ return(x at file@nodatavalue)
+}
Added: pkg/raster/R/addHistory.R
===================================================================
--- pkg/raster/R/addHistory.R (rev 0)
+++ pkg/raster/R/addHistory.R 2009-04-20 11:28:52 UTC (rev 421)
@@ -0,0 +1,12 @@
+# Author: Robert J. Hijmans, r.hijmans at gmail.com
+# International Rice Research Institute
+# Date : June 2008
+# Version 0.8
+# Licence GPL v3
+
+.addHistory <- function(raster, message) {
+ if (is.character(message) & message != "") {
+ raster at history <- c(message, raster at history)
+ }
+}
+
Added: pkg/raster/R/aggold.R
===================================================================
--- pkg/raster/R/aggold.R (rev 0)
+++ pkg/raster/R/aggold.R 2009-04-20 11:28:52 UTC (rev 421)
@@ -0,0 +1,122 @@
+# Authors: Robert J. Hijmans and Jacob van Etten
+# International Rice Research Institute
+#contact: r.hijmans at gmail.com
+# Date : October 2008
+# Version 0.8
+# Licence GPL v3
+
+
+.aggregate_old <- function(x, fact=2, fun=mean, expand=TRUE, na.rm=TRUE, filename=NULL, filetype='raster', datatype='FLT4S', overwrite=FALSE, track=-1) {
+
+ if (is.null(filename)) { filename <- "" }
+
+ if (length(fact)==1) {
+ fact <- as.integer(round(fact))
+ if (fact < 2) { stop('fact should be > 1') }
+ xfact <- yfact <- fact
+ } else if (length(fact)==2) {
+ xfact <- as.integer(round(fact[[1]]))
+ yfact <- as.integer(round(fact[[2]]))
+ if (xfact < 2) { stop('fact[[1]] should be > 1') }
+ if (yfact < 2) { stop('fact[[2]] should be > 1') }
+ } else {
+ stop('length(fact) should be 1 or 2')
+ }
+ if (xfact > ncol(x)) {warning('aggregation factor is larger than the number of columns') }
+ if (yfact > nrow(x)) {warning('aggregation factor is larger than the number of rows')}
+
+ if (expand) {
+ rsteps <- as.integer(ceiling(nrow(x)/yfact))
+ csteps <- as.integer(ceiling(ncol(x)/xfact))
+ } else {
+ rsteps <- as.integer(floor(nrow(x)/yfact))
+ csteps <- as.integer(floor(ncol(x)/xfact))
+ }
+
+ ymn <- ymax(x) - rsteps * yfact * yres(x)
+ xmx <- xmin(x) + csteps * xfact * xres(x)
+
+ outRaster <- raster(x, filename)
+ dataType(outRaster) <- datatype
+ bndbox <- newBbox(xmin(x), xmx, ymn, ymax(x))
+ outRaster <- setExtent(outRaster, bndbox, keepres=FALSE)
+ outRaster <- setRowCol(outRaster, nrows=rsteps, ncols=csteps)
+
+
+ if (na.rm) {
+ # this avoid warning messages
+ narmfun <- function(x) {
+ x <- na.omit(x)
+ if (length(x) == 0) {
+ return(NA)
+ } else {
+ return( fun(x) )
+ }
+ }
+ }
+
+ if (dataContent(x) == 'all') {
+ cols <- rep(rep(1:csteps, each=xfact)[1:ncol(x)], times=nrow(x))
+ rows <- rep(1:rsteps, each=ncol(x) * yfact)[1:ncell(x)]
+ cells <- cellFromRowCol(x, rows, cols)
+
+ if (na.rm) {
+ outRaster <- setValues(outRaster, as.vector( tapply(values(x), cells, narmfun )))
+ } else {
+ outRaster <- setValues(outRaster, as.vector(tapply(values(x), cells, fun)))
+ }
+ if (outRaster at file@name != "") {
+ outRaster <- writeRaster(outRaster, overwrite=overwrite, filetype=filetype)
+ }
+
+ } else if ( dataSource(x) == 'disk') {
+ if (!canProcessInMemory(x, 2) && filename == '') {
+ filename <- tempfile()
+ filename(outraster) <- filename
+ if (options('verbose')[[1]]) { cat('writing raster to:', filename(raster)) }
+ }
+ starttime <- proc.time()
+
+ cols <- rep(rep(1:csteps,each=xfact)[1:ncol(x)], times=yfact)
+ rows <- rep(1, each=(ncol(x) * yfact))
+ v <- vector(length=0)
+
+ theserows <- startrow * rows
+ cells <- cellFromRowCol(x, theserows, cols)
+ nrows = yfact
+
+ for (r in 1:rsteps) {
+ startrow <- 1 + (r - 1) * yfact
+ if ( r==rsteps) {
+ endrow <- min(nrow(x), startrow + yfact - 1)
+ nrows <- endrow - startrow + 1
+ theserows <- (startrow * rows)[1:(ncol(x)*nrows)]
+ cols <- cols[1:(ncol(x)*nrows)]
+ cells <- cellFromRowCol(x, theserows, cols)
+ }
+ x <- readRows(x, startrow = startrow, nrows = nrows)
+
+ if (na.rm) {
+ vals <- tapply(values(x), cells, narmfun )
+ } else {
+ vals <- tapply(values(x), cells, fun)
+ }
+ vals <- as.vector(vals)
+
+ if (outRaster at file@name == "") {
+ v <- c(v, vals)
+ } else {
+ outRaster <- setValues(outRaster, vals, r)
+ outRaster <- writeRaster(outRaster, overwrite=overwrite, filetype=filetype)
+ }
+
+ if (r %in% track) { .showTrack(r, outRaster at nrows, track, starttime) }
+
+ }
+ if (outRaster at file@name == "") {
+ outRaster <- setValues(outRaster, v)
+ }
+ }
+ return(outRaster)
+}
+
Modified: pkg/raster/R/aggregate.R
===================================================================
--- pkg/raster/R/aggregate.R 2009-04-20 02:40:21 UTC (rev 420)
+++ pkg/raster/R/aggregate.R 2009-04-20 11:28:52 UTC (rev 421)
@@ -8,8 +8,10 @@
setMethod('aggregate', signature(x='RasterLayer'),
-function(x, fact=2, fun=mean, expand=TRUE, na.rm=TRUE, filename=NULL, filetype='raster', datatype='FLT4S', overwrite=FALSE, track=-1) {
+function(x, fact=2, fun=mean, expand=TRUE, na.rm=TRUE, filename=NULL, filetype='raster', datatype='FLT4S', overwrite=FALSE, track=-1, old=FALSE) {
+ if (old) { return(.aggregate_old(x,fact, fun, expand, na.rm, filetype, datatype, overwrite, track)) }
+
if (is.null(filename)) { filename <- "" }
if (length(fact)==1) {
@@ -84,6 +86,8 @@
}
starttime <- proc.time()
v <- vector(length=0)
+ newcols <- ncol(outRaster)
+ vals <- vector(length=newcols)
nrows = yfact
for (r in 1:rsteps) {
@@ -107,15 +111,21 @@
}
a <- matrix(as.vector(a), nrow=ncells)
if (na.rm) {
- vals <- apply(a, 2, narmfun )
+ for (i in 1:csteps) {
+ vals[i] <- narmfun(a[,i])
+ }
+# vals <- apply(a, 2, narmfun )
} else {
- vals <- apply(a, 2, fun)
+# vals <- apply(a, 2, fun)
+ for (i in 1:csteps) {
+ vals[i] <- fun(a[,i])
+ }
}
if (addcol > 0) {
if (na.rm) {
- vals <- c(vals, narmfun(b))
+ vals[newcols] <- narmfun(b)
} else {
- vals <- c(vals, fun(b))
+ vals[newcols] <- fun(b)
}
}
if (outRaster at file@name == "") {
Added: pkg/raster/R/ext.R
===================================================================
--- pkg/raster/R/ext.R (rev 0)
+++ pkg/raster/R/ext.R 2009-04-20 11:28:52 UTC (rev 421)
@@ -0,0 +1,47 @@
+# R miscellaneouse file name related functions
+# Authors: Robert J. Hijmans
+# International Rice Research Institute
+# contact: r.hijmans at gmail.com
+# Date : October 2008
+# Version 0.8
+# Licence GPL v3
+
+
+ext <- function(filename) {
+ lfn <- nchar(filename)
+ extstart <- -1
+ for (i in lfn : 2) {
+ if (substr(filename, i, i) == ".") {
+ extstart <- i
+ break
+ }
+ }
+ if (extstart > 0) {
+ ext <- substr(filename, extstart, lfn)
+ }
+ else { ext <- "" }
+ return(ext)
+}
+
+
+'ext<-' <- function(filename, value) {
+ lfn <- nchar(filename)
+ value <- trim(value)
+ if (value != "" & substr(value, 1, 1) != ".") {
+ value <- paste(".", value, sep="")
+ }
+ extstart <- -1
+ for (i in lfn : 2) {
+ if (substr(filename, i, i) == ".") {
+ extstart <- i
+ break
+ }
+ }
+ if (extstart > 0) {
+ fname <- paste(substr(filename, 1, extstart-1), value, sep="")
+ }
+ else { fname <- paste(filename, value, sep="")
+ }
+ return(fname)
+}
+
Modified: pkg/raster/R/filenames.R
===================================================================
--- pkg/raster/R/filenames.R 2009-04-20 02:40:21 UTC (rev 420)
+++ pkg/raster/R/filenames.R 2009-04-20 11:28:52 UTC (rev 421)
@@ -6,13 +6,8 @@
# Version 0.8
# Licence GPL v3
+# no longer used
-trim <- function(x) {
- f <- function(s) {return( gsub('^[[:space:]]+', '', gsub('[[:space:]]+$', '', s) ) )}
- return(unlist(lapply(x, f)))
-}
-
-
.shortFileName <- function(filename) {
# is this the same as basename ?
filename <- gsub("\\\\", "/", filename)
@@ -32,43 +27,3 @@
path <- gsub(file, '', filename)
return(path)
}
-
-
-ext <- function(filename) {
- lfn <- nchar(filename)
- extstart <- -1
- for (i in lfn : 2) {
- if (substr(filename, i, i) == ".") {
- extstart <- i
- break
- }
- }
- if (extstart > 0) {
- ext <- substr(filename, extstart, lfn)
- }
- else { ext <- "" }
- return(ext)
-}
-
-
-'ext<-' <- function(filename, value) {
- lfn <- nchar(filename)
- value <- trim(value)
- if (value != "" & substr(value, 1, 1) != ".") {
- value <- paste(".", value, sep="")
- }
- extstart <- -1
- for (i in lfn : 2) {
- if (substr(filename, i, i) == ".") {
- extstart <- i
- break
- }
- }
- if (extstart > 0) {
- fname <- paste(substr(filename, 1, extstart-1), value, sep="")
- }
- else { fname <- paste(filename, value, sep="")
- }
- return(fname)
-}
-
Modified: pkg/raster/R/polygonToRaster.R
===================================================================
--- pkg/raster/R/polygonToRaster.R 2009-04-20 02:40:21 UTC (rev 420)
+++ pkg/raster/R/polygonToRaster.R 2009-04-20 11:28:52 UTC (rev 421)
@@ -88,14 +88,26 @@
npol <- length(spPolys at polygons)
- if (field < 0) {
+ if (length(field) > 1) {
+ stop('field should be a single value')
+ }
+ if (is.numeric(field) & field < 0) {
putvals <- rep(1, length=npol)
} else if (class(spPolys) == 'SpatialPolygons' | field == 0) {
putvals <- as.integer(1:npol)
} else {
+ if (is.character(field)){
+ if (!(field %in% colnames(spPolys at data))) {
+ stop('field does not exist')
+ }
+ } else if (is.numeric(field)){
+ if (field > dim(spPolys at data)[2]) {
+ stop('field index too large')
+ }
+ }
putvals <- as.vector(spPolys at data[[field]])
if (class(putvals) == 'character') {
- stop('selected field is charater type')
+ stop('selected field is character type')
}
}
Added: pkg/raster/R/roundCoords.R
===================================================================
--- pkg/raster/R/roundCoords.R (rev 0)
+++ pkg/raster/R/roundCoords.R 2009-04-20 11:28:52 UTC (rev 421)
@@ -0,0 +1,30 @@
+# Author: Robert J. Hijmans, r.hijmans at gmail.com
+# International Rice Research Institute
+# Date : June 2008
+# Version 0.8
+# Licence GPL v3
+
+
+roundExtent <- function(object, digits=0) {
+ digits <- max(0, digits)
+ b <- extent(object)
+ b at xmin <- round(b at xmin, digits)
+ b at xmax <- round(b at xmax, digits)
+ b at ymin <- round(b at ymin, digits)
+ b at ymax <- round(b at ymax, digits)
+ if (class(object) == 'BoundingBox') {
+ return(b)
+ }
+ object <- setExtent(object, b)
+ return(object)
+}
+
+nudgeExtent <- function(object){
+ b <- extent(object)
+ b at xmin <- floor(b at xmin)
+ b at ymin <- floor(b at ymin)
+ b at xmax <- ceiling(b at xmax)
+ b at ymax <- ceiling(b at ymax)
+ object <- setExtent(object, b)
+ return(object)
+}
Deleted: pkg/raster/R/set.R
===================================================================
--- pkg/raster/R/set.R 2009-04-20 02:40:21 UTC (rev 420)
+++ pkg/raster/R/set.R 2009-04-20 11:28:52 UTC (rev 421)
@@ -1,46 +0,0 @@
-# Author: Robert J. Hijmans, r.hijmans at gmail.com
-# International Rice Research Institute
-# Date : June 2008
-# Version 0.8
-# Licence GPL v3
-
-.addHistory <- function(raster, message) {
- if (is.character(message) & message != "") {
- raster at history <- c(message, raster at history)
- }
-}
-
-
-
-roundCoords <- function(object, digits=0) {
- digits <- max(0, digits)
- b <- extent(object)
- b at xmin <- round(b at xmin, digits)
- b at xmax <- round(b at xmax, digits)
- b at ymin <- round(b at ymin, digits)
- b at ymax <- round(b at ymax, digits)
- if (class(object) == 'BoundingBox') {
- return(b)
- }
- object <- setExtent(object, b)
- return(object)
-}
-
-.nudgeCoords <- function(bb){
- bb <- extent(bb)
- bb at xmin <- floor(bb at xmin)
- bb at ymin <- floor(bb at ymin)
- bb at xmax <- ceiling(bb at xmax)
- bb at ymax <- ceiling(bb at ymax)
- return(bb)
-}
-
-
-'NAvalue<-' <- function(x, value) {
- x at file@nodatavalue <- value
- return(x)
-}
-
-'NAvalue' <- function(x, value) {
- return(x at file@nodatavalue)
-}
Added: pkg/raster/R/trim.R
===================================================================
--- pkg/raster/R/trim.R (rev 0)
+++ pkg/raster/R/trim.R 2009-04-20 11:28:52 UTC (rev 421)
@@ -0,0 +1,13 @@
+# R miscellaneouse file name related functions
+# Authors: Robert J. Hijmans
+# International Rice Research Institute
+# contact: r.hijmans at gmail.com
+# Date : October 2008
+# Version 0.8
+# Licence GPL v3
+
+
+trim <- function(x) {
+ f <- function(s) {return( gsub('^[[:space:]]+', '', gsub('[[:space:]]+$', '', s) ) )}
+ return(unlist(lapply(x, f)))
+}
Added: pkg/raster/man/newCRS.Rd
===================================================================
--- pkg/raster/man/newCRS.Rd (rev 0)
+++ pkg/raster/man/newCRS.Rd 2009-04-20 11:28:52 UTC (rev 421)
@@ -0,0 +1,23 @@
+\name{newCRS}
+\alias{newCRS}
+
+\title{Coordiante Reference System object}
+
+\description{
+newCRS is a helper function to create a CRS map projection object.
+}
+
+\usage{
+newCRS(projs)
+}
+
+\arguments{
+ \item{projs}{charater. a PROJ4 type description of a projection, its paramaters, and the datum}
+ }
+
+\author{Robert J. Hijmans }
+\examples{
+ crsproj <- newCRS("+proj=longlat +datum=WGS84")
+}
+\keyword{ spatial }
+
Added: pkg/raster/man/roundExtent.Rd
===================================================================
--- pkg/raster/man/roundExtent.Rd (rev 0)
+++ pkg/raster/man/roundExtent.Rd 2009-04-20 11:28:52 UTC (rev 421)
@@ -0,0 +1,31 @@
+\name{nudgeExtent}
+
+\alias{roundExtent}
+\alias{nudgeExtent}
+
+\title{round ccoordinates of extent}
+
+\description{
+roundCoords rounds the coordinates of the extent of a Raster* to a number of digits specified. This can be useful when dealing with small inprecision in the data.
+nudgeCoords takes the floor (lower integer) of the mimumum x and y of the exent and the ceiling (upper integer) of the maximum x and y of the extent. Thus returning a RasterLayer with an extent of rounded coordinates and that always includes the original extent.
+This can be useful when creating raster objects based on the extent of other objects.
+}
+
+\usage{
+roundExtent(object, digits=0)
+nudgeExtent(object)
+}
+
+\arguments{
+ \item{object}{ a Raster* object }
+ \item{digits}{ integer indicating the precision to be used}
+ }
+
+\author{Robert J. Hijmans }
+\examples{
+ r <- raster(xmn=0.999999, xmx=10.000011, ymn=-60, ymx=60)
+ r <- roundExtent(r, 2)
+ r <- nudgeExtent(r)
+}
+\keyword{ spatial }
+
Deleted: pkg/raster/man/utils.Rd
===================================================================
--- pkg/raster/man/utils.Rd 2009-04-20 02:40:21 UTC (rev 420)
+++ pkg/raster/man/utils.Rd 2009-04-20 11:28:52 UTC (rev 421)
@@ -1,30 +0,0 @@
-\name{utilities}
-\alias{roundCoords}
-\alias{newCRS}
-
-\title{helper functions }
-
-\description{
- roundCoords rounds the coordinates of the BoundingBox of a Raster* to a number of digits specified.
- newCRS is a helper function to create a CRS map projection object.
-}
-
-\usage{
-roundCoords(object, digits=0)
-newCRS(projs)
-}
-
-\arguments{
- \item{object}{ a Raster* object }
- \item{digits}{ integer indicating the precision to be used}
- \item{projs}{charater. a PROJ4 type description of a projection, its paramaters, and the datum}
- }
-
-\author{Robert J. Hijmans }
-\examples{
- crsproj <- newCRS("+proj=longlat +datum=WGS84")
- bb <- newBbox(-179.999999, 180.000011, -60, 60)
- bb <- roundCoords(bb, 5)
-}
-\keyword{ spatial }
-
More information about the Raster-commits
mailing list