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

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

load("~/MAE2023/data_desarrollo.RData")
library(dplyr)
library(tidyr)
norm_directa<-function(x){(x-min(x))/(max(x)-min(x))}
norm_inversa<-function(x){(max(x)-x)/(max(x)-min(x))}

#Eliminación de valores nulos
data_desarrollo %>% 
    replace_na(list(ALFABET=0,INC_POB=0,ESPVIDAF=0,FERTILID=0,TASA_NAT=0,LOG_PIB=0,URBANA=0,MORTINF=0,TASA_MOR=0))-> data_desarrollo 

#Selección de variables con correlación positiva
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

#Selección de variables con correlación negativa
data_desarrollo %>% 
  dplyr::select(MORTINF,TASA_MOR) %>% 
  apply(MARGIN = 2,FUN = norm_inversa) %>% as.data.frame()->var_corr_negativa 

#Union y reordenamiento de 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_normalizada
head(data_desarrollo_normalizada)
##   ALFABET   INC_POB   ESPVIDAF  FERTILID   TASA_NAT    LOG_PIB URBANA   MORTINF
## 1    0.98 0.3068592 0.82051282 0.3418803 0.30232558 0.60885423   0.54 0.8109756
## 2    0.29 0.5595668 0.02564103 0.8424908 1.00000000 0.09867408   0.18 0.0000000
## 3    0.99 0.1191336 0.92307692 0.1794872 0.02325581 0.94458420   0.85 0.9847561
## 4    0.62 0.6317690 0.69230769 0.8144078 0.65116279 0.76022519   0.77 0.7073171
## 5    0.95 0.2888087 0.82051282 0.3418803 0.23255814 0.63309802   0.86 0.8682927
## 6    0.98 0.3068592 0.82051282 0.3894994 0.30232558 0.70597624   0.68 0.8597561
##     TASA_MOR
## 1 0.70833333
## 2 0.08333333
## 3 0.54166667
## 4 0.75000000
## 5 0.62500000
## 6 0.75000000

Matriz De Correlacion

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

Pruebas De KMO y Barlett

#Pruba de KMO
library(rela)
KMO<-paf(as.matrix(data_desarrollo_normalizada))$KMO
print(KMO)
## [1] 0.85275

Se dice que el valor mínimo de KMO para considerar aceptable el análisis factorial es de 0.5 y la batería de información tiene el 0.85275, por lo tal es apropiado continuar con el análisis.

#Prueba de Barlett
library(psych)
options(scipen = 99999)
Barlett<-cortest.bartlett(data_desarrollo_normalizada)
print(Barlett)
## $chisq
## [1] 1478.1
## 
## $p.value
## [1] 0.000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000017846
## 
## $df
## [1] 36

En esta ocasion el P-value es casi 0, con lo que podemos decir que no se rechaza la hipótesis alternativa, hay evidencia de correlación poblacional entre la batería de indicadores propuestas.

Analisis Factorial

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

Rx<-cor(data_desarrollo_normalizada)
PC<-princomp(x = data_desarrollo_normalizada,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_dark(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("hover"))
Resumen De PCA
eigenvalue variance.percent cumulative.variance.percent
Dim.1 6.45 71.63 71.63
Dim.2 1.24 13.81 85.44
Dim.3 0.56 6.18 91.62
Dim.4 0.39 4.36 95.98
Dim.5 0.18 2.01 97.99
Dim.6 0.08 0.86 98.85
Dim.7 0.06 0.64 99.49
Dim.8 0.03 0.32 99.81
Dim.9 0.02 0.19 100.00

Mediante este analisis podemos ver la cantidad de factores a retener.

Por el criterio de raíz latente: tendríamos que retener 2 componentes.

Por el criterio de porcentaje acumulado de la varianza: tedríamos DOS componentes ya que esas 2 son superior a las 3 cuartas partes de la varianza total.

Grafico De Sedimentacion

fviz_eig(PC,
         choice = "eigenvalue",
         barcolor = "purple",
         barfill = "sky blue",
         addlabels = TRUE, 
       )+labs(title = "Gráfico de Sedimentación",subtitle = "Utilisando princomp, con autovalores")+
  xlab(label = "Componentes")+
  ylab(label = "Autovalores")+geom_hline(yintercept = 1)

En esta ocasion el punto de quiebre ocurre en los primeros dos valores,con esto podemos decir que los criterios de extracciion se mantiene en 2 factores. Por lo tanto se debe de retener DOS factores.

1.2) ¿Qué variables quedan representadas en cada factor?

library(corrplot)
## corrplot 0.92 loaded
#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.70  0.51 0.74 0.260 1.8
## INC_POB  -0.98  0.04 0.96 0.041 1.0
## ESPVIDAF  0.62  0.76 0.95 0.048 1.9
## FERTILID -0.87 -0.40 0.91 0.091 1.4
## TASA_NAT -0.90 -0.40 0.96 0.036 1.4
## LOG_PIB   0.62  0.59 0.73 0.270 2.0
## URBANA    0.39  0.71 0.66 0.342 1.6
## MORTINF   0.65  0.71 0.92 0.075 2.0
## TASA_MOR -0.03  0.92 0.85 0.148 1.0
## 
##                        RC1  RC2
## SS loadings           4.35 3.34
## Proportion Var        0.48 0.37
## Cumulative Var        0.48 0.85
## 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 = 0.99

Grafico De Aglomeracion De Variables

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 = "black",
  number.cex = 0.75
)

En el factor 1 quedan representados de la siguente manera: ALFABET, INC_POB, FERTILID, TASA_NAT Y LOG_PIB.

En el factor 2 quedan representados de la siguiente manera: 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

#Ponderadores extraidos
library(kableExtra)
cargas <- rotacion$loadings[1:6, 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_dark(html_font = "sans-serif") %>%
  kable_styling(bootstrap_options = c("hover"))
Ponderadores de los Factores Extraídos
Dim.1 Dim.2
0.72 0.28

Contribucion De Las Variables En Los Factores

library(dplyr)
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_dark(html_font = "sans-serif") %>%
  kable_styling(bootstrap_options = c("hover"))
Contribución de las variables en los Factores
Dim.1 Dim.2
ALFABET 0.13 0.17
INC_POB 0.25 0.00
ESPVIDAF 0.10 0.38
FERTILID 0.20 0.11
TASA_NAT 0.21 0.11
LOG_PIB 0.10 0.23

Al factor 1 debe asignarse el peso 0.72 y al factor 2 el peso 0.28.

-Para ALFABET será al factor F1: 0.13 y al factor F2: 0.17

-Para INC_POB serán al F1: 0.25 y F2: 0

-Para ESPVIDAF serán al F1: 0.1 y F2: 0.38

-Para FERTILID serán al F1: 0.2 y F2: 0.11

-Para TASA_NAT serán al F1: 0.2 y F2 0.11

-Para LOG_PIB serán al F1: 0.1 y F2: 0.23