SOLUCION_PREPARCIAL_P2_MAE
JEFFRY ISAAC BONILLA MELARA BM20033
2022-10-25
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
1 % 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. A través del análisis de componentes principales, identifique para un modelo de 3 factores:
#Carga de data
load("C:/Users/Jeffry/Documents/CICLO2_2022/MAE/PARCIAL_2/data_parcial_2_A_rev.RData")library(kableExtra)
mat_X<-datos_parcial_2[,c(-1,-2)]
mat_X %>% head() %>%
kable(caption ="Matriz de informacion:" ,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 |
NORMALIZACION DE 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 & Pruebas de Barlett y KMO
#Matriz de correlación
library(PerformanceAnalytics)
chart.Correlation(as.matrix(datos_normalizados),histogram = TRUE,pch=12)
KMO
#KMO
library(rela)
KMO<-paf(as.matrix(datos_normalizados))$KMO
print(KMO)## [1] 0.67931BARLETT
#Prueba de Barlett
library(psych)
options(scipen = 99999)
Barlett<-cortest.bartlett(datos_normalizados)
print(Barlett)## $chisq
## [1] 1025.9
##
## $p.value
## [1] 0.0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000046951
##
## $df
## [1] 28ANALISIS FACTORIA
library(FactoMineR)
library(factoextra)
library(kableExtra)
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 |
fviz_eig(PC,
choice = "eigenvalue",
barcolor = "red",
barfill = "red",
addlabels = TRUE,
)+labs(title = "Grafico de Sedimentacion",subtitle = "Usando princomp, con Autovalores")+
xlab(label = "Componentes")+
ylab(label = "Autovalores")+geom_hline(yintercept = 1)
* Raiz latente se retienen 2 dim. * % porcentaje acumulado de la
varianza: 3 dim. * Cambio de tendencia 3 dim.
library(corrplot)
#Modelo de 3 Factores (Rotada)
numero_de_factores<-3
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 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.98- la primera variable ponderador de 0.44, la segunda de 0.31 y la tercera de 0.25.
b. Las variables incluidas 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 = "square",
addCoef.col="grey",
number.cex = 0.75)
library(kableExtra)
cargas<-rotacion$loadings[1:8,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 | Dim.3 |
|---|---|---|
| 0.44 | 0.31 | 0.25 |
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 | Dim.3 | |
|---|---|---|---|
| X1 | 0.01 | 0.31 | 0.00 |
| X2 | 0.00 | 0.34 | 0.00 |
| X3 | 0.29 | 0.00 | 0.05 |
| X4 | 0.31 | 0.00 | 0.04 |
| X5 | 0.06 | 0.00 | 0.38 |
| X6 | 0.02 | 0.00 | 0.49 |
| X7 | 0.00 | 0.33 | 0.00 |
| X8 | 0.31 | 0.00 | 0.04 |
Ejercicio 2 Para el factor 1, utilice el método CRITIC para obtener los ponderadores normalizados para cada variable.
Método Critic
library(dplyr)
# Funciones para normalizar los datos
norm_directa_a <- function(x){
return((x-min(x)) / (max(x)-min(x)))
}
norm_inverza_a <- function(x){
return((max(x)-x) / (max(x)-min(x)))
}
# Normalización de los datos
mat_X %>% dplyr::select(X3,X4,X8) %>%
dplyr::transmute(X3 = norm_directa_a(X3),
X4 = norm_inverza_a(X4),
X8 = norm_directa_a(X8)) -> data_factor
print(data_factor)## # 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#Cálculo de las desviaciones estándar de cada variable
data_factor %>% 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#Cálculo de la matriz de correlación
cor(data_factor)->mat_R_F
print(mat_R_F)## 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_F->sum_data
colSums(sum_data)->sum_vector
sd_vector*sum_vector->vj
print(vj)## S3 S4 S8
## 1 0.48755 0.79129 0.42517#Cálculo de los ponderadores netos
vj/sum(vj)->wj
print(wj)## S3 S4 S8
## 1 0.28612 0.46437 0.24951#Ponderadores:
print(round(wj*100,2))## S3 S4 S8
## 1 28.61 46.44 24.95Ejercicio 3 Para el factor 2, utilice el método de Entropía para obtener los ponderadores normalizados para cada variable.
Método Entropía
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_norm1
head(data_norm1)## 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 las entropías
K*colSums(data_norm1)->Ej_1
print(Ej_1)## X1 X2 X7
## 4.1805 3.2029 3.7019#Cálculo de las especificidades:
1-Ej_1->vj1
print(vj1)## X1 X2 X7
## -3.1805 -2.2029 -2.7019#Cálculo de los ponderadores:
prop.table(vj1)->wj1 #es igual a usar vj/sum(vj)
print(wj1)## X1 X2 X7
## 0.39337 0.27245 0.33417Ejercicio 4 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
rj1<-c(1,2)
names(rj1)<-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_suma1<-ponderadores_subjetivos_rank_suma(rj1)
#Pesos brutos
pesos_ranking_suma1$w_brutos## X5 X6
## 2 1#Pesos normalizados
pesos_ranking_suma1$w_normalizados %>% round(digits = 3)## X5 X6
## 0.667 0.333#Gráfico de los pesos normalizados
barplot(pesos_ranking_suma1$w_normalizados,
main = "Ponderadores Ranking de Suma",
ylim = c(0,1),col = "red")
#Vector de Jerarquías
rj2<-c(1,2)
names(rj2)<-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_reciproco1<-ponderadores_subjetivos_rank_reciproco(rj2)
#Pesos brutos
pesos_ranking_reciproco1$w_brutos## X5 X6
## 1.0 0.5#Pesos normalizados
pesos_ranking_reciproco1$w_normalizados %>% round(digits = 3)## X5 X6
## 0.667 0.333#Gráfico de los pesos normalizados
barplot(pesos_ranking_reciproco1$w_normalizados,
main = "Ponderadores Ranking Reciproco",
ylim = c(0,1),col = "orange")
library(magrittr)
#Vector de Jerarquías
rj3<-c(1,2)
names(rj3)<-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_exponencial1<-ponderadores_subjetivos_rank_exponencial(rj3)
#Pesos brutos
pesos_ranking_exponencial1$w_brutos## X5 X6
## 4 1#Pesos normalizados
pesos_ranking_exponencial1$w_normalizados %>% round(digits = 3)## X5 X6
## 0.8 0.2#Gráfico de los pesos normalizados (por default p=2)
barplot(pesos_ranking_suma1$w_normalizados,
main = "Ponderadores Ranking Exponencial",
ylim = c(0,1),col = "brown")
#Comparación de valores de "p"
par(mfrow=c(1,3))
for(p in 2:4){
pesos<-ponderadores_subjetivos_rank_exponencial(vector_jerarquias = rj1,p = p)
barplot(pesos$w_normalizados,main = paste0("p=",p),ylim = c(0,1),col = "brown",cex.main=3,cex.axis = 3)
}
SOLUCION CLAVE B
EJERCICIO 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
A. Usando Análisis Factorial determine cuántos factores deberían retenerse.
#Carga de datos
load("C:/Users/Jeffry/Documents/CICLO2_2022/MAE/PARCIAL_2/data_parcial_2_B_rev.RData")Matriz informacion
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 %>%
dplyr::select(ALFABET,INC_POB,ESPVIDAF,FERTILID,TASA_NAT,LOG_PIB,URBANA) %>%
apply(MARGIN = 2,FUN = norm_directa) %>% as.data.frame()->var_corr_positiva
#Selección de variables con correlación negativa
data_parcial_2 %>%
dplyr::select(MORTINF,TASA_MOR) %>%
apply(MARGIN = 2,FUN = norm_inversa) %>% as.data.frame()->var_corr_negativa
#Union y reordenamiento de 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_normalizada
head(data_p2_normalizada)## 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 (de correlación)
library(PerformanceAnalytics)
chart.Correlation(as.matrix(data_p2_normalizada),histogram = TRUE,pch=12)
Pruebas de KMO y Barlett
#KMO
library(rela)
KMO<-paf(as.matrix(data_p2_normalizada))$KMO
print(KMO)## [1] 0.85275El valor mínimo de KMO para considerar aceptable el análisis factorial es de 0.5 y la batería de información tiene el 0.85275, por lo tal es apropiado continuar con el análisis.
#Prueba de Barlett
library(psych)
options(scipen = 99999)
Barlett<-cortest.bartlett(data_p2_normalizada)
print(Barlett)## $chisq
## [1] 1478.1
##
## $p.value
## [1] 0.000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000017846
##
## $df
## [1] 36El P-value es casi 0, quiere decir que no se rechaza la hipótesis alternativa, hay evidencia de correlación poblacional entre la batería de indicadores propuestas.
Analisis Factorial
library(FactoMineR)
library(factoextra)
library(kableExtra)
Rx<-cor(data_p2_normalizada)
PC<-princomp(x = data_p2_normalizada,cor = TRUE,fix_sign = FALSE)
variables_pca<-get_pca_var(PC)
factoextra::get_eig(PC) %>% kable(caption="Resumen sobre PCA",
align = "c",
digits = 2) %>%
kable_material_dark(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 |
Según esto se puede ver la cantidad de factores a retener: Por el criterio de raíz latente: tendríamos 2 componentes.
Por el criterio de porcentaje acumulado de la varianza: tedríamos DOS componentes ya que esas 2 son superior a las 3 cuartas partes de la varianza total.
Grafica de sedimentacion
fviz_eig(PC,
choice = "eigenvalue",
barcolor = "black",
barfill = "red",
addlabels = TRUE,
)+labs(title = "Grafico de Sedimentacion",subtitle = "Utilisando princomp, con autovalores")+
xlab(label = "Componentes")
ylab(label = "Autovalores")+geom_hline(yintercept = 1)## NULLPor este criterio se puede observar que el punto de quiebre ocurre en los primeros dos. Los criterios de extracción se mantienen en 2 factores.
SE DEBEN DE RETENER DOS FACTORES
B. ¿Qué variables quedan representadas en cada factor?
library(corrplot)
#modelo de 2 fatores
numero_de_factores<-2
modelo_factores<-principal(r = Rx,
nfactors = numero_de_factores,
covar = FALSE,
rotate = "varimax")
print(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.99Gráfico de aglomeracion de variables
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 = "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 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_dark(html_font = "sans-serif") %>%
kable_styling(bootstrap_options = c("hover"))| Dim.1 | Dim.2 |
|---|---|
| 0.72 | 0.28 |
Contribucion de las variables en los factores
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"))| 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 |
RESPUESTA: Al factor 1 debe asignarse el peso 0.72 y al factor 2 el peso 0.28. * ALFABET será al factor 1: 0.13 y al factor 2: 0.17 * INC_POB serán al F1: 0.25 y F2: 0 * ESPVIDAF serán al F1: 0.1 y F2: 0.38 * FERTILID serán al F1: 0.2 y F2: 0.11 * TASA_NAT serán al F1: 0.2 y F2 0.11 * LOG_PIB serán al F1: 0.1 y F2: 0.23
EJERCICIO 2 Indicaciones: 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. Para ellos se definieron 4 variables X1, X2, X3, X4, debera resolver lo siguiente:
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)
Metodo de Ranking por suma
library(magrittr)
#Jerarquia
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
#funcion de 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))
}
#aplicacionde funcion
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 de pesos normalisados por suma
barplot(
pesos_ranking_suma$w_normalizados,
main = "Ponderadores jerarquia de suma",
ylim = c(0, 0.5),
col = "brown"
)
Metodo de ranking reciprocos
#Jerarquia
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
#funcion de 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))
}
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 de jerarquia por reciprocos
barplot(
pesos_ranking_reciproco$w_normalizados,
main = "Ponderadores Ranking Reciproco",
ylim = c(0, 0.5),
col = "brown"
)
Metodo de ranking exponencial
#Jerarquia
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
#funcion de 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))
}
#aplicacion de funcion
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 ranking exponencial
barplot(pesos_ranking_exponencial$w_normalizados,
main = "Ponderadores Ranking Exponencial",
ylim = c(0,0.8),col = "green")
2. Usando la técnica de comparación por pares, calcule los pesos normalizados para las variables:
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#Gráfico
barplot(pesos_normalizados_1@weights,
main = "Ponderadores por metodo comparacion de pares",
ylim = c(0,0.7),col = "red")
#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#Gráfico
barplot(pesos_normalizados_2@weights,
main = "Ponderadores por metodo comparacion 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#Gráfico
barplot(pesos_normalizados_3@weights,
main = "Ponderadores por metodo comparacion de pares",
ylim = c(0,0.7),col = "yellow")
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.075207sum(promedio_tot)## [1] 1#ponderacion 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.0752072.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.074838sum(ponderacion_expertos_distintas)## [1] 1#pondedracioones de expertos normalizadas (distintas)
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