Adding snapping distances to route results

R/osrmRoute.R

@@ -51,12 +51,23 @@
 #' @param osrm.profile the routing profile to use, e.g. "car", "bike" or "foot".
 #' @return
 #' The output of this function is an sf LINESTRING of the shortest route.\cr
-#' It contains 4 fields: \itemize{
-#'   \item starting point identifier
-#'   \item destination identifier
-#'   \item travel time in minutes
-#'   \item travel distance in kilometers.
+#' It contains 6 fields: \itemize{
+#'   \item src: starting point identifier
+#'   \item dst: destination identifier
+#'   \item duration: travel time in minutes
+#'   \item distance: travel distance in kilometers
+#'   \item src_snapping_distance: distance from the starting point to the
+#'   snapped point on the network (in kilometers)
+#'   \item dst_snapping_distance: distance from the destination to the
+#'   snapped point on the network (in kilometers)
 #'   }
+#' The object also contains a \code{snapping} attribute (accessible via
+#' \code{attr(result, "snapping")}, where \code{result} is the object
+#' returned by \code{osrmRoute()}) that stores a data.frame of all snapped
+#' waypoints (including middle points if \code{loc} is used). The
+#' \code{snapping} data.frame contains a \code{snapping_distance} column
+#' (in kilometers).
+#'
 #' If src (or loc) is a vector, a data.frame or a matrix, the coordinate
 #' reference system (CRS) of the route is EPSG:4326 (WGS84).\cr
 #' If src (or loc) is an sfc or sf object, the route has the same CRS
@@ -77,6 +88,12 @@
 #' plot(st_geometry(route1))
 #' plot(st_geometry(apotheke.sf[c(1, 16), ]), col = "red", pch = 20, add = TRUE)
 #'
+#' # View snapping distance
+#' route1$src_snapping_distance
+#'
+#' # View all snapped waypoints (including via points)
+#' attr(route1, "snapping")
+#'
 #' # Return only duration and distance
 #' route3 <- osrmRoute(
 #'   src = apotheke.df[1, c("lon", "lat")],
@@ -193,10 +210,16 @@ osrmRoute <- function(src,
     src = id1, dst = id2,
     duration = res$routes$duration / 60,
     distance = res$routes$distance / 1000,
+    src_snapping_distance = res$waypoints$distance[1] / 1000,
+    dst_snapping_distance = res$waypoints$distance[nrow(res$waypoints)] / 1000,
     geometry = st_as_sfc(paste0("LINESTRING(", rcoords, ")")),
     crs = 4326,
     row.names = paste(id1, id2, sep = "_")
   )
+  snapping <- res$waypoints
+  snapping$snapping_distance <- snapping$distance / 1000
+  snapping$distance <- NULL
+  attr(rosf, "snapping") <- snapping
   # prj
   if (!is.na(oprj)) {
     rosf <- st_transform(rosf, oprj)

R/osrmTable.R

@@ -29,22 +29,24 @@
 #' }
 #' If relevant, row names are used as identifiers.
 #' @param measure a character indicating what measures are calculated. It can
-#' be "duration" (in minutes), "distance" (meters), or both c('duration',
-#' 'distance').
+#' be "duration" (in minutes), "distance" (meters), "total_distance"
+#' (network distance + snapping distance, in meters) or any combination
+#' of them.
 #' @param exclude pass an optional "exclude" request option to the OSRM API
 #' (not allowed with the OSRM demo server).
 #' @param osrm.server the base URL of the routing server.
 #' @param osrm.profile the routing profile to use, e.g. "car", "bike" or "foot".
 #' @return
-#' The output of this function is a list composed of one or two matrices
+#' The output of this function is a list composed of one or several matrices
 #' and 2 data.frames
 #' \itemize{
 #'   \item{durations}: a matrix of travel times (in minutes)
-#'   \item{distances}: a matrix of distances (in meters)
+#'   \item{distances}: a matrix of network distances (in meters)
+#'   \item{total_distances}: a matrix of network + snapping distances (in meters)
 #'   \item{sources}: a data.frame of the coordinates of the points actually
-#'   used as starting points (EPSG:4326 - WGS84)
-#'   \item{sources}: a data.frame of the coordinates of the points actually
-#'   used as destinations (EPSG:4326 - WGS84)
+#'   used as starting points, including their snapping distance (EPSG:4326 - WGS84)
+#'   \item{destinations}: a data.frame of the coordinates of the points actually
+#'   used as destinations, including their snapping distance (EPSG:4326 - WGS84)
 #'   }
 #' @note
 #' The OSRM demo server does not allow large queries (more than 10000 distances
@@ -130,14 +132,21 @@ osrmTable <- function(src,
   if (!missing(exclude)) {
     url <- paste0(url, "exclude=", exclude, "&")
   }
+
+  # Manage "total_distance" measure
+  total <- "total_distance" %in% measure
+  measure_api <- setdiff(measure, "total_distance")
+  if (total && !("distance" %in% measure_api)) {
+    measure_api <- c(measure_api, "distance")
+  }
+
   # adding measure parameter
   url <- paste0(
     url,
     "annotations=",
-    paste0(measure, collapse = ","),
+    paste0(measure_api, collapse = ","),
     "&generate_hints=false"
   )
-  # print(url)
   e <- try(
     {
       req_handle <- curl::new_handle(verbose = FALSE)
@@ -155,9 +164,6 @@ osrmTable <- function(src,
 
   res <- RcppSimdJson::fparse(rawToChar(r$content))
 
-  # create dummy dataset for tests
-  # return(list(res = res, src = src_r, dst = dst_r))
-
   # format results
   output <- list()
   if (!is.null(res$durations)) {
@@ -180,5 +186,23 @@ osrmTable <- function(src,
   coords <- coord_format(res = res, src = src_r, dst = dst_r)
   output$sources <- coords$sources
   output$destinations <- coords$destinations
+
+  # compute total distances
+  if (total && !is.null(output$distances)) {
+    src_snap <- output$sources$snapping_distance
+    dst_snap <- output$destinations$snapping_distance
+    snap_sum <- outer(src_snap, dst_snap, "+")
+    output$total_distances <- output$distances + snap_sum
+
+    # fix self-distance
+    ids_match <- outer(rownames(output$total_distances), 
+                       colnames(output$total_distances), "==")
+    output$total_distances[ids_match] <- 0
+
+    if (!("distance" %in% measure)) {
+      output$distances <- NULL
+    }
+  }
+
   return(output)
 }

R/osrmTrip.R

@@ -34,6 +34,8 @@
 #' }
 #' \item{summary}{A list with 2 components: total duration (in minutes)
 #' and total distance (in kilometers) of the trip.}
+#' \item{waypoints}{An sf POINT object of the snapped waypoints used in the trip,
+#' including their \code{snapping_distance} (in kilometers).}
 #' }
 #' @export
 #' @examples
@@ -99,13 +101,16 @@ osrmTrip <- function(loc, exclude = NULL, overview = "simplified",
   res <- RcppSimdJson::fparse(rawToChar(r$content))
 
 
-  # Get all the waypoints
-  waypointsg <- data.frame(res$waypoints[, c(1, 2, 5)],
-    matrix(unlist(res$waypoints$location),
-      byrow = TRUE, ncol = 2
-    ),
-    id = loc$id
-  )
+  waypointsg <- res$waypoints
+  waypointsg$snapping_distance <- waypointsg$distance / 1000
+  waypointsg$distance <- NULL
+  waypointsg$lon <- sapply(res$waypoints$location, "[[", 1)
+  waypointsg$lat <- sapply(res$waypoints$location, "[[", 2)
+  # Alias for matching loop
+  waypointsg$X1 <- waypointsg$lon
+  waypointsg$X2 <- waypointsg$lat
+  waypointsg$location <- NULL
+  waypointsg$id <- loc$id
 
   # In case of island, multiple trips
   ntour <- dim(res$trips)[1]
@@ -177,7 +182,14 @@ osrmTrip <- function(loc, exclude = NULL, overview = "simplified",
       duration = res$trips[nt, ]$duration / 60,
       distance = res$trips[nt, ]$distance / 1000
     )
-    trips[[nt]] <- list(trip = sldf, summary = tripSummary)
+    trip_waypoints <- st_as_sf(waypoints, coords = c("lon", "lat"), crs = 4326)
+    # remove internal aliases
+    trip_waypoints$X1 <- NULL
+    trip_waypoints$X2 <- NULL
+    if (!is.na(oprj)) {
+      trip_waypoints <- sf::st_transform(trip_waypoints, oprj)
+    }
+    trips[[nt]] <- list(trip = sldf, summary = tripSummary, waypoints = trip_waypoints)
   }
   return(trips)
 }

R/utils.R

@@ -52,13 +52,17 @@ coord_format <- function(res, src, dst) {
     ncol = 2, byrow = TRUE,
     dimnames = list(src$id, c("lon", "lat"))
   ))
+  sources$snapping_distance <- res$sources$distance
+
   destinations <- data.frame(matrix(
     unlist(res$destinations$location,
       use.names = TRUE
     ),
     ncol = 2, byrow = TRUE,
     dimnames = list(dst$id, c("lon", "lat"))
   ))
+  destinations$snapping_distance <- res$destinations$distance
+
   return(list(sources = sources, destinations = destinations))
 }
 

inst/tinytest/test_osrmRoute.R

@@ -8,7 +8,10 @@ if(demo_server){
   expect_identical(st_crs(r), st_crs(x_sf))
   expect_true(nrow(r) == 1)
   expect_identical(colnames(r), 
-                   c("src", "dst", "duration", "distance", "geometry"))
+                   c("src", "dst", "duration", "distance", "src_snapping_distance", 
+                     "dst_snapping_distance", "geometry"))
+  expect_true(!is.null(attr(r, "snapping")))
+  expect_true("snapping_distance" %in% colnames(attr(r, "snapping")))
   expect_true(st_geometry_type(r) == "LINESTRING")
 
   r <- osrmRoute(loc = x_sf[1:3, ])
@@ -17,7 +20,10 @@ if(demo_server){
   expect_identical(st_crs(r), st_crs(x_sf))
   expect_true(nrow(r) == 1)
   expect_identical(colnames(r), 
-                   c("src", "dst", "duration", "distance", "geometry"))
+                   c("src", "dst", "duration", "distance", "src_snapping_distance", 
+                     "dst_snapping_distance", "geometry"))
+  expect_true(!is.null(attr(r, "snapping")))
+  expect_true("snapping_distance" %in% colnames(attr(r, "snapping")))
   expect_true(st_geometry_type(r) == "LINESTRING")
 
   # Return only duration and distance
@@ -34,7 +40,10 @@ if(demo_server){
   expect_identical(st_crs(r), st_crs(x_sf))
   expect_true(nrow(r) == 1)
   expect_identical(colnames(r), 
-                   c("src", "dst", "duration", "distance", "geometry"))
+                   c("src", "dst", "duration", "distance", "src_snapping_distance", 
+                     "dst_snapping_distance", "geometry"))
+  expect_true(!is.null(attr(r, "snapping")))
+  expect_true("snapping_distance" %in% colnames(attr(r, "snapping")))
   expect_true(st_geometry_type(r) == "LINESTRING")
 
   r <- osrmRoute(loc = x_sf[1:3, ])
@@ -43,7 +52,10 @@ if(demo_server){
   expect_identical(st_crs(r), st_crs(x_sf))
   expect_true(nrow(r) == 1)
   expect_identical(colnames(r), 
-                   c("src", "dst", "duration", "distance", "geometry"))
+                   c("src", "dst", "duration", "distance", "src_snapping_distance", 
+                     "dst_snapping_distance", "geometry"))
+  expect_true(!is.null(attr(r, "snapping")))
+  expect_true("snapping_distance" %in% colnames(attr(r, "snapping")))
   expect_true(st_geometry_type(r) == "LINESTRING")
 
   # Return only duration and distance
@@ -62,7 +74,10 @@ if(demo_server){
   expect_identical(st_crs(r), st_crs(x_sf))
   expect_true(nrow(r) == 1)
   expect_identical(colnames(r), 
-                   c("src", "dst", "duration", "distance", "geometry"))
+                   c("src", "dst", "duration", "distance", "src_snapping_distance", 
+                     "dst_snapping_distance", "geometry"))
+  expect_true(!is.null(attr(r, "snapping")))
+  expect_true("snapping_distance" %in% colnames(attr(r, "snapping")))
   expect_true(st_geometry_type(r) == "LINESTRING")
 
   r <- osrmRoute(loc = x_sf[1:3, ])
@@ -71,7 +86,10 @@ if(demo_server){
   expect_identical(st_crs(r), st_crs(x_sf))
   expect_true(nrow(r) == 1)
   expect_identical(colnames(r), 
-                   c("src", "dst", "duration", "distance", "geometry"))
+                   c("src", "dst", "duration", "distance", "src_snapping_distance", 
+                     "dst_snapping_distance", "geometry"))
+  expect_true(!is.null(attr(r, "snapping")))
+  expect_true("snapping_distance" %in% colnames(attr(r, "snapping")))
   expect_true(st_geometry_type(r) == "LINESTRING")
 
   # Return only duration and distance
@@ -109,15 +127,21 @@ if(local_server){
   expect_identical(st_crs(r), st_crs(x_sf))
   expect_true(nrow(r) == 1)
   expect_identical(colnames(r), 
-                   c("src", "dst", "duration", "distance", "geometry"))
+                   c("src", "dst", "duration", "distance", "src_snapping_distance", 
+                     "dst_snapping_distance", "geometry"))
+  expect_true(!is.null(attr(r, "snapping")))
+  expect_true("snapping_distance" %in% colnames(attr(r, "snapping")))
   expect_true(st_geometry_type(r) == "LINESTRING")
 
   r <- osrmRoute(loc = x_sf[1:3, ])
   expect_true(inherits(r, "sf"))
   expect_identical(st_crs(r), st_crs(x_sf))
   expect_true(nrow(r) == 1)
   expect_identical(colnames(r), 
-                   c("src", "dst", "duration", "distance", "geometry"))
+                   c("src", "dst", "duration", "distance", "src_snapping_distance", 
+                     "dst_snapping_distance", "geometry"))
+  expect_true(!is.null(attr(r, "snapping")))
+  expect_true("snapping_distance" %in% colnames(attr(r, "snapping")))
   expect_true(st_geometry_type(r) == "LINESTRING")
 
   # Return only duration and distance

inst/tinytest/test_osrmTable.R

@@ -144,4 +144,17 @@ if(local_server){
   expect_error(osrmTable(loc = x_sf[1:10, ], 
                          osrm.server = "http://0.0.0.0:5100/", 
                          osrm.profile = "car"))
+
+  # total_distance
+  A <- osrmTable(loc = x_sf[1:5, ], measure = "total_distance")
+  expect_true(!is.null(A$total_distances))
+  expect_true(is.null(A$distances))
+  expect_equal(dim(A$total_distances), c(5,5))
+  expect_equal(diag(A$total_distances), rep(0, 5))
+
+  B <- osrmTable(loc = x_sf[1:5, ], measure = c("distance", "total_distance"))
+  expect_true(!is.null(B$distances))
+  expect_true(!is.null(B$total_distances))
+  expect_equal(B$total_distances[1,2], 
+               B$distances[1,2] + B$sources$snapping_distance[1] + B$destinations$snapping_distance[2])
 }

inst/tinytest/test_osrmTrip.R

@@ -13,6 +13,8 @@ if(demo_server){
                    c("start", "end", "duration", "distance", "geometry"))
   expect_true(st_geometry_type(trip, by_geometry = FALSE) == "LINESTRING")
   expect_identical(names(trip_summary),c('duration', 'distance'))
+  expect_true(!is.null(r[[1]]$waypoints))
+  expect_true("snapping_distance" %in% colnames(r[[1]]$waypoints))
 
   ################# DEMO BIKE #####################
   options(osrm.server = "https://routing.openstreetmap.de/", osrm.profile = "bike")
@@ -27,6 +29,8 @@ if(demo_server){
                    c("start", "end", "duration", "distance", "geometry"))
   expect_true(st_geometry_type(trip, by_geometry = FALSE) == "LINESTRING")
   expect_identical(names(trip_summary),c('duration', 'distance'))
+  expect_true(!is.null(r[[1]]$waypoints))
+  expect_true("snapping_distance" %in% colnames(r[[1]]$waypoints))
 
 
   ############## DEMO FOOT #################"""""
@@ -42,6 +46,8 @@ if(demo_server){
                    c("start", "end", "duration", "distance", "geometry"))
   expect_true(st_geometry_type(trip, by_geometry = FALSE) == "LINESTRING")
   expect_identical(names(trip_summary),c('duration', 'distance'))
+  expect_true(!is.null(r[[1]]$waypoints))
+  expect_true("snapping_distance" %in% colnames(r[[1]]$waypoints))
 
   ############# server param ##################""
   r <- osrmTrip(loc = x_sf[1:5,], 
@@ -56,7 +62,9 @@ if(demo_server){
   expect_identical(colnames(trip), 
                    c("start", "end", "duration", "distance", "geometry"))
   expect_true(st_geometry_type(trip, by_geometry = FALSE) == "LINESTRING")
-  expect_identical(names(trip_summary),c('duration', 'distance'))  
+  expect_identical(names(trip_summary),c('duration', 'distance'))
+  expect_true(!is.null(r[[1]]$waypoints))
+  expect_true("snapping_distance" %in% colnames(r[[1]]$waypoints))  
   # server error
   expect_error(osrmTrip(loc = x_sf[1:5, ], 
                         osrm.server = "https://router.project-osrm.orgS/", 
@@ -83,6 +91,8 @@ if(local_server){
                    c("start", "end", "duration", "distance", "geometry"))
   expect_true(st_geometry_type(trip, by_geometry = FALSE) == "LINESTRING")
   expect_identical(names(trip_summary),c('duration', 'distance'))
+  expect_true(!is.null(r[[1]]$waypoints))
+  expect_true("snapping_distance" %in% colnames(r[[1]]$waypoints))
 
   # server error
   expect_error(osrmTrip(loc = x_sf[1:5, ],