Tarea Calificada N3

Author

Brigitte Arenaza Andrade

Cobertura de los Programas Sociales adscritos al MIDIS (diciembre 2024)

Estudiante: Arenaza Andrade, Brigitte Ashley (20211254)

La intención de este trabajo es conocer el número de distritos con menor cobertura de los programas sociales hasta diciembre del 2024. Para ello, se trabaja con un dataset obtenido del MIDIS en la Plataforma Nacional de Datos abiertos del Estado Peruano.

library(rio)
library(dplyr)


Adjuntando el paquete: 'dplyr'

The following objects are masked from 'package:stats':

    filter, lag

The following objects are masked from 'package:base':

    intersect, setdiff, setequal, union

library(cluster)
data<- import("DICIEMBRE_2024.csv")
rownames(data)=data$UBIGEO
data <-  select(data, -FECHA_CORTE, - UBIGEO)

str(data)

'data.frame':   1892 obs. of  16 variables:
 $ CUNAMAS - Cuidado Diurno                                   : int  96 NA 0 0 NA 0 0 0 0 0 ...
 $ CUNAMAS - Acompañamiento de Familias                       : int  151 NA 19 10 NA 64 2 8 196 127 ...
 $ JUNTOS - Hogares afiliados                                 : int  494 14 106 37 59 191 29 31 658 229 ...
 $ JUNTOS - Hogares abonados                                  : int  473 11 100 36 56 190 29 31 648 222 ...
 $ FONCODES - Nº usuarios estimados                           : int  NA NA 1640 NA NA 1804 NA NA NA NA ...
 $ FONCODES - N° proy. Culminados                             : int  NA NA NA NA NA NA NA NA NA NA ...
 $ FONCODES - N° proy. en ejecucion                           : int  NA NA 1 NA NA 2 NA NA NA NA ...
 $ FONCODES - N° Hog. Haku Winay -proyectos en ejecucion      : int  NA NA 400 NA NA 440 NA NA 0 NA ...
 $ FONCODES - N° Hog. Haku Winay -proyectos culminados        : int  NA NA 0 NA NA 0 NA NA 448 NA ...
 $ PENSION 65 - Usuarios                                      : int  637 33 58 48 67 133 44 28 378 167 ...
 $ QALI WARMA - N° de Niños y niñas atendidos                 : int  5234 18 252 70 73 372 49 36 1364 477 ...
 $ QALI WARMA - N° de IIEE                                    : int  34 4 15 5 9 22 4 2 30 15 ...
 $ CONTIGO - Usuarios                                         : int  250 4 16 16 5 23 7 3 83 60 ...
 $ PAIS - N° de Tambos prestando servicios                    : int  NA NA NA NA NA NA NA NA NA NA ...
 $ PAIS - N° de Atenciones realizadas a través de los Tambos  : int  NA NA NA NA NA NA NA NA NA NA ...
 $ PAIS - N° de Beneficiarios atendidos a través de los Tambos: int  NA NA NA NA NA NA NA NA NA NA ...

La data se normaliza

data_norm<- scale(data)
data2 <- as.data.frame(data_norm)

Los modelos son sensibles a datos perdidos, por lo que es importante identificarlos y tratarlos.

library(naniar)
data2|> 
  vis_miss()

colSums(is.na(data2))

                                   CUNAMAS - Cuidado Diurno 
                                                        397 
                       CUNAMAS - Acompañamiento de Familias 
                                                        397 
                                 JUNTOS - Hogares afiliados 
                                                          8 
                                  JUNTOS - Hogares abonados 
                                                         10 
                           FONCODES - Nº usuarios estimados 
                                                       1453 
                             FONCODES - N° proy. Culminados 
                                                       1703 
                           FONCODES - N° proy. en ejecucion 
                                                       1583 
      FONCODES - N° Hog. Haku Winay -proyectos en ejecucion 
                                                       1124 
        FONCODES - N° Hog. Haku Winay -proyectos culminados 
                                                       1124 
                                      PENSION 65 - Usuarios 
                                                          1 
                 QALI WARMA - N° de Niños y niñas atendidos 
                                                          3 
                                    QALI WARMA - N° de IIEE 
                                                          3 
                                         CONTIGO - Usuarios 
                                                         57 
                    PAIS - N° de Tambos prestando servicios 
                                                       1491 
  PAIS - N° de Atenciones realizadas a través de los Tambos 
                                                       1494 
PAIS - N° de Beneficiarios atendidos a través de los Tambos 
                                                       1494

Los programas que contienen demasiados valores perdidos son PAIS y FONCONDES. Por ello, se procede a retirarlos del dataset.

data2 <- select(data2, -`PAIS - N° de Atenciones realizadas a través de los Tambos`, 
                -`PAIS - N° de Beneficiarios atendidos a través de los Tambos`,
                - `PAIS - N° de Tambos prestando servicios`, 
                -`PAIS - N° de Tambos prestando servicios`,
                - `FONCODES - Nº usuarios estimados`,
                - `FONCODES - N° proy. Culminados`, 
                - `FONCODES - N° proy. en ejecucion`,
                - `FONCODES - N° Hog. Haku Winay -proyectos en ejecucion`, 
                - `FONCODES - N° Hog. Haku Winay -proyectos culminados`)

Se vuelve a verificar aquellos programas que aún contienen perdidos

library(naniar)
data2|> 
  vis_miss()

Para que no existan tantos perdidos, se decide imputar la data.

library(mice)

Warning: package 'mice' was built under R version 4.5.2


Adjuntando el paquete: 'mice'

The following object is masked from 'package:stats':

    filter

The following objects are masked from 'package:base':

    cbind, rbind

data_imputada <- mice(data2, m=1, method='mean', seed=20211254)


 iter imp variable
  1   1  CUNAMAS - Cuidado Diurno  CUNAMAS - Acompañamiento de Familias  JUNTOS - Hogares afiliados  PENSION 65 - Usuarios  QALI WARMA - N° de Niños y niñas atendidos  QALI WARMA - N° de IIEE  CONTIGO - Usuarios
  2   1  CUNAMAS - Cuidado Diurno  CUNAMAS - Acompañamiento de Familias  JUNTOS - Hogares afiliados  PENSION 65 - Usuarios  QALI WARMA - N° de Niños y niñas atendidos  QALI WARMA - N° de IIEE  CONTIGO - Usuarios
  3   1  CUNAMAS - Cuidado Diurno  CUNAMAS - Acompañamiento de Familias  JUNTOS - Hogares afiliados  PENSION 65 - Usuarios  QALI WARMA - N° de Niños y niñas atendidos  QALI WARMA - N° de IIEE  CONTIGO - Usuarios
  4   1  CUNAMAS - Cuidado Diurno  CUNAMAS - Acompañamiento de Familias  JUNTOS - Hogares afiliados  PENSION 65 - Usuarios  QALI WARMA - N° de Niños y niñas atendidos  QALI WARMA - N° de IIEE  CONTIGO - Usuarios
  5   1  CUNAMAS - Cuidado Diurno  CUNAMAS - Acompañamiento de Familias  JUNTOS - Hogares afiliados  PENSION 65 - Usuarios  QALI WARMA - N° de Niños y niñas atendidos  QALI WARMA - N° de IIEE  CONTIGO - Usuarios

Warning: Number of logged events: 1

data2 <- complete(data_imputada)

data2 <- na.omit(data2)

Se usa este código para asegurar no quede ningún valor perdido.

library(naniar)
data2|> 
  vis_miss()

colSums(is.na(data2))

                  CUNAMAS - Cuidado Diurno 
                                         0 
      CUNAMAS - Acompañamiento de Familias 
                                         0 
                JUNTOS - Hogares afiliados 
                                         0 
                 JUNTOS - Hogares abonados 
                                         0 
                     PENSION 65 - Usuarios 
                                         0 
QALI WARMA - N° de Niños y niñas atendidos 
                                         0 
                   QALI WARMA - N° de IIEE 
                                         0 
                        CONTIGO - Usuarios 
                                         0

Clusterización por K-means

Seleccionar el número optimo de cluster con NbClust

library(NbClust)

Warning: package 'NbClust' was built under R version 4.5.2

set.seed(20211254)
res.nbclust <- NbClust(data2, distance = "euclidean",
                       min.nc = 2, max.nc = 5, 
                       method = "average", index ="all")

[1] "Frey index : No clustering structure in this data set"

*** : The Hubert index is a graphical method of determining the number of clusters.
                In the plot of Hubert index, we seek a significant knee that corresponds to a 
                significant increase of the value of the measure i.e the significant peak in Hubert
                index second differences plot.

*** : The D index is a graphical method of determining the number of clusters. 
                In the plot of D index, we seek a significant knee (the significant peak in Dindex
                second differences plot) that corresponds to a significant increase of the value of
                the measure. 
 
******************************************************************* 
* Among all indices:                                                
* 8 proposed 2 as the best number of clusters 
* 9 proposed 3 as the best number of clusters 
* 2 proposed 4 as the best number of clusters 
* 4 proposed 5 as the best number of clusters 

                   ***** Conclusion *****                            
 
* According to the majority rule, the best number of clusters is  3 
 
 
*******************************************************************

El resultado arroja que la mejor opción es trabajas con 3 clusters.

Ahora trabajamos propiamente con k means, con tres centros, 100 interacciones máximas y 15 puntos iniciales:

set.seed(20211254)
km <- kmeans(data2, 
             centers = 3,     
             iter.max = 100,  
             nstart = 15,     
             algorithm = "Lloyd")

options(max.print = 50)
print(km)

K-means clustering with 3 clusters of sizes 382, 76, 1424

Cluster means:
  CUNAMAS - Cuidado Diurno CUNAMAS - Acompañamiento de Familias
1                0.2931117                            0.4861109
2                2.0607839                            2.1932370
3               -0.1886153                           -0.2474581
  JUNTOS - Hogares afiliados JUNTOS - Hogares abonados PENSION 65 - Usuarios
1                  0.7736813                 0.7759507             0.7668329
2                  3.2925693                 3.2439487             3.3167363
3                 -0.3823653                -0.3812874            -0.3781978
  QALI WARMA - N° de Niños y niñas atendidos QALI WARMA - N° de IIEE
1                                  0.4962835               0.8855417
2                                  3.1861101               3.1865865
3                                 -0.3004593              -0.4027257
  CONTIGO - Usuarios
1          0.6152580
2          3.2238969
3         -0.3354409

Clustering vector:
10101 10102 10103 10104 10105 10106 10107 10108 10109 10110 10111 10112 10113 
    1     3     3     3     3     3     3     3     3     3     3     3     3 
10114 10115 10116 10117 10118 10119 10120 10121 10201 10202 10203 10204 10205 
    3     3     3     3     3     3     3     3     1     1     3     3     2 
10206 10301 10302 10303 10304 10305 10306 10307 10308 10309 10310 10311 10312 
    1     3     3     3     3     3     3     3     3     3     3     3     3 
10401 10402 10403 10501 10502 10503 10504 10505 10506 10507 10508 
    2     1     2     3     3     3     3     3     3     3     3 
 [ reached 'max' / getOption("max.print") -- omitted 1832 entries ]

Within cluster sum of squares by cluster:
[1] 1859.527 3372.702  903.464
 (between_SS / total_SS =  56.9 %)

Available components:

[1] "cluster"      "centers"      "totss"        "withinss"     "tot.withinss"
[6] "betweenss"    "size"         "iter"         "ifault"

km$cluster

10101 10102 10103 10104 10105 10106 10107 10108 10109 10110 10111 10112 10113 
    1     3     3     3     3     3     3     3     3     3     3     3     3 
10114 10115 10116 10117 10118 10119 10120 10121 10201 10202 10203 10204 10205 
    3     3     3     3     3     3     3     3     1     1     3     3     2 
10206 10301 10302 10303 10304 10305 10306 10307 10308 10309 10310 10311 10312 
    1     3     3     3     3     3     3     3     3     3     3     3     3 
10401 10402 10403 10501 10502 10503 10504 10505 10506 10507 10508 
    2     1     2     3     3     3     3     3     3     3     3 
 [ reached 'max' / getOption("max.print") -- omitted 1832 entries ]

km$size

[1]  382   76 1424

prop.table(km$size)

[1] 0.20297556 0.04038257 0.75664187

km$centers

  CUNAMAS - Cuidado Diurno CUNAMAS - Acompañamiento de Familias
1                0.2931117                            0.4861109
2                2.0607839                            2.1932370
3               -0.1886153                           -0.2474581
  JUNTOS - Hogares afiliados JUNTOS - Hogares abonados PENSION 65 - Usuarios
1                  0.7736813                 0.7759507             0.7668329
2                  3.2925693                 3.2439487             3.3167363
3                 -0.3823653                -0.3812874            -0.3781978
  QALI WARMA - N° de Niños y niñas atendidos QALI WARMA - N° de IIEE
1                                  0.4962835               0.8855417
2                                  3.1861101               3.1865865
3                                 -0.3004593              -0.4027257
  CONTIGO - Usuarios
1          0.6152580
2          3.2238969
3         -0.3354409

Se visualiza los clusters creados:

library(factoextra)

Warning: package 'factoextra' was built under R version 4.5.2

Cargando paquete requerido: ggplot2

Welcome! Want to learn more? See two factoextra-related books at https://goo.gl/ve3WBa

fviz_cluster(km, data = data2, ellipse.type = "convex") +
  theme_classic()

Se procede a evaluarlo con el gráfico de silueta:

km_clusters <- eclust(x = data2, FUNcluster = "kmeans", 
                      k = 3, seed = 20211254,
                      hc_metric = "euclidean",
                      graph = FALSE)

km_clusters$centers

  CUNAMAS - Cuidado Diurno CUNAMAS - Acompañamiento de Familias
1                0.2979848                            0.4898869
2                2.0594672                            2.1967158
3               -0.1886153                           -0.2474581
  JUNTOS - Hogares afiliados JUNTOS - Hogares abonados PENSION 65 - Usuarios
1                  0.7775401                 0.7799036             0.7687687
2                  3.3064492                 3.2566692             3.3408495
3                 -0.3823653                -0.3812874            -0.3781978
  QALI WARMA - N° de Niños y niñas atendidos QALI WARMA - N° de IIEE
1                                  0.4973688               0.8888146
2                                  3.2164322               3.2005532
3                                 -0.3004593              -0.4027257
  CONTIGO - Usuarios
1          0.6183170
2          3.2430573
3         -0.3354409

km_clusters$silinfo

$widths
       cluster neighbor sil_width
21601        1        3 0.3986056
61001        1        3 0.3876767
50114        1        3 0.3870561
100103       1        3 0.3851399
100201       1        3 0.3814211
200303       1        3 0.3802102
160601       1        3 0.3790054
120604       1        3 0.3788067
100701       1        3 0.3766224
210204       1        3 0.3762826
60417        1        3 0.3751629
90705        1        3 0.3725897
160106       1        3 0.3713378
60802        1        3 0.3709248
130801       1        3 0.3688985
60201        1        3 0.3686169
 [ reached 'max' / getOption("max.print") -- omitted 1866 rows ]

$clus.avg.widths
[1]  0.12132386 -0.02256451  0.69716615

$avg.width
[1] 0.5512961

fviz_silhouette(sil.obj = km_clusters, 
                print.summary = TRUE, 
                palette = "jco",
                ggtheme = theme_classic())

Warning: `aes_string()` was deprecated in ggplot2 3.0.0.
ℹ Please use tidy evaluation idioms with `aes()`.
ℹ See also `vignette("ggplot2-in-packages")` for more information.
ℹ The deprecated feature was likely used in the factoextra package.
  Please report the issue at <https://github.com/kassambara/factoextra/issues>.

  cluster size ave.sil.width
1       1  383          0.12
2       2   75         -0.02
3       3 1424          0.70

El coeficiente de Silhoute (avg.width) promedio es 0.551, lo que quiere indicar que los cluster son moderadamente buenos.

Cluster con DBSCAN

Es necesario conocer el epsilon a usar:

distancias <- sort(dbscan::kNNdist(data2, k = 5))
dbscan::kNNdistplot(data2, k = 5)

distancias[1650]

  200504 
1.097945

La data sugiere trabajar con un epsilon de 1.09

Ahora, es importante conocer el número de vecinos (minPts)

set.seed(20211254)
dbscan_cluster1 <- fpc::dbscan(data = data2, 
                               eps = 1.09, 
                               MinPts = 3)
print(dbscan_cluster1)

dbscan Pts=1882 MinPts=3 eps=1.09
         0    1 2
border 170   19 2
seed     0 1690 1
total  170 1709 3

Ha identificado 7 grupos, pero el cero es ruido (cantidad de datos no agrupados).

set.seed(20211254)
dbscan::dbscan(data2, 1.09, 3)

DBSCAN clustering for 1882 objects.
Parameters: eps = 1.09, minPts = 3
Using euclidean distances and borderpoints = TRUE
The clustering contains 2 cluster(s) and 170 noise points.

   0    1    2 
 170 1709    3 

Available fields: cluster, eps, minPts, metric, borderPoints

El primer cluster posee demasiadas observaciones en comparación a los otros cluster.

fviz_cluster(dbscan_cluster1, 
             data2, stand = FALSE, 
             ellipse = FALSE, 
             geom = "point") + 
  labs(title = "DBSCAN") + theme_bw()

Método jerárquico

distancias= daisy(data2, 
                  metric="gower")

Retomamos la recomendación arrojada por NbClust en K-means y trabajamos con 3 clusters.

aglomerativo = hcut(x = distancias,       
                    k = 3,               
                    hc_func='agnes',      
                    hc_method = "ward.D")

Exploramos el cluster creado

fviz_dend(aglomerativo, 
          rect = TRUE,  
          cex = 0.5)

Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
ℹ Please use `linewidth` instead.
ℹ The deprecated feature was likely used in the factoextra package.
  Please report the issue at <https://github.com/kassambara/factoextra/issues>.

Warning: The `<scale>` argument of `guides()` cannot be `FALSE`. Use "none" instead as
of ggplot2 3.3.4.
ℹ The deprecated feature was likely used in the factoextra package.
  Please report the issue at <https://github.com/kassambara/factoextra/issues>.

Se evalúa la data de los clusters

plot(aglomerativo)

str(aglomerativo)

List of 13
 $ order    : int [1:1882] 1 1855 930 701 1861 1617 1860 1294 1311 1260 ...
 $ height   : num [1:1881] 0.01851 0.02328 0.04641 0.00897 0.01797 ...
 $ ac       : num 0.996
 $ merge    : int [1:1881, 1:2] -111 -388 -397 -1449 -1397 -1406 1 -1388 -1382 -18 ...
 $ diss     : NULL
 $ call     : language cluster::agnes(x = x, method = hc_method)
 $ method   : chr "ward"
 $ order.lab: chr [1:1882] "10101" "240105" "100111" "70107" ...
 $ cluster  : int [1:1882] 1 2 2 2 2 2 2 2 2 2 ...
 $ nbclust  : num 3
 $ silinfo  :List of 3
  ..$ widths         :'data.frame': 1882 obs. of  3 variables:
  .. ..$ cluster  : Factor w/ 3 levels "1","2","3": 1 1 1 1 1 1 1 1 1 1 ...
  .. ..$ neighbor : num [1:1882] 2 2 2 2 2 2 2 2 2 2 ...
  .. ..$ sil_width: num [1:1882] 0.411 0.403 0.401 0.396 0.394 ...
  ..$ clus.avg.widths: num [1:3] 0.0898 0.7132 0.0121
  ..$ avg.width      : num 0.533
 $ size     : int [1:3] 449 1349 84
 $ data     : 'dissimilarity' num [1:1770021] 0.0734 0.0734 0.08 0.0692 0.0643 ...
  ..- attr(*, "Labels")= chr [1:1882] "10101" "10102" "10103" "10104" ...
  ..- attr(*, "Size")= int 1882
  ..- attr(*, "Metric")= chr "mixed"
  ..- attr(*, "Types")= chr [1:8] "I" "I" "I" "I" ...
 - attr(*, "class")= chr [1:3] "agnes" "twins" "hcut"

El coeficiente de aglomeración (ac) es de 0.996. Esto es un buen indicador. De la misma manera, si se compara el coeficiente de Silhouette (avd.width), este es de 0.533.

Decisión final

Método	Coeficiente de Silhouette promedio
K-means	0.551
Jerárquico	0.533

En base a los resultados del coeficiente de Silhouette, el el método que mejor agrupo los datos fue k-means.

Análisis final

Se procede a incluir los resultados de k-means en la data final y

data2<-data2 %>% 
  mutate(cluster=km$cluster) 

data2%>% 
  group_by(cluster) %>% 
  summarise(`CUNAMAS - Cuidado Diurno` = mean(`CUNAMAS - Cuidado Diurno`),
            `CUNAMAS - Acompañamiento de Familias` = mean(`CUNAMAS - Acompañamiento de Familias`), `JUNTOS - Hogares afiliados`=mean(`JUNTOS - Hogares afiliados`), `JUNTOS - Hogares abonados`=mean(`JUNTOS - Hogares abonados`), `PENSION 65 - Usuarios`=mean(`PENSION 65 - Usuarios`), `QALI WARMA - N° de Niños y niñas atendidos`= mean(`QALI WARMA - N° de Niños y niñas atendidos`), `QALI WARMA - N° de IIEE`=mean(`QALI WARMA - N° de IIEE`), `CONTIGO - Usuarios`=mean(`CONTIGO - Usuarios`))

# A tibble: 3 × 9
  cluster CUNAMAS - Cuidado Diur…¹ CUNAMAS - Acompañami…² JUNTOS - Hogares afi…³
    <int>                    <dbl>                  <dbl>                  <dbl>
1       1                    0.293                  0.486                  0.774
2       2                    2.06                   2.19                   3.29 
3       3                   -0.189                 -0.247                 -0.382
# ℹ abbreviated names: ¹`CUNAMAS - Cuidado Diurno`,
#   ²`CUNAMAS - Acompañamiento de Familias`, ³`JUNTOS - Hogares afiliados`
# ℹ 5 more variables: `JUNTOS - Hogares abonados` <dbl>,
#   `PENSION 65 - Usuarios` <dbl>,
#   `QALI WARMA - N° de Niños y niñas atendidos` <dbl>,
#   `QALI WARMA - N° de IIEE` <dbl>, `CONTIGO - Usuarios` <dbl>

table(data2$cluster)


   1    2    3 
 382   76 1424

Resultado: El grupo de distritos con menos acceso a los programas sociales es el grupo 3 ya que sus promedios son inferiores a la media en cada una de las variables observadas. Esto es alarmante ya que a su vez este es el grupo con mayor número de casos (1424), lo que quiere indicar que la mayor parte de distritos no acceden a estos programas.