Bedingte Zuweisung von Werten zu benachbarten Rasterzellen?

Ich habe ein Werteraster:

m <- matrix(c(2,4,5,5,2,8,7,3,1,6,
         5,7,5,7,1,6,7,2,6,3,
         4,7,3,4,5,3,7,9,3,8,
         9,3,6,8,3,4,7,3,7,8,
         3,3,7,7,5,3,2,8,9,8,
         7,6,2,6,5,2,2,7,7,7,
         4,7,2,5,7,7,7,3,3,5,
         7,6,7,5,9,6,5,2,3,2,
         4,9,2,5,5,8,3,3,1,2,
         5,2,6,5,1,5,3,7,7,2),nrow=10, ncol=10, byrow = T)
r <- raster(m)
extent(r) <- matrix(c(0, 0, 10, 10), nrow=2)
plot(r)
text(r)

Wie kann ich in diesem Raster den 8 benachbarten Zellen der aktuellen Zelle Werte zuweisen (oder Werte ändern), wie in dieser Abbildung dargestellt? Ich habe einen roten Punkt in der aktuellen Zelle von dieser Codezeile platziert:

points(xFromCol(r, col=5), yFromRow(r, row=5),col="red",pch=16)

Hier wird das erwartete Ergebnis sein:

Dabei wird der Wert der aktuellen Zelle (dh 5 im Werteraster) durch 0 ersetzt.

Insgesamt müssen die neuen Werte für die 8 benachbarten Zellen wie folgt berechnet werden:

Neuer Wert = Durchschnitt der im roten Rechteck enthaltenen Zellenwerte * Abstand zwischen der aktuellen Zelle (roter Punkt) und der benachbarten Zelle (dh Quadrat (2) für diagonal benachbarte Zellen oder 1 auf andere Weise)

Aktualisieren

Wenn die Grenzen für die benachbarten Zellen außerhalb der Rastergrenzen liegen, muss ich neue Werte für die benachbarten Zellen berechnen, die die Bedingungen berücksichtigen. Die benachbarten Zellen, die die Bedingungen nicht einhalten, entsprechen "NA".

Wenn zum Beispiel die Referenzposition c (1,1) anstelle von c (5,5) unter Verwendung der [row, col] -Notation ist, kann nur der neue Wert in der unteren rechten Ecke berechnet werden. Das erwartete Ergebnis ist also:

     [,1] [,2] [,3]       
[1,] NA   NA   NA         
[2,] NA   0    NA         
[3,] NA   NA   New_value

Wenn die Referenzposition beispielsweise c (3,1) ist, können nur die neuen Werte in der oberen rechten, rechten und unteren rechten Ecke berechnet werden. Das erwartete Ergebnis ist also:

     [,1] [,2] [,3]       
[1,] NA   NA   New_value         
[2,] NA   0    New_value         
[3,] NA   NA   New_value

Hier ist mein erster Versuch, die Funktion zu verwenden, focalaber ich habe einige Schwierigkeiten, einen automatischen Code zu erstellen.

Markieren Sie benachbarte Zellen

mat_perc <- matrix(c(1,1,1,1,1,
                     1,1,1,1,1,
                     1,1,0,1,1,
                     1,1,1,1,1,
                     1,1,1,1,1), nrow=5, ncol=5, byrow = T)
cell_perc <- adjacent(r, cellFromRowCol(r, 5, 5), directions=mat_perc, pairs=FALSE, sorted=TRUE, include=TRUE)
r_perc <- rasterFromCells(r, cell_perc)
r_perc <- setValues(r_perc,extract(r, cell_perc))
plot(r_perc)
text(r_perc)

Wenn sich die benachbarte Zelle in der oberen linken Ecke der aktuellen Zelle befindet

focal_m <- matrix(c(1,1,NA,1,1,NA,NA,NA,NA), nrow=3, ncol=3, byrow = T)
focal_function <- function(x) mean(x,na.rm=T)*sqrt(2)
test <- as.matrix(focal(r_perc, focal_m, focal_function))

Wenn sich die benachbarte Zelle in der oberen mittleren Ecke der aktuellen Zelle befindet

focal_m <- matrix(c(1,1,1,1,1,1,NA,NA,NA), nrow=3, ncol=3, byrow = T)
focal_function <- function(x) mean(x,na.rm=T)
test <- as.matrix(focal(r_perc, focal_m, focal_function))

Wenn sich die benachbarte Zelle in der oberen linken Ecke der aktuellen Zelle befindet

focal_m <- matrix(c(NA,1,1,NA,1,1,NA,NA,NA), nrow=3, ncol=3, byrow = T)
focal_function <- function(x) mean(x,na.rm=T)*sqrt(2)
test <- as.matrix(focal(r_perc, focal_m, focal_function))

Wenn sich die benachbarte Zelle in der linken Ecke der aktuellen Zelle befindet

focal_m <- matrix(c(1,1,NA,1,1,NA,1,1,NA), nrow=3, ncol=3, byrow = T)
focal_function <- function(x) mean(x,na.rm=T)
test <- as.matrix(focal(r_perc, focal_m, focal_function))

Wenn sich die benachbarte Zelle in der rechten Ecke der aktuellen Zelle befindet

focal_m <- matrix(c(NA,1,1,NA,1,1,NA,1,1), nrow=3, ncol=3, byrow = T)
focal_function <- function(x) mean(x,na.rm=T)
test <- as.matrix(focal(r_perc, focal_m, focal_function))

Wenn sich die benachbarte Zelle in der unteren linken Ecke der aktuellen Zelle befindet

focal_m <- matrix(c(NA,NA,NA,1,1,NA,1,1,NA), nrow=3, ncol=3, byrow = T)
focal_function <- function(x) mean(x,na.rm=T)*sqrt(2)
test <- as.matrix(focal(r_perc, focal_m, focal_function))

Wenn sich die benachbarte Zelle in der unteren mittleren Ecke der aktuellen Zelle befindet

focal_m <- matrix(c(NA,NA,NA,1,1,1,1,1,1), nrow=3, ncol=3, byrow = T)
focal_function <- function(x) mean(x,na.rm=T)
test <- as.matrix(focal(r_perc, focal_m, focal_function))

Wenn sich die benachbarte Zelle in der rechten unteren Ecke der aktuellen Zelle befindet

focal_m <- matrix(c(NA,NA,NA,NA,1,1,NA,1,1), nrow=3, ncol=3, byrow = T)
focal_function <- function(x) mean(x,na.rm=T)*sqrt(2)
test <- as.matrix(focal(r_perc, focal_m, focal_function))

Die Funktion AssignValuesToAdjacentRasterCellsunten gibt ein neues Rasterebene Objekt mit den aus der ursprünglichen zugeordnet gewünschten Werten Rastereingabe. Die Funktion prüft, ob die benachbarten Zellen von der Referenzposition innerhalb der Rastergrenzen liegen. Es werden auch Meldungen angezeigt, wenn eine Grenze überschritten ist. Wenn Sie die Referenzposition verschieben müssen, können Sie einfach eine Iteration schreiben, die die Eingabeposition in c ( i , j ) ändert .

Dateneingabe

# Load packages
library("raster")

# Load matrix data
m <- matrix(c(2,4,5,5,2,8,7,3,1,6,
              5,7,5,7,1,6,7,2,6,3,
              4,7,3,4,5,3,7,9,3,8,
              9,3,6,8,3,4,7,3,7,8,
              3,3,7,7,5,3,2,8,9,8,
              7,6,2,6,5,2,2,7,7,7,
              4,7,2,5,7,7,7,3,3,5,
              7,6,7,5,9,6,5,2,3,2,
              4,9,2,5,5,8,3,3,1,2,
              5,2,6,5,1,5,3,7,7,2), nrow=10, ncol=10, byrow = TRUE)

# Convert matrix to RasterLayer object
r <- raster(m)

# Assign extent to raster
extent(r) <- matrix(c(0, 0, 10, 10), nrow=2)

# Plot original raster
plot(r)
text(r)
points(xFromCol(r, col=5), yFromRow(r, row=5), col="red", pch=16)

Funktion

# Function to assigning values to the adjacent raster cells based on conditions
# Input raster: RasterLayer object
# Input position: two-dimension vector (e.g. c(5,5))

AssignValuesToAdjacentRasterCells <- function(raster, position) {

  # Reference position
  rowPosition = position[1]
  colPosition = position[2]

  # Adjacent cells positions
  adjacentBelow1 = rowPosition + 1
  adjacentBelow2 = rowPosition + 2
  adjacentUpper1 = rowPosition - 1
  adjacentUpper2 = rowPosition - 2
  adjacentLeft1 = colPosition - 1 
  adjacentLeft2 = colPosition - 2 
  adjacentRight1 = colPosition + 1
  adjacentRight2 = colPosition + 2

  # Check if adjacent cells positions are out of raster positions limits
  belowBound1 = adjacentBelow1 <= nrow(raster)
  belowBound2 = adjacentBelow2 <= nrow(raster)
  upperBound1 = adjacentUpper1 > 0
  upperBound2 = adjacentUpper2 > 0
  leftBound1 = adjacentLeft1 > 0 
  leftBound2 = adjacentLeft2 > 0 
  rightBound1 = adjacentRight1 <= ncol(raster)
  rightBound2 = adjacentRight2 <= ncol(raster) 

  if(upperBound2 & leftBound2) {

    val1 = mean(r[adjacentUpper2:adjacentUpper1, adjacentLeft2:adjacentLeft1]) * sqrt(2)

  } else {

    val1 = NA

  }

  if(upperBound2 & leftBound1 & rightBound1) {

    val2 = mean(r[adjacentUpper1:adjacentUpper2, adjacentLeft1:adjacentRight1])

  } else {

    val2 = NA

  }

  if(upperBound2 & rightBound2) {

    val3 = mean(r[adjacentUpper2:adjacentUpper1, adjacentRight1:adjacentRight2]) * sqrt(2)

  } else {

    val3 = NA

  }

  if(upperBound1 & belowBound1 & leftBound2) {

    val4 = mean(r[adjacentUpper1:adjacentBelow1, adjacentLeft2:adjacentLeft1])

  } else {

    val4 = NA

  }

  val5 = 0

  if(upperBound1 & belowBound1 & rightBound2) {

    val6 = mean(r[adjacentUpper1:adjacentBelow1, adjacentRight1:adjacentRight2])

  } else {

    val6 = NA

  }

  if(belowBound2 & leftBound2) {

    val7 = mean(r[adjacentBelow1:adjacentBelow2, adjacentLeft2:adjacentLeft1]) * sqrt(2)

  } else {

    val7 = NA

  }

  if(belowBound2 & leftBound1 & rightBound1) {

    val8 = mean(r[adjacentBelow1:adjacentBelow2, adjacentLeft1:adjacentRight1])

  } else {

    val8 = NA

  }

  if(belowBound2 & rightBound2) {

    val9 = mean(r[adjacentBelow1:adjacentBelow2, adjacentRight1:adjacentRight2]) * sqrt(2)

  } else {

    val9 = NA

  }

  # Build matrix
  mValues = matrix(data = c(val1, val2, val3,
                            val4, val5, val6,
                            val7, val8, val9), nrow = 3, ncol = 3, byrow = TRUE)    

  if(upperBound1) {

    a = adjacentUpper1

  } else {

    # Warning message
    cat(paste("\n Upper bound out of raster limits!"))
    a = rowPosition
    mValues <- mValues[-1,]

  }

  if(belowBound1) {

    b = adjacentBelow1

  } else {

    # Warning message
    cat(paste("\n Below bound out of raster limits!"))
    b = rowPosition
    mValues <- mValues[-3,]

  }

  if(leftBound1) {

    c = adjacentLeft1

  } else {

    # Warning message
    cat(paste("\n Left bound out of raster limits!"))
    c = colPosition
    mValues <- mValues[,-1]

  }

  if(rightBound1) {

    d = adjacentRight1

  } else {

    # Warning
    cat(paste("\n Right bound out of raster limits!"))
    d = colPosition
    mValues <- mValues[,-3]

  }

  # Convert matrix to RasterLayer object
  rValues = raster(mValues)

  # Assign values to raster
  raster[a:b, c:d] = rValues[,]  

  # Assign extent to raster
  extent(raster) <- matrix(c(0, 0, 10, 10), nrow = 2)

  # Return raster with assigned values
  return(raster)      

}

Führen Sie Beispiele aus

# Run function AssignValuesToAdjacentRasterCells

# reference position (1,1)
example1 <- AssignValuesToAdjacentRasterCells(raster = r, position = c(1,1))

# reference position (1,5)
example2 <- AssignValuesToAdjacentRasterCells(raster = r, position = c(1,5))

# reference position (1,10)
example3 <- AssignValuesToAdjacentRasterCells(raster = r, position = c(1,10))

# reference position (5,1)
example4 <- AssignValuesToAdjacentRasterCells(raster = r, position = c(5,1))

# reference position (5,5)
example5 <- AssignValuesToAdjacentRasterCells(raster = r, position = c(5,5))

# reference position (5,10)
example6 <- AssignValuesToAdjacentRasterCells(raster = r, position = c(5,10))

# reference position (10,1)
example7 <- AssignValuesToAdjacentRasterCells(raster = r, position = c(10,1))

# reference position (10,5)
example8 <- AssignValuesToAdjacentRasterCells(raster = r, position = c(10,5))

# reference position (10,10)
example9 <- AssignValuesToAdjacentRasterCells(raster = r, position = c(10,10))

Handlungsbeispiele

# Plot examples
par(mfrow=(c(3,3)))

plot(example1, main = "Position ref. (1,1)")
text(example1)
points(xFromCol(example1, col=1), yFromRow(example1, row=1), col="red", cex=2.5, lwd=2.5)

plot(example2, main = "Position ref. (1,5)")
text(example2)
points(xFromCol(example2, col=5), yFromRow(example2, row=1), col="red", cex=2.5, lwd=2.5)

plot(example3, main = "Position ref. (1,10)")
text(example3)
points(xFromCol(example3, col=10), yFromRow(example3, row=1), col="red", cex=2.5, lwd=2.5)

plot(example4, main = "Position ref. (5,1)")
text(example4)
points(xFromCol(example4, col=1), yFromRow(example4, row=5), col="red", cex=2.5, lwd=2.5)

plot(example5, main = "Position ref. (5,5)")
text(example5)
points(xFromCol(example5, col=5), yFromRow(example5, row=5), col="red", cex=2.5, lwd=2.5)

plot(example6, main = "Position ref. (5,10)")
text(example6)
points(xFromCol(example6, col=10), yFromRow(example6, row=5), col="red", cex=2.5, lwd=2.5)

plot(example7, main = "Position ref. (10,1)")
text(example7)
points(xFromCol(example7, col=1), yFromRow(example7, row=10), col="red", cex=2.5, lwd=2.5)

plot(example8, main = "Position ref. (10,5)")
text(example8)
points(xFromCol(example8, col=5), yFromRow(example8, row=10), col="red", cex=2.5, lwd=2.5)

plot(example9, main = "Position ref. (10,10)")
text(example9)
points(xFromCol(example9, col=10), yFromRow(example9, row=10), col="red", cex=2.5, lwd=2.5)

Abbildung Beispiel

Hinweis: weiße Blutkörperchen bedeuten NAWerte

Für einen Matrixoperator auf einer kleinen Matrix ist dies sinnvoll und nachvollziehbar. Möglicherweise möchten Sie jedoch Ihre Logik wirklich überdenken, wenn Sie eine Funktion wie diese auf ein großes Raster anwenden. Konzeptionell verfolgt dies in der allgemeinen Anwendung nicht wirklich. Sie sprechen von einer so genannten Blockstatistik. Eine Blockstatistik beginnt jedoch naturgemäß an einer Ecke des Rasters und ersetzt Werteblöcke innerhalb einer angegebenen Fenstergröße durch einen Operator. Normalerweise dient diese Art von Operator zum Aggregieren von Daten. Es wäre wesentlich praktikabler, wenn Sie über die Verwendung von Bedingungen zur Berechnung eines Mittelwerts einer Matrix nachdenken würden. Auf diese Weise können Sie leicht eine Fokusfunktion verwenden.

Denken Sie daran, dass die Rasterfokusfunktion Datenblöcke einliest, die die Fokuswerte in der definierten Nachbarschaft basierend auf der an das Argument w übergebenen Matrix darstellen. Das Ergebnis ist ein Vektor für jede Nachbarschaft und das Ergebnis des Fokusoperators wird nur der Fokuszelle und nicht der gesamten Nachbarschaft zugewiesen. Stellen Sie sich vor, Sie greifen nach einer Matrix, die einen Zellenwert umgibt, bearbeiten ihn, weisen der Zelle einen neuen Wert zu und wechseln dann zur nächsten Zelle.

Wenn Sie sicherstellen, dass na.rm = FALSE ist, stellt der Vektor immer die exakte Nachbarschaft dar (dh denselben Längenvektor) und wird zu einem Matrixobjekt gezwungen, das innerhalb einer Funktion bearbeitet werden kann. Aus diesem Grund können Sie einfach eine Funktion schreiben, die den Erwartungsvektor aufnimmt, in eine Matrix zwingt, Ihre Nachbarschaftsnotationslogik anwendet und dann einen einzelnen Wert als Ergebnis zuweist. Diese Funktion kann dann an die Funktion raster :: focal übergeben werden.

Hier ist, was in jeder Zelle basierend auf einem einfachen Zwang und einer Auswertung des Fokusfensters passieren würde. Das "w" -Objekt wäre im Wesentlichen dieselbe Matrixdefinition, die man beim Übergeben des w-Arguments im Fokus verwenden würde. Dies definiert die Größe des Teilmengenvektors in jeder Fokusbewertung.

w=c(5,5)
x <- runif(w[1]*w[2])
x[25] <- NA
print(x)
( x <- matrix(x, nrow=w[1], ncol=w[2]) ) 
( se <- mean(x, na.rm=TRUE) * sqrt(2) )
ifelse( as.vector(x[(length(as.vector(x)) + 1)/2]) <= se, 1, 0) 

Erstellen Sie nun eine Funktion, die auf den Fokus angewendet werden kann, und wenden Sie die obige Logik an. In diesem Fall können Sie das se-Objekt als Wert zuweisen oder es als Bedingung in so etwas wie "ifelse" verwenden, um einen Wert basierend auf einer Bewertung zuzuweisen. Ich füge die ifelse-Anweisung hinzu, um zu veranschaulichen, wie man mehrere Bedingungen der Nachbarschaft bewerten und eine Matrixpositionsbedingung (Nachbarschaftsnotation) anwenden würde. In dieser Dummy-Funktion ist das Erzwingen von x zu einer Matrix völlig unnötig und dient nur der Veranschaulichung, wie dies geschehen würde. Man kann die Bedingungen für die Nachbarschaftsnotation direkt auf den Vektor anwenden, ohne dass es zu einem Matrixzwang kommt, da die Position im Vektor für seine Position im Fokusfenster gilt und fest bleibt.

f.rast <- function(x, dims=c(5,5)) {
  x <- matrix(x, nrow=dims[1], ncol=dims[2]) 
  se <- mean(x, na.rm=TRUE) * sqrt(2)
  ifelse( as.vector(x[(length(as.vector(x)) + 1)/2]) <= se, 1, 0)   
}  

Wenden Sie es auf ein Raster an

library(raster)
r <- raster(nrows=100, ncols=100)
  r[] <- runif( ncell(r) )
  plot(r)

( r.class <- focal(r, w = matrix(1, nrow=w[1], ncol=w[2]), fun=f.rast) )
plot(r.class)  

Sie können Rasterwerte auf einfache Weise aktualisieren, indem Sie das Raster in [row, col] -Notation unterteilen. Beachten Sie, dass Zeile und Spalte in der oberen linken Ecke des Rasters beginnen. r [1,1] ist der obere linke Pixelindex und r [2,1] ist derjenige unter r [1,1].

# the function to update raster cell values
focal_raster_update <- function(r, row, col) {
  # copy the raster to hold the temporary values
  r_copy <- r
  r_copy[row,col] <- 0
  #upper left
  r_copy[row-1,col-1] <- mean(r[(row-2):(row-1),(col-2):(col-1)]) * sqrt(2)
  #upper mid
  r_copy[row-1,col] <- mean(r[(row-2):(row-1),(col-1):(col+1)])
  #upper right
  r_copy[row-1,col+1] <- mean(r[(row-2):(row-1),(col+1):(col+2)]) * sqrt(2)
  #left
  r_copy[row,col-1] <- mean(r[(row-1):(row+1),(col-2):(col-1)])
  #right
  r_copy[row,col+1] <- mean(r[(row-1):(row+1),(col+1):(col+2)])
  #bottom left
  r_copy[row+1,col-1] <- mean(r[(row+1):(row+2),(col-2):(col-1)]) * sqrt(2)
  #bottom mid
  r_copy[row+1,col] <- mean(r[(row+1):(row+2),(col-1):(col+1)])
  #bottom right
  r_copy[row+1,col+1] <- mean(r[(row+1):(row+2),(col+1):(col+2)]) * sqrt(2)
  return(r_copy)
}
col <- 5
row <- 5
r <- focal_raster_update(r,row,col)

dev.set(1)
plot(r)
text(r,digits=2)