Canadian Postal Codes by Regions using #rstats with a #shiny web app

app.R

Rfuns::load_pkgs('data.table', 'leaflet', 'leaflet.extras', 'leafgl', 'shiny', 'sf')
yp <- qs::qread('./yp', nthreads = 6)
# setnames(yp, c('Place Name', 'FSA-Province'), c('PlaceName', 'FSAP'))
# qs::qsave(yp, './yp', nthreads = 6)
ypgw <- qs::qread('./ypgw', nthreads = 6)
# ypgw <- ypgw |> dplyr::rename('PlaceName' = 'Place Name', 'FSAP' = 'FSA-Province')
# qs::qsave(ypgw, './ypgw', nthreads = 6)
# yrw <- qs::qread('./yrw', nthreads = 6)
# yrws <- do.call( 'rbind', lapply( 1:nrow(yrw), \(x) yx <- yrw[x,] |> rmapshaper::ms_simplify()) )
# qs::qsave(yrws, './yrws', nthreads = 6)
yrws <- qs::qread('./yrw', nthreads = 6)
yn <- yrws |> subset(select = c(ERUID, ERNAME)) |> st_drop_geometry() |> as.data.table()
yn <- yn[order(ERNAME)]
yr.lst <- yn$ERUID
names(yr.lst) <- yn$ERNAME
# yc <- t(sapply(yrws$ERUID, \(x) yrws |> subset(ERUID == x) |> st_bbox())) |> as.data.frame()
# yc[, 'EURID'] <- rownames(yc)
# qs::qsave(yc |> as.data.table(), './yc')
yc <- qs::qread('./yc')
bbox <- st_bbox(ypgw)

ui <- fluidPage(

        tags$head(
            tags$title('Canadian Postal Codes by Region'),
            tags$style(HTML("
                    h1, h2, h3, h4 { font-weight: 400; }
                    body, label, input, button, select { 
                      font-family: 'Helvetica Neue', Helvetica;
                      font-weight: 200;
                    }
                    div.outer {
                      position: fixed;
                      top: 50px;
                      left: 0;
                      right: 0;
                      bottom: 0;
                      overflow: hidden;
                      padding: 0;
                    }
                    #controls {
                      background-color: white;
                      padding: 20px 20px 20px 20px;
                      cursor: move;
                      /* Fade out while not hovering */
                      opacity: 0.65;
                      zoom: 0.9;
                      transition: opacity 500ms 1s;
                    }
                    #controls:hover {
                      /* Fade in while hovering */
                      opacity: 0.95;
                      transition-delay: 0;
                    }
                    #outmap { height: calc(100vh - 80px) !important; }
            "))
        ),
            
        div(class = 'outer',
            leafletOutput('outmap'),
            absolutePanel(
                id = 'controls', 
                class = 'panel panel-default', 
                fixed = TRUE, draggable = TRUE, 
                top = 80, left = 16, right = 'auto', bottom = 'auto',
                width = 360, height = 'auto',
                shinyWidgets::virtualSelectInput(
                    'cbo_rgn', 'REGION:', yr.lst, character(0), search = TRUE,
                    placeholder = 'Select a Region',
                    searchPlaceholderText = 'Search...',
                    noSearchResultsText = 'No Region found!'
                )
            )
        )

)

server <- function(input, output) {

    output$outmap <- renderLeaflet({
        leaflet(options = leafletOptions(zoomControl = FALSE, minZoom = 4)) |> 
            enableTileCaching() |>
            setMaxBounds(lng1 = bbox[1], lat1 = bbox[2], lng2 = bbox[3], lat2 = bbox[4]) |> 
            addMiniMap(toggleDisplay = TRUE, width = 100, height = 100, strings = list(hideText = 'Hide Mini', showText = 'Show Mini'))|> 
            setView(-98.34903, 61.48671, zoom = 4) |>
            addTiles(options = tileOptions(useCache = TRUE, crossOrigin = TRUE)) |>
            htmlwidgets::onRender("function(el, x) { L.control.zoom({position:'topright'}).addTo(this); }")
    })
    
    observe({
        x <- input$cbo_rgn
        if(!x %in% yn$ERUID) return(NULL)
        ycx <- yc[EURID == x]
        ypgwx <- ypgw |> subset(PostalCode %in% yp[ERUID == x, PostalCode])
        leafletProxy('outmap') |>
            clearGlLayers() |>
            fitBounds(ycx$xmin, ycx$ymin, ycx$xmax, ycx$ymax) |> 
            addGlPolygons(data = yrws |> subset(ERUID == x) |> st_cast('POLYGON'), color = 'black', fillOpacity = 0, weight = 6) |> 
            addGlPoints(data = ypgwx, label = paste0(ypgwx$PostalCode, ': ', ypgwx$PlaceName))
    })
    
}

shinyApp(ui = ui, server = server)

prepare.R

lapply(c('data.table', 'sf'), require, char = TRUE)
setDTthreads(parallel::detectCores() - 2)

tmpf <- tempfile(); tmpd <- tempdir()
options(timeout = 1000)
download.file("https://www12.statcan.gc.ca/census-recensement/2021/geo/sip-pis/boundary-limites/files-fichiers/ler_000b21a_e.zip", tmpf)
unzip(tmpf, exdir = tmpd)
yr <- st_read(file.path(tmpd, grep('shp$', unzip(tmpf, list = TRUE)$Name, value = TRUE)), quiet = TRUE) |> st_make_valid()
unlink(tmpd); unlink(tmpf)
qs::qsave(yr, '~/temp/pip/yr')
yrw <- yr |> st_transform(4326)
qs::qsave(yrw, '~/temp/pip/yrw')

yp <-fread("https://raw.githubusercontent.com/ccnixon/postalcodes/master/CanadianPostalCodes.csv")
ypg <- yp |> 
        st_as_sf(coords = c('Longitude', 'Latitude'), crs = 4326) |> 
        st_make_valid() |> 
        st_transform(st_crs(yr))
qs::qsave(ypg, '~/temp/pip/ypg')
ypgw <- ypg |> st_transform(4326)
qs::qsave(ypgw, '~/temp/pip/ypgw')

t0 <- Sys.time()
y <- rbindlist(lapply(
          1:nrow(yr),
          \(x){
              yrx <- yr[x,]
              message('Processing ', yrx$ERUID)
              yx <- st_bbox(yrx |> st_transform(4236))
              ypx <- yp[Longitude %between% c(yx[1], yx[3]) & Latitude %between% c(yx[2], yx[4]), PostalCode]
              ypx <- st_filter(ypg |> subset(PostalCode %in% ypx), yrx)
              data.table( PostalCode = ypx$PostalCode, ERUID = yrx$ERUID )
          }
))
ypd <- unique(y[, .N, PostalCode][N>1, PostalCode])
y <- y[!PostalCode %in% ypd]
yp <- y[yp, on = 'PostalCode']
ypna <- yp[is.na(ERUID) & !PostalCode %in% ypd, PostalCode]
Sys.time() - t0
qs::qsave(yp, './yp')