Shiny app for comparing ORS cycling weighting alternatives https://aoles.shinyapps.io/cyclingWeightings/

app.R

library(shiny)
library(leaflet)
library(openrouteservice)
library(lubridate) #convert seconds to hh:mm

# Precomputed random routes in Bayern
load("routes.rda")

lapply(res, function(routes) {
    sapply(routes, function(x) x$features[[1]]$properties$summary$distance/1000) 
}) %>% data.frame -> distance

lapply(res, function(routes) {
    sapply(routes, function(x) {
      td <- seconds_to_period(x$features[[1]]$properties$summary$duration)
      sprintf('%dh %02dm', hour(td), minute(td))
    })
}) %>% data.frame -> duration

lapply(res, function(routes) {
  sapply(routes, function(x) x$features[[1]]$properties$ascent) 
}) %>% data.frame -> ascent

lapply(res, function(routes) {
  lapply(routes, function(x) {
    x = x$features[[1]]$properties$extras$suitability$summary
    values = sapply(x, `[[`, "value") 
    amount = sapply(x, `[[`, "amount")
    v = rep(0, 8)
    v[values-2] <- amount
    v
  })
}) -> suitability

lapply(suitability, function(routes) {
  sapply(routes, function(v) {
    sum(0:7 * v/100)
  })
}) %>% data.frame -> suitability_index

ui <- bootstrapPage(
    tags$style(type = "text/css", "
html, body {
  width: 100%;
  height: 100%;
}
#controls {
  background: rgba(255, 255, 255, 0.8);
  padding: 10px;
  border-radius: 5px;
}"),
    leafletOutput("map", width = "100%", height = "100%"),
    absolutePanel(top = 10, right = 10, id="controls",
                  #h3("Cycling Weightings"),
                  sliderInput("route",
                              "Route ID:",
                              min = 1,
                              max = 100,
                              value = 1),
                  uiOutput("google"),
                  tableOutput("summary"),
                  tableOutput("characteristics"),
                  h5(strong("Suitability")),
                  plotOutput("suitability", height = "200px")
    )
)

server <- function(input, output, session) {
    
    id <- reactive(input$route)
    
    output$google <- renderUI({ #renderText({
        coordinates <- res$fastest[[id()]]$metadata$query$coordinates
        lon1 = coordinates[1, 1]
        lat1 = coordinates[1, 2]
        lon2 = coordinates[2, 1]
        lat2 = coordinates[2, 2]
        url <- sprintf("https://www.google.com/maps/dir/?api=1&origin=%.6f,%.6f&destination=%.6f,%.6f&travelmode=bicycling", lat1, lon1, lat2, lon2)
        tagList(a("Google Maps", href=url, target="_blank"))
    })
    
    output$map <- renderLeaflet({
        i <- id()
        leaflet() %>% 
            addTiles(group = "OpenStreetMap") %>%
            addTiles("https://dev.{s}.tile.openstreetmap.fr/cyclosm/{z}/{x}/{y}.png", group ="CyclOSM" ) %>%
            addTiles("https://{s}.tile.thunderforest.com/cycle/{z}/{x}/{y}.png?apikey=13efc496ac0b486ea05691c820824f5f", group ="OpenCycleMap") %>%
            addGeoJSON(res$fastest[i], fill=FALSE, color = c("#000"), group = "current fastest") %>%
            addGeoJSON(res$recommended[i], fill=FALSE, color = c("#f00"), group = "current recommended") %>%
            addGeoJSON(res$new[i], fill=FALSE, color = c("#0f0"), group = "new") %>%
            addGeoJSON(res$reduced[i], fill=FALSE, color = c("#f80"), group = "reduced") %>%
            addGeoJSON(res$scaled[i], fill=FALSE, color = c("#f08"), group = "scaled") %>%
            addLayersControl(
                baseGroups = c("OpenStreetMap", "CyclOSM", "OpenCycleMap"),
                overlayGroups = c("current fastest", "current recommended", "reduced", "scaled", "new"),
                position = "bottomleft"
            ) %>%
            fitBBox(res$fastest[[i]]$bbox[c(1,2,4,5)])
    })
    
    output$summary <- renderTable({
        t(rbind("distance" = distance[id(),], "duration" = duration[id(),]))
    }, striped = TRUE, spacing = "xs", rownames = TRUE)
    
    output$suitability <- renderPlot({
      i <- id()
      x <- 1:8-0.5
      par(mar=c(2,4,0,0), bg = NA)
      plot(x, suitability$recommended[[i]], ylim = c(0, 90), col = "red", type = "S", ylab = "amount [%]")
      points(x, suitability$new[[i]], col = "green", type = "S")
      points(x, suitability$fastest[[i]], type = "S")
      abline(v=4, lty=2)
    }, bg = NA)
    
    output$characteristics <- renderTable({
      weightings = c("fastest", "recommended", "new")
      t(rbind("ascent" = ascent[id(), weightings], "suitability" = suitability_index[id(), weightings]))
    }, striped = TRUE, spacing = "xs", rownames = TRUE)
    
}

shinyApp(ui, server)

coordinates_bayern-cycling.rda

generate_routes.R

library("openrouteservice")

set.seed(0L)

options(openrouteservice.url = "http://localhost:8082/ors")

profile = "cycling-regular"
n = 100
rep = 1

### generate n random coordinates and convert them to start/endpoints

coordinates_file = "coordinates_bayern-cycling.rda"

if (file.exists(coordinates_file)) {
  load(coordinates_file)
} else {
  library("sf")
  library("geojson")
  
  x = readLines("~/Data/polygons/bayern.geojson")
  bbox = geo_bbox(x)
  poly = st_read(paste(x, collapse = ""))
  
  pts = vector(mode = "list", 2*n)
  
  i = 0;
  while (i < 2*n) {
    coords = c(runif(1, bbox[1], bbox[3]), runif(1, bbox[2], bbox[4]))
    if (st_within(st_point(coords), poly, sparse=FALSE))
      if ( !inherits(try(ors_directions(list(coords, coords), profile=profile), silent=TRUE), "try-error") )
        pts[[(i = i+1)]] <- coords
  }
  
  skeleton <- rep(list(list(c(0, 0), c(0,0))), n)
  coordinates <- relist(unlist(pts), skeleton)
  
  save(coordinates, file = coordinates_file)
}

profile_args = list(profile = profile, format = 'geojson', instructions = FALSE, elevation = TRUE, extra_info = "suitability")

profile_args = list(
  fastest = c(profile_args, preference = "fastest"),
  recommended = c(profile_args, preference = "recommended"),
  reduced = c(profile_args, preference = "recommendedr"),
  scaled = c(profile_args, preference = "recommendeds"),
  new = c(profile_args, preference = "recommendednew")
  )

res = lapply(names(profile_args), function(name) {
  lapply(1:n, function(id) {
    cat("                         \r", name, id)
    label = sprintf("[BENCHMARK] %s; %d", name, id)
    cl = as.call(c(ors_directions, coordinates[id], profile_args[[name]], id = label))
    res = try(eval(cl), silent = TRUE)
    if ( inherits(res, "try-error") ) {
      attr(res, "condition")$message
    } else {
      cl$id = NULL
      query_times = replicate(rep-1, attr(eval(cl), "query_time"))
      attr(res, "query_time") = c(attr(res, "query_time"), query_times)
      res
    }
  })
})

names(res) <- names(profile_args)

save(res, file = "routes.rda", compress = "xz")

routes.rda