Connect Linestrings - r

How can i connect two linestrings?
It is possible to lay a very slim buffer around the lines and then connect them like so:
one_line <- lines %>%
st_buffer(0.05) %>%
st_intersection() %>%
st_union() %>%
st_cast('LINESTRING')
There are 2 problems with this:
a) below is a very small subset of my data containing one such disconnected line segment - if i use the above method on the small part it forms a complete polygon which, when converted to a linestring just makes a very narrow loop
b) if i use the whole data set it kind of works but creates lines at the approximate distance of the buffer around my original line. See picture below:
Blue & red are the edge lines while black would be the original.
I thought to simply average them out but when i convert the 2 lines to coordinates (st_coordinates()), the resulting tables have different lengths and are not in order.
I looked around but did not really find any useful answers.
Here is a dput of the geometry data:
lines <- structure(list(structure(list(structure(c(2880, 2880.92, 2881.72,
2882.47, 2883.17, 2883.84, 2884.5, 2894.05, 2894.69, 2895.29393034826,
340255.362641509, 340257.22, 340259.03, 340260.85, 340262.69,
340264.55, 340266.4, 340293.7, 340295.61, 340297.500995024), .Dim = c(10L,
2L)), structure(c(2907.22402724177, 2914.21353757771, 340330.886392736,
340350.2), .Dim = c(2L, 2L))), class = c("XY", "MULTILINESTRING",
"sfg")), structure(c(2895.3, 2896.82, 2897.26, 2897.72, 2907.2,
340297.52, 340302.26, 340303.58, 340304.89, 340330.82), .Dim = c(5L,
2L), class = c("XY", "LINESTRING", "sfg"))), n_empty = 0L, crs = structure(list(
input = "EPSG:31256", wkt = "PROJCRS[\"MGI / Austria GK East\",\n BASEGEOGCRS[\"MGI\",\n DATUM[\"Militar-Geographische Institut\",\n ELLIPSOID[\"Bessel 1841\",6377397.155,299.1528128,\n LENGTHUNIT[\"metre\",1]]],\n PRIMEM[\"Greenwich\",0,\n ANGLEUNIT[\"degree\",0.0174532925199433]],\n ID[\"EPSG\",4312]],\n CONVERSION[\"Austria Gauss-Kruger East\",\n METHOD[\"Transverse Mercator\",\n ID[\"EPSG\",9807]],\n PARAMETER[\"Latitude of natural origin\",0,\n ANGLEUNIT[\"degree\",0.0174532925199433],\n ID[\"EPSG\",8801]],\n PARAMETER[\"Longitude of natural origin\",16.3333333333333,\n ANGLEUNIT[\"degree\",0.0174532925199433],\n ID[\"EPSG\",8802]],\n PARAMETER[\"Scale factor at natural origin\",1,\n SCALEUNIT[\"unity\",1],\n ID[\"EPSG\",8805]],\n PARAMETER[\"False easting\",0,\n LENGTHUNIT[\"metre\",1],\n ID[\"EPSG\",8806]],\n PARAMETER[\"False northing\",-5000000,\n LENGTHUNIT[\"metre\",1],\n ID[\"EPSG\",8807]]],\n CS[Cartesian,2],\n AXIS[\"northing (X)\",north,\n ORDER[1],\n LENGTHUNIT[\"metre\",1]],\n AXIS[\"easting (Y)\",east,\n ORDER[2],\n LENGTHUNIT[\"metre\",1]],\n USAGE[\n SCOPE[\"Engineering survey, topographic mapping.\"],\n AREA[\"Austria east of 14°50'E of Greenwich (32°30'E of Ferro).\"],\n BBOX[46.56,14.83,49.02,17.17]],\n ID[\"EPSG\",31256]]"), class = "crs"), idx = structure(c(1,
2, 1, 1), .Dim = c(2L, 2L)), class = c("sfc_GEOMETRY", "sfc"), precision = 0, bbox = structure(c(xmin = 2880,
ymin = 340255.362641509, xmax = 2914.21353757771, ymax = 340350.2
), class = "bbox"), classes = c("MULTILINESTRING", "LINESTRING"
))

For the above example, you could cast to MULTIPOINT, then union, and cast to LINESTRING.
``` r
library(tidyverse) #overkill, but easier
library(sf)
library(patchwork) #to plot side-by-side
# load data from above
# lines <-
single_line <- lines %>%
st_as_sf() %>%
st_cast('MULTIPOINT') %>%
st_union() %>%
st_cast('LINESTRING')
head(single_line)
#> Geometry set for 1 feature
#> Geometry type: LINESTRING
#> Dimension: XY
#> Bounding box: xmin: 2880 ymin: 340255.4 xmax: 2914.214 ymax: 340350.2
#> Projected CRS: MGI / Austria GK East
#> LINESTRING (2880 340255.4, 2880.92 340257.2, 28...
p1 <- ggplot() +
geom_sf(data = st_as_sf(lines), col = c('red', 'blue')) + ggtitle('lines')
p2 <- ggplot() + geom_sf(data = single_line, col = 'black') + ggtitle('lines cast & unioned')
p3 <- p1 + p2
p3
Created on 2022-03-08 by the reprex package (v0.3.0)

This is an incomplete answer because it still requires some manual input but it can be generalized by implementing a few rules.
The idea is to find the places where the line is broken and then go to the start/endpoints of the closest line. Then make a line segment bridging the break and combining all the line segments.
library(lwgeom)
library(tidyverse)
library(sf)
line1 <- lines %>%
st_sf() %>%
st_combine() %>%
st_sf() %>%
st_line_merge() %>%
st_cast("LINESTRING")
### this is still some manual work which needs to be improved
newline1 <- c(st_startpoint(line1[3,]), st_endpoint(line1[2,])) %>%
st_combine() %>%
st_cast("MULTIPOINT") %>%
st_union() %>%
st_cast("LINESTRING") %>%
st_sf()
newline2 <- c(st_startpoint(line1[2,]), st_endpoint(line1[1,])) %>%
st_combine() %>%
st_cast("MULTIPOINT") %>%
st_union() %>%
st_cast("LINESTRING") %>%
st_sf()
line1[nrow(line1)+1,]<-newline1
line1[nrow(line1)+1,]<-newline2
###
line1_uni <- line1 %>%
st_sf() %>%
st_combine() %>%
st_sf() %>%
st_line_merge() %>%
st_cast("LINESTRING") %>%
st_sf()
line1_uni
Simple feature collection with 1 feature and 0 fields
Geometry type: LINESTRING
Dimension: XY
Bounding box: xmin: 2880 ymin: 340255.4 xmax: 2914.214 ymax: 340350.2
Projected CRS: MGI / Austria GK East
geometry
1 LINESTRING (2880 340255.4, ...

Related

Searching a Leaflet Map?

I started working with a shapefile in R. In this shapefile, each "boundary" is uniquely defined by a value in "col1" (e.g. ABC111, ABC112 , ABC113, etc.):
library(sf)
library(igraph)
sf <- sf::st_read("C:/Users/me/OneDrive/Documents/shape5/myshp.shp", options = "ENCODING=WINDOWS-1252")
head(sf)
Simple feature collection with 6 features and 3 fields
Geometry type: MULTIPOLYGON
Dimension: XY
Bounding box: xmin: 7201955 ymin: 927899.4 xmax: 7484015 ymax: 1191414
Projected CRS: PCS_Lambert_Conformal_Conic
col1 col2 col3 geometry
620 ABC111 99 Region1 MULTIPOLYGON (((7473971 119...
621 ABC112 99 Region1 MULTIPOLYGON (((7480277 118...
622 ABC113 99 Region1 MULTIPOLYGON (((7477124 118...
627 ABC114 99 Region1 MULTIPOLYGON (((7471697 118...
638 ABC115 99 Region1 MULTIPOLYGON (((7209908 928...
639 ABC116 99 Region1 MULTIPOLYGON (((7206683 937...
> dim(sf)
[1] 500 4
sf_trans = st_transform(sf, 4326)
I then plotted this data using the leaflet library:
library(leaflet)
map = leaflet(sf_trans) %>% addPolygons( stroke = FALSE) %>% addTiles(group = "OSM") %>% addProviderTiles("CartoDB.DarkMatter", group = "Carto") %>% addPolygons(data = st_trans, weight=5, col = 'blue')
What I want to do is to try and make a "searchable" map. For example, imagine that "ABC111" is like an American ZIP Code. I want to make a map in which you can search for "ABC111" and the geographical outline of "ABC111" will be highlighted.
As an example, the ZIP Code of the Space Needle Tower in Seattle, Washington (USA) is "98109". If I search for this ZIP Code on Google Maps, the outline of this ZIP code is highlighted in red:
I was able to find a question on stackoverflow that explains how to add a search bar on a leaflet map for individual points (R leaflet search marker NOT work):
libary(dplyr)
library(leaflet)
library(leaflet.extras)
# using the same reproducible data from the question/example
cities <- read.csv(
textConnection("City,Lat,Long,Pop
Boston,42.3601,-71.0589,645966
Hartford,41.7627,-72.6743,125017
New York City,40.7127,-74.0059,8406000
Philadelphia,39.9500,-75.1667,1553000
Pittsburgh,40.4397,-79.9764,305841
Providence,41.8236,-71.4222,177994
"))
leaflet(cities) %>%
addProviderTiles(providers$OpenStreetMap) %>%
addResetMapButton() %>%
# these markers will be "invisible" on the map:
addMarkers(
data = cities, lng = ~Long, lat = ~Lat, label = cities$City,
group = 'cities', # this is the group to use in addSearchFeatures()
# make custom icon that is so small you can't see it:
icon = makeIcon(
iconUrl = "http://leafletjs.com/examples/custom-icons/leaf-green.png",
iconWidth = 1, iconHeight = 1
)
) %>%
addSearchFeatures(
targetGroups = 'cities', # group should match addMarkers() group
options = searchFeaturesOptions(
zoom=12, openPopup = TRUE, firstTipSubmit = TRUE,
autoCollapse = TRUE, hideMarkerOnCollapse = TRUE
)
)
But is there a way that the above code can be modified such that when you enter a term in the search bar (e.g. ABC111, ABC112), the entire boundaries of this region are highlighted in red?
Thank you!

Unable to find the distance between the centroid of a census tract and school location coordinates

library(tidyverse)
library(tidycensus)
library(sf)
library(sp)
#install.packages('geosphere')
library('geosphere')
library(rgeos)
library(sfheaders)
#install.packages('reshape')
library('reshape')
#> Linking to GEOS 3.6.1, GDAL 2.1.3, PROJ 4.9.3
census_tract <- get_acs(geography = "tract",
variables = "B19013_001",
state = "CA",
county = c("San Joaquin","Merced","stanislaus"),
geometry = TRUE,
year = 2020)
plot(st_geometry(census_tract), axes = T)
plot(st_centroid(st_geometry(census_tract)), pch = "+", col = "red", add = T)
library(ggplot2)
ggplot(census_tract) + geom_sf() +
geom_sf(aes(geometry = st_centroid(st_geometry(census_tract))), colour = "red")
census_tract$centroid <- st_centroid(st_geometry(census_tract))
schoolloc <- read.csv("C:/Users/rlnu/Desktop/EXAMPLE/pubschls.csv")
schoolloc <- schoolloc%>% filter(County == c("San Joaquin","Merced","Stanislaus"))
census_tract <- census_tract %>%
mutate(long = unlist(map(census_tract$centroid,1)),
lat = unlist(map(census_tract$centroid,2)))
shortest_distance$min_distance <- expand.grid.df(census_tract,schoolloc) %>%
mutate(distance = distHaversine(p1 = cbind(long,lat),
p2 = cbind(Longitude,Latitude))
`
I am trying to find distance between the each census tract's centroid to three nearest schools. please help me out with it. I have written some code . The logic is wrong and the code is not working
Can achieve this using the sf package.
I could not access you schools data so made a dummy set of 4 schools.
library(sf)
schools <- data.frame(School_Name=c("School_1", "School_2", "School_3", "School_4"), Lat=c(37.83405, 38.10867, 37.97743, 37.51615), Long=c(-121.2810, -121.2312, -121.2575, -120.8772)) %>% st_as_sf(coords=c("Long", "Lat"), crs=4326)
Convert tracts to centroids and make the crs the same as the school set then calculate the distance matrix
census_centroid <- st_centroid(census_tract) %>% st_transform(4326)
DISTS<- st_distance(census_centroid, schools)
Rename the columns to be the school IDs
colnames(DISTS) <- schools$School_Name
link it back to centoids
cent_dists <- cbind(census_centroid, DISTS) %>% #bind ditances to centroids
pivot_longer(cols = -names(census_centroid), names_to = "School Name", values_to = "Distance") %>% #make long for ordering
group_by(NAME) %>% #group by centroid
slice_min(Distance,n= 3) %>% # take three closest
mutate(Near_No=paste0("Near_School_",rep(1:3))) #School distance ranking
Make wide if one row per census centroid desired, might want to play with column order though
cent_dists_wide <- cent_dists %>%
pivot_wider(names_from = c("Near_No"), values_from = c("Distance", "School Name"), names_sort = FALSE) #make wid if wyou want one row per centoid

How can i rowwise create polygons from records in a dataframe using sf, similar to Postgis

I've got a table in Postgis which contains the field beginpunt, a geometry field containing a single point.
Next I'll create a 100*100m square which contains the point.
In Postgis I'll use the query below and it works great.
select
*
,st_transform(
ST_MakeEnvelope(floor(st_x(st_transform(beginpunt,28992))/100) *100,
floor(st_y(st_transform(beginpunt,28992))/100) *100,
floor(st_x(st_transform(beginpunt,28992))/100) *100 +100,
floor(st_y(st_transform(beginpunt,28992))/100) *100 +100, 28992),4326) as cbs_begin
from cbs
For a specific reason I want to achieve the same without using Postgis, but do the whole excersise in R.
This is where I get stuck. I can create a single polygon, but my problem is doing it rowwise in a dataframe.
I have the same table (cbs) in R
for simplicity i created a few extra fields:
dput(cbs) #this is the input dataframe
cbs$beginpunt_rd<-st_transform(cbs$beginpunt,28992) #transform crs
cbs$begincbsx<-floor(st_coordinates(cbs$beginpunt_rd)[,1]/100)*100 #define origin x
cbs$begincbsy<-floor(st_coordinates(cbs$beginpunt_rd)[,2]/100)*100 #define origin y
cbs$pol<-NA #create an extra empty field in the dataframe
tbldata<-st_sfc() #create an empty table
for(i in 1:nrow(cbs)){
cbs_begin <- st_polygon(
list(
cbind(
rbind(cbs$begincbsx[i],cbs$begincbsx[i]+100,cbs$begincbsx[i]+100 , cbs$begincbsx[i],cbs$begincbsx[i]),
rbind(cbs$begincbsy[i],cbs$begincbsy[i],cbs$begincbsy[i]+100 , cbs$begincbsy[i]+100,cbs$begincbsy[i])
)
))
if(i<2){tbldata<-cbs[FALSE,]} #create empty dataframe
tbldata[nrow(tbldata) + 1, ] <- c(cbs[i,1:5],st_sfc(st_polygon(cbs_begin),crs=28992)) #add row to dataframe
}
dput(tbldata) #this is the output dataframe
The code above gives me a (new) dataframe with a field "pol" containing a list with the right coordinates,
but it's missing the step to make it a polygon or sf object.
I've seen some examples of how it could be done, but I can't get it to work
Edit: the input-table cbs
dput(cbs) result is:
structure(list(id = c(9594L, 9520L, 9492L, 83859L,
9438L, 9490L), beginpunt = structure(list(structure(c(5.0499337,
51.5676501), class = c("XY", "POINT", "sfg")), structure(c(5.0146573,
51.5818484), class = c("XY", "POINT", "sfg")), structure(c(5.08459,
51.557595), class = c("XY", "POINT", "sfg")), structure(c(5.0129685,
51.5865527), class = c("XY", "POINT", "sfg")), structure(c(5.0548874,
51.5164541), class = c("XY", "POINT", "sfg")), structure(c(5.0647628,
51.5812475), class = c("XY", "POINT", "sfg"))), class = c("sfc_POINT",
"sfc"), precision = 0, bbox = structure(c(xmin = 5.0129685, ymin = 51.5164541,
xmax = 5.08459, ymax = 51.5865527), class = "bbox"), crs = structure(list(
input = "EPSG:4326", wkt = "GEOGCRS[\"WGS 84\",\n DATUM[\"World Geodetic System 1984\",\n ELLIPSOID[\"WGS 84\",6378137,298.257223563,\n LENGTHUNIT[\"metre\",1]]],\n PRIMEM[\"Greenwich\",0,\n ANGLEUNIT[\"degree\",0.0174532925199433]],\n CS[ellipsoidal,2],\n AXIS[\"geodetic latitude (Lat)\",north,\n ORDER[1],\n ANGLEUNIT[\"degree\",0.0174532925199433]],\n AXIS[\"geodetic longitude (Lon)\",east,\n ORDER[2],\n ANGLEUNIT[\"degree\",0.0174532925199433]],\n USAGE[\n SCOPE[\"Horizontal component of 3D system.\"],\n AREA[\"World.\"],\n BBOX[-90,-180,90,180]],\n ID[\"EPSG\",4326]]"), class = "crs"), n_empty = 0L)), row.names = c(NA,
6L), class = "data.frame")
and the output/result table: tbldata
dput(tbldata)
structure(list(id = c(9594L, 9520L, 9492L, 83859L,
9438L, 9490L), beginpunt = structure(list(structure(c(5.0499337,
51.5676501), class = c("XY", "POINT", "sfg")), structure(c(5.0146573,
51.5818484), class = c("XY", "POINT", "sfg")), structure(c(5.08459,
51.557595), class = c("XY", "POINT", "sfg")), structure(c(5.0129685,
51.5865527), class = c("XY", "POINT", "sfg")), structure(c(5.0548874,
51.5164541), class = c("XY", "POINT", "sfg")), structure(c(5.0647628,
51.5812475), class = c("XY", "POINT", "sfg"))), precision = 0, bbox = structure(c(xmin = 5.0499337,
ymin = 51.5676501, xmax = 5.0499337, ymax = 51.5676501), class = "bbox"), crs = structure(list(
input = "EPSG:4326", wkt = "GEOGCRS[\"WGS 84\",\n DATUM[\"World Geodetic System 1984\",\n ELLIPSOID[\"WGS 84\",6378137,298.257223563,\n LENGTHUNIT[\"metre\",1]]],\n PRIMEM[\"Greenwich\",0,\n ANGLEUNIT[\"degree\",0.0174532925199433]],\n CS[ellipsoidal,2],\n AXIS[\"geodetic latitude (Lat)\",north,\n ORDER[1],\n ANGLEUNIT[\"degree\",0.0174532925199433]],\n AXIS[\"geodetic longitude (Lon)\",east,\n ORDER[2],\n ANGLEUNIT[\"degree\",0.0174532925199433]],\n USAGE[\n SCOPE[\"Horizontal component of 3D system.\"],\n AREA[\"World.\"],\n BBOX[-90,-180,90,180]],\n ID[\"EPSG\",4326]]"), class = "crs"), classes = character(0), n_empty = 0L, class = c("sfc_POINT",
"sfc")), beginpunt_rd = structure(list(structure(c(131616.180272543,
397688.855374183), class = c("XY", "POINT", "sfg")), structure(c(129178.446528786,
399280.343643684), class = c("XY", "POINT", "sfg")), structure(c(134014.355256952,
396559.663404012), class = c("XY", "POINT", "sfg")), structure(c(129064.081985984,
399804.302704657), class = c("XY", "POINT", "sfg")), structure(c(131933.668374674,
391991.666781811), class = c("XY", "POINT", "sfg")), structure(c(132651.016139436,
399196.932221466), class = c("XY", "POINT", "sfg"))), precision = 0, bbox = structure(c(xmin = 131616.180272543,
ymin = 397688.855374183, xmax = 131616.180272543, ymax = 397688.855374183
), class = "bbox"), crs = structure(list(input = "EPSG:28992",
wkt = "PROJCRS[\"Amersfoort / RD New\",\n BASEGEOGCRS[\"Amersfoort\",\n DATUM[\"Amersfoort\",\n ELLIPSOID[\"Bessel 1841\",6377397.155,299.1528128,\n LENGTHUNIT[\"metre\",1]]],\n PRIMEM[\"Greenwich\",0,\n ANGLEUNIT[\"degree\",0.0174532925199433]],\n ID[\"EPSG\",4289]],\n CONVERSION[\"RD New\",\n METHOD[\"Oblique Stereographic\",\n ID[\"EPSG\",9809]],\n PARAMETER[\"Latitude of natural origin\",52.1561605555556,\n ANGLEUNIT[\"degree\",0.0174532925199433],\n ID[\"EPSG\",8801]],\n PARAMETER[\"Longitude of natural origin\",5.38763888888889,\n ANGLEUNIT[\"degree\",0.0174532925199433],\n ID[\"EPSG\",8802]],\n PARAMETER[\"Scale factor at natural origin\",0.9999079,\n SCALEUNIT[\"unity\",1],\n ID[\"EPSG\",8805]],\n PARAMETER[\"False easting\",155000,\n LENGTHUNIT[\"metre\",1],\n ID[\"EPSG\",8806]],\n PARAMETER[\"False northing\",463000,\n LENGTHUNIT[\"metre\",1],\n ID[\"EPSG\",8807]]],\n CS[Cartesian,2],\n AXIS[\"easting (X)\",east,\n ORDER[1],\n LENGTHUNIT[\"metre\",1]],\n AXIS[\"northing (Y)\",north,\n ORDER[2],\n LENGTHUNIT[\"metre\",1]],\n USAGE[\n SCOPE[\"Engineering survey, topographic mapping.\"],\n AREA[\"Netherlands - onshore, including Waddenzee, Dutch Wadden Islands and 12-mile offshore coastal zone.\"],\n BBOX[50.75,3.2,53.7,7.22]],\n ID[\"EPSG\",28992]]"), class = "crs"), classes = character(0), n_empty = 0L, class = c("sfc_POINT",
"sfc")), begincbsx = c(131600, 129100, 134000, 129000, 131900,
132600), begincbsy = c(397600, 399200, 396500, 399800, 391900,
399100), pol = list(structure(c(131600, 131700, 131700, 131600,
131600, 397600, 397600, 397700, 397700, 397600), .Dim = c(5L,
2L)), structure(c(129100, 129200, 129200, 129100, 129100, 399200,
399200, 399300, 399300, 399200), .Dim = c(5L, 2L)), structure(c(134000,
134100, 134100, 134000, 134000, 396500, 396500, 396600, 396600,
396500), .Dim = c(5L, 2L)), structure(c(129000, 129100, 129100,
129000, 129000, 399800, 399800, 399900, 399900, 399800), .Dim = c(5L,
2L)), structure(c(131900, 132000, 132000, 131900, 131900, 391900,
391900, 392000, 392000, 391900), .Dim = c(5L, 2L)), structure(c(132600,
132700, 132700, 132600, 132600, 399100, 399100, 399200, 399200,
399100), .Dim = c(5L, 2L)))), row.names = c(NA, 6L), class = "data.frame")
The expected output is
You just have to enter the following line of code and it should work :
cbs <- st_sf(cbs, sf_column_name = "beginpunt", crs = 4326)
Output :
#> Simple feature collection with 6 features and 1 field
#> Geometry type: POINT
#> Dimension: XY
#> Bounding box: xmin: 5.012968 ymin: 51.51645 xmax: 5.08459 ymax: 51.58655
#> Geodetic CRS: WGS 84
#> id beginpunt
#> 1 9594 POINT (5.049934 51.56765)
#> 2 9520 POINT (5.014657 51.58185)
#> 3 9492 POINT (5.08459 51.55759)
#> 4 83859 POINT (5.012969 51.58655)
#> 5 9438 POINT (5.054887 51.51645)
#> 6 9490 POINT (5.064763 51.58125)
Created on 2021-09-28 by the reprex package (v2.0.1)
Edit 1
Based on #skaqqs' comment, I complete my answer without taking into account his suggestion which normally works very well... but only if the points are arranged in the right order to produce a valid polygon (which is normally the most frequent case).
The original order of the points in your dataframe does not produce a valid polygon: keeping the original order, we get intersecting lines. So, if we choose the classical solution proposed by #skaqqs and draw the polygon, here is the result:
cbs_standard <- st_combine(cbs)
(cbs_standard <- st_cast(cbs_standard, "POLYGON"))
#> Geometry set for 1 feature
#> Geometry type: POLYGON
#> Dimension: XY
#> Bounding box: xmin: 5.012968 ymin: 51.51645 xmax: 5.08459 ymax: 51.58655
#> Geodetic CRS: WGS 84
#> POLYGON ((5.049934 51.56765, 5.014657 51.58185,...
plot(cbs_standard)
To circumvent this difficulty, I suggest another solution by installing and loading the "concaveman" package.
So, please find below the (very simple) procedure to obtain a topologically valid polygon.
install.packages("concaveman")
library(concaveman)
(cbs_concaveman <- concaveman(cbs))
#> Simple feature collection with 1 feature and 0 fields
#> Geometry type: POLYGON
#> Dimension: XY
#> Bounding box: xmin: 5.013 ymin: 51.5165 xmax: 5.0846 ymax: 51.5866
#> Geodetic CRS: WGS 84
#> polygons
#> 1 POLYGON ((5.0147 51.5818, 5...
plot(cbs_concaveman)
Created on 2021-09-28 by the reprex package (v2.0.1)
Edit 2
O.K. we did not understand each other #GeoDude. To follow up on your comment, here is (I hope!) the solution to your problem. You just have to type these few lines of code and it should work:
z <- st_polygon()
for (i in seq(length(tbldata$pol))){
z[i] <- st_polygon(list(tbldata$pol[[i]]))
}
sfc <- st_sfc(z, crs = 28992)
tbldata <- st_sf(tbldata, geom = sfc, row.names = 1:length(z))
tbldata$pol <- NULL
tbldata
#> Simple feature collection with 6 features and 3 fields
#> Active geometry column: geom
#> Geometry type: POLYGON
#> Dimension: XY
#> Bounding box: xmin: 129000 ymin: 391900 xmax: 134100 ymax: 399900
#> Projected CRS: Amersfoort / RD New
#> id beginpunt beginpunt_rd begincbsx begincbsy
#> 1 9594 POINT (5.049934 51.56765) POINT (131616.2 397688.9) 131600 397600
#> 2 9520 POINT (5.014657 51.58185) POINT (129178.4 399280.3) 129100 399200
#> 3 9492 POINT (5.08459 51.55759) POINT (134014.4 396559.7) 134000 396500
#> 4 83859 POINT (5.012969 51.58655) POINT (129064.1 399804.3) 129000 399800
#> 5 9438 POINT (5.054887 51.51645) POINT (131933.7 391991.7) 131900 391900
#> 6 9490 POINT (5.064763 51.58125) POINT (132651 399196.9) 132600 399100
#> geom
#> 1 POLYGON ((131600 397600, 13...
#> 2 POLYGON ((131600 397600, 13...
#> 3 POLYGON ((131600 397600, 13...
#> 4 POLYGON ((131600 397600, 13...
#> 5 POLYGON ((131600 397600, 13...
#> 6 POLYGON ((131600 397600, 13...
Created on 2021-09-29 by the reprex package (v2.0.1)
And the expected output:
library(tmap)
tmap_mode("view")
#> tmap mode set to interactive viewing
tmap::tm_shape(tbldata) +
tm_basemap(server = "OpenStreetMap")+
tm_fill(NA) +
tm_borders(col="black")
Created on 2021-09-29 by the reprex package (v2.0.1)
Edit 3
As a follow-up to your comment #Geodude, please find the fix below. Besides, I removed the for loop to take into account #nniloc's remark (For this, I built the function polygon_list() that I have applied to tbldata$pol with sapply()).
polygon_list <- function(x){
st_polygon(list(x))
}
h <- st_polygon()
h <- sapply(tbldata$pol, polygon_list, simplify = FALSE)
sfc <- st_sfc(h, crs = 28992)
tbldata <- st_sf(tbldata, geom = sfc)
tbldata$pol <- NULL
tbldata
#> Simple feature collection with 6 features and 3 fields
#> Active geometry column: geom
#> Geometry type: POLYGON
#> Dimension: XY
#> Bounding box: xmin: 129000 ymin: 391900 xmax: 134100 ymax: 399900
#> Projected CRS: Amersfoort / RD New
#> id beginpunt beginpunt_rd begincbsx begincbsy
#> 1 9594 POINT (5.049934 51.56765) POINT (131616.2 397688.9) 131600 397600
#> 2 9520 POINT (5.014657 51.58185) POINT (129178.4 399280.3) 129100 399200
#> 3 9492 POINT (5.08459 51.55759) POINT (134014.4 396559.7) 134000 396500
#> 4 83859 POINT (5.012969 51.58655) POINT (129064.1 399804.3) 129000 399800
#> 5 9438 POINT (5.054887 51.51645) POINT (131933.7 391991.7) 131900 391900
#> 6 9490 POINT (5.064763 51.58125) POINT (132651 399196.9) 132600 399100
#> geom
#> 1 POLYGON ((131600 397600, 13...
#> 2 POLYGON ((129100 399200, 12...
#> 3 POLYGON ((134000 396500, 13...
#> 4 POLYGON ((129000 399800, 12...
#> 5 POLYGON ((131900 391900, 13...
#> 6 POLYGON ((132600 399100, 13...
And by checking one of the polygons, the problem appears to be solved:
tbldata$geom[[3]]
#> POLYGON ((134000 396500, 134100 396500, 134100 396600, 134000 396600, 134000 396500))
Created on 2021-10-01 by the reprex package (v2.0.1)
A tidyverse solution. More or less the same as #lovalery but skips the for loops.
library(tidyverse)
library(sf)
library(ggspatial)
df_sf <- tbldata %>%
mutate(pol2 = st_sfc(st_multipolygon(list(pol)))) %>%
select(-beginpunt, -beginpunt_rd) %>%
st_as_sf(crs = 28992)
# plot to verify
ggplot(df_sf) +
annotation_map_tile(zoom = 13) +
geom_sf(col = 'blue', fill = NA)

Group ID for all edges between points using sfnetwork in r

I have a rooted tree with spatially explicit edges (ln_sfnetwork) with additional edges created by adding a point layer (pt).
I would like to give all of the edges between each point on the network the same ID so I can calculate the total length of the network between points. I have a manual solution but this has to be done with large datasets > 20,000 points.
install.packages("remotes"); library("remotes")
install_github("luukvdmeer/sfnetworks")
library(sf)
library(sfnetworks)
library(dplyr)
ln <- structure(list(River_ID = c(159, 160, 161, 186, 196), geometry = structure(list(
structure(c(
289924.625, 289924.5313, 289922.9688, 289920.0625,
289915.7499, 289912.7188, 289907.4375, 289905.3438, 289901.1251,
289889, 289888.5, 289887.5938, 289886.5, 289886.4063, 289885.3124,
289884.0938, 289884.0001, 289882.8125, 289881.625, 289878.6875,
289877.9688, 289876.25, 289874.5625, 289874.25, 289872.7188,
289871.2813, 289871.1875, 289870.0313, 289869, 289868.5939,
289867.8436, 289865.8438, 289864.0625, 289862.5939, 289862.375,
289861.5, 289860.7812, 289860.5625, 289859.5313, 289858.375,
289857.7813, 289855.4063, 289854.25, 289850.8749, 289846.4376,
289841.9064, 289836.0625, 289828.1562, 289822.8438, 289816.625,
289812.4376, 289807.9064, 289798.75, 289793.125, 289786.2188,
289781.375, 289777.3124, 289770.0313, 289765.4375, 289762.2188,
289759.25, 289755.5938, 289753.0625, 289747.9687, 289743.7499,
289741.5938, 289739.5, 289736.1874, 289732.75, 289727, 289723.7499,
289719.625, 289715.5626, 289713.7499, 202817.531300001, 202817.2031,
202815.1094, 202812.468699999, 202809.3906, 202806.7656,
202799.7969, 202797.906300001, 202794.093800001, 202783.515699999,
202783.125, 202782.4844, 202781.906300001, 202781.8125, 202781.3594,
202781.093800001, 202780.9999, 202780.5469, 202780, 202777.625,
202777.0469, 202775.718800001, 202774.1875, 202773.906300001,
202772.1875, 202770.4531, 202770.25, 202768.5156, 202766.6719,
202766, 202764.0469, 202759.6719, 202755.8749, 202752.781300001,
202752.1875, 202749.953199999, 202748.297, 202747.906300001,
202746.0625, 202744.2344, 202743.5625, 202740.4375, 202738.8125,
202734.5, 202727.9844, 202723.5625, 202719.1875, 202714.9845,
202713.031300001, 202710.6875, 202710.0469, 202711.406300001,
202714.5626, 202716.9845, 202718.718900001, 202719.5469,
202718.734300001, 202716.4531, 202715.125, 202713.7344, 202712.093800001,
202709.8749, 202708.875, 202709.2655, 202710.7031, 202712.375,
202712.375, 202712.2344, 202711.0469, 202707.906300001, 202705.406300001,
202703.0469, 202701.468800001, 202700.7656
), .Dim = c(
74L,
2L
), class = c("XY", "LINESTRING", "sfg")), structure(c(
289954.375,
289953.5, 289950.6562, 289949.7499, 289949, 289948.125, 289946.0625,
289945.9688, 289944.5313, 289943.4063, 289941.3438, 289939.4375,
289937.4375, 289935.1875, 289932.75, 289930.625, 289928.8125,
289928.25, 289926.7188, 289925.5313, 289925.7813, 289925.625,
289925.4063, 289925.1251, 289924.625, 202872.75, 202872.031400001,
202868.7031, 202867.343699999, 202864.906199999, 202861.515699999,
202858.297, 202854.406300001, 202851.9375, 202849.468800001,
202847.703, 202846.75, 202845.4531, 202843.6719, 202843.0625,
202841.593900001, 202839.7344, 202839.2344, 202838, 202835.9375,
202832.875, 202825.7344, 202822.9531, 202819.4531, 202817.531300001
), .Dim = c(25L, 2L), class = c("XY", "LINESTRING", "sfg")), structure(c(
290042.6563, 290042.3437, 290041.5313, 290038.4376,
290037.625, 290036.5313, 290035.5313, 290034.8438, 290034.5313,
290033.7188, 290032.9375, 290032.125, 290030.3437, 290030.0313,
290028.625, 290027.5626, 290027.3438, 290026.7188, 290024.5313,
290023.625, 290020.625, 290018.0001, 290014.9375, 290012.0938,
290008.5625, 290004.375, 290000.0001, 289999.875, 289997.625,
289993.7188, 289990.5, 289987.1562, 289985.4063, 289980.375,
289973.3124, 289966.375, 289961.8438, 289959, 289954.375,
202884.0625, 202884.25, 202884.843800001, 202888.4531, 202889.75,
202891.0469, 202892.0469, 202892.656300001, 202892.843800001,
202893.2501, 202893.5469, 202893.656300001, 202893.4531,
202893.4531, 202893.343699999, 202893.093800001, 202893.0469,
202892.843800001, 202891.953199999, 202891.5469, 202889.843800001,
202888.218800001, 202885.1094, 202880.9219, 202877.5625,
202873.968800001, 202872.5469, 202872.5156, 202872.625, 202874.5469,
202876.734300001, 202878.1719, 202877.953199999, 202876.3125,
202873.468800001, 202872.031400001, 202872.906199999, 202873.0781,
202872.75
), .Dim = c(39L, 2L), class = c(
"XY", "LINESTRING",
"sfg"
)), structure(c(
290054.125, 290053.4375, 290052.5313,
290051.625, 290050.0313, 290048.125, 290044.125, 290040.4376,
290039.4375, 290036.9688, 290031.4375, 290027.5312, 290024.8125,
290021.7499, 290020.9688, 290018.3437, 290015, 290010.25,
290006.0313, 290002.4376, 290000.0001, 289999.2187, 289996.6875,
289995.3438, 289994.125, 289991.1875, 289989.2187, 289987.9688,
289986.125, 289980.5313, 289975.0314, 289970.9063, 289968.5625,
289961.0312, 289948.0001, 289939.625, 289933.1563, 289928.3125,
289926.5313, 289924.625, 202835.953199999, 202835.656300001,
202835.4531, 202835.343699999, 202835.5469, 202835.7656,
202836.25, 202836.4531, 202836.5469, 202836.5469, 202835.953199999,
202836.031400001, 202836.625, 202837.7969, 202838.4844, 202839.343699999,
202836.25, 202832.7656, 202832.3125, 202833.4844, 202834.4844,
202834.8125, 202834.2344, 202832.625, 202830.625, 202828.593800001,
202828.968800001, 202831.0625, 202833.2655, 202835.5781,
202838, 202838.906199999, 202839.125, 202836.4531, 202830.781300001,
202827.093800001, 202823.625, 202818.5, 202817.5625, 202817.531300001
), .Dim = c(40L, 2L), class = c("XY", "LINESTRING", "sfg")), structure(c(
290042.625, 290042.0313, 290041.2187, 290040.3125,
290038.4063, 290037.7188, 290035.8125, 290033.7188, 290030.9063,
290028.2187, 290021.5313, 290021.2187, 290014.2188, 290013.4063,
290012.3125, 290010.0625, 290007.9375, 290005.9688, 290004.125,
290000.0001, 289999.4063, 289998.3125, 289997.5312, 289996.8438,
289993.625, 289993.0314, 289989.7188, 289989.3438, 289987.625,
289987.2187, 289984.0313, 289978.125, 289977.9375, 289974.3437,
289972.7188, 289970.9375, 289967.9375, 289965.2187, 289965.1563,
289962.3437, 289960.5313, 289959.1251, 289959.0314, 289959.3438,
289959.4375, 289959.4375, 289959.3438, 289959.2187, 289958.9375,
289958.5313, 289956.125, 289954.375, 202953.781300001, 202952.4844,
202951.281300001, 202950.0781, 202948.1875, 202947.5781,
202945.8749, 202944.281300001, 202941.781300001, 202940.1875,
202936.375, 202936.1875, 202931.968800001, 202931.4844, 202930.875,
202929.093800001, 202927.1094, 202925.031300001, 202922.734300001,
202917.2031, 202916.4375, 202915.2031, 202914.5469, 202914.4531,
202911.4531, 202910.843800001, 202908.0469, 202907.75, 202906.75,
202906.5469, 202904.843800001, 202901.843800001, 202901.75,
202900.0469, 202899.156400001, 202898.0469, 202894.656300001,
202892.0469, 202891.9844, 202889.343699999, 202887.656300001,
202885.75, 202884.5469, 202883.343699999, 202882.5469, 202881.343699999,
202880.0469, 202879.343699999, 202877.656300001, 202876.25,
202874.25, 202872.75
), .Dim = c(52L, 2L), class = c(
"XY",
"LINESTRING", "sfg"
))
), n_empty = 0L, crs = structure(list(
input = "OSGB 1936 / British National Grid", wkt = "PROJCRS[\"OSGB 1936 / British National Grid\",\n BASEGEOGCRS[\"OSGB 1936\",\n DATUM[\"OSGB 1936\",\n ELLIPSOID[\"Airy 1830\",6377563.396,299.3249646,\n LENGTHUNIT[\"metre\",1]]],\n PRIMEM[\"Greenwich\",0,\n ANGLEUNIT[\"degree\",0.0174532925199433]],\n ID[\"EPSG\",4277]],\n CONVERSION[\"British National Grid\",\n METHOD[\"Transverse Mercator\",\n ID[\"EPSG\",9807]],\n PARAMETER[\"Latitude of natural origin\",49,\n ANGLEUNIT[\"degree\",0.0174532925199433],\n ID[\"EPSG\",8801]],\n PARAMETER[\"Longitude of natural origin\",-2,\n ANGLEUNIT[\"degree\",0.0174532925199433],\n ID[\"EPSG\",8802]],\n PARAMETER[\"Scale factor at natural origin\",0.9996012717,\n SCALEUNIT[\"unity\",1],\n ID[\"EPSG\",8805]],\n PARAMETER[\"False easting\",400000,\n LENGTHUNIT[\"metre\",1],\n ID[\"EPSG\",8806]],\n PARAMETER[\"False northing\",-100000,\n LENGTHUNIT[\"metre\",1],\n ID[\"EPSG\",8807]]],\n CS[Cartesian,2],\n AXIS[\"(E)\",east,\n ORDER[1],\n LENGTHUNIT[\"metre\",1]],\n AXIS[\"(N)\",north,\n ORDER[2],\n LENGTHUNIT[\"metre\",1]],\n USAGE[\n SCOPE[\"unknown\"],\n AREA[\"UK - Britain and UKCS 49°46'N to 61°01'N, 7°33'W to 3°33'E\"],\n BBOX[49.75,-9.2,61.14,2.88]],\n ID[\"EPSG\",27700]]"
), class = "crs"), class = c(
"sfc_LINESTRING",
"sfc"
), precision = 0, bbox = structure(c(
xmin = 289713.7499,
ymin = 202700.7656, xmax = 290054.125, ymax = 202953.781300001
), class = "bbox"))), row.names = c(NA, -5L), class = c(
"sf",
"data.frame"
), sf_column = "geometry", agr = structure(c(River_ID = NA_integer_), .Label = c(
"constant",
"aggregate", "identity"
), class = "factor"))
pt <- structure(list(lat = c(
202805.8942, 202836.136, 202872.9487,
202905.3284
), lng = c(
289912.0584, 290014.8446, 290001.2364,
289984.9382
), id = 1:4, geometry = structure(list(structure(c(
289912.058400425,
202805.894199679
), class = c("XY", "POINT", "sfg")), structure(c(
290014.844597566,
202836.136003318
), class = c("XY", "POINT", "sfg")), structure(c(
290001.236395958,
202872.948712436
), class = c("XY", "POINT", "sfg")), structure(c(
289984.938209474,
202905.32838227
), class = c("XY", "POINT", "sfg"))), n_empty = 0L, crs = structure(list(
input = "OSGB 1936 / British National Grid", wkt = "PROJCRS[\"OSGB 1936 / British National Grid\",\n BASEGEOGCRS[\"OSGB 1936\",\n DATUM[\"OSGB 1936\",\n ELLIPSOID[\"Airy 1830\",6377563.396,299.3249646,\n LENGTHUNIT[\"metre\",1]]],\n PRIMEM[\"Greenwich\",0,\n ANGLEUNIT[\"degree\",0.0174532925199433]],\n ID[\"EPSG\",4277]],\n CONVERSION[\"British National Grid\",\n METHOD[\"Transverse Mercator\",\n ID[\"EPSG\",9807]],\n PARAMETER[\"Latitude of natural origin\",49,\n ANGLEUNIT[\"degree\",0.0174532925199433],\n ID[\"EPSG\",8801]],\n PARAMETER[\"Longitude of natural origin\",-2,\n ANGLEUNIT[\"degree\",0.0174532925199433],\n ID[\"EPSG\",8802]],\n PARAMETER[\"Scale factor at natural origin\",0.9996012717,\n SCALEUNIT[\"unity\",1],\n ID[\"EPSG\",8805]],\n PARAMETER[\"False easting\",400000,\n LENGTHUNIT[\"metre\",1],\n ID[\"EPSG\",8806]],\n PARAMETER[\"False northing\",-100000,\n LENGTHUNIT[\"metre\",1],\n ID[\"EPSG\",8807]]],\n CS[Cartesian,2],\n AXIS[\"(E)\",east,\n ORDER[1],\n LENGTHUNIT[\"metre\",1]],\n AXIS[\"(N)\",north,\n ORDER[2],\n LENGTHUNIT[\"metre\",1]],\n USAGE[\n SCOPE[\"unknown\"],\n AREA[\"UK - Britain and UKCS 49°46'N to 61°01'N, 7°33'W to 3°33'E\"],\n BBOX[49.75,-9.2,61.14,2.88]],\n ID[\"EPSG\",27700]]"
), class = "crs"), class = c(
"sfc_POINT",
"sfc"
), precision = 0, bbox = structure(c(
xmin = 289912.058400425,
ymin = 202805.894199679, xmax = 290014.844597566, ymax = 202905.32838227
), class = "bbox"))), row.names = c(NA, 4L), class = c(
"sf",
"data.frame"
), sf_column = "geometry", agr = structure(c(
lat = NA_integer_,
lng = NA_integer_,
id = NA_integer_
), .Label = c(
"constant",
"aggregate", "identity"
), class = "factor"))
Make it an sfnetwork
ln_sfnetwork <- as_sfnetwork(ln)
Add the point geometry
ln_sfnetwork <- st_network_blend(ln_sfnetwork, st_geometry(pt))
Use the point geom to create new edges by essentially splitting the sfnetwork
ln_sf <- ln_sfnetwork %>%
activate("edges") %>%
mutate(new_river_id = as.character(1:n())) %>%
st_as_sf()
The manual bit to group all of the edges between the nodes from pt. This groups all of the edges occuring between the points.
ln_sf[["new_river_id"]][2] <- "1"
ln_sf[["new_river_id"]][c(1, 3, 7, 5, 9)] <- "2"
ln_sf[["new_river_id"]][6] <- "3"
ln_sf[["new_river_id"]][4] <- "4"
ln_sf[["new_river_id"]][8] <- "5"
Desired output
Then group_by to get the combined length
ln_sf_merged <- ln_sf %>%
group_by(new_river_id) %>%
summarise(fraglen = sum(seglen)) %>%
as.data.frame() %>%
select(-geometry)
Finally
out_sf <- ln_sf %>%
left_join(ln_sf_merged, by = "new_river_id")
Interesting problem and nice to see sfnetworks being used on other type of networks than road networks! I gave this some thought. Beware, the answer is long and may be complicated sometimes.
It is clear what you want the output of your example to be, but the example does not cover many different possibilities of how the network structure can look like after blending in the given points. Therefore it is hard to generalize the rules that should be used for merging. But I made some assumptions regarding that:
As far as I understand you want to group edges based on what the first point is that you pass when travelling downstream on the river network. Hence, if the paths downstreams (towards the root of the tree) from edge 1 and edge 2 both pass through point 1 before passing any of the other points, they should be in the same group. All edges from which downstream travelling reaches the root without passing through any of the points should be together in a single group as well.
So the ultimate goal is to assign a group index to each of the edges. In tidygraph (the library on which sfnetworks is build), there are several grouping functions that can be applied to either the nodes or edges of the network. Such grouping functions are meant to be used inside tidyverse verbs like mutate() and filter(), where the network that is being worked on is known and not needed as an argument to the grouping function. Hence, you can run network %>% mutate(group = group_components()), without the need to explicitly forward the network as argument to group_components().
All nice and well, but as far as I know tidygraph does not have a grouping function implemented that addresses your problem. That means, we should create our own! I gave it a try. It may not be exactly what you need, but at least it should give you a good starting point to build further on.
The idea is that we first calculate the distances from the nodes that correspond with the points you added to the network, to all nodes in the network. Then, we select for each point a set of nodes such that the travel time from that point to these nodes is lower than from any other point. The edges that connect the nodes in such a set form the group of edges belonging to that point.
I created another example network which covers more possible cases. The first part of the code below is mainly constructing that network. Then we get to writing the custom group function, and finally applying it to my example network, and also to yours.
library(sfnetworks)
library(sf)
#> Linking to GEOS 3.9.0, GDAL 3.2.0, PROJ 7.2.0
library(dplyr)
#>
#> Attaching package: 'dplyr'
#> The following objects are masked from 'package:stats':
#>
#> filter, lag
#> The following objects are masked from 'package:base':
#>
#> intersect, setdiff, setequal, union
library(tidygraph)
#>
#> Attaching package: 'tidygraph'
#> The following object is masked from 'package:stats':
#>
#> filter
# Create an example network.
n01 = st_sfc(st_point(c(0, 0)))
n02 = st_sfc(st_point(c(1, 2)))
n03 = st_sfc(st_point(c(1, 3)))
n04 = st_sfc(st_point(c(1, 4)))
n05 = st_sfc(st_point(c(2, 1)))
n06 = st_sfc(st_point(c(2, 3)))
n07 = st_sfc(st_point(c(2, 4)))
n08 = st_sfc(st_point(c(3, 2)))
n09 = st_sfc(st_point(c(3, 3)))
n10 = st_sfc(st_point(c(3, 4)))
n11 = st_sfc(st_point(c(4, 2)))
n12 = st_sfc(st_point(c(4, 4)))
from = c(1, 2, 2, 3, 3, 5, 5, 8, 8, 9, 9)
to = c(5, 3, 6, 4, 7, 2, 8, 9, 11, 10, 12)
nodes = st_as_sf(c(n01, n02, n03, n04, n05, n06, n07, n08, n09, n10, n11, n12))
edges = data.frame(from = from, to = to)
G_1 = sfnetwork(nodes, edges)
#> Checking if spatial network structure is valid...
#> Spatial network structure is valid
n01 = st_sfc(st_point(c(0, 0)))
n02 = st_sfc(st_point(c(-1, 2)))
n03 = st_sfc(st_point(c(-1, 3)))
n04 = st_sfc(st_point(c(-1, 4)))
n05 = st_sfc(st_point(c(-2, 1)))
n06 = st_sfc(st_point(c(-2, 3)))
n07 = st_sfc(st_point(c(-2, 4)))
n08 = st_sfc(st_point(c(-3, 2)))
n09 = st_sfc(st_point(c(-3, 3)))
n10 = st_sfc(st_point(c(-3, 4)))
n11 = st_sfc(st_point(c(-4, 2)))
n12 = st_sfc(st_point(c(-4, 4)))
from = c(1, 2, 2, 3, 3, 5, 5, 8, 8, 9, 9)
to = c(5, 3, 6, 4, 7, 2, 8, 9, 11, 10, 12)
nodes = st_as_sf(c(n01, n02, n03, n04, n05, n06, n07, n08, n09, n10, n11, n12))
edges = data.frame(from = from, to = to)
G_2 = sfnetwork(nodes, edges)
#> Checking if spatial network structure is valid...
#> Spatial network structure is valid
G = st_network_join(G_1, G_2) %>%
convert(to_spatial_explicit, .clean = TRUE)
# Create a set of points.
p1 = st_sfc(st_point(c(1, 0.5)))
p2 = st_sfc(st_point(c(2.5, 1.5)))
p3 = st_sfc(st_point(c(1, 2.5)))
p4 = st_sfc(st_point(c(1, 3.5)))
p5 = st_sfc(st_point(c(1.5, 3.5)))
p6 = st_sfc(st_point(c(-1.5, 1.5)))
p7 = st_sfc(st_point(c(-1.5, 2.5)))
p8 = st_sfc(st_point(c(-1.5, 3.5)))
p9 = st_sfc(st_point(c(-1, 0.5)))
# Important!
# Add a column to the points with TRUE values.
# Such that we know which nodes correspond to the points after we inlcude them in the network.
points = st_as_sf(c(p1, p2, p3, p4, p5, p6, p7, p8, p9))
points$is_point = TRUE
plot(G)
plot(st_geometry(points), col = "red", pch = 20, add = TRUE)
# Blend the points into the network.
# Update the is_point column so that all other nodes get a value of FALSE.
G = st_network_blend(G, points) %>%
morph(to_subgraph, is.na(is_point)) %>%
mutate(is_point = FALSE) %>%
unmorph()
#> Warning: st_network_blend assumes attributes are constant over geometries
#> Subsetting by nodes
G
#> # A sfnetwork with 32 nodes and 31 edges
#> #
#> # CRS: NA
#> #
#> # A rooted tree with spatially explicit edges
#> #
#> # Node Data: 32 x 2 (active)
#> # Geometry type: POINT
#> # Dimension: XY
#> # Bounding box: xmin: -4 ymin: 0 xmax: 4 ymax: 4
#> geometry is_point
#> <POINT> <lgl>
#> 1 (1 0.5) TRUE
#> 2 (2 1) FALSE
#> 3 (0 0) FALSE
#> 4 (1 2.5) TRUE
#> 5 (1 3) FALSE
#> 6 (1 2) FALSE
#> # … with 26 more rows
#> #
#> # Edge Data: 31 x 3
#> # Geometry type: LINESTRING
#> # Dimension: XY
#> # Bounding box: xmin: -4 ymin: 0 xmax: 4 ymax: 4
#> from to geometry
#> <int> <int> <LINESTRING>
#> 1 1 2 (1 0.5, 2 1)
#> 2 3 1 (0 0, 1 0.5)
#> 3 4 5 (1 2.5, 1 3)
#> # … with 28 more rows
plot(G)
# Define our own custom grouping function.
# Remember that in the tidygraph style these functions are meant to be
# used inside tidyverse verbs like mutate() and filter(), in which the
# graph that is being worked on is known and not needed as an input to
# the function.
# The graph being worked on can be accessed with .G().
# Its nodes and edges respectively with .N() and .E().
# The mode argument specifies how to route upstreams on the river network.
# If your network is directed upstreams (i.e. starting at the root of the tree):
# --> Use only outbound edges.
# If your network is directed downstreams (i.e. ending at the root of the tree):
# --> Use only inbound edges.
group_custom = function(mode = "out") {
# First we get the node indices of the nodes we want to route from.
# These are:
# --> All points that were blended into the network.
# --> The root node at the start of the network tree.
# Including the root will group all edges that dont have a blended point downstreams.
origins = which(.N()$is_point | with_graph(.G(), node_is_root()))
# Calculate the cost matrix from the origins, to all nodes in the network.
costs = st_network_cost(.G(), from = origins, Inf_as_NaN = TRUE, mode = mode)
# For each node in the network:
# --> Define which of the origins is the first to be reached when travelling downstreams.
# Remember that in the cost matrix:
# --> The origins (the blended points + the root node) are the rows.
# --> The destinations (all nodes in the network) are the columns.
# Hence, we loop over the columns and keep only the minimum cost value per column.
# We should first remove the zeros, which are the cost values from and to the same node.
keep_minimum_cost = function(i) {
i[i == 0] = NaN
if (any(!is.na(i))) i[i != min(i, na.rm = TRUE)] = NaN
i
}
costs = apply(costs, 2, keep_minimum_cost)
# For each origin we know now which nodes are in its group.
# However, we want to know which edges are in the group.
# The cost matrix does not provide that information.
# Finding the paths from the origins to the nodes in its group will give us this.
# Hence, for each origin:
# --> We compute the paths to all nodes in its group.
# --> We extract the edge indices that are part of these paths.
get_edge_indices = function(i) {
orig = origins[i]
dest = which(!is.na(costs[i, ]))
if (length(dest) > 0) {
paths = st_network_paths(.G(), from = orig, to = dest, mode = mode)
edge_idxs = do.call(c, paths$edge_paths)
unique(edge_idxs)
}
}
groups = lapply(seq_len(nrow(costs)), get_edge_indices)
# In tidygraph the largest group always gets group index number 1.
# We can achieve the same by ordering the groups by number of edges.
groups = groups[order(lengths(groups), decreasing = TRUE)]
# Now we can assign a group index to each edge.
edge_idxs = do.call(c, groups)
group_idxs = rep(seq_along(groups), lengths(groups))
# The last thing left to do is to return the group indices in the correct order.
# That is: the order of the edges in the edge table of the network.
group_idxs[order(edge_idxs)]
}
# Group the edges with our custom grouping function.
G = G %>%
activate("edges") %>%
mutate(group = group_custom())
G
#> # A sfnetwork with 32 nodes and 31 edges
#> #
#> # CRS: NA
#> #
#> # A rooted tree with spatially explicit edges
#> #
#> # Edge Data: 31 x 4 (active)
#> # Geometry type: LINESTRING
#> # Dimension: XY
#> # Bounding box: xmin: -4 ymin: 0 xmax: 4 ymax: 4
#> from to geometry group
#> <int> <int> <LINESTRING> <int>
#> 1 1 2 (1 0.5, 2 1) 2
#> 2 3 1 (0 0, 1 0.5) 6
#> 3 4 5 (1 2.5, 1 3) 5
#> 4 6 4 (1 2, 1 2.5) 2
#> 5 6 7 (1 2, 2 3) 2
#> 6 8 9 (1 3.5, 1 4) 7
#> # … with 25 more rows
#> #
#> # Node Data: 32 x 2
#> # Geometry type: POINT
#> # Dimension: XY
#> # Bounding box: xmin: -4 ymin: 0 xmax: 4 ymax: 4
#> geometry is_point
#> <POINT> <lgl>
#> 1 (1 0.5) TRUE
#> 2 (2 1) FALSE
#> 3 (0 0) FALSE
#> # … with 29 more rows
# Plot the results.
nodes = st_as_sf(G, "nodes")
edges = st_as_sf(G, "edges")
edges$group = as.factor(edges$group) # Such that sf uses categorical colors.
plot(st_geometry(edges))
plot(edges["group"], lwd = 4, key.pos = NULL, add = TRUE)
plot(nodes[nodes$is_point, ], pch = 8, add = TRUE)
plot(nodes[!nodes$is_point, ], pch = 20, add = TRUE)
# Reproduce your example.
# Remember to add the is_point column to the created points.
ln <- structure(list(River_ID = c(159, 160, 161, 186, 196), geometry = structure(list(
structure(c(
289924.625, 289924.5313, 289922.9688, 289920.0625,
289915.7499, 289912.7188, 289907.4375, 289905.3438, 289901.1251,
289889, 289888.5, 289887.5938, 289886.5, 289886.4063, 289885.3124,
289884.0938, 289884.0001, 289882.8125, 289881.625, 289878.6875,
289877.9688, 289876.25, 289874.5625, 289874.25, 289872.7188,
289871.2813, 289871.1875, 289870.0313, 289869, 289868.5939,
289867.8436, 289865.8438, 289864.0625, 289862.5939, 289862.375,
289861.5, 289860.7812, 289860.5625, 289859.5313, 289858.375,
289857.7813, 289855.4063, 289854.25, 289850.8749, 289846.4376,
289841.9064, 289836.0625, 289828.1562, 289822.8438, 289816.625,
289812.4376, 289807.9064, 289798.75, 289793.125, 289786.2188,
289781.375, 289777.3124, 289770.0313, 289765.4375, 289762.2188,
289759.25, 289755.5938, 289753.0625, 289747.9687, 289743.7499,
289741.5938, 289739.5, 289736.1874, 289732.75, 289727, 289723.7499,
289719.625, 289715.5626, 289713.7499, 202817.531300001, 202817.2031,
202815.1094, 202812.468699999, 202809.3906, 202806.7656,
202799.7969, 202797.906300001, 202794.093800001, 202783.515699999,
202783.125, 202782.4844, 202781.906300001, 202781.8125, 202781.3594,
202781.093800001, 202780.9999, 202780.5469, 202780, 202777.625,
202777.0469, 202775.718800001, 202774.1875, 202773.906300001,
202772.1875, 202770.4531, 202770.25, 202768.5156, 202766.6719,
202766, 202764.0469, 202759.6719, 202755.8749, 202752.781300001,
202752.1875, 202749.953199999, 202748.297, 202747.906300001,
202746.0625, 202744.2344, 202743.5625, 202740.4375, 202738.8125,
202734.5, 202727.9844, 202723.5625, 202719.1875, 202714.9845,
202713.031300001, 202710.6875, 202710.0469, 202711.406300001,
202714.5626, 202716.9845, 202718.718900001, 202719.5469,
202718.734300001, 202716.4531, 202715.125, 202713.7344, 202712.093800001,
202709.8749, 202708.875, 202709.2655, 202710.7031, 202712.375,
202712.375, 202712.2344, 202711.0469, 202707.906300001, 202705.406300001,
202703.0469, 202701.468800001, 202700.7656
), .Dim = c(
74L,
2L
), class = c("XY", "LINESTRING", "sfg")), structure(c(
289954.375,
289953.5, 289950.6562, 289949.7499, 289949, 289948.125, 289946.0625,
289945.9688, 289944.5313, 289943.4063, 289941.3438, 289939.4375,
289937.4375, 289935.1875, 289932.75, 289930.625, 289928.8125,
289928.25, 289926.7188, 289925.5313, 289925.7813, 289925.625,
289925.4063, 289925.1251, 289924.625, 202872.75, 202872.031400001,
202868.7031, 202867.343699999, 202864.906199999, 202861.515699999,
202858.297, 202854.406300001, 202851.9375, 202849.468800001,
202847.703, 202846.75, 202845.4531, 202843.6719, 202843.0625,
202841.593900001, 202839.7344, 202839.2344, 202838, 202835.9375,
202832.875, 202825.7344, 202822.9531, 202819.4531, 202817.531300001
), .Dim = c(25L, 2L), class = c("XY", "LINESTRING", "sfg")), structure(c(
290042.6563, 290042.3437, 290041.5313, 290038.4376,
290037.625, 290036.5313, 290035.5313, 290034.8438, 290034.5313,
290033.7188, 290032.9375, 290032.125, 290030.3437, 290030.0313,
290028.625, 290027.5626, 290027.3438, 290026.7188, 290024.5313,
290023.625, 290020.625, 290018.0001, 290014.9375, 290012.0938,
290008.5625, 290004.375, 290000.0001, 289999.875, 289997.625,
289993.7188, 289990.5, 289987.1562, 289985.4063, 289980.375,
289973.3124, 289966.375, 289961.8438, 289959, 289954.375,
202884.0625, 202884.25, 202884.843800001, 202888.4531, 202889.75,
202891.0469, 202892.0469, 202892.656300001, 202892.843800001,
202893.2501, 202893.5469, 202893.656300001, 202893.4531,
202893.4531, 202893.343699999, 202893.093800001, 202893.0469,
202892.843800001, 202891.953199999, 202891.5469, 202889.843800001,
202888.218800001, 202885.1094, 202880.9219, 202877.5625,
202873.968800001, 202872.5469, 202872.5156, 202872.625, 202874.5469,
202876.734300001, 202878.1719, 202877.953199999, 202876.3125,
202873.468800001, 202872.031400001, 202872.906199999, 202873.0781,
202872.75
), .Dim = c(39L, 2L), class = c(
"XY", "LINESTRING",
"sfg"
)), structure(c(
290054.125, 290053.4375, 290052.5313,
290051.625, 290050.0313, 290048.125, 290044.125, 290040.4376,
290039.4375, 290036.9688, 290031.4375, 290027.5312, 290024.8125,
290021.7499, 290020.9688, 290018.3437, 290015, 290010.25,
290006.0313, 290002.4376, 290000.0001, 289999.2187, 289996.6875,
289995.3438, 289994.125, 289991.1875, 289989.2187, 289987.9688,
289986.125, 289980.5313, 289975.0314, 289970.9063, 289968.5625,
289961.0312, 289948.0001, 289939.625, 289933.1563, 289928.3125,
289926.5313, 289924.625, 202835.953199999, 202835.656300001,
202835.4531, 202835.343699999, 202835.5469, 202835.7656,
202836.25, 202836.4531, 202836.5469, 202836.5469, 202835.953199999,
202836.031400001, 202836.625, 202837.7969, 202838.4844, 202839.343699999,
202836.25, 202832.7656, 202832.3125, 202833.4844, 202834.4844,
202834.8125, 202834.2344, 202832.625, 202830.625, 202828.593800001,
202828.968800001, 202831.0625, 202833.2655, 202835.5781,
202838, 202838.906199999, 202839.125, 202836.4531, 202830.781300001,
202827.093800001, 202823.625, 202818.5, 202817.5625, 202817.531300001
), .Dim = c(40L, 2L), class = c("XY", "LINESTRING", "sfg")), structure(c(
290042.625, 290042.0313, 290041.2187, 290040.3125,
290038.4063, 290037.7188, 290035.8125, 290033.7188, 290030.9063,
290028.2187, 290021.5313, 290021.2187, 290014.2188, 290013.4063,
290012.3125, 290010.0625, 290007.9375, 290005.9688, 290004.125,
290000.0001, 289999.4063, 289998.3125, 289997.5312, 289996.8438,
289993.625, 289993.0314, 289989.7188, 289989.3438, 289987.625,
289987.2187, 289984.0313, 289978.125, 289977.9375, 289974.3437,
289972.7188, 289970.9375, 289967.9375, 289965.2187, 289965.1563,
289962.3437, 289960.5313, 289959.1251, 289959.0314, 289959.3438,
289959.4375, 289959.4375, 289959.3438, 289959.2187, 289958.9375,
289958.5313, 289956.125, 289954.375, 202953.781300001, 202952.4844,
202951.281300001, 202950.0781, 202948.1875, 202947.5781,
202945.8749, 202944.281300001, 202941.781300001, 202940.1875,
202936.375, 202936.1875, 202931.968800001, 202931.4844, 202930.875,
202929.093800001, 202927.1094, 202925.031300001, 202922.734300001,
202917.2031, 202916.4375, 202915.2031, 202914.5469, 202914.4531,
202911.4531, 202910.843800001, 202908.0469, 202907.75, 202906.75,
202906.5469, 202904.843800001, 202901.843800001, 202901.75,
202900.0469, 202899.156400001, 202898.0469, 202894.656300001,
202892.0469, 202891.9844, 202889.343699999, 202887.656300001,
202885.75, 202884.5469, 202883.343699999, 202882.5469, 202881.343699999,
202880.0469, 202879.343699999, 202877.656300001, 202876.25,
202874.25, 202872.75
), .Dim = c(52L, 2L), class = c(
"XY",
"LINESTRING", "sfg"
))
), n_empty = 0L, crs = structure(list(
input = "OSGB 1936 / British National Grid", wkt = "PROJCRS[\"OSGB 1936 / British National Grid\",\n BASEGEOGCRS[\"OSGB 1936\",\n DATUM[\"OSGB 1936\",\n ELLIPSOID[\"Airy 1830\",6377563.396,299.3249646,\n LENGTHUNIT[\"metre\",1]]],\n PRIMEM[\"Greenwich\",0,\n ANGLEUNIT[\"degree\",0.0174532925199433]],\n ID[\"EPSG\",4277]],\n CONVERSION[\"British National Grid\",\n METHOD[\"Transverse Mercator\",\n ID[\"EPSG\",9807]],\n PARAMETER[\"Latitude of natural origin\",49,\n ANGLEUNIT[\"degree\",0.0174532925199433],\n ID[\"EPSG\",8801]],\n PARAMETER[\"Longitude of natural origin\",-2,\n ANGLEUNIT[\"degree\",0.0174532925199433],\n ID[\"EPSG\",8802]],\n PARAMETER[\"Scale factor at natural origin\",0.9996012717,\n SCALEUNIT[\"unity\",1],\n ID[\"EPSG\",8805]],\n PARAMETER[\"False easting\",400000,\n LENGTHUNIT[\"metre\",1],\n ID[\"EPSG\",8806]],\n PARAMETER[\"False northing\",-100000,\n LENGTHUNIT[\"metre\",1],\n ID[\"EPSG\",8807]]],\n CS[Cartesian,2],\n AXIS[\"(E)\",east,\n ORDER[1],\n LENGTHUNIT[\"metre\",1]],\n AXIS[\"(N)\",north,\n ORDER[2],\n LENGTHUNIT[\"metre\",1]],\n USAGE[\n SCOPE[\"unknown\"],\n AREA[\"UK - Britain and UKCS 49°46'N to 61°01'N, 7°33'W to 3°33'E\"],\n BBOX[49.75,-9.2,61.14,2.88]],\n ID[\"EPSG\",27700]]"
), class = "crs"), class = c(
"sfc_LINESTRING",
"sfc"
), precision = 0, bbox = structure(c(
xmin = 289713.7499,
ymin = 202700.7656, xmax = 290054.125, ymax = 202953.781300001
), class = "bbox"))), row.names = c(NA, -5L), class = c(
"sf",
"data.frame"
), sf_column = "geometry", agr = structure(c(River_ID = NA_integer_), .Label = c(
"constant",
"aggregate", "identity"
), class = "factor"))
pt <- structure(list(lat = c(
202805.8942, 202836.136, 202872.9487,
202905.3284
), lng = c(
289912.0584, 290014.8446, 290001.2364,
289984.9382
), id = 1:4, geometry = structure(list(structure(c(
289912.058400425,
202805.894199679
), class = c("XY", "POINT", "sfg")), structure(c(
290014.844597566,
202836.136003318
), class = c("XY", "POINT", "sfg")), structure(c(
290001.236395958,
202872.948712436
), class = c("XY", "POINT", "sfg")), structure(c(
289984.938209474,
202905.32838227
), class = c("XY", "POINT", "sfg"))), n_empty = 0L, crs = structure(list(
input = "OSGB 1936 / British National Grid", wkt = "PROJCRS[\"OSGB 1936 / British National Grid\",\n BASEGEOGCRS[\"OSGB 1936\",\n DATUM[\"OSGB 1936\",\n ELLIPSOID[\"Airy 1830\",6377563.396,299.3249646,\n LENGTHUNIT[\"metre\",1]]],\n PRIMEM[\"Greenwich\",0,\n ANGLEUNIT[\"degree\",0.0174532925199433]],\n ID[\"EPSG\",4277]],\n CONVERSION[\"British National Grid\",\n METHOD[\"Transverse Mercator\",\n ID[\"EPSG\",9807]],\n PARAMETER[\"Latitude of natural origin\",49,\n ANGLEUNIT[\"degree\",0.0174532925199433],\n ID[\"EPSG\",8801]],\n PARAMETER[\"Longitude of natural origin\",-2,\n ANGLEUNIT[\"degree\",0.0174532925199433],\n ID[\"EPSG\",8802]],\n PARAMETER[\"Scale factor at natural origin\",0.9996012717,\n SCALEUNIT[\"unity\",1],\n ID[\"EPSG\",8805]],\n PARAMETER[\"False easting\",400000,\n LENGTHUNIT[\"metre\",1],\n ID[\"EPSG\",8806]],\n PARAMETER[\"False northing\",-100000,\n LENGTHUNIT[\"metre\",1],\n ID[\"EPSG\",8807]]],\n CS[Cartesian,2],\n AXIS[\"(E)\",east,\n ORDER[1],\n LENGTHUNIT[\"metre\",1]],\n AXIS[\"(N)\",north,\n ORDER[2],\n LENGTHUNIT[\"metre\",1]],\n USAGE[\n SCOPE[\"unknown\"],\n AREA[\"UK - Britain and UKCS 49°46'N to 61°01'N, 7°33'W to 3°33'E\"],\n BBOX[49.75,-9.2,61.14,2.88]],\n ID[\"EPSG\",27700]]"
), class = "crs"), class = c(
"sfc_POINT",
"sfc"
), precision = 0, bbox = structure(c(
xmin = 289912.058400425,
ymin = 202805.894199679, xmax = 290014.844597566, ymax = 202905.32838227
), class = "bbox"))), row.names = c(NA, 4L), class = c(
"sf",
"data.frame"
), sf_column = "geometry", agr = structure(c(
lat = NA_integer_,
lng = NA_integer_,
id = NA_integer_
), .Label = c(
"constant",
"aggregate", "identity"
), class = "factor"))
ln_sfnetwork <- as_sfnetwork(ln)
pt$is_point <- TRUE
ln_sfnetwork <- st_network_blend(ln_sfnetwork, pt["is_point"]) %>%
morph(to_subgraph, is.na(is_point)) %>%
mutate(is_point = FALSE) %>%
unmorph()
#> Warning: st_network_blend assumes attributes are constant over geometries
#> Subsetting by nodes
# NOTE! Your network is directed towards the root of the tree!
# Therefore we route over inbound edges instead of outbound edges to get correct results.
ln_sfnetwork <- ln_sfnetwork %>%
activate("edges") %>%
mutate(group = group_custom(mode = "in"))
# Plot the results.
nodes = st_as_sf(ln_sfnetwork, "nodes")
edges = st_as_sf(ln_sfnetwork, "edges")
edges$group = as.factor(edges$group) # Such that sf uses categorical colors.
plot(st_geometry(edges))
plot(edges["group"], lwd = 4, key.pos = NULL, add = TRUE)
plot(nodes[nodes$is_point, ], pch = 8, add = TRUE)
plot(nodes[!nodes$is_point, ], pch = 20, add = TRUE)
Created on 2021-02-03 by the reprex package (v0.3.0)

ggplot not plotting linestring points from sf object

Given the following data:
library(tidyverse)
library(sf)
df <- structure(list(geometry = c("LINESTRING (-85.76 38.34, -85.72 38.38)",
"LINESTRING (-85.46 38.76, -85.42 38.76)",
"LINESTRING (-85.89 38.31, -85.89 38.31)"
), var1 = c(4, 5, 6
), var2 = c(1, 2, 3
)), row.names = c(NA, -3L), class = c("tbl_df", "tbl", "data.frame"
))
df
df_sf <- sf::st_as_sf( df, wkt = "geometry" )
# Simple feature collection with 3 features and 2 fields
# geometry type: LINESTRING
# dimension: XY
# bbox: xmin: -85.89 ymin: 38.31 xmax: -85.42 ymax: 38.76
# CRS: NA
# # A tibble: 3 x 3
# geometry var1 var2
# <LINESTRING> <dbl> <dbl>
# 1 (-85.76 38.34, -85.72 38.38) 4 1
# 2 (-85.46 38.76, -85.42 38.76) 5 2
# 3 (-85.89 38.31, -85.89 38.31) 6 3
We can use plot to plot the data including the LINESTRING that has two points at the same location (row = 3):
plot(st_geometry(df_sf), lwd = 10)
giving:
but when we plot it using ggplot the point is dropped:
ggplot() +
geom_sf(data = df_sf, lwd = 8)
Without manually extracting locations that only contain a point, is there a quick way to tell ggplot to plot these? I can see that these points are technically not a line as theres no distance between them but plot is able to pick them up. This question seems related but slightly different, my LINESTRINGs are already created.
thanks
This is one of those situations where the headdesk emoji might come in handy:
ggplot() +
geom_sf(data = df_sf, lwd = 8, lineend = "round")
From the package's vignette on aesthetic specs, the default lineend is "butt", which stops precisely at the end point of a line (so a line of 0 length won't have anything to show), while the "round" alternative extends beyond the end point:
TL;DR: The 0-length linestring wasn't dropped. We just couldn't see it.
I think that you can solve that problem if you modify the LINESTRING geometries whose length is equal to 0 and cast them as POINTS. For example:
# packages
library(ggplot2)
library(sf)
#> Linking to GEOS 3.8.0, GDAL 3.0.4, PROJ 6.3.1
# data
df <- structure(
list(
geometry = c(
"LINESTRING (-85.76 38.34, -85.72 38.38)",
"LINESTRING (-85.46 38.76, -85.42 38.76)",
"LINESTRING (-85.89 38.31, -85.89 38.31)"
),
var1 = c(4, 5, 6),
var2 = c(1, 2, 3)
),
row.names = c(NA, -3L),
class = c("tbl_df", "tbl", "data.frame")
)
df_sf <- st_as_sf( df, wkt = "geometry" )
# Rebuild the geometry column in such a way that the zero-length LINESTRINGS are
# actually POINTS:
new_df_sf_geometry <- st_geometry(df_sf)
idx <- which(st_length(new_df_sf_geometry) == 0)
for (i in idx) {
new_df_sf_geometry[i] <- unique(st_cast(new_df_sf_geometry[i], "POINT"))
}
# This is the result
new_df_sf_geometry
#> Geometry set for 3 features
#> geometry type: GEOMETRY
#> dimension: XY
#> bbox: xmin: -85.89 ymin: 38.31 xmax: -85.42 ymax: 38.76
#> CRS: NA
#> LINESTRING (-85.76 38.34, -85.72 38.38)
#> LINESTRING (-85.46 38.76, -85.42 38.76)
#> POINT (-85.89 38.31)
# Replace the geometry
st_geometry(df_sf) <- new_df_sf_geometry
# Plot
ggplot(df_sf) +
geom_sf(size = 3)
Created on 2020-05-25 by the reprex package (v0.3.0)
If you need, you can also adopt more sophisticated approaches than a for-loop such as purrr::map_if.

Resources