Examen Parcial 2
ALAN ERNESTO HERNANDEZ ROMERO - HR15033 - 27/10/2021.
27/10/2021
UNIVERSIDAD DE EL SALVADOR
FACULTAD DE CIENCIAS ECONÓMICAS
ESCUELA DE ECONOMÍA
METODOS PARA EL ANALISIS ECONOMICO
“EXAMEN PARCIAL 2”
ALUMNO:
HERNANDEZ ROMERO, ALAN ERNESTO HR15033
MSF. CARLOS ADEMIR PÉREZ ALAS
CIUDAD UNIVERSITARIA, OCTUBRE DE 2021
Indicador multivariado sintético sobre el Desarrollo en las Economías.
library(readr)
library(dplyr)
library(kableExtra)
load("C:/Parcial 2/data_parcial_2_B.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
data_parcial_2 %>%
select(ALFABET, INC_POB, ESPVIDAF, FERTILID, TASA_NAT, LOG_PIB, URBANA) %>%
apply(MARGIN = 2, FUN = norm_directa) %>% as.data.frame() -> var_corr_positiva
data_parcial_2 %>%
select(MORTINF, TASA_MOR) %>%
apply(MARGIN = 2, FUN = norm_inversa) %>% as.data.frame() -> var_corr_negativa
var_corr_positiva %>%
bind_cols(var_corr_negativa) %>%
select(ALFABET,
INC_POB,
ESPVIDAF,
FERTILID,
TASA_NAT,
LOG_PIB,
URBANA,
MORTINF,
TASA_MOR) -> data_parcial2_norm
head(data_parcial2_norm)
## 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(data_parcial2_norm),
histogram = TRUE,
pch = 12)
Prueba KMO
library(rela)
KMO <- paf(as.matrix(data_parcial2_norm))$KMO
print(KMO)
## [1] 0.85275
El valor minimo para considerar aceptable el analisis factorial es de 0.5, nuestra informacion tiene 0.85. Es adecuado.
Prueba Barlett
library(psych)
Barlett <- cortest.bartlett(data_parcial2_norm)
print(Barlett)
## $chisq
## [1] 1478.1
##
## $p.value
## [1] 1.7846e-287
##
## $df
## [1] 36
Existe correlacion entre ellas, Pvalue pequeño, se rechaza la H0, hay evidencia entre correlacion entre la bateria de indicadores. Procedemos a pasar al analisis factorial
Analisis factorial
library(FactoMineR)
library(factoextra)
library(kableExtra)
Rx <- cor(data_parcial2_norm)
PC <- princomp(x = data_parcial2_norm, 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_dark(html_font = "sans-serif") %>%
kable_styling(bootstrap_options = c("hover"))
Resumen 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 sedimentacion
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)
El grafico de sedimentacion nos ayuda a determinar el criterio de raiz latente, se extraen los primeros 2 componentes, superior al 75%
Rotacion
library(corrplot)
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.99
Representacion factor 1: ALFABET, INC_POB, FERTILID, TASA_NAT Y LOG_PIB Representacion factor 2: ESPVIDAF, URBANA, MORTINF Y TASA_MOR
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
)
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("striped", "hover"))
Ponderadores de los Factores Extraídos
Dim.1
Dim.2
0.72
0.28
Contribucion 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_dark(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
Metodos subjetivos de ponderacion.
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:
Jerarquia Suma
library(magrittr)
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
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))
}
pesos_ranking_suma <- ponderadores_subjetivos_rank_suma(rj)
pesos_ranking_suma$w_brutos
## X1 X2 X3 X4
## 2 1 3 4
pesos_ranking_suma$w_normalizados %>% round(digits = 3)
## X1 X2 X3 X4
## 0.2 0.1 0.3 0.4
Grafico de pesos normalizados
barplot(
pesos_ranking_suma$w_normalizados,
main = "Ponderadores jerarquia de suma",
ylim = c(0, 0.5),
col = "red"
)
Jerarquia Reciprocos
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
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_ranking_reciproco$w_brutos
## X1 X2 X3 X4
## 0.33333 0.25000 0.50000 1.00000
pesos_ranking_reciproco$w_normalizados %>% round(digits = 3)
## X1 X2 X3 X4
## 0.16 0.12 0.24 0.48
Grafico de pesos normalizados
barplot(
pesos_ranking_reciproco$w_normalizados,
main = "Ponderadores Ranking Recíproco",
ylim = c(0, 0.5),
col = "brown"
)
Jerarquia exponencial
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
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))
}
pesos_ranking_exponencial <-
ponderadores_subjetivos_rank_exponencial(rj)
pesos_ranking_exponencial$w_brutos
## X1 X2 X3 X4
## 16 1 81 256
pesos_ranking_exponencial$w_normalizados %>% round(digits = 3)
## X1 X2 X3 X4
## 0.045 0.003 0.229 0.723
Grafico de pesos normalizados
barplot(pesos_ranking_exponencial$w_normalizados,
main = "Ponderadores Ranking Exponencial",
ylim = c(0,0.8),col = "Blue")
Usando la técnica de comparación por pares, calcule los pesos normalizados para las variables:
library(FuzzyAHP)
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"
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 método comparación de pares",
ylim = c(0, 0.7),
col = "green"
)
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"
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 = "gray"
)
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"
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
barplot(pesos_normalizados_3@weights,
main = "Ponderadores por método comparación de pares",
ylim = c(0,0.7),col = "white")
library(kableExtra)
ponderacion_expertos <-1/3
pesos_tot<-(pesos_normalizados@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.075207
sum(promedio_tot)
## [1] 1
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.075207
ponderacion_expertos_distintas<-(pesos_normalizados@weights*0.4)+(pesos_normalizados_2@weights*0.4)+(pesos_normalizados_3@weights*0.2)
show(ponderacion_expertos_distintas)
## w_X1 w_X2 w_X3 w_X4
## 0.609665 0.203343 0.110367 0.076624
sum(ponderacion_expertos_distintas)
## [1] 1
normalizacion_2<-ponderacion_expertos_distintas/sum(ponderacion_expertos_distintas)
show(normalizacion_2)
## w_X1 w_X2 w_X3 w_X4
## 0.609665 0.203343 0.110367 0.076624
UNIVERSIDAD DE EL SALVADOR
FACULTAD DE CIENCIAS ECONÓMICAS
ESCUELA DE ECONOMÍA
METODOS PARA EL ANALISIS ECONOMICO
“EXAMEN PARCIAL 2”
ALUMNO:
HERNANDEZ ROMERO, ALAN ERNESTO HR15033
MSF. CARLOS ADEMIR PÉREZ ALAS
CIUDAD UNIVERSITARIA, OCTUBRE DE 2021
Indicador multivariado sintético sobre el Desarrollo en las Economías.
library(readr)
library(dplyr)
library(kableExtra)
load("C:/Parcial 2/data_parcial_2_B.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
data_parcial_2 %>%
select(ALFABET, INC_POB, ESPVIDAF, FERTILID, TASA_NAT, LOG_PIB, URBANA) %>%
apply(MARGIN = 2, FUN = norm_directa) %>% as.data.frame() -> var_corr_positiva
data_parcial_2 %>%
select(MORTINF, TASA_MOR) %>%
apply(MARGIN = 2, FUN = norm_inversa) %>% as.data.frame() -> var_corr_negativa
var_corr_positiva %>%
bind_cols(var_corr_negativa) %>%
select(ALFABET,
INC_POB,
ESPVIDAF,
FERTILID,
TASA_NAT,
LOG_PIB,
URBANA,
MORTINF,
TASA_MOR) -> data_parcial2_norm
head(data_parcial2_norm)
## 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(data_parcial2_norm),
histogram = TRUE,
pch = 12)
Prueba KMO
library(rela)
KMO <- paf(as.matrix(data_parcial2_norm))$KMO
print(KMO)
## [1] 0.85275
El valor minimo para considerar aceptable el analisis factorial es de 0.5, nuestra informacion tiene 0.85. Es adecuado.
Prueba Barlett
library(psych)
Barlett <- cortest.bartlett(data_parcial2_norm)
print(Barlett)
## $chisq
## [1] 1478.1
##
## $p.value
## [1] 1.7846e-287
##
## $df
## [1] 36
Existe correlacion entre ellas, Pvalue pequeño, se rechaza la H0, hay evidencia entre correlacion entre la bateria de indicadores. Procedemos a pasar al analisis factorial
Analisis factorial
library(FactoMineR)
library(factoextra)
library(kableExtra)
Rx <- cor(data_parcial2_norm)
PC <- princomp(x = data_parcial2_norm, 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_dark(html_font = "sans-serif") %>%
kable_styling(bootstrap_options = c("hover"))
Resumen 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 sedimentacion
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)
El grafico de sedimentacion nos ayuda a determinar el criterio de raiz latente, se extraen los primeros 2 componentes, superior al 75%
Rotacion
library(corrplot)
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.99
Representacion factor 1: ALFABET, INC_POB, FERTILID, TASA_NAT Y LOG_PIB Representacion factor 2: ESPVIDAF, URBANA, MORTINF Y TASA_MOR
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
)
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("striped", "hover"))
Ponderadores de los Factores Extraídos
Dim.1
Dim.2
0.72
0.28
Contribucion 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_dark(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
Metodos subjetivos de ponderacion.
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:
Jerarquia Suma
library(magrittr)
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
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))
}
pesos_ranking_suma <- ponderadores_subjetivos_rank_suma(rj)
pesos_ranking_suma$w_brutos
## X1 X2 X3 X4
## 2 1 3 4
pesos_ranking_suma$w_normalizados %>% round(digits = 3)
## X1 X2 X3 X4
## 0.2 0.1 0.3 0.4
Grafico de pesos normalizados
barplot(
pesos_ranking_suma$w_normalizados,
main = "Ponderadores jerarquia de suma",
ylim = c(0, 0.5),
col = "red"
)
Jerarquia Reciprocos
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
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_ranking_reciproco$w_brutos
## X1 X2 X3 X4
## 0.33333 0.25000 0.50000 1.00000
pesos_ranking_reciproco$w_normalizados %>% round(digits = 3)
## X1 X2 X3 X4
## 0.16 0.12 0.24 0.48
Grafico de pesos normalizados
barplot(
pesos_ranking_reciproco$w_normalizados,
main = "Ponderadores Ranking Recíproco",
ylim = c(0, 0.5),
col = "brown"
)
Jerarquia exponencial
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
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))
}
pesos_ranking_exponencial <-
ponderadores_subjetivos_rank_exponencial(rj)
pesos_ranking_exponencial$w_brutos
## X1 X2 X3 X4
## 16 1 81 256
pesos_ranking_exponencial$w_normalizados %>% round(digits = 3)
## X1 X2 X3 X4
## 0.045 0.003 0.229 0.723
Grafico de pesos normalizados
barplot(pesos_ranking_exponencial$w_normalizados,
main = "Ponderadores Ranking Exponencial",
ylim = c(0,0.8),col = "Blue")
Usando la técnica de comparación por pares, calcule los pesos normalizados para las variables:
library(FuzzyAHP)
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"
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 método comparación de pares",
ylim = c(0, 0.7),
col = "green"
)
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"
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 = "gray"
)
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"
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
barplot(pesos_normalizados_3@weights,
main = "Ponderadores por método comparación de pares",
ylim = c(0,0.7),col = "white")
library(kableExtra)
ponderacion_expertos <-1/3
pesos_tot<-(pesos_normalizados@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.075207
sum(promedio_tot)
## [1] 1
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.075207
ponderacion_expertos_distintas<-(pesos_normalizados@weights*0.4)+(pesos_normalizados_2@weights*0.4)+(pesos_normalizados_3@weights*0.2)
show(ponderacion_expertos_distintas)
## w_X1 w_X2 w_X3 w_X4
## 0.609665 0.203343 0.110367 0.076624
sum(ponderacion_expertos_distintas)
## [1] 1
normalizacion_2<-ponderacion_expertos_distintas/sum(ponderacion_expertos_distintas)
show(normalizacion_2)
## w_X1 w_X2 w_X3 w_X4
## 0.609665 0.203343 0.110367 0.076624
“EXAMEN PARCIAL 2”
ALUMNO:
HERNANDEZ ROMERO, ALAN ERNESTO HR15033
MSF. CARLOS ADEMIR PÉREZ ALAS
CIUDAD UNIVERSITARIA, OCTUBRE DE 2021
Indicador multivariado sintético sobre el Desarrollo en las Economías.
library(readr)
library(dplyr)
library(kableExtra)
load("C:/Parcial 2/data_parcial_2_B.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
data_parcial_2 %>%
select(ALFABET, INC_POB, ESPVIDAF, FERTILID, TASA_NAT, LOG_PIB, URBANA) %>%
apply(MARGIN = 2, FUN = norm_directa) %>% as.data.frame() -> var_corr_positiva
data_parcial_2 %>%
select(MORTINF, TASA_MOR) %>%
apply(MARGIN = 2, FUN = norm_inversa) %>% as.data.frame() -> var_corr_negativa
var_corr_positiva %>%
bind_cols(var_corr_negativa) %>%
select(ALFABET,
INC_POB,
ESPVIDAF,
FERTILID,
TASA_NAT,
LOG_PIB,
URBANA,
MORTINF,
TASA_MOR) -> data_parcial2_norm
head(data_parcial2_norm)
## 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(data_parcial2_norm),
histogram = TRUE,
pch = 12)
Prueba KMO
library(rela)
KMO <- paf(as.matrix(data_parcial2_norm))$KMO
print(KMO)
## [1] 0.85275
El valor minimo para considerar aceptable el analisis factorial es de 0.5, nuestra informacion tiene 0.85. Es adecuado.
Prueba Barlett
library(psych)
Barlett <- cortest.bartlett(data_parcial2_norm)
print(Barlett)
## $chisq
## [1] 1478.1
##
## $p.value
## [1] 1.7846e-287
##
## $df
## [1] 36
Existe correlacion entre ellas, Pvalue pequeño, se rechaza la H0, hay evidencia entre correlacion entre la bateria de indicadores. Procedemos a pasar al analisis factorial
Analisis factorial
library(FactoMineR)
library(factoextra)
library(kableExtra)
Rx <- cor(data_parcial2_norm)
PC <- princomp(x = data_parcial2_norm, 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_dark(html_font = "sans-serif") %>%
kable_styling(bootstrap_options = c("hover"))
Resumen 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 sedimentacion
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)
El grafico de sedimentacion nos ayuda a determinar el criterio de raiz latente, se extraen los primeros 2 componentes, superior al 75%
Rotacion
library(corrplot)
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.99
Representacion factor 1: ALFABET, INC_POB, FERTILID, TASA_NAT Y LOG_PIB Representacion factor 2: ESPVIDAF, URBANA, MORTINF Y TASA_MOR
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
)
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("striped", "hover"))
Ponderadores de los Factores Extraídos
Dim.1
Dim.2
0.72
0.28
Contribucion 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_dark(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
Metodos subjetivos de ponderacion.
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:
Jerarquia Suma
library(magrittr)
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
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))
}
pesos_ranking_suma <- ponderadores_subjetivos_rank_suma(rj)
pesos_ranking_suma$w_brutos
## X1 X2 X3 X4
## 2 1 3 4
pesos_ranking_suma$w_normalizados %>% round(digits = 3)
## X1 X2 X3 X4
## 0.2 0.1 0.3 0.4
Grafico de pesos normalizados
barplot(
pesos_ranking_suma$w_normalizados,
main = "Ponderadores jerarquia de suma",
ylim = c(0, 0.5),
col = "red"
)
Jerarquia Reciprocos
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
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_ranking_reciproco$w_brutos
## X1 X2 X3 X4
## 0.33333 0.25000 0.50000 1.00000
pesos_ranking_reciproco$w_normalizados %>% round(digits = 3)
## X1 X2 X3 X4
## 0.16 0.12 0.24 0.48
Grafico de pesos normalizados
barplot(
pesos_ranking_reciproco$w_normalizados,
main = "Ponderadores Ranking Recíproco",
ylim = c(0, 0.5),
col = "brown"
)
Jerarquia exponencial
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
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))
}
pesos_ranking_exponencial <-
ponderadores_subjetivos_rank_exponencial(rj)
pesos_ranking_exponencial$w_brutos
## X1 X2 X3 X4
## 16 1 81 256
pesos_ranking_exponencial$w_normalizados %>% round(digits = 3)
## X1 X2 X3 X4
## 0.045 0.003 0.229 0.723
Grafico de pesos normalizados
barplot(pesos_ranking_exponencial$w_normalizados,
main = "Ponderadores Ranking Exponencial",
ylim = c(0,0.8),col = "Blue")
Usando la técnica de comparación por pares, calcule los pesos normalizados para las variables:
library(FuzzyAHP)
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"
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 método comparación de pares",
ylim = c(0, 0.7),
col = "green"
)
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"
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 = "gray"
)
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"
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
barplot(pesos_normalizados_3@weights,
main = "Ponderadores por método comparación de pares",
ylim = c(0,0.7),col = "white")
library(kableExtra)
ponderacion_expertos <-1/3
pesos_tot<-(pesos_normalizados@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.075207
sum(promedio_tot)
## [1] 1
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.075207
ponderacion_expertos_distintas<-(pesos_normalizados@weights*0.4)+(pesos_normalizados_2@weights*0.4)+(pesos_normalizados_3@weights*0.2)
show(ponderacion_expertos_distintas)
## w_X1 w_X2 w_X3 w_X4
## 0.609665 0.203343 0.110367 0.076624
sum(ponderacion_expertos_distintas)
## [1] 1
normalizacion_2<-ponderacion_expertos_distintas/sum(ponderacion_expertos_distintas)
show(normalizacion_2)
## w_X1 w_X2 w_X3 w_X4
## 0.609665 0.203343 0.110367 0.076624
ALUMNO:
HERNANDEZ ROMERO, ALAN ERNESTO HR15033
MSF. CARLOS ADEMIR PÉREZ ALAS
CIUDAD UNIVERSITARIA, OCTUBRE DE 2021
Indicador multivariado sintético sobre el Desarrollo en las Economías.
library(readr)
library(dplyr)
library(kableExtra)
load("C:/Parcial 2/data_parcial_2_B.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
data_parcial_2 %>%
select(ALFABET, INC_POB, ESPVIDAF, FERTILID, TASA_NAT, LOG_PIB, URBANA) %>%
apply(MARGIN = 2, FUN = norm_directa) %>% as.data.frame() -> var_corr_positiva
data_parcial_2 %>%
select(MORTINF, TASA_MOR) %>%
apply(MARGIN = 2, FUN = norm_inversa) %>% as.data.frame() -> var_corr_negativa
var_corr_positiva %>%
bind_cols(var_corr_negativa) %>%
select(ALFABET,
INC_POB,
ESPVIDAF,
FERTILID,
TASA_NAT,
LOG_PIB,
URBANA,
MORTINF,
TASA_MOR) -> data_parcial2_norm
head(data_parcial2_norm)
## 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(data_parcial2_norm),
histogram = TRUE,
pch = 12)
Prueba KMO
library(rela)
KMO <- paf(as.matrix(data_parcial2_norm))$KMO
print(KMO)
## [1] 0.85275
El valor minimo para considerar aceptable el analisis factorial es de 0.5, nuestra informacion tiene 0.85. Es adecuado.
Prueba Barlett
library(psych)
Barlett <- cortest.bartlett(data_parcial2_norm)
print(Barlett)
## $chisq
## [1] 1478.1
##
## $p.value
## [1] 1.7846e-287
##
## $df
## [1] 36
Existe correlacion entre ellas, Pvalue pequeño, se rechaza la H0, hay evidencia entre correlacion entre la bateria de indicadores. Procedemos a pasar al analisis factorial
Analisis factorial
library(FactoMineR)
library(factoextra)
library(kableExtra)
Rx <- cor(data_parcial2_norm)
PC <- princomp(x = data_parcial2_norm, 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_dark(html_font = "sans-serif") %>%
kable_styling(bootstrap_options = c("hover"))
Resumen 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 sedimentacion
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)
El grafico de sedimentacion nos ayuda a determinar el criterio de raiz latente, se extraen los primeros 2 componentes, superior al 75%
Rotacion
library(corrplot)
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.99
Representacion factor 1: ALFABET, INC_POB, FERTILID, TASA_NAT Y LOG_PIB Representacion factor 2: ESPVIDAF, URBANA, MORTINF Y TASA_MOR
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
)
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("striped", "hover"))
Ponderadores de los Factores Extraídos
Dim.1
Dim.2
0.72
0.28
Contribucion 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_dark(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
Metodos subjetivos de ponderacion.
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:
Jerarquia Suma
library(magrittr)
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
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))
}
pesos_ranking_suma <- ponderadores_subjetivos_rank_suma(rj)
pesos_ranking_suma$w_brutos
## X1 X2 X3 X4
## 2 1 3 4
pesos_ranking_suma$w_normalizados %>% round(digits = 3)
## X1 X2 X3 X4
## 0.2 0.1 0.3 0.4
Grafico de pesos normalizados
barplot(
pesos_ranking_suma$w_normalizados,
main = "Ponderadores jerarquia de suma",
ylim = c(0, 0.5),
col = "red"
)
Jerarquia Reciprocos
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
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_ranking_reciproco$w_brutos
## X1 X2 X3 X4
## 0.33333 0.25000 0.50000 1.00000
pesos_ranking_reciproco$w_normalizados %>% round(digits = 3)
## X1 X2 X3 X4
## 0.16 0.12 0.24 0.48
Grafico de pesos normalizados
barplot(
pesos_ranking_reciproco$w_normalizados,
main = "Ponderadores Ranking Recíproco",
ylim = c(0, 0.5),
col = "brown"
)
Jerarquia exponencial
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
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))
}
pesos_ranking_exponencial <-
ponderadores_subjetivos_rank_exponencial(rj)
pesos_ranking_exponencial$w_brutos
## X1 X2 X3 X4
## 16 1 81 256
pesos_ranking_exponencial$w_normalizados %>% round(digits = 3)
## X1 X2 X3 X4
## 0.045 0.003 0.229 0.723
Grafico de pesos normalizados
barplot(pesos_ranking_exponencial$w_normalizados,
main = "Ponderadores Ranking Exponencial",
ylim = c(0,0.8),col = "Blue")
Usando la técnica de comparación por pares, calcule los pesos normalizados para las variables:
library(FuzzyAHP)
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"
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 método comparación de pares",
ylim = c(0, 0.7),
col = "green"
)
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"
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 = "gray"
)
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"
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
barplot(pesos_normalizados_3@weights,
main = "Ponderadores por método comparación de pares",
ylim = c(0,0.7),col = "white")
library(kableExtra)
ponderacion_expertos <-1/3
pesos_tot<-(pesos_normalizados@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.075207
sum(promedio_tot)
## [1] 1
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.075207
ponderacion_expertos_distintas<-(pesos_normalizados@weights*0.4)+(pesos_normalizados_2@weights*0.4)+(pesos_normalizados_3@weights*0.2)
show(ponderacion_expertos_distintas)
## w_X1 w_X2 w_X3 w_X4
## 0.609665 0.203343 0.110367 0.076624
sum(ponderacion_expertos_distintas)
## [1] 1
normalizacion_2<-ponderacion_expertos_distintas/sum(ponderacion_expertos_distintas)
show(normalizacion_2)
## w_X1 w_X2 w_X3 w_X4
## 0.609665 0.203343 0.110367 0.076624
MSF. CARLOS ADEMIR PÉREZ ALAS
CIUDAD UNIVERSITARIA, OCTUBRE DE 2021
Indicador multivariado sintético sobre el Desarrollo en las Economías.
library(readr)
library(dplyr)
library(kableExtra)
load("C:/Parcial 2/data_parcial_2_B.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
data_parcial_2 %>%
select(ALFABET, INC_POB, ESPVIDAF, FERTILID, TASA_NAT, LOG_PIB, URBANA) %>%
apply(MARGIN = 2, FUN = norm_directa) %>% as.data.frame() -> var_corr_positiva
data_parcial_2 %>%
select(MORTINF, TASA_MOR) %>%
apply(MARGIN = 2, FUN = norm_inversa) %>% as.data.frame() -> var_corr_negativa
var_corr_positiva %>%
bind_cols(var_corr_negativa) %>%
select(ALFABET,
INC_POB,
ESPVIDAF,
FERTILID,
TASA_NAT,
LOG_PIB,
URBANA,
MORTINF,
TASA_MOR) -> data_parcial2_norm
head(data_parcial2_norm)
## 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(data_parcial2_norm),
histogram = TRUE,
pch = 12)
Prueba KMO
library(rela)
KMO <- paf(as.matrix(data_parcial2_norm))$KMO
print(KMO)
## [1] 0.85275
El valor minimo para considerar aceptable el analisis factorial es de 0.5, nuestra informacion tiene 0.85. Es adecuado.
Prueba Barlett
library(psych)
Barlett <- cortest.bartlett(data_parcial2_norm)
print(Barlett)
## $chisq
## [1] 1478.1
##
## $p.value
## [1] 1.7846e-287
##
## $df
## [1] 36
Existe correlacion entre ellas, Pvalue pequeño, se rechaza la H0, hay evidencia entre correlacion entre la bateria de indicadores. Procedemos a pasar al analisis factorial
Analisis factorial
library(FactoMineR)
library(factoextra)
library(kableExtra)
Rx <- cor(data_parcial2_norm)
PC <- princomp(x = data_parcial2_norm, 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_dark(html_font = "sans-serif") %>%
kable_styling(bootstrap_options = c("hover"))
Resumen 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 sedimentacion
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)
El grafico de sedimentacion nos ayuda a determinar el criterio de raiz latente, se extraen los primeros 2 componentes, superior al 75%
Rotacion
library(corrplot)
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.99
Representacion factor 1: ALFABET, INC_POB, FERTILID, TASA_NAT Y LOG_PIB Representacion factor 2: ESPVIDAF, URBANA, MORTINF Y TASA_MOR
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
)
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("striped", "hover"))
Ponderadores de los Factores Extraídos
Dim.1
Dim.2
0.72
0.28
Contribucion 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_dark(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
Metodos subjetivos de ponderacion.
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:
Jerarquia Suma
library(magrittr)
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
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))
}
pesos_ranking_suma <- ponderadores_subjetivos_rank_suma(rj)
pesos_ranking_suma$w_brutos
## X1 X2 X3 X4
## 2 1 3 4
pesos_ranking_suma$w_normalizados %>% round(digits = 3)
## X1 X2 X3 X4
## 0.2 0.1 0.3 0.4
Grafico de pesos normalizados
barplot(
pesos_ranking_suma$w_normalizados,
main = "Ponderadores jerarquia de suma",
ylim = c(0, 0.5),
col = "red"
)
Jerarquia Reciprocos
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
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_ranking_reciproco$w_brutos
## X1 X2 X3 X4
## 0.33333 0.25000 0.50000 1.00000
pesos_ranking_reciproco$w_normalizados %>% round(digits = 3)
## X1 X2 X3 X4
## 0.16 0.12 0.24 0.48
Grafico de pesos normalizados
barplot(
pesos_ranking_reciproco$w_normalizados,
main = "Ponderadores Ranking Recíproco",
ylim = c(0, 0.5),
col = "brown"
)
Jerarquia exponencial
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
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))
}
pesos_ranking_exponencial <-
ponderadores_subjetivos_rank_exponencial(rj)
pesos_ranking_exponencial$w_brutos
## X1 X2 X3 X4
## 16 1 81 256
pesos_ranking_exponencial$w_normalizados %>% round(digits = 3)
## X1 X2 X3 X4
## 0.045 0.003 0.229 0.723
Grafico de pesos normalizados
barplot(pesos_ranking_exponencial$w_normalizados,
main = "Ponderadores Ranking Exponencial",
ylim = c(0,0.8),col = "Blue")
Usando la técnica de comparación por pares, calcule los pesos normalizados para las variables:
library(FuzzyAHP)
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"
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 método comparación de pares",
ylim = c(0, 0.7),
col = "green"
)
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"
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 = "gray"
)
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"
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
barplot(pesos_normalizados_3@weights,
main = "Ponderadores por método comparación de pares",
ylim = c(0,0.7),col = "white")
library(kableExtra)
ponderacion_expertos <-1/3
pesos_tot<-(pesos_normalizados@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.075207
sum(promedio_tot)
## [1] 1
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.075207
ponderacion_expertos_distintas<-(pesos_normalizados@weights*0.4)+(pesos_normalizados_2@weights*0.4)+(pesos_normalizados_3@weights*0.2)
show(ponderacion_expertos_distintas)
## w_X1 w_X2 w_X3 w_X4
## 0.609665 0.203343 0.110367 0.076624
sum(ponderacion_expertos_distintas)
## [1] 1
normalizacion_2<-ponderacion_expertos_distintas/sum(ponderacion_expertos_distintas)
show(normalizacion_2)
## w_X1 w_X2 w_X3 w_X4
## 0.609665 0.203343 0.110367 0.076624
CIUDAD UNIVERSITARIA, OCTUBRE DE 2021
Indicador multivariado sintético sobre el Desarrollo en las Economías.
library(readr)
library(dplyr)
library(kableExtra)
load("C:/Parcial 2/data_parcial_2_B.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
data_parcial_2 %>%
select(ALFABET, INC_POB, ESPVIDAF, FERTILID, TASA_NAT, LOG_PIB, URBANA) %>%
apply(MARGIN = 2, FUN = norm_directa) %>% as.data.frame() -> var_corr_positiva
data_parcial_2 %>%
select(MORTINF, TASA_MOR) %>%
apply(MARGIN = 2, FUN = norm_inversa) %>% as.data.frame() -> var_corr_negativa
var_corr_positiva %>%
bind_cols(var_corr_negativa) %>%
select(ALFABET,
INC_POB,
ESPVIDAF,
FERTILID,
TASA_NAT,
LOG_PIB,
URBANA,
MORTINF,
TASA_MOR) -> data_parcial2_norm
head(data_parcial2_norm)
## 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(data_parcial2_norm),
histogram = TRUE,
pch = 12)
Prueba KMO
library(rela)
KMO <- paf(as.matrix(data_parcial2_norm))$KMO
print(KMO)
## [1] 0.85275
El valor minimo para considerar aceptable el analisis factorial es de 0.5, nuestra informacion tiene 0.85. Es adecuado.
Prueba Barlett
library(psych)
Barlett <- cortest.bartlett(data_parcial2_norm)
print(Barlett)
## $chisq
## [1] 1478.1
##
## $p.value
## [1] 1.7846e-287
##
## $df
## [1] 36
Existe correlacion entre ellas, Pvalue pequeño, se rechaza la H0, hay evidencia entre correlacion entre la bateria de indicadores. Procedemos a pasar al analisis factorial
Analisis factorial
library(FactoMineR)
library(factoextra)
library(kableExtra)
Rx <- cor(data_parcial2_norm)
PC <- princomp(x = data_parcial2_norm, 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_dark(html_font = "sans-serif") %>%
kable_styling(bootstrap_options = c("hover"))
Resumen 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 sedimentacion
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)
El grafico de sedimentacion nos ayuda a determinar el criterio de raiz latente, se extraen los primeros 2 componentes, superior al 75%
Rotacion
library(corrplot)
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.99
Representacion factor 1: ALFABET, INC_POB, FERTILID, TASA_NAT Y LOG_PIB Representacion factor 2: ESPVIDAF, URBANA, MORTINF Y TASA_MOR
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
)
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("striped", "hover"))
Ponderadores de los Factores Extraídos
Dim.1
Dim.2
0.72
0.28
Contribucion 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_dark(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
Metodos subjetivos de ponderacion.
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:
Jerarquia Suma
library(magrittr)
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
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))
}
pesos_ranking_suma <- ponderadores_subjetivos_rank_suma(rj)
pesos_ranking_suma$w_brutos
## X1 X2 X3 X4
## 2 1 3 4
pesos_ranking_suma$w_normalizados %>% round(digits = 3)
## X1 X2 X3 X4
## 0.2 0.1 0.3 0.4
Grafico de pesos normalizados
barplot(
pesos_ranking_suma$w_normalizados,
main = "Ponderadores jerarquia de suma",
ylim = c(0, 0.5),
col = "red"
)
Jerarquia Reciprocos
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
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_ranking_reciproco$w_brutos
## X1 X2 X3 X4
## 0.33333 0.25000 0.50000 1.00000
pesos_ranking_reciproco$w_normalizados %>% round(digits = 3)
## X1 X2 X3 X4
## 0.16 0.12 0.24 0.48
Grafico de pesos normalizados
barplot(
pesos_ranking_reciproco$w_normalizados,
main = "Ponderadores Ranking Recíproco",
ylim = c(0, 0.5),
col = "brown"
)
Jerarquia exponencial
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
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))
}
pesos_ranking_exponencial <-
ponderadores_subjetivos_rank_exponencial(rj)
pesos_ranking_exponencial$w_brutos
## X1 X2 X3 X4
## 16 1 81 256
pesos_ranking_exponencial$w_normalizados %>% round(digits = 3)
## X1 X2 X3 X4
## 0.045 0.003 0.229 0.723
Grafico de pesos normalizados
barplot(pesos_ranking_exponencial$w_normalizados,
main = "Ponderadores Ranking Exponencial",
ylim = c(0,0.8),col = "Blue")
Usando la técnica de comparación por pares, calcule los pesos normalizados para las variables:
library(FuzzyAHP)
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"
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 método comparación de pares",
ylim = c(0, 0.7),
col = "green"
)
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"
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 = "gray"
)
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"
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
barplot(pesos_normalizados_3@weights,
main = "Ponderadores por método comparación de pares",
ylim = c(0,0.7),col = "white")
library(kableExtra)
ponderacion_expertos <-1/3
pesos_tot<-(pesos_normalizados@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.075207
sum(promedio_tot)
## [1] 1
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.075207
ponderacion_expertos_distintas<-(pesos_normalizados@weights*0.4)+(pesos_normalizados_2@weights*0.4)+(pesos_normalizados_3@weights*0.2)
show(ponderacion_expertos_distintas)
## w_X1 w_X2 w_X3 w_X4
## 0.609665 0.203343 0.110367 0.076624
sum(ponderacion_expertos_distintas)
## [1] 1
normalizacion_2<-ponderacion_expertos_distintas/sum(ponderacion_expertos_distintas)
show(normalizacion_2)
## w_X1 w_X2 w_X3 w_X4
## 0.609665 0.203343 0.110367 0.076624
Indicador multivariado sintético sobre el Desarrollo en las Economías.
library(readr)
library(dplyr)
library(kableExtra)
load("C:/Parcial 2/data_parcial_2_B.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
data_parcial_2 %>%
select(ALFABET, INC_POB, ESPVIDAF, FERTILID, TASA_NAT, LOG_PIB, URBANA) %>%
apply(MARGIN = 2, FUN = norm_directa) %>% as.data.frame() -> var_corr_positiva
data_parcial_2 %>%
select(MORTINF, TASA_MOR) %>%
apply(MARGIN = 2, FUN = norm_inversa) %>% as.data.frame() -> var_corr_negativa
var_corr_positiva %>%
bind_cols(var_corr_negativa) %>%
select(ALFABET,
INC_POB,
ESPVIDAF,
FERTILID,
TASA_NAT,
LOG_PIB,
URBANA,
MORTINF,
TASA_MOR) -> data_parcial2_norm
head(data_parcial2_norm)## 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.75000000Matriz de correlacion.
library(PerformanceAnalytics)
chart.Correlation(as.matrix(data_parcial2_norm),
histogram = TRUE,
pch = 12)
Prueba KMO
library(rela)
KMO <- paf(as.matrix(data_parcial2_norm))$KMO
print(KMO)## [1] 0.85275El valor minimo para considerar aceptable el analisis factorial es de 0.5, nuestra informacion tiene 0.85. Es adecuado.
Prueba Barlett
library(psych)
Barlett <- cortest.bartlett(data_parcial2_norm)
print(Barlett)## $chisq
## [1] 1478.1
##
## $p.value
## [1] 1.7846e-287
##
## $df
## [1] 36Existe correlacion entre ellas, Pvalue pequeño, se rechaza la H0, hay evidencia entre correlacion entre la bateria de indicadores. Procedemos a pasar al analisis factorial
Analisis factorial
library(FactoMineR)
library(factoextra)
library(kableExtra)
Rx <- cor(data_parcial2_norm)
PC <- princomp(x = data_parcial2_norm, 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_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 |
Grafico de sedimentacion
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)
El grafico de sedimentacion nos ayuda a determinar el criterio de raiz latente, se extraen los primeros 2 componentes, superior al 75%
Rotacion
library(corrplot)
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.99Representacion factor 1: ALFABET, INC_POB, FERTILID, TASA_NAT Y LOG_PIB Representacion factor 2: ESPVIDAF, URBANA, MORTINF Y TASA_MOR
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
)
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("striped", "hover"))| Dim.1 | Dim.2 |
|---|---|
| 0.72 | 0.28 |
Contribucion 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_dark(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 |
Metodos subjetivos de ponderacion.
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:
Jerarquia Suma
library(magrittr)
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
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))
}
pesos_ranking_suma <- ponderadores_subjetivos_rank_suma(rj)
pesos_ranking_suma$w_brutos## X1 X2 X3 X4
## 2 1 3 4pesos_ranking_suma$w_normalizados %>% round(digits = 3)## X1 X2 X3 X4
## 0.2 0.1 0.3 0.4Grafico de pesos normalizados
barplot(
pesos_ranking_suma$w_normalizados,
main = "Ponderadores jerarquia de suma",
ylim = c(0, 0.5),
col = "red"
)
Jerarquia Reciprocos
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
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_ranking_reciproco$w_brutos## X1 X2 X3 X4
## 0.33333 0.25000 0.50000 1.00000pesos_ranking_reciproco$w_normalizados %>% round(digits = 3)## X1 X2 X3 X4
## 0.16 0.12 0.24 0.48Grafico de pesos normalizados
barplot(
pesos_ranking_reciproco$w_normalizados,
main = "Ponderadores Ranking Recíproco",
ylim = c(0, 0.5),
col = "brown"
)
Jerarquia exponencial
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
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))
}
pesos_ranking_exponencial <-
ponderadores_subjetivos_rank_exponencial(rj)
pesos_ranking_exponencial$w_brutos## X1 X2 X3 X4
## 16 1 81 256pesos_ranking_exponencial$w_normalizados %>% round(digits = 3)## X1 X2 X3 X4
## 0.045 0.003 0.229 0.723Grafico de pesos normalizados
barplot(pesos_ranking_exponencial$w_normalizados,
main = "Ponderadores Ranking Exponencial",
ylim = c(0,0.8),col = "Blue")
Usando la técnica de comparación por pares, calcule los pesos normalizados para las variables:
library(FuzzyAHP)
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"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.075350barplot(
pesos_normalizados@weights,
main = "Ponderadores por método comparación de pares",
ylim = c(0, 0.7),
col = "green"
)
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"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.08215barplot(
pesos_normalizados_2@weights,
main = "Ponderadores por método comparación de pares",
ylim = c(0, 0.7),
col = "gray"
)
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"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 = "white")
library(kableExtra)
ponderacion_expertos <-1/3
pesos_tot<-(pesos_normalizados@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] 1normalizacion_1<-promedio_tot/sum(promedio_tot)
show(normalizacion_1)## w_X1 w_X2 w_X3 w_X4
## 0.610848 0.198207 0.115739 0.075207ponderacion_expertos_distintas<-(pesos_normalizados@weights*0.4)+(pesos_normalizados_2@weights*0.4)+(pesos_normalizados_3@weights*0.2)
show(ponderacion_expertos_distintas)## w_X1 w_X2 w_X3 w_X4
## 0.609665 0.203343 0.110367 0.076624sum(ponderacion_expertos_distintas)## [1] 1normalizacion_2<-ponderacion_expertos_distintas/sum(ponderacion_expertos_distintas)
show(normalizacion_2)## w_X1 w_X2 w_X3 w_X4
## 0.609665 0.203343 0.110367 0.076624