Tarea N° 8: Ejercicio sobre Análisis Factorial e Indicadores Sintéticos

Planteamiento del ejercicio.

Se pretende construir un indicador multivariado sintético sobre el Desarrollo en las Economías.
Los indicadores a considerar son:
El índice de alfabetización (alfabet)[+]
El incremento de la población (inc_pob)[+]
La esperanza de vida femenina (espvidaf)[+]
La mortalidad infantil (mortinf)[-]
El número promedio de hijos por mujer (fertilid) [+]
La tasa de natalidad (tasa_nat)[+]
El logaritmo del PIB (log_pib)[+]
La población urbana (urbana)[+]
La tasa de mortalidad (tasa_mor)[-]

Ejercicio 1.1.

Usando Análisis Factorial determine cuantos factores deberían retenerse.

Tabla de informacion.

Tabla de datos sin datos NA primera opcion.

library(dplyr)
library(kableExtra)
load("C:/Users/PC-GUEVARA/Desktop/metodos/Tarea Ejercicio sobre Análisis Factorial e Indicadores Sintéticos/data_desarrollo.RData")

datos_economias<-data_desarrollo  %>% 
  select(ALFABET, INC_POB, ESPVIDAF, MORTINF, FERTILID, TASA_NAT, LOG_PIB, URBANA, TASA_MOR) %>% 
  filter(complete.cases(.))

datos_economias %>%  
  head() %>% 
  kable(caption="Tabla sobre el Desarrollo en las Economías.",
        align = "c",
        digits = 2) %>% 
  kable_material(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("striped", "hover"))
Tabla sobre el Desarrollo en las Economías.
ALFABET INC_POB ESPVIDAF MORTINF FERTILID TASA_NAT LOG_PIB URBANA TASA_MOR
98 1.40 75 35.0 2.80 23 3.48 54 7
29 2.80 44 168.0 6.90 53 2.31 18 22
99 0.36 79 6.5 1.47 11 4.24 85 11
62 3.20 70 52.0 6.67 38 3.82 77 6
95 1.30 75 25.6 2.80 20 3.53 86 9
98 1.40 75 27.0 3.19 23 3.70 68 6

Tabla de datos sin datos NA segunda opcion.

library(tidyr)

# Sin select.

# medias<-apply(X=data_desarrollo[,c(-1,-5)], MARGIN=2, mean, na.rm=TRUE)

datos_economias_prueba<-data_desarrollo  %>% 
  select(ALFABET, INC_POB, ESPVIDAF, MORTINF, FERTILID, TASA_NAT, LOG_PIB, URBANA, TASA_MOR) 

media<-apply(X=datos_economias_prueba, MARGIN=2, mean, na.rm=TRUE)

datos_economias_prueba<-datos_economias_prueba %>% 
  replace_na(
    list(ALFABET=media[1], 
         INC_POB=media[2], 
         ESPVIDAF=media[3], 
         MORTINF=media[4], 
         FERTILID=media[5], 
         TASA_NAT=media[6], 
         LOG_PIB=media[7], 
         URBANA=media[8], 
         TASA_MOR=media[9]
      
    )
  )

datos_economias_prueba %>%  
  head() %>% 
  kable(caption="Tabla sobre el Desarrollo en las Economías sin datos NA.",
        align = "c",
        digits = 2) %>% 
  kable_material(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("striped", "hover"))
Tabla sobre el Desarrollo en las Economías sin datos NA.
ALFABET INC_POB ESPVIDAF MORTINF FERTILID TASA_NAT LOG_PIB URBANA TASA_MOR
98 1.40 75 35.0 2.80 23 3.48 54 7
29 2.80 44 168.0 6.90 53 2.31 18 22
99 0.36 79 6.5 1.47 11 4.24 85 11
62 3.20 70 52.0 6.67 38 3.82 77 6
95 1.30 75 25.6 2.80 20 3.53 86 9
98 1.40 75 27.0 3.19 23 3.70 68 6

Normalización de los datos.

library(dplyr)
norm_directa<-function(x){(x-min(x))/(max(x)-min(x))}
norm_inversa<-function(x){(max(x)-x)/(max(x)-min(x))}

#Seleccionando las variables con correlación positiva 
datos_economias_prueba %>% 
  select(ALFABET, INC_POB, ESPVIDAF, FERTILID, TASA_NAT, LOG_PIB, URBANA) %>% 
  apply(MARGIN = 2,FUN = norm_directa) %>% as.data.frame()->variables_corr_positiva

#Seleccionando las variables con correlación negativa 
datos_economias_prueba %>% 
  select(MORTINF, TASA_MOR) %>% 
  apply(MARGIN = 2,FUN = norm_inversa) %>% as.data.frame()->variables_corr_negativa

#Juntando y reordenando las variables
variables_corr_positiva %>% 
  bind_cols(variables_corr_negativa) %>% 
  select(ALFABET, INC_POB, ESPVIDAF, MORTINF, FERTILID, TASA_NAT, LOG_PIB, URBANA, TASA_MOR)->datos_economias_normalizados

datos_economias_normalizados %>%  
  head() %>% 
  kable(caption="Tabla sobre el Desarrollo en las Economías Normalizada.",
        align = "c",
        digits = 2) %>% 
  kable_material(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("striped", "hover"))
Tabla sobre el Desarrollo en las Economías Normalizada.
ALFABET INC_POB ESPVIDAF MORTINF FERTILID TASA_NAT LOG_PIB URBANA TASA_MOR
0.98 0.31 0.82 0.81 0.22 0.30 0.61 0.52 0.77
0.13 0.56 0.03 0.00 0.81 1.00 0.10 0.14 0.09
0.99 0.12 0.92 0.98 0.02 0.02 0.94 0.84 0.59
0.54 0.63 0.69 0.71 0.78 0.65 0.76 0.76 0.82
0.94 0.29 0.82 0.87 0.22 0.23 0.63 0.85 0.68
0.98 0.31 0.82 0.86 0.27 0.30 0.71 0.66 0.82

Matriz de Correlación & Pruebas de Barlett y KMO.

library(PerformanceAnalytics)
chart.Correlation(as.matrix(datos_economias_normalizados),histogram = TRUE,pch=12)

#KMO
library(rela)
KMO<-paf(as.matrix(datos_economias_normalizados))$KMO
print(KMO)
## [1] 0.862
#Prueba de Barlett
library(psych)
options(scipen = 99999)
Barlett<-cortest.bartlett(datos_economias_normalizados)
print(Barlett)
## $chisq
## [1] 1545.1
## 
## $p.value
## [1] 0.00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000011126
## 
## $df
## [1] 36

Con la Prueba KMO podemos aceptar el analisis factorial al obtener un valor de 0.86467

Con la Prueba de Barlett se llega a la conclusion de rechazar Ho al obtener un p-value de casi cero. Por lo que hay evidencia de correlacion poblacional entre la bateria de indicadores.

Análisis Factorial.

library(FactoMineR)
library(factoextra)
library(kableExtra)

Rx<-cor(datos_economias_normalizados)
PC<-princomp(x = datos_economias_normalizados,cor = TRUE,fix_sign = FALSE)
variables_pca<-get_pca_var(PC)
factoextra::get_eig(PC) %>% kable(caption=" Taba 1 Resumen de PCA",
        align = "c",
        digits = 2) %>% 
  kable_material(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("hover"))
Taba 1 Resumen de PCA
eigenvalue variance.percent cumulative.variance.percent
Dim.1 6.62 73.53 73.53
Dim.2 1.25 13.88 87.41
Dim.3 0.54 5.95 93.36
Dim.4 0.25 2.77 96.12
Dim.5 0.18 1.97 98.10
Dim.6 0.07 0.79 98.89
Dim.7 0.06 0.63 99.52
Dim.8 0.03 0.28 99.80
Dim.9 0.02 0.20 100.00 
fviz_eig(PC,
         choice = "eigenvalue",
         barcolor = "red",
         barfill = "red",
         addlabels = TRUE, 
       )+labs(title = "Gráfico de Sedimentación",subtitle = "Usando princomp, con Autovalores")+
  xlab(label = "Componentes")+
  ylab(label = "Autovalores")+geom_hline(yintercept = 1)

Criterio del 75%: debemos de retener tantas dimensiones que expliquen al menos el 75%. Tomando de base la Tabla 1 de Resumen de PCA, hasta la dimensión 2 nos permite tener 85.44%, por lo tanto se debe de tomar la Dimensión 1 y Dimensión 2.

Criterio de Raíz Latente: debemos de retener aquellos componentes que sean por lo menos uno o mayores a uno. Tomando de base la Tabla 1 de Resumen de PCA, la Dimensión 1 tiene un eigenvalue de 6.45 y la Dimensión 2 tiene un eigenvalue de 1.24, solo esas dos dimensiones tienen valores superiores a uno por lo tanto solo esas dos de deben retener.

Criterio de Elbow: se tomara la cantidad de dimensiones exactamente donde ocurre el codo. Tomando de base el Grafico de Sedimentación, el codo se da en la Dimensión 2 de 1.2, por lo tanto se debe de retener la Dimensión 1 y Dimensión 2.

Con los 3 criterios podemos llegar a la conclusión que los componentes a retener serian 2.

Ejercicio 1.2.

¿Qué variables quedan representadas en cada factor?

library(corrplot)
#Modelo de 2 Factores (Rotada)
numero_de_factores<-2
modelo_factores<-principal(r = Rx,
                             nfactors = numero_de_factores,
                             covar = FALSE,
                             rotate = "varimax")
modelo_factores
## Principal Components Analysis
## Call: principal(r = Rx, nfactors = numero_de_factores, rotate = "varimax", 
##     covar = FALSE)
## Standardized loadings (pattern matrix) based upon correlation matrix
##            RC1   RC2   h2    u2 com
## ALFABET   0.75  0.54 0.85 0.148 1.8
## INC_POB  -0.98  0.05 0.96 0.042 1.0
## ESPVIDAF  0.62  0.76 0.96 0.036 1.9
## MORTINF   0.66  0.71 0.94 0.062 2.0
## FERTILID -0.87 -0.39 0.91 0.087 1.4
## TASA_NAT -0.90 -0.39 0.96 0.036 1.4
## LOG_PIB   0.64  0.58 0.74 0.256 2.0
## URBANA    0.44  0.69 0.66 0.336 1.7
## TASA_MOR -0.04  0.93 0.87 0.130 1.0
## 
##                        RC1  RC2
## SS loadings           4.50 3.36
## Proportion Var        0.50 0.37
## Cumulative Var        0.50 0.87
## Proportion Explained  0.57 0.43
## Cumulative Proportion 0.57 1.00
## 
## Mean item complexity =  1.6
## Test of the hypothesis that 2 components are sufficient.
## 
## The root mean square of the residuals (RMSR) is  0.05 
## 
## Fit based upon off diagonal values = 1
correlaciones_modelo<-variables_pca$coord
rotacion<-varimax(correlaciones_modelo[,1:numero_de_factores])
correlaciones_modelo_rotada<-rotacion$loadings

corrplot(correlaciones_modelo_rotada[,1:numero_de_factores],
         is.corr = FALSE,
         method = "square",
         addCoef.col="grey",
         number.cex = 0.75)

En el factor 1 quedan representadas las variables ALFABET, INC_POB, FERTILID, TASA_NAT, LOG_PIB.

En el factor 2 quedan representadas las variables ESPVIDAF, URBANA, MORTINF, TASA_MOR.

Ejercicio 1.3.

Determine qué pesos deben asignarse a cada factor y a las variables dentro de cada uno de ellos.

cargas<-rotacion$loadings[1:9,1:numero_de_factores]
ponderadores<-prop.table(apply(cargas^2,MARGIN = 2,sum))
t(ponderadores) %>% kable(caption="Ponderadores de los Factores Extraídos",
        align = "c",
        digits = 2) %>% 
  kable_material(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("striped", "hover"))
Ponderadores de los Factores Extraídos
Dim.1 Dim.2
0.57 0.43 
contribuciones<-apply(cargas^2,MARGIN = 2,prop.table)
contribuciones %>% kable(caption="Contribución de las variables en los Factores",
        align = "c",
        digits = 2) %>% 
  kable_material(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("striped", "hover"))
Contribución de las variables en los Factores
Dim.1 Dim.2
ALFABET 0.12 0.09
INC_POB 0.21 0.00
ESPVIDAF 0.09 0.17
MORTINF 0.10 0.15
FERTILID 0.17 0.05
TASA_NAT 0.18 0.05
LOG_PIB 0.09 0.10
URBANA 0.04 0.14
TASA_MOR 0.00 0.26

El factor 1 tiene una participacion del 57% en el calculo del indicador sintetico y el factor 2 tiene una participacion del 43% en el calculo del indicador sintetico.

Para calcular el factor 1, X1 = ALFABET tiene una peso del 12% para construir el factor, X2 = INC_POB tiene una peso del 21% para construir el factor, X3 = ESPVIDAF tiene una peso del 9% para construir el factor, X4 = MORTINF tiene una peso del 10% para construir el factor, X5 = FERTILID tiene una peso del 17% para construir el factor, X6 = TASA_NAT tiene una peso del 18% para construir el factor, X7 = LOG_PIB tiene una peso del 9% para construir el factor, X8 = URBANA tiene una peso del 4% para construir el factor, X9 = TASA_MOR tiene una peso del 0% para construir el factor.

Para calcular el factor 1, X1 = ALFABET tiene una peso del 9% para construir el factor, X2 = INC_POB tiene una peso del 0% para construir el factor, X3 = ESPVIDAF tiene una peso del 17% para construir el factor, X4 = MORTINF tiene una peso del 15% para construir el factor, X5 = FERTILID tiene una peso del 5% para construir el factor, X6 = TASA_NAT tiene una peso del 5% para construir el factor, X7 = LOG_PIB tiene una peso del 10% para construir el factor, X8 = URBANA tiene una peso del 14% para construir el factor, X9 = TASA_MOR tiene una peso del 26% para construir el factor.