Practica Unidad 2
LIDIA MARGARITA PEÑATE HERNANDEZ
2022-10-20
CLAVE “A”
Desarrolle el siguiente ejercicio: Se necesita construir un indicador multivariado sintético, que mida la “Seguridad Municipal” Para ello se dispone de la siguiente información:
Variable y Correlación con la variable compleja
X1 % de Negocios victimizados durante el año por - robo o hurto - positiva X2 % de Negocios victimizados durante el año - extorsión o secuestro - positiva X3 % de Negocios que consideran que el crimen fue mayor en el año actual comparado con el año anterior - positiva X4 % de Negocios que consideran que el crimen local es mayor que en los municipios vecinos - negativa X5 Erogaciones municipales per cápita en seguridad pública (US$) - positiva X6 Costo del crimen a negocios por cada US$1,000 de ventas durante el año previo - negativa X7 % de Negocios que califican a la municipalidad como buena en prevención y control del delito - positiva X8 % de Negocios que consideran que la calidad del alumbrado público es adecuada para la seguridad de los negocios en el municipio - positiva
Ejercicio 1 (25%):
A través del análisis de componentes principales, identifique para un modelo de 3 factores: a) Los ponderadores normalizados para cada factor. b) Las variables incluidas en cada factor.
Importación de Datos
load("C:/Users/Luis Anaya/OneDrive/Desktop/metodos para el analisis economico/UNIDAD II/data_parcial_2_A_rev.RData")a) Los ponderadores normalizados para cada factor.
library(kableExtra)
library(dplyr)
datos<-datos_parcial_2
mat_X<-datos[,c(-1,-2)]
mat_X %>% head() %>%
kable(caption ="Matriz de información:" ,align = "c",digits = 6) %>%
kable_material(html_font = "sans-serif")| X1 | X2 | X3 | X4 | X5 | X6 | X7 | X8 |
|---|---|---|---|---|---|---|---|
| 9 | 2 | 20.00000 | 20.00000 | 0.00000 | 0.000000 | 2 | 56.4000 |
| 10 | 6 | 62.50000 | 50.00000 | 37.50000 | 3.947368 | 11 | 147.3750 |
| 10 | 20 | 50.00000 | 50.00000 | 50.00000 | 2.564103 | 16 | 135.0000 |
| 8 | 3 | 42.85714 | 42.85714 | 14.28571 | 1.351351 | 35 | 121.1429 |
| 7 | 7 | 75.00000 | 75.00000 | 75.00000 | 9.090909 | 8 | 202.5000 |
| 6 | 13 | 30.00000 | 30.00000 | 30.00000 | 8.108108 | 25 | 81.0000 |
NORMALIZACIÓN DE LOS DATOS
library(dplyr)
norm_directa<-function(x){(x-min(x))/(max(x)-min(x))}
norm_inversa<-function(x){(max(x)-x)/(max(x)-min(x))}
#Seleccionando las variables con correlación positiva para la Salud Financiera
mat_X %>%
select(X1,X2,X3,X5,X6,X8) %>%
apply(MARGIN = 2,FUN = norm_directa) %>% as.data.frame()->variables_corr_positiva
#Seleccionando las variables con correlación negativa para la Salud Financiera
mat_X %>%
select(X4,X7) %>%
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(X1,X2,X3,X4,X5,X6,X7,X8)->datos_normalizados
head(datos_normalizados)## X1 X2 X3 X4 X5 X6 X7
## 1 0.19354839 0.000000000 0.0400000 0.8000000 0.0000000 0.00000000 1.0000000
## 2 0.22580645 0.017167382 0.5500000 0.5000000 0.4285714 0.21558704 0.9010989
## 3 0.22580645 0.077253219 0.4000000 0.5000000 0.5714286 0.14003945 0.8461538
## 4 0.16129032 0.004291845 0.3142857 0.5714286 0.1632653 0.07380457 0.6373626
## 5 0.12903226 0.021459227 0.7000000 0.2500000 0.8571429 0.49650350 0.9340659
## 6 0.09677419 0.047210300 0.1600000 0.7000000 0.3428571 0.44282744 0.7472527
## X8
## 1 0.1582266
## 2 0.5167488
## 3 0.4679803
## 4 0.4133709
## 5 0.7339901
## 6 0.2551724MATRIZ DE CORRELACIÓN
library(PerformanceAnalytics)
chart.Correlation(as.matrix(datos_normalizados),histogram = TRUE,pch=12)
- A simple vista vemos que la gran mayoria de correlacion son
significativas al 1% (***). - Hay evidente correlacion entre al menos la
mitad de las variables propuestas en la bateria de indicadores.
PRUEBAS DE BARLETT Y KMO
# Prueba de Barlett
library(psych)
options(scipen = 99999)
Barlett<-cortest.bartlett(datos_normalizados)
print(Barlett)## $chisq
## [1] 1025.923
##
## $p.value
## [1] 0.000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000004695093
##
## $df
## [1] 28# Prueba de KMO
library(rela)
KMO<-paf(as.matrix(datos_normalizados))$KMO
print(KMO)## [1] 0.67931Se rechaza Ho ya que p-value< nivel de significancia (5%). Por lo tanto, hay evidencia de correlacion poblacional entre la bateria de indicadores propuesta.
Se satisfacen los supuestos
ANÁLISIS FACTORIAL
library(FactoMineR)
library(factoextra)
library(kableExtra)
#CALCULO DE LA MATRIZ DE CORRELACION (version numerica)
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_material(html_font = "sans-serif") %>%
kable_styling(bootstrap_options = c("hover"))| eigenvalue | variance.percent | cumulative.variance.percent | |
|---|---|---|---|
| Dim.1 | 3.90 | 48.72 | 48.72 |
| Dim.2 | 1.96 | 24.55 | 73.27 |
| Dim.3 | 0.84 | 10.52 | 83.78 |
| Dim.4 | 0.50 | 6.24 | 90.03 |
| Dim.5 | 0.45 | 5.68 | 95.70 |
| Dim.6 | 0.28 | 3.45 | 99.16 |
| Dim.7 | 0.07 | 0.82 | 99.98 |
| Dim.8 | 0.00 | 0.02 | 100.00 |
- Por le criterio de raiz latente solo retendriamos 2 factores
- Por le criterio del porcentaje acumulado de la varianza retendriamos 3 factores.
PARA MEJORAR NUESTRA ELEECION- OBTENER EL GRAFICO DE SEDIMENTACION Criterio de el bong
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)
Por este criterio depende del investigador se podrian retener 2 o 3
componentes. Pero si nos ponemos estrictos, se deberian retener
unicamente 2 componentes segun este criterio.
MODELO DE 3 FACTORES (ROTADO)
library(psych)
library(corrplot)
library(dplyr)
numero_de_factores<-3
modelo_factores3<-principal(r = Rx,
nfactors = numero_de_factores,
covar = FALSE,
rotate = "varimax")
modelo_factores3## 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 RC3 h2 u2 com
## X1 -0.16 0.80 -0.03 0.67 0.3316 1.1
## X2 0.08 0.84 -0.03 0.71 0.2879 1.0
## X3 0.93 -0.09 0.28 0.95 0.0493 1.2
## X4 -0.95 0.05 -0.26 0.98 0.0208 1.2
## X5 0.43 -0.06 0.80 0.83 0.1742 1.5
## X6 0.25 -0.03 0.91 0.89 0.1142 1.2
## X7 0.07 -0.83 0.04 0.69 0.3107 1.0
## X8 0.96 -0.06 0.27 0.99 0.0087 1.2
##
## RC1 RC2 RC3
## SS loadings 2.97 2.05 1.68
## Proportion Var 0.37 0.26 0.21
## Cumulative Var 0.37 0.63 0.84
## Proportion Explained 0.44 0.31 0.25
## Cumulative Proportion 0.44 0.75 1.00
##
## Mean item complexity = 1.2
## Test of the hypothesis that 3 components are sufficient.
##
## The root mean square of the residuals (RMSR) is 0.06
##
## Fit based upon off diagonal values = 0.98Para esta solucion, al retener 3 factores (rotado), X1 tiene el 67% de su varianza explicada y hay un 33% de la variacion de X1 que es propia de ese indicador. Todas muestran un alto porcentaje de su varianza explicada quiere decir que esta solucion es bastante representativa de la bateria de indicadores originales.
b) Las variables incluidas en cada factor.
correlaciones_modelo<-variables_pca$coord
#Para extraer las componente rotadas hay que volverlas a calcular de manera manual
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)
- Para la variable latente 1 queda representada X3,X4,X8. Estas 3
variables estarian representadas por la dimension 1. -La dimension 2
esta mas asociada con X1,X2 y X7. -La dimension 3 esta mas asociada con
X5 y X6
Aca podemos estar totalmente seguros que esa seria la clasficiacion que deberiamos hacer.
Ejercicio 2 (25%):
Para el factor 1, utilice el método CRITIC para obtener los ponderadores normalizados para cada variable.
library(dplyr)
# Funciones para normalizar los datos
norm_directa <- function(x){
return((x-min(x)) / (max(x)-min(x)))
}
norm_inverza <- function(x){
return((max(x)-x) / (max(x)-min(x)))
}
# Normalización de los datos
datos_parcial_2 %>% dplyr::select(X3,X4,X8) %>%
dplyr::transmute(X3 = norm_directa(X3),
X4 = norm_inverza(X4),
X8 = norm_directa(X8)) -> data_factor_1
print(data_factor_1)## # A tibble: 108 × 3
## X3 X4 X8
## <dbl> <dbl> <dbl>
## 1 0.04 0.8 0.158
## 2 0.55 0.5 0.517
## 3 0.4 0.5 0.468
## 4 0.314 0.571 0.413
## 5 0.7 0.25 0.734
## 6 0.16 0.7 0.255
## 7 0.673 0.273 0.714
## 8 0.55 0.5 0.446
## 9 0.4 0.563 0.433
## 10 0.68 0.467 0.552
## # … with 98 more rows## CALCULO DE LAS DESVIACIONES ESTANDAR DE CADA VARIABLES (cada columna)
data_factor_1 %>% dplyr::summarise(S3=sd(X3),S4=sd(X4),S8=sd(X8))-> sd_vector
print(sd_vector)## # A tibble: 1 × 3
## S3 S4 S8
## <dbl> <dbl> <dbl>
## 1 0.246 0.201 0.209## CALCULO DE LA MATRIZ DE CORRELACION
cor(data_factor_1)->mat_R_F1
print(mat_R_F1)## X3 X4 X8
## X3 1.00000 -0.93872 0.95904
## X4 -0.93872 1.00000 -0.99585
## X8 0.95904 -0.99585 1.00000## CÁLCULO DE LOS PONDERADORES BRUTOS
1-mat_R_F1->sum_data
colSums(sum_data)->sum_vector
sd_vector*sum_vector->vj
print(vj)## S3 S4 S8
## 1 0.48755 0.79129 0.42517## CALCULO DE LOS PONDERADORES NETOS
vj/sum(vj)->wj
print(wj)## S3 S4 S8
## 1 0.28612 0.46437 0.24951## PONDERADORES/ PESOS:
print(round(wj*100,2))## S3 S4 S8
## 1 28.61 46.44 24.95Ejercicio 3 (25%):
Para el factor 2, utilice el método de Entropía para obtener los ponderadores normalizados para cada variable.
Método de ENTROPIA
#Normalización de los datos
mat_X %>% dplyr::select(X1,X2,X7)->data_norm
apply(data_norm,2,prop.table)->data_norm
head(data_norm)## X1 X2 X7
## [1,] 0.0078125 0.00070734 0.0013986
## [2,] 0.0086806 0.00212202 0.0076923
## [3,] 0.0086806 0.00707339 0.0111888
## [4,] 0.0069444 0.00106101 0.0244755
## [5,] 0.0060764 0.00247569 0.0055944
## [6,] 0.0052083 0.00459770 0.0174825# Fórmula de entropía
entropy<-function(x){
return(x*log(x))
}
apply(data_norm,2,entropy)->data_norm_2
head(data_norm_2)## X1 X2 X7
## [1,] -0.037906 -0.0051310 -0.009192
## [2,] -0.041204 -0.0130618 -0.037443
## [3,] -0.041204 -0.0350233 -0.050270
## [4,] -0.034513 -0.0072664 -0.090806
## [5,] -0.031010 -0.0148572 -0.029013
## [6,] -0.027383 -0.0247457 -0.070744#Número de variables en el factor:
ncol(data_norm)->m
#Constante de entropía:
-1/log(m)->K
print(K)## [1] -0.91024#Cálculo de los indices de entropía
K*colSums(data_norm_2)->Ej
print(Ej)## X1 X2 X7
## 4.1805 3.2029 3.7019#Cálculo de las especificidades:
1-Ej->vj
print(vj)## X1 X2 X7
## -3.1805 -2.2029 -2.7019#Cálculo de los ponderadores netos:
prop.table(vj)->wj #es igual a usar vj/sum(vj)
print(wj)## X1 X2 X7
## 0.39337 0.27245 0.33417Ejercicio 4 (25%):
Para el factor 3, utilice el método de Ranking para obtener los ponderadores normalizados para cada variable (utilice la numeración de las variables para establecer la jerarquía).
POR SUMA
library(magrittr)
#Vector de Jerarquías
rj<-c(1,2)
names(rj)<-c("X5","X6")
#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## X5 X6
## 2 1#Pesos normalizados
pesos_ranking_suma$w_normalizados %>% round(digits = 3)## X5 X6
## 0.667 0.333GRÁFICO DE LOS PESOS NORMALIZADOS- Suma
barplot(pesos_ranking_suma$w_normalizados,
main = "Ponderadores Ranking de Suma",
ylim = c(0,0.5),col = "red")
JERARGUÍA RECÍPROCA
#Vector de Jerarquías
rj<-c(1,2)
names(rj)<-c("X5","X6")
#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## X5 X6
## 1.0 0.5#Pesos normalizados
pesos_ranking_reciproco$w_normalizados %>% round(digits = 3)## X5 X6
## 0.667 0.333#Gráfico de los pesos normalizados GRÁFICO DE LOS PESOS NORMALIZADOS- Reciproco
barplot(pesos_ranking_reciproco$w_normalizados,
main = "Ponderadores Ranking Recíproco",
ylim = c(0,0.5),col = "green")
JERARQUÍA EXPONENCIAL
library(magrittr)
#Vector de Jerarquías
rj<-c(1,2)
names(rj)<-c("X5","X6")
#Función para generar los pesos
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)
#Pesos brutos
pesos_ranking_exponencial$w_brutos## X5 X6
## 4 1#Pesos normalizados
pesos_ranking_exponencial$w_normalizados %>% round(digits = 3)## X5 X6
## 0.8 0.2GRÁFICO DE LOS PESOS NORMALIZADOS- Exponencial
#(por default p=2)
barplot(pesos_ranking_suma$w_normalizados,
main = "Ponderadores Ranking Exponencial",
ylim = c(0,0.5),col = "coral")
CLAVE “B”
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
SECCIÓN 1:
a) Usando Análisis Factorial determine cuántos factores deberían retenerse.
CARGA DE DATOS
load("C:/Users/Luis Anaya/OneDrive/Desktop/metodos para el analisis economico/UNIDAD II/data_parcial_2_B_rev.RData")NORMALIZACIÓN DE DATOS
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))}
# 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))->data_parcial_2
# Seleccionando variables con correlación positiva con desarrollo de economias
data_parcial_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
data_parcial_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 TASA_MOR
## 1 0.98 0.30686 0.820513 0.34188 0.302326 0.608854 0.54 0.81098 0.708333
## 2 0.29 0.55957 0.025641 0.84249 1.000000 0.098674 0.18 0.00000 0.083333
## 3 0.99 0.11913 0.923077 0.17949 0.023256 0.944584 0.85 0.98476 0.541667
## 4 0.62 0.63177 0.692308 0.81441 0.651163 0.760225 0.77 0.70732 0.750000
## 5 0.95 0.28881 0.820513 0.34188 0.232558 0.633098 0.86 0.86829 0.625000
## 6 0.98 0.30686 0.820513 0.38950 0.302326 0.705976 0.68 0.85976 0.750000MATRIZ Rx (Matriz de Correlación)
library(PerformanceAnalytics)
chart.Correlation(as.matrix(data_p2_normalizados),histogram = TRUE,pch=12)
Pruebas de Barlett y KMO
#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#KMO
library(rela)
KMO<-paf(as.matrix(data_p2_normalizados))$KMO
print(KMO)## [1] 0.85275Debido a que el p-value < 0.05 (nivel de significancia), se rechaza la Ho por lo tanto, hay evidencia de multicolinealidad
ANÁLISIS 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("hover"))| 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 |
Por le criterio de raiz latente solo retendriamos 2 factores
Por le criterio del porcentaje acumulado de la varianza retendriamos 2 factores.
GRÁFICO DE SEDIMENTACIÓN
fviz_eig(PC,
choice = "eigenvalue",
barcolor = "pink",
barfill = "blue",
addlabels = TRUE,
)+labs(title = "Gráfico de Sedimentación",subtitle = "Usando princomp con Autovalores")+
xlab(label = "Componentes")+
ylab(label = "Autovalores")+geom_hline(yintercept = 1)
Por este criterio (criterio de el bong) se podrian retener 2 componentes.
b)¿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#Gráfico de aglomeración de las variables en cada factor
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
c) Determine qué pesos deben asignarse a cada factor y a las variables dentro de cada uno de ellos.
# 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"))| 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"))| 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 |
- Al factor 1 debe asignarse el peso 0.72
- 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
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, ha han determinado 4 variables que definen adecuadamente el desempeño de las líneas de producción: X1: Mantenimiento de la línea de producción X2: Tamaño de planta X3: Logística (entradas y salidas de insumos y producción) X4: Capacidad de innovación. La consultora jerarquizó las variables de la siguiente manera:
Variable: X1, X2, X3, X4 Ranking: 3, 4, 2, 1
Dentro de la consultora hay 3 expertos que propusieron la jerarquía anterior, pero también realizaron un ejercicio de comparación por pares y los resultados fueron los siguientes:
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)
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# Gráfico de los pesos normalizados
barplot(pesos_ranking_suma$w_normalizados,
main = "Ponderadores Ranking de Suma",
ylim = c(0,0.5),col = "red")
JERARGUÍA RECÍPROCA
# 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")
JERARQUÍA 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#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 = "blue")
Ejercicio 2. Usando la técnica de comparación por pares, calcule los pesos normalizados para las variables:
2.1 Asumiendo que la opinión de los 3 expertos es igualmente válida.
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# Graficando
barplot(pesos_normalizados_1@weights,
main = "Ponderadores por método comparación de pares",
ylim = c(0,0.7),col = "blue")
# 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 = "blue")
# 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.06812barplot(pesos_normalizados_3@weights,
main = "Ponderadores por método comparación de pares",
ylim = c(0,0.7),col = "blue")
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.074838normalizacion_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.074838sum(ponderacion_expertos_distintas)## [1] 1