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

Carga de la data

library(dplyr)
load("C:/Users/Molin/Downloads/data_desarrollo.RData")

data_desarrollo %>% 
  select(PAÍS, 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)

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))}

#Selección de los datos con correlación positiva
data_desarrollo %>% 
  select(ALFABET,INC_POB,ESPVIDAF,FERTILID,TASA_NAT,LOG_PIB,URBANA) %>% 
  apply(MARGIN = 2, FUN = norm_directa) %>% 
  as.data.frame() -> var.cor.positiva

#Selección de los datos con correlación negativa
data_desarrollo %>% 
  select(MORTINF,TASA_MOR) %>% 
  apply(MARGIN = 2, FUN = norm_inversa) %>% 
  as.data.frame() -> var.cor.negativa

#Unión de ambos df
var.cor.positiva %>% 
  bind_cols(var.cor.negativa) %>% 
  select(ALFABET,INC_POB,ESPVIDAF,FERTILID,TASA_NAT,LOG_PIB,URBANA,MORTINF,TASA_MOR) -> data.desarrollo.norm
head(data.desarrollo.norm)

Matriz de correlación y pruebas de Barlett y KMO

library(PerformanceAnalytics)
chart.Correlation(as.matrix(data.desarrollo.norm),histogram = TRUE,pch=12)

En la matriz de correlación se observa que en la parte triangular superior casi todas las correlación son significativas, casi todas de las correlaciones son significativas al 100% y solamente una de las correlaciones no son significativas.

(Teniendo en cuenta que: *** = 100%, ** = 95%, * = 10%)

#Prueba KMO
library(rela)
KMO <- paf(as.matrix(data.desarrollo.norm))$KMO
print(KMO)

## [1] 0.86467

Teniendo en cuenta que el criterio de evaluación es KMO > 0.5:

Se concluye que en esta ocasión es adecuado el uso del Análisis factorial debido a que el KMO es de 0.86

#Prueba Barlett
library(psych)
options(scipen = 99999)
Barlett <- cortest.bartlett(data.desarrollo.norm)
print(Barlett)

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

Teniendo en cuenta que el criterio de evaluación es rechazar la hipotesis nula si el Pvalue <= 0.05:

Se concluye que se rechaza la hipotesis nula, lo que indica que hay evidencia de multicolinealidad, lo que es necesario para el Análisis factorial.

1.1. Análisis factorial

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

Rx<-cor(data.desarrollo.norm)
PC<-princomp(x = data.desarrollo.norm,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

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 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. Variables dentro de cada factor

library(corrplot)
#Modelo de 2 Factores (Rotada)
factores<-2
modelo.factores<-principal(r = Rx,
                             nfactors = factores,
                             covar = FALSE,
                             rotate = "varimax")
modelo.factores

## Principal Components Analysis
## Call: principal(r = Rx, nfactors = 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%.

correlaciones.modelo<-variables.pca$coord
rotacion<-varimax(correlaciones.modelo[,1:factores])
correlaciones.modelo.rotada<-rotacion$loadings

corrplot(correlaciones.modelo.rotada[,1:factores],
         is.corr = FALSE,
         method = "square",
         addCoef.col="grey",
         number.cex = 0.75)

En la primera dimensión quedan representadas 5 de 9 variables (las cuales son: ALFABET, INC_POB, FERTILID, TASA_NAT, LOG_PIB); mientras que en la segunda dimensión quedan representadas 4 de 9 variables (las cuales son: ESPVIDAF, URBANA, MORTINF, TASA_MOR).

1.3. Pesos de cada factor y cada variable

library(kableExtra)
cargas<-rotacion$loadings[1:9,1: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.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

Tarea 8: Análisis factorial e indicadores sintéticos

DM19001 - CARLOS DAVID DELEON MOLINA

2023-11-23