lvalnegri

various.R

Aug 5th, 2020 (edited)
1,518
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. add_loca_name <- function(dt, geo, coords = FALSE){
  2.     yn <- names(dt)
  3.     cols <- c('type', 'location_id', 'name')
  4.     if(coords) cols <- c(cols, 'x_lon', 'y_lat')
  5.     y <- read_fst(file.path(geouk_path, 'locations'), columns = cols, as.data.table = TRUE)
  6.     y <- y[type == geo][, type := NULL]
  7.     cols <- c('id', geo)
  8.     if(coords) cols <- c(cols,  paste0(geo, c('x', 'y')))
  9.     setnames(y, cols)
  10.     dt <- y[dt, on = c(id = geo)][, id := NULL]
  11.     setcolorder(dt, yn)
  12.     dt
  13. }
  14.  
  15.  
  16. # List of palettes to be used with ColourBrewer package:  
  17. palette.lst <- list(
  18.     'SEQUENTIAL' = c( # ordinal data where (usually) low is less important and high is more important
  19.         'Blues' = 'Blues', 'Blue-Green' = 'BuGn', 'Blue-Purple' = 'BuPu', 'Green-Blue' = 'GnBu', 'Greens' = 'Greens', 'Greys' = 'Greys',
  20.         'Oranges' = 'Oranges', 'Orange-Red' = 'OrRd', 'Purple-Blue' = 'PuBu', 'Purple-Blue-Green' = 'PuBuGn', 'Purple-Red' = 'PuRd', 'Purples' = 'Purples',
  21.         'Red-Purple' = 'RdPu', 'Reds' = 'Reds', 'Yellow-Green' = 'YlGn', 'Yellow-Green-Blue' = 'YlGnBu', 'Yellow-Orange-Brown' = 'YlOrBr',
  22.         'Yellow-Orange-Red' = 'YlOrRd'
  23.     ),
  24.     'DIVERGING' = c(  # ordinal data where both low and high are important (i.e. deviation from some reference "average" point)
  25.         'Brown-Blue-Green' = 'BrBG', 'Pink-Blue-Green' = 'PiYG', 'Purple-Red-Green' = 'PRGn', 'Orange-Purple' = 'PuOr', 'Red-Blue' = 'RdBu', 'Red-Grey' = 'RdGy',
  26.         'Red-Yellow-Blue' = 'RdYlBu', 'Red-Yellow-Green' = 'RdYlGn', 'Spectral' = 'Spectral'
  27.     ),  
  28.     'QUALITATIVE' = c(  # categorical/nominal data where there is no logical order
  29.         'Accent' = 'Accent', 'Dark2' = 'Dark2', 'Paired' = 'Paired', 'Pastel1' = 'Pastel1', 'Pastel2' = 'Pastel2',
  30.         'Set1' = 'Set1', 'Set2' = 'Set2', 'Set3' = 'Set3'
  31.     )
  32. )
  33.  
  34. tiles.lst <- c(
  35.     'OSM Mapnik' = 'OpenStreetMap.Mapnik',
  36.     'OSM B&W' = 'OpenStreetMap.BlackAndWhite',
  37.     'Stamen Toner' = 'Stamen.Toner',
  38.     'Stamen Toner Lite' = 'Stamen.TonerLite',
  39.     'Wikimedia' = 'Wikimedia',
  40.     'Hydda Full' = 'Hydda.Full',
  41.     'Hydda Base' = 'Hydda.Base'
  42. )
  43. marker_colours <- c(
  44.     'red', 'darkred', 'orange', 'pink', 'beige', 'green', 'darkgreen', 'lightgreen',
  45.     'blue', 'lightblue', 'purple', 'cadetblue', 'white', 'lightgray', 'gray', 'black'
  46. )
  47. markers <- iconList(
  48.     red = makeIcon(file.path(pub_path, 'images', 'icons', 'leaflet', 'markers', 'sm-orange.png'), iconWidth = 24, iconHeight =32),
  49.     blue = makeIcon(file.path(pub_path, 'images', 'icons', 'leaflet', 'markers', 'sm-lightblue.png'), iconWidth = 24, iconHeight =32)
  50. )
  51.  
  52. mp <- leaflet(options = leafletOptions(minZoom = 6)) %>%
  53.         setView(lat = 54.003419, lng = -2.547973, zoom = 6) %>%
  54.         enableTileCaching() %>%
  55.         addTiles(options = tileOptions(useCache = TRUE, crossOrigin = TRUE)) %>%
  56.         addSearchOSM() %>%
  57.         addResetMapButton() %>%
  58.         addFullscreenControl()
  59. for(idx in 1:length(tiles.lst))
  60.     mp <- mp %>% addProviderTiles(providers[[tiles.lst[idx]]], group = names(tiles.lst)[idx])
  61.  
  62.  
  63. # list of options for charts
  64. point.shapes <- c('circle' = 21, 'square' = 22, 'diamond' = 23, 'triangle up' = 24, 'triangle down' = 25)
  65. line.types <- c('dashed', 'dotted', 'solid', 'dotdash', 'longdash', 'twodash')
  66. face.types <- c('plain', 'bold', 'italic', 'bold.italic')
  67. val.lbl.pos <- list(
  68.     'Inside'  = list('Vertical' = c(0.5,  1.5), 'Horizontal' = c( 1.2, 0.2) ),
  69.     'Outside' = list('Vertical' = c(0.4, -0.3), 'Horizontal' = c(-0.2, 0.2) )
  70. )
  71.  
  72. lbl.format <- function(y, type, is.pct = FALSE){
  73.     if(type == 1){
  74.         format(y, big.mark = ',', nsmall = 0)
  75.     } else if(type == 2){
  76.         if(is.pct){
  77.             paste0(format(round(100 * y, 2), nsmall = 2), '%')
  78.         } else {
  79.             format(y, big.mark = ',', nsmall = 0)
  80.         }    
  81.     } else {
  82.         format(y, nsmall = 2)
  83.     }
  84. }
  85.  
  86. class.methods <- c(
  87. #    'Fixed' = 'fixed',                  # need an additional argument fixedBreaks that lists the n+1 values to be used
  88.     'Equal Intervals' = 'equal',        # the range of the variable is divided into n part of equal space
  89.     'Quantiles' = 'quantile',           # each class contains (more or less) the same amount of values
  90.     '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.
  91. #    'Natural Breaks' = 'jenks',         # seeks to reduce the variance within classes and maximize the variance between classes
  92.     'Hierarchical Cluster' = 'hclust',  # Cluster with short distance
  93.     'K-means Cluster' = 'kmeans'        # Cluster with low variance and similar size
  94. )
  95.  
  96. # list of maptiles as background for maps
  97. tiles.lst <- as.list(mpt[, provider])
  98. names(tiles.lst) <- mpt[, name]
  99.  
  100.  
  101.  
  102.  
  103. # return correct spacing for axis labels rotation
  104. lbl.plt.rotation = function(angle, position = 'x'){
  105.     positions = list(x = 0, y = 90, top = 180, right = 270)
  106.     rads  = (angle - positions[[ position ]]) * pi / 180
  107.     hjust = 0.5 * (1 - sin(rads))
  108.     vjust = 0.5 * (1 + cos(rads))
  109.     element_text(angle = angle, vjust = vjust, hjust = hjust)
  110. }
  111.  
  112. # global style for ggplot charts
  113. my.ggtheme <- function(g,
  114.                        xaxis.draw = FALSE, yaxis.draw = FALSE, axis.draw = FALSE, ticks.draw = FALSE, axis.colour = 'black', axis.size = 0.1,
  115.                        hgrid.draw = FALSE, vgrid.draw = FALSE, grids.colour = 'black', grids.size = 0.1, grids.type = 'dotted',
  116.                        labels.rotation = c(45, 0), labels.rotate = FALSE,
  117.                        bkg.colour = 'white', font.size = 6, ttl.font.size.mult = 1.2, ttl.face = 'bold',
  118.                        legend.pos = 'bottom', plot.border = FALSE, font.family = 'Arial'
  119. ){
  120.     g <- g + theme(
  121.         text             = element_text(family = font.family),
  122.         plot.title       = element_text(hjust = 0, size = rel(1.2) ),  # hjust: 0-left, 0.5-center, 1-right
  123.         plot.background  = element_blank(),
  124.         plot.margin      = unit(c(1, 0.5, 0, 0.5), 'lines'),  # space around the plot as in: TOP, RIGHT, BOTTOM, RIGHT
  125.         plot.caption     = element_text(size = 8, face = 'italic'),
  126.         axis.line        = element_blank(),
  127.         axis.ticks       = element_blank(),
  128.         axis.text        = element_text(size = font.size, color = axis.colour),
  129.         axis.text.x      = element_text(angle = labels.rotation[1], hjust = 1), # vjust = 0.5),
  130.         axis.text.y      = element_text(angle = labels.rotation[2]), # , hjust = , vjust = ),
  131.         axis.title       = element_text(size = font.size * (1 + ttl.font.size.mult), face = ttl.face),
  132.         axis.title.x     = element_text(vjust = -0.3),
  133.         axis.title.y     = element_text(vjust = 0.8, margin = margin(0, 10, 0, 0) ),
  134.         legend.text      = element_text(size = 6),
  135.         legend.title     = element_text(size = 8),
  136.         legend.title.align = 1,
  137.         legend.position  = legend.pos,
  138.         legend.background = element_blank(),
  139.         legend.spacing   = unit(0, 'cm'),
  140.         #                legend.key = element_blank(),
  141.         legend.key.size  = unit(0.2, 'cm'),
  142.         legend.key.height = unit(0.4, 'cm'),      
  143.         legend.key.width = unit(1, 'cm'),
  144.         panel.background = element_rect(fill = bkg.colour, colour = bkg.colour),
  145.         panel.border     = element_blank(),
  146.         panel.grid       = element_blank(),
  147.         panel.spacing.x  = unit(3, 'lines'),
  148.         panel.spacing.y  = unit(2, 'lines'),
  149.         strip.text       = element_text(hjust = 0.5, size = font.size * (1 + ttl.font.size.mult), face = ttl.face),
  150.         strip.background = element_blank()
  151.     )
  152.     if(plot.border) g <- g + theme( panel.border = element_rect(colour = axis.colour, size = axis.size, fill = NA) )
  153.     if(axis.draw){
  154.         g <- g + theme( axis.line = element_line(color = axis.colour, size = axis.size ) )
  155.     } else {
  156.         if(xaxis.draw) g <- g + theme( axis.line.x = element_line(color = axis.colour, size = axis.size ) )
  157.         if(yaxis.draw) g <- g + theme( axis.line.y = element_line(color = axis.colour, size = axis.size ) )
  158.     }
  159.     if(ticks.draw)  g <- g + theme( axis.ticks = element_line(color = axis.colour, size = axis.size ) )
  160.     if(hgrid.draw & vgrid.draw){
  161.         g <- g + theme( panel.grid.major = element_line(colour = grids.colour, size = grids.size, linetype = grids.type ) )
  162.     } else{
  163.         if(vgrid.draw) g <- g + theme( panel.grid.major.x = element_line(colour = grids.colour, size = grids.size, linetype = grids.type ) )
  164.         if(hgrid.draw) g <- g + theme( panel.grid.major.y = element_line(colour = grids.colour, size = grids.size, linetype = grids.type ) )
  165.     }
  166.     if(labels.rotate){
  167.         g <- g + theme( axis.text.x = element_text(hjust = 1, angle = 45 ) )
  168.     }
  169.     return(g)
  170. }
  171.  
  172. bounding_box <- function(lat, lon, dist, in.miles = TRUE) {
  173.  
  174.     if (in.miles) {
  175.         ang_rad <- function(miles) miles/3958.756
  176.     } else {
  177.         ang_rad <- function(miles) miles/1000
  178.     }
  179.     `%+/-%` <- function(x, margin){x + c(-1, +1)*margin}
  180.     deg2rad <- function(x) x/(180/pi)
  181.     rad2deg <- function(x) x*(180/pi)
  182.     lat_range <- function(latr, r) rad2deg(latr %+/-% r)
  183.     lon_range <- function(lonr, dlon) rad2deg(lonr %+/-% dlon)
  184.  
  185.     r <- ang_rad(dist)
  186.     latr <- deg2rad(lat)
  187.     lonr <- deg2rad(lon)
  188.     dlon <- asin(sin(r)/cos(latr))
  189.  
  190.     m <- matrix(c(lon_range(lonr = lonr, dlon = dlon),
  191.         lat_range(latr=latr, r=r)), nrow=2, byrow = TRUE)
  192.  
  193.     dimnames(m) <- list(c("lng", "lat"), c("min", "max"))
  194.     m
  195. }
  196.  
  197.  
  198.  
  199. lcn.tpe <- c('Postcode [Bounding Box]' = 'PCU', 'Postcode Sector ' = 'PCS', 'Postcode District' = 'PCD', 'Post Town' = 'PCT', 'Ward' = 'WARD', 'Parish' = 'PAR')
  200. rgns.lst <- list(
  201.     'England' = c(
  202.         'East Midlands', 'East of England', 'London',
  203.         'North East', 'North West', 'South East', 'South West', 'West Midlands', 'Yorkshire and The Humber'
  204.     ),
  205.     'Northern Ireland', 'Scotland', 'Wales'
  206. )
  207.  
  208. build_list_loca <- function(x, tpe, cname = NA){
  209.     yl <- read_fst_idx(file.path(geouk_path, 'locations'), tpe)
  210.     if(is.na(cname)) cname <- tpe
  211.     yl <- yl[x, on = c(location_id = cname)][, .(id = location_id, name)][order(name)]
  212.     y <- as.list(yl$id)
  213.     names(y) <- yl$name
  214.     y
  215. }
  216.  
  217. addLegendFixedCustom <- function(map, colors, labels, sizes = 20, opacity = 0.5, radius = 50, ...){
  218.     colorAdditions <- paste0(colors, ';margin-top:4px;margin-bottom:4px;border-radius:', radius, '%;width:', sizes, 'px;height:', sizes, 'px')
  219.     labelAdditions <- paste0(
  220.         '<div style=display:inline-block;height:', sizes, 'px;margin-top:4px;margin-bottom:4px;line-height:', sizes, 'px;>',
  221.         labels,
  222.         '</div>'
  223.     )
  224.   return(addLegend(map, colors = colorAdditions, labels = labelAdditions, opacity = opacity, ...))
  225. }
  226.  
  227. get_postcodes_map <- function(id
  228.                              
  229.     ){
  230.         lcn <- read_fst(file.path(geouk_path, 'locations'), as.data.table = TRUE)
  231.         tpe <- lcn[location_id == id, as.character(type)]
  232.         if(!tpe %in% c('PCS', 'PCD', 'PCT', 'WARD', 'PAR')) stop('Sorry, location type not implemented.')
  233.         tiles.lst <- c(
  234.             'OSM Mapnik' = 'OpenStreetMap.Mapnik',
  235.             'OSM B&W' = 'OpenStreetMap.BlackAndWhite',
  236.             'Stamen Toner' = 'Stamen.Toner',
  237.             'Stamen Toner Lite' = 'Stamen.TonerLite'
  238.         )
  239.         mp <- leaflet(options = leafletOptions(minZoom = 6)) %>%
  240.             enableTileCaching() %>%
  241.             addSearchOSM() %>%
  242.             addResetMapButton() %>%
  243.             addFullscreenControl()
  244.         for(idx in 1:length(tiles.lst))
  245.             mp <- mp %>% addProviderTiles(providers[[tiles.lst[idx]]], group = names(tiles.lst)[idx])
  246.        
  247.         y <- readRDS(file.path(bnduk_path, 'postcodes', 'ch', id))
  248.         grps <- c('Concave Hull', 'Output Areas', 'Postcodes (active)', 'Postcodes (terminated)')
  249.         mp <- mp %>%
  250.             addPolygons(
  251.                 data = y,
  252.                 group = grps[1]
  253.             )
  254.        
  255.         y <- readRDS(file.path(bnduk_path, 'postcodes', 'oa', id))
  256.         mp <- mp %>%
  257.             addPolygons(
  258.                 data = y,
  259.                 group = grps[2],
  260.                 color = 'green'
  261.             )
  262.        
  263.         cid <- c(NA, id)
  264.         switch(tpe,
  265.             'PCS' = { fname <- 'pcds' },        
  266.             'PCD' = {
  267.                 fname <- 'pcds'
  268.                 cid <- id
  269.             },        
  270.             'PCT' = { fname <- 'pcat' },        
  271.             'WARD' = { fname <- 'ladw' },        
  272.             'PAR' = { fname <- 'ladp' }      
  273.         )
  274.         y <- read_fst_idx2(
  275.                 file.path(geouk_path, paste0('postcodes_', fname)),
  276.                 cid,
  277.                 c('postcode', 'is_active', 'x_lon', 'y_lat')
  278.         )
  279.         mp <- mp %>%
  280.             addCircles(
  281.                 data = y[is_active == 1],
  282.                 lng = ~x_lon, lat = ~y_lat,
  283.                 group = grps[3],
  284.                 radius = 5,
  285.                 weight = 1,
  286.                 color = 'darkgreen',
  287.                 opacity = 1,
  288.                 fillColor = 'green',
  289.                 fillOpacity = 0.5,
  290.                 label = ~postcode
  291.             )
  292.         if(nrow(y[is_active == 0]) > 0){
  293.             mp <- mp %>%
  294.                 addCircles(
  295.                     data = y[is_active == 0],
  296.                     lng = ~x_lon, lat = ~y_lat,
  297.                     group = grps[4],
  298.                     radius = 5,
  299.                     weight = 1,
  300.                     color = 'darkred',
  301.                     opacity = 1,
  302.                     fillColor = 'red',
  303.                     fillOpacity = 0.5,
  304.                     label = ~postcode
  305.                 )
  306.         } else { grps <- grps[1:3] }
  307.        
  308.         mp <- mp %>%
  309.             addLayersControl(
  310.                 baseGroups = names(tiles.lst),
  311.                 overlayGroups = grps,
  312.                 options = layersControlOptions(collapsed = FALSE)
  313.             )
  314.        
  315.         # mp <- mp %>%
  316.            
  317.  
  318.         # mp <- mp %>%
  319.         #   addLegendFixedCustom(
  320.         #         colors = c('orange', 'lightblue'),
  321.         #         labels = c('Big Chains', 'Other Shops'),
  322.         #       opacity = 1,
  323.         #         title = '',
  324.         #         position = 'bottomright',
  325.         #   )
  326.        
  327.         mp
  328. }
  329.  
RAW Paste Data

Adblocker detected! Please consider disabling it...

We've detected AdBlock Plus or some other adblocking software preventing Pastebin.com from fully loading.

We don't have any obnoxious sound, or popup ads, we actively block these annoying types of ads!

Please add Pastebin.com to your ad blocker whitelist or disable your adblocking software.

×