Tarea_8_AFIS_AT21006
Walter Orlando Alemán Turcios
2023-11-23
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)[-]
library(readr)
library(dplyr)
library(tidyr)
load("C:/Users/Walter Alemán/Desktop/UES VI/MAE/TAREA A.F/data_desarrollo.RData")
dat_des_depu<-data_desarrollo %>%
select(ALFABET,
INC_POB,
ESPVIDAF,
MORTINF,
FERTILID,
TASA_NAT,
LOG_PIB,
URBANA,
TASA_MOR)
medias<-apply(X = dat_des_depu, MARGIN = 2,mean, na.rm=TRUE)
dat_des_depu<-replace_na(data = dat_des_depu, replace = list(ALFABET=medias[1],
INC_POB=medias[2],
ESPVIDAF=medias[3],
MORTINF=medias[4],
FERTILID=medias[5],
TASA_NAT=medias[6],
LOG_PIB=medias[7],
URBANA=medias[8],
TASA_MOR=medias[9]))
print(dat_des_depu)## # A tibble: 109 × 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
## 7 100 1.38 80 7.3 1.9 15 4.23 85 8
## 8 99 0.2 79 6.7 1.5 12 4.26 58 11
## 9 77 2.4 74 25 3.96 29 3.90 83 4
## 10 35 2.4 53 106 4.7 35 2.31 16 11
## # ℹ 99 more rowsEjercicio 1.1
Usando Análisis Factorial determine cuantos factores deberían retenerse.
Normalizacion de datos
library(dplyr)
INDicadores<-dat_des_depu[complete.cases(dat_des_depu),]
norm_directa<-function(x){(x-min(x))/(max(x)-min(x))}
norm_inversa<-function(x){(max(x)-x)/(max(x)-min(x))}
# Variables con correlacion positiva
INDicadores %>%
select(ALFABET,
INC_POB,
ESPVIDAF,
FERTILID,
TASA_NAT,
LOG_PIB,
URBANA) %>%
apply(MARGIN = 2, FUN = norm_directa) %>% as.data.frame()-> variable_corr_ps
# Variables con correlacion negativa
INDicadores %>%
select(MORTINF,
TASA_MOR) %>%
apply(MARGIN = 2, FUN = norm_inversa) %>% as.data.frame()-> variable_corr_ng
# Juntando y reordenando las variables
variable_corr_ps %>%
bind_cols(variable_corr_ng) %>%
select(ALFABET,
INC_POB,
ESPVIDAF,
MORTINF,
FERTILID,
TASA_NAT,
LOG_PIB,
URBANA,
TASA_MOR)-> Dat_Fin_Nor
head(Dat_Fin_Nor)Matriz de Correlacion y Pruebas de barlett y KMO
Matriz de Correlacion
Prueba de Kaiser Meyer Olkin (KMO)
## [1] 0.862En la prueba KMO para que nuestra data sea adecuada debe de ser KMO>0.5, pero para ser aceptable debe de ser entre 0.6 a 0.7, para que sea perfecto debe de ser entre 0.8 a 0.9, en este caso vemos que da 0,86 eso significa que es un dato perfecto para poder realizar el analisis sintetico
Prueba de barlett
## R was not square, finding R from data## $chisq
## [1] 1545.1
##
## $p.value
## [1] 0.00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000011126
##
## $df
## [1] 36Como notamos que el p<0.5 (nivel de significancia), podemos concluir que se rechaza la hipotesis nula. estamos en presencia de una matriz de correlacion que no representa variable independientes
Analisis factorial
Decision de dimensiones
library(kableExtra)
library(factoextra)
library(FactoMineR)
Rx<-cor(Dat_Fin_Nor)
PC<-princomp(x = Dat_Fin_Nor, cor = TRUE, fix_sign = FALSE)
Vari_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"))| 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 |
Por criterio de raiz latente: Solo la dimension 1 y 2 serian las que se retendrian ya que por este criterio solo aquellos autovalores superiores a 1 son las que se retienen
Por porcentaje de varianza explicada: Solo la dimension 1 y 2 serian las que se retendrian, Porque como vemos en la columna de autovalores acumulativo solo hasta la dimension 2 es que sobre pasa los 3/4 (75%) que este criterio pide.
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)
Grafica de sedimentacion (codo): Como podemos ver en la grafica donde se ve el cambio brusco en la tendencia se situa en la dimension 1 y 2, asi que solo estas serian las que se retendrian por este criterio
Ejercicio 1.2
¿Qué variables quedan representadas en cada factor?
Modelos de 2 factores
library(corrplot)
numero_de_factores<-2
MOD_factores<-principal(r = Rx,
nfactors = numero_de_factores,
covar = FALSE,
rotate = "varimax")
MOD_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 = 1Al realiza el modelo por los 2 factores podemos notar que solo 1 de 9, no estan muy bien representada que seria la variable LOG_PIB=74%
¿porque no estan bien representadas?, porque utilizamos el criterio del porcentaje de varianza explicada, eso significa que el componente debe de explicar al menos una 3/4 (75%) parte.
CORR_Modelo<-Vari_PCA$coord
rotacion<-varimax(CORR_Modelo[,1:numero_de_factores])
CORR_MOD_rotadas<-rotacion$loading
corrplot(CORR_MOD_rotadas[,1:numero_de_factores],
is.corr = FALSE,
method = "square",
addCoef.col="grey",
number.cex = 0.75)
Como podemos ver en la grafica notamos que:
En la variable latente 1 se encuentran mejor representadas: ALFABET, INC_POB, FETTILID, TASA_NAT, LOG_PIB
En la variable latente 2 se encuentran mejor representadas: ESPVIDAF, MORTINF, URBANA, TASA_MOR
Modelo de 3 factores
library(corrplot)
numero_de_facs<-3
MODE_factores<-principal(r = Rx,
nfactors = numero_de_facs,
covar = FALSE,
rotate = "varimax")
MODE_factores## Principal Components Analysis
## Call: principal(r = Rx, nfactors = numero_de_facs, rotate = "varimax",
## covar = FALSE)
## Standardized loadings (pattern matrix) based upon correlation matrix
## RC1 RC3 RC2 h2 u2 com
## ALFABET 0.74 0.40 0.41 0.87 0.132 2.2
## INC_POB -0.95 -0.19 0.15 0.96 0.037 1.1
## ESPVIDAF 0.59 0.53 0.58 0.97 0.032 3.0
## MORTINF 0.63 0.51 0.53 0.94 0.059 2.9
## FERTILID -0.87 -0.33 -0.28 0.94 0.062 1.5
## TASA_NAT -0.87 -0.39 -0.24 0.97 0.029 1.6
## LOG_PIB 0.47 0.78 0.21 0.88 0.123 1.8
## URBANA 0.24 0.88 0.27 0.90 0.098 1.3
## TASA_MOR 0.04 0.23 0.96 0.97 0.027 1.1
##
## RC1 RC3 RC2
## SS loadings 3.99 2.43 1.99
## Proportion Var 0.44 0.27 0.22
## Cumulative Var 0.44 0.71 0.93
## Proportion Explained 0.47 0.29 0.24
## Cumulative Proportion 0.47 0.76 1.00
##
## Mean item complexity = 1.8
## Test of the hypothesis that 3 components are sufficient.
##
## The root mean square of the residuals (RMSR) is 0.03
##
## Fit based upon off diagonal values = 1Al realizarlo por 3 factores no tamos que la variable LOG_PIB mejora y tiene una representacion de 87%, eso quiere decir que todas estan mejor representadas que el modelo de 2 factores
CORRE_Modelo<-Vari_PCA$coord
Rota<-varimax(CORRE_Modelo[,1:numero_de_facs])
CORRE_MOD_rotadas<-Rota$loading
corrplot(CORRE_MOD_rotadas[,1:numero_de_facs],
is.corr = FALSE,
method = "square",
addCoef.col="grey",
number.cex = 0.75)
En la variable latente 1 se encuentran: ALFABET, INC_POB, ESPVIDAF, MORTINF, FETTILID, TASA_NAT,
En la variable latente 2 se encuentran: TASA_MOR
En la variable latente 3 se encuentran: LOG_PIB, URBANA
Aun sigue siendo la variable latente 1 la que seguiria sosteniendo la mayoria de las representaciones, entonces no vale la pena retener solo 2 variable por añadir una dimension mas ya que se volveria mas compleja y no valdria la pena.
Ejercicio 1.3
Determine qué pesos deben asignarse a cada factor y a las variables dentro de cada uno de ellos
Ponderadores
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"))| Dim.1 | Dim.2 |
|---|---|
| 0.57 | 0.43 |
Los ponderadores para las dos dimensiones son: DIM1=0.57 y DIM2=0.43
lo podemos asegurar ya que la tabla donde esta el nivel de varianza comun de todas los componentes en el aparado de Proportion Explained podemos notar que son los mismo
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"))| 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 |