R中与ggmap的自定义属性的地理热图

Question

目标是建立类似的东西 http://rentheatmap.com/sanfrancisco.html

我使用ggmap获取地图，并能够在其上绘制点。

library('ggmap')
map <- get_map(location=c(lon=20.46667, lat=44.81667), zoom=12, maptype='roadmap', color='bw')
positions <- data.frame(lon=rnorm(100, mean=20.46667, sd=0.05), lat=rnorm(100, mean=44.81667, sd=0.05), price=rnorm(10, mean=1000, sd=300))
ggmap(map) + geom_point(data=positions, mapping=aes(lon, lat)) + stat_density2d(data=positions, mapping=aes(x=lon, y=lat, fill=..level..), geom="polygon", alpha=0.3)

这是一个基于密度的漂亮图像。有没有人知道如何制作看起来相同的东西，但是使用position $ property来构建轮廓和缩放？

我通过stackoverflow.com彻底查看并找不到解决方案。

编辑1

positions$price_cuts <- cut(positions$price, breaks=5)
ggmap(map) + stat_density2d(data=positions, mapping=aes(x=lon, y=lat, fill=price_cuts), alpha=0.3, geom="polygon")

五个独立的stat_density图中的结果：

编辑2（来自hrbrmstr）

positions <- data.frame(lon=rnorm(10000, mean=20.46667, sd=0.05), lat=rnorm(10000, mean=44.81667, sd=0.05), price=rnorm(10, mean=1000, sd=300))
positions$price <- ((20.46667 - positions$lon) ^ 2 + (44.81667 - positions$lat) ^ 2) ^ 0.5 * 10000
positions <- data.frame(lon=rnorm(10000, mean=20.46667, sd=0.05), lat=rnorm(10000, mean=44.81667, sd=0.05))
positions$price <- ((20.46667 - positions$lon) ^ 2 + (44.81667 - positions$lat) ^ 2) ^ 0.5 * 10000
positions <- subset(positions, price < 1000)
positions$price_cuts <- cut(positions$price, breaks=5)
ggmap(map) + geom_hex(data=positions, aes(fill=price_cuts), alpha=0.3)

结果：

它也为真实数据创造了一个不错的画面。到目前为止，这是最好的结果。欢迎提出更多建议。

编辑3： 以下是上述方法的测试数据和结果：

https://raw.githubusercontent.com/artem-fedosov/share/master/kernel_smoothing_ggplot.csv

test<-read.csv('test.csv')
ggplot(data=test, aes(lon, lat, fill=price_cuts)) + stat_bin2d(, alpha=0.7) + geom_point() + scale_fill_brewer(palette="Blues")

我认为应该使用除密度内核之外的其他方法来计算适当的多边形。看起来该功能应该是开箱即用的ggplot，但我找不到它。

编辑4： 我感谢您花时间和精力找出这个看似不太复杂的问题的正确解决方案。我把你的答案都投票给了目标。

我发现了一个问题：带圆圈的数据太过于人为，而且这些方法在读取世界数据上表现不佳。

保罗的方法给了我情节：

它似乎捕获了很酷的数据模式。

jazzurro的批准给了我这个情节：

它也有模式。但是，这两个图似乎都不如默认的stat_density2d图那么漂亮。我还会等几天看看是否会出现其他解决方案。如果没有，我会将赏金奖给jazzurro，因为这将是我将坚持使用的结果。

有一个打开的python + google_maps版本的必需代码。可能有人会在这里找到灵感： https://github.com/jeffkaufman/apartment_prices

Answer 1

这是我的方法。 geom_hex方法很好。当它出来时，我真的很喜欢它。我仍然。既然你问了更多我试过以下的事情。我认为我的结果类似于stat_density2d的结果。但是，我可以避免你遇到的问题。我基本上自己创建了一个shapefile并绘制了多边形。我按价格区域（price_cuts）对数据进行子集化，并从边缘到区域中心绘制多边形。这种方法符合编辑1和编辑2.我认为如果你想绘制一个大面积的地图，还有一段距离可以达到你的最终目标。但是，我希望这会让你前进。最后，我想感谢几位SO用户，他们提出了与多边形相关的重要问题。没有他们，我无法想出这个答案。

library(dplyr)
library(data.table)
library(ggmap)
library(sp)
library(rgdal)
library(ggplot2)
library(RColorBrewer)


### Data set by the OP
positions <- data.frame(lon=rnorm(10000, mean=20.46667, sd=0.05), lat=rnorm(10000,    mean=44.81667, sd=0.05))

positions$price <- ((20.46667 - positions$lon) ^ 2 + (44.81667 - positions$lat) ^ 2) ^ 0.5 * 10000

positions <- subset(positions, price < 1000)


### Data arrangement
positions$price_cuts <- cut(positions$price, breaks=5)
positions$price_cuts <- as.character(as.integer(positions$price_cuts))

### Create a copy for now
ana <- positions

### Step 1: Get a map
map <- get_map(location=c(lon=20.46667, lat=44.81667), zoom=11, maptype='roadmap', color='bw')

### Step 2: I need to create SpatialPolygonDataFrame using the original data.
### http://stackoverflow.com/questions/25606512/create-polygon-from-points-and-save-as-shapefile
### For each price zone, create a polygon, SpatialPolygonDataFrame, and convert it
### it data.frame for ggplot.

cats <- list()

for(i in unique(ana$price_cuts)){

foo <- ana %>%
       filter(price_cuts == i) %>%
       select(lon, lat)

    ch <- chull(foo)
    coords <- foo[c(ch, ch[1]), ]

    sp_poly <- SpatialPolygons(list(Polygons(list(Polygon(coords)), ID=1)))

    bob <- fortify(sp_poly)

    bob$area <- i

    cats[[i]] <- bob
}

cathy <- as.data.frame(rbindlist(cats))


### Step 3: Draw a map
### The key thing may be that you subet data for each price_cuts and draw
### polygons from outer side given the following link.
### This link was great. This is exactly what I was thinking.
### http://stackoverflow.com/questions/21748852/choropleth-map-in-ggplot-with-polygons-that-have-holes

ggmap(map) +
    geom_polygon(aes(x = long, y = lat, group = group, fill = as.numeric(area)),
                 alpha = .3,
                 data = subset(cathy, area == 5))+
    geom_polygon(aes(x = long, y = lat, group = group, fill = as.numeric(area)),
                 alpha = .3,
                 data =subset(cathy, area == 4))+
    geom_polygon(aes(x = long, y = lat, group = group, fill = as.numeric(area)),
                 alpha = .3,
                 data = subset(cathy, area == 3))+
    geom_polygon(aes(x = long, y = lat, group = group, fill = as.numeric(area)),
                 alpha = .3,
                 data = subset(cathy, area == 2))+
    geom_polygon(aes(x = long, y = lat, group = group, fill = as.numeric(area)),
                 alpha= .3,
                 data = subset(cathy, area == 1))+
    geom_point(data = ana, aes(x = lon, y = lat), size = 0.3) +                              
    scale_fill_gradientn(colours = brewer.pal(5,"Spectral")) +
    scale_x_continuous(limits = c(20.35, 20.58), expand = c(0, 0)) +
    scale_y_continuous(limits = c(44.71, 44.93), expand = c(0, 0)) +
    guides(fill = guide_legend(title = "Property price zone"))

Answer 2

在我看来，您附加的链接中的地图是使用插值生成的。考虑到这一点，我想知道是否可以通过将插值栅格覆盖到ggmap上来实现类似的苦行僧。

library(ggmap)
library(akima) 
library(raster) 

## data set-up from question
map <- get_map(location=c(lon=20.46667, lat=44.81667), zoom=12, maptype='roadmap', color='bw')
positions <- data.frame(lon=rnorm(10000, mean=20.46667, sd=0.05), lat=rnorm(10000, mean=44.81667, sd=0.05), price=rnorm(10, mean=1000, sd=300))
positions$price <- ((20.46667 - positions$lon) ^ 2 + (44.81667 - positions$lat) ^ 2) ^ 0.5 * 10000
positions <- data.frame(lon=rnorm(10000, mean=20.46667, sd=0.05), lat=rnorm(10000, mean=44.81667, sd=0.05))
positions$price <- ((20.46667 - positions$lon) ^ 2 + (44.81667 - positions$lat) ^ 2) ^ 0.5 * 10000
positions <- subset(positions, price < 1000)

## interpolate values using akima package and convert to raster
r <- interp(positions$lon, positions$lat, positions$price, 
            xo=seq(min(positions$lon), max(positions$lon), length=100),
            yo=seq(min(positions$lat), max(positions$lat), length=100))
r <- cut(raster(r), breaks=5) 

## plot
ggmap(map) + inset_raster(r, extent(r)@xmin, extent(r)@xmax, extent(r)@ymin, extent(r)@ymax) +
  geom_point(data=positions, mapping=aes(lon, lat), alpha=0.2) 

http://i.stack.imgur.com/qzqfu.png

不幸的是，我无法弄清楚如何使用inset_raster更改颜色或alpha ...可能是因为我对ggmap不熟悉。

编辑1

这是一个非常有趣的问题让我摸不着头脑。当应用于真实世界的数据时，插值并没有我认为的那样。多边形接近你自己和jazzurro肯定看起来好多了！

想知道为什么光栅方法看起来如此锯齿状，我再看看你附上的地图，发现数据点周围有一个明显的缓冲区...我想知道我是否可以使用一些rgeos工具来尝试复制效果：

library(ggmap)
library(raster)
library(rgeos)
library(gplots)

## data set-up from question
dat <- read.csv("clipboard") # load real world data from your link
dat$price_cuts <- NULL
map <- get_map(location=c(lon=median(dat$lon), lat=median(dat$lat)), zoom=12, maptype='roadmap', color='bw')

## use rgeos to add buffer around points
coordinates(dat) <- c("lon","lat")
polys <- gBuffer(dat, byid=TRUE, width=0.005)

## calculate mean price in each circle
polys <- aggregate(dat, polys, FUN=mean)

## rasterize polygons
r <- raster(extent(polys), ncol=200, nrow=200) # define grid
r <- rasterize(polys, r, polys$price, fun=mean) 

## convert raster object to matrix, assign colors and plot
mat <- as.matrix(r)
colmat <- matrix(rich.colors(10, alpha=0.3)[cut(mat, 10)], nrow=nrow(mat), ncol=ncol(mat))
ggmap(map) + 
  inset_raster(colmat, extent(r)@xmin, extent(r)@xmax, extent(r)@ymin, extent(r)@ymax) +
  geom_point(data=data.frame(dat), mapping=aes(lon, lat), alpha=0.1, cex=0.1) 

P.S。我发现需要将一个颜色矩阵发送到inset_raster以自定义叠加层