[Raster-commits] r400 - pkg/raster/R

[noreply at r-forge.r-project.org]

Author: rhijmans
Date: 2009-04-11 16:12:37 +0200 (Sat, 11 Apr 2009)
New Revision: 400

Added:
   pkg/raster/R/writeStack.R
Modified:
   pkg/raster/R/properties.R
   pkg/raster/R/setValues.R
   pkg/raster/R/valuesRow.R
   pkg/raster/R/write.R
Log:


Modified: pkg/raster/R/properties.R
===================================================================
--- pkg/raster/R/properties.R	2009-04-09 08:31:00 UTC (rev 399)
+++ pkg/raster/R/properties.R	2009-04-11 14:12:37 UTC (rev 400)
@@ -24,6 +24,7 @@
 }
 
 
+
 minValue <- function(object, layer=1) {
 	if (layer < 1) { 
 		return(NA)

Modified: pkg/raster/R/setValues.R
===================================================================
--- pkg/raster/R/setValues.R	2009-04-09 08:31:00 UTC (rev 399)
+++ pkg/raster/R/setValues.R	2009-04-11 14:12:37 UTC (rev 400)
@@ -57,7 +57,7 @@
 		object at data@source <- 'ram'
 		object at data@indices <- c(1, ncell(object))
 		object <- setMinMax(object)
-		return(object)	
+		return(object)
 	} else if (length(values) == ncol(object)) {
 		rownr <- round(rownr)
 		if (rownr < 1 | rownr > nrow(object)) {
@@ -69,10 +69,8 @@
 		lastcell <- cellFromRowCol(object, rownr=rownr, colnr=ncol(object))
 		object at data@indices <- c(firstcell, lastcell)
 		return(object)
-	} else if (length(values) / ncol(object) ) {
-		
 	} else {
-		stop("length(values) is not equal to ncell(object) or ncol(object)") 
+		stop("length(values) is not equal to ncell(object), or to ncol(object), or 1") 
 	}
  }
 )

Modified: pkg/raster/R/valuesRow.R
===================================================================
--- pkg/raster/R/valuesRow.R	2009-04-09 08:31:00 UTC (rev 399)
+++ pkg/raster/R/valuesRow.R	2009-04-11 14:12:37 UTC (rev 400)
@@ -4,6 +4,9 @@
 # Version 0.8
 # Licence GPL v3
 
+
+
+
 valuesRow <- function(object, rownr) {
 	if (dataContent(object) == 'nodata') {
 		stop('no values in memory. First read or set values')
@@ -18,6 +21,8 @@
 	if (!(validRow(object, rownr))) {
 		stop(paste(rownr,'is not a valid rownumber')) 
 	}
+	
+	
 	if (dataContent(object) == 'sparse') {
 		return (.valuesRow.sparse(object, rownr)) 
 	} else if (dataContent(object) == 'row') {
@@ -49,13 +54,13 @@
 	} else if (dataContent(object) == 'all'){
 		startcell <- cellFromRowCol(object, rownr, 1)
 		endcell <- startcell+ncol(object)-1
-		if (class(object) == 'objectStack') {
+		if (class(object) == 'RasterStack') {
 			return(values(object)[startcell:endcell,])
 		} else {	
 			return(values(object)[startcell:endcell])
 		}
 	} else {
-		stop('something is wrong with the objectLayer dataContent')
+		stop('something is wrong with the RasterLayer dataContent')
 	}
 }
 

Modified: pkg/raster/R/write.R
===================================================================
--- pkg/raster/R/write.R	2009-04-09 08:31:00 UTC (rev 399)
+++ pkg/raster/R/write.R	2009-04-11 14:12:37 UTC (rev 400)
@@ -48,10 +48,3 @@
 	}
 }	
 
-
-writeStack <- function(rstack, overwrite=FALSE) {
-	stop("not available yet")
-	for (i in 1:nlayers(rstack)) {
-		
-	}
-}

Added: pkg/raster/R/writeStack.R
===================================================================
--- pkg/raster/R/writeStack.R	                        (rev 0)
+++ pkg/raster/R/writeStack.R	2009-04-11 14:12:37 UTC (rev 400)
@@ -0,0 +1,71 @@
+# Author: Robert J. Hijmans, r.hijmans at gmail.com
+# International Rice Research Institute
+# Date :  April 2009
+# Version 0.8
+# Licence GPL v3
+
+writeStack <- function(rstack, bandorder='BIL', filename='', filetype='raster', datatype='FLT4S', overwrite=FALSE) {
+	if (!bandorder %in% c('BIL', 'BSQ', 'BIP')) {
+		stop("invalid bandorder, should be 'BIL', 'BSQ' or 'BIP'")
+	}
+	if (!datatype == 'raster') {
+		stop('only implemented for datatype=raster')
+	}
+
+	nl <- nlayers(rstack)
+	rout <- raster(rstack)
+	filename(rout) <- filename
+	rout at file@nbands <- nl
+	rout at file@bandorder <- bandorder
+	dataType(rout) <- datatype
+
+	if (bandorder=='BIL') {
+		ncol(rout) <- ncol(rout) * nl
+		if (dataContent(rstack) == 'all') {
+			for (r in 1:nrow(rstack)) {
+				rv <- valuesRow(rstack, r)
+				rout <- setValues(rout, as.vector(rv))
+				rout <- writeRaster(rout,  overwrite=overwrite)			
+			}
+		} else {
+			for (r in 1:nrow(rstack)) {
+				rstack <- readRow(rstack, r)
+				rout <- setValues(rout, as.vector(values(rstack)), r)
+				rout <- writeRaster(rout,  overwrite=overwrite)
+			}
+		}
+	} else 	if (bandorder=='BIP') {
+		ncol(rout) <- ncol(rout) * nl
+		if (dataContent(rstack) == 'all') {
+			sv <- as.vector(t(values(rstack)))
+			rout <- setValues(rout, sv)
+			rout <- writeRaster(rout, overwrite=overwrite)			
+		} else {
+			for (r in 1:nrow(rstack)) {
+				rstack <- readRow(rstack, r)
+				rout <- setValues(rout, as.vector(t(values(rstack))), r)
+				rout <- writeRaster(rout, overwrite=overwrite)
+			}
+		}
+	} else 	if (bandorder=='BSQ') {
+		nrow(rout) <- nrow(rout) * nl
+		if (dataContent(rstack) == 'all') {
+			rout <- setValues(rout, as.vector(values(rstack)))
+			rout <- writeRaster(rout, overwrite=overwrite)			
+		} else {
+			fakerow <- 0
+			for (i in 1:nl) {
+				sr <- asRasterLayer(rstack, i)
+				for (r in 1:nrow(sr)) {
+					fakerow <- fakerow + 1
+					sr <- readRow(sr, r)
+					rout <- setValues(rout, values(sr, r), fakerow)
+					rout <- writeRaster(rout, overwrite=overwrite)
+				}
+			}
+		}		
+	}
+	return(missing())
+}
+
+