Zgony w Europie

Dane

Dane pobrane https://ec.europa.eu/eurostat/web/population-demography-migration-projections/data/database?node_code=demomwk (tabela demo_r_mwk_05 – Deaths by week, sex and 5-year age group). Dane zostały skonwertowane do postaci zbioru CSV w którym każdy wiersz zawiera 5 pól:

age – grupa wiekowa (UNK Y10-14 Y15-19 Y20-24 Y25-29 Y30-34 Y35-39 Y40-44 Y45-49 Y50-54 Y55-59 Y5-9 Y60-64 Y65-69 Y70-74 Y75-79 Y80-84 Y85-89 Y_GE90 Y_LT5; UNK oznacza unknown czyli nieznaną, Y_GE90 to 90+ natomiast Y_LT5 to 4-);
sex – (transfobicznie F/M oraz T czyli razem);
unit – niewykorzystywane;
geo – ISO-symbol kraju;
time – rok i numer tygodnia w roku w formacie yyyyWww;
value – liczba zgonów

Czytam dane:

u0 <- read.csv(file='demo_r_mwk_05.csv.gz', sep=';', header=T)

Grupa wiekowa 70+

Analizę ograniczamy do 21 krajów ważniejszych/krajów, bez podziału na płeć.

Grupa wiekowa 70+ jest definiowana jako suma grup: Y70-74, Y75-79 , Y80-84, Y85-89 oraz Y_GE90.

geo.grp <- c("BE", "BG", "CH", "CZ", "DE", "DK", "EL", "ES", "FI",
    "FR", "HU", "IT", "NL", "NO", "PL",
    "PT", "RO", "SE", "SI", "SK", "UK")

old.age.grp <- c('Y70-74', 'Y75-79', 'Y80-84', 'Y85-89', 'Y_GE90' )

Ograniczamy się do danych z lat 2015–2020 (sześć lat) Aby zmienić wyjściową ramkę na tą na podstawie, której wyrysowany zostanie wykres trzeba dokonać paru przekształceń. Komentarze opisują co i po co jest transformowane:

u <- u0 %>% filter(age %in% old.age.grp & sex == 'T') %>%
  ## oblicz numer roku jako pierwsze cztery znaki pola time
  mutate (yr = as.numeric(substr(as.character(time), 1, 4))) %>%
  filter(yr > 2014) %>%
  filter(geo %in% geo.grp) %>%
  ## grupuj wg tygodni i państw:
  group_by(time,geo) %>% 
  ## sumuj grupy | dodaj do zmiennych yr
  summarise(v=sum(value, na.rm=T), yr=first(yr)) %>% 
  ## https://stackoverflow.com/questions/45549449/transform-year-week-to-date-object
  ## zamień rok/tydzień/dzień na datę (umownie przyjmujemy 1-dzień tygodnia):
  mutate(date = as.Date(sprintf("%s01", time), "%YW%W%w")) %>%
  ## w zbiorze są zera zamiast NA:
  mutate ( v = replace(v, which( v <= 0), NA))  %>%
  as.data.frame()
## first/last week
fy <- first(u$time)
ly <- last(u$time)

Że 21 krajów na jednym wykresie to by było raczej nieczytelne, zdecydowaliśmy się na 21 wykresów liniowo-punktowych (za co odpowiada facet_wrap):

mainBreaks <- "1 year"
labTxt <- "wygładzanie wykładnicze/span = 0.25"
note <- "© NI-KW  (dane: Eurostat/tabela demo_r_mwk_05)"

p1 <- ggplot(u, aes(x= as.Date(date, format="%Y-%m-%d"), y=v)) +
  geom_smooth(method="loess", se=F, span=spanV) +
  geom_point(size=.4, alpha=.5) +
  xlab(label="") +
  ylab(label="liczba zgonów") +
  scale_x_date( labels = date_format("%y%m"), breaks = mainBreaks) +
  facet_wrap( ~geo, scales = "free_y") +
  ggtitle(sprintf("Zgony w wybranych krajach w grupie wiekowej 70+"), subtitle=note)

p1

Ponieważ dalszą analizę ograniczmy wyłącznie do porównania PL oraz CZ możemy oba te kraje przedstawić na jednym wykresie:

##Tylko PL i Cz
u1 <- u %>% filter(geo %in% c("PL", "CZ")) %>%  as.data.frame()

p2 <- ggplot(u1, aes(x= as.Date(date, format="%Y-%m-%d"), 
                     y=v, color=geo, group=geo)) +
  geom_smooth(method="loess", se=F, span=spanV) +
  geom_point(size=1.2, alpha=.5) +
  xlab(label="") +
  ylab(label="liczba zgonów") +
  scale_x_date( labels = date_format("%y%m%d"), breaks = mainBreaks) +
  ggtitle(sprintf("Zgony w PL i CZ (70+)"), subtitle=note)
p2

Można też procentowo np. jako odchylenie od średniej liczby zgonów dla wszystkich lat poprzedzających rok 2020. Średnie dla lat 2015–2019 są następujące:

meanPL <- u1 %>% filter (yr < 2020 & geo == 'PL') %>% 
  pull(v) %>% mean(na.rm=T)
meanCZ <- u1 %>% filter (yr < 2020 & geo == 'CZ') %>% 
  pull(v) %>% mean(na.rm=T)
## dla porównania

meanPL2000 <- u1 %>% filter (yr == 2020 & geo == 'PL') %>% 
  pull(v) %>% mean(na.rm=T)
meanCZ2000 <- u1 %>% filter (yr == 2020 & geo == 'CZ') %>% 
  pull(v) %>% mean(na.rm=T)

Średnia liczba zgonów w PL w latach 2015–2019 wyniosła 4913.7 zaś w CZ wyniosła 1522.3 tygodniowo. W roku pandemii w PL zmarło 6180.1 oraz 1861.2 odpowiednio albo 125.77% oraz 122.26%.

u2 <- u %>% filter(geo %in% c("PL", "CZ")) %>%  
  pivot_wider(names_from = geo, values_from = v) %>%
  mutate(CZ=CZ/meanCZ, PL=PL/meanPL) %>%
  pivot_longer(c('CZ', 'PL'), names_to="geo", values_to='v') %>%
  mutate(v=v *100) %>% as.data.frame()

p3 <- ggplot(u2, aes(x= as.Date(date, format="%Y-%m-%d"), 
                     y=v, color=geo, group=geo)) +
  geom_smooth(method="loess", se=F, span=spanV) +
  geom_point(size=1.2, alpha=.5) +
  xlab(label="") +
  ylab(label="%") +
  scale_x_date( labels = date_format("%y%m%d"), breaks = mainBreaks) +
  ggtitle(sprintf("Zgony w PL i CZ (70+) jako odchylenie od średniej"), subtitle=note)

p3

Szczegółowy wykres tylko dla roku 2020:

mainBreaks <- "4 weeks"
u2 <- u2 %>%
  mutate (yr = as.numeric(substr(as.character(time), 1, 4))) %>%
  filter(yr > 2019) %>% as.data.frame()

p3_2 <- ggplot(u2, aes(x= as.Date(date, format="%Y-%m-%d"), 
                     y=v, color=geo, group=geo)) +
  geom_smooth(method="loess", se=F, span=spanV, size=1.5) +
  geom_point(size=2.5, alpha=.5) +
  xlab(label="") +
  ylab(label="%") +
  scale_x_date( labels = date_format("%m%d"), breaks = mainBreaks) +
  ggtitle(sprintf("Zgony w PL i CZ (70+) jako odchylenie od średniej"), subtitle=note)
p3_2

W dalszej analizie porównujemy tylko PL oraz CZ.

Grupa wiekowa 20–45

Jak wyglądała śmiertelność w grupie 20–45. Analogicznie jak w przypadku grupy 70+ zaczynamy od zsumowania liczby zgonów w relewantnych grupach wiekowych:

young.age.grp <- c('Y20-24', 'Y25-29', 'Y30-34', 'Y35-39', 'Y40-44') 
mainBreaks <- "1 year"

u3 <- u0 %>% filter(age %in% young.age.grp ) %>%
  filter(sex == 'T') %>%
  mutate (yr = as.numeric(substr(as.character(time), 1, 4))) %>%
  filter(yr > 2014) %>%
  filter(geo %in% c('CZ', 'PL')) %>%
  group_by(time,geo) %>% 
  summarise(v=sum(value, na.rm=T), yr=first(yr)) %>% 
  ## https://stackoverflow.com/questions/45549449/transform-year-week-to-date-object
  mutate(date = as.Date(sprintf("%s01", time), "%YW%W%w")) %>%
  mutate ( v = replace(v, which( v <= 0), NA))  %>%
  as.data.frame()

Obliczamy średnie dla lat 2015–2019:

meanPL <- u3 %>% filter (yr < 2020 & geo == 'PL') %>% 
  pull(v) %>% mean(na.rm=T)

meanCZ <- u3 %>% filter (yr < 2020 & geo == 'CZ') %>% 
  pull(v) %>% mean(na.rm=T)
meanPL2000 <- u3 %>% filter (yr == 2020 & geo == 'PL') %>% 
  pull(v) %>% mean(na.rm=T)
meanCZ2000 <- u3 %>% filter (yr == 2020 & geo == 'CZ') %>% 
  pull(v) %>% mean(na.rm=T)

u3 <- u3 %>%
  pivot_wider(names_from = geo, values_from = v) %>%
  mutate(CZ=CZ/meanCZ, PL=PL/meanPL) %>%
  pivot_longer(c('CZ', 'PL'), names_to="geo", values_to='v') %>%
  mutate(v= v *100) %>%
  as.data.frame()
###

Średnia liczba zgonów w PL w latach 2015–2019 wyniosła 303.5 zaś w CZ wyniosła 58.7 tygodniowo. W roku pandemii w PL zmarło 321.7 oraz 58.4 odpowiednio albo 106.00% oraz 99.51%.

p4 <- ggplot(u3, aes(x= as.Date(date, format="%Y-%m-%d"), 
                     y=v, color=geo, group=geo)) +
  geom_smooth(method="loess", se=F, span=spanV) +
  geom_point(size=1.2, alpha=.5) +
  xlab(label="") +
  ylab(label="%") +
  scale_x_date( labels = date_format("%y%m%d"), breaks = mainBreaks) +
  ggtitle(sprintf("Zgony w PL i CZ (20--45) jako odchylenie od średniej"), subtitle=note)
p4

Bardziej szczegółowo (dla roku 2020):

mainBreaks <- "4 weeks"
u4 <- u3 %>%
  mutate (yr = as.numeric(substr(as.character(time), 1, 4))) %>%
  filter(yr > 2019) %>%
  as.data.frame()

p5 <- ggplot(u4, aes(x= as.Date(date, format="%Y-%m-%d"), 
                     y=v, color=geo, group=geo)) +
  geom_smooth(method="loess", se=F, span=spanV, size=1.5) +
  geom_point(size=2.5, alpha=.5) +
  xlab(label="") +
  ylab(label="%") +
  scale_x_date( labels = date_format("%m%d"), breaks = mainBreaks) +
  ggtitle(sprintf("Zgony w PL i CZ (20--45) jako odchylenie od średniej"), subtitle=note)

p5

PL

Tylko dla PL ale bardziej szczegółowo, bo w podziale na następujące grupy wiekowe: do 30 lat, 30–50, 50–70 oraz powyżej 70 lat:

wiek	2019	2020	różnica	różnica/%	różnica/t	2020/t	2019/t
Y30	5948.0	5362	-586.0	90.14795	-11.26923	103.1154	114.3846
Y50	20976.6	23345	2368.4	111.29068	45.54615	448.9423	403.3962
Y70	118634.4	129188	10553.6	108.89590	202.95385	2484.3846	2281.4308
Y99	256495.8	327546	71050.2	127.70034	1366.35000	6298.9615	4932.6115

(/t) oznacza przeciętną wielkość na tydzień, np różnica/t to różnica w liczbie zgonów pomiędzy średnią 2015–2019 a rokiem 2020 średnio w tygodniu.

Jeszcze bardziej szczegółowo (oryginalne grupy wiekowe):

wiek	2019	2020	różnica	różnica/%	różnica/t	2020/t	2019/t
Y05	1744.4	1492	-252.4	85.53084	-4.8538462	28.692308	33.546154
Y10	185.6	153	-32.6	82.43534	-0.6269231	2.942308	3.569231
Y15	226.2	193	-33.2	85.32272	-0.6384615	3.711539	4.350000
Y20	685.4	565	-120.4	82.43362	-2.3153846	10.865385	13.180769
Y25	1281.8	1215	-66.8	94.78858	-1.2846154	23.365385	24.650000
Y30	1824.6	1744	-80.6	95.58259	-1.5500000	33.538461	35.088462
Y35	2833.6	2788	-45.6	98.39074	-0.8769231	53.615385	54.492308
Y40	4091.8	4708	616.2	115.05939	11.8500000	90.538461	78.688462
Y45	5811.8	6597	785.2	113.51044	15.1000000	126.865385	111.765385
Y50	8239.4	9252	1012.6	112.28973	19.4730769	177.923077	158.450000
Y55	13024.0	13279	255.0	101.95792	4.9038462	255.365385	250.461538
Y60	23856.2	21223	-2633.2	88.96220	-50.6384615	408.134615	458.773077
Y65	37096.2	39122	2025.8	105.46094	38.9576923	752.346154	713.388461
Y70	44658.0	55564	10906.0	124.42116	209.7307692	1068.538462	858.807692
Y75	37096.2	61321	24224.8	165.30265	465.8615385	1179.250000	713.388461
Y80	45584.4	49593	4008.6	108.79380	77.0884615	953.711538	876.623077
Y85	59916.8	68653	8736.2	114.58055	168.0038462	1320.250000	1152.246154
Y90	62804.8	74610	11805.2	118.79665	227.0230769	1434.807692	1207.784615
Y99	49722.4	73369	23646.6	147.55724	454.7423077	1410.942308	956.200000

Kolumnę #4 (różnica w liczbie zgonów) można też przedstawić na wykresie; zaznaczono kategorie wiekowe w których zaobserwowano znaczący spadek:

pl0 <- pl0 %>% mutate (grp = d ) %>%
  ## zaznacz kategorie ze znaczącym spadkiem
  mutate( grp=case_when(grp < -999 ~ "1", TRUE ~ "0") ) 

p9 <- ggplot(pl0, aes(x=age, y=d, fill=grp)) +
    #geom_point(size=1.8, alpha=.3) +
  ylab(label="zgony") +
  xlab(label="wiek") +
  scale_fill_manual( values = c( "1" = "#F8766D", "0" = "#00BFC4" ), guide = FALSE ) +
    geom_bar(stat="identity", position=position_dodge(width=.4), width=.8, alpha=.5) +
        coord_flip() +
    ggtitle("Zgony w PL", subtitle="Różnica 2015--2019 a 2020 wg grup wieku ")
p9

Najgorzej wyglądają grupy 65–75 oraz 85+. Nie chwaląc się kategoria, w której liczba zgonów znacząco spadła to moja kategoria wiekowa. Przypadek:-)?

Zgony w Europie

TP

1/3/2021

Dane

Grupa wiekowa 70+

Grupa wiekowa 20–45

PL