Population Demographics In Canada
Graphs of population demographics in Canada using STATCAN data
Data
STATCAN Table: 17-10-0009-01
STATCAN Table: 17-10-0005-01
Prepare Data
# devtools::install_github("derekmichaelwright/agData")
library(agData)
library(gganimate)
library(transformr)
# Prep data
<- "www.dblogr.com/ or derekmichaelwright.github.io/dblogr/ | Data: STATCAN"
myCaption <- c("steelblue", "palevioletred3")
myColorsMF <- c("darkgoldenrod3", "darkred", "darkgreen", "darkslategray",
myColorsP "darkblue", "steelblue", "maroon4", "purple4", "cyan4", "burlywood4")
<- c("0 to 4 years", "5 to 9 years",
myAges "10 to 14 years", "15 to 19 years",
"20 to 24 years", "25 to 29 years",
"30 to 34 years", "35 to 39 years",
"40 to 44 years", "45 to 49 years",
"50 to 54 years", "55 to 59 years",
"60 to 64 years", "65 to 69 years",
"70 to 74 years", "75 to 79 years",
"80 to 84 years", "85 to 89 years",
"90 to 94 years", "95 to 99 years",
"100 years and over", "Median age")
<- c("Canada", "British Columbia", "Alberta", "Saskatchewan", "Manitoba",
myAreas "Ontario", "Quebec", "New Brunswick", "Prince Edward Island",
"Nova Scotia", "Newfoundland and Labrador",
"Yukon", "NWT & Nunavut", "Northwest Territories", "Nunavut")
<- c("CA", "BC", "AB", "SK", "MB",
myAreasShort "ON", "QC", "NB", "PE", "NS", "NL",
"YT", "NTNU", "NT", "NU")
#
<- read.csv("1710000901_databaseLoadingData.csv") %>%
d1 select(Year=1, Area=GEO, Unit=UOM, Value=VALUE) %>%
mutate(Area = gsub("Northwest Territories including", "NWT &", Area),
Area = factor(Area, levels = myAreas),
AreaShort = plyr::mapvalues(Area, myAreas, myAreasShort),
Month = substr(Year, 6, 8),
Year = substr(Year, 1,4),
Year = as.numeric(Year),
Month = as.numeric(Month),
Date = as.Date(paste(Year, Month, "01", sep = "-")))
#
<- read.csv("1710000501_databaseLoadingData.csv") %>%
d2 select(Year=1, Area=GEO, Sex, Age=Age.group, Unit=UOM, Value=VALUE) %>%
mutate(Area = gsub("Northwest Territories including", "NWT &", Area),
Area = factor(Area, levels = myAreas),
Sex = factor(Sex, levels = c("Both sexes", "Males", "Females")),
Age = factor(Age, levels = myAges),
Year = substr(Year, 1,4),
Year = as.numeric(Year)) %>%
filter(!is.na(Age))
Population
Canada
# Prep data
<- d1 %>% filter(Area == "Canada")
xx <- as.Date(paste0(seq(1950, 2020, by = 10), "-01-01"))
myBreaks # Plot
<- ggplot(xx, aes(x = Date, y = Value / 1000000)) +
mp geom_col(fill = "darkgreen", alpha = 0.7) +
facet_wrap(Area ~ ., ncol = 4, scales = "free_y") +
scale_x_date(breaks = myBreaks, date_labels = "%Y") +
theme_agData(legend.position = "none") +
labs(y = "Million People", x = NULL, caption = myCaption)
ggsave("canada_population_1_01.png", mp, width = 6, height = 4)
Saskatchewan
# Prep data
<- d1 %>% filter(Area == "Saskatchewan")
xx <- as.Date(paste0(seq(1950, 2020, by = 10), "-01-01"))
myBreaks # Plot
<- ggplot(xx, aes(x = Date, y = Value / 1000000)) +
mp geom_col(fill = "darkgreen", alpha = 0.7) +
facet_wrap(Area ~ ., ncol = 4, scales = "free_y") +
scale_x_date(breaks = myBreaks, date_labels = "%Y") +
theme_agData(legend.position = "none") +
labs(y = "Million People", x = NULL, caption = myCaption)
ggsave("canada_population_1_02.png", mp, width = 6, height = 4)
All Provinces
# Prep data
<- as.Date(paste0(seq(1950, 2020, by = 10), "-01-01"))
myBreaks # Plot
<- ggplot(d1, aes(x = Date, y = Value / 1000000)) +
mp geom_col(fill = "darkgreen", alpha = 0.7) +
facet_wrap(Area ~ ., ncol = 5, scales = "free_y") +
scale_x_date(breaks = myBreaks, date_labels = "%Y") +
theme_agData(legend.position = "none",
axis.text.x = element_text(angle = 45, hjust = 1)) +
labs(y = "Million People", x = NULL, caption = myCaption)
ggsave("canada_population_1_03.png", mp, width = 14, height = 6)
2021
# Prep data
<- d1 %>% filter(!AreaShort %in% c("CA", "NU", "NT", "YT", "NTNU"),
xx %in% c(1960, 2023), Month == 1) %>%
Year mutate(Year = factor(Year))
# Plot
<- ggplot(xx, aes(x = AreaShort, y = Value / 1000000, fill = Area, alpha = Year)) +
mp geom_col(position = "dodge", color = "black") +
scale_fill_manual(name = NULL, values = myColorsP, guide = F) +
scale_alpha_manual(name = NULL, values = c(0.4, 0.8)) +
scale_y_continuous(minor_breaks = 1:16) +
theme_agData(legend.position = "bottom",
axis.text.x = element_text(angle = 45, hjust = 1)) +
labs(title = "Population Growth In Canada", x = NULL,
y = "Million People", caption = myCaption)
ggsave("canada_population_1_04.png", mp, width = 6, height = 4)
Western Canada
# Prep data
<- d1 %>% filter(Area %in% myAreas[2:5])
xx # Plot
<- ggplot(xx, aes(x = Date, y = Value / 1000000, color = Area)) +
mp geom_line(size = 1.25, alpha = 0.7) +
scale_color_manual(name = NULL, values = myColorsP) +
theme_agData() +
labs(title = "Western Canada Population Growth",
y = "Million People", x = NULL, caption = myCaption)
ggsave("canada_population_1_05.png", mp, width = 6, height = 4)
Growth Rate
# Prep data
<- d1 %>%
xx filter(Month == 1,
%in% c("British Columbia", "Alberta", "Saskatchewan", "Manitoba",
Area "Ontario", "Quebec", "New Brunswick", "Nova Scotia")) %>%
mutate(Group = ifelse(Area %in% c("British Columbia", "Alberta",
"Saskatchewan", "Manitoba"),
"West", "East"),
Group = factor(Group, levels = c("West", "East")),
Rate = NA)
for(i in 1:nrow(xx)) {
<- xx$Value[xx$Year == xx$Year[i]-1 & xx$Area == xx$Area[i]]
priorV if(length(priorV)>0) { xx$Rate[i] <- 1000 * (xx$Value[i] - priorV) / priorV }
}# Plot
<- ggplot(xx, aes(x = Year, y = Rate, color = Area)) +
mp geom_line(size = 1.25, alpha = 0.7) +
facet_grid(. ~ Group) +
scale_color_manual(name = NULL, values = myColorsP) +
scale_x_continuous(breaks = seq(1950, 2020, by = 10)) +
theme_agData(legend.position = "bottom") +
labs(title = "Population Growth Rate In Canada", x = NULL,
y = "People Per 1000", caption = myCaption)
ggsave("canada_population_1_06.png", mp, width = 10, height = 5)
Median Age
Canada
# Prep data
<- d2 %>%
xx filter(Area == "Canada", Sex != "Both sexes", Age == "Median age")
# Plot
<- ggplot(xx, aes(x = Year, y = Value, color = Sex)) +
mp geom_line(size = 1.5, alpha = 0.7) +
scale_color_manual(name = NULL, values = myColorsMF) +
scale_x_continuous(minor_breaks = 1970:2025) +
scale_y_continuous(minor_breaks = 25:45) +
theme_agData(legend.position = "bottom") +
labs(title = "Median Age In Canada", x = NULL,
y = "Median Age", caption = myCaption)
ggsave("canada_population_1_07.png", mp, width = 6, height = 4)
Provinces
# Prep data
<- d2 %>%
xx filter(Sex != "Both sexes", Age == "Median age")
# Plot
<- ggplot(xx, aes(x = Year, y = Value, color = Sex)) +
mp geom_line() +
facet_wrap(Area ~ ., ncol = 5) +
scale_color_manual(name = NULL, values = myColorsMF) +
theme_agData(legend.position = "bottom") +
labs(title = "Median Age In Canada", x = NULL,
y = "Median Age", caption = myCaption)
ggsave("canada_population_1_08.png", mp, width = 10, height = 6)
Population Pyramids
<- function(myArea = "Saskatchewan", myYears = 2019 ) {
gg_PopDem_plot # Prep data
<- d2 %>%
xx filter(Area == myArea, Year %in% myYears,
!= "Median age", Sex != "Both sexes")
Age <- xx %>% spread(Sex, Value) %>%
yy mutate(Value = Females - Males,
Sex = ifelse(Value < 0, "Males", "Females"))
<- xx %>%
xx mutate(Value = ifelse(Sex == "Males", -Value, Value))
# Plot
ggplot(xx, aes(y = Value / 1000, x = Age, fill = Sex)) +
geom_col(color = "black", alpha = 0.7) +
geom_col(data = yy, color = "black", alpha = 0.7) +
scale_fill_manual(name = NULL, values = myColorsMF) +
#scale_x_discrete(sec.axis = sec_axis(~ .)) +
facet_grid(. ~ Year) +
theme_agData(legend.position = "bottom") +
labs(title = paste("Population in", myArea), x = NULL,
y = "Thousand People", caption = myCaption) +
coord_cartesian(ylim = c(-max(xx$Value), max(xx$Value))) +
coord_flip()
}
Canada
<- gg_PopDem_plot(myArea = "Canada", myYears = c(1971, 1995, 2021))
mp ggsave("canada_population_2_01.png", mp, width = 10, height = 4)
British Columbia
<- gg_PopDem_plot(myArea = "British Columbia", myYears = c(1971, 1995, 2021))
mp ggsave("canada_population_2_02.png", mp, width = 10, height = 4)
Alberta
<- gg_PopDem_plot(myArea = "Alberta", myYears = c(1971, 1995, 2021))
mp ggsave("canada_population_2_03.png", mp, width = 10, height = 4)
Saskatchewan
<- gg_PopDem_plot(myArea = "Saskatchewan", myYears = c(1971, 1995, 2021))
mp ggsave("canada_population_2_04.png", mp, width = 10, height = 4)
Manitoba
<- gg_PopDem_plot(myArea = "Manitoba", myYears = c(1971, 1995, 2021))
mp ggsave("canada_population_2_05.png", mp, width = 10, height = 4)
Ontario
<- gg_PopDem_plot(myArea = "Ontario", myYears = c(1971, 1995, 2021))
mp ggsave("canada_population_2_06.png", mp, width = 10, height = 4)
Quebec
<- gg_PopDem_plot(myArea = "Quebec", myYears = c(1971, 1995, 2021))
mp ggsave("canada_population_2_07.png", mp, width = 10, height = 4)
Newfoundland and Labrador
<- gg_PopDem_plot(myArea = "Newfoundland and Labrador",
mp myYears = c(1971, 1995, 2021))
ggsave("canada_population_2_08.png", mp, width = 10, height = 4)
Yukon
<- gg_PopDem_plot(myArea = "Yukon", myYears = c(1971, 1995, 2021))
mp ggsave("canada_population_2_09.png", mp, width = 10, height = 4)
Animated Population Pyramids
<- function(myArea = "Saskatchewan") {
gg_PopDem_anim # Prep data
<- d2 %>%
xx filter(Area %in% myArea, Age != "Median age", Sex != "Both sexes")
<- xx %>% spread(Sex, Value) %>%
yy mutate(Value = Females - Males,
Sex = ifelse(Value < 0, "Males", "Females"))
<- xx %>%
xx mutate(Value = ifelse(Sex == "Males", -Value, Value))
# Plot
ggplot(xx, aes(y = Value / 1000, x = Age, fill = Sex)) +
geom_col(color = "black", alpha = 0.7) +
geom_col(data = yy, color = "black", alpha = 0.7) +
scale_fill_manual(name = NULL, values = myColorsMF) +
facet_grid(. ~ Area) +
theme_agData(legend.position = "bottom") +
labs(title = title, y = "Thousand People", x = NULL, caption = myCaption) +
coord_cartesian(ylim = c(-max(xx$Value), max(xx$Value))) +
coord_flip() +
# gganimate specific bits
labs(title = paste(myArea, '{round(frame_time)}')) +
transition_time(Year) +
ease_aes('linear')
}
Canada
<- gg_PopDem_anim(myArea = "Canada")
mp anim_save("canada_population_gif_2_01.gif", mp,
nframes = 400, fps = 20, end_pause = 80,
width = 900, height = 600, res = 150)
British Columbia
<- gg_PopDem_anim(myArea = "British Columbia")
mp anim_save("canada_population_gif_2_02.gif", mp,
nframes = 400, fps = 20, end_pause = 80,
width = 900, height = 600, res = 150)
Alberta
<- gg_PopDem_anim(myArea = "Alberta")
mp anim_save("canada_population_gif_2_03.gif", mp,
nframes = 400, fps = 20, end_pause = 80,
width = 900, height = 600, res = 150)
Saskatchewan
<- gg_PopDem_anim(myArea = "Saskatchewan")
mp anim_save("canada_population_gif_2_04.gif", mp,
nframes = 400, fps = 20, end_pause = 80,
width = 900, height = 600, res = 150)
Manitoba
<- gg_PopDem_anim(myArea = "Manitoba")
mp anim_save("canada_population_gif_2_05.gif", mp,
nframes = 400, fps = 20, end_pause = 80,
width = 900, height = 600, res = 150)
Ontario
<- gg_PopDem_anim(myArea = "Ontario")
mp anim_save("canada_population_gif_2_06.gif", mp,
nframes = 400, fps = 20, end_pause = 80,
width = 900, height = 600, res = 150)
Quebec
<- gg_PopDem_anim(myArea = "Quebec")
mp anim_save("canada_population_gif_2_07.gif", mp,
nframes = 400, fps = 20, end_pause = 80,
width = 900, height = 600, res = 150)
Newfoundland and Labrador
<- gg_PopDem_anim(myArea = "Newfoundland and Labrador")
mp anim_save("canada_population_gif_2_08.gif", mp,
nframes = 400, fps = 20, end_pause = 80,
width = 900, height = 600, res = 150)
Yukon
<- gg_PopDem_anim(myArea = "Yukon")
mp anim_save("canada_population_gif_2_09.gif", mp,
nframes = 400, fps = 20, end_pause = 80,
width = 900, height = 600, res = 150)
Dual Year Population Pyramids
<- function(myArea = "Saskatchewan", myYears = c(1971,2022) ) {
gg_PopDem_plot2 # Prep data
<- d2 %>%
xx filter(Area == myArea, Year %in% myYears,
!= "Median age", Sex == "Both sexes")
Age <- xx %>% spread(Year, Value)
yy $Value <- yy[,6] - yy[,5]
yy<- yy %>%
yy mutate(Year = ifelse(Value < 0, myYears[1], myYears[2]),
Year = factor(Year))
<- xx %>%
xx mutate(Value = ifelse(Year == myYears[1], -Value, Value),
Year = factor(Year))
# Plot
ggplot(xx, aes(y = Value / 1000, x = Age, fill = Year)) +
geom_col(color = "black", alpha = 0.7) +
geom_col(data = yy, color = "black", alpha = 0.7) +
scale_fill_manual(name = NULL, values = c("darkgreen","purple4")) +
theme_agData(legend.position = "bottom") +
labs(title = paste("Population in", myArea), x = NULL,
y = "Thousand People", caption = myCaption) +
coord_cartesian(ylim = c(-max(xx$Value), max(xx$Value))) +
coord_flip()
}
Canada
<- gg_PopDem_plot2(myArea = "Canada")
mp ggsave("canada_population_3_01.png", mp, width = 6, height = 4)
British Columbia
<- gg_PopDem_plot2(myArea = "British Columbia")
mp ggsave("canada_population_3_02.png", mp, width = 6, height = 4)
Alberta
<- gg_PopDem_plot2(myArea = "Alberta")
mp ggsave("canada_population_3_03.png", mp, width = 6, height = 4)
Saskatchewan
<- gg_PopDem_plot2(myArea = "Saskatchewan")
mp ggsave("canada_population_3_04.png", mp, width = 6, height = 4)
Manitoba
<- gg_PopDem_plot2(myArea = "Manitoba")
mp ggsave("canada_population_3_05.png", mp, width = 6, height = 4)
Ontario
<- gg_PopDem_plot2(myArea = "Ontario")
mp ggsave("canada_population_3_06.png", mp, width = 6, height = 4)
Quebec
<- gg_PopDem_plot2(myArea = "Quebec")
mp ggsave("canada_population_3_07.png", mp, width = 6, height = 4)
Newfoundland and Labrador
<- gg_PopDem_plot2(myArea = "Newfoundland and Labrador")
mp ggsave("canada_population_3_08.png", mp, width = 6, height = 4)
Yukon
<- gg_PopDem_plot2(myArea = "Yukon")
mp ggsave("canada_population_3_09.png", mp, width = 6, height = 4)
Sex Ratios
<- function(myArea = "Saskatchewan", myYears = 2019) {
gg_SexRatio_plot # Prep data
<- d2 %>%
xx filter(Area %in% myArea, Year %in% myYears,
!= "Median age", Sex %in% c("Males","Females")) %>%
Age spread(Sex, Value) %>%
mutate(Value = Females - Males,
Group = ifelse(Value < 0, "More Males", "More Females"),
Group = factor(Group, levels = c("More Males", "More Females")))
# Plot
ggplot(xx, aes(y = Value / 1000, x = Age, fill = Group)) +
geom_col(color = "black", alpha = 0.7) +
scale_fill_manual(name = NULL, values = myColorsMF) +
facet_grid(. ~ Year) +
theme_agData(legend.position = "bottom") +
labs(title = paste("Sex Ratio in", myArea), subtitle = "Females - Males",
y = "Thousand People", x = NULL, caption = myCaption) +
coord_cartesian(ylim = c(-max(xx$Value), max(xx$Value))) +
coord_flip()
}
Canada
<- gg_SexRatio_plot(myArea = "Canada", myYears = c(1971, 1995, 2021))
mp ggsave("canada_population_4_01.png", mp, width = 10, height = 4)
British Columbia
<- gg_SexRatio_plot(myArea = "British Columbia", myYears = c(1971, 1995, 2021))
mp ggsave("canada_population_4_02.png", mp, width = 10, height = 4)
Alberta
<- gg_SexRatio_plot(myArea = "Alberta", myYears = c(1971, 1995, 2021))
mp ggsave("canada_population_4_03.png", mp, width = 10, height = 4)
Saskatchewan
<- gg_SexRatio_plot(myArea = "Saskatchewan", myYears = c(1971, 1995, 2021))
mp ggsave("canada_population_4_04.png", mp, width = 10, height = 4)
Manitoba
<- gg_SexRatio_plot(myArea = "Manitoba", myYears = c(1971, 1995, 2021))
mp ggsave("canada_population_4_05.png", mp, width = 10, height = 4)
Ontario
<- gg_SexRatio_plot(myArea = "Ontario", myYears = c(1971, 1995, 2021))
mp ggsave("canada_population_4_06.png", mp, width = 10, height = 4)
Quebec
<- gg_SexRatio_plot(myArea = "Quebec", myYears = c(1971, 1995, 2021))
mp ggsave("canada_population_4_07.png", mp, width = 10, height = 4)
Newfoundland and Labrador
<- gg_SexRatio_plot(myArea = "Newfoundland and Labrador",
mp myYears = c(1971, 1995, 2021))
ggsave("canada_population_4_08.png", mp, width = 10, height = 4)
Yukon
<- gg_SexRatio_plot(myArea = "Yukon", myYears = c(1971, 1995, 2021))
mp ggsave("canada_population_4_09.png", mp, width = 10, height = 4)
Age Line Graphs
Males vs. Females
# Prep data
<- d2 %>%
xx filter(Area == "Canada", Sex %in% c("Males","Females"), Age != "Median age")
# Plot
<- ggplot(xx, aes(x = Year, y = Value / 1000000, color = Sex)) +
mp geom_line(size = 1, alpha = 0.7) +
facet_wrap(Age ~ ., scales = "free_y", ncol = 7) +
scale_color_manual(name = NULL, values = myColorsMF) +
theme_agData(legend.position = "bottom",
axis.text.x = element_text(angle = 45, hjust = 1)) +
labs(title = "Canadian Population Dynamics",
y = "Million People", x = NULL, caption = myCaption)
ggsave("canada_population_5_01.png", mp, width = 12, height = 6)
Animation
<- d2 %>%
xx filter(Area == "Canada", Sex %in% c("Males","Females"),
!= "Median age", !is.na(Value))
Age # Plot
<- ggplot(xx, aes(x = Year, y = Value / 1000000, color = Sex, group = Sex)) +
mp geom_line(size = 1, alpha = 0.7) +
scale_color_manual(name = NULL, values = myColorsMF) +
theme_agData(legend.position = "bottom") +
labs(y = "Million People", x = NULL, caption = myCaption) +
labs(title = paste("Canadian Population Dynamics -", '{closest_state}')) +
transition_states(Age, transition_length = 1, state_length = 1) +
ease_aes('linear')
anim_save("canada_population_gif_4_01.gif", mp,
nframes = 300, fps = 60,
width = 900, height = 600, res = 150)
Old vs Young
Canada
# Prep data
<- d2 %>%
xx filter(Sex %in% c("Males", "Females")) %>%
mutate(Group = ifelse(Age %in% myAges[14:21], "old", "Young")) %>%
group_by(Year, Area, Sex, Group) %>%
summarise(Value = sum(Value, na.rm = T)) %>%
ungroup() %>%
group_by(Year, Area, Sex) %>%
mutate(Total = sum(Value, na.rm = T)) %>%
ungroup() %>%
mutate(Percent = 100 * Value / Total)
# Plot
<- ggplot(xx %>% filter(Area == "Canada", Group == "Young"),
mp aes(x = Year, y = Percent, color = Sex)) +
geom_line(alpha = 0.7, size = 1) +
scale_color_manual(name = NULL, values = myColorsMF) +
scale_y_continuous(minor_breaks = 70:100, limits = c(70,100)) +
theme_agData(legend.position = "bottom") +
labs(title = "Canada - Percent Of Population Under 65", x = NULL)
ggsave("canada_population_6_01.png", mp, width = 6, height = 4)
Provinces
# Plot
<-ggplot(xx %>% filter(Area != "Canada", Group == "Young"),
mp aes(x = Year, y = Percent, color = Sex)) +
geom_line(alpha = 0.7, size = 1) +
scale_color_manual(name = NULL, values = myColorsMF) +
facet_wrap(Area ~ ., ncol = 5) +
scale_y_continuous(minor_breaks = 70:100, limits = c(70,100)) +
theme_agData(legend.position = "bottom") +
labs(title = "Canada - Percent Of Population Under 65", x = NULL)
ggsave("canada_population_6_02.png", mp, width = 12, height = 6)
2021
# Prep data
<- xx %>% filter(Year == 2021, Group == "Young")
xx # Plot
<- ggplot(xx, aes(x = Area, y = Percent, fill = Sex)) +
mp geom_col(position = "dodge", color = "black", alpha = 0.7) +
scale_fill_manual(name = NULL, values = myColorsMF) +
theme_agData(legend.position = "bottom",
axis.text.x = element_text(angle = 45, hjust = 1)) +
labs(title = "Canada - Percent Of Population Under 65", x = NULL)
ggsave("canada_population_6_03.png", mp, width = 6, height = 4)