Sección I. 25%

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 varibles se encuentran el archivo data_parcial_2_B.Rdata

Todas los indicadores se encuentran el archivo data_parcial_2_B.Rdata

load("C:/Users/lupita nieto/Downloads/data_parcial_2_B_rev.RData")
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))}

## Eliminando valores nulos

data_parcial_2%>%
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))->indicador_2

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

indicador_2%>% 
  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

indicador_2%>% 
  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_p2_normalizados
head(data_p2_normalizados)
##   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 Rx

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

Pruebas KMO y Barlett

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

Como el KMO > 0.5 y el pvalue < 0.05, se puede procederse al análisis factorial porque existe multicolinealidad en los valores de la matriz de información

Analisis Factorial

library(FactoMineR)
library(factoextra)
library(kableExtra)
Rx<-cor(data_p2_normalizados)
PC<-princomp(x = data_p2_normalizados,cor = TRUE,fix_sign = FALSE)
variables_pca<-get_pca_var(PC)
factoextra::get_eig(PC) %>% kable(caption="Resumen PCA",
        align = "c",
        digits = 2) %>% 
  kable_material(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("striped", "hover"))
Resumen 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

Gráfico de sedimentación

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

R/ Basado en el criterio de raíz latente (que se verifica en el grafico de sedimentación), en el criterio del autovalor mayor que 1, en el criterio que están por encima del turning point y en que ambos explican más del 70% de la varianza acumulada, se extraen los primeros 2 componentes.

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

library(corrplot)
#Modelo de 2 Factores (Rotada)
numero_de_factores<-2
modelo_2_factores<-principal(r = Rx,
                             nfactors = numero_de_factores,
                             covar = FALSE,
                             rotate = "varimax")
print(modelo_2_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

Al hacerlo con 2 factores, en la primer variable, el 0.74% de su varianza es explicada por la solución. La segunda variable, el 0.96% de su varianza es explicada por la extracción. Entonces es una solución representativa de los datos originales.

En los ponderadores que se han extraído, la primera variable que se construya va a tener un ponderador de 0.57, la segunda de 0.43.

#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="pink",
         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 que 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: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(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("striped", "hover"))
Ponderadores de los Factores Extraídos
Dim.1 Dim.2
0.72 0.28 
# 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.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

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

Para ALFABET será al facor 1: 0.13 y al factor 2: 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

SECCION II.

EJERCICIO 1

Calcule los pesos normalizados, de las variables, usando los métodos de ranking directo, por suma, por reciproco y por ranking exponencial (use p=4)

* 1. Por suma

library(magrittr)

#Vector de Jerarquías
rj<-c(3,4,2,1)
names(rj)<-c("X1","X2","X3","X4")

#Función para generar los pesos
ponderadores_subjetivos_rank_suma<-function(vector_jerarquias){
  n<-length(vector_jerarquias)
  vector_pesos<-n-vector_jerarquias+1
  list(w_brutos=vector_pesos,w_normalizados=vector_pesos/sum(vector_pesos))
}

#Aplicando la función:
pesos_ranking_suma<-ponderadores_subjetivos_rank_suma(rj)

#Pesos brutos
pesos_ranking_suma$w_brutos
## X1 X2 X3 X4 
##  2  1  3  4
#Pesos normalizados
pesos_ranking_suma$w_normalizados %>% round(digits = 3)
##  X1  X2  X3  X4 
## 0.2 0.1 0.3 0.4
### GRAFICO
#Gráfico de los pesos normalizados
barplot(pesos_ranking_suma$w_normalizados,
        main = "Ponderadores Ranking de Suma",
        ylim = c(0,0.5),col = "orange")

* 2. Por reciproco

#Vector de Jerarquías
rj<-c(3,4,2,1)
names(rj)<-c("X1","X2","X3","X4")

#Función para generar los pesos
ponderadores_subjetivos_rank_reciproco<-function(vector_jerarquias){
  vector_pesos<-1/vector_jerarquias
  list(w_brutos=vector_pesos,w_normalizados=vector_pesos/sum(vector_pesos))
}
#Aplicando la función:
pesos_ranking_reciproco<-ponderadores_subjetivos_rank_reciproco(rj)

#Pesos brutos
pesos_ranking_reciproco$w_brutos
##      X1      X2      X3      X4 
## 0.33333 0.25000 0.50000 1.00000
#Pesos normalizados
pesos_ranking_reciproco$w_normalizados %>% round(digits = 3)
##   X1   X2   X3   X4 
## 0.16 0.12 0.24 0.48
### Grafico

#Gráfico de los pesos normalizados
barplot(pesos_ranking_reciproco$w_normalizados,
        main = "Ponderadores Ranking Recíproco",
        ylim = c(0,0.5),density=c(5,10,20,7) , angle=c(0,45,90,11), col = "yellow")

* 3. Por exponencial

#Vector de Jerarquías
rj<-c(3,4,2,1)
names(rj)<-c("X1","X2","X3","X4")

#Función para generar los pesos
ponderadores_subjetivos_rank_exponencial<-function(vector_jerarquias,p=4){
  n<-length(vector_jerarquias)
  vector_pesos<-(n-vector_jerarquias+1)^p
  list(w_brutos=vector_pesos,w_normalizados=vector_pesos/sum(vector_pesos))
}
#Aplicando la función:
pesos_ranking_exponencial<-ponderadores_subjetivos_rank_exponencial(rj)

#Pesos brutos
pesos_ranking_exponencial$w_brutos
##  X1  X2  X3  X4 
##  16   1  81 256
#Pesos normalizados
pesos_ranking_exponencial$w_normalizados %>% round(digits = 3)
##    X1    X2    X3    X4 
## 0.045 0.003 0.229 0.723
### Grafica

#Gráfico de los pesos normalizados (por default p=4)
barplot(pesos_ranking_exponencial$w_normalizados,
        main = "Ponderadores Ranking Exponencial",
        ylim = c(0,0.8), col = "pink")

Ejercicio 2 Usando la técnica de comparación por pares, calcule los pesos normalizados para las variables:

comparación por pares

library(FuzzyAHP)
# Matriz_1

valores_matriz_comparacion_1 = c(1,7,4,5,
                                 NA,1,6,3,
                                 NA,NA,1,2,
                                 NA,NA,NA,1)
matriz_comparacion_1<-matrix(valores_matriz_comparacion_1,
                           nrow = 4, ncol = 4, byrow = TRUE)
matriz_comparacion_1<-pairwiseComparisonMatrix(matriz_comparacion_1)
matriz_comparacion_1@variableNames<-c("X1","X2","X3","X4")
show(matriz_comparacion_1)
## An object of class "PairwiseComparisonMatrix"
## Slot "valuesChar":
##      [,1]  [,2]  [,3]  [,4]
## [1,] "1"   "7"   "4"   "5" 
## [2,] "1/7" "1"   "6"   "3" 
## [3,] "1/4" "1/6" "1"   "2" 
## [4,] "1/5" "1/3" "1/2" "1" 
## 
## Slot "values":
##         [,1]    [,2] [,3] [,4]
## [1,] 1.00000 7.00000  4.0    5
## [2,] 0.14286 1.00000  6.0    3
## [3,] 0.25000 0.16667  1.0    2
## [4,] 0.20000 0.33333  0.5    1
## 
## Slot "variableNames":
## [1] "X1" "X2" "X3" "X4"
# Cálculo de los pesos:

pesos_normalizados_1 = calculateWeights(matriz_comparacion_1)
show(pesos_normalizados_1)
## An object of class "Weights"
## Slot "weights":
##     w_X1     w_X2     w_X3     w_X4 
## 0.606592 0.223310 0.094748 0.075350
barplot(pesos_normalizados_1@weights,
        main = "Ponderadores por método comparación de pares",
        ylim = c(0,0.7),col = "purple")

# Matriz_2

valores_matriz_comparacion_2 = c(1,7,6,3,
                                 NA,1,5,2,
                                 NA,NA,1,4,
                                 NA,NA,NA,1)
matriz_comparacion_2<-matrix(valores_matriz_comparacion_2,
                           nrow = 4, ncol = 4, byrow = TRUE)
matriz_comparacion_2<-pairwiseComparisonMatrix(matriz_comparacion_2)
matriz_comparacion_2@variableNames<-c("X1","X2","X3","X4")
show(matriz_comparacion_2)
## An object of class "PairwiseComparisonMatrix"
## Slot "valuesChar":
##      [,1]  [,2]  [,3]  [,4]
## [1,] "1"   "7"   "6"   "3" 
## [2,] "1/7" "1"   "5"   "2" 
## [3,] "1/6" "1/5" "1"   "4" 
## [4,] "1/3" "1/2" "1/4" "1" 
## 
## Slot "values":
##         [,1] [,2] [,3] [,4]
## [1,] 1.00000  7.0 6.00    3
## [2,] 0.14286  1.0 5.00    2
## [3,] 0.16667  0.2 1.00    4
## [4,] 0.33333  0.5 0.25    1
## 
## Slot "variableNames":
## [1] "X1" "X2" "X3" "X4"
# Cálculo de los pesos:
pesos_normalizados_2 = calculateWeights(matriz_comparacion_2)
show(pesos_normalizados_2)
## An object of class "Weights"
## Slot "weights":
##    w_X1    w_X2    w_X3    w_X4 
## 0.60919 0.19879 0.10987 0.08215
barplot(pesos_normalizados_2@weights,
        main = "Ponderadores por método comparación de pares",
        ylim = c(0,0.7),col = "brown")

# Matriz_3

valores_matriz_comparacion_3 = c(1,7,5,4,
                                 NA,1,3,2,
                                 NA,NA,1,6,
                                 NA,NA,NA,1)
matriz_comparacion_3<-matrix(valores_matriz_comparacion_3,
                           nrow = 4, ncol = 4, byrow = TRUE)
matriz_comparacion_3<-pairwiseComparisonMatrix(matriz_comparacion_3)
matriz_comparacion_3@variableNames<-c("X1","X2","X3","X4")
show(matriz_comparacion_3)
## An object of class "PairwiseComparisonMatrix"
## Slot "valuesChar":
##      [,1]  [,2]  [,3]  [,4]
## [1,] "1"   "7"   "5"   "4" 
## [2,] "1/7" "1"   "3"   "2" 
## [3,] "1/5" "1/3" "1"   "6" 
## [4,] "1/4" "1/2" "1/6" "1" 
## 
## Slot "values":
##         [,1]    [,2]    [,3] [,4]
## [1,] 1.00000 7.00000 5.00000    4
## [2,] 0.14286 1.00000 3.00000    2
## [3,] 0.20000 0.33333 1.00000    6
## [4,] 0.25000 0.50000 0.16667    1
## 
## Slot "variableNames":
## [1] "X1" "X2" "X3" "X4"
# Cálculo de los pesos:

pesos_normalizados_3 = calculateWeights(matriz_comparacion_3)
show(pesos_normalizados_3)
## An object of class "Weights"
## Slot "weights":
##    w_X1    w_X2    w_X3    w_X4 
## 0.61676 0.17252 0.14259 0.06812
barplot(pesos_normalizados_3@weights,
        main = "Ponderadores por método comparación de pares",
        ylim = c(0,0.7),col = "purple")

2.1 Asumiendo que la opinión de los 3 expertos es igualmente válida.

library(kableExtra)
ponderacion_expertos <-1/3

pesos_tot<-(pesos_normalizados_1@weights+pesos_normalizados_2@weights+
              pesos_normalizados_3@weights)

promedio_tot<-ponderacion_expertos*pesos_tot
show(promedio_tot)
##     w_X1     w_X2     w_X3     w_X4 
## 0.610848 0.198207 0.115739 0.075207
sum(promedio_tot)
## [1] 1
normalizacion_1<-promedio_tot/sum(promedio_tot)
show(normalizacion_1)
##     w_X1     w_X2     w_X3     w_X4 
## 0.610848 0.198207 0.115739 0.075207

2.2 Si el experto 1 se pondera con 0.25, el experto 2 con 0.35 y el experto 3 con 0.4

ponderacion_expertos_distintas<-(pesos_normalizados_1@weights*0.25)+(pesos_normalizados_2@weights*0.35)+(pesos_normalizados_3@weights*0.4)

show(ponderacion_expertos_distintas)
##     w_X1     w_X2     w_X3     w_X4 
## 0.611569 0.194412 0.119180 0.074838
sum(ponderacion_expertos_distintas)
## [1] 1
normalizacion_2<-ponderacion_expertos_distintas/sum(ponderacion_expertos_distintas)
show(normalizacion_2)
##     w_X1     w_X2     w_X3     w_X4 
## 0.611569 0.194412 0.119180 0.074838