StOREE Highways

library(tidyverse)
library(leaflet)
library(leaflegend)
library(shiny)
knitr::opts_chunk$set(echo = TRUE)

source("00setup.R")

# EWKB to SF
f_ewkb_to_sf <- function(x, spatial_column){
    cmd <- paste("x %<>% mutate(geometry = st_as_sfc(structure(as.list(", spatial_column, "), class = 'WKB'), EWKB = TRUE))")
    eval(parse(text = cmd))
    x <- st_as_sf(x, sf_column_name = "geometry")
    cmd <- paste("x %<>% dplyr::select(-", spatial_column, ")")
    eval(parse(text = cmd))
    x
}

# f_system 1 and 2 in MESA sites
sql <- "select distinct mesa_city, f_system, route_number
from arnold_rest.arnold_rest_mesa_sites
order by f_system, mesa_city, route_number;"

# get and write the table
fwys_mesa_arnold <- dbGetQuery(conn = storee, statement = sql)

1 Introduction

This presents ARNOLD f_system 1 and 2 roadways passing through the StOREE/MESA sites.

2 Map

The map presents StOREE study site outlines and ARNOLD roadways, color coded by f_system. Hover over roadway segments to show the route number.

When changing the MESA city, it will take some moments for the map data to redraw.

# UI----
# the UI allows selection of locale
mesa_cities <- fwys_mesa_arnold %>% pull(mesa_city) %>% unique()
ui <- bootstrapPage(
    tags$style(type = "text/css", "html, body {width:100%;height:100%}"),
    leafletOutput("map", height = 1000),
    absolutePanel(
        top = 10, right = 10,
        selectInput(inputId  = "mesa_cities",
                    label = "MESA City",
                    choices = mesa_cities
        )
    )
)

# server----
server <- function(input, output, session) {

    # base SQL for roads
    sqlbase <- "select mesa_city, f_system, route_number, rn, geom_4326 as geom_4326 from arnold_rest.arnold_rest_mesa_sites where mesa_city = 'xMCx' order by f_system, mesa_city, route_number;"

    # base SQL for study sites
    sqlbase_ss <- "select mesa_city, geom_4326 from study_area.mesa_sites where mesa_city = 'xMCx';"

    # a two color palette
    pal <- colorBin(c("red", "green"), 1:2)

    # the map----
    output$map <- renderLeaflet({
        # Use leaflet() here, and only include aspects of the map that
        # won't need to change dynamically (at least, not unless the
        # entire map is being torn down and recreated).
        leaflet() %>%
            #clearShapes() %>%
            addProviderTiles(providers$CartoDB.Positron)
    })

    # polys----
    polys <- reactive({
        # the MESA city
        MC <- input$mesa_cities
        # get the lines,make an SQL
        sql <- sqlbase_ss %>%
            str_replace_all(pattern = "xMCx", replacement = MC)
        # message(sql)
        # get the data and convert to sf
        dat <- dbGetQuery(conn = storee, statement = sql, quiet = TRUE)
        f_ewkb_to_sf(x = dat, spatial_column = "geom_4326")
    })

    # highways----
    highways <- reactive({
        # the MESA city
        MC <- input$mesa_cities
        # get the lines,make an SQL
        sql <- sqlbase %>%
            str_replace_all(pattern = "xMCx", replacement = MC)
        # message(sql)
        # get the data and convert to sf
        dat <- dbGetQuery(conn = storee, statement = sql, quiet = TRUE)
        f_ewkb_to_sf(x = dat, spatial_column = "geom_4326")
    })

    observe({
        # get the highways
        df <- highways()
        # bounding box
        bbox_df <- st_bbox(df) %>% as.numeric()

        # polys
        dfpolys <- polys()
        assign(x = "dfpolys", dfpolys, envir = .GlobalEnv)

        # make the map
        m <- leafletProxy("map", data = df) %>%
            clearControls() %>%
            addLegend(colors = c("red", "green"), labels = c("1", "2"), title = "f_system", position = "bottomright", opacity = 1)

        # change bounds to display
        m %>% fitBounds(lng1 = bbox_df[1], lat1 = bbox_df[2], lng2 = bbox_df[3], lat2 = bbox_df[4])
        # add polygons
        m %>%
            addPolygons(data = dfpolys,
                        fill = FALSE)
        # add polylines
        m %>%
            #addTiles() %>%
            addPolylines(data = df, color = ~pal(f_system), label = ~rn,
            labelOptions = labelOptions(noHide = FALSE, textsize = "15px"), opacity = 1)

        #m %>% addLegendBin(data = df, pal = pal, values = ~f_system, opacity = 1)

    })


}

shinyApp(ui, server)