Bộ đệm Euclide và trắc địa trong R

Để hiểu về bộ đệm trắc địa , Nhóm phát triển địa vật lý Esri phân biệt giữa bộ đệm Euclide và bộ đệm trắc địa. Họ kết luận với "Bộ đệm Euclide được thực hiện trên các lớp tính năng được chiếu có thể tạo ra bộ đệm sai lệch và không chính xác về mặt kỹ thuật. Tuy nhiên, bộ đệm trắc địa sẽ luôn tạo ra kết quả chính xác về mặt địa lý bởi vì bộ đệm trắc địa không bị ảnh hưởng bởi các biến dạng được giới thiệu bởi các hệ tọa độ dự kiến".

Tôi phải làm việc với một tập dữ liệu toàn cầu điểm và tọa độ không được cung cấp ( +proj=longlat +ellps=WGS84 +datum=WGS84). Có chức năng tạo bộ đệm trắc địa trong R khi chiều rộng được tính theo đơn vị số liệu không? Tôi nhận thức được gBuffertừ rgeosgói. Hàm này tạo một bộ đệm theo đơn vị của đối tượng không gian được sử dụng ( ví dụ ), vì vậy, tôi phải chiếu tọa độ để có thể tạo bộ đệm có X km mong muốn. Chiếu và sau đó áp dụng một gBufferphương tiện thực sự tạo ra bộ đệm Euclide trái ngược với bộ đệm trắc địa mà tôi cần. Dưới đây là một số mã để minh họa mối quan tâm của tôi:

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

Hình ảnh bên dưới mô tả bộ đệm Euclidian bị biến dạng (bán kính 1000 km) được tạo ra với mã từ phía trên.

Robert J. Hijmans trong phần Giới thiệu về gói Geosphere , phần này 4 Point at distance and bearingđưa ra một ví dụ về cách tạo ra "đa giác tròn có bán kính cố định, nhưng theo tọa độ kinh độ / vĩ độ", mà tôi nghĩ có thể được gọi là "bộ đệm trắc địa". Tôi đã bỏ qua ý tưởng này và tôi đã viết một số mã hy vọng sẽ thực hiện đúng, nhưng tôi tự hỏi liệu đã có một số chức năng R đệm trắc địa trong một số gói cho phép bán kính số liệu làm đầu vào:

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

Hình ảnh dưới đây mô tả bộ đệm Geodesic (bán kính 1000 km).

Chỉnh sửa 2019-02-12 : Để thuận tiện, tôi đã gói một phiên bản của chức năng trong gói geobuffer . Hãy đóng góp với các yêu cầu kéo.

Đối với hầu hết các mục đích, nó sẽ đủ chính xác để sử dụng mô hình hình cầu của trái đất - và mã hóa sẽ dễ dàng hơn và các phép tính nhanh hơn nhiều.

Theo đề xuất của M. Kennedy trong một bình luận, giải pháp này đệm Bắc Cực (rất dễ: ranh giới bộ đệm nằm ở một vĩ độ cố định) và sau đó xoay bộ đệm này vào bất kỳ vị trí mong muốn nào.

Việc xoay vòng được thực hiện bằng cách chuyển đổi bộ đệm ban đầu sang tọa độ Cartesian (XYZ), xoay vòng với phép nhân ma trận (nhanh) dọc theo Kinh tuyến gốc sang vĩ độ đích, chuyển đổi tọa độ của nó trở lại Địa lý (lat-lon), sau đó quay bộ đệm xung quanh trục Trái đất chỉ bằng cách thêm kinh độ mục tiêu vào mỗi tọa độ giây.

Tại sao làm điều đó trong hai bước khi (thông thường) một phép nhân ma trận đơn sẽ hoạt động? Bởi vì không cần mã đặc biệt để xác định các ngắt ở kinh tuyến +/- 180 độ. Thay vào đó, cách tiếp cận này có thể tạo ra kinh độ vượt quá phạm vi ban đầu (cho dù -180 đến 180 độ hoặc 0 đến 360 hoặc bất cứ điều gì), nhưng bằng cách đó, các quy trình vẽ đa giác tiêu chuẩn (và các quy trình phân tích khác) sẽ hoạt động tốt mà không cần sửa đổi. Nếu bạn phải có kinh độ trong một phạm vi nhất định, chỉ cần giảm modulo 360 độ ở cuối: đó là nhanh chóng và dễ dàng.

Khi điểm đệm, thông thường tất cả các bộ đệm có cùng bán kính. Giải pháp mô-đun này cho phép tăng tốc trong trường hợp này: bạn có thể đệm Bắc Cực và sau đó chuyển đổi nó thành tọa độ XYZ một lần và mãi mãi. Do đó, việc đệm từng điểm đòi hỏi phải nhân ma trận (rất nhanh), chuyển đổi trở lại tọa độ lat-lon và dịch chuyển các kinh độ (cũng rất nhanh). Dự kiến ​​sẽ tạo ra khoảng 10.000 bộ đệm có độ phân giải cao (360 đỉnh) mỗi giây.

RMã này hiển thị các chi tiết. Vì mục đích của nó là minh họa, nó không sử dụng các gói bổ trợ; không có gì được giấu hoặc chôn Nó bao gồm một bài kiểm tra trong đó một tập hợp các điểm ngẫu nhiên được tạo, đệm và hiển thị bằng tọa độ lat-lon (Địa lý) thô của nó. Đây là đầu ra:

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