Deaths In Canada
Graphs of weekly deaths in Canada using STATCAN data
Data
STATCAN Table: 13-10-0783-01
STATCAN Table: 13-10-0768-01
STATCAN Table: 13-10-0708-01
STATCAN Table: 17-10-0009-01
STATCAN Interactive Graph
Prepare Data
# devtools::install_github("derekmichaelwright/agData")
library(agData)
# Prep data
<- "www.dblogr.com/ or derekmichaelwright.github.io/dblogr/ | Data: STATCAN\nNote: most recent years data may be incomplete"
myCaption <- c("darkgreen", "darkred", "darkorange", "steelblue", "darkblue", "purple4", "magenta3")
myColors <- c("Canada", "Quebec", "Ontario", "British Columbia",
myAreas "Alberta", "Saskatchewan", "Manitoba", "Nova Scotia",
"Newfoundland and Labrador", "New Brunswick", "Prince Edward Island",
"Northwest Territories", "Nunavut", "Yukon")
#
# d1 = Deaths per Week (2010-2023)
<- paste(2009:2023, 2010:2024, sep = "-")
mySeasons <- c(rep("pre-2020",10), mySeasons[11:length(mySeasons)])
myGroups <- read.csv("1310078301_databaseLoadingData.csv") %>%
d1 rename(Date=1, Area=GEO, Value=VALUE) %>%
mutate(Date = as.Date(Date),
Year = as.numeric(substr(Date, 1, 4)),
Month = as.numeric(substr(Date, 6, 7)),
Group = ifelse(Year < 2020, "<2020", Year),
Group = factor(Group, levels = c("<2020", "2020", "2021", "2022", "2023")),
JulianDay = lubridate::yday(Date),
AdjJulianDay = ifelse(Month < 8, JulianDay + 365, JulianDay),
Area = gsub(", place of occurrence", "", Area),
Area = factor(Area, levels = myAreas)) %>%
arrange(Date)
# filter incomplete new data
for(i in unique(d1$Area)) {
<- d1 %>% filter(Area == i, Year < 2020) %>% pull(Value) %>% min()
mymin <- d1 %>% filter(!(Area == i & Value < mymin))
d1
}# Calculate Year Group
<- 1
j for(i in 1:nrow(d1)) {
if(d1$Month[i] < 8) { mySwitch <- T }
$Season[i] <- mySeasons[j]
d1$SeasonGroup[i] <- myGroups[j]
d1if(d1$Month[i] > 7 & mySwitch == T) { j <- j + 1; mySwitch <- F }
}<- d1 %>%
d1 mutate(Season = factor(Season, levels = mySeasons),
SeasonGroup = factor(SeasonGroup, levels = unique(myGroups)))
# d2 = Deaths per Week, by gender and age (2010-2023)
<- read.csv("1310076801_databaseLoadingData.csv") %>%
d2 rename(Date=1, Age=Age.at.time.of.death, Value=VALUE, Area=GEO) %>%
mutate(Date = as.Date(Date),
Age = gsub("Age at time of death, ", "", Age),
Year = as.numeric(substr(Date, 1, 4)),
Month = as.numeric(substr(Date, 6, 7)),
Group = ifelse(Year < 2020, "<2020", Year),
Group = factor(Group, levels = c("<2020", "2020", "2021", "2022", "2023")),
JulianDay = lubridate::yday(Date),
AdjJulianDay = ifelse(Month < 8, JulianDay + 365, JulianDay),
Area = gsub(", place of occurrence", "", Area),
Area = factor(Area, levels = myAreas)) %>%
arrange(Date)
# Calculate Year Group
<- 1
j for(i in 1:nrow(d2)) {
if(d2$Month[i] < 8) { mySwitch <- T }
$Season[i] <- mySeasons[j]
d2$SeasonGroup[i] <- myGroups[j]
d2if(d2$Month[i] > 7 & mySwitch == T) { j <- j + 1; mySwitch <- F }
}<- d2 %>%
d2 mutate(Season = factor(Season, levels = mySeasons),
SeasonGroup = factor(SeasonGroup, levels = unique(myGroups)))
# d3 = Yearly death rate (1991-2023)
<- read.csv("1710000901_databaseLoadingData.csv") %>%
p1 select(Area=GEO, Year=REF_DATE, Population=VALUE) %>%
filter(Year %in% paste0(1991:2023,"-01")) %>%
mutate(Year = as.numeric(gsub("-01","",Year)))
#filter(Month == 1) %>% select(Area, Year, Population=Value)
<- read.csv("1710000501_databaseLoadingData.csv") %>%
p2 select(Area=GEO, Year=REF_DATE, Sex, Age.group, Population=VALUE)
<- d1 %>% filter(Year > 2020) %>%
yy group_by(Area, Year) %>%
summarise(Value = sum(Value)) %>%
mutate(Month.of.death = "Total")
<- read.csv("1310070801_databaseLoadingData.csv") %>%
d3 rename(Year=1, Area=GEO, Value=VALUE, Unit=UOM) %>%
mutate(Month.of.death = gsub("Month of death, |, month of death", "",
Month.of.death),Area = gsub(", place of residence", "", Area),
Area = factor(Area, levels = myAreas)) %>%
filter(Unit == "Number") %>%
bind_rows(yy) %>%
rename(Total.Deaths=Value) %>%
left_join(p1, by = c("Area", "Year")) %>%
mutate(Death.Rate = 1000 * Total.Deaths / Population) %>%
filter(Month.of.death == "Total", !is.na(Area)) %>%
mutate(Group = ifelse(Year < 2020, "<2020", Year),
Group = factor(Group, levels = c("<2020", "2020", "2021", "2022", "2023")))
Total Deaths & Death Rates 1991-2022
# Prep data
<- d3 %>% filter(Area == "Canada")
xx # Plot
<- ggplot(xx, aes(x = Year, y = Total.Deaths / 1000,
mp1 fill = Group, alpha = Group)) +
geom_col(color = "black") +
scale_fill_manual(name = NULL, values = myColors) +
scale_alpha_manual(name = NULL, values = c(0.4,0.8,0.8,0.8,0.8,0.8)) +
scale_x_continuous(breaks = c(1991, seq(1995,2020, by = 5))) +
scale_y_continuous(minor_breaks = seq(0, 400, by = 20)) +
theme_agData() +
labs(subtitle = "(A) Total Number of Deaths Per Year in Canada",
y = "Thousand Deaths", x = NULL, caption = "")
<- ggplot(xx, aes(x = Year, y = Death.Rate,
mp2 fill = Group, alpha = Group)) +
geom_col(color = "black") +
scale_fill_manual(name = NULL, values = myColors) +
scale_alpha_manual(name = NULL, values = c(0.4,0.8,0.8,0.8,0.8,0.8)) +
scale_x_continuous(breaks = c(1991, seq(1995,2020, by = 5))) +
scale_y_continuous(minor_breaks = seq(0, 400, by = 20)) +
theme_agData() +
labs(subtitle = "(B) Death Rate Per Year in Canada",
y = "Deaths / Thousand", x = NULL, caption = myCaption)
<- ggarrange(mp1, mp2, ncol = 2, legend = "none", common.legend = T)
mp ggsave("canada_deaths_01_01.png", mp, width = 10, height = 4, bg = "white")
Total Deaths 2010-2023
# Create plotting function
<- function(myArea = "Canada", xmin = 2010) {
ggWeeklyDeaths # Prep data
<- max(d1$Year)
xmax <- as.Date(paste0(as.character(xmin:xmax),"-01-01"))
vv <- d1 %>% filter(Area == myArea, Year >= xmin)
xx #
<- max(xx %>% filter(Year < 2020) %>% pull(Value), na.rm = T)
myMax # Plot
ggplot(xx, aes(x = Date, y = Value, fill = Group)) +
geom_col(alpha = 0.7) +
geom_vline(xintercept = vv, lty = 2, alpha = 0.5) +
geom_hline(yintercept = myMax, alpha = 0.2) +
scale_fill_manual(values = myColors) +
scale_x_date(date_breaks = "1 year", date_labels = "%Y",
minor_breaks = "1 year") +
theme_agData(legend.position = "none") +
labs(title = myArea, y = "Weekly Deaths", x = NULL, caption = myCaption)
}
Canada
<- ggWeeklyDeaths("Canada")
mp ggsave("canada_deaths_02_01.png", mp, width = 8, height = 4)
Ontario
<- ggWeeklyDeaths("Ontario")
mp ggsave("canada_deaths_02_02.png", mp, width = 8, height = 4)
Quebec
<- ggWeeklyDeaths("Quebec")
mp ggsave("canada_deaths_02_03.png", mp, width = 8, height = 4)
British Columbia
<- ggWeeklyDeaths("British Columbia")
mp ggsave("canada_deaths_02_04.png", mp, width = 8, height = 4)
Alberta
<- ggWeeklyDeaths("Alberta")
mp ggsave("canada_deaths_02_05.png", mp, width = 8, height = 4)
Saskatchewan
<- ggWeeklyDeaths("Saskatchewan")
mp ggsave("canada_deaths_02_06.png", mp, width = 8, height = 4)
Manitoba
<- ggWeeklyDeaths("Manitoba")
mp ggsave("canada_deaths_02_07.png", mp, width = 8, height = 4)
Total Deaths 2016-2023
Canada
<- ggWeeklyDeaths("Canada", xmin = 2016)
mp ggsave("canada_deaths_03_01.png", mp, width = 8, height = 4)
Ontario
<- ggWeeklyDeaths("Ontario", xmin = 2016)
mp ggsave("canada_deaths_03_02.png", mp, width = 8, height = 4)
Quebec
<- ggWeeklyDeaths("Quebec", xmin = 2016)
mp ggsave("canada_deaths_03_03.png", mp, width = 8, height = 4)
British Columbia
<- ggWeeklyDeaths("British Columbia", xmin = 2016)
mp ggsave("canada_deaths_03_04.png", mp, width = 8, height = 4)
Alberta
<- ggWeeklyDeaths("Alberta", xmin = 2016)
mp ggsave("canada_deaths_03_05.png", mp, width = 8, height = 4)
Saskatchewan
<- ggWeeklyDeaths("Saskatchewan", xmin = 2016)
mp ggsave("canada_deaths_03_06.png", mp, width = 8, height = 4)
Manitoba
<- ggWeeklyDeaths("Manitoba", xmin = 2016)
mp ggsave("canada_deaths_03_07.png", mp, width = 8, height = 4)
Cummulative Deaths
# Prep data
<- d1 %>% mutate(Year = as.numeric(as.character(Year))) %>%
xx select(Date, Year, JulianDay, Group, Area, Value) %>%
arrange(Area, Date) %>%
spread(Area, Value)
for(i in 5:ncol(xx)) {
for(k in min(xx$Year):max(xx$Year)) {
$Year == k, i] <- cumsum(xx[xx$Year == k,i])
xx[xx
}
}<- xx %>% gather(Area, Value, 5:ncol(.)) %>%
xx mutate(Area = factor(Area, levels = myAreas)) %>%
filter(Area %in% myAreas)
# Plot
<- ggplot(xx, aes(x = JulianDay, y = Value / 1000,
mp group = Year, color = Group, alpha = Group)) +
geom_line() +
facet_wrap(Area ~ ., scales = "free_y", ncol = 5) +
scale_color_manual(name = NULL, values = myColors) +
scale_alpha_manual(name = NULL, values = c(0.5,1,1,1,1)) +
theme_agData(legend.position = "bottom") +
labs(y = "Thousand Deaths", x = "Julian Day", caption = myCaption)
ggsave("canada_deaths_04_01.png", mp, width = 15, height = 8)
Respiratory Season Graphs
# Create plotting function
<- function(myArea) {
ggRespSeasons # Prep data
<- d1 %>% filter(Area == myArea)
xx <- xx %>% filter(Date == "2020-03-14")
zz #
<- c(213, 244, 274, 305, 335,
myBreaks 366, 397, 425, 456, 486, 517, 547, 577)
<- c("Aug","Sept","Oct","Nov","Dec",
myLabels "Jan","Feb","Mar","Apr", "May","June","July","Aug")
# Plot
ggplot(xx, aes(x = AdjJulianDay, y = Value, group = Season,
color = SeasonGroup, alpha = SeasonGroup, size = SeasonGroup)) +
geom_line() +
geom_point(data = zz, size = 2, pch = 13, color = "black", alpha = 0.7) +
facet_wrap(Area ~ ., scales = "free_y", ncol = 5) +
scale_color_manual(name = NULL, values = myColors) +
scale_alpha_manual(name = NULL, values = c(0.2,0.8,0.8,0.8,0.8,0.8)) +
scale_size_manual(name = NULL, values = c(0.5,1,1,1,1,1)) +
scale_x_continuous(breaks = myBreaks, labels = myLabels) +
theme_agData(legend.position = "bottom",
axis.text.x = element_text(angle = 45, hjust = 1)) +
labs(y = "Deaths Per Week", x = NULL, caption = myCaption)
}
Canada
<- ggRespSeasons("Canada")
mp ggsave("canada_deaths_05_01.png", mp, width = 6, height = 4)
Ontario
<- ggRespSeasons("Ontario")
mp ggsave("canada_deaths_05_02.png", mp, width = 6, height = 4)
Quebec
<- ggRespSeasons("Quebec")
mp ggsave("canada_deaths_05_03.png", mp, width = 6, height = 4)
British Columbia
<- ggRespSeasons("British Columbia")
mp ggsave("canada_deaths_05_04.png", mp, width = 6, height = 4)
Alberta
<- ggRespSeasons("Alberta")
mp ggsave("canada_deaths_05_05.png", mp, width = 6, height = 4)
Saskatchewan
<- ggRespSeasons("Saskatchewan")
mp ggsave("canada_deaths_05_06.png", mp, width = 6, height = 4)
Manitoba
<- ggRespSeasons("Manitoba")
mp ggsave("canada_deaths_05_07.png", mp, width = 6, height = 4)
Respiratory Season Graphs by Age Group
# Create plotting function
<- function(myArea = "Canada") {
ggRespSeasonsAge # Prep data
<- d2 %>% filter(Area == myArea, Sex == "Both sexes", Age != "all ages")
xx <- xx %>% filter(Date == "2020-03-14")
zz #
<- c(213, 244, 274, 305, 335,
myBreaks 366, 397, 425, 456, 486, 517, 547, 577)
<- c("Aug","Sept","Oct","Nov","Dec",
myLabels "Jan","Feb","Mar","Apr", "May","June","July", "Aug")
# Plot
ggplot(xx, aes(x = AdjJulianDay, y = Value, group = Season,
color = SeasonGroup, alpha = SeasonGroup, size = SeasonGroup)) +
geom_line() +
geom_point(data = zz, size = 1.5, pch = 13, color = "black", alpha = 0.7) +
facet_grid(. ~ Age, scales = "free_y") +#labeller = label_wrap_gen(width = 10)
scale_color_manual(name = NULL, values = myColors) +
scale_alpha_manual(name = NULL, values = c(0.4,0.8,0.8,0.8,0.8)) +
scale_size_manual(name = NULL, values = c(0.3,0.75,0.75,0.75,0.75,0.75)) +
scale_x_continuous(breaks = myBreaks, labels = myLabels) +
theme_agData(legend.position = "bottom",
axis.text.x = element_text(angle = 45, hjust = 1)) +
labs(title = myArea, y = "Deaths Per Week", x = NULL, caption = myCaption)
}
Canada
<- ggRespSeasonsAge(myArea = "Canada")
mp ggsave("canada_deaths_06_01.png", mp, width = 10, height = 4)
Ontario
<- ggRespSeasonsAge("Ontario")
mp ggsave("canada_deaths_06_02.png", mp, width = 10, height = 4)
Quebec
<- ggRespSeasonsAge("Quebec")
mp ggsave("canada_deaths_06_03.png", mp, width = 10, height = 4)
British Columbia
<- ggRespSeasonsAge("British Columbia")
mp ggsave("canada_deaths_06_04.png", mp, width = 10, height = 4)
Alberta
<- ggRespSeasonsAge("Alberta")
mp ggsave("canada_deaths_06_05.png", mp, width = 10, height = 4)
Saskatchewan
<- ggRespSeasonsAge("Saskatchewan")
mp ggsave("canada_deaths_06_06.png", mp, width = 10, height = 4)
Manitoba
<- ggRespSeasonsAge("Manitoba")
mp ggsave("canada_deaths_06_07.png", mp, width = 10, height = 4)
Yearly Deaths by Age Group
# Create plotting function
<- function(myArea = "Canada") {
ggYearlyDeaths # Prep data
<- d2 %>%
xx filter(Area == myArea,
== "Both sexes", Age != "all ages") %>%
Sex group_by(Age, Year, Group) %>%
summarise(Value = sum(Value, na.rm = T))
# Plot
ggplot(xx, aes(x = Year, y = Value / 1000, fill = Group, alpha = Group)) +
geom_col(color = "black") +
facet_grid(. ~ Age) +
scale_fill_manual(name = NULL, values = myColors) +
scale_alpha_manual(name = NULL, values = c(0.4,0.8,0.8,0.8,0.8)) +
scale_x_continuous(breaks = seq(2010, 2022, 2)) +
theme_agData(legend.position = "none",
axis.text.x = element_text(angle = 45, hjust = 1)) +
labs(title = myArea, caption = myCaption,
y = "Thousand Deaths", x = NULL)
}
Canada
<- ggYearlyDeaths(myArea = "Canada")
mp ggsave("canada_deaths_07_01.png", mp, width = 10, height = 4)
Ontario
<- ggYearlyDeaths(myArea = "Ontario")
mp ggsave("canada_deaths_07_02.png", mp, width = 10, height = 4)
Quebec
<- ggYearlyDeaths(myArea = "Quebec")
mp ggsave("canada_deaths_07_03.png", mp, width = 10, height = 4)
British Columbia
<- ggYearlyDeaths(myArea = "British Columbia")
mp ggsave("canada_deaths_07_04.png", mp, width = 10, height = 4)
Alberta
<- ggYearlyDeaths(myArea = "Alberta")
mp ggsave("canada_deaths_07_05.png", mp, width = 10, height = 4)
Saskatchewan
<- ggYearlyDeaths(myArea = "Saskatchewan")
mp ggsave("canada_deaths_07_06.png", mp, width = 10, height = 4)
Manitoba
<- ggYearlyDeaths(myArea = "Manitoba")
mp ggsave("canada_deaths_07_07.png", mp, width = 10, height = 4)
Death Rate - Ages 65+
# Prep data
.1 <- d2 %>%
d2filter(Sex == "Both sexes", !is.na(Value),
%in% c("65 to 84 years", "84 years and over")) %>%
Age group_by(Year, Group, Area) %>%
summarise(Deaths = sum(Value, na.rm = T))
<- p2 %>%
pi filter(Sex == "Both sexes",
%in% c("65 to 69 years", "70 to 74 years",
Age.group "75 to 79 years", "80 to 84 years",
"85 to 89 years", "90 to 94 years",
"95 to 99 years", "100 years and over")) %>%
group_by(Year, Area) %>%
summarise(Population = sum(Population, na.rm = T))
.1 <- d2.1 %>% left_join(pi, by = c("Year","Area")) %>%
d2mutate(`Deaths Per 1000 People` = 1000 * Deaths / Population,
Area = factor(Area, levels = myAreas))
Canada
# Prep data
<- d2.1 %>% filter(Area == "Canada") %>% select(-Population) %>%
xx gather(Trait, Value, 4:5)
# Plot
<- ggplot(xx, aes(x = Year, y = Value, fill = Group)) +
mp geom_col(color = "black", alpha = 0.7) +
facet_wrap(Trait ~ ., scales= "free_y") +
scale_fill_manual(values = myColors) +
scale_x_continuous(breaks = min(xx$Year):max(xx$Year)) +
theme_agData(legend.position = "none",
axis.text.x = element_text(angle = 45, hjust = 1)) +
labs(title = "Canada - Ages 65+",
x = NULL, y = NULL, caption = myCaption)
ggsave("canada_deaths_08_01.png", mp, width = 10, height = 4)
Provinces
# Plot
<- ggplot(d2.1, aes(x = Year, y = `Deaths Per 1000 People`, fill = Group)) +
mp geom_col(color = "black", alpha = 0.7) +
facet_wrap(Area ~ ., scales= "free_y", ncol = 5) +
scale_fill_manual(values = myColors) +
theme_agData(legend.position = "none") +
labs(title = "Canada - Ages 65+",
x = NULL, caption = myCaption)
ggsave("canada_deaths_08_02.png", mp, width = 14, height = 8)
Death Rate - Ages 0-44
# Prep data
.2 <- d2 %>%
d2filter(Sex == "Both sexes", Age == "0 to 44 years") %>%
group_by(Year, Group, Area) %>%
summarise(Value = sum(Value, na.rm = T))
<- c("0 to 4 years", "5 to 9 years", "10 to 14 years",
myAges "15 to 19 years", "20 to 24 years", "25 to 29 years",
"30 to 34 years", "35 to 39 years", "40 to 44 years")
<- p2 %>% filter(Age.group %in% myAges) %>%
pi group_by(Year, Area) %>% summarise(Population = sum(Population))
.2 <- d2.2 %>% left_join(pi, by = c("Year", "Area")) %>%
d2rename(Deaths=Value) %>%
mutate(`Deaths Per 10000 People` = 10000 * Deaths / Population,
Area = factor(Area, levels = myAreas))
Canada
# Prep data
<- d2.2 %>% filter(Area == "Canada") %>% select(-Population) %>%
xx gather(Trait, Value, 4:5)
# Plot
<- ggplot(xx, aes(x = Year, y = Value, fill = Group)) +
mp geom_col(color = "black", alpha = 0.7) +
facet_wrap(Trait ~ ., scales= "free_y") +
scale_fill_manual(values = myColors) +
scale_x_continuous(breaks = min(xx$Year):max(xx$Year)) +
theme_agData(legend.position = "none",
axis.text.x = element_text(angle = 45, hjust = 1)) +
labs(title = "Canada - Ages 0 - 44",
x = NULL, y = NULL, caption = myCaption)
ggsave("canada_deaths_08_03.png", mp, width = 10, height = 4)
Provinces
# Plot
<- ggplot(d2.2, aes(x = Year, y = `Deaths Per 10000 People`, fill = Group)) +
mp geom_col(color = "black", alpha = 0.7) +
facet_wrap(Area ~ ., scales= "free_y") +
scale_fill_manual(values = myColors) +
theme_agData(legend.position = "none") +
labs(title = "Canada - Ages 0 - 44",
x = NULL, caption = myCaption)
ggsave("canada_deaths_08_04.png", mp, width = 14, height = 8)
BC Drug Overdoses
# Prep data
<- read_xlsx("data_canada_overdoses.xlsx", "BC Age") %>%
d4 gather(Year, Overdoses, 2:ncol(.)) %>%
mutate(Overdoses = ifelse(`Age Group` == "40-49", Overdoses / 2, Overdoses)) %>%
filter(`Age Group` %in% c("< 19","19-29","30-39","40-49")) %>%
group_by(Year) %>%
summarise(Overdoses = sum(Overdoses, na.rm = T)) %>%
mutate(Year = as.integer(Year))
<- d2 %>% filter(Area == "British Columbia", Sex == "Both sexes",
xx == "0 to 44 years") %>%
Age group_by(Year) %>%
summarise(Deaths = sum(Value, na.rm = T)) %>%
left_join(d4, by = "Year") %>%
filter(!is.na(Overdoses)) %>%
mutate(Deaths = Deaths - Overdoses) %>%
gather(Measurement, Value, 2:3) %>%
mutate(Measurement = factor(Measurement, levels = c("Overdoses","Deaths")))
<- xx %>% filter(Year < 2015, Measurement == "Overdoses") %>% pull(Value) %>% max()
x1 <- xx %>% filter(Year == 2019, Measurement == "Deaths") %>% pull(Value) %>% max()
x2 # Plot
<- ggplot(xx, aes(x = Year, y = Value, fill = Measurement)) +
mp geom_col(color = "black", alpha = 0.7, position = "dodge") +
geom_hline(yintercept = x1, alpha = 0.7, lty = 3) +
geom_hline(yintercept = x2, alpha = 0.7, lty = 2) +
scale_fill_manual(name = NULL, values = myColors[2:1],
labels = c("Drug Overdoses", "Other Deaths")) +
scale_x_continuous(breaks = 2011:2022, minor_breaks = 2011:2022) +
theme_agData(legend.position = "bottom") +
labs(title = "British Columbia - Ages 0 - 44",
y = "Deaths", x = NULL, caption = myCaption)
ggsave("canada_deaths_08_05.png", mp, width = 6, height = 4)
sum(xx$Value[xx$Year%in%2021:2022 & xx$Measurement == "Deaths"] - xx$Value[xx$Year==2020 & xx$Measurement=="Deaths"])
## [1] 502.5
sum(xx$Value[xx$Year%in%2020:2022 & xx$Measurement == "Deaths"] - xx$Value[xx$Year==2019 & xx$Measurement=="Overdoses"])
## [1] 3295.5
sum(xx$Value[xx$Year%in%2015:2022 & xx$Measurement == "Deaths"] - xx$Value[xx$Year==2014 & xx$Measurement=="Overdoses"])
## [1] 10035.5
SK Drug Overdoses
# Prep data
<- read_xlsx("data_canada_overdoses.xlsx", "SK Age") %>%
d4 gather(Year, Overdoses, 3:ncol(.)) %>%
mutate(Overdoses = ifelse(`Age Group` == "40 - 49", Overdoses / 2, Overdoses)) %>%
filter(`Age Group` %in% c("0 - 9","10 - 19","20 - 29","30 - 39","40 - 49")) %>%
group_by(Year) %>%
summarise(Overdoses = sum(Overdoses, na.rm = T)) %>%
mutate(Year = as.integer(Year))
<- d2 %>% filter(Area == "Saskatchewan", Sex == "Both sexes",
xx == "0 to 44 years") %>%
Age group_by(Year) %>%
summarise(Deaths = sum(Value, na.rm = T)) %>%
left_join(d4, by = "Year") %>%
filter(!is.na(Overdoses)) %>%
mutate(Deaths = Deaths - Overdoses) %>%
gather(Measurement, Value, 2:3) %>%
mutate(Measurement = factor(Measurement, levels = c("Overdoses","Deaths")))
<- xx %>% filter(Year < 2015, Measurement == "Overdoses") %>% pull(Value) %>% max()
x1 <- xx %>% filter(Year == 2019, Measurement == "Deaths") %>% pull(Value) %>% max()
x2 # Plot
<- ggplot(xx, aes(x = Year, y = Value, fill = Measurement)) +
mp geom_col(color = "black", alpha = 0.7, position = "dodge") +
geom_hline(yintercept = x1, alpha = 0.7, lty = 3) +
geom_hline(yintercept = x2, alpha = 0.7, lty = 2) +
scale_fill_manual(name = NULL, values = myColors[2:1],
labels = c("Drug Overdoses", "Other Deaths")) +
scale_x_continuous(breaks = 2011:2022, minor_breaks = 2011:2022) +
theme_agData(legend.position = "bottom") +
labs(title = "Saskatchewan - Ages 0 - 44",
y = "Deaths", x = NULL, caption = myCaption)
ggsave("canada_deaths_08_06.png", mp, width = 6, height = 4)
sum(xx$Value[xx$Year%in%2021:2022 & xx$Measurement == "Deaths"] - xx$Value[xx$Year==2020 & xx$Measurement=="Deaths"])
## [1] 214
sum(xx$Value[xx$Year%in%2020:2022 & xx$Measurement == "Deaths"] - xx$Value[xx$Year==2019 & xx$Measurement=="Overdoses"])
## [1] 1973.5
sum(xx$Value[xx$Year%in%2015:2022 & xx$Measurement == "Deaths"] - xx$Value[xx$Year==2014 & xx$Measurement=="Overdoses"])
## [1] 4918.5
Weekly Deaths Ages 0-44
<- function(myArea = "Canada") {
ggWeeklyDeaths044 # Prep data
<- d2 %>%
xx filter(Area == myArea, Age == "0 to 44 years", Sex == "Both sexes")
<- as.Date(paste0(as.character(2010:2023),"-01-01"))
vv # Plot
ggplot(xx, aes(x = Date, y = Value, fill = Group)) +
geom_col(alpha = 0.7) +
geom_vline(xintercept = vv, lty = 2, alpha = 0.5) +
scale_fill_manual(values = myColors) +
scale_x_date(date_breaks = "1 year", date_labels = "%Y",
minor_breaks = "1 year") +
theme_agData(legend.position = "none") +
labs(title = paste(myArea, "- Ages 0 - 44"),
x = NULL, y = "Weekly Deaths", caption = myCaption)
}
Canada
<- ggWeeklyDeaths044(myArea = "Canada")
mp ggsave("canada_deaths_09_01.png", mp, width = 8, height = 4)
Ontario
<- ggWeeklyDeaths044(myArea = "Ontario")
mp ggsave("canada_deaths_09_02.png", mp, width = 8, height = 4)
Quebec
<- ggWeeklyDeaths044(myArea = "Quebec")
mp ggsave("canada_deaths_09_03.png", mp, width = 8, height = 4)
British Columbia
<- ggWeeklyDeaths044(myArea = "British Columbia")
mp ggsave("canada_deaths_09_04.png", mp, width = 8, height = 4)
Alberta
<- ggWeeklyDeaths044(myArea = "Alberta")
mp ggsave("canada_deaths_09_05.png", mp, width = 8, height = 4)
Saskatcehwan
<- ggWeeklyDeaths044(myArea = "Saskatchewan")
mp ggsave("canada_deaths_09_06.png", mp, width = 8, height = 4)
Manitoba
<- ggWeeklyDeaths044(myArea = "Manitoba")
mp ggsave("canada_deaths_09_07.png", mp, width = 8, height = 4)
Weekly Deaths By Sex
Canada
# Prep data
<- d2 %>% filter(Area %in% "Canada", Sex != "Both sexes", Year > 2016)
xx # Plot
<- ggplot(xx, aes(x = Date, y = Value, group = Sex, color = Sex)) +
mp geom_line() +
facet_grid(Area ~ Age) +
scale_color_manual(name = NULL, values = c("palevioletred3", "steelblue")) +
theme_agData(legend.position = "bottom",
axis.text.x = element_text(angle = 45, hjust = 1)) +
labs(y = "Deaths Per Week", x = NULL, caption = myCaption)
ggsave("canada_deaths_10_01.png", mp, width = 8, height = 4)
2020
# Prep data
<- d2 %>% filter(Area %in% "Canada", Sex != "Both sexes", Year >= 2020)
xx # Plot
<- ggplot(xx, aes(x = Date, y = Value, group = Sex, color = Sex)) +
mp geom_line(size = 1) +
facet_grid(Area ~ Age) +
scale_color_manual(name = NULL, values = c("palevioletred3", "steelblue")) +
scale_x_date(date_breaks = "1 year", date_labels = "%Y",
minor_breaks = "1 year") +
theme_agData(legend.position = "bottom",
axis.text.x = element_text(angle = 45, hjust = 1)) +
labs(y = "Deaths Per Week", x = NULL, caption = myCaption)
ggsave("canada_deaths_10_02.png", mp, width = 8, height = 4)
Yearly Death Rate
Canada
# Plot
<- ggplot(d3 %>% filter(Area == "Canada"),
mp aes(x = Year, y = Death.Rate, fill = Group, alpha = Group)) +
geom_col(color = "black") +
scale_fill_manual(values = myColors) +
scale_alpha_manual(name = NULL, values = c(0.4,0.8,0.8,0.8,0.8)) +
scale_x_continuous(breaks = seq(1990, 2020, 5)) +
theme_agData(legend.position = "none") +
labs(title = "Death Rate - Canada",
y = "Deaths Per Thousand People", x = NULL, caption = myCaption)
ggsave("canada_deaths_11_01.png", mp, width = 6, height = 4)
Provinces
# Plot
<- ggplot(d3, aes(x = Year, y = Death.Rate, fill = Group, alpha = Group)) +
mp geom_col(color = "black", lwd = 0.2) +
scale_fill_manual(name = NULL, values = myColors) +
scale_alpha_manual(name = NULL, values = c(0.4,0.8,0.8,0.8,0.8)) +
scale_x_continuous(breaks = seq(1995, 2015, 10)) +
facet_wrap(Area ~ ., ncol = 5) +
theme_agData(legend.position = "none") +
labs(title = "Death Rate - Canada",
y = "Deaths Per Thousand People", x = NULL, caption = myCaption)
ggsave("canada_deaths_11_02.png", mp, width = 10, height = 6)
2019 vs 2020
# Prep data
<- d3 %>% filter(Year %in% c(2019, 2020, 2021, 2022)) %>%
xx filter(!is.na(Total.Deaths), Total.Deaths > 0)
# Plot
<- ggplot(xx, aes(x = Year, y = Death.Rate, fill = factor(Year))) +
mp geom_col(position = "dodge", color = "black", alpha = 0.7) +
facet_grid(. ~ Area, labeller = label_wrap_gen(width = 10)) +
scale_fill_manual(name = NULL, values = myColors) +
theme_agData(legend.position = "bottom",
axis.text.x = element_blank(),
axis.ticks.x = element_blank()) +
labs(title = "Death Rate Change in Canada", subtitle = "2019 and 2020",
y = "Deaths Per Thousand People", x = NULL, caption = myCaption)
ggsave("canada_deaths_11_03.png", mp, width = 13, height = 4)
Change
# Prep data
<- d3 %>% filter(Year %in% c(1991, 2019)) %>%
xx select(Area, Year, Death.Rate) %>%
spread(Year, Death.Rate) %>%
mutate(Change = `2019` - `1991`) %>%
filter(!is.na(Change))
# Plot
<- ggplot(xx, aes(x = Area, y = Change)) +
mp geom_col(color = "black", fill = "darkred", alpha = 0.7) +
theme_agData(axis.text.x = element_text(angle = 45, hjust = 1)) +
labs(title = "Death Rate Change (1991 to 2019)",
subtitle = "Deaths per thousand people",
y = "Change", x = NULL, caption = myCaption)
ggsave("canada_deaths_11_04.png", mp, width = 6, height = 4)
# Prep data
<- d3 %>% filter(Year %in% c(1991, 2019, 2020, 2021)) %>%
xx select(Area, Year, Death.Rate) %>%
spread(Year, Death.Rate) %>%
mutate(Change1 = `2019` - `1991`,
Change2 = `2020` - `2019`,
Change3 = `2021` - `2020`) %>%
filter(!is.na(Change1)) %>%
select(Area, Change1, Change2, Change3) %>%
gather(Trait, Value, 2:4)
<- c(alpha("darkred",0.3), alpha("darkred",0.6), alpha("darkred",0.8))
myColors <- c(c("1991 to 2019", "2019 to 2020", "2020 to 2021"))
myLabels # Plot
<- ggplot(xx, aes(x = Area, y = Value, fill = Trait)) +
mp geom_col(position = "dodge", color = "black") +
scale_fill_manual(values = myColors, labels = myLabels) +
theme_agData(legend.position = "bottom",
axis.text.x = element_text(angle = 45, hjust = 1)) +
labs(title = "Death Rate Change",
subtitle = "Deaths per thousand people",
y = "Change", x = NULL, caption = myCaption)
ggsave("canada_deaths_11_05.png", mp, width = 6, height = 4)
Select Provinces
# Prep data
<- c("Ontario", "Quebec", "Alberta")
myAreas <- c("darkblue", "steelblue", "darkred")
myColors <- p1 %>% filter(Year > 2019)
pi <- d1 %>%
xx filter(Year > 2019, Area %in% myAreas) %>%
left_join(pi, by = c("Area", "Year")) %>%
mutate(Death.Rate = 1000000 * Value / Population,
#Death.Rate = movingAverage(Death.Rate, n = 3),
Area = factor(Area, levels = myAreas)) %>%
filter(!is.na(Death.Rate))
# Plot
<- ggplot(xx, aes(x = Date, y = Death.Rate, color = Area)) +
mp geom_line(size = 1.5, alpha = 0.8) +
scale_color_manual(values = myColors) +
theme_agData(legend.position = "bottom") +
labs(title = "Death Rate 2020", x = "Julian Day",
y = "Deaths per million people per week", caption = myCaption)
ggsave("canada_deaths_11_06.png", mp, width = 6, height = 4)
Heatmap
# Prep data
<- c("Yukon", "Northwest Territories", "Nunavut")
myAreas <- c("white", "darkorange1", "darkred")
myColors <- p1 %>% filter(Year > 2019)
pi <- d1 %>%
xx filter(Year > 2019, !Area %in% myAreas) %>%
left_join(pi %>% select(-Year), by = "Area") %>%
mutate(Death.Rate = 1000000 * Value / Population)
# Plot
<- ggplot(xx, aes(x = Date, y = Area, fill = Death.Rate)) +
mp geom_tile(color = "white", size = 0.35) +
scale_fill_gradientn(colors = myColors, na.value = 'white') +
theme_minimal() +
theme(plot.background = element_rect(fill = "white"),
panel.grid = element_blank()) +
coord_cartesian(clip = 'off') +
theme(legend.position = "bottom",
text = element_text(size = 8)) +
labs(x = NULL, y = NULL, caption = myCaption)
ggsave("canada_deaths_11_07.png", mp, width = 6, height = 4)
1900 - Present
library(readxl)
# Prep data
<- read_xlsx("data_canada_deaths.xlsx", "Death Rate") %>%
d4 gather(Trait, Value, 2:ncol(.)) %>%
mutate(Value = gsub(",", "", Value),
Value = as.numeric(Value))
<- d4 %>%
xx filter(Year %in% 2020:max(d4$Year), Trait == "Death rate (per 1,000)") %>%
pull(Value) %>% max(na.rm = T)
<- d4 %>% filter(Trait == "Death rate (per 1,000)") %>%
xx mutate(Group = ifelse(Value >= xx, "higher", "Lower"),
Group = ifelse(Year %in% c(1918, 2020, 2021), "Pandemic", Group))
# Plot
<- ggplot(xx, aes(x = Year, y = Value, alpha = Group)) +
mp geom_col(color = "black", fill = "darkred", size = 0.3) +
scale_x_continuous(breaks = seq(1900, 2020, 20)) +
scale_fill_manual(values = c("darkred", "darkgreen", "darkred")) +
scale_alpha_manual(values = c(0.6, 0.3, 0.8)) +
theme_agData(legend.position = "none") +
labs(title = "Death Rate in Canada", y = "Deaths per 1000 people", x = NULL,
caption = "www.dblogr.com/ or derekmichaelwright.github.io/dblogr/ | Data: Wikipedia")
ggsave("canada_deaths_12_01.png", mp, width = 6, height = 4)
Life Expectancy
https://www150.statcan.gc.ca/n1/pub/91f0015m/91f0015m2021002-eng.htm
# Prep data
<- read_xlsx("data_canada_deaths.xlsx", "Life Expectancy") %>%
d5 mutate(Area = factor(Area, levels = Area))
<- d5 %>% select(Area, `Life expectancy in 2019`,
xx `Average age at death, due to COVID-19`) %>%
gather(Trait, Value, 2:3) %>%
mutate(Trait = factor(Trait,
levels = c("Life expectancy in 2019", "Average age at death, due to COVID-19")))
# Plot
<- ggplot(xx, aes(x = Trait, y = Value, fill = Trait)) +
mp geom_col(color = "black", alpha = 0.7) +
facet_wrap(. ~ Area, ncol = 4) +
scale_fill_manual(name = NULL, values = c("steelblue", "darkred")) +
coord_cartesian(ylim = c(70, 90)) +
theme_agData(legend.position = "bottom",
axis.text.x = element_blank(),
axis.ticks.x = element_blank()) +
labs(title = "", x = NULL, y = NULL, caption = myCaption)
ggsave("canada_deaths_12_02.png", mp, width = 8, height = 4)
<- ggplot(d5, aes(x = Area, fill = Area,
mp y = `Crude death rate, due to COVID-19 (per thousand)`)) +
geom_col(color = "black") +
theme_agData(legend.position = "none",
axis.text.x = element_text(angle = 45, hjust = 1)) +
labs(title = "COVID-19 Death Rate In Canada",
y = "Deaths per 1000 People", x = NULL, caption = myCaption)
ggsave("canada_deaths_12_03.png", mp, width = 6, height = 4)