SECCION I

Carga de data

load("C:/Users/Keiry/Documents/Metodos2020/Parcial2/data_parcial_2.RData")
library(tidyr)
library(dplyr)
norm_directa<-function(x){(x-min(x))/(max(x)-min(x))}
norm_inversa<-function(x){(max(x)-x)/(max(x)-min(x))}

# Quitando las variables nulas
#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

#Seleccionando las 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()->variables_corr_positiva
#Seleccionando las variables con correlación negativa 
data_parcial_2 %>% 
  select(MORTINF,TASA_MOR) %>% 
  apply(MARGIN = 2,FUN = norm_inversa) %>% as.data.frame()->variables_corr_negativa
#Juntando y reordenando las variables
variables_corr_positiva %>% 
  bind_cols(variables_corr_negativa) %>% 
  select(ALFABET,INC_POB,ESPVIDAF,FERTILID,TASA_NAT,LOG_PIB,URBANA,MORTINF,TASA_MOR)->data_parcial_2_normalizada
head(data_parcial_2_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 Correlación & Pruebas de Barlett y KMO
# Matriz de correlación
library(PerformanceAnalytics)
chart.Correlation(as.matrix(data_parcial_2_normalizada),histogram = TRUE,pch=12)

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

Rx<-cor(data_parcial_2_normalizada)
PC<-princomp(x = data_parcial_2_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(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 
######### Grafico de sedimentación
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)

######### Componentes principales
library(corrplot)
#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
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="grey",
         number.cex = 0.75)

######### Ponderadores de los factores 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(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 
######### Contribución de las variables en los Factores
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

SECCION II

Ejercicio 1 1. Jeraquia de 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
#Gráfico de los pesos normalizados
barplot(pesos_ranking_suma$w_normalizados,
        main = "Ponderadores Ranking de Suma",
        ylim = c(0,0.5),col = "blue")

  1. Jerarquia reciproca
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_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
#Gráfico de los pesos normalizados
barplot(pesos_ranking_reciproco$w_normalizados,
        main = "Ponderadores Ranking Recíproco",
        ylim = c(0,0.5),col = "green")

  1. Jerarquia exponencial
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_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
#Gráfico de los pesos normalizados (p=4)
barplot(pesos_ranking_exponencial$w_normalizados,
        main = "Ponderadores Ranking Exponencial",
        ylim = c(0,0.8),col = "coral")

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

library(FuzzyAHP)
#Experto 1
valores_matriz_comparacion = c(1,7,4,5,
                               NA,1,6,3,
                               NA,NA,1,2,
                               NA,NA,NA,1)
matriz_comparacion<-matrix(valores_matriz_comparacion,
                           nrow = 4, ncol = 4, byrow = TRUE)
matriz_comparacion<-pairwiseComparisonMatrix(matriz_comparacion)
matriz_comparacion@variableNames<-c("X1","X2","X3","X4")
show(matriz_comparacion)
## 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 = calculateWeights(matriz_comparacion)
show(pesos_normalizados)
## 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@weights,
        main = "Ponderadores por comparación de pares",
        ylim = c(0,0.7),col = "blue")

#Experto 2
valores_matriz_comparacion_1 = c(1,7,6,3,
                                NA,1,5,2,
                                NA,NA,1,4,
                                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"   "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_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.60919 0.19879 0.10987 0.08215
barplot(pesos_normalizados_1@weights,
        main = "Ponderadores por comparación de pares",
        ylim = c(0,0.7),col = "blue")

#Experto 3
valores_matriz_comparacion_2 = c(1,7,5,4,
                               NA,1,3,2,
                               NA,NA,1,6,
                               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"   "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_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.61676 0.17252 0.14259 0.06812
barplot(pesos_normalizados_2@weights,
        main = "Ponderadores por comparación de pares",
        ylim = c(0,0.7),col = "blue")

Promedio pesos, asumiendo que son iguales

ponderacion<-1/3
promedio<-pesos_normalizados@weights+pesos_normalizados_1@weights+pesos_normalizados_2@weights

promedio_final<-ponderacion*promedio
show(promedio_final)
##     w_X1     w_X2     w_X3     w_X4 
## 0.610848 0.198207 0.115739 0.075207
sum(promedio_final)
## [1] 1
normalizacion<-promedio_final/sum(promedio_final)
show(normalizacion)
##     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.4, el experto 2 con 0.4 y el experto 3 con 0.2

promedio_final_total<-(pesos_normalizados@weights*0.4)+(pesos_normalizados_1@weights*0.4)+(pesos_normalizados_2@weights*0.20)
promedio_final_total
##     w_X1     w_X2     w_X3     w_X4 
## 0.609665 0.203343 0.110367 0.076624
sum(promedio_final_total)
## [1] 1
normalizacion_1<-promedio_final_total/sum(promedio_final_total)
show(normalizacion_1)
##     w_X1     w_X2     w_X3     w_X4 
## 0.609665 0.203343 0.110367 0.076624