sample points on polygon edge in R - r

If I have a spatialpolygons object in R, how can I generate a set of n points that are on the edge of that polygon?
I originally thought I could just sample from the polygon vertices, but it looks like there are sometimes stretches where there are no vertices because the polygon edge is a straight line...

A simple solution would be to use st_segmentize() from package sf that adds points to straight lines, then sample along these finer points.
st_segmentize() has an argument dfMaxLength that defines the max distance to allow along a line. The smaller you will set, the more points you will have. It should at least be as small as the minimum distance between any two points.
library(sf)
library(tidyverse)
## original form
poly <- st_polygon(x=list(cbind(x=c(1,2,3,1),y=c(1,2,1,1))))
# segmentize, then convert to points
poly_points <- st_segmentize(poly, dfMaxLength = 0.1) %>%
st_coordinates() %>%
as.data.frame() %>%
select(X, Y) %>%
st_as_sf(coords = c("X", "Y"))
## plot: you can just use sample() now on your point dataset
plot(poly, reset = FALSE, main = "segmentize (black point), then sample 5 (red points)")
plot(poly_points, reset = FALSE, add = TRUE)
plot(poly_points[sample(1:nrow(poly_points), size = 5),], add = TRUE, col = 2, pch = 19)
To get the minimum distance between any two points (beware of zero):
poly %>%
st_coordinates() %>%
as.data.frame() %>%
st_as_sf(coords = c("X", "Y")) %>%
st_distance() %>% c() %>%
unique() %>%
sort

Assuming you want to draw points around the perimeter, I would split this into two parts:
P(Point p on Edge e) = P(point p | Edge e) P(Edge e)
with P(Edge e) proportional to its length. So first sample an edge, then sample a point
on it.
Here's an example triangle:
poly <- Polygon(list(x=c(1,2,3,1),y=c(1,2,1,1)))
We'll calculate the lengths of the sides:
require(gsl) #for fast hypot function
xy <- poly#coords
dxy <- diff(xy)
h <- hypot(dxy[,"x"], dxy[,"y"])
and draw a random side:
e <- sample(nrow(dxy), 1, probs=h)
and then draw a point on that edge:
u <- runif(1)
p <- xy[e,] + u * dxy[e,]
Wrapping the whole thing in a function, we have:
rPointOnPerimeter <- function(n, poly) {
xy <- poly#coords
dxy <- diff(xy)
h <- hypot(dxy[,"x"], dxy[,"y"])
e <- sample(nrow(dxy), n,replace=TRUE, prob=h)
u <- runif(n)
p <- xy[e,] + u * dxy[e,]
p
}
with a demo:
plot( rPointOnPerimeter(100,poly) )

Related

select raster within a specified distance from polygon boundary

I want to select raster cells that are within a certain distance (for e.g. 1 km or 5 km) from the boundary of a polygon. I ultimately want to take an average of only those raster cells that are within the specified distance from the boundary of shapefile inwards.
The way I thought I would approach is to create a negative buffer inwards, and subtract the original polygon and the buffer. Then mask and crop the raster using the new polygon and take the average.
Here's sample data demonstrating what I want to do.
library(raster)
# raster
r <- raster(xmn=1035792, xmx= 1116792, ymn=825303.6, ymx=937803.6, resolution = 12.5,crs = "+init=epsg:3174")
r <- setValues(r, 0)
# polygon
x <- c(1199999, 1080000, 1093067, 1090190, 1087977, 1070419, 1180419)
y <- c(957803.6,937803.6, 894366.9, 872153.9, 853703.0, 825353.6, 805353.6)
poly.lake <- SpatialPolygons(list(Polygons(list(Polygon(data.frame(x,y))), ID = 1)))
r <- mask(r, poly.lake)
r <- crop(r, poly.lake)
plot(poly.lake)
plot(r, add = T)
Instead of taking average of the resulting raster r, I only want to average raster cells which are within a certain specified distance from the boundary.
The example data but using "terra"
library(terra)
r <- rast(xmin=1035792, xmax= 1116792, ymin=825303.6, ymax=937803.6, resolution = 125, crs = "epsg:3174")
values(r) <- 1:ncell(r)
# polygon
x <- c(1199999, 1080000, 1093067, 1090190, 1087977, 1070419, 1180419)
y <- c(957803.6,937803.6, 894366.9, 872153.9, 853703.0, 825353.6, 805353.6)
p <- vect(cbind(x, y), "polygons", crs = "epsg:3174")
r <- mask(r, p)
r <- crop(r, p)
You can now take the internal buffer of p
b <- buffer(p, -10000)
x <- mask(r, b, inverse=TRUE)
global(x, mean,na.rm=T)
# mean
#lyr.1 296549.9
Or you can take both sides like this
bb <- buffer(as.lines(p), 10000)
y <- mask(r, bb)
global(y, mean,na.rm=T)
# mean
#lyr.1 296751.3
So there is a slight difference between these two approaches; I think because the first uses inverse=TRUE; I would go with the second approach.
Your drawing (and Chris' answer) suggests that you only want the distance to the western border. In that case, you can first find the start and end nodes you need (from 2 to 6)
plot(p)
points(p)
text(as.points(p), pos=2)
Select the segments in between these nodes and create a line type SpatVector.
g <- geom(p)
k <- vect(g[2:6,], "lines", crs=crs(p))
lines(k, col="red", lwd=2)
And now do as above.
bk <- buffer(k, 10000)
z <- mask(r, bk)
global(z, mean,na.rm=T)
# mean
#lyr.1 297747
If you wanted to get the part of buffer bk that is inside the original polygon p you can do
bki <- intersect(bk, p)
To complete the plot
polys(bk, lty=3, border=NA, col=adjustcolor("light blue", alpha.f = 0.4))
lines(bki, lty=3)
Finding which segments of a polygon to buffer was what puzzled me, and this seems a decent approach cast_poly_to_subsegments. Taking your poly.lake as poly_sf:
geom <- lapply(
1:(length(st_coordinates(poly_sf)[, 1]) - 1),
function(i) {
rbind(
as.numeric(st_coordinates(poly_sf)[i, 1:2]),
as.numeric(st_coordinates(poly_sf)[i + 1, 1:2])
)
}
+ ) |>
st_multilinestring() |>
st_sfc(crs=st_crs(rt)) |>
st_cast('LINESTRING')
gives us
which is a little surprising, the 'green and red', that I assumed would be 'green'. It is wound clockwise so the desired segments to buffer are 4 & 5.
lns_buf4 <- st_buffer(st_geometry(geom)[4], 1000, singleSide = TRUE)
lns_buf5 <- st_buffer(st_geometry(geom)[5], 1000, singleSide= TRUE)
lns_buf5_neg <- st_buffer(st_geometry(geom)[5], -1000, singleSide= TRUE)
plot(st_geometry(geom), col = c('red', 'yellow', 'blue', 'green'))
plot(lns_buf4, col = 'black', add = TRUE)
plot(lns_buf5, col = 'green', add = TRUE)
plot(lns_buf5_neg, col = 'blue', add = TRUE)
Whether +/-1000 is sufficient is a further intersection test between the buffer poly(s) and the other boundary. If the desired sampling area is not rectangular, steps can be taken to construct a sampling polygon from the buffer and intersection.
#library(lwgeom)
# on poly_sf
new_line <- draw(x = 'line', col ='blue', lwd = 2, n = 10)
lns_buf5_10k_neg <- st_buffer(st_geometry(geom)[5], -10000, singleSide= TRUE)
new_line_sf <- st_as_sf(new_line, crs = st_crs(lns_buf5_10k_neg))
buf5_nline_split <- lwgeom::st_split(lns_buf5_10k_neg, new_line_sf$geometry)
irreg_smp_area <- st_collection_extract(buf5_nline_split)[1]
Though I'm happy to see it all done in terra.

Converting (alpha) hulls to spatial polygon

In R, I wish to convert the alpha shape polygon surrounding a bunch of points into one single spatial polygon object.
library(sf)
library(alphahull)
To start out, I create the point random points distribution
dat <- matrix(c(1,2,3,4,5, 3,3,5,6,9), ncol = 2)
I find the alpha shape covering the points (i.e. a polygon encompassing all points). I am particularly interested in this function as it has the feature to find a more or less tight polygon shape according to the given alpha
dat.ashape<- ashape(dat, alpha= 7)
I take the coordinates of the extreme
coords<- dat.ashape$x[dat.ashape$alpha.extreme,]
I make the last point same as the first (to have a closed shape)
coords<- rbind(coords, coords[1,])
To make things to work I need to order the point in sequence
coords<- cbind(coords, NA)
coords[,3]<- c(1, 5, 3, 2, 4, 6)
coords<- coords[order(coords[,3]),]
I create the simple spatial point feature from the coordinate matrix
dat.sf <- st_multipoint(coords, dim = "XYZ")
... and create the polygon
tst<- dat.sf %>% #
st_cast('POLYGON')
Finally, comparing the point and shape distribution and the polygon, I was able to build the polygon correctly, but this is rather easy with six points! (Because I made myself manually the right order)
plot(dat.ashape)
plot(tst, add=T, col=adjustcolor('red', alpha.f=.3), border=2)
In a more sophisticated example with say 100 points, I get stuck in the part where I should get the sequence of points right, before st_cast into polygon.
set.seed(1)
dat <- matrix(stats::rnorm(100), ncol = 2)
dat.ashape<- ashape(dat, alpha=7)
coords<- dat.ashape$x[dat.ashape$alpha.extreme,]
coords<- rbind(coords, coords[1,])
dat.sf <- st_multipoint(coords, dim = "XY")
tst <- dat.sf %>%
st_cast('POLYGON')
plot(dat.ashape)
plot(tst, add=T, col=adjustcolor('red', alpha.f=.3), col.line='red', border=2)
.... and I obviously do not get trick done.
I am grateful for any help!
OK, I was not happy with the concaveman. I really wanted the Delaunay triangulation as basis of my hull computation as I like alphahull a lot. Also, after reading this I wanted to find a (or my) viable way for converting the hull retrieved from alphahull package to a spatial polygon, which I could further use for my broader spatial analysis. Therefore I wrote the following function to do the job:
hull2poly <- function(my.ashape){
require(sf)
if(class(my.ashape) != "ashape") {stop('error, your input must be
ashape class')} else
my.edge<- data.frame(my.ashape$edges)[,c( 'x1', 'y1', 'x2', 'y2')]
x<- my.edge[,1:2]
y<- my.edge[,3:4]
my.edge2<- matrix(t(cbind(x,y)), byrow=T,ncol=2)
my.edge2<- as.data.frame(my.edge2)
names(my.edge2)<- c('x','y')
my.edge2$id <- unlist(lapply((1: (nrow(my.edge2)/2)),
FUN=function(x){c(rep(x,2))}))
start.edge<- 1
new.id<- start.edge
new.edges<- my.edge2[which(my.edge2$id== start.edge ),]
while(length(new.id)<= length(unique(my.edge2$id))-1){
internal.id<- new.id[length(new.id)]
edge <- my.edge2[which(my.edge2$id== internal.id ),]
where.to.search <- my.edge2[which(my.edge2$id %in% new.id ==F ),]
index1<- apply(where.to.search[,1:2], 1, function(x){x == edge[1,1:2]})
index1<- as.numeric(names(which(apply(index1,2, sum)>0)))[1]
index2<- apply(where.to.search[,1:2], 1, function(x){x == edge[2,1:2]})
index2<- as.numeric(names(which(apply(index2,2, sum)>0)))[1]
main.index<- c(index1, index2)
ifelse(all(!is.na(main.index)),
# yes
{flag<- c(T,T)
main.index<- main.index[2]
point.coord<- my.edge2[main.index,]
segment<- my.edge2[my.edge2$id==my.edge2[main.index,'id'],]
new.id<- c( new.id, my.edge2[main.index,]$id) },
# no
ifelse(which(!is.na(main.index))==1,
# yes
{flag<- c(T,F)
main.index<- main.index[flag]
point.coord<- my.edge2[main.index,]
segment<-
my.edge2[my.edge2$id==my.edge2[main.index,'id'],]
new.id<- c( new.id, my.edge2[main.index,]$id)},
# no
{flag<- c(F,T)
main.index<- main.index[flag]
point.coord<- my.edge2[main.index,]
segment<- my.edge2[my.edge2$id==my.edge2[main.index,'id'],]
new.id<- c( new.id, my.edge2[main.index,]$id)} ) )
index3<- t(apply(segment, 1, function(x){x ==point.coord}))
new.edges<- rbind(new.edges, rbind(point.coord, segment[which(apply(index3,1, sum)<3),]))
}
tst <- st_multipoint(as.matrix(new.edges), dim = "XYZ")
poly<- tst %>% #
st_cast('POLYGON')
return(poly)}
So, if you wish to give a try with a cloud of 1000 points:
library(alphahull)
set.seed(1)
dat <- matrix(stats::rnorm(1000), ncol = 2)
dat <- as.data.frame(dat)
dat.ashape<- ashape(dat, alpha= 2)
tmp<- hull2poly(dat.ashape)
plot(tmp)
I hope, it comes useful for someone.
Searching for further alternatives to packages alphahull, rgeos, sf for computing the hull surrounding a bunch of points, I finally found concaveman thanks to this post, which does the trick, being compatible with sf objects.
library(concaveman)
library(sf)
set.seed(1)
dat <- matrix(stats::rnorm(100), ncol = 2)
dat <- as.data.frame(dat)
names(dat)<- c('x', 'y')
dat.sf<-st_as_sf(dat, coords=c("x","y"))
polygon <- concaveman(dat.sf)
plot(dat.sf, pch=16)
plot(polygon, add=T, col=adjustcolor('red', alpha.f=.3), col.line='red', border=2)
The other answer wouldn't work for my dataset so I found another way.
First I used the coordinate pairs to create the line segments of the alpha shape. Then I just bound those line segments together and converted that to a polygon.
library(sp)
library(sf)
library(alphahull)
dat.ashape<- ashape(dat, alpha=7)
a<- data.frame(dat.ashape$edges)[,c( 'x1', 'y1', 'x2', 'y2')]
# create first line segment to initialize the object
i=1
line_obj <- sp::Line(cbind( c(a$x1[i], a$x2[i]),c(a$y1[i], a$y2[i]) ))
lines_obj <- sp::Lines(list(line_obj),ID=i)
myLines <- sp::SpatialLines(list(lines_obj))
for (i in 2:nrow(a)){
line_obj <- sp::Line(cbind( c(a$x1[i], a$x2[i]),c(a$y1[i], a$y2[i]) ))
lines_obj <- sp::Lines(list(line_obj),ID=i)
myLines <- rbind(myLines, sp::SpatialLines(list(lines_obj))) #bind the line to the rest
}
sfL<-as(myLines, "sf") #convert lines to sf
alphapoly = st_collection_extract(st_polygonize(st_union(sfL))) # union the lines and convert to polygon
apol<-as_Spatial(alphapoly) #if you want to convert back to sp
library(leaflet) #plot the line segments and polygon in Leaflet
leaflet() %>% addTiles() %>% addPolygons(data=apol) %>% addPolylines(data=myLines, color="yellow")

From points to buffer passing through a smoothed line using sf package

I have a lot of shapefiles of points that I have to manipulate in R.
My aim is to link all the points with a line, smooth it (to recreate a kind of path through points), segmentize the smoothed line in small sections (every section must have a precise length) and then create a buffer for every segments (then transform from lines to polygon) and finally count the points inside the polygons.
I start importing the points:
p <- st_read("/points.shp")
then I create the line:
l <- p %>% st_coordinates() %>% st_linestring()
From the line to the smoothed line:
ls <- smooth(l, method = "ksmooth")
Then I have created the segmentized smoothed line:
sls = st_segmentize(ls, 50)
And finally my buffer:
mybuf <- st_buffer(sls, dist= 30, endCapStyle="ROUND")
Unfortunately with this last command I can create only one buffer but I have to obtain a "segmented" buffer with a length of 50 meters and a height of 30m for each section.
I'm working with WGS84/UTM zone 32 N, epsg 32632 projection and my buffers must have the same projection.
Maybe there is another way to to that? Thanks...
Here the link to download a subset of the shapefile
From what I can tell, the main issue to surmount was that your code defines the line through your points as a single feature, so st_buffer was drawing a buffer around the whole line, rather than each segment between points. My goal was to figure out how to make sure each 50 meter segment was a unique feature.
library(sf)
library(smoothr)
cols <- c("red", "blue", "yellow")
source_file <- "./punti.shp"
par(mfrow = c(2,4))
p <- st_read(source_file)
plot(st_geometry(p), col = cols, main = "points")
l <- p %>% st_coordinates() %>% st_linestring()
plot(st_geometry(l), col = cols, main = "line")
l <- st_as_sf(data.frame(id = 1, geom=st_geometry(l)))
ls <- smooth(l, method = "ksmooth")
plot(st_geometry(ls), col = cols, main = "smoothed line")
# Note that segmentize doesn't slice a line
# Instead, it seems to just increases the number of vertices
sls <- st_segmentize(ls, 50)
slsp <- st_cast(sls, "POINT")
plot(st_geometry(slsp), col = cols, main = "segmented line vertices")
# Draw line between pairs of consecutive points
slsp <- st_as_sf(data.frame(id = 1, geom=st_geometry(slsp)))
slsp2 <- cbind(slsp[-nrow(slsp),"geometry"], slsp[-1,"geometry"])
ll <- st_sfc(mapply(function(a,b){
st_cast(st_union(a,b),"LINESTRING")}, slsp2$geometry, slsp2$geometry.1, SIMPLIFY=FALSE))
plot(st_geometry(ll), col = cols, main = "manually segmented line")
plot(st_geometry(head(ll)), col = cols, main = "man. segmented line, 1-10")
# Assign crs
st_crs(ll)
st_crs(ll) <- st_crs(p)
# Calculate buffers
mybuf <- st_buffer(ll, dist= 30, endCapStyle="ROUND")
plot(st_geometry(mybuf), col = cols, main = "buffers, all")
plot(st_geometry(head(mybuf)), col = cols, main = "buffers, 1-10")
# Count points in buffers
lengths(st_intersects(mybuf, p))

Create voronoi cells within each polygon seperately

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)

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)

Resources