Update 'cbs_2021/cbs_data_updaten.R'

This commit is contained in:
dr. M.S. (Matthijs) Berends 2021-03-30 18:23:43 +02:00
parent 02811500ab
commit d3e74dd632

View File

@ -1,233 +1,235 @@
library(dplyr) library(dplyr)
library(sf) library(sf)
# De %like% functie, zodat je kunt gebruiken: "Test" %like% "te" (= TRUE) linbrary(cleaner)
`%like%` <- function (x, pattern) grepl(pattern = tolower(pattern), x = tolower(x), fixed = FALSE)
# De %like% functie, zodat je kunt gebruiken: "Test" %like% "te" (= TRUE)
`%like%` <- function (x, pattern) grepl(pattern = tolower(pattern), x = tolower(x), fixed = FALSE)
# Bronnen -----------------------------------------------------------------
downloadmap <- "/Users/msberends/Downloads/" # Bronnen -----------------------------------------------------------------
# download inwoners (gescheiden op geslacht) per postcode hier als 'CSV volgens tabelindeling': downloadmap <- "/Users/msberends/Downloads/"
# https://opendata.cbs.nl/#/CBS/nl/dataset/83503NED/table?dl=42FC6
# verwijder dan de eerste rijen en de laatste rij ("Bron: CBS") # download inwoners (gescheiden op geslacht) per postcode hier als 'CSV volgens tabelindeling':
postcodes_bestand <- paste0(downloadmap, "Bevolking__geslacht__migratieachtergrond__viercijferige_postcode__1_januari_15102020_095747.csv") # https://opendata.cbs.nl/#/CBS/nl/dataset/83503NED/table?dl=42FC6
# download inwoners per 5 jaar leeftijd en geslacht hier voor het huidige jaar: # verwijder dan de eerste rijen en de laatste rij ("Bron: CBS")
# https://opendata.cbs.nl/#/CBS/nl/dataset/83502NED/table?dl=42FE0 postcodes_bestand <- paste0(downloadmap, "Bevolking__geslacht__migratieachtergrond__viercijferige_postcode__1_januari_15102020_095747.csv")
inwoners_bestand <- paste0(downloadmap, "Bevolking__leeftijd__postcode_15102020_102334.csv") # download inwoners per 5 jaar leeftijd en geslacht hier voor het huidige jaar:
# gebiedsindelingen hier downloaden: # https://opendata.cbs.nl/#/CBS/nl/dataset/83502NED/table?dl=42FE0
# https://www.cbs.nl/nl-nl/dossier/nederland-regionaal/geografische-data/cbs-gebiedsindelingen inwoners_bestand <- paste0(downloadmap, "Bevolking__leeftijd__postcode_15102020_102334.csv")
gebiedsindelingen_bestand <- paste0(downloadmap, "cbsgebiedsindelingen_2021_v1.gpkg") # gebiedsindelingen hier downloaden:
# download postcodes 4 onder 'Downloads' ('Numeriek deel van de postcode (PC4)') hier: # https://www.cbs.nl/nl-nl/dossier/nederland-regionaal/geografische-data/cbs-gebiedsindelingen
# https://www.cbs.nl/nl-nl/dossier/nederland-regionaal/geografische-data/gegevens-per-postcode gebiedsindelingen_bestand <- paste0(downloadmap, "cbsgebiedsindelingen_2021_v1.gpkg")
postcodes4_bestand <- paste0(downloadmap, "2019-CBS_PC4_2018_v1/CBS_PC4_2018_v1.shp") # download postcodes 4 onder 'Downloads' ('Numeriek deel van de postcode (PC4)') hier:
# https://www.cbs.nl/nl-nl/dossier/nederland-regionaal/geografische-data/gegevens-per-postcode
postcodes4_bestand <- paste0(downloadmap, "2019-CBS_PC4_2018_v1/CBS_PC4_2018_v1.shp")
# Helpfuncties ------------------------------------------------------------
kaart_fixen <- function(kaart) { # Helpfuncties ------------------------------------------------------------
# CRS opnieuw instellen, bij nieuwe GDAL geeft dit anders problemen:
st_crs(kaart) <- clean_numeric(st_crs(kaart)$input) kaart_fixen <- function(kaart) {
if (is.na(st_crs(kaart))) { # CRS opnieuw instellen, bij nieuwe GDAL geeft dit anders problemen:
# 'reserve' CRS st_crs(kaart) <- clean_numeric(st_crs(kaart)$input)
st_crs(kaart) <- 28992 if (is.na(st_crs(kaart))) {
} # 'reserve' CRS
if (!"geometry" %in% colnames(kaart)) { st_crs(kaart) <- 28992
geom_naam <- c("shape", "geom") }
geom_naam <- colnames(kaart)[colnames(kaart) %in% geom_naam][1] if (!"geometry" %in% colnames(kaart)) {
geometry <- kaart[, colnames(kaart)[tolower(colnames(kaart)) == geom_naam], drop = TRUE] geom_naam <- c("shape", "geom")
kaart <- st_drop_geometry(kaart) geom_naam <- colnames(kaart)[colnames(kaart) %in% geom_naam][1]
kaart <- st_set_geometry(kaart, geometry) geometry <- kaart[, colnames(kaart)[tolower(colnames(kaart)) == geom_naam], drop = TRUE]
} kaart <- st_drop_geometry(kaart)
# geometrie als breedte- en lengtegraad, CRS transformeren van 28992 naar 4326 kaart <- st_set_geometry(kaart, geometry)
kaart <- st_transform(kaart, crs = 4326) }
# geometrie als breedte- en lengtegraad, CRS transformeren van 28992 naar 4326
# alle ongeldige vormen geldig maken kaart <- st_transform(kaart, crs = 4326)
if (any(!st_is_valid(kaart$geometry))) {
kaart$geometry <- st_make_valid(kaart$geometry) # alle ongeldige vormen geldig maken
} if (any(!st_is_valid(kaart$geometry))) {
kaart$geometry <- st_make_valid(kaart$geometry)
# CRS opnieuw instellen, bij nieuwe GDAL geeft dit anders problemen: }
st_crs(kaart) <- clean_numeric(st_crs(kaart)$input)
if (is.na(st_crs(kaart))) { # CRS opnieuw instellen, bij nieuwe GDAL geeft dit anders problemen:
# 'reserve' CRS st_crs(kaart) <- clean_numeric(st_crs(kaart)$input)
st_crs(kaart) <- 28992 if (is.na(st_crs(kaart))) {
} # 'reserve' CRS
# geometrie als breedte- en lengtegraad, CRS transformeren van 28992 naar 4326 st_crs(kaart) <- 28992
kaart <- st_transform(kaart, crs = 4326) }
# oppervlakte toevoegen # geometrie als breedte- en lengtegraad, CRS transformeren van 28992 naar 4326
kaart$area_km2 <- as.double(st_area(st_geometry(kaart)) / 1000 ^ 2) kaart <- st_transform(kaart, crs = 4326)
kaart # oppervlakte toevoegen
} kaart$area_km2 <- as.double(st_area(st_geometry(kaart)) / 1000 ^ 2)
kaart
lagen_beschikbaar <- sort(st_layers(gebiedsindelingen_bestand)$name) }
downloaden_transformeren <- function(laag) {
zoeklaag <- sort(lagen_beschikbaar[lagen_beschikbaar %like% laag & lagen_beschikbaar <- sort(st_layers(gebiedsindelingen_bestand)$name)
lagen_beschikbaar %like% "gegeneraliseerd" & downloaden_transformeren <- function(laag) {
!lagen_beschikbaar %like% "niet"]) zoeklaag <- sort(lagen_beschikbaar[lagen_beschikbaar %like% laag &
if (length(zoeklaag) == 0) { lagen_beschikbaar %like% "gegeneraliseerd" &
stop("Geen laag gevonden") !lagen_beschikbaar %like% "niet"])
} if (length(zoeklaag) == 0) {
zoeklaag <- zoeklaag[length(zoeklaag)] stop("Geen laag gevonden")
message("Laag '", zoeklaag, "' gevonden", appendLF = FALSE) }
zoeklaag <- zoeklaag[length(zoeklaag)]
kaart <- st_read(gebiedsindelingen_bestand, layer = zoeklaag, quiet = TRUE) message("Laag '", zoeklaag, "' gevonden", appendLF = FALSE)
kaart <- kaart_fixen(kaart)
kaart <- st_read(gebiedsindelingen_bestand, layer = zoeklaag, quiet = TRUE)
message(", met ", nrow(kaart), " geometrieën") kaart <- kaart_fixen(kaart)
colnames(kaart)[colnames(kaart) %like% "naam"] <- laag
# geen factor message(", met ", nrow(kaart), " geometrieën")
kaart[, laag] <- as.character(kaart[, laag, drop = TRUE]) colnames(kaart)[colnames(kaart) %like% "naam"] <- laag
# geen factor
# alleen het type, oppervlakte en de geometrie behouden kaart[, laag] <- as.character(kaart[, laag, drop = TRUE])
kaart <- kaart[, c(laag, "area_km2", "geometry"), drop = FALSE]
kaart # alleen het type, oppervlakte en de geometrie behouden
} kaart <- kaart[, c(laag, "area_km2", "geometry"), drop = FALSE]
kaart
}
# Inwoners per postcode/leeftijd/geslacht ---------------------------------
inwoners_per_postcode_leeftijd <- read_csv2(inwoners_bestand) # Inwoners per postcode/leeftijd/geslacht ---------------------------------
inwoners_per_postcode_leeftijd <- inwoners_per_postcode_leeftijd %>%
filter(!leeftijd %like% "totaal", postcode %like% "[0-9]") %>% inwoners_per_postcode_leeftijd <- read_csv2(inwoners_bestand)
mutate(postcode = as.double(postcode), inwoners_per_postcode_leeftijd <- inwoners_per_postcode_leeftijd %>%
geslacht = case_when(geslacht %like% "totaal" ~ "inwoners", filter(!leeftijd %like% "totaal", postcode %like% "[0-9]") %>%
geslacht %like% "man" ~ "inwoners_man", mutate(postcode = as.double(postcode),
geslacht %like% "vrouw" ~ "inwoners_vrouw"), geslacht = case_when(geslacht %like% "totaal" ~ "inwoners",
# bij CBS vinden ze 0-5 en 5-10 handig. Waarin zit iemand dan die 5 is?! We maken er 0-4 en 5-9 van: geslacht %like% "man" ~ "inwoners_man",
leeftijd_min = as.numeric(gsub("([0-9]+).*", "\\1", leeftijd)), geslacht %like% "vrouw" ~ "inwoners_vrouw"),
leeftijd_max = as.numeric(gsub("([0-9]+)[^0-9]+([0-9]+)[^0-9]+", "\\2", leeftijd)), # bij CBS vinden ze 0-5 en 5-10 handig. Waarin zit iemand dan die 5 is?! We maken er 0-4 en 5-9 van:
leeftijd_nieuw = paste0(leeftijd_min, "-", leeftijd_max - 1), leeftijd_min = as.numeric(gsub("([0-9]+).*", "\\1", leeftijd)),
leeftijd_nieuw = gsub("95-NA", "95+", leeftijd_nieuw), leeftijd_max = as.numeric(gsub("([0-9]+)[^0-9]+([0-9]+)[^0-9]+", "\\2", leeftijd)),
leeftijd = factor(leeftijd_nieuw, levels = levels(age_groups(0, 5 * c(1:19))), ordered = TRUE)) %>% leeftijd_nieuw = paste0(leeftijd_min, "-", leeftijd_max - 1),
select(postcode, geslacht, leeftijd, inwoners) %>% leeftijd_nieuw = gsub("95-NA", "95+", leeftijd_nieuw),
pivot_wider(names_from = geslacht, values_from = inwoners) leeftijd = factor(leeftijd_nieuw, levels = levels(age_groups(0, 5 * c(1:19))), ordered = TRUE)) %>%
# alle PC2 en PC3 toevoegen select(postcode, geslacht, leeftijd, inwoners) %>%
inwoners_per_postcode_leeftijd <- inwoners_per_postcode_leeftijd %>% pivot_wider(names_from = geslacht, values_from = inwoners)
bind_rows(inwoners_per_postcode_leeftijd %>% # alle PC2 en PC3 toevoegen
group_by(postcode = clean_numeric(substr(postcode, 1, 2)), leeftijd) %>% inwoners_per_postcode_leeftijd <- inwoners_per_postcode_leeftijd %>%
summarise_all(sum)) %>% bind_rows(inwoners_per_postcode_leeftijd %>%
bind_rows(inwoners_per_postcode_leeftijd %>% group_by(postcode = clean_numeric(substr(postcode, 1, 2)), leeftijd) %>%
group_by(postcode = clean_numeric(substr(postcode, 1, 3)), leeftijd) %>% summarise_all(sum)) %>%
summarise_all(sum)) %>% bind_rows(inwoners_per_postcode_leeftijd %>%
arrange(postcode, leeftijd) group_by(postcode = clean_numeric(substr(postcode, 1, 3)), leeftijd) %>%
summarise_all(sum)) %>%
arrange(postcode, leeftijd)
# Postcodes (wordt later alle referentiedata aan toegevoegd) --------------
# `postcodes` is hier de vorige versie die we als `postcodes` gebruikten, deze wordt vernieuwd # Postcodes (wordt later alle referentiedata aan toegevoegd) --------------
postcodes_plaats_gemeente <- postcodes %>%
filter(postcode > 999) %>% # alleen PC4 houden, wordt later weer aangevuld met PC2 en PC3 # `postcodes` is hier de vorige versie die we als `postcodes` gebruikten, deze wordt vernieuwd
select(postcode, plaats, gemeente) postcodes_plaats_gemeente <- postcodes %>%
filter(postcode > 999) %>% # alleen PC4 houden, wordt later weer aangevuld met PC2 en PC3
postcodes <- read_csv2(postcodes_bestand) select(postcode, plaats, gemeente)
colnames(postcodes) <- gsub("(man|vrouw)n?en", "\\1", colnames(postcodes))
postcodes <- read_csv2(postcodes_bestand)
colnames(postcodes) <- gsub("(man|vrouw)n?en", "\\1", colnames(postcodes))
# Postcode-4 kaart --------------------------------------------------------
# we gebruiken deze postcodekaart om te bepalen welke postcodes in welk gebied liggen met sf::st_intersects(). # Postcode-4 kaart --------------------------------------------------------
# dus de geometrie van postcode 9251 valt in het snijvlak van de de geometrie van de gemeente Tytsjerksteradiel
# en dus is Tytsjerksteradiel de gemeente van postcode 9251 (en zo verder voor NUTS-3, GGD-regio, ...) # we gebruiken deze postcodekaart om te bepalen welke postcodes in welk gebied liggen met sf::st_intersects().
postcodes4 <- st_read(postcodes4_bestand) # dus de geometrie van postcode 9251 valt in het snijvlak van de de geometrie van de gemeente Tytsjerksteradiel
postcodes4 <- kaart_fixen(postcodes4) # en dus is Tytsjerksteradiel de gemeente van postcode 9251 (en zo verder voor NUTS-3, GGD-regio, ...)
# alleen relevante kolommen houden postcodes4 <- st_read(postcodes4_bestand)
postcodes4 <- postcodes4 %>% postcodes4 <- kaart_fixen(postcodes4)
transmute(postcode = as.double(as.character(PC4)), # alleen relevante kolommen houden
huishoudens = ifelse(AANTAL_HH < 0, NA_real_, AANTAL_HH), postcodes4 <- postcodes4 %>%
huishouden_grootte = ifelse(GEM_HH_GR < 0, NA_real_, GEM_HH_GR), transmute(postcode = as.double(as.character(PC4)),
area_km2 = as.double(st_area(geometry) / 1000 ^ 2), huishoudens = ifelse(AANTAL_HH < 0, NA_real_, AANTAL_HH),
geometry) huishouden_grootte = ifelse(GEM_HH_GR < 0, NA_real_, GEM_HH_GR),
area_km2 = as.double(st_area(geometry) / 1000 ^ 2),
geometry)
# Referentiewaarden aan `postcodes` toevoegen en kaarten opslaan ----------
relevante_lagen <- c("gemeente", # Referentiewaarden aan `postcodes` toevoegen en kaarten opslaan ----------
"provincie",
"nuts3", relevante_lagen <- c("gemeente",
"ggdregio", "provincie",
"jeugdregio", "nuts3",
"veiligheidsregio") "ggdregio",
for (i in 3:length(relevante_lagen)) { "jeugdregio",
message(">> zoeken naar ", relevante_lagen[i]) "veiligheidsregio")
kaart <- downloaden_transformeren(relevante_lagen[i]) for (i in 3:length(relevante_lagen)) {
message(">> zoeken naar ", relevante_lagen[i])
if (!relevante_lagen[i] %in% c("plaats", "gemeente")) { kaart <- downloaden_transformeren(relevante_lagen[i])
# referentiedata toevoegen aan 'postcodes'
p <- dplyr::progress_estimated(length(postcodes4$geometry)) if (!relevante_lagen[i] %in% c("plaats", "gemeente")) {
newvar <- character(length = nrow(postcodes4)) # referentiedata toevoegen aan 'postcodes'
for (pc in 1:nrow(postcodes4)) { p <- dplyr::progress_estimated(length(postcodes4$geometry))
p$tick()$print() newvar <- character(length = nrow(postcodes4))
suppressMessages( for (pc in 1:nrow(postcodes4)) {
verschillen <- as.double(st_area(st_difference(postcodes4 %>% slice(pc), p$tick()$print()
kaart)) / suppressMessages(
st_area(postcodes4 %>% slice(pc))) verschillen <- as.double(st_area(st_difference(postcodes4 %>% slice(pc),
) kaart)) /
if (any(verschillen < 1)) { st_area(postcodes4 %>% slice(pc)))
newvar[pc] <- as.character(kaart[, 1, drop = TRUE])[verschillen == min(verschillen)] )
} else { if (any(verschillen < 1)) {
kaart_ind <- as.double(suppressMessages(st_intersects(postcodes4 %>% slice(pc), kaart)))[1] newvar[pc] <- as.character(kaart[, 1, drop = TRUE])[verschillen == min(verschillen)]
newvar[pc] <- as.character(kaart[, 1, drop = TRUE])[kaart_ind] } else {
} kaart_ind <- as.double(suppressMessages(st_intersects(postcodes4 %>% slice(pc), kaart)))[1]
} newvar[pc] <- as.character(kaart[, 1, drop = TRUE])[kaart_ind]
newdf <- data.frame(postcode = as.double(postcodes4$postcode), }
newvar = as.character(newvar), stringsAsFactors = FALSE) }
postcodes <- postcodes %>% newdf <- data.frame(postcode = as.double(postcodes4$postcode),
left_join(newdf, by = "postcode") newvar = as.character(newvar), stringsAsFactors = FALSE)
colnames(postcodes)[colnames(postcodes) == "newvar"] <- relevante_lagen[i] postcodes <- postcodes %>%
} left_join(newdf, by = "postcode")
colnames(postcodes)[colnames(postcodes) == "newvar"] <- relevante_lagen[i]
object_naam <- case_when(relevante_lagen[i] == "gemeente" ~ "gemeenten", }
relevante_lagen[i] == "nuts3" ~ "nuts3regios",
TRUE ~ paste0(relevante_lagen[i], "s")) object_naam <- case_when(relevante_lagen[i] == "gemeente" ~ "gemeenten",
relevante_lagen[i] == "nuts3" ~ "nuts3regios",
# kaart opslaan in Global Environment TRUE ~ paste0(relevante_lagen[i], "s"))
assign(x = object_naam,
value = kaart, # kaart opslaan in Global Environment
envir = globalenv()) assign(x = object_naam,
# kaart opslaan op schijf value = kaart,
saveRDS(object = kaart, envir = globalenv())
file = paste0(object_naam, ".rds"), # kaart opslaan op schijf
version = 2, saveRDS(object = kaart,
compress = "xz") file = paste0(object_naam, ".rds"),
} version = 2,
compress = "xz")
# uit PC4-kaart van CBS ook nog wat kolommen halen, en die hoeven niet in dat kaartobject }
postcodes <- postcodes %>%
left_join(postcodes_plaats_gemeente, by = "postcode") %>% # uit PC4-kaart van CBS ook nog wat kolommen halen, en die hoeven niet in dat kaartobject
select(postcode, matches("inwoner"), "plaats", "gemeente", "provincie", everything()) %>% postcodes <- postcodes %>%
left_join(postcodes4 %>% left_join(postcodes_plaats_gemeente, by = "postcode") %>%
as.data.frame(stringsAsFactors = FALSE) %>% select(postcode, matches("inwoner"), "plaats", "gemeente", "provincie", everything()) %>%
select(-area_km2, -geometry), left_join(postcodes4 %>%
by = "postcode") as.data.frame(stringsAsFactors = FALSE) %>%
select(-area_km2, -geometry),
# alles van PC2 en PC3 toevoegen by = "postcode")
postcodes <- postcodes %>%
bind_rows(postcodes %>% # alles van PC2 en PC3 toevoegen
group_by(postcode = clean_numeric(substr(postcode, 1, 2))) %>% postcodes <- postcodes %>%
summarise_all(function(x, ...) { bind_rows(postcodes %>%
if (is.numeric(x) & any(x > 20)) { group_by(postcode = clean_numeric(substr(postcode, 1, 2))) %>%
# inwoners en aantal huishoudens summarise_all(function(x, ...) {
sum(x, na.rm = TRUE) if (is.numeric(x) & any(x > 20)) {
} else if (is.numeric(x)) { # inwoners en aantal huishoudens
# gemiddelde grootte van huishoudens sum(x, na.rm = TRUE)
mean(x, na.rm = TRUE) } else if (is.numeric(x)) {
} else { # gemiddelde grootte van huishoudens
x[1] mean(x, na.rm = TRUE)
} } else {
})) %>% x[1]
bind_rows(postcodes %>% }
group_by(postcode = clean_numeric(substr(postcode, 1, 3))) %>% })) %>%
summarise_all(function(x, ...) { bind_rows(postcodes %>%
if (is.numeric(x) & any(x > 20)) { group_by(postcode = clean_numeric(substr(postcode, 1, 3))) %>%
# inwoners en aantal huishoudens summarise_all(function(x, ...) {
sum(x, na.rm = TRUE) if (is.numeric(x) & any(x > 20)) {
} else if (is.numeric(x)) { # inwoners en aantal huishoudens
# gemiddelde grootte van huishoudens sum(x, na.rm = TRUE)
mean(x, na.rm = TRUE) } else if (is.numeric(x)) {
} else { # gemiddelde grootte van huishoudens
x[1] mean(x, na.rm = TRUE)
} } else {
})) %>% x[1]
arrange(postcode) }
})) %>%
arrange(postcode)