[Raster-commits] r105 - pkg/raster/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Jan 8 07:31:28 CET 2009
Author: rhijmans
Date: 2009-01-08 07:31:28 +0100 (Thu, 08 Jan 2009)
New Revision: 105
Added:
pkg/raster/R/conversion.R
pkg/raster/R/raster.generic.functions.R
pkg/raster/R/standard.generic.functions.R
Removed:
pkg/raster/R/all.generic.functions.R
pkg/raster/R/raster.sp.R
Log:
more generic functions
Deleted: pkg/raster/R/all.generic.functions.R
===================================================================
--- pkg/raster/R/all.generic.functions.R 2009-01-08 06:30:26 UTC (rev 104)
+++ pkg/raster/R/all.generic.functions.R 2009-01-08 06:31:28 UTC (rev 105)
@@ -1,423 +0,0 @@
-# Authors: Robert J. Hijmans, r.hijmans at gmail.com and Jacob van Etten
-# International Rice Research Institute
-# Date : June 2008
-# Version 0,8
-# Licence GPL v3
-
-setAs('RasterLayer', 'SpatialGridDataFrame',
- function(from){ return(asSpGrid (from)) }
-)
-
-setAs('SpatialGridDataFrame', 'RasterBrick',
- function(from){ return(asRasterBrick (from)) }
-)
-
-setAs('SpatialGridDataFrame', 'RasterLayer',
- function(from){ return(asRasterLayer (from)) }
-)
-
-setMethod('==', signature(e1='AbstractRaster', e2='AbstractRaster'),
- function(e1,e2){
- cond <- compare(c(e1, e2), origin=TRUE, resolution=TRUE, rowcol=TRUE, projection=TRUE, slack=0.01, stopiffalse=FALSE)
-# c1 <- identical(ncol(e1), ncol(e2))
-# c2 <- identical(nrow(e1), nrow(e2))
-# c3 <- identical(boundingbox(e1), boundingbox(e2))
-# c4 <- identical(projection(e1),projection(e2))
-# cond <- c1 & c2 & c3 & c4
- return(cond)
- }
-)
-
-setMethod('!=', signature(e1='AbstractRaster', e2='AbstractRaster'),
- function(e1,e2){
- cond <- compare(c(e1, e2), origin=TRUE, resolution=TRUE, rowcol=TRUE, projection=TRUE, slack=0.01, stopiffalse=FALSE)
- return(!cond)
- }
-)
-
-
-.getvalues <- function(x) {
- if (dataContent(x) != 'all') {
- if (dataSource(x) == 'ram') {
- stop('no data on disk or in memory')
- } else {
- x <- readAll(x)
- }
- }
- return(values(x))
-}
-
-
-setMethod("[", "RasterLayer",
- function(x, i, j, ..., drop = TRUE) {
- if (!missing(drop)) { stop("don't supply drop: it needs to be FALSE anyway") }
- if (!missing(j)) { stop("can only set values with a single index (a vector)") }
- if (missing(i)) { return(x) }
- rs <- setRaster(x)
- rs <- setValues(rs, i)
- return(x)
- }
-)
-
-
-setMethod("Math", signature(x='RasterLayer'),
- function(x){
- v = callGeneric(.getvalues(x))
- rs <- setRaster(x)
- rs <- setValues(rs, v)
- return(rs)
- }
-)
-
-
-
-setMethod("Arith", signature(e1='RasterLayer', e2='RasterLayer'),
- function(e1, e2){
- v = callGeneric(.getvalues(e1), .getvalues(e2))
- rs <- setRaster(e1)
- rs <- setValues(rs, v)
- return(rs)
- }
-)
-
-setMethod("Arith", signature(e1='RasterLayer', e2='numeric'),
- function(e1, e2){
- v <- callGeneric(.getvalues(e1), e2)
- rs <- setRaster(e1)
- rs <- setValues(rs, v)
- return(rs)
- }
-)
-
-setMethod("max", signature(x='RasterLayer'),
- function(x, ..., na.rm=FALSE){
- obs <- list(...)
- if (length(obs) == 0) {
- return(x)
- } else {
- v <- .getvalues(x)
- for (i in 1:length(obs)) {
- if (class(obs[[1]]) == 'RasterLayer') {
- v <- pmax(v, .getvalues(obs[[i]]), na.rm=na.rm)
- } else if (is.atomic(obs[[1]])) {
- v <- pmax(v, rep(obs[[1]], ncells(x)), na.rm=na.rm)
- } else if (length(obs[[1]])==ncells(x)) {
- v <- pmax(v, obs[[1]], na.rm=na.rm)
- } else {
- stop(paste("I do not understand this argument:",obs[1]))
- }
- }
- rs <- setRaster(x)
- rs <- setValues(rs, v)
- return(rs)
- }
- }
-)
-
-
-setMethod("min", signature(x='RasterLayer'),
- function(x, ..., na.rm=FALSE){
- obs <- list(...)
- if (length(obs) == 0) {
- return(x)
- } else {
- v <- .getvalues(x)
- for (i in 1:length(obs)) {
- if (class(obs[[1]]) == 'RasterLayer') {
- v <- pmin(v, .getvalues(obs[[i]]), na.rm=na.rm)
- } else if (is.atomic(obs[[1]])) {
- v <- pmin(v, rep(obs[[1]], ncells(x)), na.rm=na.rm)
- } else if (length(obs[[1]])==ncells(x)) {
- v <- pmin(v, obs[[1]], na.rm=na.rm)
- } else {
- stop(paste("I do not understand this argument:",obs[1]))
- }
- }
- rs <- setRaster(x)
- rs <- setValues(rs, v)
- return(rs)
- }
- }
-)
-
-
-
-setMethod("sum", signature(x='RasterLayer'),
- function(x, ..., na.rm=FALSE){
- obs <- list(...)
- if (length(obs) == 0) {
- return(x)
- } else {
- v <- .getvalues(x)
- for (i in 1:length(obs)) {
- if (class(obs[[1]]) == 'RasterLayer') {
- v <- rowSums(cbind(v, .getvalues(obs[[i]]), na.rm=na.rm))
- } else if (is.atomic(obs[[1]])) {
- v <- rowSums(cbind(v, rep(obs[[1]], ncells(x)), na.rm=na.rm))
- } else if (length(obs[[1]])==ncells(x)) {
- v <- rowSums(cbind(v, obs[[1]], na.rm=na.rm))
- } else {
- stop(paste("I do not understand this argument:",obs[1]))
- }
- }
- rs <- setRaster(x)
- rs <- setValues(rs, v)
- return(rs)
- }
- }
-)
-
-#todo "any", "all"
-
-
-setMethod("range", signature(x='RasterLayer'),
- function(x, ..., na.rm=FALSE){
- mx <- max(x, ..., na.rm=na.rm)
- mn <- max(x, ..., na.rm=na.rm)
- rn <- mx - mn
- return(rn)
- }
-)
-
-setMethod("is.na", signature(x='RasterLayer'),
- function(x) {
- v <- is.na(.getvalues(x))
- rs <- setRaster(x)
- rs <- setValues(rs, v)
- return(rs)
- }
-)
-
-
-
-
-setMethod('dim', signature(x='AbstractRaster'),
- function(x){ return(c(nrow(x), ncol(x)))}
-)
-
-setMethod('dim', signature(x='RasterStack'),
- function(x){ return(c(nrow(x), ncol(x), nlayers(x)))}
-)
-
-setMethod('dim', signature(x='RasterBrick'),
- function(x){ return(c(nrow(x), ncol(x), nlayers(x)))}
-)
-
-setMethod('nrow', signature(x='AbstractRaster'),
- function(x){ return(x at nrows)}
-)
-
-setMethod('ncol', signature(x='AbstractRaster'),
- function(x){ return(x at ncols) }
-)
-
-
-if (!isGeneric("readAll")) {
- setGeneric("readAll", function(object)
- standardGeneric("readAll"))
-}
-setMethod('readAll', signature(object='RasterLayer'),
- function(object){ return(.rasterRead(object, -1))}
-)
-setMethod('readAll', signature(object='RasterStack'),
- function(object){ return(.stackRead(object, -1))}
-)
-
-
-if (!isGeneric("readRow")) {
- setGeneric("readRow", function(object, rownr)
- standardGeneric("readRow"))
-}
-setMethod('readRow', signature(object='RasterLayer'),
- function(object, rownr){ return(.rasterRead(object, rownr))}
-)
-setMethod('readRow', signature(object='RasterStack'),
- function(object, rownr){ return(.stackRead(object, rownr))}
-)
-
-
-if (!isGeneric("readRows")) {
- setGeneric("readRows", function(object, startrow, nrows=3)
- standardGeneric("readRows"))
-}
-
-setMethod('readRows', signature(object='RasterLayer'),
- function(object, startrow, nrows=3) {
- #read multiple rows
- return(.rasterReadBlock(object, startrow, nrows))
- }
-)
-
-
-
-if (!isGeneric("readBlock")) {
- setGeneric("readBlock", function(object, startrow, nrows=3, startcol=1, ncolumns=(ncol(object)-startcol+1))
- standardGeneric("readBlock"))
-}
-
-setMethod('readBlock', signature(object='RasterLayer'),
- function(object, startrow, nrows=3, startcol=1, ncolumns=(ncol(object)-startcol+1)) {
- return(.rasterReadBlock(object, startrow, nrows, ncolumns))}
-)
-
-if (!isGeneric("readPartOfRow")) {
- setGeneric("readPartOfRow", function(object, rownr, startcol=1, ncolumns=(ncol(object)-startcol+1))
- standardGeneric("readPartOfRow"))
-}
-
-setMethod('readPartOfRow', signature(object='RasterLayer'),
- function(object, rownr, startcol=1, ncolumns=(ncol(object)-startcol+1)) {
- return(.rasterRead(object, rownr, startcol, ncolumns))}
-)
-
-setMethod('readPartOfRow', signature(object='RasterStack'),
- function(object, rownr, startcol=1, ncolumns=(ncol(object)-startcol+1)) {
- return( .stackRead(object, rownr, startcol, ncolumns) ) }
-)
-
-if (!isGeneric("cellValues")) {
- setGeneric("cellValues", function(object, cells)
- standardGeneric("cellValues"))
-}
-
-setMethod("cellValues", signature(object='RasterLayer'),
- function(object, cells) {
- return(.rasterReadCells(object, cells))}
-)
-
-
-setMethod("cellValues", signature(object='RasterStack'),
- function(object, cells) {
- return(.stackReadCells(object, cells))}
-)
-
-if (!isGeneric("xyValues")) {
- setGeneric("xyValues", function(object, xy)
- standardGeneric("xyValues"))
-}
-
-setMethod("xyValues", signature(object='RasterLayer'),
- function(object, xy) {
- return(.rasterReadXY(object, xy))
- }
-)
-
-setMethod("xyValues", signature(object='RasterStack'),
- function(object, xy) {
- return(.stackReadXY(object, xy))}
-)
-
-
-
-setMethod('summary', signature(object='AbstractRaster'),
- function(object, ...) {
- # to be replaces by something more typical for summary in R, i.e. a sumary of the raster values
- cat ("Cells: " , ncells(object), '\n')
- if ( class(object) == "RasterLayer" ) {
- if ( dataContent(object) == "all") {
- cat("NAs : ", sum(is.na(values(object))), "\n")
- summary(values(object))
- } else {
- cat("values not in memory\n")
- }
- } else if (class(object) == "RasterStack" | class(object) == "RasterBrick") {
- if (dataContent(object) == 'all') {
- for (n in 1:nlayers(object)) {
- cat("layer ", n, "\n")
- cat("NAs : ", sum(is.na(values(object)[,n])), "\n")
- summary(values(object)[,n])
- }
- } else {
- cat("values not in memory\n")
- }
- }
- }
-)
-
-
-setMethod("plot", signature(x='RasterLayer', y='missing'),
- function(x, y, ...) {
- map(x, ...)
- }
-)
-
-
-setMethod("plot", signature(x='RasterStack', y='numeric'),
- function(x, y, ...) {
- ind <- as.integer(round(y))
- ind <- min(max(ind, 1), nlayers(x))
- map(x, ind, ...)
- }
-)
-
-
-setMethod("plot", signature(x='RasterBrick', y='numeric'),
- function(x, y, ...) {
- ind <- as.integer(round(y))
- ind <- min(max(ind, 1), nlayers(x))
- map(x, ind, ...)
- }
-)
-
-
-
-setMethod("plot", signature(x='RasterLayer', y='RasterLayer'),
- function(x, y, ...) {
- comp <- compare(c(x, y), origin=FALSE, resolution=FALSE, rowcol=TRUE, projection=FALSE, slack=0, stopiffalse=TRUE)
- if (dataContent(x) != 'all') {
- if (ncells(x) > 15000) {
- maxdim <- 200
- } else {
- maxdim <- 10000
- }
- x <- readSkip(x, maxdim=maxdim)
- if (x != y) {
- warning(paste('plot used a sample of ', round(100*ncells(x)/ncells(y)), "% of the cells", sep=""))
- }
- y <- readSkip(y, maxdim=maxdim)
- x <- values(x)
- y <- values(y)
- plot(x, y, cex=0.1, ...)
- } else {
- maxcell <- 15000
- if (length(na.omit(values(x))) > maxcell) {
- v <- na.omit(cbind(values(x), values(y)))
- r <- order(runif(length(v[,1])))
- v <- v[r,]
- l <- min(maxcell, length(v))
- v <- v[1:l,]
- warning(paste("plot used a sample of ", l, " cells (with data; ", maxcell, " when counting NA cells)", sep=""))
- x <- v[,1]
- y <- v[,2]
- plot(x, y, cex=0.1, ...)
- }
- }
- }
-)
-
-
-setMethod('hist', signature(x='RasterLayer'),
- function(x, ...){
- maxsamp <- 1000000
- if (dataContent(x) != 'all') {
- if (dataSource(x) == 'disk') {
- # TO DO: ake a function that does this by block and combines all data into a single histogram
- if (ncells(x) <= maxsamp) {
- values <- na.omit(values(readAll(x)))
- } else {
- values <- readRandom(x, maxsamp)
- msg <- paste(round(100 * maxsamp / ncells(x)), "% of the raster cells were used", sep="")
- if (maxsamp > length(values)) {
- msg <- paste(msg, " (of which ", 100 - round(100 * length(values) / maxsamp ), "% were NA)", sep="")
- }
- msg <- paste(msg, ". ",length(values)," values used.", sep="")
- warning(msg)
- }
- } else { stop('cannot make a histogram; need data on disk or in memory')}
- } else {
- values <- values(x)
- }
- hist(values, ...)
- }
-)
-
Added: pkg/raster/R/conversion.R
===================================================================
--- pkg/raster/R/conversion.R (rev 0)
+++ pkg/raster/R/conversion.R 2009-01-08 06:31:28 UTC (rev 105)
@@ -0,0 +1,101 @@
+
+setAs('RasterLayer', 'SpatialGridDataFrame',
+ function(from){ return(asSpGrid (from)) }
+)
+
+setAs('SpatialGridDataFrame', 'RasterBrick',
+ function(from){ return(asRasterBrick (from)) }
+)
+
+setAs('SpatialGridDataFrame', 'RasterLayer',
+ function(from){ return(asRasterLayer (from)) }
+)
+
+setAs('RasterBrick', 'RasterLayer',
+ function(from){ return(asRasterLayer (from)) }
+)
+
+setAs('RasterStack', 'RasterLayer',
+ function(from){ return(asRasterLayer (from)) }
+)
+
+
+asRasterLayer <- function(object, dataindex=1) {
+ if (class(object) == 'RasterLayer') {
+ return(object)
+ } else if (class(object) == 'RasterBrick' | class(object) == 'RasterStack') {
+ rs <- newRaster(xmn = xmin(object), xmx = xmax(object), ymn = ymin(object), ymx = ymax(object), nrows=nrow(object), ncols=ncol(object), projstring=projection(object))
+ return(rs)
+ } else { # assuming an SP raster
+ raster <- newRaster()
+ raster at bbox <- object at bbox
+ raster at proj4string <- object at proj4string
+ raster at ncols <- object at grid@cells.dim[1]
+ raster at nrows <- object at grid@cells.dim[2]
+ if (class(object)=='SpatialPixels') {
+ # do noting, there is no data
+ # we could store the indices, but then we would have a sparse raster with no data (or with NAs). That goes against our definition of sparse (all NAs have been removed)
+ } else if (class(object)=='SpatialPixelsDataFrame') {
+ cells <- object at grid.index
+ if (length(cells)==0) {
+ cells <- cellFromXY(raster, object at coords)
+ }
+ vals <- object at data[[dataindex]]
+ raster <- setValuesSparse(raster, cells, vals)
+ } else if ( class(object)=='SpatialGrid' ) {
+ # do nothing, there is no data
+ } else if (class(object)=='SpatialGridDataFrame' ) {
+ raster <- setValues(raster, object at data[[dataindex]])
+ }
+ return(raster)
+ }
+}
+
+
+asRasterBrick <- function(spgrid) {
+ brick <- newBrick()
+ brick at bbox <- spgrid at bbox
+ brick at proj4string <- spgrid at proj4string
+ brick at ncols <- spgrid at grid@cells.dim[1]
+ brick at nrows <- spgrid at grid@cells.dim[2]
+ if (class(spgrid)=='SpatialPixels') {
+ # do noting, there is no data
+ # we could store the indices, but then we would have a sparse raster with no data (or with NAs). That goes against our definition of sparse (all NAs have been removed)
+ } else if (class(spgrid)=='SpatialPixelsDataFrame') {
+ cells <- spgrid at grid.index
+ if (length(cells)==0) {
+ cells <- cellFromXY(brick, spgrid at coords)
+ }
+ vals <- as.matrix(spgrid at data)
+ brick <- setValuesSparse(brick, cells, vals)
+ } else if ( class(spgrid)=='SpatialGrid' ) {
+ # do nothing, there is no data
+ } else if (class(spgrid)=='SpatialGridDataFrame' ) {
+ brick <- setValues(brick, as.matrix(spgrid at data))
+ }
+ return(brick)
+}
+
+
+asSpGrid <- function(raster, type='grid') {
+ bb <- boundingbox(raster)
+ cs <- resolution(raster)
+ cc <- bb[,1] + (cs/2)
+ cd <- ceiling(diff(t(bb))/cs)
+ grd <- GridTopology(cellcentre.offset=cc, cellsize=cs, cells.dim=cd)
+ if (type=='pixel') {
+ raster <- makeSparse(raster)
+ pts <- SpatialPoints(xyFromCell(raster, dataIndices(raster)))
+ sp <- SpatialPixelsDataFrame(points=pts, data=as.data.frame(values(raster)), proj4string=projection(raster, FALSE))
+
+ } else if (type=='grid') {
+ if ( dataContent(raster) == 'all') {
+ values <- as.data.frame(values(raster))
+ sp <- SpatialGridDataFrame(grd, proj4string=projection(raster, FALSE), data=values)
+ } else {
+ sp <- SpatialGrid(grd, proj4string=projection(raster, FALSE))
+ }
+ }
+ return(sp)
+}
+
Added: pkg/raster/R/raster.generic.functions.R
===================================================================
--- pkg/raster/R/raster.generic.functions.R (rev 0)
+++ pkg/raster/R/raster.generic.functions.R 2009-01-08 06:31:28 UTC (rev 105)
@@ -0,0 +1,96 @@
+
+if (!isGeneric("readAll")) {
+ setGeneric("readAll", function(object)
+ standardGeneric("readAll"))
+}
+setMethod('readAll', signature(object='RasterLayer'),
+ function(object){ return(.rasterRead(object, -1))}
+)
+setMethod('readAll', signature(object='RasterStack'),
+ function(object){ return(.stackRead(object, -1))}
+)
+
+
+if (!isGeneric("readRow")) {
+ setGeneric("readRow", function(object, rownr)
+ standardGeneric("readRow"))
+}
+setMethod('readRow', signature(object='RasterLayer'),
+ function(object, rownr){ return(.rasterRead(object, rownr))}
+)
+setMethod('readRow', signature(object='RasterStack'),
+ function(object, rownr){ return(.stackRead(object, rownr))}
+)
+
+
+if (!isGeneric("readRows")) {
+ setGeneric("readRows", function(object, startrow, nrows=3)
+ standardGeneric("readRows"))
+}
+
+setMethod('readRows', signature(object='RasterLayer'),
+ function(object, startrow, nrows=3) {
+ #read multiple rows
+ return(.rasterReadBlock(object, startrow, nrows))
+ }
+)
+
+
+
+if (!isGeneric("readBlock")) {
+ setGeneric("readBlock", function(object, startrow, nrows=3, startcol=1, ncolumns=(ncol(object)-startcol+1))
+ standardGeneric("readBlock"))
+}
+
+setMethod('readBlock', signature(object='RasterLayer'),
+ function(object, startrow, nrows=3, startcol=1, ncolumns=(ncol(object)-startcol+1)) {
+ return(.rasterReadBlock(object, startrow, nrows, ncolumns))}
+)
+
+if (!isGeneric("readPartOfRow")) {
+ setGeneric("readPartOfRow", function(object, rownr, startcol=1, ncolumns=(ncol(object)-startcol+1))
+ standardGeneric("readPartOfRow"))
+}
+
+setMethod('readPartOfRow', signature(object='RasterLayer'),
+ function(object, rownr, startcol=1, ncolumns=(ncol(object)-startcol+1)) {
+ return(.rasterRead(object, rownr, startcol, ncolumns))}
+)
+
+setMethod('readPartOfRow', signature(object='RasterStack'),
+ function(object, rownr, startcol=1, ncolumns=(ncol(object)-startcol+1)) {
+ return( .stackRead(object, rownr, startcol, ncolumns) ) }
+)
+
+if (!isGeneric("cellValues")) {
+ setGeneric("cellValues", function(object, cells)
+ standardGeneric("cellValues"))
+}
+
+setMethod("cellValues", signature(object='RasterLayer'),
+ function(object, cells) {
+ return(.rasterReadCells(object, cells))}
+)
+
+
+setMethod("cellValues", signature(object='RasterStack'),
+ function(object, cells) {
+ return(.stackReadCells(object, cells))}
+)
+
+if (!isGeneric("xyValues")) {
+ setGeneric("xyValues", function(object, xy)
+ standardGeneric("xyValues"))
+}
+
+setMethod("xyValues", signature(object='RasterLayer'),
+ function(object, xy) {
+ return(.rasterReadXY(object, xy))
+ }
+)
+
+setMethod("xyValues", signature(object='RasterStack'),
+ function(object, xy) {
+ return(.stackReadXY(object, xy))}
+)
+
Deleted: pkg/raster/R/raster.sp.R
===================================================================
--- pkg/raster/R/raster.sp.R 2009-01-08 06:30:26 UTC (rev 104)
+++ pkg/raster/R/raster.sp.R 2009-01-08 06:31:28 UTC (rev 105)
@@ -1,77 +0,0 @@
-
-asRasterLayer <- function(spgrid, getdata=TRUE, dataindex=1) {
- raster <- newRaster()
- raster at bbox <- spgrid at bbox
- raster at proj4string <- spgrid at proj4string
- raster at ncols <- spgrid at grid@cells.dim[1]
- raster at nrows <- spgrid at grid@cells.dim[2]
- if (getdata) {
- if (class(spgrid)=='SpatialPixels') {
- # do noting, there is no data
- # we could store the indices, but then we would have a sparse raster with no data (or with NAs). That goes against our definition of sparse (all NAs have been removed)
- } else if (class(spgrid)=='SpatialPixelsDataFrame') {
- cells <- spgrid at grid.index
- if (length(cells)==0) {
- cells <- cellFromXY(raster, spgrid at coords)
- }
- vals <- spgrid at data[[dataindex]]
- raster <- setValuesSparse(raster, cells, vals)
- } else if ( class(spgrid)=='SpatialGrid' ) {
- # do nothing, there is no data
- } else if (class(spgrid)=='SpatialGridDataFrame' ) {
- raster <- setValues(raster, spgrid at data[[dataindex]])
- }
- }
- return(raster)
-}
-
-
-asRasterBrick <- function(spgrid, getdata=TRUE) {
- brick <- newBrick()
- brick at bbox <- spgrid at bbox
- brick at proj4string <- spgrid at proj4string
- brick at ncols <- spgrid at grid@cells.dim[1]
- brick at nrows <- spgrid at grid@cells.dim[2]
- if (getdata) {
- if (class(spgrid)=='SpatialPixels') {
- # do noting, there is no data
- # we could store the indices, but then we would have a sparse raster with no data (or with NAs). That goes against our definition of sparse (all NAs have been removed)
- } else if (class(spgrid)=='SpatialPixelsDataFrame') {
- cells <- spgrid at grid.index
- if (length(cells)==0) {
- cells <- cellFromXY(brick, spgrid at coords)
- }
- vals <- as.matrix(spgrid at data)
- brick <- setValuesSparse(brick, cells, vals)
- } else if ( class(spgrid)=='SpatialGrid' ) {
- # do nothing, there is no data
- } else if (class(spgrid)=='SpatialGridDataFrame' ) {
- brick <- setValues(brick, as.matrix(spgrid at data))
- }
- }
- return(brick)
-}
-
-
-asSpGrid <- function(raster, type='grid') {
- bb <- boundingbox(raster)
- cs <- resolution(raster)
- cc <- bb[,1] + (cs/2)
- cd <- ceiling(diff(t(bb))/cs)
- grd <- GridTopology(cellcentre.offset=cc, cellsize=cs, cells.dim=cd)
- if (type=='pixel') {
- raster <- makeSparse(raster)
- pts <- SpatialPoints(xyFromCell(raster, dataIndices(raster)))
- sp <- SpatialPixelsDataFrame(points=pts, data=as.data.frame(values(raster)), proj4string=projection(raster, FALSE))
-
- } else if (type=='grid') {
- if ( dataContent(raster) == 'all') {
- values <- as.data.frame(values(raster))
- sp <- SpatialGridDataFrame(grd, proj4string=projection(raster, FALSE), data=values)
- } else {
- sp <- SpatialGrid(grd, proj4string=projection(raster, FALSE))
- }
- }
- return(sp)
-}
-
Added: pkg/raster/R/standard.generic.functions.R
===================================================================
--- pkg/raster/R/standard.generic.functions.R (rev 0)
+++ pkg/raster/R/standard.generic.functions.R 2009-01-08 06:31:28 UTC (rev 105)
@@ -0,0 +1,306 @@
+# Authors: Robert J. Hijmans, r.hijmans at gmail.com and Jacob van Etten
+# International Rice Research Institute
+# Date : June 2008
+# Version 0,8
+# Licence GPL v3
+
+
+
+
+setMethod('==', signature(e1='AbstractRaster', e2='AbstractRaster'),
+ function(e1,e2){
+ cond <- compare(c(e1, e2), origin=TRUE, resolution=TRUE, rowcol=TRUE, projection=TRUE, slack=0.01, stopiffalse=FALSE)
+# c1 <- identical(ncol(e1), ncol(e2))
+# c2 <- identical(nrow(e1), nrow(e2))
+# c3 <- identical(boundingbox(e1), boundingbox(e2))
+# c4 <- identical(projection(e1),projection(e2))
+# cond <- c1 & c2 & c3 & c4
+ return(cond)
+ }
+)
+
+setMethod('!=', signature(e1='AbstractRaster', e2='AbstractRaster'),
+ function(e1,e2){
+ cond <- compare(c(e1, e2), origin=TRUE, resolution=TRUE, rowcol=TRUE, projection=TRUE, slack=0.01, stopiffalse=FALSE)
+ return(!cond)
+ }
+)
+
+
+.getValues <- function(x) {
+# need to take care of 'spase'
+ if (dataContent(x) != 'all') {
+ if (dataSource(x) == 'ram') {
+ stop('no data on disk or in memory')
+ } else {
+ x <- readAll(x)
+ }
+ }
+ return(values(x))
+}
+
+.getLogicalValues <- function(x) {
+ v <- .getValues(x)
+ v[v<0] <- 0
+ v[v>0] <- 1
+ return(v)
+}
+
+
+setMethod("[", "RasterLayer",
+ function(x, i, j, ..., drop = TRUE) {
+ if (!missing(drop)) { stop("don't supply drop: it needs to be FALSE anyway") }
+ if (!missing(j)) { stop("can only set values with a single index (a vector)") }
+ if (missing(i)) { return(x) }
+ return(setRaster(x, values=i))
+ }
+)
+
+
+setMethod("Math", signature(x='RasterLayer'),
+ function(x){
+ return(setRaster(x, values=callGeneric(.getValues(x))))
+ }
+)
+
+setMethod("Logic", signature(e1='RasterLayer', e2='RasterLayer'),
+ function(e1, e2){
+ return(setRaster(e1, values=callGeneric(.getLogicalValues(e1), .getLogicalValues(e2))))
+ }
+)
+
+setMethod("Arith", signature(e1='RasterLayer', e2='RasterLayer'),
+ function(e1, e2){
+ return(setRaster(e1, values=callGeneric(.getValues(e1), .getValues(e2))))
+ }
+)
+
+setMethod("Arith", signature(e1='RasterLayer', e2='numeric'),
+ function(e1, e2){
+ return(setRaster(e1, values=callGeneric(.getValues(e1), e2)))
+ }
+)
+
+setMethod("max", signature(x='RasterLayer'),
+ function(x, ..., na.rm=FALSE){
+ obs <- list(...)
+ if (length(obs) == 0) {
+ return(x)
+ } else {
+ v <- .getValues(x)
+ for (i in 1:length(obs)) {
+ if (class(obs[[1]]) == 'RasterLayer') {
+ v <- pmax(v, .getValues(obs[[i]]), na.rm=na.rm)
+ } else if (is.atomic(obs[[1]])) {
+ v <- pmax(v, rep(obs[[1]], ncells(x)), na.rm=na.rm)
+ } else if (length(obs[[1]])==ncells(x)) {
+ v <- pmax(v, obs[[1]], na.rm=na.rm)
+ } else {
+ stop(paste("I do not understand this argument:",obs[1]))
+ }
+ }
+ return(setRaster(x, values=v))
+ }
+ }
+)
+
+
+setMethod("min", signature(x='RasterLayer'),
+ function(x, ..., na.rm=FALSE){
+ obs <- list(...)
+ if (length(obs) == 0) {
+ return(x)
+ } else {
+ v <- .getValues(x)
+ for (i in 1:length(obs)) {
+ if (class(obs[[1]]) == 'RasterLayer') {
+ v <- pmin(v, .getValues(obs[[i]]), na.rm=na.rm)
+ } else if (is.atomic(obs[[1]])) {
+ v <- pmin(v, rep(obs[[1]], ncells(x)), na.rm=na.rm)
+ } else if (length(obs[[1]])==ncells(x)) {
+ v <- pmin(v, obs[[1]], na.rm=na.rm)
+ } else {
+ stop(paste("I do not understand this argument:",obs[1]))
+ }
+ }
+ return(setRaster(x, values=v))
+ }
+ }
+)
+
+
+
+setMethod("sum", signature(x='RasterLayer'),
+ function(x, ..., na.rm=FALSE){
+ obs <- list(...)
+ if (length(obs) == 0) {
+ return(x)
+ } else {
+ v <- .getValues(x)
+ for (i in 1:length(obs)) {
+ if (class(obs[[1]]) == 'RasterLayer') {
+ v <- rowSums(cbind(v, .getValues(obs[[i]]), na.rm=na.rm))
+ } else if (is.atomic(obs[[1]])) {
+ v <- rowSums(cbind(v, rep(obs[[1]], ncells(x)), na.rm=na.rm))
+ } else if (length(obs[[1]])==ncells(x)) {
+ v <- rowSums(cbind(v, obs[[1]], na.rm=na.rm))
+ } else {
+ stop(paste("I do not understand this argument:",obs[1]))
+ }
+ }
+ return(setRaster(x, values=v))
+ }
+ }
+)
+
+#todo "any", "all"
+
+
+setMethod("range", signature(x='RasterLayer'),
+ 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(.getValues(x))))
+ }
+)
+
+
+setMethod('dim', signature(x='AbstractRaster'),
+ function(x){ return(c(nrow(x), ncol(x)))}
+)
+
+setMethod('dim', signature(x='RasterStack'),
+ function(x){ return(c(nrow(x), ncol(x), nlayers(x)))}
+)
+
+setMethod('dim', signature(x='RasterBrick'),
+ function(x){ return(c(nrow(x), ncol(x), nlayers(x)))}
+)
+
+setMethod('nrow', signature(x='AbstractRaster'),
+ function(x){ return(x at nrows)}
+)
+
+setMethod('ncol', signature(x='AbstractRaster'),
+ function(x){ return(x at ncols) }
+)
+
+
+
+
+setMethod('summary', signature(object='AbstractRaster'),
+ function(object, ...) {
+ # to be replaces by something more typical for summary in R, i.e. a sumary of the raster values
+ cat ("Cells: " , ncells(object), '\n')
+ if ( class(object) == "RasterLayer" ) {
+ if ( dataContent(object) == "all") {
+ cat("NAs : ", sum(is.na(values(object))), "\n")
+ summary(values(object))
+ } else {
+ cat("values not in memory\n")
+ }
+ } else if (class(object) == "RasterStack" | class(object) == "RasterBrick") {
+ if (dataContent(object) == 'all') {
+ for (n in 1:nlayers(object)) {
+ cat("layer ", n, "\n")
+ cat("NAs : ", sum(is.na(values(object)[,n])), "\n")
+ summary(values(object)[,n])
+ }
+ } else {
+ cat("values not in memory\n")
+ }
+ }
+ }
+)
+
+
+setMethod("plot", signature(x='RasterLayer', y='missing'),
+ function(x, y, ...) {
+ map(x, ...)
+ }
+)
+
+
+setMethod("plot", signature(x='RasterStack', y='numeric'),
+ function(x, y, ...) {
+ ind <- as.integer(round(y))
+ ind <- min(max(ind, 1), nlayers(x))
+ map(x, ind, ...)
+ }
+)
+
+
+setMethod("plot", signature(x='RasterBrick', y='numeric'),
+ function(x, y, ...) {
+ ind <- as.integer(round(y))
+ ind <- min(max(ind, 1), nlayers(x))
+ map(x, ind, ...)
+ }
+)
+
+
+
+setMethod("plot", signature(x='RasterLayer', y='RasterLayer'),
+ function(x, y, ...) {
+ comp <- compare(c(x, y), origin=FALSE, resolution=FALSE, rowcol=TRUE, projection=FALSE, slack=0, stopiffalse=TRUE)
+ if (dataContent(x) != 'all') {
+ if (ncells(x) > 15000) {
+ maxdim <- 200
+ } else {
+ maxdim <- 10000
+ }
+ x <- readSkip(x, maxdim=maxdim)
+ if (x != y) {
+ warning(paste('plot used a sample of ', round(100*ncells(x)/ncells(y)), "% of the cells", sep=""))
+ }
+ y <- readSkip(y, maxdim=maxdim)
+ x <- values(x)
+ y <- values(y)
+ plot(x, y, cex=0.1, ...)
+ } else {
+ maxcell <- 15000
+ if (length(na.omit(values(x))) > maxcell) {
+ v <- na.omit(cbind(values(x), values(y)))
+ r <- order(runif(length(v[,1])))
+ v <- v[r,]
+ l <- min(maxcell, length(v))
+ v <- v[1:l,]
+ warning(paste("plot used a sample of ", l, " cells (with data; ", maxcell, " when counting NA cells)", sep=""))
+ x <- v[,1]
+ y <- v[,2]
+ plot(x, y, cex=0.1, ...)
+ }
+ }
+ }
+)
+
+
+setMethod('hist', signature(x='RasterLayer'),
+ function(x, ...){
+ maxsamp <- 1000000
+ if (dataContent(x) != 'all') {
+ if (dataSource(x) == 'disk') {
+ # TO DO: ake a function that does this by block and combines all data into a single histogram
+ if (ncells(x) <= maxsamp) {
+ values <- na.omit(values(readAll(x)))
+ } else {
+ values <- readRandom(x, maxsamp)
+ msg <- paste(round(100 * maxsamp / ncells(x)), "% of the raster cells were used", sep="")
+ if (maxsamp > length(values)) {
+ msg <- paste(msg, " (of which ", 100 - round(100 * length(values) / maxsamp ), "% were NA)", sep="")
+ }
+ msg <- paste(msg, ". ",length(values)," values used.", sep="")
+ warning(msg)
+ }
+ } else { stop('cannot make a histogram; need data on disk or in memory')}
+ } else {
+ values <- values(x)
+ }
+ hist(values, ...)
+ }
+)
+
More information about the Raster-commits
mailing list