Create voronoi cells within each polygon seperately - r
Data:
In the data below I have clusters, which are 2 large groupings of the data. Within each cluster are 5 districts. I use the points within each cluster to create a polygon for the cluster.
Problem: I'm attempting to calculate voronoi for each district within each cluster. So each of the 2 cluster polygons should have 5 voronoi cells within it.
How can I create 5 voronoi cells bounded by each cluster polygon?
library(dbplyr)
library(sf)
library(purrr)
library(concaveman)
# Create raw data
df <- data.frame(
"cluster" = c(1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2),
"district" = c('1_1','1_1','1_1','1_1','1_1','1_1','1_1','1_1','1_1','1_1','1_1','1_1','1_1','1_1','1_1','1_1','1_1','1_1','1_1','1_1','1_1','1_1','1_2','1_2','1_2','1_2','1_2','1_2','1_2','1_2','1_2','1_2','1_2','1_2','1_2','1_2','1_2','1_2','1_2','1_2','1_3','1_3','1_3','1_3','1_3','1_3','1_3','1_4','1_4','1_4','1_4','1_4','1_4','1_4','1_4','1_4','1_4','1_4','1_4','1_4','1_4','1_4','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','1_5','2_1','2_1','2_1','2_1','2_1','2_1','2_1','2_1','2_1','2_1','2_1','2_1','2_1','2_1','2_1','2_1','2_1','2_1','2_1','2_2','2_2','2_2','2_2','2_2','2_2','2_2','2_2','2_2','2_2','2_2','2_2','2_2','2_2','2_2','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_3','2_4','2_4','2_4','2_4','2_4','2_4','2_4','2_4','2_4','2_4','2_4','2_4','2_5','2_5','2_5','2_5','2_5','2_5','2_5','2_5','2_5','2_5','2_5','2_5','2_5','2_5'),
"mx" = c(0.973009090909091,0.973009090909091,0.973009090909091,0.973009090909091,0.973009090909091,0.973009090909091,0.973009090909091,0.973009090909091,0.973009090909091,0.973009090909091,0.973009090909091,0.973009090909091,0.973009090909091,0.973009090909091,0.973009090909091,0.973009090909091,0.973009090909091,0.973009090909091,0.973009090909091,0.973009090909091,0.973009090909091,0.973009090909091,1.10794444444444,1.10794444444444,1.10794444444444,1.10794444444444,1.10794444444444,1.10794444444444,1.10794444444444,1.10794444444444,1.10794444444444,1.10794444444444,1.10794444444444,1.10794444444444,1.10794444444444,1.10794444444444,1.10794444444444,1.10794444444444,1.10794444444444,1.10794444444444,0.983014285714286,0.983014285714286,0.983014285714286,0.983014285714286,0.983014285714286,0.983014285714286,0.983014285714286,1.20296666666667,1.20296666666667,1.20296666666667,1.20296666666667,1.20296666666667,1.20296666666667,1.20296666666667,1.20296666666667,1.20296666666667,1.20296666666667,1.20296666666667,1.20296666666667,1.20296666666667,1.20296666666667,1.20296666666667,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,1.31765526315789,0.560226315789474,0.560226315789474,0.560226315789474,0.560226315789474,0.560226315789474,0.560226315789474,0.560226315789474,0.560226315789474,0.560226315789474,0.560226315789474,0.560226315789474,0.560226315789474,0.560226315789474,0.560226315789474,0.560226315789474,0.560226315789474,0.560226315789474,0.560226315789474,0.560226315789474,0.377593333333333,0.377593333333333,0.377593333333333,0.377593333333333,0.377593333333333,0.377593333333333,0.377593333333333,0.377593333333333,0.377593333333333,0.377593333333333,0.377593333333333,0.377593333333333,0.377593333333333,0.377593333333333,0.377593333333333,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.7201725,0.215625,0.215625,0.215625,0.215625,0.215625,0.215625,0.215625,0.215625,0.215625,0.215625,0.215625,0.215625,0.369878571428571,0.369878571428571,0.369878571428571,0.369878571428571,0.369878571428571,0.369878571428571,0.369878571428571,0.369878571428571,0.369878571428571,0.369878571428571,0.369878571428571,0.369878571428571,0.369878571428571,0.369878571428571),
"my" = c(-1.27477272727273,-1.27477272727273,-1.27477272727273,-1.27477272727273,-1.27477272727273,-1.27477272727273,-1.27477272727273,-1.27477272727273,-1.27477272727273,-1.27477272727273,-1.27477272727273,-1.27477272727273,-1.27477272727273,-1.27477272727273,-1.27477272727273,-1.27477272727273,-1.27477272727273,-1.27477272727273,-1.27477272727273,-1.27477272727273,-1.27477272727273,-1.27477272727273,-1.49177777777778,-1.49177777777778,-1.49177777777778,-1.49177777777778,-1.49177777777778,-1.49177777777778,-1.49177777777778,-1.49177777777778,-1.49177777777778,-1.49177777777778,-1.49177777777778,-1.49177777777778,-1.49177777777778,-1.49177777777778,-1.49177777777778,-1.49177777777778,-1.49177777777778,-1.49177777777778,-1.07938571428571,-1.07938571428571,-1.07938571428571,-1.07938571428571,-1.07938571428571,-1.07938571428571,-1.07938571428571,-1.0937,-1.0937,-1.0937,-1.0937,-1.0937,-1.0937,-1.0937,-1.0937,-1.0937,-1.0937,-1.0937,-1.0937,-1.0937,-1.0937,-1.0937,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.15119473684211,-1.02930526315789,-1.02930526315789,-1.02930526315789,-1.02930526315789,-1.02930526315789,-1.02930526315789,-1.02930526315789,-1.02930526315789,-1.02930526315789,-1.02930526315789,-1.02930526315789,-1.02930526315789,-1.02930526315789,-1.02930526315789,-1.02930526315789,-1.02930526315789,-1.02930526315789,-1.02930526315789,-1.02930526315789,-1.10028666666667,-1.10028666666667,-1.10028666666667,-1.10028666666667,-1.10028666666667,-1.10028666666667,-1.10028666666667,-1.10028666666667,-1.10028666666667,-1.10028666666667,-1.10028666666667,-1.10028666666667,-1.10028666666667,-1.10028666666667,-1.10028666666667,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.9094475,-0.642783333333333,-0.642783333333333,-0.642783333333333,-0.642783333333333,-0.642783333333333,-0.642783333333333,-0.642783333333333,-0.642783333333333,-0.642783333333333,-0.642783333333333,-0.642783333333333,-0.642783333333333,-0.795914285714286,-0.795914285714286,-0.795914285714286,-0.795914285714286,-0.795914285714286,-0.795914285714286,-0.795914285714286,-0.795914285714286,-0.795914285714286,-0.795914285714286,-0.795914285714286,-0.795914285714286,-0.795914285714286,-0.795914285714286),
"ID" = 1:200,
"X" = c(1.0083,0.9068,1.0232,1.0005,0.8388,0.8655,1.0133,1.0106,1.0139,1.0537,0.8759,1.0063,1.0187,1.0241,1.0004,0.8886,1.0803,0.8518,0.9998,1.0154,0.8851,1.0252,1.0926,1.064,1.1015,1.0354,1.1511,1.1074,1.202,1.1063,1.0173,1.137,1.1156,1.0776,1.1315,1.2281,0.9974,1.1487,1.0098,1.2197,0.9598,0.9695,0.9268,1.0008,1.0827,0.9331,1.0084,1.1311,1.1856,1.1932,1.2464,1.2331,1.1944,1.1846,1.2203,1.1753,1.2245,1.2396,1.2682,1.2359,1.1918,1.1205,1.3166,1.3072,1.2984,1.2842,1.3451,1.3197,1.2996,1.3482,1.28,1.3051,1.4471,1.315,1.3177,1.3387,1.32,1.3508,1.2747,1.3681,1.2735,1.325,1.3093,1.3244,1.2626,1.3123,1.2819,1.2619,1.3639,1.3099,1.2783,1.3313,1.3895,1.3559,1.3521,1.2589,1.4204,1.2303,1.2808,1.3125,0.55,0.5483,0.6329,0.5006,0.5233,0.566,0.5673,0.4864,0.5658,0.5636,0.542,0.6146,0.5648,0.6092,0.5329,0.5726,0.574,0.62,0.51,0.3787,0.3769,0.3579,0.3881,0.3806,0.403,0.3962,0.409,0.3422,0.4361,0.3853,0.3568,0.3105,0.3674,0.3752,0.6694,0.6492,0.6568,0.6773,0.6237,0.7265,0.7201,0.7596,0.7049,0.7699,0.6555,0.7105,0.731,0.6376,0.8865,0.754,0.7983,0.699,0.7223,0.7214,0.6496,0.7907,0.7418,0.7825,0.7417,0.8978,0.7875,0.6874,0.7761,0.6189,0.706,0.7037,0.7149,0.7059,0.687,0.7888,0.6514,0.7271,0.6679,0.7067,0.2631,0.2701,0.0822,0.069,0.2196,0.2848,0.2661,0.2343,0.2905,0.0684,0.2874,0.252,0.3301,0.5509,0.3343,0.343,0.2951,0.2524,0.5442,0.3187,0.3143,0.3731,0.3352,0.2711,0.455,0.4609),
"Y" = c(-1.2547,-1.2297,-1.3071,-1.237,-1.362,-1.3776,-1.2552,-1.2354,-1.2396,-1.3493,-1.3019,-1.2484,-1.2435,-1.233,-1.217,-1.2715,-1.3396,-1.34,-1.233,-1.2511,-1.3333,-1.1851,-1.5461,-1.5043,-1.5452,-1.5412,-1.4937,-1.5425,-1.4155,-1.523,-1.549,-1.5077,-1.5458,-1.369,-1.5033,-1.3805,-1.5183,-1.4288,-1.5429,-1.3952,-1.0349,-1.0838,-1.0615,-1.0702,-1.0446,-1.1367,-1.124,-1.0626,-1.0958,-1.0808,-1.0775,-1.0499,-1.0963,-1.0341,-1.0348,-1.0838,-1.162,-1.0487,-1.0924,-1.1537,-1.2107,-1.1224,-1.1499,-1.1803,-1.2877,-1.1151,-1.1339,-1.1431,-1.1521,-1.1675,-1.1407,-1.1916,-1.1229,-1.1308,-1.1154,-1.183,-1.1214,-1.0793,-1.1857,-1.0679,-1.1633,-1.075,-1.1354,-1.1494,-1.162,-1.1582,-1.18,-1.1234,-1.1077,-1.1144,-1.1305,-1.1482,-1.2058,-1.1685,-1.2152,-1.1439,-1.1252,-1.2113,-1.1632,-1.1965,-0.9917,-0.9861,-1.064,-0.9898,-0.9799,-1.1048,-1.0085,-0.9395,-1.0425,-1.0806,-1.0132,-1.0785,-1.1109,-1.0632,-0.945,-1.009,-1.1005,-1.0759,-0.9732,-1.1279,-1.1746,-1.1957,-1.0738,-0.9896,-1.0601,-0.9735,-1.0953,-1.0849,-1.0406,-1.1202,-1.0781,-1.2002,-1.157,-1.1328,-0.7416,-0.9323,-0.9372,-0.7013,-0.9191,-0.9356,-0.9838,-0.9302,-0.9407,-1.044,-0.6478,-0.9147,-0.9688,-0.9272,-0.9494,-1.0817,-0.9915,-0.9329,-0.8514,-0.9665,-0.783,-0.9601,-0.8996,-0.7717,-1.0067,-0.9839,-1.0594,-0.9705,-1.01,-0.9163,-1.0049,-0.6829,-0.7918,-0.7353,-0.9295,-0.9944,-0.9524,-0.9257,-0.936,-0.7661,-0.5825,-0.5989,-0.7375,-0.7262,-0.594,-0.6145,-0.571,-0.7069,-0.6377,-0.7865,-0.5962,-0.5615,-0.7729,-0.7873,-0.7713,-0.7774,-0.816,-0.8865,-0.7689,-0.8591,-0.7913,-0.7231,-0.7859,-0.8542,-0.7447,-0.8042)
)
#Create cluster polygons from data
sf <- st_as_sf(df, coords = c("X","Y"), crs = 4326)
shapes <- map(unique(sf$cluster),
~ concaveman(sf[sf$cluster %in% .,])
) %>%
map2(unique(sf$cluster), ~ mutate(.x, cluster = .y)) %>%
reduce(rbind)
###################################################
# OK, here is where I start running into problems #
###################################################
# Attempt to calculate voronoi cells within each cluster polygon
bbox_polygon <- function(x) {
bb <- sf::st_bbox(x)
p <- matrix(
c(bb["xmin"], bb["ymin"],
bb["xmin"], bb["ymax"],
bb["xmax"], bb["ymax"],
bb["xmax"], bb["ymin"],
bb["xmin"], bb["ymin"]),
ncol = 2, byrow = T
)
sf::st_polygon(list(p))
}
sf_district <- df %>%
select(district, mx, my) %>%
st_as_sf(coords = c("mx","my"), crs = 4326)
sfbox <- st_sfc(bbox_polygon(sf_district))
v <- st_voronoi(st_union(sf_district), sfbox)
# Plot to see what it looks like
plot(st_intersection(st_cast(v), st_union(shapes)), col = 0)
If you look at the picture, you can see that I'm doing something wrong because the northwest polygon has 6 voronoi cells when there are only 5 districts in the data. I think the problem is that my script is just creating one big voronoi tesselation and then laying the polygon shapes on top of it, rather than calculating the voronoi for each cluster separately and then bounding them within each cluster polygon.
To get separate voronoi polygons for each "cluster", you can run a for loop. Instead of the expression v <- st_voronoi(st_union(sf_district), sfbox), as follows:
sf_district = st_join(sf_district, shapes)
result = list()
for(i in unique(sf_district$cluster)) {
u = sf_district[sf_district$cluster == i, ]
v = st_voronoi(st_union(u), sfbox)
v = st_intersection(st_cast(v), shapes[shapes$cluster == i, ])
result[[i]] = v
}
result = do.call(c, result)
This ensures that the voronoi polygons in each cluster are unaffected by other points, and that each cluster has as many polygons as there are points.
Here is a plot of the result:
plot(result, col = hcl.colors(length(result), "Set 2"))
plot(st_geometry(sf_district), add = TRUE)
Related
R: mask() and rasterize() with spatialPolygonsDataFrame having holes
I have a spatialPolygonsDataFrame consisting of 3 polygons. The third polygon has the same shape as the first but has a hole where the second polygon is located.
I built the hole in the using the answer from another question (How to add a hole to a polygon within a SpatialPolygonsDataFrame?).
library(raster)
library(sp)
# create rasters and store them in a list
r1 <- raster(xmn=1, xmx=5, ymn=1, ymx=5, nrows=4, ncols=4)
r1[] <- 1:length(r1)
# create SpatialPolygonsDataFrame
Sr1 = Polygon(cbind(c(1,5,4,1,1),c(1,2,5,4,1)))
Sr2 = Polygon(cbind(c(2,4,3,2),c(3,2,4,3)))
SpP = SpatialPolygons(list(Polygons(list(Sr1), "s1"), Polygons(list(Sr2), "s2")),
1:2)
dat = data.frame(ID = c("s1", "s2"), value = c("a", "b"))
row.names(dat) <- c("s1", "s2")
p <- SpatialPolygonsDataFrame(SpP, data = dat,
match.ID = TRUE)
AddHoleToPolygon <-function(poly,hole){
# invert the coordinates for Polygons to flag it as a hole
coordsHole <- hole#polygons[[1]]#Polygons[[1]]#coords
newHole <- Polygon(coordsHole,hole=TRUE)
# punch the hole in the main poly
listPol <- poly#polygons[[1]]#Polygons
listPol[[length(listPol)+1]] <- newHole
punch <- Polygons(listPol,poly#polygons[[1]]#ID)
# make the polygon a SpatialPolygonsDataFrame as the entry
new <- SpatialPolygons(list(punch),proj4string=poly#proj4string)
new <- SpatialPolygonsDataFrame(new,data=as(poly,"data.frame"))
return(new)
}
punchedPoly <-AddHoleToPolygon(p[1,],p[2,])
p1 <- rbind(p, punchedPoly, makeUniqueIDs = TRUE)
p1 <- p1[2:3,]
When I use mask() to "crop" the raster r1, then the hole is created, although the triangular polygon has a value and indeed is not a real hole. But it gets "overridden" by the third polygon with the hole:
masked_hole <- mask(r1, p1)
plot(masked_hole)
When I change the order of the polygons, then no hole is created:
m3 <- mask(r1, p1[c(2,1),])
plot(m3)
The function rasterize is affected in the same manner:
r2 <- rasterize(p1, r1, field = "value")
plot(r2)
r3 <- rasterize(p1[c(2,1),], r1, field = "value")
plot(r3)
In my real data I have holes where there are no "filling" polygons and those ones I want to keep as holes.
How can I fix the spatialPolygonsDataFrame for polygons that are creating holes where there are none?
How can I fix this issue without reordering but "transform" the hole-creating polygons?
It was a bug in the raster package which has been fixed meanwhile (see https://github.com/rspatial/raster/issues/60).
Reverse cluster analysis; identifying empty space or a lack of density in R with longitude and latitude?
I'm working on a project where I have a very large amount of points and I am looking to identify regions (defined by a lack of clustering) where the density of these points is statistically significantly less relative to others. Normally a visual would be enough but I have so many points that it is to difficult to tell where these empty spaces are and a density heat map doesn't help me zero in on smaller regions. Maybe I'm missing something very simpler here, but I am hoping someone can at least send me in the right direction of where to look. Below is a reproducible sample quick and dirty lets take these points from open data and map them to the borough file for NYC:
#libraries--------------------------
library(ggplot2)
library(ggmap)
library(sp)
library(jsonlite)
library(RJSONIO)
library(rgdal)
#call api data--------------------------
df = fromJSON("https://data.cityofnewyork.us/resource/24t3-xqyv.json?$query= SELECT Lat, Long_")
df <- data.frame(t(matrix(unlist(df),nrow=length(unlist(df[1])))))
names(df)[names(df) == 'X2'] = 'x'
names(df)[names(df) == 'X1'] = 'y'
df = df[, c("x", "y")]
df$x = as.numeric(as.character(df$x))
df$y = as.numeric(as.character(df$y))
df$x = round(df$x, 4)
df$y = round(df$y, 4)
df$x[df$x < -74.2] = NA
df$y[df$y < 40.5] = NA
df = na.omit(df)
#map data----------------------------
cd = readOGR("nybb.shp", layer = "nybb")
cd = spTransform(cd, CRS("+proj=longlat +datum=WGS84"))
cd_f = fortify(cd)
#map data
nyc = ggplot() +
geom_polygon(aes(x=long,
y=lat, group=group), fill='grey',
size=.2,color='black', data=cd_f, alpha=1)
nyc + geom_point(aes(x = x, y = y), data = df, size = 1)
#how would I go about finding the empty spaces? That is the regions where there are no clusters?
In this case there aren't a lot of points but for the sake of demonstration, how would I:
identify pockets of low density
potentially draw polygon boundaries on those pockets?
Appreciate the help!
One way to get polygonal areas of low density would be to construct the
Dirichlet/Voronoi tesselation and choose the largest ones.
Below I use spatstat and deldir (loaded by spatstat) to do this.
It is not so fast so with many more points I don't know how well it will
go.
To use the results in ggmap and other spatial packages you can convert
back from owin and ppp to the spatial classes from sp and use
spTransform to get lat, long coordinates.
First load the packages:
library(maptools)
library(spatstat)
library(jsonlite)
Map and points in coordinates of shapefile (note I read in data from
local files downloaded from www):
cd = readOGR("nybb.shp", layer = "nybb")
#> OGR data source with driver: ESRI Shapefile
#> Source: "nybb.shp", layer: "nybb"
#> with 5 features
#> It has 4 fields
df <- fromJSON("NYC_data.json")
df <- as.data.frame(matrix(as.numeric(unlist(df)), ncol = 2, byrow = TRUE))
df <- df[, c(2, 1)]
names(df) <- c("x", "y")
df <- df[df$x > -74.2 & df$y > 40.5, ]
coordinates(df) <- ~x+y
proj4string(df) <- CRS("+proj=longlat +datum=WGS84")
df2 <- spTransform(df, proj4string(cd))
Switch to spatstat classes:
cd2 <- as(cd, "SpatialPolygons")
W <- as(cd2, "owin")
X <- as(df2, "ppp")
Window(X) <- W
plot(X, main = "")
Compute Dirichlet tessellation and areas and plot the tessellation:
d <- dirichlet(X)
#> Warning: 96 duplicated points were removed
a <- tile.areas(d)
plot(d, main = "")
Combine the n_areas biggest areas of the tessellation:
n_areas <- 30
empty <- tess(tiles = d$tiles[tail(order(a), n = n_areas)])
empty2 <- as.owin(empty)
Plot the result:
plot(W, main = "")
plot(empty2, col = "red", add = TRUE)
plot(X, add = TRUE)
Counting spatialpoints in gridcells
SO-gurues!
I am trying to count the densities of surviving units in different gridcells.
I have two shapefiles with points from the two survey periods in question (one before and one after the mortality event). What I intend is to see whether there is a difference in survival rates and link the proportion of survival to any climatic variable obtained from the raster value of the desired grid. In the code snippet below I have created some random raster and shapefiles.
packs = c('raster', 'rgdal', 'spatstat', 'sp' ,'dplyr')
sapply(packs, FUN = 'require', character.only = TRUE)
xy <- matrix(rnorm(1024),32,32) #Creating the desired raster
image(xy)
rast <- raster(xy)
extent(rast) <- c(36,37,-3,-2)
projection(rast) <- CRS("+proj=longlat +datum=WGS84")
points <- runifpoint(n =4000, c(36,37,-3,-2)) # Creating the points
x <- points$x
y <- points$y
values <- c(rep(1, 900), rep(0, 3100))
xy <- cbind(x, y)
points <- cbind(x, y, values)
points <- data.frame(points)
shp <- SpatialPointsDataFrame(coords = xy, data = data.frame(values) ) # creating shpfiles
projection(shp) <- CRS("+proj=longlat +datum=WGS84")
subs <- filter(points, values == 1)
suxy <- select(subs, x,y)
shpsub <- SpatialPointsDataFrame(coords = suxy, data = data.frame(subs$values)) # creating shpfiles
projection(shpsub) <- CRS("+proj=longlat +datum=WGS84")
When I attempt to extract the points I use the following lines of code
shp <- spTransform(shp, projection(rast)) # make sure they have same transformation
shpsub <- spTransform(shpsub, projection(rast))
XY <- xyFromCell(rast, cell = 1:ncell(rast))
v <- as.data.frame(rast) #Extract values from raster
XY <- data.frame(XY, v) # Creating a data frame containing coord., cellno and value
XY$cell <- c(1:ncell(rast))
cells <- cellFromXY(rast,shp) # find which cells the points are in
cells <- rle(cells) # returns a value and a length, fast for counting
cellsfound <- cellFromXY(rast,shpsub)
cellsfound <- rle(cellsfound)
Proportion <- data.frame(cell = cells$values, shp = cells$lengths)
test <- data.frame(cell = rep(NA,NROW(Proportion)), shpsub = rep(NA, NROW(Proportion)))
test$cell <- c(cellsfound$values, rep(NA, nrow(test) - length(cellsfound$values)))
test$shpsub <- c(cellsfound$lengths, rep(NA, NROW(test) - length(cellsfound$lengths)))
Proportion <- full_join(Proportion, test, by = "cell")
test.Proportion <- mutate(Proportion, Proportion = shpsub/shp) #Calculating Proportion
XY <- left_join(XY, test.Proportion, by = "cell") # Adding Proportion to coord and cell no.
XY.m <- summarise(XY, )
XY <- na.omit(XY) ; XY <- XY[,-4]
As I see it. Using rle() returns the same cells multiple times instead of counting the no of points within each individual cell as was my intention. Can anyone please explain me how to do this in a way that retrieves the information on the number of occurrences in the individual cells?
Generate regularly spaced points in polygon
Is there a way to generate regularly spaced (e.g., 500 meters apart) points within a polygon using R? I have been trying to use the sp package but can't seem to define a set of points that are spaced a certain distance apart from one another. My aim is to generate the points, then extract their lat/long coordinates into a new dataframe. Any help would be much appreciated! Thanks
Quite straight forward and almost out-of-the-box.
As OP did not share data, buckle up, put your seats in a vertical position and let us fly to Paris. There, we will adapt a geosphere function, and with its help we will divide up Paris' shape into lon / lat coordinates that are 500 meters apart each (vertically and horizontally).
# Load necessary libraries.
library(raster)
library(geosphere)
library(tidyverse)
library(sp)
# This is an adapted version of geosphere's destPoint() function that works with
# changing d (distance).
destPoint_v <- function (x, y, b, d, a = 6378137, f = 1/298.257223563, ...)
{
r <- list(...)$r
if (!is.null(r)) {
return(.old_destPoint(x, y, b, d, r = r))
}
b <- as.vector(b)
d <- as.vector(d)
x <- as.vector(x)
y <- as.vector(y)
p <- cbind(x, y, b, d)
r <- .Call("_geodesic", as.double(p[, 1]), as.double(p[, 2]),
as.double(p[, 3]), as.double(p[, 4]),
as.double(a), as.double(f),
PACKAGE = "geosphere")
r <- matrix(r, ncol = 3, byrow = TRUE)
colnames(r) <- c("lon", "lat", "finalbearing")
return(r[, 1:2, drop = FALSE])
}
# Data can be downloaded from
# http://osm13.openstreetmap.fr/~cquest/openfla/export/communes-20190101-shp.zip
# or
# https://www.data.gouv.fr/en/datasets/decoupage-administratif-communal-francais-issu-d-openstreetmap/
# ("Export simple de janvier 2019 (225Mo)")
# Load shapefile.
# shp <- raster::shapefile("Dropbox/work/crema/communes-20190101-shp/communes-20190101.shp")
# Extract Paris.
paris <- shp[shp$nom == "Paris", ]
# Set distance of points in meters.
dist <- 500
# Extract bounding box from Paris' SpatialPolygonDataFrame.
bbox <- raster::extent(paris)
# Calculate number of points on the vertical axis.
ny <- ceiling(geosphere::distGeo(p1 = c(bbox#xmin, bbox#ymin),
p2 = c(bbox#xmin, bbox#ymax)) / dist)
# Calculate maximum number of points on the horizontal axis.
# This needs to be calculated for the lowermost and uppermost horizontal lines
# as the distance between latitudinal lines varies when the longitude changes.
nx <- ceiling(max(geosphere::distGeo(p1 = c(bbox#xmin, bbox#ymin),
p2 = c(bbox#xmax, bbox#ymin)) / dist,
geosphere::distGeo(p1 = c(bbox#xmin, bbox#ymax),
p2 = c(bbox#xmax, bbox#ymax)) / dist))
# Create result data frame with number of points on vertical axis.
df <- data.frame(ny = 1:ny)
# Calculate coordinates along the vertical axis.
pts <- geosphere::destPoint(p = c(bbox#xmin, bbox#ymin),
b = 0, d = dist * (1:ny - 1))
df$x <- pts[, 1]
df$y <- pts[, 2]
# Add points on horizontal axis.
df <- tidyr::crossing(nx = 1:nx, df)
# Calculate coordinates.
pts <- destPoint_v(df$x, df$y, b = 90, 500 * (df$nx - 1))
# Turn coordinates into SpatialPoints.
pts <- SpatialPoints(cbind(pts[, 1], pts[, 2]), proj4string = CRS(proj4string(paris)))
# Cut to boundaries of Paris.
result <- raster::intersect(pts, paris)
# Plot result.
plot(result)
title("Paris in Points")
Kind of looks like a fish, doesn't it?
Here is a way to do assuming you have a lonlat polygon by first transforming it to a planar crs (not as nifty as Roman's solution with destPoint).
Packages and example data
library(raster)
library(rgdal)
p <- shapefile(system.file("external/lux.shp", package="raster"))[1,]
Transform to planar crs (pick one that matches your data!)
putm <- spTransform(p, "+proj=utm +zone=32 +datum=WGS84")
Create a raster with 500 m resolution, rasterize the polygon and transform to points
r <- raster(putm, res=500)
r <- rasterize(putm, r)
pts <- rasterToPoints(r, spatial=TRUE)
Transform the points to lon/lat and plot the results
pts_lonlat <- spTransform(pts, "+proj=longlat +datum=WGS84")
result <- coordinates(pts_lonlat)
plot(p)
points(result, pch="+", cex=.5)
(looks like an elephant)
world map - map halves of countries to different colors
I am using the example here for discussion:
ggplot map with l
library(rgdal)
library(ggplot2)
library(maptools)
# Data from http://thematicmapping.org/downloads/world_borders.php.
# Direct link: http://thematicmapping.org/downloads/TM_WORLD_BORDERS_SIMPL-0.3.zip
# Unpack and put the files in a dir 'data'
gpclibPermit()
world.map <- readOGR(dsn="data", layer="TM_WORLD_BORDERS_SIMPL-0.3")
world.ggmap <- fortify(world.map, region = "NAME")
n <- length(unique(world.ggmap$id))
df <- data.frame(id = unique(world.ggmap$id),
growth = 4*runif(n),
category = factor(sample(1:5, n, replace=T)))
## noise
df[c(sample(1:100,40)),c("growth", "category")] <- NA
ggplot(df, aes(map_id = id)) +
geom_map(aes(fill = growth, color = category), map =world.ggmap) +
expand_limits(x = world.ggmap$long, y = world.ggmap$lat) +
scale_fill_gradient(low = "red", high = "blue", guide = "colorbar")
Gives the following results:
I would like to map one variable to the left "half" of a country and a different variable to the right "half" of the country. I put "half" in quotes because it's not clearly defined (or at least I'm not clearly defining it). The answer by Ian Fellows might help (which gives an easy way to get the centroid). I'm hoping for something so that I can do aes(left_half_color = growth, right_half_color = category) in the example. I'm also interested in top half and bottom half if that is different.
If possible, I would also like to map the individual centroids of the halves to something.
This is a solution without ggplot that relies on the plot function instead. It also requires the rgeos package in addition to the code in the OP:
EDIT Now with 10% less visual pain
EDIT 2 Now with centroids for east and west halves
library(rgeos)
library(RColorBrewer)
# Get centroids of countries
theCents <- coordinates(world.map)
# extract the polygons objects
pl <- slot(world.map, "polygons")
# Create square polygons that cover the east (left) half of each country's bbox
lpolys <- lapply(seq_along(pl), function(x) {
lbox <- bbox(pl[[x]])
lbox[1, 2] <- theCents[x, 1]
Polygon(expand.grid(lbox[1,], lbox[2,])[c(1,3,4,2,1),])
})
# Slightly different data handling
wmRN <- row.names(world.map)
n <- nrow(world.map#data)
world.map#data[, c("growth", "category")] <- list(growth = 4*runif(n),
category = factor(sample(1:5, n, replace=TRUE)))
# Determine the intersection of each country with the respective "left polygon"
lPolys <- lapply(seq_along(lpolys), function(x) {
curLPol <- SpatialPolygons(list(Polygons(lpolys[x], wmRN[x])),
proj4string=CRS(proj4string(world.map)))
curPl <- SpatialPolygons(pl[x], proj4string=CRS(proj4string(world.map)))
theInt <- gIntersection(curLPol, curPl, id = wmRN[x])
theInt
})
# Create a SpatialPolygonDataFrame of the intersections
lSPDF <- SpatialPolygonsDataFrame(SpatialPolygons(unlist(lapply(lPolys,
slot, "polygons")), proj4string = CRS(proj4string(world.map))),
world.map#data)
##########
## EDIT ##
##########
# Create a slightly less harsh color set
s_growth <- scale(world.map#data$growth,
center = min(world.map#data$growth), scale = max(world.map#data$growth))
growthRGB <- colorRamp(c("red", "blue"))(s_growth)
growthCols <- apply(growthRGB, 1, function(x) rgb(x[1], x[2], x[3],
maxColorValue = 255))
catCols <- brewer.pal(nlevels(lSPDF#data$category), "Pastel2")
# and plot
plot(world.map, col = growthCols, bg = "grey90")
plot(lSPDF, col = catCols[lSPDF#data$category], add = TRUE)
Perhaps someone can come up with a good solution using ggplot2. However, based on this answer to a question about multiple fill scales for a single graph ("You can't"), a ggplot2 solution seems unlikely without faceting (which might be a good approach, as suggested in the comments above).
EDIT re: mapping centroids of the halves to something: The centroids for the east ("left") halves can be obtained by
coordinates(lSPDF)
Those for the west ("right") halves can be obtained by creating an rSPDF object in a similar way:
# Create square polygons that cover west (right) half of each country's bbox
rpolys <- lapply(seq_along(pl), function(x) {
rbox <- bbox(pl[[x]])
rbox[1, 1] <- theCents[x, 1]
Polygon(expand.grid(rbox[1,], rbox[2,])[c(1,3,4,2,1),])
})
# Determine the intersection of each country with the respective "right polygon"
rPolys <- lapply(seq_along(rpolys), function(x) {
curRPol <- SpatialPolygons(list(Polygons(rpolys[x], wmRN[x])),
proj4string=CRS(proj4string(world.map)))
curPl <- SpatialPolygons(pl[x], proj4string=CRS(proj4string(world.map)))
theInt <- gIntersection(curRPol, curPl, id = wmRN[x])
theInt
})
# Create a SpatialPolygonDataFrame of the western (right) intersections
rSPDF <- SpatialPolygonsDataFrame(SpatialPolygons(unlist(lapply(rPolys,
slot, "polygons")), proj4string = CRS(proj4string(world.map))),
world.map#data)
Then information could be plotted on the map according to the centroids of lSPDF or rSPDF:
points(coordinates(rSPDF), col = factor(rSPDF#data$REGION))
# or
text(coordinates(lSPDF), labels = lSPDF#data$FIPS, cex = .7)