API tools faq
paste
lvalnegri

various.R

lvalnegri
Aug 5th, 2020 (edited)
1,866
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
R 14.30 KB | None | 0 0
raw download clone embed print report
  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.  
Advertisement
Add Comment
Please, Sign In to add comment
Public Pastes
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!