EJERCICIO PRACTICO UNIDAD 2 CLAVE B
Luis David Castro Martinez
2022-10-25
#Seccion I #Indicador multivariado sintético sobre el Desarrollo en las Economías
load("C:/Users/Familia/Downloads/data_parcial_2_B_rev.RData")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))}
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_claveB
VAR_CORRELACION_POSITIVAS<-select(data_parcial_2_claveB,ALFABET,INC_POB,ESPVIDAF,FERTILID,TASA_NAT,LOG_PIB,URBANA) %>% apply(MARGIN = 2,FUN = norm_directa) %>% as.data.frame()
VAR_CORRELACION_NEGATIVAS<-select(data_parcial_2_claveB,MORTINF,TASA_MOR) %>% apply(MARGIN = 2,FUN = norm_inversa) %>% as.data.frame()
VAR_CORRELACION_POSITIVAS %>%
bind_cols(VAR_CORRELACION_NEGATIVAS) %>%
select(ALFABET, INC_POB, ESPVIDAF, FERTILID, TASA_NAT, LOG_PIB,
URBANA,MORTINF,TASA_MOR)->datos_indicador_deseco_normalizado
head(datos_indicador_deseco_normalizado)## 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 Correlacion.
library(PerformanceAnalytics)
chart.Correlation(as.matrix(datos_indicador_deseco_normalizado),histogram = TRUE,pch=12)
#Prueba de Bartlett.
library(psych)
options(scipen = 99999)
analisis_multicol<-cortest.bartlett(datos_indicador_deseco_normalizado)
print(analisis_multicol)## $chisq
## [1] 1478.145
##
## $p.value
## [1] 0.00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001784625
##
## $df
## [1] 36#Analisis Factorial.
library(FactoMineR)
library(factoextra)
library(kableExtra)
Rx_B<-cor(datos_indicador_deseco_normalizado)
PC_B<-princomp(x = datos_indicador_deseco_normalizado ,cor = TRUE,fix_sign = FALSE)
variables_pca_B<-get_pca_var(PC_B)
factoextra::get_eig(PC_B) %>% 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 |
#Grafico de Sedimentacion.
fviz_eig(PC_B,
choice = "eigenvalue",
barcolor = "yellow",
barfill = "skyblue",
addlabels = TRUE,
)+labs(title = "Gráfico de Sedimentación",subtitle = "Usando princomp, con Autovalores")+
xlab(label = "Componentes")+
ylab(label = "Autovalores")+geom_hline(yintercept = 1)
#Al hacer uso del analisis factorial y visualizado a travez del grafico
de sedimentacion los factores que deberian retenerse tienen que ser 2 ya
que en su conjunto contienen o explican el 85.44% de la varianza
acumulada.
#Modelo de 2 factores (Varimax).
library(corrplot)
numero_de_factores_B<-2
modelo_2factores_rotacion<-principal(r = Rx_B,
nfactors = numero_de_factores_B,
covar = FALSE,
rotate = "varimax")
print(modelo_2factores_rotacion)## Principal Components Analysis
## Call: principal(r = Rx_B, nfactors = numero_de_factores_B, 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#Grafico de correlaciones.
correlaciones_modelo_B<-variables_pca_B$coord
rotacion_B<-varimax(correlaciones_modelo_B[,1:numero_de_factores_B])
correlaciones_modelo_rotada_B<-rotacion_B$loadings
corrplot(correlaciones_modelo_rotada_B[,1:numero_de_factores_B],
is.corr = FALSE,
method = "circle",
addCoef.col="black",
number.cex = 0.75)
#Al hacer uso de la rotacion “Varimax” las variables quedan
representadas en los factores del siguiente modo: Factor
1[ALFABET,INC_POB,FERTILID,TASA_NAT.LOG_PIB] Factor 2[ESPVIDAF, URBANA,
MORTINF,TASA_MOR]
Pese a que LOG_PIB no cumple el criterio de representacion en ambos factores queda mejor representada en el factor 1.
#Ponderadores para cada factor.
library(kableExtra)
cargas_B<-rotacion_B$loadings[1:9,1:numero_de_factores_B]
ponderadores_B<-prop.table(apply(cargas_B^2,MARGIN = 2,sum))
t(ponderadores_B) %>% 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.57 | 0.43 |
#Contribucion de pesos en cada factor y las variables en cada factores.
contribuciones_B<-apply(cargas_B^2,MARGIN = 2,prop.table)
contribuciones_B %>% 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.11 | 0.08 |
| INC_POB | 0.22 | 0.00 |
| ESPVIDAF | 0.09 | 0.17 |
| FERTILID | 0.17 | 0.05 |
| TASA_NAT | 0.19 | 0.05 |
| LOG_PIB | 0.09 | 0.10 |
| URBANA | 0.04 | 0.15 |
| MORTINF | 0.10 | 0.15 |
| TASA_MOR | 0.00 | 0.25 |
##Seccion II #Ejercicio 1. Indicador del desempeño de líneas de producción.
#Jerarquia de suma
#Creacion de jerarquias, funcion de pesos y pesos brutos.
library(magrittr)
# Creacion del vector de Jerarquías
ranking_variables_claveB<-c(3,4,2,1)
names(ranking_variables_claveB)<-c("X1","X2","X3","X4")
# Creacion de función para generar los pesos
ponderadores_ranking_suma<-function(vector_jerarquias){
n<-length(vector_jerarquias)
vector_pesos_claveB<-n-vector_jerarquias+1
list(w_brutos=vector_pesos_claveB,w_normalizados=
vector_pesos_claveB/sum(vector_pesos_claveB))
}
pesos_ranking_claveB<-ponderadores_ranking_suma(ranking_variables_claveB)
pesos_ranking_claveB$w_brutos## X1 X2 X3 X4
## 2 1 3 4#Pesos normalizados.
pesos_ranking_claveB$w_normalizados %>% round(digits = 3)## X1 X2 X3 X4
## 0.2 0.1 0.3 0.4#Grafico pesos normalizados (suma).
barplot(pesos_ranking_claveB$w_normalizados,
main = "Ponderadores Ranking de Suma",
ylim = c(0,0.5),col = rgb(red =0.2,green = 1,blue = 1))
#Jerarquia reciproca #Funcion de pesos y pesos brutos.
#Creacion de función para generar los pesos
ponderadores_ranking_reciproco<-function(vector_jerarquias){
vector_pesos_reciprocoB<-1/vector_jerarquias
list(w_brutos=vector_pesos_reciprocoB,w_normalizados=
vector_pesos_reciprocoB/sum(vector_pesos_reciprocoB))
}
pesos_ranking_reciprocoB<-ponderadores_ranking_reciproco(
ranking_variables_claveB)
pesos_ranking_reciprocoB$w_brutos## X1 X2 X3 X4
## 0.3333333 0.2500000 0.5000000 1.0000000#Pesos normalizados
pesos_ranking_reciprocoB$w_normalizados %>% round(digits = 3)## X1 X2 X3 X4
## 0.16 0.12 0.24 0.48#Grafico pesos normalizados (reciproco).
#Gráfico de los pesos normalizados
barplot(pesos_ranking_reciprocoB$w_normalizados,
main = "Ponderadores Ranking Recíproco",
ylim = c(0,0.6),col = rgb(red =1,green = 0.6,blue = 0.6))
#Jerarquia Exponencial #funcion de pesos y pesos brutos
#Creacion de función para generar los pesos
ponderadores_ranking_exponencial<-function(vector_jerarquias,p=4){
n<-length(vector_jerarquias)
vector_pesos_exponencialB<-(n-vector_jerarquias+1)^p
list(w_brutos=vector_pesos_exponencialB,w_normalizados=
vector_pesos_exponencialB/sum(vector_pesos_exponencialB))
}
pesos_ranking_exponencialB<-ponderadores_ranking_exponencial(
ranking_variables_claveB)
pesos_ranking_exponencialB$w_brutos## X1 X2 X3 X4
## 16 1 81 256#Pesos normalizados.
pesos_ranking_exponencialB$w_normalizados %>% round(digits = 3)## X1 X2 X3 X4
## 0.045 0.003 0.229 0.723#Grafico pesos normalizados (exponencial).
#p=4
barplot(pesos_ranking_exponencialB$w_normalizados,
main = "Ponderadores Ranking Exponencial",
ylim = c(0,0.8),col = rgb(red =0.4,green = 1,blue = 0))
ejercicio 2. Tecnica de comparacion por pares.
#Datos del primer experto.
library(FuzzyAHP)
datos_matriz_comparacion_experto1 = c(1,7,4,5,
NA,1,6,3,
NA,NA,1,2,
NA,NA,NA,1)
matriz_comparacion_experto1<-matrix(datos_matriz_comparacion_experto1,
nrow = 4, ncol = 4, byrow = TRUE)
matriz_comparacion_experto1<-pairwiseComparisonMatrix(
matriz_comparacion_experto1)
matriz_comparacion_experto1@variableNames<-c("X1","X2","X3","X4")
show(matriz_comparacion_experto1)## 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.0000000 7.0000000 4.0 5
## [2,] 0.1428571 1.0000000 6.0 3
## [3,] 0.2500000 0.1666667 1.0 2
## [4,] 0.2000000 0.3333333 0.5 1
##
## Slot "variableNames":
## [1] "X1" "X2" "X3" "X4"#Calculo de pesos.
pesos_normalizados_experto1 = calculateWeights(matriz_comparacion_experto1)
show(pesos_normalizados_experto1)## An object of class "Weights"
## Slot "weights":
## w_X1 w_X2 w_X3 w_X4
## 0.60659194 0.22331004 0.09474784 0.07535018#Grafica de ponderacion (experto 1).
barplot(pesos_normalizados_experto1@weights,
main = "Ponderadores por método comparación de pares",
ylim = c(0,0.7),col = "pink")
#Datos del segundo experto.
datos_matriz_comparacion_experto2 = c(1,7,6,3,
NA,1,5,2,
NA,NA,1,4,
NA,NA,NA,1)
matriz_comparacion_experto2<-matrix(datos_matriz_comparacion_experto2,
nrow = 4, ncol = 4, byrow = TRUE)
matriz_comparacion_experto2<-pairwiseComparisonMatrix(
matriz_comparacion_experto2)
matriz_comparacion_experto2@variableNames<-c("X1","X2","X3","X4")
show(matriz_comparacion_experto2)## 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.0000000 7.0 6.00 3
## [2,] 0.1428571 1.0 5.00 2
## [3,] 0.1666667 0.2 1.00 4
## [4,] 0.3333333 0.5 0.25 1
##
## Slot "variableNames":
## [1] "X1" "X2" "X3" "X4"#Calculo de pesos.
pesos_normalizados_experto2 = calculateWeights(matriz_comparacion_experto2)
show(pesos_normalizados_experto2)## An object of class "Weights"
## Slot "weights":
## w_X1 w_X2 w_X3 w_X4
## 0.60919010 0.19878595 0.10987399 0.08214997#Grafico de ponderacion (experto 2).
barplot(pesos_normalizados_experto2@weights,
main = "Ponderadores por método comparación de pares",
ylim = c(0,0.7),col = "orange")
#Datos del tercer experto.
datos_matriz_comparacion_experto3 = c(1,7,5,4,
NA,1,3,2,
NA,NA,1,6,
NA,NA,NA,1)
matriz_comparacion_experto3<-matrix(datos_matriz_comparacion_experto3,
nrow = 4, ncol = 4, byrow = TRUE)
matriz_comparacion_experto3<-pairwiseComparisonMatrix(
matriz_comparacion_experto3)
matriz_comparacion_experto3@variableNames<-c("X1","X2","X3","X4")
show(matriz_comparacion_experto3)## 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.0000000 7.0000000 5.0000000 4
## [2,] 0.1428571 1.0000000 3.0000000 2
## [3,] 0.2000000 0.3333333 1.0000000 6
## [4,] 0.2500000 0.5000000 0.1666667 1
##
## Slot "variableNames":
## [1] "X1" "X2" "X3" "X4"#Calculo de pesos.
pesos_normalizados_experto3 = calculateWeights(matriz_comparacion_experto3)
show(pesos_normalizados_experto3)## An object of class "Weights"
## Slot "weights":
## w_X1 w_X2 w_X3 w_X4
## 0.61676222 0.17252382 0.14259384 0.06812013#Grafico de ponderacion (experto 3).
barplot(pesos_normalizados_experto3@weights,
main = "Ponderadores por método comparación de pares",
ylim = c(0,0.7),col = "purple")
2.1 Asumiendo que la opinión de los 3 expertos es igualmente válida.
#Creacion de los pesos totales normalizado y su promedio normalizado
library(kableExtra)
validez_opinion_expertos <-1/3
pesos_totales_claveB<-(pesos_normalizados_experto1@weights+
pesos_normalizados_experto2@weights+
pesos_normalizados_experto3@weights)
promedio_total_claveB<-validez_opinion_expertos*pesos_totales_claveB
show(promedio_total_claveB)## w_X1 w_X2 w_X3 w_X4
## 0.61084809 0.19820660 0.11573855 0.07520676#Sumatoria de ponderaciones
sum(promedio_total_claveB)## [1] 12.2 Si el experto 1 se pondera con 0.25, el experto 2 con 0.35 y el experto 3 con 0.40.
#Creacion de ponderaciones de distintos pesos normalizada.
opinion_pesos_distintas<-(pesos_normalizados_experto1@weights*0.25)+
(pesos_normalizados_experto2@weights*0.35)+
(pesos_normalizados_experto3@weights*0.40)
show(opinion_pesos_distintas)## w_X1 w_X2 w_X3 w_X4
## 0.61156941 0.19441212 0.11918039 0.07483808#Sumatoria de ponderaciones.
sum(opinion_pesos_distintas)## [1] 1