Skip to content
Permalink
master
Switch branches/tags
Go to file
 
 
Cannot retrieve contributors at this time
# This is server base that the every client will connect to.
#
# Copyright (C) 2016 Nikolai Berkoff, Ali Abbas and Robin Lovelace
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU Affero General Public License as
# published by the Free Software Foundation, either version 3 of the
# License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU Affero General Public License for more details.
#
# You should have received a copy of the GNU Affero General Public License
# along with this program. If not, see <https://www.gnu.org/licenses/>.
# # # # #
# Setup #
# # # # #
## Functions
source("pct_shiny_funs.R", local = T)
## Packages (Only regularly used packages are loaded into the global space, the others must be installed but are used with the package prefix, e.g. DT::)
available_locally_pkgs <- c("shiny", "leaflet", "sp")
must_be_installed_pkgs <- c("rgdal", "rgeos", "shinyjs")
## Path directories to load data (expect regional data as a sibling of interface_root)
interface_root <- file.path("..", "..")
data_regional_root <- file.path(interface_root, '..', 'pct-outputs-regional-Rsmall')
outputs_regional_Rsmall_sha <- as.character(readLines(file.path(interface_root, "outputs_regional_Rsmall_sha"), warn = F))
## Check if working on server and if not initiate environment (including packages)
on_server <- grepl("shiny", Sys.info()["user"])
if (!on_server) {
source(file.path(interface_root, "scripts", "init.R"))
init_dev_env(interface_root, data_regional_root, outputs_regional_Rsmall_sha,c(available_locally_pkgs, must_be_installed_pkgs))
}
repo_sha <- as.character(readLines(file.path(interface_root, "repo_sha")))
# Check if we are on the production server (npt followed by any number of digits (only) is a prod machine)
is_prod <- grepl("npt\\d*$", Sys.info()["nodename"])
# Apply local packages, and check correct packages installed
lapply(available_locally_pkgs, library, character.only = T)
installed <- must_be_installed_pkgs %in% installed.packages()
if (length(must_be_installed_pkgs[!installed]) > 0) {
stop(paste(c(
"Missing packages:", must_be_installed_pkgs[!installed]
), collapse = " "))
}
# Save current sha, required for files to be downloaded
download_sha <- data.frame(repo_sha = repo_sha)
## Load region boundaries
regions <- rgdal::readOGR(file.path(interface_root, "regions_www/pct_regions_highres.geojson"))
regions$region_name <- as.character(regions$region_name)
## Define zone colours from colourbrewer + number of bins and breaks used
# Set minimum just below zero, otherwise zero is unassigned
zcolourscale <- "RdYlBu"
zbins_commute <- 10
zbreaks_commute = c(-0.001, 1.5, 3.5, 6.5, 9.5, 14.5, 19.5, 24.5, 29.5, 39.5,100) / 100
zbins_school <- 11
zbreaks_school = c(-0.001, 1.5, 3.5, 6.5, 9.5, 14.5, 19.5, 24.5, 29.5, 39.5, 49.5, 100) / 100
## Create a df to store LSOA legend information
# NB: CURRENTLY WRITTEN FOR COMMUTE - ULTIMATELY MAKE VARIABLE BY PURPOSE
lsoa_legend_df <- data.frame(
colours = c("#9C9C9C", "#FFFF73", "#AFFF00", "#00FFFF",
"#30B0FF", "#2E5FFF", "#0000FF", "#FF00C5"),
labels = c("1-9", "10-49", "50-99", "100-249",
"250-499", "500-999", "1000-1999", "2000+")
)
loaded_data <- list()
loaded_data_accessed <- list()
# # # # # # # #
# shinyServer #
# # # # # # # #
shinyServer(function(input, output, session) {
input_purpose <- reactive({
if(is.null(input$purpose)) {
"commute"
} else {
input$purpose
}
})
##############
# FUNCTIONS TO CUSTOMISE RIGHT HAND MENU BY PURPOSE/SCENARIO [NB changes here may need to be made to UI too!]
##############
## Define purposes and geographies available depending on region
update_purposegeog <- function(purposes_present, geographies_present) {
# Identify locally available purposes and update list accordingly
if(!is.null(input$purpose)){
local_purposes <- c(
"Commuting" = "commute" ,
"School travel" = "school" ,
"All trips" = "alltrips"
)[purposes_present]
# Remove all trips for prod branch
if (is_prod)
local_purposes <- local_purposes[local_purposes != 'alltrips']
if(input$purpose %in% local_purposes) {
selected_purpose <- input$purpose
} else {
selected_purpose <- local_purposes[1]
}
updateSelectInput(session, "purpose", choices = local_purposes, selected = selected_purpose)
}
# Identify locally available geographies
local_geographies <- c(
"Middle Super Output Area" = "msoa" ,
"Lower Super Output Area" = "lsoa"
)[geographies_present]
# Update geographies available, and set to default if the currently-selected geography does not exist
if (region$geography %in% local_geographies) {
selected_geog <- region$geography
} else {
selected_geog <- local_geographies[1]
}
updateSelectInput(session, "geography", choices = local_geographies, selected = selected_geog)
}
## Define scenarios line types and line orders available, and their labels, depending on purpose
update_labels <- function(purpose, geography) {
if (purpose == "commute") {
local_scenarios <- c(
"Census 2011 Cycling" = "olc",
"Government Target (equality)" = "govtarget",
"Government Target (near market)" = "govnearmkt",
"Gender equality" = "gendereq",
"Go Dutch" = "dutch",
"Ebikes" = "ebike"
)
local_line_types <- c("None" = "none",
"Straight Lines" = "straight_lines",
"Fast Routes" = "routes_fast",
"Fast & Quieter Routes" = "routes",
"Route Network (LSOA, clickable)" = "route_network",
"Route Network (LSOA, image)" = "lsoa_base_map"
)
local_line_order <- c(
"Number of cyclists" = "slc",
"Increase in cyclists" = "sic",
"Health economic gain (YLLs + sick leave)" = "sivaluecomb",
"Reduction in CO2/car distance" = "sico2"
)
} else if (purpose == "school") {
local_scenarios <- c(
"School Census 2011" = "olc",
"Government Target (equality)" = "govtarget",
"Go Cambridge" = "cambridge",
"Go Dutch" = "dutch"
)
local_line_types <- c("None" = "none",
"Route Network (LSOA, clickable)" = "route_network",
"Route Network (LSOA, image)" = "route_network_tile"
)
local_line_order <- c(
"Number of cycle trips" = "slc",
"Increase in cyclists" = "sic"
)
} else if (purpose == "alltrips") {
local_scenarios <- c(
"Current travel patterns" = "olc",
"Government Target (equality)" = "govtarget",
"Gender equality" = "gendereq",
"Go Dutch" = "dutch",
"Ebikes" = "ebike"
)
local_line_types <- c("None" = "none",
"Straight Lines" = "straight_lines",
"Fast Routes" = "routes_fast",
"Fast & Quieter Routes" = "routes",
"Route Network (MSOA)" = "route_network"
)
local_line_order <- c(
"Number of cycle trips" = "slc",
"Increase in cycling" = "sic",
"Health economic gain (YLLs + sick leave)" = "sivaluecomb",
"Reduction in CO2/car distance" = "sico2"
)
}
# Update line options available, and set to default if the currently-selected option does not exist
if (input$scenario %in% local_scenarios) {
updateSelectInput(session, "scenario", choices = local_scenarios, selected = input$scenario)
} else {
updateSelectInput(session, "scenario", choices = local_scenarios)
}
if (input$line_type %in% local_line_types) {
updateSelectInput(session, "line_type", choices = local_line_types, selected = input$line_type)
} else {
updateSelectInput(session, "line_type", choices = local_line_types)
}
if (input$line_order %in% local_line_order) {
updateSelectInput(session, "line_order", choices = local_line_order, selected = input$line_order)
} else {
updateSelectInput(session, "line_order", choices = local_line_order)
}
}
##############
# Initialise region, and update right hand menu by region/purpose
##############
## Create region and (for persistent geographical values) helper
region <- reactiveValues(current = NA, data_dir = NA, geography = NA, repopulate_region = F, purposes_present = NA, plot = NULL, line_data_dir = "", ldata = NULL)
helper <- NULL
helper$e_lat_lng <- ""
helper$old_geog <- ""
helper$old_purpose <- ""
load_data <- function(base_path, filename, purpose, str_lines = NULL){
filepath <- file.path(base_path, filename)
# Rm objects (by time last accessed) if the list size is more than 2 Gb
if (format(object.size(loaded_data), units = "Gb") > 2) {
idx_to_rm <- which(loaded_data_accessed == min(unlist(loaded_data_accessed)))
if (interactive()){
print(c("removing", names(loaded_data)[[idx_to_rm]], format(object.size(loaded_data), units = "Gb")))
}
loaded_data[[idx_to_rm]] <<- NULL
loaded_data_accessed[[idx_to_rm]] <<- NULL
}
if (file.exists(filepath)) {
loaded_data_accessed[[filepath]] <<- Sys.time()
if (is.null(loaded_data[[filepath]])) {
rds <- readRDS(filepath)
if(filename == "rnet.Rds") {
if(!is.null(rds)){
rds$id <- rds$local_id
}
}
if(filename == "rq.Rds"){
# Merge in scenario data for quiet routes - don't want this in download but need for line sorting
rds@data <- cbind(
rds@data[!(names(rds) %in% names(str_lines))],
str_lines@data)
# Add is_quiet column to identify quieter, as opposed to faster, data - used in routes pop-up
rds@data$is_quiet <- T
}
loaded_data[[filepath]] <<- rds
} else {
loaded_data[[filepath]]
}
} else {
NULL
}
}
## Set values of region
observe({
shinyjs::showElement(id = "loading")
if (interactive()){
start_time <- Sys.time()
}
if(is.null(input$geography)){
shinyjs::hideElement(id = "loading")
return()
}
# Identify region from URL or use a default
if (is.na(region$current)) {
query <- parseQueryString(session$clientData$url_search)
region$current <- if (isTRUE(query[['r']] %in% regions$region_name)) {
query[['r']]
} else {
"isle-of-wight"
}
}
# Notify browser to update URL to reflect new region
session$sendCustomMessage("regionchange", region$current)
# Define region geography, forcing a default in cases where the geography is not available
switch(input_purpose(),
"commute"= {
if (input$geography %in% c("msoa", "lsoa")) {
region_geo_change_to <- input$geography
} else {
region_geo_change_to <- "msoa"
}
},
"school"= { region_geo_change_to <- "lsoa" },
"alltrips"= { region_geo_change_to <- "msoa" }
)
# Only trigger geography changes if required.
if (!identical(region_geo_change_to, region$geography)) {
region$geography <- region_geo_change_to
}
# Set data_dir
new_data_dir <- file.path(data_regional_root, input_purpose(), region$geography, region$current)
if(!identical(region$data_dir, new_data_dir)) {
region$data_dir <- file.path(data_regional_root, input_purpose(), region$geography, region$current)
}
# Identify that region repopulation has happened
region$repopulate_region <- T
# Identify purposes and geographies available in region
purposes_list <- c("commute", "school", "alltrips")
new_purpose <- (dir.exists(file.path(data_regional_root, purposes_list, "msoa", region$current)) | dir.exists(file.path(data_regional_root, purposes_list, "lsoa", region$current)))
# Set alltrips to FALSE for the production branch, even if the data directory exists
if (is_prod)
new_purpose[which(purposes_list %in% "alltrips")] <- FALSE
if(!identical(new_purpose,region$purposes_present)){
region$purposes_present <- new_purpose
}
geographies_list <- c("msoa", "lsoa")
region$geographies_present <- dir.exists(file.path(data_regional_root, input_purpose(), geographies_list, region$current))
# Identify the centre of the current region, save in region$plot
isolate({
region$plot$center_dim <- rgeos::gCentroid(regions[regions$region_name == region$current, ], byid = TRUE)@coords
# Load data to region$plot (if data exists - this varies by purpose/geography)
region$plot$zones <- load_data(region$data_dir, "z.Rds", input_purpose())
region$plot$centroids <- load_data(region$data_dir, "c.Rds", input_purpose())
region$plot$destinations <- load_data(region$data_dir, "d.Rds", input_purpose())
# Use LSOA's route network even when MSOA as geography is selected
if (region$geography == "msoa"){
# Create a local directory path, with fixed LSOA as geography
local_dir_path <- file.path(data_regional_root, input_purpose(), "lsoa", region$current)
# Read LSOA's route network
region$plot$route_network <- load_data(local_dir_path, "rnet.Rds", input_purpose())
}
else
region$plot$route_network <- load_data(region$data_dir, "rnet.Rds", input_purpose())
# For confidentiality we have replaced exact numbers with NAs but they cause havoc with the interface.
# This replaces the NAs with the mean values.
if (input_purpose() == "school") {
columns_na <- c("all", "bicycle", "car")
z_na_const <- 1.5
d_na_const <- 3
rnet_na_const <- 1.5
idx <- is.na(region$plot$zones@data[,columns_na])
region$plot$zones@data[,columns_na][idx] <- z_na_const
idx <- is.na(region$plot$zones@data[,school_na("govtarget")$na])
region$plot$zones@data[,school_na("govtarget")$na][idx] <- z_na_const +
region$plot$zones@data[,school_na("govtarget")$base][idx]
idx <- is.na(region$plot$zones@data[,school_na("cambridge")$na])
region$plot$zones@data[,school_na("cambridge")$na][idx] <- z_na_const +
region$plot$zones@data[,school_na("cambridge")$base][idx]
idx <- is.na(region$plot$zones@data[,school_na("dutch")$na])
region$plot$zones@data[,school_na("dutch")$na][idx] <- z_na_const +
region$plot$zones@data[,school_na("dutch")$base][idx]
idx <- is.na(region$plot$destinations@data[,columns_na])
region$plot$destinations@data[,columns_na][idx] <- d_na_const
idx <- is.na(region$plot$destinations@data[,school_na("govtarget")$na])
region$plot$destinations@data[,school_na("govtarget")$na][idx] <- d_na_const +
region$plot$destinations@data[,school_na("govtarget")$base][idx]
idx <- is.na(region$plot$destinations@data[,school_na("cambridge")$na])
region$plot$destinations@data[,school_na("cambridge")$na][idx] <- d_na_const +
region$plot$destinations@data[,school_na("cambridge")$base][idx]
idx <- is.na(region$plot$destinations@data[,school_na("dutch")$na])
region$plot$destinations@data[,school_na("dutch")$na][idx] <- d_na_const +
region$plot$destinations@data[,school_na("dutch")$base][idx]
region$plot$route_network@data[is.na(region$plot$route_network@data)] <- rnet_na_const
}
})
shinyjs::hideElement(id = "loading")
if (interactive()){
print(
paste(
"Loading region",
region$current,
"for",
input$geography,
input_purpose(),
"took",
round(difftime(Sys.time(), start_time, "s"), 3),
"s"
)
)
}
}, priority = 3)
# Only requred to run if the region changes (as that affects purpose) or the purpose changes (as that affects geographies)
observe({
shinyjs::showElement(id = "loading")
region$current
input_purpose()
isolate({
update_purposegeog(region$purposes_present, region$geographies_present)
})
shinyjs::hideElement(id = "loading")
}, priority = 2)
## Update labels according to purpose
# NB don't have as part of above 'observes' otherwise those re-run when scenario changes, even though data all the same
observe({
shinyjs::showElement(id = "loading")
# massive hack to return early if the geography and purpose haven't actually changed
if (helper$old_geog == region$geography && helper$old_purpose == input_purpose()) {
shinyjs::hideElement(id = "loading")
return()
}
helper$old_purpose <<- input_purpose()
helper$old_geog <<- region$geography
update_labels(input_purpose(), region$geography)
shinyjs::hideElement(id = "loading")
}, priority = 1)
##############
# Define BB
##############
## Returns the map bounding box [default lat/long PCT projection]
map_bb <- reactive({
if (is.null(input$map_bounds)) {
return (NULL)
}
lat <- c(input$map_bounds$west, input$map_bounds$east, input$map_bounds$east, input$map_bounds$west)
lng <- c(input$map_bounds$north, input$map_bounds$north, input$map_bounds$south, input$map_bounds$south)
c1 <- cbind(lat, lng)
r1 <- rbind(c1, c1[1,])
bounds <- SpatialPolygons(list(Polygons(list(Polygon(r1)), 'bb')),
proj4string = CRS("+init=epsg:4326 +proj=longlat"))
proj4string(bounds) = CRS("+init=epsg:4326 +proj=longlat")
bounds
})
## Updates the bounding box (bb) to the current map bb unless the map is frozen (freeze lines on)
flows_bb <- reactive({
if (!input$freeze || is.null(helper$bb)) {
helper$bb <<- map_bb()
}
helper$bb
})
##############
# Select, sort and plot lines
##############
## Identify suffix + complete name of lines variables
line_attr <- reactive({
if (input$scenario == 'olc')
'olc'
else if (input$line_type != 'route_network')
input$line_order
else
'slc'
})
line_data <- reactive({
data_filter(input$scenario, line_attr())
})
## Define when not to give option to sort by lines [NB also hard-written into ui ]
show_no_lines <- c("none", "lsoa_base_map", "route_network_tile")
## Select and sort lines within flows_bb bounding box
sort_lines <- function(lines, line_type, nos) {
if (line_type %in% show_no_lines)
return(NULL)
if (!line_data() %in% names(lines))
return(NULL)
# If other than route network lines are selected, subset them by the bounding box
if (line_type != "route_network") {
poly <- flows_bb()
if (is.null(poly))
return(NULL)
poly <- spTransform(poly, CRS(proj4string(lines)))
keep <- rgeos::gIntersects(poly, lines, byid = TRUE)
if (all(!keep))
return(NULL)
lines_in_bb <- lines[drop(keep),]
# Sort low-to-high for reduction in YLLs (can't use absolute values as no. YLLs can be a positive number, i.e. health disbenefit)
if (grepl(c("siyll"), line_data())) {
lines_in_bb[tail(order(lines_in_bb[[line_data()]], decreasing = T), nos),]
} else {
# sort by absolute values for remainder of things, which all have zero as higher or lower limit
lines_in_bb[tail(order(abs(lines_in_bb[[line_data()]])), nos),]
}
} else {
# For the route network, just sort them according to the percentage of display
# Sort by the absolute values
nos <- nos / 100 * nrow(lines)
lines[tail(order(abs(lines[[line_data()]])), nos),]
}
}
## Adds polylines on the map, depending on types and number of lines
plot_lines <- function(m, sorted_l, line_type) {
if (is.null(sorted_l))
return()
if (line_type == "route_network") {
min <- 1
max <- 20
} else {
min <- 5
max <- 12
}
line_opacity <- 0.8
popup_fun_name <- paste0("popup_", line_type)
if (line_type == 'routes_quieter' || line_type == 'routes_fast') {
popup_fun_name <- "popup_routes"
line_opacity <- 0.5
}
popop_fun <- get(popup_fun_name)
addPolylines(
m,
data = sorted_l,
color = get_line_colour(line_type),
# Plot widths proportional to attribute value, removing NAs
weight = normalise(sorted_l[[line_data()]][!is.na(sorted_l[[line_data()]])], min = min, max = max),
opacity = line_opacity,
group = line_type,
popup = popop_fun(sorted_l, input$scenario, input_purpose()),
layerId = paste0(sorted_l[['id']], '-', line_type)
)
}
observe({
if (region$line_data_dir != region$data_dir && (input$line_type %in% c("straight_lines", "routes_fast", "routes")) ){
region$line_data_dir <- region$data_dir
region$plot$straight_lines <- load_data(region$data_dir, "l.Rds", input_purpose())
region$plot$routes_fast <- load_data(region$data_dir, "rf.Rds", input_purpose())
region$plot$routes_quieter <- load_data(region$data_dir, "rq.Rds", input_purpose(), region$plot$straight_lines)
return()
if (interactive()){
loading_finish_time <- Sys.time()
}
}
}, priority = 10)
## Plot if lines change
observe({
if (interactive()){
start_time <- Sys.time()
}
region$data_dir
input$nos_lines
input$line_type
input$scenario
input$line_order
# If we are showing lines and the input is not frozen then we want to trigger this observe
# when the map bounds change
if (!isTruthy(input$line_type %in% show_no_lines) && !isTRUE(input$freeze)){
input$map_bounds
}
isolate({
shinyjs::showElement(id = "loading")
line_type <- ifelse(input$line_type == 'routes', "routes_quieter", input$line_type)
local_lines <- sort_lines(region$plot[[line_type]], input$line_type, input$nos_lines)
# Filter out zero lines for scenario in question from route network
if (input$line_type == "route_network") {
if (input$scenario == 'olc') {
local_lines <- local_lines[local_lines$bicycle>0,]
} else if (input$scenario == 'govtarget') {
local_lines <- local_lines[local_lines$govtarget_slc>0,]
} else if (input$scenario == 'govnearmkt') {
local_lines <- local_lines[local_lines$govnearmkt_slc>0,]
} else if (input$scenario == 'gendereq') {
local_lines <- local_lines[local_lines$gendereq_slc>0,]
} else if (input$scenario == 'cambridge') {
local_lines <- local_lines[local_lines$cambridge_slc>0,]
} else {
local_lines <- local_lines[local_lines$dutch_slc>0,] # always >0 for both
}
}
if (is.null(region$ldata) || (!is.null(region$ldata) && (!identical(region$ldata, local_lines) || !identical(region$plot$scenario, input$scenario)))) {
leafletProxy("map") %>% clearGroup(.,
c("straight_lines",
"routes_quieter",
"routes_fast",
"route_network"
)) %>%
removeShape(., "highlighted")
region$ldata <- local_lines
# Include current scenario in region$plot as the set of lines to plot may not change when the scenario alters, and so otherwise don't update
region$plot$scenario <- input$scenario
plot_lines(leafletProxy("map"), region$ldata, line_type)
# Additionally plot fast routes on top of quieter if selected 'fast & quieter'
if (input$line_type == 'routes') {
plot_lines(leafletProxy("map"), sort_lines(region$plot$routes_fast, "routes_fast", input$nos_lines),"routes_fast")
}
}
if (input$line_type == 'route_network') {
updateSliderInput(
session,
inputId = "nos_lines",
min = 10,
max = 90,
step = 20,
label = "Percent (%) of Network"
)
} else {
if (input$line_order == "slc")
updateSliderInput(
session,
inputId = "nos_lines",
min = 1,
max = 200,
step = 1,
label = "Top N Lines (most cycled)"
)
else
updateSliderInput(
session,
inputId = "nos_lines",
min = 1,
max = 200,
step = 1,
label = "Top N Lines"
)
}
})
shinyjs::hideElement(id = "loading")
if (interactive()){
print(
paste(
"Plotting top",
input$nos_lines,
input$line_type,
"took",
round(difftime(Sys.time(), start_time, "s"), 3),
"s"
)
)
}
}, priority = - 10)
##############
# Plot zones and centroids
##############
## Set transparency of zones to 0.5 when displayed, otherwise 0
transp_rate <- reactive({
if (input$show_zones)
0.5
else
0.0
})
## Identify suffix + complete name of zones variables
zone_attr <- reactive({
if (input$scenario == 'olc')
'olc'
else
'slc'
})
zone_data <- reactive({
data_filter(input$scenario, zone_attr())
})
## Display zones
observe({
line_type <- isolate(input$line_type)
region$repopulate_region
clearGroup(leafletProxy("map"), c("zones"))
## Display zones
if (input$show_zones && !is.null(region$plot$zones)) {
# Define bins and breaks (by purpose)
if (input_purpose() == "school") {
zbins <- zbins_school
zbreaks <- zbreaks_school
} else {
zbins <- zbins_commute
zbreaks <- zbreaks_commute
}
# Show zones when no lines are selected
show_zone_popup <- (line_type %in% show_no_lines)
popup <-
if (show_zone_popup){
popup_zones(region$plot$zones, input$scenario, input_purpose())
}
addPolygons(
leafletProxy("map"),
data = region$plot$zones,
weight = 2,
fillOpacity = transp_rate(),
opacity = 0.2,
fillColor = get_colour_ramp(zcolourscale, zbins, (region$plot$zones[[zone_data()]] /region$plot$zones$all), zbreaks),
color = "black",
group = "zones",
popup = popup,
options = pathOptions(clickable = show_zone_popup),
layerId = paste0(region$plot$zones[['geo_code']], '-', "zones")
)
}
## Hide and then re-Show line layers, so that they are displayed as the top layer in the map.
# NB Leaflet's function bringToBack() or bringToFront() (see https://leafletjs.com/reference.html#path) don't seem to exist for R
leafletProxy("map") %>% {
if(!line_type %in% show_no_lines) {
switch(line_type,
'routes'= {
hideGroup(., c("routes_quieter", "routes_fast") ) %>% showGroup(., c("routes_quieter", "routes_fast"))
},
hideGroup(., line_type) %>% showGroup(., line_type)
)
}
}
})
## Define centroids
observe({
input$line_type
input$map_zoom
clearGroup(leafletProxy("map"), c("centroids"))
# Define centroids (if exist) and display when zoom level is greater or equal to 11 and lines are selected
if (!is.null(region$plot$centroids)) {
addCircleMarkers(leafletProxy("map"), data = region$plot$centroids,
radius = normalise(region$plot$centroids$all, min = 1, max = 8),
color = get_line_colour("centroids"), group = "centroids", opacity = 0.5,
popup = popup_centroids(region$plot$centroids, input$scenario, input_purpose()),
layerId = paste0(region$plot$centroids[['geo_code']], '-', "centroids")
)
if (isTRUE((is.null(input$map_zoom)) || input$map_zoom < 11 || (input$line_type %in% show_no_lines) || (input$line_type=="route_network"))) {
hideGroup(leafletProxy("map"), "centroids")
} else {
showGroup(leafletProxy("map"), "centroids")
}
}
})
## Define destinations
observe({
input$line_type
input$map_zoom
clearGroup(leafletProxy("map"), c("destinations"))
# Define destinations (if exist) and display when zoom level is greater or equal to 11 and lines are selected
if (!is.null(region$plot$destinations)) {
addCircleMarkers(leafletProxy("map"), data = region$plot$destinations,
radius = normalise(region$plot$destinations$all, min = 1, max = 8),
color = get_line_colour("destinations"), group = "destinations", opacity = 0.5,
popup = popup_destinations(region$plot$destinations, input$scenario, input_purpose()),
layerId = paste0(region$plot$destinations[['urn']], '-', "destinations")
)
if (isTRUE((is.null(input$map_zoom)) || input$map_zoom < 11 )) {
hideGroup(leafletProxy("map"), "destinations")
} else {
showGroup(leafletProxy("map"), "destinations")
}
}
})
##############
# Highlighting - both for regions and for lines
##############
## Creating and highlighting alternative regions (only if have the purpose in question)
observe({
input$map_base
region$repopulate_region
# Remove old region's polygons
leafletProxy("map") %>% clearGroup(., "regions-zones")
# Identify regions that 1) have the input purpose data and 2) are not the current region
new_regions_with_purpose <- regions$region_name[(dir.exists(file.path(data_regional_root, input_purpose(), region$geography, regions$region_name))) & (!regions$region_name %in% region$current)]
# Add all eligible regions boundaries in the beginning , but set the opacity to a minimum
addPolygons(
leafletProxy("map"),
data = regions[(regions$region_name %in% new_regions_with_purpose), ],
weight = 0.1,
color = "#000000",
fillColor = "aliceblue",
fillOpacity = 0.01,
opacity = 0.3,
label = paste(
"Click to view",
get_pretty_region_name(regions[regions$region_name %in% new_regions_with_purpose, ]$region_name)
),
labelOptions = labelOptions(direction = 'auto'),
# On highlight widen the boundary and fill the polygons
highlightOptions = highlightOptions(
color = 'grey',
opacity = 0.3,
weight = 10,
fillOpacity = 0.6,
bringToFront = F,
sendToBack = TRUE
),
options = pathOptions(clickable = T),
layerId = paste("new_region", regions[regions$region_name %in% new_regions_with_purpose, ]$region_name),
group = "regions-zones"
)
})
## Switching to highlighted regions + highlighting pop-ups
observeEvent(input$map_shape_click, {
# For switching to the clicked region
event <- input$map_shape_click
if (is.null(event) || event$id == "highlighted")
return()
# Check if the event$id is called from the "new_region" polygons
if (grepl("new_region", event$id)) {
# Split the id to identify the region name
new_region <- strsplit(event$id, " ")[[1]][2]
if (is.null(new_region))
return()
new_data_dir <- file.path(data_regional_root, input_purpose(), region$geography, new_region)
if (region$data_dir != new_data_dir &&
file.exists(new_data_dir)) {
region$current <- new_region
region$data_dir <- new_data_dir
region$repopulate_region <- F
if (input$freeze)
# If we change the map data then lines should not be frozen to the old map data
updateCheckboxInput(session, "freeze", value = F)
}
return()
}
e_lat_lng <- paste0(event$lat, event$lng)
# Fix bug when a line has been clicked then the click event is re-emmited when the map is moved
if (e_lat_lng == helper$e_lat_lng)
return()
helper$e_lat_lng <<- e_lat_lng
# Highlighting for the pop-ups
isolate({
id_line_type <- unlist(strsplit(event$id, "-"))
id <- id_line_type[1]
line_type <- id_line_type[2]
if (event$group == "centroids") {
addPolygons(
leafletProxy("map"),
data = region$plot$centroids[region$plot$c$geo_code == id, ],
fill = F,
color = get_line_colour("centroids") ,
opacity = 0.7,
layerId = "highlighted"
)
} else if (event$group == "zones") {
addPolygons(
leafletProxy("map"),
data = region$plot$zones[region$plot$z$geo_code == id, ],
fill = FALSE,
color = "black",
opacity = 0.7 ,
layerId = "highlighted"
)
} else {
line <- region$plot[[line_type]][region$plot[[line_type]]$id == id, ]
if (!is.null(line))
addPolylines(
leafletProxy("map"),
data = line,
color = "white",
opacity = 0.4,
layerId = "highlighted"
)
}
})
})
##############
# Rasters + basemaps
##############
## LSOA layer + legend
## NB in future need to make this purpose + geography specific
observe({
shinyjs::showElement(id = "loading")
if (input$line_type %in% c("lsoa_base_map", "route_network_tile")) {
urlTemplate <- paste("https://npttile.vs.mythic-beasts.com", input_purpose(), "v2", input$scenario,"{z}/{x}/{y}.png", sep= "/")
leafletProxy("map") %>%
addTiles(
.,
urlTemplate = urlTemplate,
layerId = "lsoa_base_map",
group = "lsoa_base_map",
options = tileOptions(
maxNativeZoom = 15,
reuseTiles = T,
tms = T
)
) %>%
addLegend(
"topleft",
layerId = "lsoa_leg",
colors = lsoa_legend_df$colours,
labels = lsoa_legend_df$labels,
title = "Cyclists on route network",
opacity = 0.5
)
} else {
leafletProxy("map") %>% removeTiles(., layerId = "lsoa_base_map") %>% removeControl("lsoa_leg")
}
shinyjs::hideElement(id = "loading")
})
## Updates map tile according to the selected map base
map_tile <- reactive({
switch(
input$map_base,
'roadmap' = list(url = "https://cartodb-basemaps-{s}.global.ssl.fastly.net/light_all/{z}/{x}/{y}.png", zoom = 18),
'satellite' = list(url = "https://server.arcgisonline.com/ArcGIS/rest/services/World_Imagery/MapServer/tile/{z}/{y}/{x}", zoom = 18),
'IMD' = list(url = "https://cdrc-maps.liv.ac.uk/tiles/imd2015_eng/{z}/{x}/{y}.png", zoom = 14),
'opencyclemap' = list(url = "https://{s}.tile.thunderforest.com/cycle/{z}/{x}/{y}.png?apikey=feae177da543411c9efa64160305212d", zoom = 18),
'hilliness' = list(url = "https://server.arcgisonline.com/ArcGIS/rest/services/World_Shaded_Relief/MapServer/tile/{z}/{y}/{x}", zoom = 13)
)
})
##############
# Map attribute outputs
##############
## Initialize the leaflet map
output$map <- renderLeaflet(
isolate(
leaflet() %>%
setView(.,
lng = region$plot$center_dim[1, 1],
lat = region$plot$center_dim[1, 2],
zoom = 10
) %>%
mapOptions(zoomToLimits = "never")
)
)
## Attribution statement bottom right + define the map base
observe({
shinyjs::showElement(id = "loading")
region$current
tileOpts <- tileOptions(
opacity = 1,
minZoom = 7,
reuseTiles = T,
maxZoom = 18,
maxNativeZoom = map_tile()$zoom
)
leafletProxy("map") %>% addTiles(
.,
urlTemplate = map_tile()$url,
layerId = "background",
attribution = '<a target="_blank" href="http://shiny.rstudio.com/">Shiny</a> |
Routing <a target="_blank" href ="https://www.cyclestreets.net">CycleStreets</a> |
Map &copy <a target="_blank" href ="https://www.openstreetmap.org/copyright">OpenStreetMap</a> contributors',
options = tileOpts
) %>%
clearGroup(., "imd_extras")
if (input$map_base == 'IMD') {
leafletProxy("map") %>%
addTiles(.,
urlTemplate = "https://cdrc-maps.liv.ac.uk/tiles/imd2014_wal/{z}/{x}/{y}.png",
group = "imd_extras",
options = tileOpts) %>%
addTiles(.,
urlTemplate = "https://cdrc-maps.liv.ac.uk/tiles/shine_urbanmask_dark/{z}/{x}/{y}.png",
group = "imd_extras",
options = tileOpts) %>%
addTiles(.,
urlTemplate = "https://cdrc-maps.liv.ac.uk/tiles/shine_labels_cdrc/{z}/{x}/{y}.png",
group = "imd_extras",
options = tileOpts)
}
leafletProxy("map") %>% hideGroup(., "lsoa_base_map") %>% showGroup(., "lsoa_base_map")
shinyjs::hideElement(id = "loading")
})
## Map version info - text in bottom left
output$cite_html <- renderUI({
HTML(paste('Version', a(repo_sha, href = paste0("https://github.com/npct/pct-shiny/tree/", repo_sha), target = '_blank'),
'released under a', a('GNU Affero GPL', href = "../www/licence.html", target = '_blank'), 'and funded by the',
a('DfT', href = "https://www.gov.uk/government/organisations/department-for-transport", target = "_blank")
))
})
## Adds map legend for zones
observe({
input_purpose()
# Define the legend title
switch(input_purpose(),
"commute" = { legend_title <- "% cycling to work"},
"school" = { legend_title <- "% cycling to school" },
"alltrips" = { legend_title <- "% trips cycled" }
)
leafletProxy("map") %>% removeControl(layerId = "zone_leg")
if (input_purpose() == "school") {
if (input$show_zones) {
leafletProxy("map") %>%
addLegend(
"topleft",
layerId = "zone_leg",
colors = get_colour_palette(zcolourscale, 11),
labels = c("0-1%", "2-3%", "4-6%", "7-9%",
"10-14%", "15-19%", "20-24%",
"25-29%", "30-39%", "40-49%", "50%+"),
title = legend_title,
opacity = 0.5
)
}
} else {
if (input$show_zones) {
leafletProxy("map") %>%
addLegend(
"topleft",
layerId = "zone_leg",
colors = get_colour_palette(zcolourscale, 10),
labels = c("0-1%", "2-3%", "4-6%", "7-9%",
"10-14%", "15-19%", "20-24%",
"25-29%", "30-39%", "40%+"),
title = legend_title,
opacity = 0.5
)
}
}
})
## Creates legend as a barplot for IMD map base
output$imd_legend <- renderPlot({
my_lab <- c(
"Most deprived tenth", "2nd", "3rd", "4th", "5th",
"6th", "7th", "8th", "9th", "Least deprived tenth"
)
my_lab <- rev(my_lab)
my_colors <-
c(
"#a50026", "#d73027", "#f46d43", "#fdae61", "#fee08b",
"#d9ef8b", "#a6d96a", "#66bd63", "#1a9850", "#006837"
)
my_colors <- rev(my_colors)
# Set the labelling of Y-axis to bold
par(font.lab = 2, mar = c(0.0, 5.8, 0.0, 1.0))
bp <- barplot(
rep(1, 10),
beside = TRUE,
col = my_colors,
ylab = "Index of Multiple \n Deprivation",
horiz = T,
axes = F
)
text(
0,
bp,
my_lab,
cex = 0.8,
pos = 4,
font = 2,
col = "black"
)
})
## Hide/show panels on user-demand
shinyjs::onclick("toggle_panel", shinyjs::toggle(id = "input_panel", anim = FALSE))
shinyjs::onclick("toggle_imd_legend", shinyjs::toggle(id = "imd_legend", anim = FALSE))
## Function to add a layers control for the routes, so that users can easily select quiet routes
# NB: currently this resets every time scenario changes or lines get redrawn because of map zoom - possibly to revisit
observe({
input$line_type
if (input$line_type == 'routes') {
leafletProxy("map") %>% addLayersControl(
position = c("bottomright"),
overlayGroups = c("routes_fast", "routes_quieter"),
options = layersControlOptions(collapsed = T)
)
} else if (input$line_type != 'routes') {
leafletProxy("map") %>% showGroup(c("routes_fast", "routes_quieter")) %>% removeLayersControl()
}
})
## Read region_stats.html, if it exists, for the loaded region
output$region_stats <- renderUI({
input_purpose()
input$geography
region$current
region_stats_file <-
file.path("../tabs/region_stats", input_purpose(), input$geography, region$current,
"region_stats.html")
if (file.exists(region_stats_file))
includeHTML(region_stats_file)
else
HTML("<strong>No statistics available</strong>")
})
## Read regional data download files
# This file updates whenever there is a change to input$region
output$download_region_current <- renderUI({
input_purpose()
html <- includeHTML(file.path("..", "..", "non_www", "tabs", input_purpose(), "download_region.html"))
html <- gsub("<!--region_name-->", get_pretty_region_name(region$current), html)
gsub("<!--region_url-->", region$current, html)
})
## Create the national data download files
output$download_national_current <- renderUI({
input_purpose()
includeHTML(file.path("..", "..", "non_www", "tabs", input_purpose(), "download_national.html"))
})
})