Bitişik tarama hücrelerine değerlerin koşullu olarak atanması?

Bir değer rasterim var:

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)

Bu taramadan, bu şekle göre mevcut hücrenin bitişik 8 hücresine nasıl değer atayabilirim (veya değerleri değiştirebilirim)? Bu kod satırından geçerli hücrenin içine kırmızı bir nokta yerleştirdim:

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

Burada beklenen sonuç:

burada mevcut hücrenin değeri (yani değer rasterinde 5) 0 ile değiştirilir.

Genel olarak, bitişik 8 hücre için yeni değerler aşağıdaki gibi hesaplanmalıdır:

Yeni değer = kırmızı dikdörtgenin içerdiği hücre değerlerinin ortalaması * geçerli hücre (kırmızı nokta) ve bitişik hücre arasındaki mesafe (yani, çapraz olarak bitişik hücreler için sqrt (2) veya 1 aksi takdirde)

Güncelleme

Bitişik hücreler için sınırlar tarama sınırlarının dışında olduğunda, koşullara uyan bitişik hücreler için yeni değerler hesaplamam gerekir. Koşullara uymayan bitişik hücreler "NA" ya eşit olacaktır.

Örneğin, referans konumu [satır, sütun] gösterimi kullanılarak c (5,5) yerine c (1,1) ise, yalnızca sağ alt köşedeki yeni değer hesaplanabilir. Böylece, beklenen sonuç:

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

Örneğin, referans konumu c (3,1) ise, yalnızca sağ üst, sağ ve sağ alt köşelerdeki yeni değerler hesaplanabilir. Böylece, beklenen sonuç:

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

İşte işlevi kullanarak bu benim ilk denemem focalama otomatik kod yapmak için bazı zorluklar var.

Bitişik hücreleri seçin

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)

bitişik hücre geçerli hücrenin sol üst köşesinde bulunuyorsa

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))

bitişik hücre geçerli hücrenin üst orta köşesinde bulunuyorsa

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))

bitişik hücre geçerli hücrenin sol üst köşesinde bulunuyorsa

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))

bitişik hücre geçerli hücrenin sol köşesinde bulunuyorsa

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))

bitişik hücre geçerli hücrenin sağ köşesinde bulunuyorsa

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))

bitişik hücre geçerli hücrenin sol alt köşesinde bulunuyorsa

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))

bitişik hücre geçerli hücrenin alt orta köşesinde bulunuyorsa

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))

bitişik hücre geçerli hücrenin sağ alt köşesinde bulunuyorsa

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))

Aşağıdaki işlev , orijinal tarama girişinden atanan istenen değerlere sahip AssignValuesToAdjacentRasterCellsyeni bir RasterLayer nesnesi döndürür . İşlev, referans konumundan bitişik hücrelerin tarama sınırları içinde olup olmadığını kontrol eder . Bazı sınırlamalar varsa mesajlar da görüntüler. Referans konumunu taşımanız gerekirse, giriş konumunu c ( i , j ) olarak değiştiren bir yineleme yazabilirsiniz .

Veri girişi

# 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)

fonksiyon

# 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)      

}

Örnekleri çalıştır

# 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))

Arsa örnekleri

# 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)

Şekil örneği

Not: beyaz hücreler ortalama NAdeğerler

Küçük bir matristeki bir matris operatörü için bu anlamlıdır ve izlenebilirdir. Bununla birlikte, büyük bir rasterde böyle bir işlev uygularken mantığınızı gerçekten yeniden düşünmek isteyebilirsiniz. Kavramsal olarak, bu genel uygulamada gerçekten takip etmez. Geleneksel olarak bir blok istatistik olarak adlandırılan şeyden bahsediyorsunuz. Bununla birlikte, bir blok istatistik, doğası gereği, taramanın bir köşesinden başlar ve belirli bir pencere boyutunda değer bloklarını bir işleçle değiştirir. Normalde bu tip operatör verileri toplamak içindir. Bir matrisin merkez değerini hesaplamak için koşulları kullanma açısından düşündüğünüzde çok daha izlenebilir olacaktır. Bu şekilde kolayca bir odak fonksiyonu kullanabilirsiniz.

Raster odak fonksiyonunun, w argümanına iletilen matrise dayalı olarak tanımlanan mahalledeki odak değerlerini temsil eden veri bloklarında okuduğunu unutmayın. Sonuç, her mahalle için bir vektördür ve odak operatörünün sonucu, tüm mahalleye değil, sadece odak hücresine atanır. Bir hücre değerini çevreleyen, üzerinde çalışan bir matris yakalama, hücreye yeni bir değer atama ve bir sonraki hücreye geçme olarak düşünün.

Eğer na.rm = FALSE olduğundan emin olursanız, vektör her zaman tam mahalleyi temsil eder (yani, aynı uzunluk vektörü) ve bir fonksiyon içinde çalıştırılabilen bir matris nesnesine zorlanır. Bu nedenle, beklenti vektörünü alan, bir matrise zorlanan, mahalle gösterim mantığınızı uygulayan ve sonuç olarak tek bir değer atayan bir işlev yazabilirsiniz. Bu fonksiyon daha sonra raster :: focus fonksiyonuna aktarılabilir.

Basit bir baskı ve odak penceresinin değerlendirmesine dayalı olarak her bir hücrede olacaklar. "W" nesnesi esasen odakta w argümanını ileteceği matris tanımıyla aynı olacaktır. Her odak değerlendirmesinde altküme vektörünün boyutunu tanımlayan budur.

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) 

Şimdi yukarıdaki mantığa uygulanan odak uygulanabilecek bir işlev oluşturun. Bu durumda se nesnesini değer olarak atayabilir veya bir değerlendirmeye dayalı bir değer atamak için "ifelse" gibi bir koşulda koşul olarak kullanabilirsiniz. Bir mahallenin birden fazla koşulunu nasıl değerlendireceğini ve bir matris pozisyonu (mahalle notasyonu) koşulunu nasıl uygulayacağını göstermek için ifelse ifadesini ekliyorum. Bu kukla fonksiyonda, x'in bir matrise zorlanması tamamen gereksizdir ve sadece nasıl yapılacağını göstermek için vardır. Bir kimse mahalle gösterim koşullarını matris zorlaması olmadan doğrudan vektöre uygulayabilir, çünkü vektördeki konum odak penceresindeki konumuna uygulanacak ve sabit kalacaktır.

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)   
}  

Ve rasterlere uygulayın

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)  

Raster değerlerini [row, col] gösterimini kullanarak raster alt kümesiyle kolayca güncelleyebilirsiniz. Sıra ve sütunun, rasterin sol üst köşesinden başladığını unutmayın; r [1,1] sol üst piksel indeksidir ve r [2,1] r [1,1] altındaki dizindir.

# 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)