CLAVE B

SECCIÓN 1

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 

#Carga de datos
library(readr)
library(dplyr)
library(kableExtra)
load("C:/Users/Wendy/Downloads/data_parcial_2_B_rev.RData")

1. Usando Análisis Factorial determine cuántos factores deberían retenerse.

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_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
  )
) -> data_parcial_2

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

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

#Union y reordenamiento de variables
vble_corrlcn_positiva %>%
  bind_cols(vble_corrlcn_negativa) %>%
  select(ALFABET,
         INC_POB,
         ESPVIDAF,
         FERTILID,
         TASA_NAT,
         LOG_PIB,
         URBANA,
         MORTINF,
         TASA_MOR) -> data_parcial2_norm
head(data_parcial2_norm)
##   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 correlación
library(PerformanceAnalytics)
chart.Correlation(as.matrix(data_parcial2_norm),
                  histogram = TRUE,
                  pch = 12)

#Prueba KMO
library(rela)
KMO <- paf(as.matrix(data_parcial2_norm))$KMO
print(KMO)
## [1] 0.85275
#Prueba Barlett
library(psych)
Barlett <- cortest.bartlett(data_parcial2_norm)
print(Barlett)
## $chisq
## [1] 1478.1
## 
## $p.value
## [1] 1.7846e-287
## 
## $df
## [1] 36

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

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. 

library(FactoMineR)
library(factoextra)
library(kableExtra)
Rx <- cor(data_parcial2_norm)
PC <- princomp(x = data_parcial2_norm, 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_dark(html_font = "sans-serif") %>%
  kable_styling(bootstrap_options = c("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 
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)

El grafico de sedimentacion nos ayuda a determinar el criterio de la raiz latente, de donde se extraen los primeros 2 componentes que son superiores al 70%.

2.¿Qué variables quedan representadas en cada factor?

library(psych)
library(corrplot)
library(dplyr)

#Modelo de 2 factores
num_factores<-2
factores_modelo<-principal(r = Rx,
                             nfactors = num_factores,
                             covar = FALSE,
                             rotate = "varimax")
print(factores_modelo)
## Principal Components Analysis
## Call: principal(r = Rx, nfactors = num_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
#Gráfico de aglomeración de las variables en los factores

correlaciones_modelo<-variables_pca$coord
rotacion<-varimax(correlaciones_modelo[,1:num_factores])
correlaciones_modelo_rotada<-rotacion$loadings

corrplot(correlaciones_modelo_rotada[,1:num_factores],
         is.corr = FALSE,
         method = "circle",
         addCoef.col="black",
         number.cex = 0.75)

En el factor 1: quedan representadas las variables ALFABET, INC_POB, FERTILID, TASA_NAT Y LOG_PIB; en el factor 2: quedan representadas las variables ESPVIDAF, URBANA, MORTINF Y TASA_MOR.

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

# Extracción de ponderadores 

library(kableExtra)
cargas <- rotacion$loadings[1:6, 1:num_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 
print(ponderadores)
##   Dim.1   Dim.2 
## 0.71684 0.28316

Los pesos a ser asignados en cada factor son: factor 1: peso de 0.72; y factor 2: peso de 0.28. 

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

Para el caso de las variables, los pesos para cada factor serán segun lo obtenido en la tabla anterior “Contribución de las variables en los Factores”.

SECCIÓN 2

Una empresa se encuentra calculando un Indicador del desempeño de sus líneas de producción, para ello no dispone de información previa, pero hay una importante consultora que posee expertos en el sector donde se ubica la empresa en cuestión. La consultora, la han determinado 4 variables que definen adecuadamente el desempeño de las líneas de producción:

Según su jerarquización, debera resolver lo siguiente:

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)

Método de Ranking por suma

library(magrittr)
#Jerarquia
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")

#Función de pesos
rank_suma_ponderadores_subjetivos <- 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))
}
#Aplicación de función
ranking_suma_pesos <- rank_suma_ponderadores_subjetivos(rj)

#Pesos brutos
ranking_suma_pesos$w_brutos
## X1 X2 X3 X4 
##  2  1  3  4
#Pesos normalizados
ranking_suma_pesos$w_normalizados %>% round(digits = 3)
##  X1  X2  X3  X4 
## 0.2 0.1 0.3 0.4
#Gráfico de pesos normalizados por suma
barplot(
  ranking_suma_pesos$w_normalizados,
  main = "Ponderadores jerarquia de suma",
  ylim = c(0, 0.5),
  col = "hotpink"
)

Metodo de Ranking reciprocos

#Jerarquia
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")

#Función de pesos
rank_reciproco_ponderadores_subjetivos <- function(vector_jerarquias) {
  vector_pesos <- 1 / vector_jerarquias
  list(w_brutos = vector_pesos,
       w_normalizados = vector_pesos / sum(vector_pesos))
}

#Aplicando la función
ranking_reciproco_pesos <- rank_reciproco_ponderadores_subjetivos(rj)

#Pesos brutos
ranking_reciproco_pesos$w_brutos
##      X1      X2      X3      X4 
## 0.33333 0.25000 0.50000 1.00000
#Pesos normalizados
ranking_reciproco_pesos$w_normalizados %>% round(digits = 3)
##   X1   X2   X3   X4 
## 0.16 0.12 0.24 0.48
#Gráfico de jerarquia por reciprocos
barplot(
  ranking_reciproco_pesos$w_normalizados,
  main = "Ponderadores Ranking Recíproco",
  ylim = c(0, 0.5),
  col = "mediumorchid1"
)

Metodo de Ranking exponencial

#Jerarquia
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")

#Función de pesos
rank_exponencial_ponderadores_subjetivos <-
  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))
  }
#Aplicación de función
ranking_exponencial_pesos <-
  rank_exponencial_ponderadores_subjetivos(rj)

#Pesos brutos
ranking_exponencial_pesos$w_brutos
##  X1  X2  X3  X4 
##  16   1  81 256
#Pesos normalizados
ranking_exponencial_pesos$w_normalizados %>% round(digits = 3)
##    X1    X2    X3    X4 
## 0.045 0.003 0.229 0.723
#Gráfico de ranking exponencial
barplot(ranking_exponencial_pesos$w_normalizados,
        main = "Ponderadores Ranking Exponencial",
        ylim = c(0,0.8),col = "seagreen1")

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

library(FuzzyAHP)

#Matriz 1
valores_matriz_comparativa_1 = c(1,7,4,5,
                                 NA,1,6,3,
                                 NA,NA,1,2,
                                 NA,NA,NA,1)
matriz_comparativa_1<-matrix(valores_matriz_comparativa_1,
                           nrow = 4, ncol = 4, byrow = TRUE)
matriz_comparativa_1<-pairwiseComparisonMatrix(matriz_comparativa_1)
matriz_comparativa_1@variableNames<-c("X1","X2","X3","X4")
show(matriz_comparativa_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_comparativa_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
#Gráfico
barplot(pesos_normalizados_1@weights,
        main = "Ponderadores por método comparación de pares",
        ylim = c(0,0.7),col = "thistle")

#Matriz 2
valores_matriz_comparativa_2 = c(1,7,6,3,
                                 NA,1,5,2,
                                 NA,NA,1,4,
                                 NA,NA,NA,1)
matriz_comparativa_2<-matrix(valores_matriz_comparativa_2,
                           nrow = 4, ncol = 4, byrow = TRUE)
matriz_comparativa_2<-pairwiseComparisonMatrix(matriz_comparativa_2)
matriz_comparativa_2@variableNames<-c("X1","X2","X3","X4")
show(matriz_comparativa_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_comparativa_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
#Gráfico
barplot(pesos_normalizados_2@weights,
        main = "Ponderadores por método comparación de pares",
        ylim = c(0,0.7),col = "darkcyan")

#Matriz 3
valores_matriz_comparativa_3 = c(1,7,5,4,
                                 NA,1,3,2,
                                 NA,NA,1,6,
                                 NA,NA,NA,1)
matriz_comparativa_3<-matrix(valores_matriz_comparativa_3,
                           nrow = 4, ncol = 4, byrow = TRUE)
matriz_comparativa_3<-pairwiseComparisonMatrix(matriz_comparativa_3)
matriz_comparativa_3@variableNames<-c("X1","X2","X3","X4")
show(matriz_comparativa_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_comparativa_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
#Gráfico
barplot(pesos_normalizados_3@weights,
        main = "Ponderadores por método comparación de pares",
        ylim = c(0,0.7),col = "firebrick1")

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
#Ponderación de expertos normalizadas (iguales)
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
library(kableExtra)
ponderacion_diferente_expertos<-(pesos_normalizados_1@weights*0.25)+(pesos_normalizados_2@weights*0.35)+(pesos_normalizados_3@weights*0.4)

show(ponderacion_diferente_expertos)
##     w_X1     w_X2     w_X3     w_X4 
## 0.611569 0.194412 0.119180 0.074838
sum(ponderacion_diferente_expertos)
## [1] 1
#Ponderaciones de expertos normalizadas (distintas)
normalizacion_2<-ponderacion_diferente_expertos/sum(ponderacion_diferente_expertos)
show(normalizacion_2)
##     w_X1     w_X2     w_X3     w_X4 
## 0.611569 0.194412 0.119180 0.074838