add_loca_name <- function(dt, geo, coords = FALSE){ yn <- names(dt) cols <- c('type', 'location_id', 'name') if(coords) cols <- c(cols, 'x_lon', 'y_lat') y <- read_fst(file.path(geouk_path, 'locations'), columns = cols, as.data.table = TRUE) y <- y[type == geo][, type := NULL] cols <- c('id', geo) if(coords) cols <- c(cols, paste0(geo, c('x', 'y'))) setnames(y, cols) dt <- y[dt, on = c(id = geo)][, id := NULL] setcolorder(dt, yn) dt } # List of palettes to be used with ColourBrewer package: palette.lst <- list( 'SEQUENTIAL' = c( # ordinal data where (usually) low is less important and high is more important 'Blues' = 'Blues', 'Blue-Green' = 'BuGn', 'Blue-Purple' = 'BuPu', 'Green-Blue' = 'GnBu', 'Greens' = 'Greens', 'Greys' = 'Greys', 'Oranges' = 'Oranges', 'Orange-Red' = 'OrRd', 'Purple-Blue' = 'PuBu', 'Purple-Blue-Green' = 'PuBuGn', 'Purple-Red' = 'PuRd', 'Purples' = 'Purples', 'Red-Purple' = 'RdPu', 'Reds' = 'Reds', 'Yellow-Green' = 'YlGn', 'Yellow-Green-Blue' = 'YlGnBu', 'Yellow-Orange-Brown' = 'YlOrBr', 'Yellow-Orange-Red' = 'YlOrRd' ), 'DIVERGING' = c( # ordinal data where both low and high are important (i.e. deviation from some reference "average" point) 'Brown-Blue-Green' = 'BrBG', 'Pink-Blue-Green' = 'PiYG', 'Purple-Red-Green' = 'PRGn', 'Orange-Purple' = 'PuOr', 'Red-Blue' = 'RdBu', 'Red-Grey' = 'RdGy', 'Red-Yellow-Blue' = 'RdYlBu', 'Red-Yellow-Green' = 'RdYlGn', 'Spectral' = 'Spectral' ), 'QUALITATIVE' = c( # categorical/nominal data where there is no logical order 'Accent' = 'Accent', 'Dark2' = 'Dark2', 'Paired' = 'Paired', 'Pastel1' = 'Pastel1', 'Pastel2' = 'Pastel2', 'Set1' = 'Set1', 'Set2' = 'Set2', 'Set3' = 'Set3' ) ) tiles.lst <- c( 'OSM Mapnik' = 'OpenStreetMap.Mapnik', 'OSM B&W' = 'OpenStreetMap.BlackAndWhite', 'Stamen Toner' = 'Stamen.Toner', 'Stamen Toner Lite' = 'Stamen.TonerLite', 'Wikimedia' = 'Wikimedia', 'Hydda Full' = 'Hydda.Full', 'Hydda Base' = 'Hydda.Base' ) marker_colours <- c( 'red', 'darkred', 'orange', 'pink', 'beige', 'green', 'darkgreen', 'lightgreen', 'blue', 'lightblue', 'purple', 'cadetblue', 'white', 'lightgray', 'gray', 'black' ) markers <- iconList( red = makeIcon(file.path(pub_path, 'images', 'icons', 'leaflet', 'markers', 'sm-orange.png'), iconWidth = 24, iconHeight =32), blue = makeIcon(file.path(pub_path, 'images', 'icons', 'leaflet', 'markers', 'sm-lightblue.png'), iconWidth = 24, iconHeight =32) ) mp <- leaflet(options = leafletOptions(minZoom = 6)) %>% setView(lat = 54.003419, lng = -2.547973, zoom = 6) %>% enableTileCaching() %>% addTiles(options = tileOptions(useCache = TRUE, crossOrigin = TRUE)) %>% addSearchOSM() %>% addResetMapButton() %>% addFullscreenControl() for(idx in 1:length(tiles.lst)) mp <- mp %>% addProviderTiles(providers[[tiles.lst[idx]]], group = names(tiles.lst)[idx]) # list of options for charts point.shapes <- c('circle' = 21, 'square' = 22, 'diamond' = 23, 'triangle up' = 24, 'triangle down' = 25) line.types <- c('dashed', 'dotted', 'solid', 'dotdash', 'longdash', 'twodash') face.types <- c('plain', 'bold', 'italic', 'bold.italic') val.lbl.pos <- list( 'Inside' = list('Vertical' = c(0.5, 1.5), 'Horizontal' = c( 1.2, 0.2) ), 'Outside' = list('Vertical' = c(0.4, -0.3), 'Horizontal' = c(-0.2, 0.2) ) ) lbl.format <- function(y, type, is.pct = FALSE){ if(type == 1){ format(y, big.mark = ',', nsmall = 0) } else if(type == 2){ if(is.pct){ paste0(format(round(100 * y, 2), nsmall = 2), '%') } else { format(y, big.mark = ',', nsmall = 0) } } else { format(y, nsmall = 2) } } class.methods <- c( # 'Fixed' = 'fixed', # need an additional argument fixedBreaks that lists the n+1 values to be used 'Equal Intervals' = 'equal', # the range of the variable is divided into n part of equal space 'Quantiles' = 'quantile', # each class contains (more or less) the same amount of values 'Pretty Integers' = 'pretty', # sequence of about ‘n+1’ equally spaced ‘round’ values which cover the range of the values in ‘x’. The values are chosen so that they are 1, 2 or 5 times a power of 10. # 'Natural Breaks' = 'jenks', # seeks to reduce the variance within classes and maximize the variance between classes 'Hierarchical Cluster' = 'hclust', # Cluster with short distance 'K-means Cluster' = 'kmeans' # Cluster with low variance and similar size ) # list of maptiles as background for maps tiles.lst <- as.list(mpt[, provider]) names(tiles.lst) <- mpt[, name] # return correct spacing for axis labels rotation lbl.plt.rotation = function(angle, position = 'x'){ positions = list(x = 0, y = 90, top = 180, right = 270) rads = (angle - positions[[ position ]]) * pi / 180 hjust = 0.5 * (1 - sin(rads)) vjust = 0.5 * (1 + cos(rads)) element_text(angle = angle, vjust = vjust, hjust = hjust) } # global style for ggplot charts my.ggtheme <- function(g, xaxis.draw = FALSE, yaxis.draw = FALSE, axis.draw = FALSE, ticks.draw = FALSE, axis.colour = 'black', axis.size = 0.1, hgrid.draw = FALSE, vgrid.draw = FALSE, grids.colour = 'black', grids.size = 0.1, grids.type = 'dotted', labels.rotation = c(45, 0), labels.rotate = FALSE, bkg.colour = 'white', font.size = 6, ttl.font.size.mult = 1.2, ttl.face = 'bold', legend.pos = 'bottom', plot.border = FALSE, font.family = 'Arial' ){ g <- g + theme( text = element_text(family = font.family), plot.title = element_text(hjust = 0, size = rel(1.2) ), # hjust: 0-left, 0.5-center, 1-right plot.background = element_blank(), plot.margin = unit(c(1, 0.5, 0, 0.5), 'lines'), # space around the plot as in: TOP, RIGHT, BOTTOM, RIGHT plot.caption = element_text(size = 8, face = 'italic'), axis.line = element_blank(), axis.ticks = element_blank(), axis.text = element_text(size = font.size, color = axis.colour), axis.text.x = element_text(angle = labels.rotation[1], hjust = 1), # vjust = 0.5), axis.text.y = element_text(angle = labels.rotation[2]), # , hjust = , vjust = ), axis.title = element_text(size = font.size * (1 + ttl.font.size.mult), face = ttl.face), axis.title.x = element_text(vjust = -0.3), axis.title.y = element_text(vjust = 0.8, margin = margin(0, 10, 0, 0) ), legend.text = element_text(size = 6), legend.title = element_text(size = 8), legend.title.align = 1, legend.position = legend.pos, legend.background = element_blank(), legend.spacing = unit(0, 'cm'), # legend.key = element_blank(), legend.key.size = unit(0.2, 'cm'), legend.key.height = unit(0.4, 'cm'), legend.key.width = unit(1, 'cm'), panel.background = element_rect(fill = bkg.colour, colour = bkg.colour), panel.border = element_blank(), panel.grid = element_blank(), panel.spacing.x = unit(3, 'lines'), panel.spacing.y = unit(2, 'lines'), strip.text = element_text(hjust = 0.5, size = font.size * (1 + ttl.font.size.mult), face = ttl.face), strip.background = element_blank() ) if(plot.border) g <- g + theme( panel.border = element_rect(colour = axis.colour, size = axis.size, fill = NA) ) if(axis.draw){ g <- g + theme( axis.line = element_line(color = axis.colour, size = axis.size ) ) } else { if(xaxis.draw) g <- g + theme( axis.line.x = element_line(color = axis.colour, size = axis.size ) ) if(yaxis.draw) g <- g + theme( axis.line.y = element_line(color = axis.colour, size = axis.size ) ) } if(ticks.draw) g <- g + theme( axis.ticks = element_line(color = axis.colour, size = axis.size ) ) if(hgrid.draw & vgrid.draw){ g <- g + theme( panel.grid.major = element_line(colour = grids.colour, size = grids.size, linetype = grids.type ) ) } else{ if(vgrid.draw) g <- g + theme( panel.grid.major.x = element_line(colour = grids.colour, size = grids.size, linetype = grids.type ) ) if(hgrid.draw) g <- g + theme( panel.grid.major.y = element_line(colour = grids.colour, size = grids.size, linetype = grids.type ) ) } if(labels.rotate){ g <- g + theme( axis.text.x = element_text(hjust = 1, angle = 45 ) ) } return(g) } bounding_box <- function(lat, lon, dist, in.miles = TRUE) { if (in.miles) { ang_rad <- function(miles) miles/3958.756 } else { ang_rad <- function(miles) miles/1000 } `%+/-%` <- function(x, margin){x + c(-1, +1)*margin} deg2rad <- function(x) x/(180/pi) rad2deg <- function(x) x*(180/pi) lat_range <- function(latr, r) rad2deg(latr %+/-% r) lon_range <- function(lonr, dlon) rad2deg(lonr %+/-% dlon) r <- ang_rad(dist) latr <- deg2rad(lat) lonr <- deg2rad(lon) dlon <- asin(sin(r)/cos(latr)) m <- matrix(c(lon_range(lonr = lonr, dlon = dlon), lat_range(latr=latr, r=r)), nrow=2, byrow = TRUE) dimnames(m) <- list(c("lng", "lat"), c("min", "max")) m } lcn.tpe <- c('Postcode [Bounding Box]' = 'PCU', 'Postcode Sector ' = 'PCS', 'Postcode District' = 'PCD', 'Post Town' = 'PCT', 'Ward' = 'WARD', 'Parish' = 'PAR') rgns.lst <- list( 'England' = c( 'East Midlands', 'East of England', 'London', 'North East', 'North West', 'South East', 'South West', 'West Midlands', 'Yorkshire and The Humber' ), 'Northern Ireland', 'Scotland', 'Wales' ) build_list_loca <- function(x, tpe, cname = NA){ yl <- read_fst_idx(file.path(geouk_path, 'locations'), tpe) if(is.na(cname)) cname <- tpe yl <- yl[x, on = c(location_id = cname)][, .(id = location_id, name)][order(name)] y <- as.list(yl$id) names(y) <- yl$name y } addLegendFixedCustom <- function(map, colors, labels, sizes = 20, opacity = 0.5, radius = 50, ...){ colorAdditions <- paste0(colors, ';margin-top:4px;margin-bottom:4px;border-radius:', radius, '%;width:', sizes, 'px;height:', sizes, 'px') labelAdditions <- paste0( '
', labels, '
' ) return(addLegend(map, colors = colorAdditions, labels = labelAdditions, opacity = opacity, ...)) } get_postcodes_map <- function(id ){ lcn <- read_fst(file.path(geouk_path, 'locations'), as.data.table = TRUE) tpe <- lcn[location_id == id, as.character(type)] if(!tpe %in% c('PCS', 'PCD', 'PCT', 'WARD', 'PAR')) stop('Sorry, location type not implemented.') tiles.lst <- c( 'OSM Mapnik' = 'OpenStreetMap.Mapnik', 'OSM B&W' = 'OpenStreetMap.BlackAndWhite', 'Stamen Toner' = 'Stamen.Toner', 'Stamen Toner Lite' = 'Stamen.TonerLite' ) mp <- leaflet(options = leafletOptions(minZoom = 6)) %>% enableTileCaching() %>% addSearchOSM() %>% addResetMapButton() %>% addFullscreenControl() for(idx in 1:length(tiles.lst)) mp <- mp %>% addProviderTiles(providers[[tiles.lst[idx]]], group = names(tiles.lst)[idx]) y <- readRDS(file.path(bnduk_path, 'postcodes', 'ch', id)) grps <- c('Concave Hull', 'Output Areas', 'Postcodes (active)', 'Postcodes (terminated)') mp <- mp %>% addPolygons( data = y, group = grps[1] ) y <- readRDS(file.path(bnduk_path, 'postcodes', 'oa', id)) mp <- mp %>% addPolygons( data = y, group = grps[2], color = 'green' ) cid <- c(NA, id) switch(tpe, 'PCS' = { fname <- 'pcds' }, 'PCD' = { fname <- 'pcds' cid <- id }, 'PCT' = { fname <- 'pcat' }, 'WARD' = { fname <- 'ladw' }, 'PAR' = { fname <- 'ladp' } ) y <- read_fst_idx2( file.path(geouk_path, paste0('postcodes_', fname)), cid, c('postcode', 'is_active', 'x_lon', 'y_lat') ) mp <- mp %>% addCircles( data = y[is_active == 1], lng = ~x_lon, lat = ~y_lat, group = grps[3], radius = 5, weight = 1, color = 'darkgreen', opacity = 1, fillColor = 'green', fillOpacity = 0.5, label = ~postcode ) if(nrow(y[is_active == 0]) > 0){ mp <- mp %>% addCircles( data = y[is_active == 0], lng = ~x_lon, lat = ~y_lat, group = grps[4], radius = 5, weight = 1, color = 'darkred', opacity = 1, fillColor = 'red', fillOpacity = 0.5, label = ~postcode ) } else { grps <- grps[1:3] } mp <- mp %>% addLayersControl( baseGroups = names(tiles.lst), overlayGroups = grps, options = layersControlOptions(collapsed = FALSE) ) # mp <- mp %>% # mp <- mp %>% # addLegendFixedCustom( # colors = c('orange', 'lightblue'), # labels = c('Big Chains', 'Other Shops'), # opacity = 1, # title = '', # position = 'bottomright', # ) mp }