Gán điều kiện giá trị cho các ô raster liền kề?

Tôi có một raster giá trị:

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)

Từ raster này, làm thế nào tôi có thể gán giá trị (hoặc thay đổi giá trị) cho 8 ô liền kề của ô hiện tại theo hình minh họa này? Tôi đã đặt một điểm đỏ trong ô hiện tại từ dòng mã này:

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

Ở đây, kết quả dự kiến ​​sẽ là:

trong đó giá trị của ô hiện tại (nghĩa là 5 trong raster giá trị) được thay thế bằng 0.

Nhìn chung, các giá trị mới cho 8 ô liền kề phải được tính như sau:

Giá trị mới = trung bình của các giá trị ô chứa trong hình chữ nhật màu đỏ * khoảng cách giữa ô hiện tại (điểm đỏ) và ô liền kề (nghĩa là sqrt (2) cho các ô liền kề chéo hoặc 1 khác)

Cập nhật

Khi giới hạn cho các ô liền kề nằm ngoài giới hạn raster, tôi cần tính các giá trị mới cho các ô liền kề tôn trọng các điều kiện. Các ô liền kề không tôn trọng các điều kiện sẽ bằng "NA".

Ví dụ: nếu vị trí tham chiếu là c (1,1) thay vì c (5,5) bằng cách sử dụng ký hiệu [hàng, col], chỉ có thể tính giá trị mới ở góc dưới bên phải. Do đó, kết quả dự kiến ​​sẽ là:

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

Ví dụ: nếu vị trí tham chiếu là c (3,1), chỉ có thể tính các giá trị mới ở góc trên bên phải, bên phải và dưới cùng bên phải. Do đó, kết quả dự kiến ​​sẽ là:

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

Đây là nỗ lực đầu tiên của tôi ở đây bằng cách sử dụng hàm focalnhưng tôi gặp một số khó khăn để tạo mã tự động.

Chọn các ô liền kề

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)

nếu ô liền kề nằm ở góc trên bên trái của ô hiện tại

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

nếu ô liền kề nằm ở góc trên giữa của ô hiện tại

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

nếu ô liền kề nằm ở góc trên bên trái của ô hiện tại

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

nếu ô liền kề nằm ở góc trái của ô hiện tại

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

nếu ô liền kề nằm ở góc bên phải của ô hiện tại

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

nếu ô liền kề nằm ở góc dưới bên trái của ô hiện tại

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

nếu ô liền kề nằm ở góc dưới cùng giữa của ô hiện tại

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

nếu ô liền kề nằm ở góc dưới bên phải của ô hiện tại

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

Hàm AssignValuesToAdjacentRasterCellsbên dưới trả về một đối tượng RasterLayer mới với các giá trị mong muốn được gán từ đầu vào raster ban đầu. Hàm kiểm tra xem các ô liền kề từ vị trí tham chiếu có nằm trong giới hạn raster không. Nó cũng hiển thị thông báo nếu một số ràng buộc được đưa ra. Nếu bạn cần di chuyển vị trí tham chiếu, bạn có thể chỉ cần viết một vị trí đầu vào thay đổi lặp lại thành c ( i , j ).

Nhập dữ liệu

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

Chức năng

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

}

Chạy ví dụ

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

Ví dụ cốt truyện

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

Hình ví dụ

Lưu ý:NA giá trị trung bình của các ô trắng

Đối với một toán tử ma trận trên một ma trận nhỏ, điều này có ý nghĩa và có thể kéo được. Tuy nhiên, bạn có thể muốn thực sự suy nghĩ lại về logic của mình khi áp dụng một chức năng như thế này cho một raster lớn. Về mặt khái niệm, điều này không thực sự theo dõi trong ứng dụng chung. Bạn đang nói về những gì theo truyền thống được gọi là một thống kê khối. Tuy nhiên, về cơ bản, một thống kê khối bắt đầu từ một góc của raster và thay thế các khối giá trị, trong một kích thước cửa sổ được chỉ định, bằng một toán tử. Thông thường loại toán tử này là để tổng hợp dữ liệu. Sẽ dễ dàng hơn đáng kể nếu bạn nghĩ về việc sử dụng các điều kiện để tính giá trị trung tâm của ma trận. Theo cách này, bạn có thể dễ dàng sử dụng chức năng đầu mối.

Chỉ cần lưu ý rằng hàm tiêu điểm raster đang đọc trong các khối dữ liệu đại diện cho các giá trị tiêu cự trong vùng lân cận được xác định dựa trên ma trận được truyền cho đối số w. Kết quả là một vectơ cho mỗi vùng lân cận và kết quả của toán tử tiêu điểm được gán cho chỉ ô tiêu điểm chứ không phải toàn bộ vùng lân cận. Hãy nghĩ về nó như lấy một ma trận bao quanh một giá trị ô, hoạt động trên nó, gán một giá trị mới cho ô sau đó di chuyển đến ô tiếp theo.

Nếu bạn chắc chắn rằng na.rm = FALSE thì vectơ sẽ luôn đại diện cho vùng lân cận chính xác (nghĩa là vectơ có cùng độ dài) và được ép buộc vào một đối tượng ma trận có thể được vận hành trong một hàm. Do đó, bạn có thể chỉ cần viết một hàm lấy vectơ kỳ vọng, ép buộc vào một ma trận, áp dụng logic ký hiệu lân cận của bạn và sau đó gán một giá trị duy nhất làm kết quả. Hàm này sau đó có thể được truyền cho hàm raster :: focal.

Dưới đây là những gì sẽ xảy ra ở mỗi ô dựa trên sự ép buộc và đánh giá đơn giản của cửa sổ tiêu cự. Đối tượng "w" về cơ bản sẽ là cùng một định nghĩa ma trận mà người ta sẽ vượt qua đối số w trong tiêu điểm. Đây là những gì xác định kích thước của vectơ con trong mỗi đánh giá đầu mối.

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) 

Bây giờ tạo một hàm có thể được áp dụng cho tiêu điểm áp dụng logic trên. Trong trường hợp này, bạn có thể gán đối tượng se làm giá trị hoặc sử dụng nó làm điều kiện trong một cái gì đó như "ifelse" để gán giá trị dựa trên đánh giá. Tôi đang thêm câu lệnh ifelse để minh họa cách người ta đánh giá nhiều điều kiện của vùng lân cận và áp dụng điều kiện vị trí ma trận (ký hiệu vùng lân cận). Trong hàm giả này, việc ép x thành ma trận là hoàn toàn không cần thiết và chỉ để minh họa cách nó sẽ được thực hiện. Người ta có thể áp dụng các điều kiện ký hiệu lân cận trực tiếp vào vectơ, mà không ép buộc ma trận, bởi vì vị trí trong vectơ sẽ áp dụng cho vị trí của nó trong cửa sổ tiêu cự và vẫn cố định.

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

Và áp dụng nó cho một raster

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)  

Bạn có thể dễ dàng cập nhật giá trị raster bằng cách đặt tập hợp raster bằng cách sử dụng ký hiệu [row, col]. Chỉ cần lưu ý rằng hàng và cột bắt đầu từ góc trên bên trái của raster; r [1,1] là chỉ số pixel phía trên bên trái và r [2.1] là chỉ số bên dưới 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)