[Raster-commits] r122 - in pkg/raster: R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Jan 12 11:52:24 CET 2009
Author: rhijmans
Date: 2009-01-12 11:52:24 +0100 (Mon, 12 Jan 2009)
New Revision: 122
Added:
pkg/raster/R/bounding.box.R
pkg/raster/R/filenames.R
pkg/raster/R/group.generic.functions.R
pkg/raster/R/read.inifile.R
pkg/raster/R/set.values.R
pkg/raster/R/stats.R
Removed:
pkg/raster/R/misc.R
Modified:
pkg/raster/R/set.R
pkg/raster/R/standard.generic.functions.R
pkg/raster/man/bbox.Rd
pkg/raster/man/calc.Rd
pkg/raster/man/create.brick.Rd
pkg/raster/man/create.raster.Rd
pkg/raster/man/export.Rd
pkg/raster/man/misc.Rd
pkg/raster/man/properties.Rd
pkg/raster/man/raster.change.Rd
pkg/raster/man/raster.write.Rd
pkg/raster/man/set.Rd
pkg/raster/man/utils.Rd
Log:
Added: pkg/raster/R/bounding.box.R
===================================================================
--- pkg/raster/R/bounding.box.R (rev 0)
+++ pkg/raster/R/bounding.box.R 2009-01-12 10:52:24 UTC (rev 122)
@@ -0,0 +1,64 @@
+
+changeBbox <- function(object, xmn=xmin(object), xmx=xmax(object), ymn=ymin(object), ymx = ymax(object), keepres=FALSE) {
+ bb <- newBbox(xmn, xmx, ymn, ymx)
+ object <- setBbox(object, bb, keepres=keepres)
+ return(object)
+}
+
+
+newBbox <- function(xmn, xmx, ymn, ymx) {
+ bb <- new('BoundingBox')
+ bb at xmin <- xmn
+ bb at xmax <- xmx
+ bb at ymin <- ymn
+ bb at ymax <- ymx
+ return(bb)
+}
+
+getBbox <- function(object) {
+ if ( class(object) == 'BoundingBox' ) {
+ bb <- object
+ } else if ( class(object) == 'RasterLayer' | class(object) == 'RasterStack' | class(object) == 'RasterBrick' ) {
+ bb <- object at bbox
+ } else if (class(object) == "matrix") {
+ bb <- new('BoundingBox')
+ bb at xmin <- object[1,1]
+ bb at xmax <- object[1,2]
+ bb at ymin <- object[2,1]
+ bb at ymax <- object[2,2]
+ } else if (class(object) == "vector") {
+ bb <- new('BoundingBox')
+ bb at xmin <- object[1]
+ bb at xmax <- object[2]
+ bb at ymin <- object[3]
+ bb at ymax <- object[4]
+ } else {
+ bndbox <- bbox(object)
+ bb <- new('BoundingBox')
+ bb at xmin <- bndbox[1,1]
+ bb at xmax <- bndbox[1,2]
+ bb at ymin <- bndbox[2,1]
+ bb at ymax <- bndbox[2,2]
+ }
+ return(bb)
+}
+
+
+setBbox <- function(object, bndbox, keepres=FALSE) {
+ xrs <- xres(object)
+ yrs <- yres(object)
+ object at bbox <- getBbox(bndbox)
+ if (keepres) {
+ nc <- as.integer(round( (xmax(object) - xmin(object)) / xrs ))
+ if (nc < 1) { stop( "xmin and xmax are less than one cell apart" )
+ } else { object at ncols <- nc }
+ nr <- as.integer(round( (ymax(object) - ymin(object)) / xrs ) )
+ if (nr < 1) { stop( "ymin and ymax are less than one cell apart" )
+ } else { object at nrows <- nr }
+ object at bbox@xmax <- object at bbox@xmin + ncol(object) * xrs
+ object at bbox@ymax <- object at bbox@ymin + nrow(object) * yrs
+ }
+ return(object)
+}
+
+
Added: pkg/raster/R/filenames.R
===================================================================
--- pkg/raster/R/filenames.R (rev 0)
+++ pkg/raster/R/filenames.R 2009-01-12 10:52:24 UTC (rev 122)
@@ -0,0 +1,78 @@
+# 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(astring) {
+ f <- function(s) {return( gsub('^[[:space:]]+', '', gsub('[[:space:]]+$', '', s) ) )}
+ return(unlist(lapply(astring, f)))
+}
+
+
+fileName <- function(filename) {
+# Author: Robert Hijmans
+# Version 1; Date: 1-Sep-2008; License: GPL3
+ filename <- gsub("\\\\", "/", filename)
+ if (filename == "") {return(filename)
+ } else {
+ split <- strsplit(filename, "/")
+ l <- length(split[[1]])
+ shortfilename <- split[[1]][[l]]
+ return(shortfilename)
+ }
+}
+
+filePath <- function(filename) {
+ filename <- gsub("\\\\", "/", filename)
+ file <- fileName(filename)
+ path <- gsub(file, '', filename)
+ return(path)
+}
+
+
+fileExtension <- function(filename) {
+# Author: Robert Hijmans
+# Version 1; Date: 1-Sep-2008; License: GPL3
+ 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)
+}
+
+
+setFileExtension <- function(filename, newextension="") {
+# Author: Robert Hijmans
+# Version 1; Date: 1-Sep-2008; License: GPL3
+ lfn <- nchar(filename)
+ newextension <- trim(newextension)
+ if (newextension != "" & substr(newextension, 1, 1) != ".") {
+ newextension <- paste(".", newextension, 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), newextension, sep="")
+ }
+ else { fname <- paste(filename, newextension, sep="")
+ }
+ return(fname)
+}
+
Added: pkg/raster/R/group.generic.functions.R
===================================================================
--- pkg/raster/R/group.generic.functions.R (rev 0)
+++ pkg/raster/R/group.generic.functions.R 2009-01-12 10:52:24 UTC (rev 122)
@@ -0,0 +1,170 @@
+# Authors: Robert J. Hijmans, r.hijmans at gmail.com and Jacob van Etten
+# International Rice Research Institute
+# Date : January 2009
+# Version 0,8
+# Licence GPL v3
+
+
+setMethod('==', signature(e1='Raster', e2='Raster'),
+ function(e1,e2){
+ cond <- compare(c(e1, e2), bb=TRUE, rowcol=TRUE, prj=TRUE, tolerance=0.0001, stopiffalse=FALSE)
+ return(cond)
+ }
+)
+
+setMethod('!=', signature(e1='Raster', e2='Raster'),
+ function(e1,e2){
+ cond <- compare(c(e1, e2), bb=TRUE, rowcol=TRUE, prj=TRUE, tolerance=0.0001, stopiffalse=FALSE)
+ return(!cond)
+ }
+)
+
+
+.getRasterValues <- function(x) {
+# need to take care of 'spase'
+ if (dataContent(x) != 'all') {
+ if (class(x) == "RasterLayer") {
+ if (dataSource(x) == 'ram') {
+ stop('no data on disk or in memory')
+ } else x <- readAll(x)
+ } else {
+ x <- readAll(x)
+ }
+ }
+ return(values(x))
+}
+
+.getLogicalValues <- function(x) {
+ v <- .getRasterValues(x)
+ v[v<0] <- 0
+ v[v>0] <- 1
+ return(v)
+}
+
+.getAllTypeOfValues <- function(x, y, i) {
+ if ( (class(y) == 'RasterLayer' | class(y) == 'RasterStack' | class(y) == 'RasterBrick') & compare(c(x, y)) ) {
+ return(.getRasterValues(y))
+ } else if (is.atomic(y)) {
+ return(rep(y, ncells(x)))
+ } else if (length(y)==ncells(x)) {
+ return(y)
+ } else {
+ stop(paste("I do not understand argument",i + 1))
+ }
+}
+
+setMethod("[", "RasterLayer",
+ function(x, i, j, ..., drop = TRUE) {
+ if (!missing(drop)) { stop("drop is ignored. It is always set to FALSE") }
+ if (!missing(j)) { stop("can only set values with a single index (a vector)") }
+ if (missing(i)) { return(x) }
+ v <- values(i)
+ v[x] <- i
+ return(setRaster(x, v))
+ }
+)
+
+
+setMethod("Math", signature(x='RasterLayer'),
+ function(x){
+ return(setRaster(x, values=callGeneric(.getRasterValues(x))))
+ }
+)
+
+setMethod("Logic", signature(e1='RasterLayer', e2='RasterLayer'),
+ function(e1, e2){
+ if ( compare(c(e1, e2)) ) {
+ return(setRaster(e1, values=callGeneric(.getLogicalValues(e1), .getLogicalValues(e2))))
+ }
+ }
+)
+
+setMethod("Arith", signature(e1='RasterLayer', e2='RasterLayer'),
+ function(e1, e2){
+ if (compare(c(e1, e2))) {
+ return(setRaster(e1, values=callGeneric(.getRasterValues(e1), .getRasterValues(e2))))
+ }
+ }
+)
+
+setMethod("Arith", signature(e1='RasterLayer', e2='numeric'),
+ function(e1, e2){
+ return(setRaster(e1, values=callGeneric(.getRasterValues(e1), e2)))
+ }
+)
+
+setMethod("Arith", signature(e1='numeric', e2='RasterLayer'),
+ function(e1, e2){
+ return(setRaster(e2, values=callGeneric(.getRasterValues(e2), e1)))
+ }
+)
+
+
+setMethod("max", signature(x='Raster'),
+ function(x, ..., na.rm=FALSE){
+ obs <- list(...)
+ if (length(obs) == 0) {
+ return(setRaster(x, values=apply(as.matrix(.getRasterValues(x)), 1, max, na.rm=na.rm)))
+ } else {
+ v <- .getRasterValues(x)
+ for (i in 1:length(obs)) {
+ v <- apply(cbind(v, .getAllTypeOfValues(x, obs[[i]], i)), 1, max, na.rm=na.rm)
+ }
+ return(setRaster(x, values=v))
+ }
+ }
+)
+
+
+setMethod("min", signature(x='Raster'),
+ function(x, ..., na.rm=FALSE){
+ obs <- list(...)
+ if (length(obs) == 0) {
+ return(setRaster(x, values=apply(as.matrix(.getRasterValues(x)), 1, min, na.rm=na.rm)))
+ } else {
+ v <- .getRasterValues(x)
+ for (i in 1:length(obs)) {
+ v <- apply(cbind(v, .getAllTypeOfValues(x, obs[[i]], i)), 1, min, na.rm=na.rm)
+ }
+ return(setRaster(x, values=v))
+ }
+ }
+)
+
+
+setMethod("sum", signature(x='Raster'),
+ function(x, ..., na.rm=FALSE){
+ obs <- list(...)
+ if (length(obs) == 0) {
+ return(setRaster(x, values=rowSums(as.matrix(.getRasterValues(x)), na.rm)))
+ } else {
+ v <- .getRasterValues(x)
+ if (!(is.null(dim(v)))) {
+ v <- rowSums(as.matrix(.getRasterValues(x)), na.rm=na.rm)
+ }
+ for (i in 1:length(obs)) {
+ vv <- .getAllTypeOfValues(x, obs[[i]], i)
+ v <- rowSums(cbind(v, vv), na.rm=na.rm)
+ }
+ return(setRaster(x, values=v))
+ }
+ }
+)
+
+
+#todo "any", "all"
+
+
+setMethod("range", signature(x='Raster'),
+ function(x, ..., na.rm=FALSE){
+ return(max(x, ..., na.rm=na.rm) - min(x, ..., na.rm=na.rm))
+ }
+)
+
+setMethod("is.na", signature(x='RasterLayer'),
+ function(x) {
+ return(setRaster(x, values=is.na(.getRasterValues(x))))
+ }
+)
+
+
Deleted: pkg/raster/R/misc.R
===================================================================
--- pkg/raster/R/misc.R 2009-01-12 10:29:32 UTC (rev 121)
+++ pkg/raster/R/misc.R 2009-01-12 10:52:24 UTC (rev 122)
@@ -1,150 +0,0 @@
-# R miscellanea
-# Authors: Robert J. Hijmans
-# International Rice Research Institute
-# contact: r.hijmans at gmail.com
-# Date : October 2008
-# Version 0,2
-# Licence GPL v3
-
-Mode <- function(x, na.rm = TRUE) {
-#partly based on http://wiki.r-project.org/rwiki/doku.php?id=tips:stats-basic:modalvalue
-# ties are broken at random
-# earlier approach contained this
-# freq <- tapply(rep(0, length(x)), x, length)
-# w <- as.vector(which(freq == max(freq)) )
-# result <- as.numeric(dimnames(freq)[[1]][w])
-# return(result)
- z <- x[!is.na(x)]
- if (length(z) == 0) { return(NA)
- } else if (na.rm == FALSE & length(z) < length(x)) { return(NA)
- } else if (length(z) == 1) { return(z)
- } else {
- freq <- table(z)
- w <- as.numeric(names(freq[max(freq)==freq]))
- if (length(w) > 1) {
- r <- runif(length(w))
- w <- w[which.max(r)]
- }
- return(w)
- }
-}
-
-CV <- function(x, na.rm = TRUE, singlevalueaszero=TRUE) {
-# R function to compute the coefficient of variation (expressed as a percentage)
-# if there is only a single value, sd = NA. However, one could argue that cv =0. In this case a NA is returned if(singlevaluecvzero=FALSE)
-# else a value of 0 is returned.
- z <- x[!is.na(x)]
- if (length(z) == 0) { return(NA)
- } else if (na.rm == FALSE & length(z) < length(x)) { return(NA)
- } else if (length(z) == 1 & singlevalueaszero == TRUE) { return(0)
- } else {
- return(100 * sd(z) / mean(z))
- }
-}
-
-trim <- function(astring) {
- f <- function(s) {return( gsub('^[[:space:]]+', '', gsub('[[:space:]]+$', '', s) ) )}
- return(unlist(lapply(astring, f)))
-}
-
-fileName <- function(filename) {
-# Author: Robert Hijmans
-# Version 1; Date: 1-Sep-2008; License: GPL3
- filename <- gsub("\\\\", "/", filename)
- if (filename == "") {return(filename)
- } else {
- split <- strsplit(filename, "/")
- l <- length(split[[1]])
- shortfilename <- split[[1]][[l]]
- return(shortfilename)
- }
-}
-
-filePath <- function(filename) {
- filename <- gsub("\\\\", "/", filename)
- file <- fileName(filename)
- path <- gsub(file, '', filename)
- return(path)
-}
-
-fileExtension <- function(filename) {
-# Author: Robert Hijmans
-# Version 1; Date: 1-Sep-2008; License: GPL3
- 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)
-}
-
-
-setFileExtension <- function(filename, newextension="") {
-# Author: Robert Hijmans
-# Version 1; Date: 1-Sep-2008; License: GPL3
- lfn <- nchar(filename)
- newextension <- trim(newextension)
- if (newextension != "" & substr(newextension, 1, 1) != ".") {
- newextension <- paste(".", newextension, 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), newextension, sep="")
- }
- else { fname <- paste(filename, newextension, sep="")
- }
- return(fname)
-}
-
-
-readIniFile <- function(filename) {
- if (!file.exists(filename)) { stop(paste(filename, " does not exist")) }
-
- strSplitOnFirstToken <- function(s, token="=") {
-# this function allows for using inistrings that have "=" in the value
-# e.g. "projection = +proj=sinu +lon_0=0 +x_0=0 +y_0=0 +a=6371007.181 +b=6371007.181 +units=m +no_defs"
- pos <- which(strsplit(s, '')[[1]]==token)[1]
- if (is.na(pos)) {
- return(c(trim(s), NA))
- } else {
- first <- substr(s, 1, (pos-1))
- second <- substr(s, (pos+1), nchar(s))
- return(trim(c(first, second)))
- }
- }
- Lines <- readLines(filename)
-# ";" is the start of a comment .
- strsplitcomment <- function(s) {strSplitOnFirstToken(s, token=";")}
- ini <- lapply(Lines, strsplitcomment)
- Lines <- matrix(unlist(ini), ncol=2, byrow=T)[,1]
- ini <- lapply(Lines, strSplitOnFirstToken)
- ini <- matrix(unlist(ini), ncol=2, byrow=T)
- ini <- subset(ini, ini[,1] != "")
-
- sections <- c(which(is.na(ini[,2])), length(ini[,2]))
-# here I should check whether the section text is enclused in [ ]. If not, it is junk text that should be removed, rather than used as a section
- ini <- cbind("", ini)
- for (i in 1:(length(sections)-1)) {
- ini[sections[i]:(sections[i+1]), 1] <- ini[sections[i],2]
- }
- ini[,1] <- gsub("\\[", "", ini[,1])
- ini[,1] <- gsub("\\]", "", ini[,1])
-
- colnames(ini) <- c("section", "name", "value")
- sections <- sections[1:(length(sections)-1)]
- return(ini[-sections,])
-}
-
Added: pkg/raster/R/read.inifile.R
===================================================================
--- pkg/raster/R/read.inifile.R (rev 0)
+++ pkg/raster/R/read.inifile.R 2009-01-12 10:52:24 UTC (rev 122)
@@ -0,0 +1,49 @@
+# Authors: Robert J. Hijmans
+# International Rice Research Institute
+# contact: r.hijmans at gmail.com
+# Date : October 2008
+# Version 0,2
+# Licence GPL v3
+
+# Read inifile into a matrix of 'section', 'name', value'
+# this function allows for using inistrings that have "=" in the value
+# e.g. "projection = +proj=sinu +lon_0=0 +x_0=0 +y_0=0 +a=6371007.181 +b=6371007.181 +units=m +no_defs"
+
+
+readIniFile <- function(filename) {
+ if (!file.exists(filename)) { stop(paste(filename, " does not exist")) }
+
+ strSplitOnFirstToken <- function(s, token="=") {
+ pos <- which(strsplit(s, '')[[1]]==token)[1]
+ if (is.na(pos)) {
+ return(c(trim(s), NA))
+ } else {
+ first <- substr(s, 1, (pos-1))
+ second <- substr(s, (pos+1), nchar(s))
+ return(trim(c(first, second)))
+ }
+ }
+
+ Lines <- readLines(filename)
+# ";" is the start of a comment .
+ strsplitcomment <- function(s) {strSplitOnFirstToken(s, token=";")}
+ ini <- lapply(Lines, strsplitcomment)
+ Lines <- matrix(unlist(ini), ncol=2, byrow=T)[,1]
+ ini <- lapply(Lines, strSplitOnFirstToken)
+ ini <- matrix(unlist(ini), ncol=2, byrow=T)
+ ini <- subset(ini, ini[,1] != "")
+
+ sections <- c(which(is.na(ini[,2])), length(ini[,2]))
+# here I should check whether the section text is enclused in [ ]. If not, it is junk text that should be removed, rather than used as a section
+ ini <- cbind("", ini)
+ for (i in 1:(length(sections)-1)) {
+ ini[sections[i]:(sections[i+1]), 1] <- ini[sections[i],2]
+ }
+ ini[,1] <- gsub("\\[", "", ini[,1])
+ ini[,1] <- gsub("\\]", "", ini[,1])
+
+ colnames(ini) <- c("section", "name", "value")
+ sections <- sections[1:(length(sections)-1)]
+ return(ini[-sections,])
+}
+
Modified: pkg/raster/R/set.R
===================================================================
--- pkg/raster/R/set.R 2009-01-12 10:29:32 UTC (rev 121)
+++ pkg/raster/R/set.R 2009-01-12 10:52:24 UTC (rev 122)
@@ -69,34 +69,6 @@
}
-clearValues <- function(object) {
- object at data@content <- 'nodata'
- object at data@indices <- ""
- if (class(object) == 'RasterLayer') {
- object at data@values <- vector()
- } else {
- object at data@values <- matrix(NA,0,0)
- }
- return(object)
-}
-
-
-roundCoords <- function(object, digits=0) {
- digits <- max(0, digits)
- b <- getBbox(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 <- setBbox(object, b)
- return(object)
-}
-
-
-
newCRS <- function(projstring) {
projstring <- trim(projstring)
if (is.na(projstring) | nchar(projstring) < 3) {
@@ -112,148 +84,23 @@
}
-changeBbox <- function(object, xmn=xmin(object), xmx=xmax(object), ymn=ymin(object), ymx = ymax(object), keepres=FALSE) {
- bb <- newBbox(xmn, xmx, ymn, ymx)
- object <- setBbox(object, bb, keepres=keepres)
- return(object)
-}
-
-newBbox <- function(xmn, xmx, ymn, ymx) {
- bb <- new('BoundingBox')
- bb at xmin <- xmn
- bb at xmax <- xmx
- bb at ymin <- ymn
- bb at ymax <- ymx
- return(bb)
-}
-
-getBbox <- function(object) {
- if ( class(object) == 'BoundingBox' ) {
- bb <- object
- } else if ( class(object) == 'RasterLayer' | class(object) == 'RasterStack' | class(object) == 'RasterBrick' ) {
- bb <- object at bbox
- } else if (class(object) == "matrix") {
- bb <- new('BoundingBox')
- bb at xmin <- object[1,1]
- bb at xmax <- object[1,2]
- bb at ymin <- object[2,1]
- bb at ymax <- object[2,2]
- } else if (class(object) == "vector") {
- bb <- new('BoundingBox')
- bb at xmin <- object[1]
- bb at xmax <- object[2]
- bb at ymin <- object[3]
- bb at ymax <- object[4]
- } else {
- bndbox <- bbox(object)
- bb <- new('BoundingBox')
- bb at xmin <- bndbox[1,1]
- bb at xmax <- bndbox[1,2]
- bb at ymin <- bndbox[2,1]
- bb at ymax <- bndbox[2,2]
+roundCoords <- function(object, digits=0) {
+ digits <- max(0, digits)
+ b <- getBbox(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)
}
- return(bb)
-}
-
-
-setBbox <- function(object, bndbox, keepres=FALSE) {
- xrs <- xres(object)
- yrs <- yres(object)
- object at bbox <- getBbox(bndbox)
- if (keepres) {
- nc <- as.integer(round( (xmax(object) - xmin(object)) / xrs ))
- if (nc < 1) { stop( "xmin and xmax are less than one cell apart" )
- } else { object at ncols <- nc }
- nr <- as.integer(round( (ymax(object) - ymin(object)) / xrs ) )
- if (nr < 1) { stop( "ymin and ymax are less than one cell apart" )
- } else { object at nrows <- nr }
- object at bbox@xmax <- object at bbox@xmin + ncol(object) * xrs
- object at bbox@ymax <- object at bbox@ymin + nrow(object) * yrs
- }
+ object <- setBbox(object, b)
return(object)
}
-makeSparse <- function(raster) {
- if ( dataContent(raster) == 'sparse') {return(raster)
- } else {
- if ( dataContent(raster) == 'all') {
- vals <- seq(1:ncells(raster))
- vals <- cbind(vals, values(raster))
- vals <- as.vector(na.omit(vals))
- raster <- setValuesSparse(raster, sparsevalues=vals[,2], cellnumbers=vals[,1])
- return(raster)
- } else {
- # as above, but by reading data from disk, row by row
- stop('not implemented yet, use readAll() first' )
- }
- }
-}
-
-setValuesSparse <- function(raster, sparsevalues, cellnumbers) {
- if (!(isTRUE(length(cellnumbers) == (length(sparsevalues))))) {
- stop()
- }
- raster at data@content <- 'sparse'
- raster at data@values <- sparsevalues
- raster at data@indices <- cellnumbers
- raster at data@source <- 'ram'
- raster <- setMinmax(raster)
- return(raster)
-}
-
-setValuesBlock <- function(raster, blockvalues, firstcell, lastcell) {
- if (!is.vector(blockvalues)) { stop('values must be a vector') }
- if (length(blockvalues) == 0) { stop('length(blockvalues==0). If this is intended use raster.data.clear(raster)') }
- if (!(is.numeric(blockvalues) | is.integer(blockvalues) | is.logical(blockvalues))) { stop('values must be numeric, integer or logical') }
- firstcol <- colFromCell(raster, firstcell)
- lastcol <- colFromCell(raster, lastcell)
- firstrow <- rowFromCell(raster, firstcell)
- lastrow <- rowFromCell(raster, lastcell)
- ncells <- (lastcol - firstcol + 1) * (lastrow - firstrow + 1)
-
- if (ncells != length(blockvalues)) {
- stop( paste("length(blockdata):", length(blockvalues), "does not match the number implied by firstcell and lastcell:", ncells))
- }
- raster at data@values <- blockvalues
- raster at data@content <- 'block'
- raster at data@indices <- c(firstcell, lastcell)
- return(raster)
-}
-
-
-setValues <- function(raster, values, rownr=-1) {
- if (!is.vector(values)) {stop('values must be a vector')}
- if (length(values) == 0) { stop('length(values==0). If this is intended then use clearValues(raster)') }
- if (!(is.numeric(values) | is.integer(values) | is.logical(values))) {stop('data must be values')}
- rownr <- round(rownr)
- if (length(values) == ncells(raster)) {
- if (rownr > 0) {
- stop("if setting all values, rownr must be < 1")
- }
- raster at data@values <- values
- raster at data@content <- 'all'
- raster at data@source <- 'ram'
- raster at data@indices <- c(1, ncells(raster))
- raster <- setMinmax(raster)
- return(raster)
- } else if (length(values) == ncol(raster)) {
- if (rownr < 1 | rownr > nrow(raster)) {
- stop(paste("rownumber out of bounds:", rownr))
- }
- raster at data@values <- values
- raster at data@content <- 'row'
- firstcell <- cellFromRowcol(raster, rownr=rownr, colnr=1)
- lastcell <- cellFromRowcol(raster, rownr=rownr, colnr=ncol(raster))
- raster at data@indices <- c(firstcell, lastcell)
- return(raster)
- } else {
- stop("length(values) is not equal to ncells(raster) or ncol(raster)")
- }
-}
-
setMinmax <- function(raster) {
if (dataContent(raster) == 'nodata') {
stop('no data in memory')
Added: pkg/raster/R/set.values.R
===================================================================
--- pkg/raster/R/set.values.R (rev 0)
+++ pkg/raster/R/set.values.R 2009-01-12 10:52:24 UTC (rev 122)
@@ -0,0 +1,101 @@
+# Author: Robert J. Hijmans, r.hijmans at gmail.com
+# International Rice Research Institute
+# Date : June 2008
+# Version 0,8
+# Licence GPL v3
+
+
+
+setValues <- function(raster, values, rownr=-1) {
+ if (!is.vector(values)) {stop('values must be a vector')}
+ if (length(values) == 0) { stop('length(values==0). If this is intended then use clearValues(raster)') }
+ if (!(is.numeric(values) | is.integer(values) | is.logical(values))) {stop('data must be values')}
+ rownr <- round(rownr)
+ if (length(values) == ncells(raster)) {
+ if (rownr > 0) {
+ stop("if setting all values, rownr must be < 1")
+ }
+ raster at data@values <- values
+ raster at data@content <- 'all'
+ raster at data@source <- 'ram'
+ raster at data@indices <- c(1, ncells(raster))
+ raster <- setMinmax(raster)
+ return(raster)
+ } else if (length(values) == ncol(raster)) {
+ if (rownr < 1 | rownr > nrow(raster)) {
+ stop(paste("rownumber out of bounds:", rownr))
+ }
+ raster at data@values <- values
+ raster at data@content <- 'row'
+ firstcell <- cellFromRowcol(raster, rownr=rownr, colnr=1)
+ lastcell <- cellFromRowcol(raster, rownr=rownr, colnr=ncol(raster))
+ raster at data@indices <- c(firstcell, lastcell)
+ return(raster)
+ } else {
+ stop("length(values) is not equal to ncells(raster) or ncol(raster)")
+ }
+}
+
+
+
+clearValues <- function(object) {
+ object at data@content <- 'nodata'
+ object at data@indices <- ""
+ if (class(object) == 'RasterLayer') {
+ object at data@values <- vector()
+ } else {
+ object at data@values <- matrix(NA,0,0)
+ }
+ return(object)
+}
+
+
+
+makeSparse <- function(raster) {
+ if ( dataContent(raster) == 'sparse') {return(raster)
+ } else {
+ if ( dataContent(raster) == 'all') {
+ vals <- seq(1:ncells(raster))
+ vals <- cbind(vals, values(raster))
+ vals <- as.vector(na.omit(vals))
+ raster <- setValuesSparse(raster, sparsevalues=vals[,2], cellnumbers=vals[,1])
+ return(raster)
+ } else {
+ # as above, but by reading data from disk, row by row
+ stop('not implemented yet, use readAll() first' )
+ }
+ }
+}
+
+setValuesSparse <- function(raster, sparsevalues, cellnumbers) {
+ if (!(isTRUE(length(cellnumbers) == (length(sparsevalues))))) {
+ stop()
+ }
+ raster at data@content <- 'sparse'
+ raster at data@values <- sparsevalues
+ raster at data@indices <- cellnumbers
+ raster at data@source <- 'ram'
+ raster <- setMinmax(raster)
+ return(raster)
+}
+
+setValuesBlock <- function(raster, blockvalues, firstcell, lastcell) {
+ if (!is.vector(blockvalues)) { stop('values must be a vector') }
+ if (length(blockvalues) == 0) { stop('length(blockvalues==0). If this is intended use raster.data.clear(raster)') }
+ if (!(is.numeric(blockvalues) | is.integer(blockvalues) | is.logical(blockvalues))) { stop('values must be numeric, integer or logical') }
+
+ firstcol <- colFromCell(raster, firstcell)
+ lastcol <- colFromCell(raster, lastcell)
+ firstrow <- rowFromCell(raster, firstcell)
+ lastrow <- rowFromCell(raster, lastcell)
+ ncells <- (lastcol - firstcol + 1) * (lastrow - firstrow + 1)
+
+ if (ncells != length(blockvalues)) {
+ stop( paste("length(blockdata):", length(blockvalues), "does not match the number implied by firstcell and lastcell:", ncells))
+ }
+ raster at data@values <- blockvalues
+ raster at data@content <- 'block'
+ raster at data@indices <- c(firstcell, lastcell)
+ return(raster)
+}
+
Modified: pkg/raster/R/standard.generic.functions.R
===================================================================
--- pkg/raster/R/standard.generic.functions.R 2009-01-12 10:29:32 UTC (rev 121)
+++ pkg/raster/R/standard.generic.functions.R 2009-01-12 10:52:24 UTC (rev 122)
@@ -5,6 +5,20 @@
# Licence GPL v3
+setMethod('dim', signature(x='Raster'),
+ function(x){ return(c(nrow(x), ncol(x), nlayers(x)))}
+)
+
+setMethod('nrow', signature(x='Raster'),
+ function(x){ return(x at nrows)}
+)
+
+setMethod('ncol', signature(x='Raster'),
+ function(x){ return(x at ncols) }
+)
+
+
+
setMethod ('show' , 'BoundingBox',
function(object) {
cat('class :' , class(object), '\n')
@@ -87,184 +101,8 @@
)
-
-setMethod('==', signature(e1='Raster', e2='Raster'),
- function(e1,e2){
- cond <- compare(c(e1, e2), bb=TRUE, rowcol=TRUE, prj=TRUE, tolerance=0.0001, stopiffalse=FALSE)
- return(cond)
- }
-)
-
-setMethod('!=', signature(e1='Raster', e2='Raster'),
- function(e1,e2){
- cond <- compare(c(e1, e2), bb=TRUE, rowcol=TRUE, prj=TRUE, tolerance=0.0001, stopiffalse=FALSE)
- return(!cond)
- }
-)
-
-
-.getRasterValues <- function(x) {
-# need to take care of 'spase'
- if (dataContent(x) != 'all') {
- if (class(x) == "RasterLayer") {
- if (dataSource(x) == 'ram') {
- stop('no data on disk or in memory')
- } else x <- readAll(x)
- } else {
- x <- readAll(x)
- }
- }
- return(values(x))
-}
-
-.getLogicalValues <- function(x) {
- v <- .getRasterValues(x)
- v[v<0] <- 0
- v[v>0] <- 1
- return(v)
-}
-
-.getAllTypeOfValues <- function(x, y, i) {
- if ( (class(y) == 'RasterLayer' | class(y) == 'RasterStack' | class(y) == 'RasterBrick') & compare(c(x, y)) ) {
- return(.getRasterValues(y))
- } else if (is.atomic(y)) {
- return(rep(y, ncells(x)))
- } else if (length(y)==ncells(x)) {
- return(y)
- } else {
- stop(paste("I do not understand argument",i + 1))
- }
-}
-
-setMethod("[", "RasterLayer",
- function(x, i, j, ..., drop = TRUE) {
- if (!missing(drop)) { stop("drop is ignored. It is always set to FALSE") }
- if (!missing(j)) { stop("can only set values with a single index (a vector)") }
- if (missing(i)) { return(x) }
- v <- values(i)
- v[x] <- i
- return(setRaster(x, v))
- }
-)
-
-
-setMethod("Math", signature(x='RasterLayer'),
- function(x){
- return(setRaster(x, values=callGeneric(.getRasterValues(x))))
- }
-)
-
-setMethod("Logic", signature(e1='RasterLayer', e2='RasterLayer'),
- function(e1, e2){
- if ( compare(c(e1, e2)) ) {
- return(setRaster(e1, values=callGeneric(.getLogicalValues(e1), .getLogicalValues(e2))))
- }
- }
-)
-setMethod("Arith", signature(e1='RasterLayer', e2='RasterLayer'),
- function(e1, e2){
- if (compare(c(e1, e2))) {
- return(setRaster(e1, values=callGeneric(.getRasterValues(e1), .getRasterValues(e2))))
- }
- }
-)
-setMethod("Arith", signature(e1='RasterLayer', e2='numeric'),
- function(e1, e2){
- return(setRaster(e1, values=callGeneric(.getRasterValues(e1), e2)))
- }
-)
-
-setMethod("Arith", signature(e1='numeric', e2='RasterLayer'),
- function(e1, e2){
- return(setRaster(e2, values=callGeneric(.getRasterValues(e2), e1)))
- }
-)
-
-
-setMethod("max", signature(x='Raster'),
- function(x, ..., na.rm=FALSE){
- obs <- list(...)
- if (length(obs) == 0) {
- return(setRaster(x, values=apply(as.matrix(.getRasterValues(x)), 1, max, na.rm=na.rm)))
- } else {
- v <- .getRasterValues(x)
- for (i in 1:length(obs)) {
- v <- apply(cbind(v, .getAllTypeOfValues(x, obs[[i]], i)), 1, max, na.rm=na.rm)
- }
- return(setRaster(x, values=v))
- }
- }
-)
-
-
-setMethod("min", signature(x='Raster'),
- function(x, ..., na.rm=FALSE){
- obs <- list(...)
- if (length(obs) == 0) {
- return(setRaster(x, values=apply(as.matrix(.getRasterValues(x)), 1, min, na.rm=na.rm)))
- } else {
- v <- .getRasterValues(x)
- for (i in 1:length(obs)) {
- v <- apply(cbind(v, .getAllTypeOfValues(x, obs[[i]], i)), 1, min, na.rm=na.rm)
- }
- return(setRaster(x, values=v))
- }
- }
-)
-
-
-setMethod("sum", signature(x='Raster'),
- function(x, ..., na.rm=FALSE){
- obs <- list(...)
- if (length(obs) == 0) {
- return(setRaster(x, values=rowSums(as.matrix(.getRasterValues(x)), na.rm)))
- } else {
- v <- .getRasterValues(x)
- if (!(is.null(dim(v)))) {
- v <- rowSums(as.matrix(.getRasterValues(x)), na.rm=na.rm)
- }
- for (i in 1:length(obs)) {
- vv <- .getAllTypeOfValues(x, obs[[i]], i)
- v <- rowSums(cbind(v, vv), na.rm=na.rm)
- }
- return(setRaster(x, values=v))
- }
- }
-)
-
-
-#todo "any", "all"
-
-
-setMethod("range", signature(x='Raster'),
- function(x, ..., na.rm=FALSE){
- return(max(x, ..., na.rm=na.rm) - min(x, ..., na.rm=na.rm))
- }
-)
-
-setMethod("is.na", signature(x='RasterLayer'),
- function(x) {
- return(setRaster(x, values=is.na(.getRasterValues(x))))
- }
-)
-
-
-setMethod('dim', signature(x='Raster'),
- function(x){ return(c(nrow(x), ncol(x), nlayers(x)))}
-)
-
-setMethod('nrow', signature(x='Raster'),
- function(x){ return(x at nrows)}
-)
-
-setMethod('ncol', signature(x='Raster'),
- function(x){ return(x at ncols) }
-)
-
-
-
setMethod('summary', signature(object='Raster'),
function(object, ...) {
# to be replaces by something more typical for summary in R, i.e. a sumary of the raster values
Added: pkg/raster/R/stats.R
===================================================================
--- pkg/raster/R/stats.R (rev 0)
+++ pkg/raster/R/stats.R 2009-01-12 10:52:24 UTC (rev 122)
@@ -0,0 +1,53 @@
+# R miscellaneous stat functions
+# Authors: Robert J. Hijmans
+# International Rice Research Institute
+# contact: r.hijmans at gmail.com
+# Date : October 2008
+# Version 0,8
+# Licence GPL v3
+
+
+Mode <- function(x, ties='random', na.rm = TRUE) {
+#partly based on http://wiki.r-project.org/rwiki/doku.php?id=tips:stats-basic:modalvalue
+# ties are broken at random
+# earlier approach contained this
+# freq <- tapply(rep(0, length(x)), x, length)
+# w <- as.vector(which(freq == max(freq)) )
+# result <- as.numeric(dimnames(freq)[[1]][w])
+# return(result)
+ z <- x[!is.na(x)]
+ if (length(z) == 0) { return(NA)
+ } else if (na.rm == FALSE & length(z) < length(x)) { return(NA)
+ } else if (length(z) == 1) { return(z)
+ } else {
+ freq <- table(z)
+ w <- as.numeric(names(freq[max(freq)==freq]))
+ if (length(w) > 1) {
+ if (ties == 'lowest') {
+ w <- min(w)
+ } else if (ties == 'highest') {
+ w <- max(w)
+ } else if (ties == 'NA') {
+ w <- NA
+ } else { # random
+ r <- runif(length(w))
+ w <- w[which.max(r)]
+ }
+ }
+ return(w)
+ }
+}
+
+
+CV <- function(x, na.rm = TRUE, singlevalueaszero=TRUE) {
+# R function to compute the coefficient of variation (expressed as a percentage)
+# if there is only a single value, sd = NA. However, one could argue that cv =0. In this case a NA is returned if(singlevaluecvzero=FALSE)
+# else a value of 0 is returned.
+ z <- x[!is.na(x)]
+ if (length(z) == 0) { return(NA)
+ } else if (na.rm == FALSE & length(z) < length(x)) { return(NA)
+ } else if (length(z) == 1 & singlevalueaszero == TRUE) { return(0)
+ } else {
+ return(100 * sd(z) / mean(z))
+ }
+}
Modified: pkg/raster/man/bbox.Rd
===================================================================
--- pkg/raster/man/bbox.Rd 2009-01-12 10:29:32 UTC (rev 121)
+++ pkg/raster/man/bbox.Rd 2009-01-12 10:52:24 UTC (rev 122)
@@ -24,9 +24,9 @@
\item{xmx}{ the maximum x coordinate of the bounding box }
\item{ymn}{ the minimum y coordinate of the bounding box }
\item{ymx}{ the maximum y coordinate of the bounding box }
- \item{object} {A Raster* object }
+ \item{object}{A Raster* object }
\item{bndbox}{ An object of class BoundingBox (which you can create with newBbox() ) }
- \item{keepres} {logical. If \code{TRUE}, the resolution of the cells will stay the same after adjusting the bounding box (by adjusting the number of rows and columns). if \code{FALSE}, the number of rows and columns will stay the same, and the resolution will be adjusted}
+ \item{keepres}{logical. If \code{TRUE}, the resolution of the cells will stay the same after adjusting the bounding box (by adjusting the number of rows and columns). if \code{FALSE}, the number of rows and columns will stay the same, and the resolution will be adjusted}
}
\author{Robert J. Hijmans \email{r.hijmans at gmail.com}}
Modified: pkg/raster/man/calc.Rd
===================================================================
--- pkg/raster/man/calc.Rd 2009-01-12 10:29:32 UTC (rev 121)
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/raster -r 122
More information about the Raster-commits
mailing list