การกำหนดค่าตามเงื่อนไขให้กับเซลล์แรสเตอร์ที่อยู่ติดกัน?

ฉันมีค่าแรสเตอร์:

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)

จากแรสเตอร์นี้ฉันจะกำหนดค่า (หรือเปลี่ยนค่า) ให้กับ 8 เซลล์ที่อยู่ติดกันของเซลล์ปัจจุบันตามภาพประกอบนี้ได้อย่างไร ฉันวางจุดสีแดงในเซลล์ปัจจุบันจากบรรทัดรหัสนี้:

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

ที่นี่ผลลัพธ์ที่คาดหวังจะเป็น:

โดยที่ค่าของเซลล์ปัจจุบัน (เช่น 5 ในค่าแบบแรสเตอร์) จะถูกแทนที่ด้วย 0

โดยรวมแล้วจะต้องคำนวณค่าใหม่สำหรับ 8 เซลล์ที่อยู่ติดกันดังนี้:

ค่าใหม่ = ค่าเฉลี่ยของค่าเซลล์ที่มีอยู่ในสี่เหลี่ยมสีแดง * ระยะห่างระหว่างเซลล์ปัจจุบัน (จุดสีแดง) และเซลล์ที่อยู่ติดกัน (เช่น sqrt (2) สำหรับเซลล์ที่อยู่ติดกันตามแนวทแยงมุมหรือ 1 อย่างอื่น)

ปรับปรุง

เมื่อขอบเขตของเซลล์ที่อยู่ติดกันเกินขีด จำกัด แรสเตอร์ฉันต้องคำนวณค่าใหม่สำหรับเซลล์ที่อยู่ติดกันซึ่งเคารพเงื่อนไข เซลล์ที่อยู่ติดกันซึ่งไม่เคารพเงื่อนไขจะเท่ากับ "NA"

ตัวอย่างเช่นหากตำแหน่งอ้างอิงคือ c (1,1) แทน c (5,5) โดยใช้สัญกรณ์ [row, col] จะสามารถคำนวณเฉพาะค่าใหม่ที่มุมล่างขวา ดังนั้นผลลัพธ์ที่คาดหวังจะเป็น:

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

ตัวอย่างเช่นหากตำแหน่งอ้างอิงคือ c (3,1) คุณจะสามารถคำนวณเฉพาะค่าใหม่ที่มุมขวาบนขวาและล่างขวา ดังนั้นผลลัพธ์ที่คาดหวังจะเป็น:

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

นี่คือความพยายามครั้งแรกของฉันที่นี่โดยใช้ฟังก์ชั่นfocalแต่ฉันมีปัญหาในการสร้างรหัสอัตโนมัติ

เลือกเซลล์ที่อยู่ติดกัน

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)

หากเซลล์ที่อยู่ติดกันตั้งอยู่ที่มุมบนซ้ายของเซลล์ปัจจุบัน

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

หากเซลล์ที่อยู่ติดกันตั้งอยู่ที่มุมบนกลางของเซลล์ปัจจุบัน

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

หากเซลล์ที่อยู่ติดกันตั้งอยู่ที่มุมบนซ้ายของเซลล์ปัจจุบัน

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

หากเซลล์ที่อยู่ติดกันอยู่ที่มุมซ้ายของเซลล์ปัจจุบัน

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

หากเซลล์ที่อยู่ติดกันตั้งอยู่ที่มุมขวาของเซลล์ปัจจุบัน

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

ถ้าเซลล์ที่อยู่ติดกันอยู่ที่มุมล่างซ้ายของเซลล์ปัจจุบัน

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

หากเซลล์ที่อยู่ติดกันตั้งอยู่ที่มุมด้านล่างตรงกลางของเซลล์ปัจจุบัน

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

หากเซลล์ที่อยู่ติดกันตั้งอยู่ที่มุมล่างขวาของเซลล์ปัจจุบัน

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

ฟังก์ชั่นAssignValuesToAdjacentRasterCellsด้านล่างผลตอบแทนใหม่RasterLayerวัตถุที่มีค่าที่ต้องการได้รับมอบหมายจากเดิมrasterการป้อนข้อมูล ฟังก์ชั่นตรวจสอบว่าเซลล์ที่อยู่ติดกันจากตำแหน่งอ้างอิงอยู่ภายในขีด จำกัด แรสเตอร์ นอกจากนี้ยังแสดงข้อความหากมีข้อ จำกัด บางอย่างเกิดขึ้น หากคุณต้องการย้ายตำแหน่งอ้างอิงคุณสามารถเขียนการเปลี่ยนตำแหน่งอินพุตซ้ำเป็น c ( i , j )

ป้อนข้อมูล

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

ฟังก์ชัน

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

}

เรียกใช้ตัวอย่าง

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

พล็อตตัวอย่าง

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

ตัวอย่างรูปที่

หมายเหตุ:เซลล์สีขาวหมายถึงNAค่า

สำหรับผู้ดำเนินการของเมทริกซ์ในเมทริกซ์ขนาดเล็กสิ่งนี้เหมาะสมและเป็นไปได้ง่าย อย่างไรก็ตามคุณอาจต้องการคิดใหม่ตรรกะของคุณเมื่อใช้ฟังก์ชันเช่นนี้กับแรสเตอร์ขนาดใหญ่ แนวคิดนี้ไม่ได้ติดตามในแอปพลิเคชันทั่วไป คุณกำลังพูดถึงสิ่งที่ได้รับแบบดั้งเดิมเรียกว่าสถิติบล็อก อย่างไรก็ตามสถิติบล็อกโดยธรรมชาติเริ่มต้นที่มุมหนึ่งของแรสเตอร์และแทนที่บล็อกของค่าภายในขนาดหน้าต่างที่ระบุด้วยโอเปอเรเตอร์ โดยปกติผู้ประกอบการประเภทนี้มีไว้สำหรับรวบรวมข้อมูล มันจะง่ายกว่าถ้าคุณคิดในแง่ของการใช้เงื่อนไขเพื่อคำนวณค่ากลางของเมทริกซ์ ด้วยวิธีนี้คุณสามารถใช้ฟังก์ชั่นโฟกัสได้ง่าย

เพียงจำไว้ว่าฟังก์ชั่นโฟกัสแบบ raster กำลังอ่านในบล็อกของข้อมูลที่แสดงค่าโฟกัสในละแวกที่กำหนดตามเมทริกซ์ที่ส่งไปยังอาร์กิวเมนต์ w ผลลัพธ์คือเวกเตอร์สำหรับละแวกใกล้เคียงและผลลัพธ์ของตัวดำเนินการโฟกัสถูกกำหนดให้กับเซลล์โฟกัสไม่ใช่เฉพาะย่านทั้งหมด คิดว่ามันเป็นการจับเมทริกซ์ที่ล้อมรอบค่าเซลล์ดำเนินการอยู่โดยกำหนดค่าใหม่ให้กับเซลล์จากนั้นย้ายไปยังเซลล์ถัดไป

หากคุณตรวจสอบให้แน่ใจว่า na.rm = FALSE แล้วเวกเตอร์จะแสดงพื้นที่ใกล้เคียงที่แน่นอนเสมอ (เช่น., เวกเตอร์ความยาวเท่ากัน) และถูกรวมเข้ากับวัตถุเมทริกซ์ที่สามารถทำงานได้ภายในฟังก์ชัน ด้วยเหตุนี้คุณสามารถเขียนฟังก์ชันที่ใช้เวกเตอร์ที่คาดหวังรวมเข้ากับเมทริกซ์ใช้ตรรกะสัญลักษณ์ของพื้นที่ใกล้เคียงแล้วกำหนดค่าเดียวเป็นผลลัพธ์ ฟังก์ชั่นนี้สามารถส่งผ่านไปยังฟังก์ชัน raster :: focal

นี่คือสิ่งที่จะเกิดขึ้นในแต่ละเซลล์โดยอาศัยการบีบบังคับและการประเมินผลของหน้าต่างโฟกัส วัตถุ "w" โดยพื้นฐานแล้วจะเป็นนิยามเมทริกซ์เดียวกันที่เราจะผ่านอาร์กิวเมนต์ w ในโฟกัส นี่คือสิ่งที่กำหนดขนาดของเวกเตอร์ย่อยในการประเมินแต่ละโฟกัส

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) 

ตอนนี้สร้างฟังก์ชั่นที่สามารถนำไปใช้กับโฟกัสใช้ตรรกะข้างต้น ในกรณีนี้คุณสามารถกำหนดวัตถุ se เป็นค่าหรือใช้เป็นเงื่อนไขในบางสิ่งเช่น "ifelse" เพื่อกำหนดค่าตามการประเมินผล ฉันกำลังเพิ่มคำสั่ง ifelse เพื่อแสดงให้เห็นว่าจะประเมินเงื่อนไขหลายประการของพื้นที่ใกล้เคียงและใช้เงื่อนไขเมทริกซ์ตำแหน่ง (สัญลักษณ์ของพื้นที่ใกล้เคียง) ในฟังก์ชันดัมมี่นี้การบังคับ x เพื่อเมทริกซ์นั้นไม่จำเป็นอย่างสมบูรณ์และมีเพียงเพื่อแสดงให้เห็นว่ามันจะต้องทำอย่างไร หนึ่งสามารถใช้เงื่อนไขสัญกรณ์ละแวกใกล้เคียงโดยตรงกับเวกเตอร์โดยไม่ต้องบังคับเมทริกซ์เพราะตำแหน่งในเวกเตอร์จะนำไปใช้กับตำแหน่งของมันในหน้าต่างโฟกัสและยังคงได้รับการแก้ไข

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

และนำไปใช้กับแรสเตอร์

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)  

คุณสามารถอัปเดตค่าแรสเตอร์ได้อย่างง่ายดายโดยการแบ่งย่อยแรสเตอร์โดยใช้สัญลักษณ์ [row, col] เพียงสังเกตว่าแถวและคอลัมน์เริ่มต้นจากมุมซ้ายบนของแรสเตอร์ r [1,1] คือดัชนีพิกเซลด้านซ้ายบนและ r [2,1] คือดัชนีใต้ 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)