Условное присвоение значений соседним растровым ячейкам?

У меня есть растровое значение:

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 с требуемыми значениями, назначенными из исходного растрового ввода. Функция проверяет, находятся ли соседние ячейки от референтной позиции в пределах растра. Он также отображает сообщения, если какая-то граница отсутствует. Если вам нужно переместить референтную позицию, вы можете просто написать итерацию, изменяющую входную позицию на 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значения белых клеток

Для матричного оператора на малой матрице это имеет смысл и может быть учтено. Однако вы можете по-настоящему переосмыслить свою логику, применяя такую ​​функцию к большому растру. Концептуально это не совсем соответствует общему применению. Вы говорите о том, что традиционно называлось статистикой блоков. Однако статистика блоков по своей природе начинается с одного угла растра и заменяет блоки значений в пределах указанного размера окна оператором. Обычно этот тип оператора предназначен для агрегирования данных. Это было бы значительно лучше, если бы вы думали с точки зрения использования условий для вычисления центрального значения матрицы. Таким образом, вы можете легко использовать фокусную функцию.

Просто имейте в виду, что функция фокусировки растра считывает блоки данных, которые представляют значения фокусировки в определенной окрестности на основе матрицы, переданной аргументу 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)