[Raster-commits] r127 - in pkg/raster: R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Jan 13 07:53:41 CET 2009
Author: jacobvanetten
Date: 2009-01-13 07:53:41 +0100 (Tue, 13 Jan 2009)
New Revision: 127
Added:
pkg/raster/R/adjacency.R
pkg/raster/man/adjacency.Rd
Log:
adjacency added
Added: pkg/raster/R/adjacency.R
===================================================================
--- pkg/raster/R/adjacency.R (rev 0)
+++ pkg/raster/R/adjacency.R 2009-01-13 06:53:41 UTC (rev 127)
@@ -0,0 +1,234 @@
+# Author: Jacob van Etten jacobvanetten at yahoo.com
+# International Rice Research Institute
+# Date : January 2009
+# Version 1.0
+# Licence GPL v3
+
+.cs <- function(a,b)
+{
+ aRep <- rep(a,times=length(b))
+ out <- cbind(aRep,as.integer(aRep+rep(b,each=length(a))),deparse.level=0)
+ return(out)
+}
+
+#Costumized (internal) functions can be created for each number of directions and for upper, middle and lower rows to optimize the code for row-level processing. 32 directions can be created if higher precision is needed.
+
+adjacency <- function(raster, fromCells, toCells, directions, outerMeridianConnect)
+{
+ nCols <- ncols(raster)
+ nCells <- ncells(raster)
+
+ left <- seq(nCols+1,(nCells-2*nCols+1),by=nCols)
+ right <- seq(2*nCols,nCells-nCols,by=nCols)
+ upper <- 2:(nCols-1)
+ lower <- seq((nCells-nCols+2),(nCells-1),by=1)
+ upperleft <- 1
+ upperright <- nCols
+ lowerleft <- nCells-nCols+1
+ lowerright <- nCells
+
+ fromCellsCore <- as.integer(setdiff(fromCells,(c(left,right,upper,lower,upperleft,upperright,lowerleft,lowerright))))
+ fromCellsUpper <- as.integer(intersect(fromCells,upper))
+ fromCellsLower <- as.integer(intersect(fromCells,lower))
+ fromCellsLeft <- as.integer(intersect(fromCells,left))
+ fromCellsRight <- as.integer(intersect(fromCells,right))
+ fromCellUpperleft <- as.integer(intersect(fromCells,upperleft))
+ fromCellUpperright <- as.integer(intersect(fromCells,upperright))
+ fromCellLowerleft <- as.integer(intersect(fromCells,lowerleft))
+ fromCellLowerright <- as.integer(intersect(fromCells,lowerright))
+
+ rook <- c(1,-1,nCols,-nCols)
+
+ coreFromToRook <- .cs(fromCellsCore,rook)
+ upperFromToRook <- .cs(fromCellsUpper,rook[1:3])
+ lowerFromToRook <- .cs(fromCellsLower,rook[c(1,2,4)])
+ leftFromToRook <- .cs(fromCellsLeft,rook[c(1,3,4)])
+ rightFromToRook <- .cs(fromCellsRight,rook[2:4])
+ upperleftFromToRook <- .cs(fromCellUpperleft,rook[c(1,3)])
+ upperrightFromToRook <- .cs(fromCellUpperright,rook[2:3])
+ lowerleftFromToRook <- .cs(fromCellLowerleft,rook[c(1,4)])
+ lowerrightFromToRook <- .cs(fromCellLowerright,rook[c(2,4)])
+ fromto1 <- rbind(coreFromToRook,upperFromToRook,lowerFromToRook,leftFromToRook,rightFromToRook,upperleftFromToRook,upperrightFromToRook,lowerleftFromToRook,lowerrightFromToRook)
+
+ if (outerMeridianConnect)
+ {
+ meridianFromLeft <- rbind(
+ cbind(fromCellsLeft,as.integer(fromCellsLeft+nCols-1)),
+ cbind(fromCellUpperleft,as.integer(fromCellUpperleft+nCols-1)),
+ cbind(fromCellLowerleft,as.integer(fromCellLowerleft+nCols-1))
+ )
+ meridianFromRight <- rbind(
+ cbind(fromCellsRight,as.integer(fromCellsRight-nCols+1)),
+ cbind(fromCellUpperright,as.integer(fromCellUpperright-nCols+1)),
+ cbind(fromCellLowerright,as.integer(fromCellLowerright-nCols+1))
+ )
+ fromto1 <- rbind(fromto1,meridianFromLeft,meridianFromRight)
+ }
+ else{}
+ fromto <- subset(fromto1,fromto1[,2] %in% toCells)
+
+ if(directions > 4)
+ {
+ bishop <- as.integer(c(-nCols-1, -nCols+1, nCols-1,+nCols+1))
+
+ coreFromToBishop <- .cs(fromCellsCore,bishop)
+ upperFromToBishop <- .cs(fromCellsUpper,bishop[3:4])
+ lowerFromToBishop <- .cs(fromCellsLower,bishop[1:2])
+ leftFromToBishop <- .cs(fromCellsLeft,bishop[c(2,4)])
+ rightFromToBishop <- .cs(fromCellsRight,bishop[c(1,3)])
+ upperleftFromToBishop <- .cs(fromCellUpperleft,bishop[4])
+ upperrightFromToBishop <- .cs(fromCellUpperright,bishop[3])
+ lowerleftFromToBishop <- .cs(fromCellLowerleft,bishop[2])
+ lowerrightFromToBishop <- .cs(fromCellLowerright,bishop[1])
+
+ fromto2 <- rbind(coreFromToBishop,upperFromToBishop,lowerFromToBishop,leftFromToBishop,rightFromToBishop,upperleftFromToBishop,upperrightFromToBishop,lowerleftFromToBishop,lowerrightFromToBishop)
+
+ if (outerMeridianConnect)
+ {
+ meridianFromLeft <- rbind(
+ .cs(fromCellsLeft,c(2*nCols-1,-1)),
+ cbind(fromCellUpperleft,as.integer(fromCellUpperleft+2*nCols-1)),
+ cbind(fromCellLowerleft,as.integer(fromCellLowerleft-1))
+ )
+ meridianFromRight <- rbind(
+ cbind(rep(fromCellsRight,times=2),as.integer(c(fromCellsRight-2*nCols+1,fromCellsRight+1))),
+ cbind(fromCellUpperright,as.integer(fromCellUpperright+1)),
+ cbind(fromCellLowerright,as.integer(fromCellLowerright-2*nCols+1))
+ )
+ fromto2 <- rbind(fromto2,meridianFromLeft,meridianFromRight)
+ }
+ else{}
+ fromto2 <- subset(fromto2,fromto2[,2] %in% toCells)
+ fromto <- rbind(fromto,fromto2)
+ }
+ else{}
+ if(directions > 8)
+ {
+
+ leftOuter <- seq(2*nCols+1,nCells-3*nCols+1,by=nCols)
+ rightOuter <- seq(3*nCols,nCells-2*nCols,by=nCols)
+ upperOuter <- seq(3,nCols-2,by=1)
+ lowerOuter <- seq(nCells-nCols+3,nCells-2,by=1)
+
+ upperleftUnder <- nCols+1
+ upperrightLeft <- nCols-1
+ lowerleftUp <- nCells-2*nCols+1
+ lowerrightUp <- nCells-nCols
+ upperleftRight <- 2
+ upperrightUnder <- 2*nCols
+ lowerleftRight <- nCells-nCols+2
+ lowerrightLeft <- nCells-1
+
+ leftInner <- seq(2*nCols+2,(nCells-3*nCols+2),by=nCols)
+ rightInner <- seq(3*nCols-1,nCells-2*nCols-1,by=nCols)
+ upperInner <- seq(nCols+3,2*nCols-2,by=1)
+ lowerInner <- seq(nCells-2*nCols+3,nCells-nCols-2,by=1)
+
+ upperleftInner <- nCols+2
+ upperrightInner <- 2*nCols-1
+ lowerleftInner <- nCells-2*nCols+2
+ lowerrightInner <- nCells-nCols-1
+
+ fromCellsCoreInner <- setdiff(fromCells,(c(leftOuter,rightOuter,upperOuter,lowerOuter,upperleft,upperright,lowerleft,lowerright, upperleftUnder, upperrightLeft, lowerleftUp, lowerrightUp, upperleftRight, upperrightUnder, lowerleftRight, lowerrightLeft, leftInner, rightInner, upperInner, lowerInner, upperleftInner, upperrightInner, lowerleftInner, lowerrightInner)))
+
+ fromCellsUpperInner <- as.integer(intersect(fromCells,upperInner))
+ fromCellsLowerInner <- as.integer(intersect(fromCells,lowerInner))
+ fromCellsLeftInner <- as.integer(intersect(fromCells,leftInner))
+ fromCellsRightInner <- as.integer(intersect(fromCells,rightInner))
+
+ fromCellUpperleftInner <- as.integer(intersect(fromCells,upperleftInner))
+ fromCellUpperrightInner <- as.integer(intersect(fromCells,upperrightInner))
+ fromCellLowerleftInner <- as.integer(intersect(fromCells,lowerleftInner))
+ fromCellLowerrightInner <- as.integer(intersect(fromCells,lowerrightInner))
+
+ fromCellsLeftOuter <- as.integer(intersect(fromCells,leftOuter))
+ fromCellsRightOuter <- as.integer(intersect(fromCells,rightOuter))
+ fromCellsUpperOuter <- as.integer(intersect(fromCells,upperOuter))
+ fromCellsLowerOuter <- as.integer(intersect(fromCells,lowerOuter))
+
+ fromCellUpperleftUnder <- as.integer(intersect(fromCells,upperleftUnder))
+ fromCellUpperrightLeft <- as.integer(intersect(fromCells,upperrightLeft))
+ fromCellLowerleftUp <- as.integer(intersect(fromCells,lowerleftUp))
+ fromCellLowerrightUp <- as.integer(intersect(fromCells,lowerrightUp))
+ fromCellUpperleftRight <- as.integer(intersect(fromCells,upperleftRight))
+ fromCellUpperrightUnder <- as.integer(intersect(fromCells,upperrightUnder))
+ fromCellLowerleftRight <- as.integer(intersect(fromCells,lowerleftRight))
+ fromCellLowerrightLeft <- as.integer(intersect(fromCells,lowerrightLeft))
+
+ knight <- c(-2*nCols-1, -2*nCols+1, -nCols-2, -nCols+2, nCols-2, nCols+2, 2*nCols-1, 2*nCols+1)
+
+ coreInnerFromToKnight <- .cs(fromCellsCoreInner, knight)
+
+ upperInnerFromToKnight <- .cs(fromCellsUpperInner, knight[3:8])
+ lowerInnerFromToKnight <- .cs(fromCellsLowerInner, knight[1:6])
+ leftInnerFromToKnight <- .cs(fromCellsLeftInner, knight[c(1,2,4,6:8)])
+ rightInnerFromToKnight <- .cs(fromCellsRightInner, knight[c(1:3,5,7,8)])
+
+ upperleftInnerFromToKnight <- .cs(fromCellUpperleftInner, knight[c(4,6:8)])
+ upperrightInnerFromToKnight <- .cs(fromCellUpperrightInner, knight[c(3,5,7,8)])
+ lowerleftInnerFromToKnight <- .cs(fromCellLowerleftInner, knight[c(1,2,4,6)])
+ lowerrightInnerFromToKnight <- .cs(fromCellLowerrightInner, knight[c(1:3,5)])
+
+ leftOuterFromToKnight <- .cs(fromCellsLeftOuter, knight[c(2,4,6,8)])
+ rightOuterFromToKnight <- .cs(fromCellsRightOuter, knight[c(1,3,5,7)])
+ upperOuterFromToKnight <- .cs(fromCellsUpperOuter, knight[5:8])
+ lowerOuterFromToKnight <- .cs(fromCellsLowerOuter, knight[1:4])
+
+ upperleftUnderFromToKnight <- .cs(fromCellUpperleftUnder, knight[c(4,6,8)])
+ upperrightLeftFromToKnight <- .cs(fromCellUpperrightLeft, knight[c(5,7,8)])
+ lowerleftUpFromToKnight <- .cs(fromCellLowerleftUp, knight[c(2,4,6)])
+ lowerrightUpFromToKnight <- .cs(fromCellLowerright, knight[c(1,3,5)])
+ upperleftRightFromToKnight <- .cs(fromCellUpperleftRight, knight[6:8])
+ upperrightUnderFromToKnight <- .cs(fromCellUpperrightUnder, knight[c(3,5,7)])
+ lowerleftRightFromToKnight <- .cs(fromCellLowerleftRight, knight[c(1,2,4)])
+ lowerrightLeftFromToKnight <- .cs(fromCellLowerrightLeft, knight[1:3])
+
+ upperleftFromToKnight <- .cs(fromCellUpperleft, knight[c(6,8)])
+ upperrightFromToKnight <- .cs(fromCellUpperright, knight[c(5,7)])
+ lowerleftFromToKnight <- .cs(fromCellLowerleft, knight[c(2,4)])
+ lowerrightFromToKnight <- .cs(fromCellLowerright, knight[c(1,3)])
+
+ fromto3 <- rbind(coreInnerFromToKnight, upperInnerFromToKnight, lowerInnerFromToKnight, leftInnerFromToKnight, rightInnerFromToKnight, upperleftInnerFromToKnight, upperrightInnerFromToKnight, lowerleftInnerFromToKnight, lowerrightInnerFromToKnight, leftOuterFromToKnight, rightOuterFromToKnight, upperOuterFromToKnight, lowerOuterFromToKnight, upperleftUnderFromToKnight, upperrightLeftFromToKnight, lowerleftUpFromToKnight, lowerrightUpFromToKnight, upperleftRightFromToKnight, upperrightUnderFromToKnight, lowerleftRightFromToKnight, lowerrightLeftFromToKnight, upperleftFromToKnight, upperrightFromToKnight, lowerleftFromToKnight, lowerrightFromToKnight)
+ fromto3 <- subset(fromto3,fromto3[,2] %in% toCells)
+
+ if (outerMeridianConnect)
+ {
+ knightLeft <- c(-nCols-1, -2, +2*nCols-2, 3*nCols-1)
+ knightRight <- c(-3*nCols+1, -2*nCols+2, +2, nCols+1)
+
+ leftInnerFromToKnight <- .cs(fromCellsLeftInner, knightLeft[c(2,3)])
+ rightInnerFromToKnight <- .cs(fromCellsRightInner, knightRight[c(2,3)])
+
+ upperleftInnerFromToKnight <- .cs(fromCellUpperleftInner, knightLeft[c(2,3)])
+ upperrightInnerFromToKnight <- .cs(fromCellUpperrightInner, knightRight[c(2,3)])
+ lowerleftInnerFromToKnight <- .cs(fromCellLowerleftInner, knightLeft[c(2,3)])
+ lowerrightInnerFromToKnight <- .cs(fromCellLowerrightInner, knightRight[c(2,3)])
+
+ leftOuterFromToKnight <- .cs(fromCellsLeftOuter, knightLeft)
+ rightOuterFromToKnight <- .cs(fromCellsRightOuter, knightRight)
+
+ upperleftUnderFromToKnight <- .cs(fromCellUpperleftUnder, knightLeft[2:4])
+ upperrightLeftFromToKnight <- .cs(fromCellUpperrightLeft, knightRight[3])
+ lowerleftUpFromToKnight <- .cs(fromCellLowerleftUp, knightLeft[1:3])
+ lowerrightUpFromToKnight <- .cs(fromCellLowerrightUp, knightRight[1:3])
+ upperleftRightFromToKnight <- .cs(fromCellUpperleftRight, knightLeft[c(3)])
+ upperrightUnderFromToKnight <- .cs(fromCellUpperrightUnder, knightRight[2:4])
+ lowerleftRightFromToKnight <- .cs(fromCellLowerleftRight, knightLeft[2])
+ lowerrightLeftFromToKnight <- .cs(fromCellLowerrightLeft, knightRight[2])
+
+ upperleftFromToKnight <- .cs(fromCellUpperleft, knightLeft[c(3,4)])
+ upperrightFromToKnight <- .cs(fromCellUpperright, knightRight[c(3,4)])
+ lowerleftFromToKnight <- .cs(fromCellLowerleft, knightLeft[c(1,2)])
+ lowerrightFromToKnight <- .cs(fromCellLowerright, knightRight[c(1,2)])
+
+ fromto3 <- rbind(fromto3, leftInnerFromToKnight, rightInnerFromToKnight, upperleftInnerFromToKnight, upperrightInnerFromToKnight, lowerleftInnerFromToKnight, lowerrightInnerFromToKnight, leftOuterFromToKnight, rightOuterFromToKnight, upperleftUnderFromToKnight, upperrightLeftFromToKnight, lowerleftUpFromToKnight, lowerrightUpFromToKnight, upperleftRightFromToKnight, upperrightUnderFromToKnight, lowerleftRightFromToKnight, lowerrightLeftFromToKnight, upperleftFromToKnight, upperrightFromToKnight, lowerleftFromToKnight, lowerrightFromToKnight)
+ }
+ else{}
+
+ fromto3 <- subset(fromto3,fromto3[,2] %in% toCells)
+ fromto <- rbind(fromto,fromto3)
+ }
+ else{}
+ colnames(fromto) <- c("from","to")
+ return(fromto)
+}
\ No newline at end of file
Added: pkg/raster/man/adjacency.Rd
===================================================================
--- pkg/raster/man/adjacency.Rd (rev 0)
+++ pkg/raster/man/adjacency.Rd 2009-01-13 06:53:41 UTC (rev 127)
@@ -0,0 +1,35 @@
+\name{adjacency}
+\alias{adjacency}
+
+\title{ adjacency }
+\description{
+ calculate adjacent cells in a grid
+}
+\usage{
+adjacency(raster, fromCells, toCells, mode, outerMeridianConnect)
+}
+
+\arguments{
+ \item{raster}{ an object of the Raster family }
+ \item{fromCells}{ a vector of cell numbers for which adjacent cells should be calculated }
+ \item{toCells}{ a vector of cell numbers from which adjacent cells are selected }
+ \item{directions}{ in how many direction cells should be connected: 4, 8 or 16. }
+ \item{outerMeridianConnect}{ logical value indicating whether the outer columns of the raster should be connected as a cylinder }
+}
+
+\details{
+Cell numbers start with 1 in the upperleft corner and increase from left to right and from top to bottom.
+Number of directions: 4 connects cells with one-cell rook moves, 8 with one-cell queen moves, and 16 with knight and one-cell queen moves.
+}
+
+\value{
+ a two column matrix with each row containing a pair of adjacent cells.
+}
+\author{ Jacob van Etten \email{jacobvanetten at yahoo.com} }
+
+\examples{
+ rs <- newRaster(nrows=10, ncols=10)
+ adjacency(raster = rs, fromCells = c(1,30,55,72,100), toCells = c(1:ncells(rs)), directions=16, outerMeridianConnect = TRUE)
+}
+
+\keyword{ spatial }
\ No newline at end of file
More information about the Raster-commits
mailing list