在R中进行空间最近邻分配

Question

在R中进行空间最近邻分配

5

我正在研究如何根据地址将颗粒物暴露分配给特定个体。我有两个数据集，其中一个包含个体的经度和纬度坐标，另一个则是颗粒物暴露块。我想基于最接近的颗粒物暴露块为每个主题分配颗粒物暴露块。

library(sp)
library(raster)
library(tidyverse)

#subject level data
subjectID<-c("A1","A2","A3","A4")

subjects<-data.frame(tribble(
~lon,~lat,
-70.9821391,    42.3769511,
-61.8668537,    45.5267133,
-70.9344039,    41.6220337,
-70.7283830,    41.7123494
))

row.names(subjects)<-subjectID

#PM Block Locations 
blockID<-c("B1","B2","B3","B4","B5")

blocks<-data.frame(tribble(
~lon,~lat,
-70.9824591,    42.3769451,
-61.8664537,    45.5267453,
-70.9344539,    41.6220457,
-70.7284530,    41.7123454,
-70.7284430,    41.7193454
))

row.names(blocks)<-blockID

#Creating distance matrix
dis_matrix<-pointDistance(blocks,subjects,lonlat = TRUE)

###The above code doesnt preserve the row names. Is there a way to to do 
that?

###I'm unsure about the below code
colnames(dis_matrix)<-row.names(subjects)
row.names(dis_matrix)<-row.names(blocks)

dis_data<-data.frame(dis_matrix)

###Finding nearst neighbor and coercing to usable format 
getname <-function(x) {
row.names(dis_data[which.min(x),])
}

nn<-data.frame(lapply(dis_data,getname)) %>% 
gather(key=subject,value=neighbor)

这段代码的输出结果看起来是有意义的，但我不确定它的有效性和效率。欢迎您提供改进和修复这段代码的建议。我还收到以下错误信息：

Warning message:
attributes are not identical across measure variables;
they will be dropped

我无法确定其来源。

感谢您的查看！

- afossa

2个回答

1

如果你有一个大的数据集，你可能想使用非常高效的 nabor 包，如 @user3507085 在 this answer 中所解释的。由于这个问题已被关闭为离题，我已经复制并粘贴了下面的答案，以便它在本主题中“保持活跃”。我不知道这是否被认为是不好的做法，如果需要，我很乐意删除/编辑（请注意，knn 给出的距离不是地理距离，但我想它们可以通过简单的转换，包括 arcsin，转换为球面距离）。

lonlat2xyz=function (lon, lat, r) 
{
lon = lon * pi/180
lat = lat * pi/180
if (missing(r)) 
    r <- 6378.1
x <- r * cos(lat) * cos(lon)
y <- r * cos(lat) * sin(lon)
z <- r * sin(lat)
return(cbind(x, y, z))
}

lon1=runif(100,-180,180);lon2=runif(100,-180,180);lat1=runif(100,-90,90);lat2=runif(100,-90,90)

xyz1=lonlat2xyz(lon1,lat1)
xyz2=lonlat2xyz(lon2,lat2)

library(nabor)

out=knn(data=xyz1,query = xyz2,k=20)

library(maps)

map()
points(lon1,lat1,pch=16,col="black")
points(lon2[1],lat2[1],pch=16,col="red")
points(lon1[out$nn.idx[1,]],lat1[out$nn.idx[1,]],pch=16,col="blue")

- Ege Rubak

谢谢Ege，考虑效率绝对是有帮助的。数据集非常大。我也会使用这个版本进行实验。不过需要注意的是，确保在转换为地理距离时使用正确的椭球体（地球的球形模型）。点距离函数的优点就在于它使用了通用的WGS椭球体。 - afossa

我认为你可以使用nabor这种方法来找到每个点的最近邻，然后你可以使用另一个函数（如pointDistance或geosphere::distGeo）来精确计算到最近邻的距离。 - Ege Rubak

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- Robert Hijmans · Accepted Answer

这里是一些示例数据，展示如何使用 pointDistance ：

library(raster)

#subject level data
subjectID <- c("A1","A2","A3","A4")
subxy <- matrix(c(-65, 42, -60, 4.5, -70, 20, -75, 41 ), ncol=2, byrow=TRUE)
#PM Block Locations 
blockID <- c("B1","B2","B3","B4","B5")
blockxy <- matrix(c(-68, 22, -61, 25, -70, 31, -65, 11,-63, 21), ncol=2, byrow=TRUE)

# distance of all subxy to all blockxy points
d <- pointDistance(subxy, blockxy, lonlat=TRUE)

# get the blockxy record nearest to each subxy record
r <- apply(d, 1, which.min)
r
#[1] 3 4 1 3

所以这些配对关系如下:

p <- data.frame(subject=subjectID, block=blockID[r])
p

#  subject block
#1      A1    B3
#2      A2    B4
#3      A3    B1
#4      A4    B3

展示它的工作原理：

plot(rbind(blockxy, subxy), ylim=c(0,45), xlab='longitude', ylab='latitude')
points(blockxy, col="red", pch=20, cex=2)
points(subxy, col="blue", pch=20, cex=2)
text(subxy, subjectID, pos=1)
text(blockxy, blockID, pos=1)
for (i in 1:nrow(subxy)) {
    arrows(subxy[i,1], subxy[i,2], blockxy[r[i],1], blockxy[r[i],2])
}