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)[-].

*Entre Corchetes aparece la correlación teórica esperada entre la variable compleja y el indicador. Todas las variables se encuentran el archivo data_desarrollo.Rdata

Importación de Datos

library(readr)
library(dplyr)
library(kableExtra)
load("C:/Users/User/Desktop/Análisis Factorial e Indicadores Sintéticos/data_desarrollo.RData")
data_desarrollo %>% 
  select(ALFABET, INC_POB, ESPVIDAF, MORTINF, FERTILID, TASA_NAT, LOG_PIB, URBANA, TASA_MOR) -> data_desarrollo

data_desarrollo <- data_desarrollo[complete.cases(data_desarrollo), ]
head(data_desarrollo)

## # A tibble: 6 × 9
##   ALFABET INC_POB ESPVIDAF MORTINF FERTILID TASA_NAT LOG_PIB URBANA TASA_MOR
##     <dbl>   <dbl>    <dbl>   <dbl>    <dbl>    <dbl>   <dbl>  <dbl>    <dbl>
## 1      98    1.4        75    35       2.8        23    3.48     54        7
## 2      29    2.8        44   168       6.9        53    2.31     18       22
## 3      99    0.36       79     6.5     1.47       11    4.24     85       11
## 4      62    3.2        70    52       6.67       38    3.82     77        6
## 5      95    1.3        75    25.6     2.8        20    3.53     86        9
## 6      98    1.4        75    27       3.19       23    3.70     68        6

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

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


## Seleccionando variables con correlación positiva con desarrollo de economias 

data_desarrollo %>% 
  dplyr::select(ALFABET,INC_POB,ESPVIDAF,FERTILID,TASA_NAT,LOG_PIB,URBANA) %>% 
  apply(MARGIN = 2,FUN = norm_directa) %>% as.data.frame()->var_corr_positiva

## Seleccionando variables con correlación negativa con desarrollo de economias

data_desarrollo %>% 
  dplyr::select(MORTINF,TASA_MOR) %>% 
  apply(MARGIN = 2,FUN = norm_inversa) %>% as.data.frame()->var_corr_negativa 

## Juntando y reordenando las variables

var_corr_positiva %>% 
  bind_cols(var_corr_negativa) %>% 
  dplyr::select(ALFABET,INC_POB,ESPVIDAF,FERTILID,TASA_NAT,LOG_PIB,URBANA,MORTINF,TASA_MOR)->data_desarrollo_normalizados
head(data_desarrollo_normalizados)

##     ALFABET   INC_POB   ESPVIDAF   FERTILID   TASA_NAT    LOG_PIB    URBANA
## 1 0.9756098 0.3068592 0.82051282 0.21770682 0.30232558 0.60885423 0.5157895
## 2 0.1341463 0.5595668 0.02564103 0.81277213 1.00000000 0.09867408 0.1368421
## 3 0.9878049 0.1191336 0.92307692 0.02467344 0.02325581 0.94458420 0.8421053
## 4 0.5365854 0.6317690 0.69230769 0.77939042 0.65116279 0.76022519 0.7578947
## 5 0.9390244 0.2888087 0.82051282 0.21770682 0.23255814 0.63309802 0.8526316
## 6 0.9756098 0.3068592 0.82051282 0.27431060 0.30232558 0.70597624 0.6631579
##     MORTINF   TASA_MOR
## 1 0.8109756 0.77272727
## 2 0.0000000 0.09090909
## 3 0.9847561 0.59090909
## 4 0.7073171 0.81818182
## 5 0.8682927 0.68181818
## 6 0.8597561 0.81818182

Matriz de Correlación & Pruebas de Barlett y KMO

#Matriz de correlación
library(PerformanceAnalytics)
chart.Correlation(as.matrix(data_desarrollo_normalizados),histogram = TRUE,pch=12)

presenta la matriz de correlación mostrando en la diagonal principal un histograma con los kernels de densidad de probabilidad para cada una de las variables y por debajo se presenta un diagrama de dispersión donde se muestra una aproximación de la relación no lineal que pueda aparecer entre cada una de las variables.

Si no hay asteriscos , la variable no es estadísticamente significativa, mientras que una, dos y tres estrellas significan que la correspondiente variable es estadísticamente significativa para los niveles 10%, 5% y 1%, respectivamente. Para este ejercicio, las correlacciones son mayormente significativas al 1% por lo que existe una evidente correlación entre las variables propuestas en la batería de indicadores

Verificación de supuestos: Prueba de Barlett y KMO

#KMO
library(rela)
KMO<-paf(as.matrix(data_desarrollo_normalizados))$KMO
print(KMO)

## [1] 0.86467

Nuestro KMO es de 0.86 y el valor minimo para considerar aceptable el analisis factorial es de 0.5, por lo que nuestros datos son adecuados.

#Prueba de Barlett
library(psych)
options(scipen = 99999)
Barlett<-cortest.bartlett(data_desarrollo_normalizados)
print(Barlett)

## $chisq
## [1] 1544.4
## 
## $p.value
## [1] 0.00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000015692
## 
## $df
## [1] 36

Con los resultados de la prueba Barlett, podemos determinar que la H0 se rechaza, esto porque el p.value<0.05. Entonces decimos que existe correlacion entre la bateria de indicadores. Podemos realizar un analisis factorial.

Análisis Factorial

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

Rx<-cor(data_desarrollo_normalizados)
PC<-princomp(x = data_desarrollo_normalizados,cor = TRUE,fix_sign = FALSE)
variables_pca<-get_pca_var(PC)
factoextra::get_eig(PC) %>% kable(caption="Resumen de PCA",
        align = "c",
        digits = 2) %>% 
  kable_material(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("hover"))

Resumen de PCA
	eigenvalue	variance.percent	cumulative.variance.percent
Dim.1	6.69	74.34	74.34
Dim.2	1.24	13.83	88.18
Dim.3	0.53	5.91	94.08
Dim.4	0.20	2.20	96.28
Dim.5	0.17	1.93	98.21
Dim.6	0.07	0.73	98.94
Dim.7	0.06	0.62	99.56
Dim.8	0.03	0.28	99.84
Dim.9	0.01	0.16	100.00

Gráfico de sedimentación

fviz_eig(PC,
         choice = "eigenvalue",
         barcolor = "red",
         barfill = "blue",
         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 de los 3 cuartos: Según este criterio, en donde se deben de retener las dimesiones en donde se explique al menos el 75% de la varianza de los datos originales, se deben de retener las primeras 2 dimensiones, debido a que con estas dos se logran retener el 88.18% de la varianza de los datos originales.

-Criterio de raíz latente: Según este criterio, en donde se deben de rentener las dimensiones cuyo autovalor sea superior o por lo menos a 1, se deben de retener las primeras 2 dimensiones, debido a que estas tienen un autovalor de 6.7 y de 1.2 respectivamente.

-Criterio de Elbow: Según este criterio, en donde se deben de retener las dimensiones que es encuentren hasta donde se encuentra el “codo”, se deben de retener las primeras 2 dimensiones.

Debido a que todos los criterios concuerdan entre si, se concluye que nada más se retendran las primeras 2 dimensiones.

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")
print(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.76  0.53 0.86 0.141 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
## FERTILID -0.87 -0.40 0.92 0.079 1.4
## TASA_NAT -0.90 -0.40 0.97 0.034 1.4
## LOG_PIB   0.65  0.58 0.75 0.246 2.0
## URBANA    0.42  0.73 0.71 0.294 1.6
## MORTINF   0.66  0.71 0.94 0.059 2.0
## TASA_MOR -0.02  0.93 0.87 0.135 1.0
## 
##                        RC1  RC2
## SS loadings           4.52 3.41
## Proportion Var        0.50 0.38
## Cumulative Var        0.50 0.88
## 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

Teniendo en cuenta la columna de h2, se observa que 8 de las 9 indicadores son explicados por la extracción realizada en donde se retubieron solamente 2 dimensiones (usando el criterio de los tres cuartos). El indicador que no pasó este criterio es “URBANA” con 70.6%.

#Gráfico de aglomeración de las variables en los factores
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="green",
         number.cex = 0.75)

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

En el factor 2 quedan representadas ESPVIDAF, URBANA, MORTINF Y TASA_MOR

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

# Cargas de cada dimensión
library(kableExtra)
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
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.13	0.08
INC_POB	0.21	0.00
ESPVIDAF	0.09	0.17
FERTILID	0.17	0.05
TASA_NAT	0.18	0.05
LOG_PIB	0.09	0.10
URBANA	0.04	0.16
MORTINF	0.10	0.15
TASA_MOR	0.00	0.25

Al factor 1 debe asignarse el peso 0.57 y al factor 2 el peso 0.43.

Para ALFABET será al factor 1: 0.13 y al factor 2: 0.08

Para INC_POB serán al F1: 0.21 y F2: 0

Para ESPVIDAF serán al F1: 0.09 y F2: 0.17

Para FERTILID serán al F1: 0.17 y F2: 0.05

Para TASA_NAT serán al F1: 0.18 y F2 0.05

Para LOG_PIB serán al F1: 0.09 y F2: 0.10

Para URBANA serán al F1: 0.04 y F2: 0.16

Para MORTINF serán al F1: 0.10 y F2: 0.15

Para TASA_MOR serán al F1: 0 y F2: 0.25