Smoothed logo created with `btb` !

In btb: Beyond the Border - Kernel Density Estimation for Urban Geography

knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>",
  fig.height = 5,
  fig.width = 5,fig.align = 'center'


)

1. Load the packages you need

library(sf)
library(dplyr)
library(mapsf)

library(sf)
library(dplyr)
library(mapsf)
library(hexbin)

1. Create the letters polygons "b" "t" and "b"

b1 <- "POLYGON ((-12076233 5319120, -11880555 5328904, -11528333 5201712,-11362006 4986466, -11391358 4683163, -11479413 4438565, -11782715 4311374,-12448023 4340726, -12389319 6229026, -12017530 6229026, -12076233 5319120),(-12164208 4569828, -11795932 4579271, -11663730 4692586, -11682616 4938104,-12145322 5060862, -12164208 4569828))"
t <- "POLYGON ((-11031051 6184577, -11049937 4305424, -10483358 4295981,-10218955 4456512, -10077310 4692586, -10426700 4702029, -10719433 4579271,-10719433 5032534, -10709990 5315823, -10332271 5315823, -10285056 5561340,-10700547 5561340, -10709990 6146805, -11031051 6184577))"                                                           
b2 <- "POLYGON ((-9376233 5319120, -9180555 5328904, -8828333 5201712,-8662006 4986466, -8691358 4683163, -8779413 4438565, -9082715 4311374,-9748023 4340726, -9689319 6229026, -9317530 6229026, -9376233 5319120),(-9464208 4569828, -9095932 4579271, -8963730 4692586, -8982616 4938104,-9445322 5060862, -9464208 4569828))" 
letters =  st_as_sf(data.frame(geom=c(b1,t,b2)), wkt = "geom") %>% st_set_crs(3857)
plot(letters)

1. Create the hex logo

hexcoords <- function (dx, dy = NULL, n = 1, sep = NULL) 
{
    stopifnot(length(dx) == 1)
    if (is.null(dy)) 
        dy <- dx/sqrt(3)
    if (is.null(sep)) 
        list(x = rep.int(c(dx, dx, 0, -dx, -dx, 0), n), y = rep.int(c(dy, 
            -dy, -2 * dy, -dy, dy, 2 * dy), n), no.sep = TRUE)
    else list(x = rep.int(c(dx, dx, 0, -dx, -dx, 0, sep), n), 
        y = rep.int(c(dy, -dy, -2 * dy, -dy, dy, 2 * dy, sep), 
            n), no.sep = FALSE)
}

letters_bbox <- st_bbox(st_buffer(letters,500000))
dx = (letters_bbox[["xmax"]] - letters_bbox[["xmin"]])/2
dy = (letters_bbox[["ymax"]] - letters_bbox[["ymin"]])/2
coords_hex <- hexcoords(dx = dx, dy = dy)
corners <- tibble(x = coords_hex$x + letters_bbox[["xmin"]] + dx,
                  y = coords_hex$y + letters_bbox[["ymin"]] + dy)
corners <- rbind(corners, corners[1,])
hexagon <- st_polygon(list(as.matrix(corners)))
hexagon_int <- st_buffer(hexagon,-150000)
lines <- st_as_sf(st_graticule(st_bbox(hexagon),lat = seq(-32,80,8), crs = 2154)) 
lines <- st_intersection(lines %>% st_set_crs(NA),hexagon_int)
plot(hexagon)
plot(hexagon_int, add=TRUE)
plot(lines, col="black",add = TRUE)

1. Sample points inside the letters

sample <- st_sample(letters,1000)
plot(hexagon)
plot(hexagon_int, add=TRUE)
plot(letters,add=TRUE)
plot(st_geometry(lines), col="black",add = TRUE)
plot(st_geometry(sample),add=TRUE)

1. Spatial smoothing

sample <- data.frame(st_coordinates(sample))
sample$nobs <- 1
colnames(sample) <- c("x","y","nobs")

sfCarrLiss <- btb::kernelSmoothing(dfObservations = sample, 
                                   sEPSG = "3857",
                                   iCellSize = 10000, 
                                   iBandwidth = 200000)

sfCarrLiss <- btb::kernelSmoothing(dfObservations = sample, 
                                   sEPSG = "3857",
                                   iCellSize = 10000, 
                                   iBandwidth = 200000)

1. Plot the result with mapsf !

mf_init(x=hexagon,theme = mf_theme(list(bg = "#FFFFFFFF")))
 mf_map(x = hexagon, 
        border="#7D0025",
        col="#7D0025",
        add = TRUE)
 mf_map(x = hexagon_int, 
        border="#e8f4f8",
        col="#e8f4f8",
        add = TRUE)
 mf_map(x = lines, 
        col="darkgrey",
        lwd = 2,
        add = TRUE)
 mf_map(x = sfCarrLiss, 
       type = "choro",
       var="nobs",
       breaks = "quantile",
       nbreaks = 4,
       lwd=1,
       pal = c("#FEF1B2",rev(hcl.colors(n=5, palette ="YlOrRd")[1:3])),
       border=NA,
       leg_pos=NA,
       add = TRUE)

btb documentation built on Oct. 24, 2022, 5:10 p.m.