Motivación:

  • Este proyecto está inspirado en el ejercicio de DS4B. Enlace YouTube

0.- Carga de Paquetes

options(scipen=999)

library(readr)
library(tidyverse)
library(data.table)
library(readxl)
library(lubridate)
library(ggpubr)
library(ggdark)

library(knitr)

1.- Carga de Datos

2.- Preparación de datos

  • Transformamos tipos y nombres de variables.
  • Obtenemos el globlal con la suma de muertes e infectados.
  • Obtenemos el total de contagios y muertes por pais.

3.- Exploración inicial. Situación general

  • Vamos a analizar la situación por país.
# Caso Contagios
data1<-filter(data, Indicador=="cases")

# Preparamos dataset de Contagios
data1 %>%
  group_by(Pais) %>% 
  summarize(Contagiados = sum(Numero_Semanal)) %>% 
  arrange(desc(Contagiados)) %>%
  head(20) %>% 
  knitr::kable(row.names  = 1:20)
Pais Contagiados
1 America (total) 100109980
2 Europe (total) 92450160
3 Asia (total) 72591725
4 EU/EEA (total) 51619430
5 United States Of America 50846941
6 India 34746838
7 Brazil 22213762
8 United Kingdom 11361387
9 Russia 10214790
10 Africa (total) 9237053
11 Turkey 9154209
12 France 8582736
13 Germany 6816908
14 Iran 6170979
15 Spain 5534520
16 Argentina 5395044
17 Italy 5385649
18 Colombia 5109022
19 Indonesia 4260544
20 Poland 3940198 
# Caso Muertes
data2<-filter(data, Indicador=="deaths")

# Preparamos dataset de Muertes
data2 %>%
  group_by(Pais) %>% 
  summarize(Muertes = sum(Numero_Semanal)) %>% 
  arrange(desc(Muertes)) %>%
  head(20) %>% 
  kable(row.names = 1:20)
Pais Muertes
1 America (total) 2393027
2 Europe (total) 1603511
3 Asia (total) 1135911
4 EU/EEA (total) 886434
5 United States Of America 806437
6 Brazil 617803
7 India 477554
8 Russia 298222
9 Mexico 297916
10 Africa (total) 225851
11 Peru 202295
12 United Kingdom 147218
13 Indonesia 144002
14 Italy 136243
15 Iran 131083
16 Colombia 129487
17 France 125533
18 Argentina 116930
19 Germany 108352
20 Ukraine 93262

Conclusiones:

  • El continente mas afectado, actualmente, es América, tanto por contagios como por muertes.

  • España, según esta fuente, está en la posición 15 por contagios y no aparece ya, ni entre los 20 primeros por muertes, se estudiará.

  • Se incluye la India y brasil, para saber su evolución, al ver como ha empeorado su situación en las últimas semanas.

  • China no aparece en los 20 primeros lugares de este ranking.

4.- Evaluación tendencias.

  • El modelo epidemiológico predice que el número de infectados crecerá de forma exponencial hasta alcanzar el pico. En ese momento el ritmo de crecimiento comenzará a decaer y el acumulado de infectados pasará de una forma exponencial a una forma sigmoidal.

  • En este momento, nos encontramos casi en una recta, con pendiente “leve” pero positiva.

  • Dado que no necesitamos compararnos con otros países, al tener un histórico, vamos a evaluar la curva de contagios y muerte de España.

  • Comenzamos por explorar gráficamente su ciclo en cuanto a nuevos infectados y fallecidos por semana:

Conclusiones:

  • En el caso de España, se aprecia que aunque los contagios, en 2021, son menores en enero que respecto a los que ocurrían en Marzo y Abril de 2020, si se aprecia un aumento en las dos últimas semanas. Los fallecimientos por COVID se aprecia que aumentan un poco en las últimas semanas pero siguen siendo menor medida que en anteriores olas.

  • Es importante señalar que la tendencia de contagios, actual, es ascendente, y que el periodo de incubación es de 14 días. Se estudiará con mas detalle, más adelante.

  • Se estudian los Contagios en: España, la India y Brasil, para ver como le ha afectado las últimas variantes.

4.1 Tendencias por pais (sin acumulado)

  • Se confirma que aumenta el número de cotagios, hacia otro pico, en las últimas semanas, se estudiará el acumulado.

  • Se confirma la tendencia a la baja.

  • Tendencia a la baja en las últimas semanas.

5.- Comprobación tendencias (con acumulado)

  • Se aprecia que sigue tendencia alcista. Se hará estimación cronológica. La distancia entre los últimos puntos se comienza a aumentar en las últimas semanas, al igual que ocurrió en las olas anteriores.
# Contagios India. Acumulados.
data1  %>% 
  filter(Pais == 'India',Numero_Semana_Año > "2020-02-01") %>% 
  
  #Gráfico
  ggplot(aes(x= factor(Numero_Semana_Año), y = Casos_Acumulados_Semana)) +
  geom_vline(xintercept ="2020-50", labs("Vacuna COVID"), col="blue") + # Comienzo de vacunación Covid
  geom_vline(xintercept ="2021-19", labs("Vacuna COVID"),col="red") + # Comienzo de variante delta
  geom_point(color = 'orange') +
   geom_vline(xintercept ="2021-45", labs("Vacuna COVID"),col="yellow") + # Comienzo de variante Omicrom
  labs(x="Semanas del año", y= "Nº Contagios", title=" Contagios India por COVID-19")+
  dark_theme_minimal()+
  theme(axis.text.x = element_text(angle = 90,size = 8))

  • Se aprecia que la tendencia es ascendente, pero en muy poca medida.
# Contagios Brazil. Acumulados.
data1  %>% 
  filter(Pais == 'Brazil',Numero_Semana_Año > "2020-02-01") %>% 
  
  #Gráfico
  ggplot(aes(x= factor(Numero_Semana_Año), y = Casos_Acumulados_Semana)) +
  geom_point(color = 'orange') +
  geom_vline(xintercept ="2020-50", labs("Vacuna COVID"), col="blue") + # Comienzo de vacunación Covid
  geom_vline(xintercept ="2021-19", labs("Vacuna COVID"),col="red") + # Comienzo de variante delta
  
   geom_vline(xintercept ="2021-45", labs("Vacuna COVID"),col="yellow") + # Comienzo de variante Omicrom
  labs(x="Semanas del año", y= "Nº Contagios", title=" Contagios Brazil por COVID-19")+
  dark_theme_minimal() +
  theme(axis.text.x = element_text(angle = 90,size = 8))

  • Se aprecia que sigue tendencia alcista, aunque descendiendo levemente.

6.- Análisis España

Con un conjunto de datos tratado solo para España, pasamos a analizar la previsión de contagios futura.

6.1- Subconjunto, España. Semana 46 en adelante (2020)

Indicador Numero_Semanal Numero_Semana_Año Casos_Acumulados_Semana
cases 112042 2020-46 1541413
cases 81175 2020-47 1622588
cases 58574 2020-48 1681162
cases 50591 2020-49 1731753
cases 50564 2020-50 1782317
cases 68287 2020-51 1850604
cases 66070 2020-52 1916674
cases 98416 2020-53 2015090
cases 159789 2021-01 2174879
cases 233549 2021-02 2408428
cases 244117 2021-03 2652545
cases 201550 2021-04 2854095
cases 129967 2021-05 2984062
cases 75371 2021-06 3059433
cases 50184 2021-07 3109617
cases 38801 2021-08 3148418
cases 33455 2021-09 3181873
cases 32307 2021-10 3214180
cases 33846 2021-11 3248026
cases 42551 2021-12 3290577
cases 43083 2021-13 3333660
cases 59795 2021-14 3393455
cases 58827 2021-15 3452282
cases 58096 2021-16 3510378
cases 53376 2021-17 3563754
cases 42085 2021-18 3605839
cases 34810 2021-19 3640649
cases 32511 2021-20 3673160
cases 30958 2021-21 3704118
cases 28455 2021-22 3732573
cases 24335 2021-23 3756908
cases 23701 2021-24 3780609
cases 29824 2021-25 3810433
cases 78751 2021-26 3889184
cases 134658 2021-27 4023842
cases 176088 2021-28 4199930
cases 185382 2021-29 4385312
cases 156982 2021-30 4542294
cases 118656 2021-31 4660950
cases 90229 2021-32 4751179
cases 68180 2021-33 4819359
cases 51461 2021-34 4870820
cases 34006 2021-35 4904826
cases 23212 2021-36 4928038
cases 17834 2021-37 4945872
cases 14504 2021-38 4960376
cases 12219 2021-39 4972595
cases 10459 2021-40 4983054
cases 10665 2021-41 4993719
cases 12293 2021-42 5006012
cases 13252 2021-43 5019264
cases 15919 2021-44 5035183
cases 25300 2021-45 5060483
cases 40525 2021-46 5101008
cases 58613 2021-47 5159621
cases 87713 2021-48 5247334
cases 110360 2021-49 5357694
cases 176826 2021-50 5534520

6.2- Gráfico de nuevos infectados por semana

spain %>% 
  
  #Gráfico
  ggplot(aes(x= factor(Numero_Semana_Año), y = Numero_Semanal)) +
  geom_col(fill = 'orange', color ='red') +
  labs(x="Semanas del año",y= "Nº Contagios", title=" Contagios España COVID-19") +
  dark_theme_minimal() +
  theme(axis.text.x = element_text(angle = 90,size = 8))

6.3- Gráfico del acumulado de infectados semana.

spain %>% 
  
  #Gráfico
  ggplot(aes(x=factor(Numero_Semana_Año), y = Casos_Acumulados_Semana)) +
  geom_point(color = 'orange') +
  geom_smooth() +
   geom_vline(xintercept ="2020-50", labs("Vacuna COVID"), col="blue") + # Comienzo de vacunación Covid
  geom_vline(xintercept ="2021-19", labs("Vacuna COVID"),col="red") + # Comienzo de variante delta
  
   geom_vline(xintercept ="2021-45", labs("Vacuna COVID"),col="yellow") + # Comienzo de variante Omicrom
  labs(x="Semanas del año", y= "Nº Contagios Acumulados", title=" Contagios España 
       por COVID-19") +
  dark_theme_minimal() +
  theme(axis.text.x = element_text(angle = 90,size = 8))

  • La curva, realmente no ha parado de crecer durante toda la pandemia, ni al comienzo del año 2021. Así que sólo podemos pensar que durante los próximos días, en España, seguiran aumentando los contagios, aunque parece que se esta empezando a encontrar un punto de inflexión. Estaremos atentos de aquí en adelante.

  • En esta situación la pregunta es:

6.4- ¿Cuántos infectados podríamos esperar en los próximos días, es necesario tomar alguna medida adicional?

  • Vamos a intentar ajustar un modelo para predecirlo.

  • La estrategia de modelización, consiste en ajustar los datos a un modelo de regresión, que se ajuste lo mas posible a la realidad. En este caso se probará un ajuste lineal o cuadrático.

  • Creamos dataset específico.

Numero_Semanal Numero_Semana_Año Casos_Acumulados_Semana Log_Casos_Acu
112042 202046 1541413 6.187919
81175 202047 1622588 6.210208
58574 202048 1681162 6.225610
50591 202049 1731753 6.238486
50564 202050 1782317 6.250985
68287 202051 1850604 6.267314
66070 202052 1916674 6.282548
98416 202053 2015090 6.304294
159789 202101 2174879 6.337435
233549 202102 2408428 6.381734
244117 202103 2652545 6.423663
201550 202104 2854095 6.455468
129967 202105 2984062 6.474808
75371 202106 3059433 6.485641
50184 202107 3109617 6.492707
38801 202108 3148418 6.498092
33455 202109 3181873 6.502683
32307 202110 3214180 6.507070
33846 202111 3248026 6.511620
42551 202112 3290577 6.517272
43083 202113 3333660 6.522921
59795 202114 3393455 6.530642
58827 202115 3452282 6.538106
58096 202116 3510378 6.545354
53376 202117 3563754 6.551908
42085 202118 3605839 6.557006
34810 202119 3640649 6.561179
32511 202120 3673160 6.565040
30958 202121 3704118 6.568685
28455 202122 3732573 6.572008
24335 202123 3756908 6.574831
23701 202124 3780609 6.577562
29824 202125 3810433 6.580974
78751 202126 3889184 6.589859
134658 202127 4023842 6.604641
176088 202128 4199930 6.623242
185382 202129 4385312 6.642000
156982 202130 4542294 6.657275
118656 202131 4660950 6.668474
90229 202132 4751179 6.676801
68180 202133 4819359 6.682989
51461 202134 4870820 6.687602
34006 202135 4904826 6.690624
23212 202136 4928038 6.692674
17834 202137 4945872 6.694243
14504 202138 4960376 6.695515
12219 202139 4972595 6.696583
10459 202140 4983054 6.697496
10665 202141 4993719 6.698424
12293 202142 5006012 6.699492
13252 202143 5019264 6.700640
15919 202144 5035183 6.702015
25300 202145 5060483 6.704192
40525 202146 5101008 6.707656
58613 202147 5159621 6.712618
87713 202148 5247334 6.719939
110360 202149 5357694 6.728978
176826 202150 5534520 6.743080

  • Esto ya nos permite ver que la incidencia acumulada, no ha parado de incrementarse desde hace, como mínimo, 12-13 semanas atrás.

  • La columna “Log_Casos_Acu”, hace referencia al acumulado de casos contagiados, en escala log10.

6.5- Estimaciones numéricas con modelo (algoritmo).

  • Entrenamos la regresión (lineal múltiple)
## 
## Call:
## lm(formula = Casos_Acumulados_Semana ~ poly(Numero_Semana_Año, 
##     3), data = spain1)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -454554 -115866    3123  123430  388702 
## 
## Coefficients:
##                             Estimate Std. Error t value            Pr(>|t|)    
## (Intercept)                  3754794      23035 163.006 <0.0000000000000002 ***
## poly(Numero_Semana_Año, 3)1  8178668     175427  46.622 <0.0000000000000002 ***
## poly(Numero_Semana_Año, 3)2  2537137     175427  14.463 <0.0000000000000002 ***
## poly(Numero_Semana_Año, 3)3  -678053     175427  -3.865              0.0003 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 175400 on 54 degrees of freedom
## Multiple R-squared:  0.978,  Adjusted R-squared:  0.9768 
## F-statistic: 799.2 on 3 and 54 DF,  p-value: < 0.00000000000000022
  • Se comprueba que la variable es significativa (elegimos grado 3 para el polinomio), y que el modelo es adecuado (p-value de la F-statistic es muy baja). Vamos a utilizar el coeficiente para estimar el factor de crecimiento.
## La R2 del modelo, está próximo a 1, R2= 0.9779743 lo que nos indica cual es el porcentaje de la varianza, de las variables predictoras, que pueden explicar la variable a predecir, y por tanto, que porcentaje no conocemos y no puede explicarse de la variable a predecir. Es decir, podemos explicar un porcentaje muy alto de la varianza de esas variables
## El factor de crecimiento, medio, en las últimas 27 semanas, en España, es de: -0.02603343 .Es decir, cada semana se detecta un -102.6033 % menos de casos que la anterior. Aunque no se aprecia un descenso acusado en los contagios
  • Gráfico tendencia de factor de crecimiento (Fecha de realización: 15-02-2021)

  • Vamos a contrastar las predicciones del modelo contra los datos reales
spain1 %>% 
  mutate(Pred = predict(mod_spain, newdata = spain1)) %>% 
  
  #Gráfico
  ggplot(aes(x = Numero_Semana_Año)) +
  geom_line(aes(y = Casos_Acumulados_Semana), color = 'blue',size = 2) +
  geom_line(aes(y = Pred), color = 'red',size = 2) +
  geom_vline(xintercept =c(202045,202100, 202103)) + # Líneas verticales para:# Semana 45 de 2020. Fin del 2020 y marcado de semana 3 de 2021 (las dos más próximas).
  labs(x="Semanas del año", y= "Nº Contagios Acumulados", 
       title=" Comparación Curva de Contagios Real (azul) y Modelo (rojo)") +
  dark_theme_minimal() +
  theme(axis.text.x = element_text(angle = 90, size = 10))

  • Ajusta bien, así que vamos a predecir los infectados en las próximas 4 semanas si no se toman nuevas medidas
Numero_Semana_Año Casos_Acumulados_Semana Pred
202046 1541413 1885914
202047 1622588 1840408
202048 1681162 1797778
202049 1731753 1757983
202050 1782317 1720986
202051 1850604 1686747
202052 1916674 1655228
202053 2015090 1626388
202101 2174879 2629433
202102 2408428 2684139
202103 2652545 2739574
202104 2854095 2795699
202105 2984062 2852477
202106 3059433 2909867
202107 3109617 2967832
202108 3148418 3026331
202109 3181873 3085325
202110 3214180 3144777
202111 3248026 3204646
202112 3290577 3264894
202113 3333660 3325482
202114 3393455 3386370
202115 3452282 3447521
202116 3510378 3508894
202117 3563754 3570450
202118 3605839 3632152
202119 3640649 3693959
202120 3673160 3755833
202121 3704118 3817734
202122 3732573 3879624
202123 3756908 3941464
202124 3780609 4003215
202125 3810433 4064837
202126 3889184 4126292
202127 4023842 4187540
202128 4199930 4248543
202129 4385312 4309262
202130 4542294 4369657
202131 4660950 4429690
202132 4751179 4489322
202133 4819359 4548513
202134 4870820 4607225
202135 4904826 4665418
202136 4928038 4723054
202137 4945872 4780094
202138 4960376 4836498
202139 4972595 4892228
202140 4983054 4947244
202141 4993719 5001508
202142 5006012 5054980
202143 5019264 5107622
202144 5035183 5159394
202145 5060483 5210258
202146 5101008 5260174
202147 5159621 5309104
202148 5247334 5357009
202149 5357694 5403849
202150 5534520 5449585
202151 NA 5494179
202152 NA 5537591
202153 NA 5579783
202154 NA 5620715
202155 NA 5660349
  • Vamos a verlo gráficamente
spain_pred %>% 
  
  #Gráfico
  ggplot(aes(x = Numero_Semana_Año )) +  
  geom_line(aes(y = Pred), color = 'red') +
  geom_line(aes(y = Casos_Acumulados_Semana ), color = 'blue',size = 2) +
  geom_vline(xintercept =c(202045,202100, 202104))+ # Líneas verticales para:
  # Semana 45 de 2020. Fin del 2020 y marcado de semana 4 de 2021 (las dos más próximas).
  labs(x="Semanas del año", y= "Nº Contagios Acumulados", title=" Comparación Curva Real 
       (azul) y Modelo (rojo). Contagiados Real y Previstos Respectivamente") +
  dark_theme_minimal() +
  theme(axis.text.x = element_text(angle = 90, size = 10))

  • NOTA. Es importante tener presente que las predicciones son por semanas, no por día, eso junto con las medidas contra el COVID-19 que se mantengan o modifiquen, pueden variar los datos.

7.- Conclusiones y respuestas a las principales preguntas

(Fecha de Publicación inicial: 09-02-2021. Fecha de Última Publicación: 29-12-2021)

¿Están funcionando las medidas actuales?

  • En mi opinión, en España, se aprecia una contención del proceso de contagio, por la vacunación y por la continuidad de las medidas de prevención, tanto las indicadas por los gobiernos como las tomadas individualmente. Aunque en los paÍses en los que ha comenzado a ser dominante la variable Omicrom, se ha comenzado a detectar un aumento de los contagios.

  • El factor de crecimiento, en España, está actualmente por debajo de 1.

¿Qué medidas?

Debemos controlar 3 factores:

  • El número medio de personas con las que interactúa un infectado
  • La tasa de transmisión
  • Porcentaje de personas vacunadas con segunda dosis.

¿Cuando podemos empezar a ver un cambio en la curva?

  • Según los datos, la tendencia debería ser la misma mientras la tasa acumulada siga teniendo el mismo ratio, es decir menor que uno, con las medidas actuales. Por lo que habrá que tener presente, lo indicado anteriormente.

¿Cual será el efecto de la vacuna?

  • Se aprecia claramente, con los históricos, que esta descendiendo el número de personas infectadas y fallecidas, aunque está claro que el número, aún, es alto.

8.- Bibliografía

  • An Introduction to Statistical Learning: with Applications in R (Springer Texts in Statistics) libro

  • Programación práctica con R. Garrett Grolemund libro

  • DS4B. Curso Machine Learning. Isaac González DS4B

  • RStudio Community (Cheatsheets) Página

9.- Datos