diff --git a/R/osrmRoute.R b/R/osrmRoute.R index 20d1763..035c7b3 100644 --- a/R/osrmRoute.R +++ b/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) diff --git a/R/osrmTable.R b/R/osrmTable.R index 963301d..3e29f8f 100644 --- a/R/osrmTable.R +++ b/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) } diff --git a/R/osrmTrip.R b/R/osrmTrip.R index c24cba5..2b83c98 100644 --- a/R/osrmTrip.R +++ b/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) } diff --git a/R/utils.R b/R/utils.R index 3196b16..0e70842 100644 --- a/R/utils.R +++ b/R/utils.R @@ -52,6 +52,8 @@ 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 @@ -59,6 +61,8 @@ coord_format <- function(res, src, dst) { ncol = 2, byrow = TRUE, dimnames = list(dst$id, c("lon", "lat")) )) + destinations$snapping_distance <- res$destinations$distance + return(list(sources = sources, destinations = destinations)) } diff --git a/inst/tinytest/coord_format_out.rds b/inst/tinytest/coord_format_out.rds index 7688e2f..7f83f4a 100644 Binary files a/inst/tinytest/coord_format_out.rds and b/inst/tinytest/coord_format_out.rds differ diff --git a/inst/tinytest/test_osrmRoute.R b/inst/tinytest/test_osrmRoute.R index d53abfa..a53757e 100644 --- a/inst/tinytest/test_osrmRoute.R +++ b/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,7 +127,10 @@ 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, ]) @@ -117,7 +138,10 @@ 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") # Return only duration and distance diff --git a/inst/tinytest/test_osrmTable.R b/inst/tinytest/test_osrmTable.R index 3248131..98b7596 100644 --- a/inst/tinytest/test_osrmTable.R +++ b/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]) } \ No newline at end of file diff --git a/inst/tinytest/test_osrmTrip.R b/inst/tinytest/test_osrmTrip.R index 6c8d53c..03a5c26 100644 --- a/inst/tinytest/test_osrmTrip.R +++ b/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, ], diff --git a/man/osrmRoute.Rd b/man/osrmRoute.Rd index 96896c9..1d78b1c 100644 --- a/man/osrmRoute.Rd +++ b/man/osrmRoute.Rd @@ -63,12 +63,23 @@ FALSE to return only time and distance.} } \value{ 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 @@ -98,6 +109,12 @@ route1 <- osrmRoute(src = apotheke.sf[1, ], dst = apotheke.sf[16, ]) 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")], diff --git a/man/osrmTable.Rd b/man/osrmTable.Rd index 2b52bc0..ebb975e 100644 --- a/man/osrmTable.Rd +++ b/man/osrmTable.Rd @@ -45,23 +45,25 @@ If relevant, row names are used as identifiers.} (not allowed with the OSRM demo server).} \item{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.} \item{osrm.server}{the base URL of the routing server.} \item{osrm.profile}{the routing profile to use, e.g. "car", "bike" or "foot".} } \value{ -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) } } \description{ diff --git a/man/osrmTrip.Rd b/man/osrmTrip.Rd index 782b5bc..ec2e9bc 100644 --- a/man/osrmTrip.Rd +++ b/man/osrmTrip.Rd @@ -46,6 +46,8 @@ distance (length of the step in kilometers). } \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).} } } \description{