API tools faq
paste
lvalnegri

various.R

lvalnegri
Aug 5th, 2020 (edited)
1,865
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
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!