Making a shiny app to check OS Grid references

Recently I was working with the OS Terrain 50 dataset to make a basemap. Its a wonderful resource, but if you download all of the data as gml files you will be faced with a very long list of folders containing all the data you want but organized by OS Grid reference numbers. Not knowing exactly what I wanted of the top of my head I though it would be useful to quickly put together a tool that would allow me to draw bounding boxes and get back a list of all the grids it contained.

Shiny, which I have been using quite a bit recently, is the easiest tool for this task and we can quickly throw together an app that is sufficient for quickly looking up grid references.

First lets load in all the packages we will need to put everything together.

library(tidyverse)

library(shiny)
library(leaflet)
library(leaflet.extras)

library(sf)
library(sp)

Tidyverse will let us quickly load in an manipulate the data we need. Shiny will provide the web interface, leaflet the interactive map, and leaflet extras for some tools for drawing on the map. Finally we have sp and sf to work with spatial data.

With these packages ready we can then load in our data. Thankfully this is an easy task thanks to shapefiles of the underlying OS Grid that have been put together by Charles Roper.

os_grid <- st_read("OSGB_Grid_5km.geojson")

The next step is to specify how we would like the UI of the app to look. To keep things simple I’ve opted for one tab for the map and one for the results.

ui <- navbarPage( # three tab page with headline at top
  "OS GridRef Lookup Tool", # The headline
  tabPanel("Draw",
           tags$style(type = "text/css", "#map {height: calc(100vh - 80px) !important;}"),
           leafletOutput("mymap"),
           ),
  tabPanel("Results",
           tags$h3("Top Level Grid Codes"),
           tags$blockquote(textOutput("top_tiles")),
           tags$h3("Med Level Grid Codes"),
           tags$blockquote(textOutput("med_tiles")),
           tags$h3("All Grid Codes"),
           tags$blockquote(textOutput("all_tiles")),
           tags$h2("About"),
           tags$text("This tool makes use of the 5km OS grid file produced by Charles Roper, avalable at https://github.com/charlesroper/OSGB_Grids/.
                     If you need the more detailed 1km grid you can download this file and run it on you own computer (its the difrence between 5 or 95mb!).
                     The code for this is avalable at: "),
           )
)

If you are not familiar with how shiny apps work, I would highly recommend Mastering Shiny by Hadley Wickham which does a wonderful job of explaining reactivity. But to explain things quickly, not much is being defined in this section other than to say that both the map (“mymap”) and the selected data (“top_tiles”, “med_tiles”, “all_tiles”) are waiting on data to be passed to them via the leafletOutput and textOutput functions. What exactly is being passed here is then defined in the next section where we setup the shiny server that does all of the heavy lifting.

First, lets define our server, which is incredibly simple.

server <- function(input, output) {
  }

Then lets populate it with variables and functions that we can feed back to the UI. So within the server function add the following code to make our basemap.

  output$mymap <- renderLeaflet(
    leaflet() %>%
      addTiles(group = "Background") %>%
      addProviderTiles(providers$OpenStreetMap.Mapnik, group = "OSM") %>%
      addLayersControl(baseGroups = c("OSM")) %>%
      setView(lng = -5, lat = 55, zoom = 5) %>%
      addDrawToolbar(
        polylineOptions = FALSE,
        polygonOptions = FALSE,
        circleOptions = FALSE,
        markerOptions = FALSE,
        circleMarkerOptions = FALSE,
        singleFeature = TRUE,
        targetGroup='draw',
        editOptions = editToolbarOptions(selectedPathOptions = selectedPathOptions()))
  )

Here I’m going with the basic OpenStreetMap basemap, although you can easily change this to whatever you fancy, and indeed it is very easy to have multiple options to choose from within the app by simply adding extra tile providers here and including them in the LayersControl list. Next we set the base lat/long and zoom to center on the UK. Finally we add in a drawing tool from the leaflet.extras package. To make the next section much easier I then restrict this to just drawing a single rectangle at a time.

This next section is a little hacky, but does everything we need it to. The main thing to note is that the observeEvent function looks for new rectangles to be drawn on the basemap and then feeds this information into this code. This is then processed and the tile references are returned as outputs for our UI.

  observeEvent(input$mymap_draw_new_feature,{

    #get the coordinates of the polygon
    polygon_coordinates <- input$mymap_draw_new_feature$geometry$coordinates[[1]]
    
    #transform them to an sp Polygon
    drawn_polygon <- Polygon(do.call(rbind,lapply(polygon_coordinates,
                                                  function(x){c(x[[1]][1],
                                                                x[[2]][1])})))
    
    #use over from the sp package to identify selected tiles
    selected <- SpatialPolygons(list(Polygons(list(drawn_polygon),
                                              "drawn_polygon")))
    
    # into a bounding box 
    bounding_box <- st_bbox(selected) %>% st_as_sfc()

    # align crs systems
    st_crs(os_grid) <- st_crs(bounding_box)
    
    print(st_intersection(os_grid, bounding_box))
    
    tiles <- st_intersection(os_grid, bounding_box)
    
    top_tiles <- toString(unique(substr(tiles$TILE_NAME, start = 1, stop = 2)))
    
    med_tiles <- toString(unique(substr(tiles$TILE_NAME, start = 1, stop = 4)))
    
    all_tiles <- toString(tiles$TILE_NAME)
    
    output$top_tiles <- renderText({top_tiles})

    output$med_tiles <- renderText({med_tiles})
    
    output$all_tiles <- renderText({all_tiles})
    
  })

Putting this all together leaves us with a nice little interactive map that looks like this: