Ein Thema, das mich seit Beginn der Pandemie interessiert und für das ich erstaunlich selten aufbereitete Grafiken finde, sind Unterschiede zwischen Altersgruppen. Die Daten liegen vor und werden auch vom RKI auf dem eigenen Dashboard dargestellt. Was nicht dargestellt wird sind Zeitreihen.
Das Thema interessiert mich als Vater besonders, weil für Familien der Einfluss von Schul- und Kindergartenschließungen enorm ist. In der Betrachtung der Daten werde ich daher vor allem aus dieser Brille auf die Daten schauen und verschiedene Visualisierungsmöglichkeiten zeigen.
Für die Visualisierungen nutze ich:
- Daten des RKI (Rohdatei, csv): https://npgeo-corona-npgeo-de.hub.arcgis.com/datasets/dd4580c810204019a7b8eb3e0b329dd6_0
- Bevölkerungsdaten aus dem Zensus: https://www-genesis.destatis.de/genesis//online?operation=table&code=12111-0002&bypass=true&levelindex=1&levelid=1619459516101#abreadcrumb
Positive Tests aufgesplittet nach Altersgruppe
Zunächst einfach mal die Anzahl der positiven Tests über die Zeit aufgesplittert nach Altersgruppen, die dass Rai angibt.
Interessant finde ich hier die Wellenform die für jede Altersgruppe insbesondere in der zweiten Welle deutlich zu erkennen ist. In der zweiten Welle ist die nicht der Fall für Kinder (Altersgruppe 0-4 und 5-14). Interessanterweise bleibt auch die Zahl der positiven Tests bei den Menschen über 80 in der dritten Welle flach. Ein Hinweis auf die Wirksamkeit der Impfungen, wie mittlerweile auch die Zeit meint.
Positive Tests gestapelt nach Altersgruppe
Eine Alternative Darstellung dieser Daten ist, die Linien zu stapeln:
Mir gefällt diese Darstellung sehr, weil sich die einzelnen Altersgruppen einfach zur Gesamt-Kurve addieren. Die Relationen der Anzahl zwischen den Gruppen kommen hier schön zur Geltung. Schaut man auf den Anteil der Kinder an der Gesamtzahl der positiv getesteten Personen, scheint dieser gering. In einer anderen Darstellung lässt er sich aber noch besser einschätzen.
Positive Tests nach Altersgruppe – relativ gestapelt
Berechnet man der relativen Anteil aller Altersgruppen an der Gesamtzahl und macht ein Bild daraus, sieht man folgendes:
Zur Orientierung habe ich den Verlauf der Gesamtzahl positiver Tests mit in dass Bild geplottet. Spannend ist, dass während der ersten und zweiten Welle der Anteil der Über 60-Jährigen stark ansteigt. Dieser Effekt scheint vor allem durch die Menschen über 80 getrieben zu sein und ist für die 3. Welle nicht sichtbar.
Offensichtlich wird auch, dass mehr als 60% aller positiven Tests auf Menschen zwischen 15 und 59 zurückzuführen sind
Es gibt zwei Probleme mit den Stapeldarstellungen:
- Der unterste Bereich verzerrt optisch alle darüber gestapelten Bereiche – ich persönlich finde Stapeldarstellungen daher zwar hübsch aber wenig aussagefähig
- Die Darstellung berücksichtig nicht die unterschiedliche Größe der Altersgruppen
Inzidenz nach Altersgruppen
Dieses Problem lässt sich lösen, wenn man die 7-Tage-Inzidenz je 100.000 Einwohner je Altersgruppe berechnet, wie das auch für Landkreise getan wird.
Die Linien zeigen nun, wie stark betroffen Altersgruppen zum jeweiligen Zeitpunkt waren. Am stärksten springt der Gipfel zum Höhepunkt der zweiten Welle heraus: Menschen über 80 waren zu diesem Zeitpunkt besonders stark betroffen. Verhältnismäßig wenig betroffen (positiv getestet) waren in der zweiten Welle Kinder. Dieses Bild ändert sich ein wenig zur dritten Welle, wo Kinder ungefähr so häufig positiv getestet werden wie Erwachsene.
Zur besseren Detaillierung, die gleichen Daten getrennt für Jüngere und Ältere.
Was für mich aus diesen Darstellungen deutlich wird und eigentlich seit Beginn der Pandemie erahnbar ist, ist, dass Kinder vermutlich keine herausragende Rolle im Pandemiegeschehen spielen. Sie weisen weder von der absoluten Anzahl an positiv getesteten, noch nach relativem Anteil noch nach Inzidenz höhere Werte vor als andere Altersgruppen.
Gleichzeitig bilden Kinder meiner Meinung nach eine besonders schützenswerte Gruppe. Bei der Auswahl von Maßnahmen sollten Kinder daher weiter starken Maßnahmen ausgesetzt sein als Erwachsene. Dieser Umstand wird auch durch die Diskussionen um Privilegien für Geimpfte relevanter. Für Kinder gibt es bisher keine zugelassenen Impfstoffe (was auch sinnvoll ist). D.h. hier müssen Privilegien für Kinder unabhängig vom Impfstatus mitbrachtet werden.
R Skript
Im Skript werden lokale Dateien geladen, die selbst gespeichert werden müssen. Weil ich verschiedene Datenquellen nutze und kombiniere, werden im Skript mehr Daten geladen als für obige Grafik nötig.
- Download R: https://ftp.fau.de/cran/
- Download R Studio: https://www.rstudio.com/products/rstudio/download/#download
########### Daten aus DIVI laden und nur die Daten für Deutschland auswählen ##########
#Einlesen
bundesland.zeitreihe <- read.csv("https://diviexchange.blob.core.windows.net/%24web/bundesland-zeitreihe.csv")
#Filtern
divi <- filter(bundesland.zeitreihe, Bundesland == "DEUTSCHLAND")
divi_s <- divi[,-(2:3)]
max(divi$Anzahl_Meldebereiche_Erwachsene)
plot(divi$Anzahl_Meldebereiche_Erwachsene, type = "l")
#Aufräumen
names(divi_s) <- c("Datum", "covCount", "bedsUsed", "bedsFree", "reserve", "ivFree", "ivFreeCov", "sitGood", "sitMedium", "sitBad", "sitNA")
divi_s$Datum <- as.Date(divi_s$Datum)
#Moving Averages berechnen
divi_s$bedsUsed_7 <- movavg(divi_s$bedsUsed,7,"s")
############### Daten vom RKI laden, aggregieren und moving averages der letzten 7 Tage berechnen ##############
#Einlesen
rki <- read.csv("https://opendata.arcgis.com/datasets/dd4580c810204019a7b8eb3e0b329dd6_0.csv")
rki_s <- data.frame(rki$Meldedatum, rki$AnzahlFall, rki$AnzahlTodesfall, rki$AnzahlGenesen)
#Anzahl der Fälle auf Null setzen, wo es sich um Todesfall, aber keinen neuen Fall handelt
rki$AnzahlFall[rki$NeuerFall == 1] <- 0
#Aggregieren
names(rki_s) <- c("Datum", "Infekt", "Tod", "Gesund")
rki_a <- aggregate(rki_s[,2:4], list(rki_s$Datum), FUN = sum)
names(rki_a) <- c("Datum","Infekt", "Tod", "Gesund")
#Moving Averages berechnen
Infekt_7 <- movavg(rki_a$Infekt,7,"s")
Tod_7 <- movavg(rki_a$Tod,7,"s")
Gesund_7 <- movavg(rki_a$Gesund,7,"s")
#Aufräumen
rki_c <- data.frame(rki_a, Infekt_7, Tod_7, Gesund_7)
rki_c$Datum <- as.Date(rki_c$Datum)
####### RKI Fallzahlen und DIVI Daten Mergen und Normalisieren #########
#RKi Fallzahlen und DIVI zahlen mergen und weitere Variablen bereechnen
d <- merge(rki_c, divi_s, by=c("Datum"), all.x = TRUE)
d$beds <- d$bedsFree + d$bedsUsed
d$bedsT <- d$bedsFree + d$bedsUsed + d$reserve
d$ivFree
#Normalisierung von Variablen
z <- as.data.frame(apply(d[,c("Infekt_7", "Tod_7", "covCount", "ivFree", "bedsUsed_7", "beds", "bedsT", "sitGood", "ivFreeCov")], 2, FUN = normalize, method = "range", range = c(0,1)))
z$Datum <- d$Datum
z$ivFree[z$ivFree == 0] <- NA
z$ivFreeCov[z$ivFreeCov == 0] <- NA
########## RKI Testdaten aus lokaler Excel einlesen ##########
#Einlesen und unnötige Zeilen rauswerfen
tests <- read_excel("Documents/Corona Date/Testzahlen-gesamt.xlsx")
tests <- tests[-c((nrow(tests)-(nrow(tests)-1)),nrow(tests)),]
names(tests) <- c("KW", "Zahl", "ZahlPos", "PosAnteil", "Labore")
#Datensatz bereinigen, erste und letzte Zeile entfernen, Daten normalisieren
tz <- as.data.frame(apply(tests[,c("Zahl", "ZahlPos", "PosAnteil", "Labore")], 2, FUN = normalize, method = "range", range = c(0,1)))
tz$KW <- tests$KW
######### RKI Testdaten von Wochenbericht auf Tage strecken ###################
#Vorbereitung des Datensatzes
ndays = nrow(z) # Zahl der Tage, die schon im RKI Bericht sind
td <- matrix(0, nrow = ndays, ncol = 4)
td <- as.data.frame(td)
names(td) <- c("Datum", "Zahl", "ZahlPos", "PosAnteil")
td$Datum <- z$Datum
# Wochenzahlen der Tests für jeden Tag reinschreiben
for(w in 0:(nrow(tests)-1)) {
for(p in 0:6){
td$Zahl[31 + (w*7) + p] <- tz$Zahl[w+1]
td$PosAnteil[31 + (w*7) + p] <- tz$PosAnteil[w+1]
td$ZahlPos[31 + (w*7) + p] <- tz$ZahlPos[w+1]
}
}
#Die Tage, für die es am Ende noch keine Daten gibt großzügig rauswerfen
s <- ndays - 5
for(x in s:ndays){
td$Zahl[x] <- NA
td$PosAnteil[x] <- NA
td$ZahlPos[x] <- NA
}
############ Mergen der DIVI, RKI, und Testdaten #############
total <- merge(z, td, by=c("Datum"), all.x = TRUE)
total$PosAnteil_7 <- movavg(total$PosAnteil, 7, "s")
########## RKi Daten nach Altersgruppen, Infektionen & Tode ##########################
#Datenauswählen
rage <- data.frame(rki$Meldedatum, rki$Altersgruppe, rki$AnzahlFall, rki$AnzahlTodesfall)
names(rage) <- c("Datum", "Altersgruppe", "Infekt", "Tod")
rage$Datum <- as.Date(rage$Datum)
#Aggregieren
age_dat <- aggregate(rage[3:4], by = list(rage$Datum, rage$Altersgruppe), FUN = sum, drop = FALSE)
names(age_dat) <- c("Datum", "Altersgruppe", "Infekt", "Tod")
#Splitten
age_dat_split <- split(age_dat, f= age_dat$Altersgruppe)
#Moving average berechnen
age_dat_split_7 <- lapply(age_dat_split, function(x){
x$Infekt_7 <- movavg(x$Infekt, 7, "s")
x$Tod_7 <- movavg(x$Tod, 7, "s")
return(x)
})
#Unsplitten
age_dat_comb <- unsplit(age_dat_split_7, f= age_dat$Altersgruppe)
############## Zensus-Daten einlesen #################
Zensus <- read_excel("Documents/Corona Date/Graphics/Altersgruppen/Zensus.xlsx")
Zensus$Alter <- as.numeric(Zensus$Alter)
Zensus_sum <-as.data.frame()
N_A00_A04 <- sum(subset(Zensus$J2019, Zensus$Alter < 5))
N_A05_A14 <- sum(subset(Zensus$J2019, Zensus$Alter > 4 & Zensus$Alter < 15))
N_A15_A34 <- sum(subset(Zensus$J2019, Zensus$Alter > 14 & Zensus$Alter < 35))
N_A35_A59 <- sum(subset(Zensus$J2019, Zensus$Alter > 34 & Zensus$Alter < 60))
N_A60_A79 <- sum(subset(Zensus$J2019, Zensus$Alter > 59 & Zensus$Alter < 80))
N_A80 <- sum(subset(Zensus$J2019, Zensus$Alter > 79))
Zensus_Sum <- as.data.frame(matrix(c("A00-A04", "A05-A14", "A15-A34", "A35-A59","A60-A79","A80+"), byrow = F, ncol = 1))
names(Zensus_Sum) <- c("Altersgruppe")
Zensus_Sum$Zahl_Alter <- c(N_A00_A04, N_A05_A14, N_A15_A34, N_A35_A59, N_A60_A79, N_A80)
#Zensus Daten an Alterstdaten ranmergen
age_dat_comb <- merge(age_dat_comb, Zensus_Sum, by=c("Altersgruppe"), all.x = TRUE)
#7 Tage Inzidenz je 100.000 Einwohner je Altersgruppe berechnen
age_dat_comb$Inz_7 <- age_dat_comb$Infekt_7 * 7 * 100000 / age_dat_comb$Zahl_Alter
############## rki Daten relativ ##################
age_dat_split_rel <- lapply(age_dat_split, function(x){
x$Infekt_rel <- x$Infekt / rki_a$Infekt
return(x)
})
#Moving Averages berechnen
age_dat_split_rel_7 <- lapply(age_dat_split_rel, function(x){
x$Infekt_rel_7 <- movavg(x$Infekt_rel, 7, "s")
return(x)
})
#unsplitten
age_dat_comb_rel <- unsplit(age_dat_split_rel, f= age_dat$Altersgruppe)
age_dat_comb_rel_7 <- unsplit(age_dat_split_rel_7, f= age_dat$Altersgruppe)
################# Plotten relativer Anteeil der Erkrankten nach Altersgruppe #######################
#Anzahl als einfache Linie
age_line <- ggplot(data = subset(age_dat_comb,age_dat_comb$Datum > "2020-03-01" & age_dat_comb$Altersgruppe != "unbekannt"), aes(x = Datum, y = Infekt_7)) + geom_line(aes(group = Altersgruppe, col = Altersgruppe), size = 0.5) + scale_color_brewer(palette = 3)
age_line <- age_line + ggtitle("Positive Tests nach Altersgruppen") + ylab("Positive Tests") + theme_classic() + theme(plot.title = element_text(hjust = 0.5), panel.background = element_rect(fill = "white"))
age_line
#Anzahl als gestapeltes Diagramm
age_plot <- ggplot(data = age_dat_comb, aes(x = Datum, y = Infekt_7)) + geom_area(aes(group = Altersgruppe, fill = Altersgruppe), position = 'stack') + scale_fill_brewer(palette = 3) + geom_line(aes(group = Altersgruppe), size = 0.3, position = "stack")
age_plot <- age_plot + ggtitle("Positive Tests nach Altersgruppen - gestapelt") + ylab("Positive Tests") + theme_classic() + theme(plot.title = element_text(hjust = 0.5), panel.background = element_rect(fill = "white"))
age_plot
#Relativer Anteil wegen Datenartefakten eingeschränkter Zeitbereich
rel_plot <- ggplot(data = subset(age_dat_comb_rel_7, age_dat_comb_rel_7$Datum > "2020-03-10" & age_dat_comb_rel_7$Datum < "2021-04-24" & age_dat_comb_rel_7$Altersgruppe != "unbekannt"), aes(x = Datum, y = Infekt_7)) + geom_area(aes(y = Infekt_rel_7 ,group = Altersgruppe, fill = Altersgruppe), position = 'stack') + scale_fill_brewer(palette = 3)
rel_plot <- rel_plot + ggtitle("Positive Tests nach Altersgruppen - relativ") + ylab("Anteil") + theme_classic() + theme(plot.title = element_text(hjust = 0.5), panel.background = element_rect(fill = "white")) + geom_line(data=subset(total, total$Datum > "2020-03-10" & total$Datum < "2021-04-24" ), aes(y = Infekt_7))
rel_plot
#Inzidenz für alle
inz_line <- ggplot(data = subset(age_dat_comb,age_dat_comb$Datum > "2020-03-01" & age_dat_comb$Altersgruppe != "unbekannt"), aes(x = Datum, y = Inz_7)) + geom_line(aes(group = Altersgruppe, col = Altersgruppe), size = 0.5) + scale_color_brewer(palette = 3)
inz_line <- inz_line + ggtitle("Inzidenz nach Altersgruppen") + ylab("Positive Tests je 100.000 Einwohner") + theme_classic() + theme(plot.title = element_text(hjust = 0.5), panel.background = element_rect(fill = "black")) + geom_hline(yintercept=165, linetype="dashed", color = "red")
inz_line
#Inzidenz Junge
inz_line_young <- ggplot(data = subset(age_dat_comb, age_dat_comb$Datum > "2020-03-01" & age_dat_comb$Altersgruppe %in% c("A00-A04", "A05-A14", "A15-A34")), aes(x = Datum, y = Inz_7)) + geom_line(aes(group = Altersgruppe, col = Altersgruppe), size = 0.5) + scale_color_brewer(palette = 1)
inz_line_young <- inz_line_young + ggtitle("Inzidenz nach Altersgruppen - Jüngere") + ylab("Positive Tests je 100.000 Einwohner") + theme_classic() + theme(plot.title = element_text(hjust = 0.5), panel.background = element_rect(fill = "black")) + geom_hline(yintercept=165, linetype="dashed", color = "red")
inz_line_young
#Inzidenz Alte
inz_line_old <- ggplot(data = subset(age_dat_comb, age_dat_comb$Datum > "2020-03-01" & age_dat_comb$Altersgruppe %in% c("A35-A59", "A60-A79", "A80+")), aes(x = Datum, y = Inz_7)) + geom_line(aes(group = Altersgruppe, col = Altersgruppe), size = 0.5) + scale_color_brewer(palette = 2)
inz_line_old <- inz_line_old + ggtitle("Inzidenz nach Altersgruppen - Ältere") + ylab("Positive Tests je 100.000 Einwohner") + theme_classic() + theme(plot.title = element_text(hjust = 0.5), panel.background = element_rect(fill = "black")) + geom_hline(yintercept=165, linetype="dashed", color = "red")
inz_line_old
Denkbär 