PRACTICA UNIDAD 2_CLAVE_B
Hazel Zuriel Menendez Ceron_MC16036
2022-10-25
Sección I
1.1) Usando Análisis Factorial determine cuántos factores deberían retenerse
Carga de datos
datos<- as.data.frame(load("C:/Users/hazel/Desktop/CICLO II-2022/METODOS/UNIDAD II/PARCIAL 2/data_parcial_2_B_rev.Rdata"))
data_parcial_2 %>% dplyr::select("ALFABET","INC_POB","ESPVIDAF","MORTINF","FERTILID","TASA_NAT", "LOG_PIB", "URBANA", "TASA_MOR") -> variables
variables <- na.omit(variables)
variables## # A tibble: 105 × 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
## # … with 95 more rowsNormalización de los datos
normalizacion_directa<-function(x){(x-min(x))/(max(x)-min(x))}
normalizacion_inversa<-function(x){(max(x)-x)/(max(x)-min(x))}
#Seleccionando las variables con correlación positiva con el desarrollo de las economias
variables %>% dplyr::select("ALFABET","INC_POB","ESPVIDAF","FERTILID","TASA_NAT", "LOG_PIB", "URBANA") %>%
apply(MARGIN = 2, FUN = normalizacion_directa) %>% as.data.frame()->variables_corr_positivas
#Seleccionando las variables con correlación negativa con el desarrollo de las economias
variables %>% dplyr::select("MORTINF", "TASA_MOR") %>%
apply(MARGIN = 2, FUN = normalizacion_inversa) %>% as.data.frame()->variables_corr_negativas
#Juntando y reordenando las variables
variables_corr_positivas %>% bind_cols(variables_corr_negativas) %>% dplyr::select("ALFABET","INC_POB","ESPVIDAF","MORTINF","FERTILID","TASA_NAT", "LOG_PIB", "URBANA", "TASA_MOR") ->datos_normalizados
head(datos_normalizados)## ALFABET INC_POB ESPVIDAF MORTINF FERTILID TASA_NAT LOG_PIB
## 1 0.9756098 0.3068592 0.82051282 0.8109756 0.21770682 0.30232558 0.60885423
## 2 0.1341463 0.5595668 0.02564103 0.0000000 0.81277213 1.00000000 0.09867408
## 3 0.9878049 0.1191336 0.92307692 0.9847561 0.02467344 0.02325581 0.94458420
## 4 0.5365854 0.6317690 0.69230769 0.7073171 0.77939042 0.65116279 0.76022519
## 5 0.9390244 0.2888087 0.82051282 0.8682927 0.21770682 0.23255814 0.63309802
## 6 0.9756098 0.3068592 0.82051282 0.8597561 0.27431060 0.30232558 0.70597624
## URBANA TASA_MOR
## 1 0.5157895 0.77272727
## 2 0.1368421 0.09090909
## 3 0.8421053 0.59090909
## 4 0.7578947 0.81818182
## 5 0.8526316 0.68181818
## 6 0.6631579 0.81818182Matriz de correlación y pruebas de Barlett y KMO
Matriz de correlación
# Matriz Rx
chart.Correlation(as.matrix(datos_normalizados), histogram = TRUE, pch=12)
Prueba de KMO
KMO<-paf(as.matrix(datos_normalizados))$KMO
KMO## [1] 0.86467Prueba de KMO >0.5, aplica analisis factorial
Prueba de Barlett
options(scipen = 99999)
Barlett<-cortest.bartlett(datos_normalizados)
Barlett## $chisq
## [1] 1544.4
##
## $p.value
## [1] 0.00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000015692
##
## $df
## [1] 36Como el KMO > 0.5 y el pvalue < 0.05, se tiene que puede procederse al análisis factorial porque existe multicolinealidad en los valores de la matriz de información
Análisis Factorial
Rx<-cor(datos_normalizados)
PC<-princomp(x = datos_normalizados, 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_classic_2(html_font = "helvetica") %>% kable_styling(bootstrap_options = c("hover"))| eigenvalue | variance.percent | cumulative.variance.percent | |
|---|---|---|---|
| Dim.1 | 6.69 | 74.34 | 74.34 |
| Dim.2 | 1.24 | 13.83 | 88.18 |
| Dim.3 | 0.53 | 5.91 | 94.08 |
| Dim.4 | 0.20 | 2.20 | 96.28 |
| Dim.5 | 0.17 | 1.93 | 98.21 |
| Dim.6 | 0.07 | 0.73 | 98.94 |
| Dim.7 | 0.06 | 0.62 | 99.56 |
| Dim.8 | 0.03 | 0.28 | 99.84 |
| Dim.9 | 0.01 | 0.16 | 100.00 |
Gráfico de sedimentación
fviz_eig(PC, choice = "eigenvalue", barcolor = "grey", barfill = "grey", addlabels = TRUE,
)+labs(title = "Gráfico de sedimentación", subtitle = "Usando Princom, con autovalores")+
xlab(label = "Componentes")+
ylab(label = "Autovalores")+geom_hline(yintercept = 1)
1.2) ¿Qué variables quedan representadas en cada factor?
Modelo de 2 factores (rotado)
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.76 0.53 0.86 0.141 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.059 2.0
## FERTILID -0.87 -0.40 0.92 0.079 1.4
## TASA_NAT -0.90 -0.40 0.97 0.034 1.4
## LOG_PIB 0.65 0.58 0.75 0.246 2.0
## URBANA 0.42 0.73 0.71 0.294 1.6
## TASA_MOR -0.02 0.93 0.87 0.135 1.0
##
## RC1 RC2
## SS loadings 4.52 3.41
## Proportion Var 0.50 0.38
## Cumulative Var 0.50 0.88
## 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 = 1#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 = "circle", addCoef.col ="black", 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<-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 extraidos", align = "c", digits = 2) %>%
kable_classic_2(html_font = "helvetica") %>% kable_styling(bootstrap_options = c("striped", "hover"))| Dim.1 | Dim.2 |
|---|---|
| 0.57 | 0.43 |
# 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_classic_2(html_font = "sans-serif") %>% kable_styling(bootstrap_options = c("striped", "hover"))| Dim.1 | Dim.2 | |
|---|---|---|
| ALFABET | 0.13 | 0.08 |
| 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.16 |
| TASA_MOR | 0.00 | 0.25 |
Sección II
Ejercicio 1
Ranking suma
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)
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 4Pesos normalizados
pesos_ranking_suma$w_normalizados %>% round(digits = 3)## X1 X2 X3 X4
## 0.2 0.1 0.3 0.4#Gráfica de los pesos normalizados
barplot(pesos_ranking_suma$w_normalizados,
main = "Ponderadores Ranking Suma",
ylim = c(0,0.5), col = "pink")
Ranking recíproco
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.00000Pesos normalizados
pesos_ranking_reciproco$w_normalizados %>% round(digits = 3)## X1 X2 X3 X4
## 0.16 0.12 0.24 0.48#Gráfica de los pesos normalizados
barplot(pesos_ranking_reciproco$w_normalizados,
main = "Ponderadores Ranking Reciproco",
ylim = c(0,0.5), col = "light blue")
Jerarquía Exponencial
ponderadores_subjetivos_rank_exponencial<-function(vector_jerarquias, p=2){
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, p = 4)
#Pesos brutos
pesos_ranking_exponencial$w_brutos## X1 X2 X3 X4
## 16 1 81 256Pesos normalizados
pesos_ranking_exponencial$w_normalizados %>% round(digits = 3)## X1 X2 X3 X4
## 0.045 0.003 0.229 0.723#Gráfica de los pesos normalizados
barplot(pesos_ranking_exponencial$w_normalizados,
main = "Ponderadores Ranking exponencial",
ylim = c(0,0.8), col = "gold")
Ejercicio 2
2.1) Asumiendo que la opinión de los 3 expertos es igualmente válida.
Experto 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("Mantenimiento de la línea de producción", "Tamaño de planta", "Logística", "Capacidad de innovación")
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] "Mantenimiento de la línea de producción"
## [2] "Tamaño de planta"
## [3] "Logística"
## [4] "Capacidad de innovación"Cálculo de los pesos normalizados
pesos_normalizados_1 = calculateWeights(matriz_comparacion_1)
show(pesos_normalizados_1)## An object of class "Weights"
## Slot "weights":
## w_Mantenimiento de la línea de producción
## 0.606592
## w_Tamaño de planta
## 0.223310
## w_Logística
## 0.094748
## w_Capacidad de innovación
## 0.075350Experto 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("Mant. producción", "Tamaño de planta", "Logística", "Capacidad de innovación")
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] "Mant. producción" "Tamaño de planta"
## [3] "Logística" "Capacidad de innovación"Cálculo de los pesos normalizado
pesos_normalizados_2 = calculateWeights(matriz_comparacion_2)
show(pesos_normalizados_2)## An object of class "Weights"
## Slot "weights":
## w_Mant. producción w_Tamaño de planta w_Logística
## 0.60919 0.19879 0.10987
## w_Capacidad de innovación
## 0.08215Experto 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("Mantenimiento de la línea de producción", "Tamaño de planta", "Logística", "Capacidad de innovación")
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] "Mantenimiento de la línea de producción"
## [2] "Tamaño de planta"
## [3] "Logística"
## [4] "Capacidad de innovación"Cálculo de los pesos normalizados
pesos_normalizados_3 = calculateWeights(matriz_comparacion_3)
show(pesos_normalizados_3)## An object of class "Weights"
## Slot "weights":
## w_Mantenimiento de la línea de producción
## 0.61676
## w_Tamaño de planta
## 0.17252
## w_Logística
## 0.14259
## w_Capacidad de innovación
## 0.068122.1) Asumiendo que la opinión de los 3 expertos es igualmente válida
Promedio simple
opinion_1<-as.matrix(pesos_normalizados_1@weights)
opinion_2<-as.matrix(pesos_normalizados_2@weights)
opinion_3<-as.matrix(pesos_normalizados_3@weights)
pesos_promedio_simple<-(opinion_1+opinion_2+opinion_3)/3
show(pesos_promedio_simple)## [,1]
## w_Mantenimiento de la línea de producción 0.610848
## w_Tamaño de planta 0.198207
## w_Logística 0.115739
## w_Capacidad de innovación 0.0752072.2) Si el experto 1 se pondera con 0.25, el experto 2 con 0.35 y el experto 3 con 0.4
Promedio ponderado
pesos_promedios_ponderados<-(opinion_1%*%0.25)+(opinion_2%*%0.35)+(opinion_3%*%0.4)
show(pesos_promedios_ponderados)## [,1]
## w_Mantenimiento de la línea de producción 0.611569
## w_Tamaño de planta 0.194412
## w_Logística 0.119180
## w_Capacidad de innovación 0.074838