1
#' HERE Intermodal Routing API: Calculate Route
2
#'
3
#' Calculates route geometries (\code{LINESTRING}) between given pairs of points using the HERE 'Intermodal Routing' API.
4
#'
5
#' @references
6
#' \href{https://developer.here.com/documentation/intermodal-routing/dev_guide/index.html}{HERE Intermodal Routing API: Routes}
7
#'
8
#' @param origin \code{sf} object, the origin locations of geometry type \code{POINT}.
9
#' @param destination \code{sf} object, the destination locations of geometry type \code{POINT}.
10
#' @param datetime \code{POSIXct} object, datetime for the departure (\code{default = Sys.time()}).
11
#' @param results numeric, maximum number of suggested route alternatives (Valid range: 1 and 7, \code{default = 3}).
12
#' @param transfers numeric, maximum number of transfers allowed per route (Valid range: -1 and 6, \code{default = -1}).
13
#' @param url_only boolean, only return the generated URLs (\code{default = FALSE})?
14
#'
15
#' @return
16
#' An \code{sf} object containing the requested intermodal routes.
17
#' @export
18
#'
19
#' @examples
20
#' # Provide an API Key for a HERE project
21
#' set_key("<YOUR API KEY>")
22
#'
23
#' # Intermodal routing
24
#' routes <- intermodal_route(
25
#'   origin = poi[1:3, ],
26
#'   destination = poi[4:6, ],
27
#'   url_only = TRUE
28
#' )
29
intermodal_route <- function(origin, destination, datetime = Sys.time(),
30
                             results = 3, transfers = -1, url_only = FALSE) {
31
  # Checks
32 1
  .check_points(origin)
33 1
  .check_points(destination)
34 1
  .check_input_rows(origin, destination)
35 1
  .check_datetime(datetime)
36 1
  .check_numeric_range(results, 1, 7)
37 1
  .check_numeric_range(transfers, -1, 6)
38 1
  .check_boolean(url_only)
39

40
  # CRS transformation and formatting
41 1
  origin <- sf::st_coordinates(
42 1
    sf::st_transform(origin, 4326)
43
  )
44 1
  origin <- paste0(
45 1
    origin[, 2], ",", origin[, 1]
46
  )
47 1
  destination <- sf::st_coordinates(
48 1
    sf::st_transform(destination, 4326)
49
  )
50 1
  destination <- paste0(
51 1
    destination[, 2], ",", destination[, 1]
52
  )
53

54
  # Add API key
55 1
  url <- .add_key(
56 1
    url = "https://intermodal.router.hereapi.com/v8/routes?"
57
  )
58

59
  # Add origin and destination
60 1
  url = paste0(
61 1
    url,
62 1
    "&origin=",
63 1
    origin,
64 1
    "&destination=",
65 1
    destination
66
  )
67

68
  # # Add mode
69
  # url = .add_mode(
70
  #   url = url,
71
  #   type = type,
72
  #   mode = mode,
73
  #   traffic = traffic
74
  # )
75

76
  # Add departure time (arrival time is not supported)
77 1
  url <- .add_datetime(
78 1
    url,
79 1
    datetime,
80 1
    "departureTime"
81
  )
82

83
  # Add alternatives (results minus 1)
84 1
  url = paste0(
85 1
    url,
86 1
    "&alternatives=",
87 1
    results - 1
88
  )
89

90
  # Number of transfers
91 1
  if (transfers > -1) {
92 0
    url <- paste0(
93 0
      url,
94 0
      "&changes=",
95 0
      transfers
96
    )
97
  }
98

99
  # Request polyline and summary
100 1
  url = paste0(
101 1
    url,
102 1
    "&return=",
103 1
    "polyline,travelSummary"
104
  )
105

106
  # Return urls if chosen
107 0
  if (url_only) return(url)
108

109
  # Request and get content
110 1
  data <- .get_content(
111 1
    url = url
112
  )
113 0
  if (length(data) == 0) return(NULL)
114

115
  # Extract information
116 1
  routes <- .extract_intermodal_routes(data)
117

118
  # Checks success
119 1
  if (is.null(routes)) {
120 0
    message("No intermodal routes found.")
121 0
    return(NULL)
122
  }
123

124
  # Postprocess
125 1
  routes <- routes[routes$rank <= results, ]
126 1
  routes$departure <- .parse_datetime(routes$departure, tz = attr(datetime, "tzone"))
127 1
  routes$arrival <- .parse_datetime(routes$arrival, tz = attr(datetime, "tzone"))
128 1
  rownames(routes) <- NULL
129

130
  # Create sf object
131 1
  return(
132 1
    sf::st_as_sf(
133 1
      as.data.frame(routes),
134 1
      sf_column_name = "geometry",
135 1
      crs = 4326
136
    )
137
  )
138
}
139

140
.extract_intermodal_routes <- function(data) {
141 1
  ids <- .get_ids(data)
142 1
  count <- 0
143

144
  # Routes
145 1
  routes <- data.table::rbindlist(
146 1
    lapply(data, function(con) {
147 1
      count <<- count + 1
148

149
      # # O-D: function(data, origin, destination
150
      # orig <- rev(as.numeric(strsplit(origin[[count]], ",")[[1]]))
151
      # dest <- rev(as.numeric(strsplit(destination[[count]], ",")[[1]]))
152

153
      # Parse JSON
154 1
      df <- jsonlite::fromJSON(con)
155 1
      if (is.null(df$routes$sections)) {return(NULL)}
156

157
      # Connections
158 1
      rank <- 0
159 1
      routes <- data.table::data.table(
160 1
        id = ids[count],
161

162
        # Segments
163 1
        data.table::rbindlist(
164 1
          lapply(df$routes$sections, function(sec) {
165 1
            rank <<- rank + 1
166 1
            data.table::data.table(
167 1
              rank = rank,
168 1
              departure = sec$departure$time,
169 1
              origin = c("ORIG", sec$departure$place$name[2:length(sec$departure$place$name)]),
170 1
              arrival = sec$arrival$time,
171 1
              destination = c(sec$arrival$place$name[1:(length(sec$arrival$place$name)-1)], "DEST"),
172 1
              type = sec$type,
173 1
              mode = sec$transport$mode,
174 1
              vehicle = if (is.null(sec$transport$name)) {NA} else {sec$transport$name},
175 1
              provider = if (is.null(sec$agency$name)) {NA} else {sec$agency$name},
176 1
              direction = if (is.null(sec$transport$headsign)) {NA} else {sec$transport$headsign},
177 1
              distance = sec$travelSummary$length,
178 1
              duration = sec$travelSummary$duration,
179 1
              geometry = sec$polyline
180
            )
181 1
          }), fill = TRUE)
182
      )
183 1
    }), fill = TRUE)
184

185
  # Check success
186 0
  if (nrow(routes) < 1) {return(NULL)}
187

188
  # Decode flexible polyline encoding to LINESTRING
189 1
  routes$geometry <- sf::st_geometry(
190 1
    flexpolyline::decode_sf(
191 1
      routes$geometry, 4326
192
    )
193
  )
194

195 1
  return(routes)
196
}

Read our documentation on viewing source code .

Loading