Tampão Euclidiano e Geodésico em R

Em Entendendo o buffer geodésico , a equipe de desenvolvimento de geoprocessamento da Esri distingue entre buffer euclidiano e geodésico. Eles concluem com "O buffer euclidiano realizado em classes de recursos projetados pode produzir buffers enganosos e tecnicamente incorretos. No entanto, o buffer geodésico sempre produzirá resultados geograficamente precisos porque os buffers geodésicos não são afetados pelas distorções introduzidas pelos sistemas de coordenadas projetadas".

Eu tenho que trabalhar com um conjunto de dados global pontual e as coordenadas não são projetadas ( +proj=longlat +ellps=WGS84 +datum=WGS84). Existe uma função para criar um buffer geodésico em R quando a largura é fornecida em unidades métricas? Estou ciente gBufferdo rgeospacote. Esta função cria um buffer em unidades do objeto espacial que é usado ( exemplo ), então, eu tenho que projetar as coordenadas para poder criar um buffer de X km desejado. Projetar e, em seguida, aplicar um gBuffermeio, na verdade, fazer um buffer euclidiano em vez de um geodésico que eu preciso. Abaixo está um código para ilustrar minhas preocupações:

require(rgeos)
require(sp)
require(plotKML)

# Generate a random grid-points for a (almost) global bounding box
b.box <- as(raster::extent(120, -120, -60, 60), "SpatialPolygons")
proj4string(b.box) <- "+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs"
set.seed(2017)
pts <- sp::spsample(b.box, n=100, type="regular")
plot(pts@coords)

# Project to Mollweide to be able to apply buffer with `gBuffer` 
# (one could use other projection)
pts.moll <- sp::spTransform(pts, CRSobj = "+proj=moll")
# create 1000 km buffers around the points
buf1000km.moll <- rgeos::gBuffer(spgeom = pts.moll, byid = TRUE, width = 10^6)
plot(buf1000km.moll)
# convert back to WGS84 unprojected
buf1000km.WGS84 <- sp::spTransform(buf1000km.moll, CRSobj = proj4string(pts))
plot(buf1000km.WGS84) # distorsions are present
# save as KML to better visualize distorted Euclidian buffers on Google Earth
plotKML::kml(buf1000km.WGS84, file.name = "buf1000km.WGS84.kml")

A imagem abaixo mostra os buffers euclidianos distorcidos (raio de 1000 km) produzidos com o código acima.

Robert J. Hijmans, na introdução ao pacote "geosfera" , seção 4 Point at distance and bearingfornece um exemplo de como criar "polígonos circulares com um raio fixo, mas em coordenadas de longitude / latitude", que eu acho que podem ser chamadas de "buffer geodésico". Adotei essa ideia e escrevi um código que, com sorte, faz a coisa certa, mas me pergunto se já existe alguma função R do buffer geodésico em algum pacote que permita o raio métrico como entrada:

require(geosphere)

make_GeodesicBuffer <- function(pts, width) {
    ### A) Construct buffers as points at given distance and bearing
    # a vector of bearings (fallows a circle)
    dg <- seq(from = 0, to = 360, by = 5)

    # Construct equidistant points defining circle shapes (the "buffer points")
    buff.XY <- geosphere::destPoint(p = pts, 
                                    b = rep(dg, each = length(pts)), 
                                    d = width)

    ### B) Make SpatialPolygons
    # group (split) "buffer points" by id
    buff.XY <- as.data.frame(buff.XY)
    id  <- rep(1:length(pts), times = length(dg))
    lst <- split(buff.XY, id)

    # Make SpatialPolygons out of the list of coordinates
    poly   <- lapply(lst, sp::Polygon, hole = FALSE)
    polys  <- lapply(list(poly), sp::Polygons, ID = NA)
    spolys <- sp::SpatialPolygons(Srl = polys, 
                                  proj4string = CRS(as.character("+proj=longlat +ellps=WGS84 +datum=WGS84")))
    # Disaggregate (split in unique polygons)
    spolys <- sp::disaggregate(spolys)
    return(spolys)
}

buf1000km.geodesic <- make_GeodesicBuffer(pts, width=10^6)
# save as KML to visualize geodesic buffers on Google Earth
plotKML::kml(buf1000km.geodesic, file.name = "buf1000km.geodesic.kml")

A imagem abaixo mostra os buffers geodésicos (raio de 1000 km).

Edit 2019-02-12 : Por conveniência, envolvi uma versão da função no pacote geobuffer . Sinta-se livre para contribuir com solicitações de recebimento.

Para a maioria dos propósitos, será preciso o suficiente para usar um modelo esférico da Terra - e a codificação será mais fácil e os cálculos muito mais rápidos.

Seguindo as sugestões de M. Kennedy em um comentário, esta solução armazena em buffer o Pólo Norte (o que é fácil: o limite do buffer fica em uma latitude fixa) e depois gira esse buffer para qualquer local desejado.

A rotação é efetuada convertendo o buffer original em coordenadas cartesianas geocêntricas (XYZ), girando aquelas com uma multiplicação de matriz (rápida) ao longo do Meridiano Principal para a latitude alvo, convertendo suas coordenadas de volta para Geográfica (lat-lon) e girando o buffer ao redor do eixo da Terra simplesmente adicionando a longitude alvo a cada segunda coordenada.

Por que fazê-lo em duas etapas quando (normalmente) uma multiplicação de matriz única funcionaria? Porque não há necessidade de código especial para identificar as quebras no meridiano de +/- 180 graus. Em vez disso, essa abordagem pode gerar longitudes além do intervalo original (-180 a 180 graus ou 0 a 360 ou o que for), mas ao fazer isso, os procedimentos padrão de desenho de polígonos (e outros procedimentos analíticos) funcionarão bem sem modificação. Se você precisa ter longitudes em um determinado intervalo, basta reduzi-las em 360 graus no final: isso é rápido e fácil.

Ao armazenar pontos em buffer, normalmente todos os buffers têm o mesmo raio. Esta solução modular permite uma aceleração neste caso: você pode armazenar em buffer o Polo Norte e convertê-lo em coordenadas XYZ de uma vez por todas. O buffer de cada ponto exige, assim, a multiplicação (muito rápida) da matriz, a conversão de volta para as coordenadas lat-lon e a mudança das longitudes (também muito rápidas). Espere gerar cerca de 10.000 buffers de alta resolução (360 vértices) por segundo.

Este Rcódigo mostra os detalhes. Como seu objetivo é ilustrativo, ele não usa pacotes complementares; nada está oculto ou enterrado. Ele inclui um teste no qual um conjunto de pontos aleatórios é gerado, armazenado em buffer e exibido usando suas coordenadas lat-lon (Geographic) brutas. Aqui está a saída:

degrees.to.radians <- function(phi) phi * (pi / 180)
radians.to.degrees <- function(phi) phi * (180 / pi)
#
# Create a 3X3 matrix to rotate the North Pole to latitude `phi`, longitude 0.
# Solution: A rotation is a linear map, and therefore is determined by its
#           effect on a basis.  This rotation does the following:
#           (0,0,1) -> (cos(phi), 0, sin(phi))  {North Pole (Z-axis)}
#           (0,1,0) -> (0,1,0)                  {Y-axis is fixed}
#           (1,0,0) -> (sin(phi), 0, -cos(phi)) {Destination of X-axis}
#
rotation.create <- function(phi, is.radians=FALSE) {
  if (!is.radians) phi <- degrees.to.radians(phi)
  cos.phi <- cos(phi)
  sin.phi <- sin(phi)
  matrix(c(sin.phi, 0, -cos.phi, 0, 1, 0, cos.phi, 0, sin.phi), 3)
}
#
# Convert between geocentric and spherical coordinates for a unit sphere.
# Assumes `latlon` in degrees.  It may be a 2-vector or a 2-row matrix.
# Returns an array with three rows for x,y,z.
#
latlon.to.xyz <- function(latlon) {
  latlon <- degrees.to.radians(latlon)
  latlon <- matrix(latlon, nrow=2)
  cos.phi <- cos(latlon[1,])
  sin.phi <- sin(latlon[1,])
  cos.lambda <- cos(latlon[2,])
  sin.lambda <- sin(latlon[2,])
  rbind(x = cos.phi * cos.lambda,
        y = cos.phi * sin.lambda,
        z = sin.phi)
}
xyz.to.latlon <- function(xyz) {
  xyz <- matrix(xyz, nrow=3) 
  radians.to.degrees(rbind(phi=atan2(xyz[3,], sqrt(xyz[1,]^2 + xyz[2,]^2)),
                           lambda=atan2(xyz[2,], xyz[1,])))
}
#
# Create a circle of radius `r` centered at the North Pole, oriented positively.
# `r` is measured relative to the sphere's radius `R`.  For the authalic Earth,
# r==1 corresponds to 6,371,007.2 meters.
#
# `resolution` is the number of vertices to use in a polygonal approximation.
# The first and last vertex will coincide.
#
circle.create <- function(r, resolution=360, R=6371007.2) {
  phi <- pi/2 - r / R                       # Constant latitude of the circle
  resolution <- max(1, ceiling(resolution)) # Assures a positive integer
  radians.to.degrees(rbind(phi=rep(phi, resolution+1),
                           lambda=seq(0, 2*pi, length.out = resolution+1)))
}
#
# Rotate around the y-axis, sending the North Pole to `phi`; then
# rotate around the new North Pole by `lambda`.
# Output is in geographic (spherical) coordinates, but input points may be
# in Earth-centered Cartesian or geographic.
# No effort is made to clamp longitudes to a 360 degree range.  This can 
# facilitate later computations.  Clamping is easily done afterwards if needed:
# reduce the longitude modulo 360 degrees.
#
rotate <- function(p, phi, lambda, is.geographic=FALSE) {
  if (is.geographic) p <- latlon.to.xyz(p)
  a <- rotation.create(phi)   # First rotation matrix
  q <- xyz.to.latlon(a %*% p) # Rotate the XYZ coordinates
  q + c(0, lambda)            # Second rotation
}
#------------------------------------------------------------------------------#
#
# Test.
#
n <- 50                  # Number of circles
radius <- 1.5e6          # Radii, in meters
resolution <- 360
set.seed(17)             # Makes this code reproducible

#-- Generate random points for testing.
centers <- rbind(phi=(rbeta(n, 2, 2) - 1/2) * 180,
                 lambda=runif(n, 0, 360))

system.time({
  #-- Buffer the North Pole and convert to XYZ once and for all.
  p.0 <- circle.create(radius, resolution=resolution) 
  p <- latlon.to.xyz(p.0)

  #-- Buffer the set of points (`centers`).
  circles <- apply(centers, 2, function(center) 
    rotate(p, center[1], center[2]))

  #-- Convert into an array indexed by (latlon, vertex, point id).
  circles <- array(circles, c(2, resolution+1, n))
})
#
# Display the buffers (if there are not too many).
#
if (n <= 1000) {
  #-- Create a background map area and graticule.
  xlim <- range(circles[2,,]) # Extent of all longitudes in the buffers
  plot(xlim, c(-90, 90), type="n", xlim=xlim, ylim=c(-90,90), asp=1,
       xlab="Longitude", ylab="Latitude",
       main=paste(n, "Random Disks of Radius", signif(radius/1e3, 3), "Km"),
       sub="Centers shown with gray dots")
  abline(v=seq(-360, 720, by=45), lty=1, col="#d0d0d0")
  abline(h=seq(-90, 90, by=30), lty=1, col="#d0d0d0")

  #-- Display the buffers themselves.
  colors <- terrain.colors(n, alpha=1/3) # Vary their colors
  invisible(sapply(1:n, function(i) {
    polygon(circles[2,,i], circles[1,,i], col=colors[i])
  }))

  #-- Show the original points (and, optionally, labels).
  points(centers[2,], centers[1,], pch=21, bg="Gray", cex=min(1, sqrt(25/n)))
  # text(centers[2,], centers[1,], labels=1:n, cex=min(1, sqrt(100/n)))
}