Получить значения из соседних ячеек растра R - PullRequest
Новая
       40

Получить значения из соседних ячеек растра R

0 голосов
/ 26 июня 2019

Мне нужно извлечь значения из ячеек, смежных с моими ячейками фокуса, в растре, и мне нужно иметь возможность связать эти значения с ячейкой фокуса.Пока я могу извлечь значения из соседних ячеек, но результат не в организованной форме.

 library(raster)
 r <- raster(matrix(runif(100), 10))
 cells <- c(34,22,50,10)
 cells_ad <- adjacent(r,cells, directions = 8, pairs=FALSE)
 extract (r,cells_ad)

Мне нужно иметь фрейм данных со значениями, извлеченными для каждой из соседних ячеек, где каждый столбец представляет собой одну смежную ячейку (в идеале я бы знал порядок - юг, юго-запад, запад, северо-запад ...) и в каждой строке ячейка фокуса.Следуя моему примеру выше, фрейм данных будет иметь 8 столбцов и 4 строки.

Это необходимо сделать для массивного растрового файла и для извлечения миллионов точек.Поэтому время вычислений следует учитывать здесь.

Я ценю любую помощь.

Ответы [ 2 ]

2 голосов
/ 26 июня 2019

См. Ниже мое (небрежное) решение. Я заметил, что соседняя функция () пропускает ячейки NA, поэтому я изменил ее, чтобы удалить это. Ориентация для извлеченных ячеек имеет следующий порядок: «nw», «w», «sw», «ne», «e», «se», «n», «s». 

library(raster)
r <- raster(matrix(runif(100), 10))
cells <- c(34,22,50,10)

# modified adjacent function to exclud the na.omit() part, therefore it returns all adjacent cells around the cell
adjacent_mod = function (x, cells, directions = 4, pairs = TRUE, target = NULL, 
                         sorted = FALSE, include = FALSE, id = FALSE) 
{
  .isGlobalLonLat <- function(x) {
    res <- FALSE
    tolerance <- 0.1
    scale <- xres(x)
    if (isTRUE(all.equal(xmin(x), -180, tolerance=tolerance, scale=scale)) & 
        isTRUE(all.equal(xmax(x),  180, tolerance=tolerance, scale=scale))) {
      if (couldBeLonLat(x, warnings=FALSE)) {
        res <- TRUE
      }
    }
    res
  }


  if (is.character(directions)) {
    directions <- tolower(directions)
  }
  x <- raster(x)
  r <- res(x)
  xy <- xyFromCell(x, cells)
  mat <- FALSE
  if (is.matrix(directions)) {
    stopifnot(length(which(directions == 0)) == 1)
    stopifnot(length(which(directions == 1)) > 0)
    d <- .adjacentUD(x, cells, directions, include)
    directions <- sum(directions == 1, na.rm = TRUE)
    mat <- TRUE
  }
  else if (directions == 4) {
    if (include) {
      d <- c(xy[, 1], xy[, 1] - r[1], xy[, 1] + r[1], 
             xy[, 1], xy[, 1], xy[, 2], xy[, 2], xy[, 2], 
             xy[, 2] + r[2], xy[, 2] - r[2])
    }
    else {
      d <- c(xy[, 1] - r[1], xy[, 1] + r[1], xy[, 1], 
             xy[, 1], xy[, 2], xy[, 2], xy[, 2] + r[2], xy[, 
                                                           2] - r[2])
    }
  }
  else if (directions == 8) {
    if (include) {
      d <- c(xy[, 1], rep(xy[, 1] - r[1], 3), rep(xy[, 
                                                     1] + r[1], 3), xy[, 1], xy[, 1], xy[, 2], rep(c(xy[, 
                                                                                                        2] + r[2], xy[, 2], xy[, 2] - r[2]), 2), xy[, 
                                                                                                                                                    2] + r[2], xy[, 2] - r[2])
    }
    else {
      d <- c(rep(xy[, 1] - r[1], 3), rep(xy[, 1] + r[1], 
                                         3), xy[, 1], xy[, 1], rep(c(xy[, 2] + r[2], 
                                                                     xy[, 2], xy[, 2] - r[2]), 2), xy[, 2] + r[2], 
             xy[, 2] - r[2])
    }
  }
  else if (directions == 16) {
    r2 <- r * 2
    if (include) {
      d <- c(xy[, 1], rep(xy[, 1] - r2[1], 2), rep(xy[, 
                                                      1] + r2[1], 2), rep(xy[, 1] - r[1], 5), rep(xy[, 
                                                                                                     1] + r[1], 5), xy[, 1], xy[, 1], xy[, 2], rep(c(xy[, 
                                                                                                                                                        2] + r[2], xy[, 2] - r[2]), 2), rep(c(xy[, 2] + 
                                                                                                                                                                                                r2[2], xy[, 2] + r[2], xy[, 2], xy[, 2] - r[2], 
                                                                                                                                                                                              xy[, 2] - r2[2]), 2), xy[, 2] + r[2], xy[, 2] - 
               r[2])
    }
    else {
      d <- c(rep(xy[, 1] - r2[1], 2), rep(xy[, 1] + r2[1], 
                                          2), rep(xy[, 1] - r[1], 5), rep(xy[, 1] + r[1], 
                                                                          5), xy[, 1], xy[, 1], rep(c(xy[, 2] + r[2], 
                                                                                                      xy[, 2] - r[2]), 2), rep(c(xy[, 2] + r2[2], 
                                                                                                                                 xy[, 2] + r[2], xy[, 2], xy[, 2] - r[2], xy[, 
                                                                                                                                                                             2] - r2[2]), 2), xy[, 2] + r[2], xy[, 2] - 
               r[2])
    }
  }
  else if (directions == "bishop") {
    if (include) {
      d <- c(xy[, 1], rep(xy[, 1] - r[1], 2), rep(xy[, 
                                                     1] + r[1], 2), xy[, 2], rep(c(xy[, 2] + r[2], 
                                                                                   xy[, 2] - r[2]), 2))
    }
    else {
      d <- c(rep(xy[, 1] - r[1], 2), rep(xy[, 1] + r[1], 
                                         2), rep(c(xy[, 2] + r[2], xy[, 2] - r[2]), 2))
    }
    directions <- 4
  }
  else {
    stop("directions should be one of: 4, 8, 16, \"bishop\", or a matrix")
  }
  if (include) 
    directions <- directions + 1
  d <- matrix(d, ncol = 2)
  if (.isGlobalLonLat(x)) {
    d[, 1] <- (d[, 1] + 180)%%360 - 180
  }
  if (pairs) {
    if (mat) {
      cell <- rep(cells, each = directions)
    }
    else {
      cell <- rep(cells, directions)
    }
    if (id) {
      if (mat) {
        ID <- rep(1:length(cells), each = directions)
      }
      else {
        ID <- rep(1:length(cells), directions)
      }
      d <- cbind(ID, cell, cellFromXY(x, 
                                      d))
      attr(d, "na.action") <- NULL
      colnames(d) <- c("id", "from", "to")
      if (!is.null(target)) {
        d <- d[d[, 3] %in% target, ]
      }
    }
    else {
      d <- cbind(cell, cellFromXY(x, d))
      attr(d, "na.action") <- NULL
      colnames(d) <- c("from", "to")
      if (!is.null(target)) {
        d <- d[d[, 2] %in% target, ]
      }
    }
    if (sorted) {
      d <- d[order(d[, 1], d[, 2]), ]
    }
  }
  else {
    d <- as.vector(unique(cellFromXY(x, d)))
    if (!is.null(target)) {
      d <- intersect(d, target)
    }
    if (sorted) {
      d <- sort(d)
    }
  }
  d
}

# extract adjacent cell numbers
cells_ad <- adjacent_mod(r,cells, directions = 8, pairs=T, sorted=T, id=F)

# table them into a data.frame with the orientation
i=1
for (i in 1:length(unique(cells))) {
  if (i == 1) {
    df = data.frame(matrix(c(cells[i], cells_ad[which(cells_ad[,1]==cells[i]),2]), ncol=9))
  } else {
    df = rbind(df, data.frame(matrix(c(cells[i], cells_ad[which(cells_ad[,1]==cells[i]),2]), ncol=9)))
  }
}
names(df) = c("cell","nw","w","sw","ne","e","se","n","s")

# extract values from raster r
i=1
df_values = df
for (i in 1:dim(df)[1]) {
  df_values[i,] = extract (r, as.numeric(df[i,]))
}
1 голос
/ 26 июня 2019

Вот простая смежная функция для случая королевы, которая включает ячейки вне растра (как NA). 

adj <- function(x, rr, ngb, global) {
    a <- x + ngb
    # the below line is not strictly needed, so it should be faster without it
    # a[a < 1 | a > ncell(rr)] <- NA
    if (!global) {
        col <- colFromCell(rr, x)
        if (col == 1) {
            a[c(1,4,6)] <- NA
        } else if (col==nc) {
            a[c(3,5,8)] <- NA
        }
    }
    a
}

Ваш пример данных 

library(raster)
r <- raster(matrix(runif(100), 10))
cells <- c(34,22,50,10)

Применить функцию 

nc <- ncol(r)
nbrs <- c(-nc-1, -nc, -nc+1, -1, +1, +nc-1, +nc, +nc+1) 
ad <- t(sapply(cells, adj, rr=raster(r), ngb=nbrs, global=FALSE))   
colnames(ad) <- c("NW", "N", "NE", "W", "E", "SW", "S", "SE")

Извлечение значений 

ad[] <- extract(r, as.vector(ad))
...