In joebrew/tango: Tango
knitr::opts_chunk$set(
collapse = TRUE,
comment = NA,
echo = TRUE,
warning = FALSE,
message = FALSE,
error = TRUE,
cache = FALSE,
fig.path = "man/figures/README-",
out.width = "100%"
)
Tango
Chaccour and Brew
# Load the package for this project
library(tango)
# Load other useful packages
library(knitr)
library(tidyr)
library(dplyr)
library(sp)
library(ggplot2)
library(RColorBrewer)
# Get census age data
census <- tango::census
# Get municipios spatial data
municipios <- tango::municipios
# Get census age data
census <- diadespres::census
#43 = Tarragona
#08 = Barcelona
#25 = Lleida
#17 = Girona
catalan_codes <- c('43', '08', '25', '17')
census <- census %>%
filter(substr(id, 1, 2) %in% catalan_codes)
# Get municipios spatial data
municipios <- diadespres::municipios
municipios <- municipios[substr(municipios@data$id, 1, 2) %in% catalan_codes, ]
# Order census by pop
by_pop <- census %>%
group_by(id, municipio) %>%
summarise(pop = sum(total, na.rm = T)) %>%
ungroup %>%
arrange(desc(pop)) %>%
mutate(p = pop / sum(pop) * 100) %>%
mutate(cp = cumsum(p))
areas <- rgeos::gArea(municipios, byid = T)
# Make plot by percentage
make_plot <- function(cut_off = 30){
sub_pop <- by_pop %>%
filter(cp <= cut_off)
keep <- municipios@data$id %in% sub_pop$id
keep_areas <- areas[keep]
sub_municipios <- municipios[keep,]
sub_municipios@data$area <- keep_areas
space_take_up <- round(sum(keep_areas) / sum(areas) * 100, digits = 1)
plot(municipios)
plot(sub_municipios, col = 'red', add = T)
title(main = paste0(max(round(sub_pop$cp)), '% of Catalans live in the red area (', space_take_up, ' % of area)' ))
}
# for(i in c( seq(30, 90, by = 10), 92, 94, 96, 98, 99)){
# make_plot(cut_off = i)
# }
Plots for 2020-04-06
Population density
# # Project municipalities
# municipios_proj <- spTransform(municipios, CRS("+proj=lcc +lat_1=40 +lat_0=40 +lon_0=0 +k_0=0.9988085293 +x_0=600000 +y_0=600000 +a=6378298.3 +b=6356657.142669561 +pm=madrid +units=m +no_defs"))
# Get area for each municipality
areas_km <- raster::area(municipios) / 1000000
# Add to municipios
map <- municipios
map@data$area_km <- areas_km
# Get population numbers to plug into municipios
right <- census %>%
group_by(id) %>%
summarise(pop = sum(total, na.rm = TRUE),
pop60 = sum(total[edad >= 60], na.rm = TRUE),
pop50 = sum(total[edad >= 50], na.rm = TRUE),
pop70 = sum(total[edad >= 70], na.rm = TRUE),
pop80 = sum(total[edad >= 80], na.rm = TRUE),
pop90 = sum(total[edad >= 90], na.rm = TRUE),
popl60 = sum(total[edad < 60], na.rm = TRUE),
popl50 = sum(total[edad < 50], na.rm = TRUE),
popl70 = sum(total[edad < 70], na.rm = TRUE),
popl80 = sum(total[edad < 80], na.rm = TRUE),
popl90 = sum(total[edad < 90], na.rm = TRUE))
map@data <-
left_join(map@data,
right)
map@data <- map@data %>%
mutate(pop_per_km = pop / area_km,
pop50_per_km = pop50 / area_km,
pop60_per_km = pop60 / area_km,
pop70_per_km = pop70 / area_km,
pop80_per_km = pop80 / area_km,
pop90_per_km = pop90 / area_km,
popl50_per_km = popl50 / area_km,
popl60_per_km = popl60 / area_km,
popl70_per_km = popl70 / area_km,
popl80_per_km = popl80 / area_km,
popl90_per_km = popl90 / area_km) %>%
mutate(ratio60 = popl60 / pop60,
ratio50 = popl50 / pop50,
ratio70 = popl70 / pop70,
ratio80 = popl80 / pop80,
ratio90 = popl90 / pop90)
big_right <- map@data
# Fortify
mapf <- fortify(map, region = 'id')
library(ggthemes)
50 -/+ ratio
map@data$ratiox <- ifelse(map@data$ratio50 < 1,
'0-1',
ifelse(map@data$ratio50 <2,
'1-2',
ifelse(map@data$ratio50 < 3,
'2-3',
ifelse(map@data$ratio50 < 4,
'3-4',
'4+'))))
shp <- mapf %>%
left_join(map@data[,c('id', 'ratiox')])
cols <- rev(RColorBrewer::brewer.pal(n = 5, name = 'Spectral'))
ggplot(data = shp,
aes(x = long,
y = lat,
group = group,
fill = factor(ratiox))) +
geom_polygon(color = 'black',
size = 0.2) +
theme_map() +
theme(plot.title = element_text(size = 16),
legend.position = 'right') +
scale_fill_manual(name ='',
values = cols) +
labs(title = 'Ratio of people younger than 50 to people older than 50')
Table of cut-offs and population affected. How to read:
-Cut off: We apply measures to all towns with this ratio, or lower, of young to old
-Below: Means that the measures are applied
-Above: means that the measures are not applied.
pop <- sum(map@data$pop)
out_list <- list()
cut_offs <- c(1, 1.5, 1.7, 1.8, 1.9, 2, 3, 4, 5)
for(i in 1:length(cut_offs)){
this_cut_off <- cut_offs[i]
out <- data.frame(cut_off = this_cut_off)
out$under_50s_affected <- sum(map@data$popl50[map@data$ratio50 < this_cut_off])
out$over_50s_protected <- sum(map@data$pop50[map@data$ratio50 < this_cut_off])
out$pop_below_cut_off <- sum(map@data$pop[map@data$ratio50 < this_cut_off])
out$pop_above_cut_off <- sum(map@data$pop[map@data$ratio50 >= this_cut_off])
out$p_below_cut_off <- round(out$pop_below_cut_off / pop * 100, digits = 2)
out$p_above_cut_off <- round(out$pop_above_cut_off / pop * 100, digits = 2)
out$municipalities_below_cut_off <- length(map@data$pop[map@data$ratio50 < this_cut_off])
out$municipalities_above_cut_off <- length(map@data$pop[map@data$ratio50 >= this_cut_off])
out_list[[i]] <- out
}
out <- bind_rows(out_list)
knitr::kable(out)
cut_pretty <- function(x, breaks, collapse=" to ", ...) {
breaks[1] <- floor(breaks[1])
breaks[length(breaks)] <- ceiling(breaks[length(breaks)])
breaks[2:(length(breaks)-1)] <- round(breaks[2:(length(breaks)-1)])
breaks <- unique(breaks)
it_breaks <- itertools2::ipairwise(breaks)
breaks_pretty <- sapply(it_breaks, paste, collapse=collapse)
cut(x, breaks=breaks, labels=breaks_pretty, ...)
}
# Define variable for plotting var
plot_var <- function(var = 'pop', return_table = 0, quant = T, n = 5){
sub_map <- mapf
right <- big_right[,c('id', var)]
sub_map <- left_join(sub_map, right)
names(sub_map)[ncol(sub_map)] <- 'var'
if(return_table > 0){
out <- big_right[,c('id', 'NAMEUNIT', var)]
names(out)[ncol(out)] <- 'var'
out <- out %>% arrange(desc(var))
names(out)[ncol(out)] <- var
out$pop <- big_right$pop
names(out)[2] <- 'Nom'
out <- out[1:return_table,]
out
} else {
if(quant){
x <-cut_pretty(sub_map$var, breaks = unique(unique(quantile(right[,2], probs = seq(0, 1, length = n)))))
sub_map$var <- x
cols <- rev(RColorBrewer::brewer.pal(n = 4, name = 'Spectral'))
ggplot(data = sub_map,
aes(x = long,
y = lat,
group = group,
fill = factor(var))) +
geom_polygon(color = 'black',
size = 0.2) +
theme_map() +
theme(plot.title = element_text(size = 16),
legend.position = 'right') +
scale_fill_manual(name ='',
values = cols)
} else {
cols <- rev(RColorBrewer::brewer.pal(n = 9, name = 'Spectral'))
ggplot(data = sub_map,
aes(x = long,
y = lat,
group = group,
fill = var)) +
geom_polygon(color = 'black',
size = 0.2) +
theme_map() +
theme(plot.title = element_text(size = 16),
legend.position = 'right') +
scale_fill_gradientn(name ='',
colors = cols)
}
}
}
Population
plot_var('pop') +
labs(title = 'Population per municipality')
Population density
plot_var('pop_per_km') +
labs(title = 'Population per sq km')
Top 10:
plot_var('pop_per_km', return_table = 10)
Population density of 50+ year-olds
plot_var('pop50_per_km') +
labs(title = 'Population of people aged 50+ per sq km')
Top 10:
plot_var('pop50_per_km', return_table = 10)
Population density of 60+ year-olds
plot_var('pop60_per_km') +
labs(title = 'Population of people aged 60+ per sq km')
Top 10:
plot_var('pop60_per_km', return_table = 10)
Population density of 70+ year-olds
plot_var('pop70_per_km') +
labs(title = 'Population of people aged 70+ per sq km')
Top 10:
plot_var('pop70_per_km', return_table = 10)
Population density of 80+ year-olds
plot_var('pop80_per_km') +
labs(title = 'Population of people aged 80+ per sq km')
Top 10:
plot_var('pop80_per_km', return_table = 10)
Ratio of under-50s to 50+
(ie, ratio of protectors to protected)
plot_var('ratio50', n = 10) +
labs(title = 'Ratio of under-50s to 50+')
Top 10:
plot_var('ratio50', return_table = 10)
Ratio of under-60s to 60+
(ie, ratio of protectors to protected)
plot_var('ratio60') +
labs(title = 'Ratio of under-60s to 60+')
Top 10:
plot_var('ratio60', return_table = 10)
Ratio of under-70s to 70+
(ie, ratio of protectors to protected)
plot_var('ratio70') +
labs(title = 'Ratio of under-70s to 70+')
Top 10:
plot_var('ratio70', return_table = 10)
Ratio of under-80s to 80+
(ie, ratio of protectors to protected)
plot_var('ratio80') +
labs(title = 'Ratio of under-80s to 80+')
Top 10:
plot_var('ratio80', return_table = 10)
joebrew/tango documentation built on April 7, 2020, 1:08 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
knitr::opts_chunk$set( collapse = TRUE, comment = NA, echo = TRUE, warning = FALSE, message = FALSE, error = TRUE, cache = FALSE, fig.path = "man/figures/README-", out.width = "100%" )
Tango
Chaccour and Brew
# Load the package for this project library(tango) # Load other useful packages library(knitr) library(tidyr) library(dplyr) library(sp) library(ggplot2) library(RColorBrewer) # Get census age data census <- tango::census # Get municipios spatial data municipios <- tango::municipios # Get census age data census <- diadespres::census #43 = Tarragona #08 = Barcelona #25 = Lleida #17 = Girona catalan_codes <- c('43', '08', '25', '17') census <- census %>% filter(substr(id, 1, 2) %in% catalan_codes) # Get municipios spatial data municipios <- diadespres::municipios municipios <- municipios[substr(municipios@data$id, 1, 2) %in% catalan_codes, ] # Order census by pop by_pop <- census %>% group_by(id, municipio) %>% summarise(pop = sum(total, na.rm = T)) %>% ungroup %>% arrange(desc(pop)) %>% mutate(p = pop / sum(pop) * 100) %>% mutate(cp = cumsum(p)) areas <- rgeos::gArea(municipios, byid = T) # Make plot by percentage make_plot <- function(cut_off = 30){ sub_pop <- by_pop %>% filter(cp <= cut_off) keep <- municipios@data$id %in% sub_pop$id keep_areas <- areas[keep] sub_municipios <- municipios[keep,] sub_municipios@data$area <- keep_areas space_take_up <- round(sum(keep_areas) / sum(areas) * 100, digits = 1) plot(municipios) plot(sub_municipios, col = 'red', add = T) title(main = paste0(max(round(sub_pop$cp)), '% of Catalans live in the red area (', space_take_up, ' % of area)' )) } # for(i in c( seq(30, 90, by = 10), 92, 94, 96, 98, 99)){ # make_plot(cut_off = i) # }
Plots for 2020-04-06
Population density
# # Project municipalities # municipios_proj <- spTransform(municipios, CRS("+proj=lcc +lat_1=40 +lat_0=40 +lon_0=0 +k_0=0.9988085293 +x_0=600000 +y_0=600000 +a=6378298.3 +b=6356657.142669561 +pm=madrid +units=m +no_defs")) # Get area for each municipality areas_km <- raster::area(municipios) / 1000000 # Add to municipios map <- municipios map@data$area_km <- areas_km # Get population numbers to plug into municipios right <- census %>% group_by(id) %>% summarise(pop = sum(total, na.rm = TRUE), pop60 = sum(total[edad >= 60], na.rm = TRUE), pop50 = sum(total[edad >= 50], na.rm = TRUE), pop70 = sum(total[edad >= 70], na.rm = TRUE), pop80 = sum(total[edad >= 80], na.rm = TRUE), pop90 = sum(total[edad >= 90], na.rm = TRUE), popl60 = sum(total[edad < 60], na.rm = TRUE), popl50 = sum(total[edad < 50], na.rm = TRUE), popl70 = sum(total[edad < 70], na.rm = TRUE), popl80 = sum(total[edad < 80], na.rm = TRUE), popl90 = sum(total[edad < 90], na.rm = TRUE)) map@data <- left_join(map@data, right) map@data <- map@data %>% mutate(pop_per_km = pop / area_km, pop50_per_km = pop50 / area_km, pop60_per_km = pop60 / area_km, pop70_per_km = pop70 / area_km, pop80_per_km = pop80 / area_km, pop90_per_km = pop90 / area_km, popl50_per_km = popl50 / area_km, popl60_per_km = popl60 / area_km, popl70_per_km = popl70 / area_km, popl80_per_km = popl80 / area_km, popl90_per_km = popl90 / area_km) %>% mutate(ratio60 = popl60 / pop60, ratio50 = popl50 / pop50, ratio70 = popl70 / pop70, ratio80 = popl80 / pop80, ratio90 = popl90 / pop90) big_right <- map@data # Fortify mapf <- fortify(map, region = 'id') library(ggthemes)
50 -/+ ratio
map@data$ratiox <- ifelse(map@data$ratio50 < 1, '0-1', ifelse(map@data$ratio50 <2, '1-2', ifelse(map@data$ratio50 < 3, '2-3', ifelse(map@data$ratio50 < 4, '3-4', '4+')))) shp <- mapf %>% left_join(map@data[,c('id', 'ratiox')]) cols <- rev(RColorBrewer::brewer.pal(n = 5, name = 'Spectral')) ggplot(data = shp, aes(x = long, y = lat, group = group, fill = factor(ratiox))) + geom_polygon(color = 'black', size = 0.2) + theme_map() + theme(plot.title = element_text(size = 16), legend.position = 'right') + scale_fill_manual(name ='', values = cols) + labs(title = 'Ratio of people younger than 50 to people older than 50')
Table of cut-offs and population affected. How to read:
-Cut off: We apply measures to all towns with this ratio, or lower, of young to old -Below: Means that the measures are applied -Above: means that the measures are not applied.
pop <- sum(map@data$pop) out_list <- list() cut_offs <- c(1, 1.5, 1.7, 1.8, 1.9, 2, 3, 4, 5) for(i in 1:length(cut_offs)){ this_cut_off <- cut_offs[i] out <- data.frame(cut_off = this_cut_off) out$under_50s_affected <- sum(map@data$popl50[map@data$ratio50 < this_cut_off]) out$over_50s_protected <- sum(map@data$pop50[map@data$ratio50 < this_cut_off]) out$pop_below_cut_off <- sum(map@data$pop[map@data$ratio50 < this_cut_off]) out$pop_above_cut_off <- sum(map@data$pop[map@data$ratio50 >= this_cut_off]) out$p_below_cut_off <- round(out$pop_below_cut_off / pop * 100, digits = 2) out$p_above_cut_off <- round(out$pop_above_cut_off / pop * 100, digits = 2) out$municipalities_below_cut_off <- length(map@data$pop[map@data$ratio50 < this_cut_off]) out$municipalities_above_cut_off <- length(map@data$pop[map@data$ratio50 >= this_cut_off]) out_list[[i]] <- out } out <- bind_rows(out_list) knitr::kable(out)
cut_pretty <- function(x, breaks, collapse=" to ", ...) { breaks[1] <- floor(breaks[1]) breaks[length(breaks)] <- ceiling(breaks[length(breaks)]) breaks[2:(length(breaks)-1)] <- round(breaks[2:(length(breaks)-1)]) breaks <- unique(breaks) it_breaks <- itertools2::ipairwise(breaks) breaks_pretty <- sapply(it_breaks, paste, collapse=collapse) cut(x, breaks=breaks, labels=breaks_pretty, ...) } # Define variable for plotting var plot_var <- function(var = 'pop', return_table = 0, quant = T, n = 5){ sub_map <- mapf right <- big_right[,c('id', var)] sub_map <- left_join(sub_map, right) names(sub_map)[ncol(sub_map)] <- 'var' if(return_table > 0){ out <- big_right[,c('id', 'NAMEUNIT', var)] names(out)[ncol(out)] <- 'var' out <- out %>% arrange(desc(var)) names(out)[ncol(out)] <- var out$pop <- big_right$pop names(out)[2] <- 'Nom' out <- out[1:return_table,] out } else { if(quant){ x <-cut_pretty(sub_map$var, breaks = unique(unique(quantile(right[,2], probs = seq(0, 1, length = n))))) sub_map$var <- x cols <- rev(RColorBrewer::brewer.pal(n = 4, name = 'Spectral')) ggplot(data = sub_map, aes(x = long, y = lat, group = group, fill = factor(var))) + geom_polygon(color = 'black', size = 0.2) + theme_map() + theme(plot.title = element_text(size = 16), legend.position = 'right') + scale_fill_manual(name ='', values = cols) } else { cols <- rev(RColorBrewer::brewer.pal(n = 9, name = 'Spectral')) ggplot(data = sub_map, aes(x = long, y = lat, group = group, fill = var)) + geom_polygon(color = 'black', size = 0.2) + theme_map() + theme(plot.title = element_text(size = 16), legend.position = 'right') + scale_fill_gradientn(name ='', colors = cols) } } }
Population
plot_var('pop') + labs(title = 'Population per municipality')
Population density
plot_var('pop_per_km') + labs(title = 'Population per sq km')
Top 10:
plot_var('pop_per_km', return_table = 10)
Population density of 50+ year-olds
plot_var('pop50_per_km') + labs(title = 'Population of people aged 50+ per sq km')
Top 10:
plot_var('pop50_per_km', return_table = 10)
Population density of 60+ year-olds
plot_var('pop60_per_km') + labs(title = 'Population of people aged 60+ per sq km')
Top 10:
plot_var('pop60_per_km', return_table = 10)
Population density of 70+ year-olds
plot_var('pop70_per_km') + labs(title = 'Population of people aged 70+ per sq km')
Top 10:
plot_var('pop70_per_km', return_table = 10)
Population density of 80+ year-olds
plot_var('pop80_per_km') + labs(title = 'Population of people aged 80+ per sq km')
Top 10:
plot_var('pop80_per_km', return_table = 10)
Ratio of under-50s to 50+
(ie, ratio of protectors to protected)
plot_var('ratio50', n = 10) + labs(title = 'Ratio of under-50s to 50+')
Top 10:
plot_var('ratio50', return_table = 10)
Ratio of under-60s to 60+
(ie, ratio of protectors to protected)
plot_var('ratio60') + labs(title = 'Ratio of under-60s to 60+')
Top 10:
plot_var('ratio60', return_table = 10)
Ratio of under-70s to 70+
(ie, ratio of protectors to protected)
plot_var('ratio70') + labs(title = 'Ratio of under-70s to 70+')
Top 10:
plot_var('ratio70', return_table = 10)
Ratio of under-80s to 80+
(ie, ratio of protectors to protected)
plot_var('ratio80') + labs(title = 'Ratio of under-80s to 80+')
Top 10:
plot_var('ratio80', return_table = 10)
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.