Practica Parcial 2
Diana Carolina Villatoro Romero
2022-10-22
Clave A
Desarrolle el siguiente ejercicio: Se necesita construir un indicador multivariado sintético, que mida la “Seguridad Municipal” Para ello se dispone de la siguiente información:
(25%) A través del análisis de componentes principales, identifique para un modelo de 3 factores:
a)Los ponderadores normalizados para cada factor. b)Las variables incluidas en cada factor.
Cargar la data
library(magrittr)
data_parcial_2_A<-
load("~/Metodos/data_parcial_2_A.RData")
head(datos_parcial_2)## ID Municipio X1 X2 X3 X4 X5 X6 X7 X8
## 1 1 ATIQUIZAYA 9 2 20.00000 20.00000 0.00000 0.000000 2 56.4000
## 2 2 EL CARMEN 10 6 62.50000 50.00000 37.50000 3.947368 11 147.3750
## 3 3 ALEGRIA 10 20 50.00000 50.00000 50.00000 2.564103 16 135.0000
## 4 4 SAN JULIAN 8 3 42.85714 42.85714 14.28571 1.351351 35 121.1429
## 5 5 TEJUTLA 7 7 75.00000 75.00000 75.00000 9.090909 8 202.5000
## 6 6 PASAQUINA 6 13 30.00000 30.00000 30.00000 8.108108 25 81.0000library(dplyr)##
## Attaching package: 'dplyr'## The following objects are masked from 'package:stats':
##
## filter, lag## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, unionlibrary(magrittr)
library(dplyr)
norm_directa <- function(x) {
(x - min(x)) / (max(x) - min(x))
}
norm_inversa <- function(x) {
(max(x) - x) / (max(x) - min(x))
}
#Seleccionando las variables con correlación positiva
datos_parcial_2 %>%
select(X1, X2, X3, X5, X7, X8) %>%
apply(MARGIN = 2, FUN = norm_directa) %>% as.data.frame() -> variables_corr_positiva
#Seleccionando las variables con correlación negativa
datos_parcial_2 %>%
select(X4, X6) %>%
apply(MARGIN = 2, FUN = norm_inversa) %>% as.data.frame() -> variables_corr_negativa
#Juntando y reordenando las variables
variables_corr_positiva %>%
bind_cols(variables_corr_negativa) %>%
select(X1, X2, X3, X4, X5, X6, X7, X8) -> datos_financieros_normalizados
head(datos_financieros_normalizados)## X1 X2 X3 X4 X5 X6 X7
## 1 0.19354839 0.000000000 0.0400000 0.8000000 0.0000000 1.0000000 0.00000000
## 2 0.22580645 0.017167382 0.5500000 0.5000000 0.4285714 0.7844130 0.09890110
## 3 0.22580645 0.077253219 0.4000000 0.5000000 0.5714286 0.8599606 0.15384615
## 4 0.16129032 0.004291845 0.3142857 0.5714286 0.1632653 0.9261954 0.36263736
## 5 0.12903226 0.021459227 0.7000000 0.2500000 0.8571429 0.5034965 0.06593407
## 6 0.09677419 0.047210300 0.1600000 0.7000000 0.3428571 0.5571726 0.25274725
## X8
## 1 0.1582266
## 2 0.5167488
## 3 0.4679803
## 4 0.4133709
## 5 0.7339901
## 6 0.2551724Matriz de Correlación & Pruebas de Barlett y KMO para saber si se puede usar análisis factorial
#Matriz de correlación
library(PerformanceAnalytics)## Loading required package: xts## Loading required package: zoo##
## Attaching package: 'zoo'## The following objects are masked from 'package:base':
##
## as.Date, as.Date.numeric##
## Attaching package: 'xts'## The following objects are masked from 'package:dplyr':
##
## first, last##
## Attaching package: 'PerformanceAnalytics'## The following object is masked from 'package:graphics':
##
## legendchart.Correlation(as.matrix(datos_financieros_normalizados),
histogram = TRUE,
pch = 12)## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
#KMO
library(rela)
KMO <- paf(as.matrix(datos_financieros_normalizados))$KMO
print(KMO)## [1] 0.67931R/Se puede realizar el análisis factorial por ser mayor a 0.5
#Prueba de Barlett
library(psych)
options(scipen = 99999)
Barlett <- cortest.bartlett(datos_financieros_normalizados)## R was not square, finding R from dataprint(Barlett)## $chisq
## [1] 1025.9
##
## $p.value
## [1] 0.0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000046951
##
## $df
## [1] 28R/El p value es mucho menor, por lo tanto hay correlación Por esto se realizara el analicis factorial
Análisis Factorial
library(FactoMineR)
library(factoextra)## Loading required package: ggplot2##
## Attaching package: 'ggplot2'## The following objects are masked from 'package:psych':
##
## %+%, alpha## Welcome! Want to learn more? See two factoextra-related books at https://goo.gl/ve3WBalibrary(kableExtra)##
## Attaching package: 'kableExtra'## The following object is masked from 'package:dplyr':
##
## group_rowsRx <- cor(datos_financieros_normalizados)
PC <-
princomp(x = datos_financieros_normalizados, cor = TRUE, fix_sign = FALSE)
variables_pca <- get_pca_var(PC)
factoextra::get_eig(PC) %>% kable(caption = "Resumen de PCA",
align = "c",
digits = 2) %>%
kable_material(html_font = "sans-serif") %>%
kable_styling(bootstrap_options = c("hover"))| eigenvalue | variance.percent | cumulative.variance.percent | |
|---|---|---|---|
| Dim.1 | 3.90 | 48.72 | 48.72 |
| Dim.2 | 1.96 | 24.55 | 73.27 |
| Dim.3 | 0.84 | 10.52 | 83.78 |
| Dim.4 | 0.50 | 6.24 | 90.03 |
| Dim.5 | 0.45 | 5.68 | 95.70 |
| Dim.6 | 0.28 | 3.45 | 99.16 |
| Dim.7 | 0.07 | 0.82 | 99.98 |
| Dim.8 | 0.00 | 0.02 | 100.00 |
#Obtener una visualización de lo anterior
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)
En este ejercicio, son tres factores los que se van a retener.
library(corrplot)## corrplot 0.92 loaded#Modelo de 3 Factores (de una vez Rotada, porque no se especifica)
numero_de_factores <- 3
modelo_factores <- principal(
r = Rx,
nfactors = numero_de_factores,
covar = FALSE,
rotate = "varimax"
)
modelo_factores## Principal Components Analysis
## Call: principal(r = Rx, nfactors = numero_de_factores, rotate = "varimax",
## covar = FALSE)
## Standardized loadings (pattern matrix) based upon correlation matrix
## RC1 RC2 RC3 h2 u2 com
## X1 -0.16 0.80 -0.03 0.67 0.3316 1.1
## X2 0.08 0.84 -0.03 0.71 0.2879 1.0
## X3 0.93 -0.09 0.28 0.95 0.0493 1.2
## X4 -0.95 0.05 -0.26 0.98 0.0208 1.2
## X5 0.43 -0.06 0.80 0.83 0.1742 1.5
## X6 -0.25 0.03 -0.91 0.89 0.1142 1.2
## X7 -0.07 0.83 -0.04 0.69 0.3107 1.0
## X8 0.96 -0.06 0.27 0.99 0.0087 1.2
##
## RC1 RC2 RC3
## SS loadings 2.97 2.05 1.68
## Proportion Var 0.37 0.26 0.21
## Cumulative Var 0.37 0.63 0.84
## Proportion Explained 0.44 0.31 0.25
## Cumulative Proportion 0.44 0.75 1.00
##
## Mean item complexity = 1.2
## Test of the hypothesis that 3 components are sufficient.
##
## The root mean square of the residuals (RMSR) is 0.06
##
## Fit based upon off diagonal values = 0.98Con esto se nos presenta la solución.
#Verificar las correlaciones, para ver la representación de cada variable en el factor.
correlaciones_modelo <- variables_pca$coord
rotacion <- varimax(correlaciones_modelo[, 1:numero_de_factores])
correlaciones_modelo_rotada <- rotacion$loadings
corrplot(
correlaciones_modelo_rotada[, 1:numero_de_factores],
is.corr = FALSE,
method = "square",
addCoef.col = "grey",
number.cex = 0.75
)
Respuesta 1.b:Las variables que pertenecen a cada componente son: Comp 1: X3,X4 y X8 Comp 2: X1,X2 y X7 Comp 3: X5 y X6
#Respuesta 1.a
library(kableExtra)
cargas <- rotacion$loadings[1:6, 1:numero_de_factores]
ponderadores <- prop.table(apply(cargas ^ 2, MARGIN = 2, sum))
#Estética
t(ponderadores) %>% kable(caption = "Ponderadores de los Factores Extraídos",
align = "c",
digits = 2) %>%
kable_material(html_font = "sans-serif") %>%
kable_styling(bootstrap_options = c("striped", "hover"))| Dim.1 | Dim.2 | Dim.3 |
|---|---|---|
| 0.41 | 0.27 | 0.32 |
#Aquí se puede ver cuanto a contribuido cada variable a cada factor
contribuciones <- apply(cargas ^ 2, MARGIN = 2, prop.table)
contribuciones %>% kable(caption = "Contribución de las variables en los Factores",
align = "c",
digits = 2) %>%
kable_material(html_font = "sans-serif") %>%
kable_styling(bootstrap_options = c("striped", "hover"))| Dim.1 | Dim.2 | Dim.3 | |
|---|---|---|---|
| X1 | 0.01 | 0.47 | 0.00 |
| X2 | 0.00 | 0.52 | 0.00 |
| X3 | 0.42 | 0.01 | 0.05 |
| X4 | 0.44 | 0.00 | 0.04 |
| X5 | 0.09 | 0.00 | 0.40 |
| X6 | 0.03 | 0.00 | 0.51 |
(25%) Para el factor 1, utilice el método CRITIC para obtener los ponderadores normalizados para cada variable.
# Normalización de los datos
library(dplyr)
datos_parcial_2 %>%
select(X3, X8) %>%
apply(MARGIN = 2, FUN = norm_directa) %>% as.data.frame() -> data_factor
datos_parcial_2 %>%
select(X4) %>%
apply(MARGIN = 2, FUN = norm_inversa) %>% as.data.frame() -> data_factorr
data_factor %>% #peguele el otro dataframe
bind_cols(data_factorr) %>%
select(X3, X4, X8) -> data_factor_1
head(data_factor_1)## X3 X4 X8
## 1 0.04000 0.80000 0.15823
## 2 0.55000 0.50000 0.51675
## 3 0.40000 0.50000 0.46798
## 4 0.31429 0.57143 0.41337
## 5 0.70000 0.25000 0.73399
## 6 0.16000 0.70000 0.25517#Cálculo de las desviaciones estándar de cada variable
data_factor_1 %>% dplyr::summarise(S3 = sd(X3),
S4 = sd(X4),
S8 = sd(X8)) -> sd_vector
print(sd_vector)## S3 S4 S8
## 1 0.24628 0.20111 0.20874#Cálculo de la matriz de correlación
cor(data_factor_1) -> mat_R_F1
print(mat_R_F1)## X3 X4 X8
## X3 1.00000 -0.93872 0.95904
## X4 -0.93872 1.00000 -0.99585
## X8 0.95904 -0.99585 1.00000#Cálculo de los ponderadores brutos
1 - mat_R_F1 -> sum_data
colSums(sum_data) -> sum_vector
sd_vector * sum_vector -> vj
print(vj)## S3 S4 S8
## 1 0.48755 0.79129 0.42517#Cálculo de los ponderadores netos
vj / sum(vj) -> wj
print(wj)## S3 S4 S8
## 1 0.28612 0.46437 0.24951#Ponderadores:
print(round(wj * 100, 2))## S3 S4 S8
## 1 28.61 46.44 24.95(25%) Para el factor 2, utilice el método de Entropía para obtener los ponderadores normalizados para cada variable.
Se utilizarán las variables X1,X2 y X7
#Normalización de los datos
datos_parcial_2 %>% dplyr::select(X1, X2, X7) -> data_norm
apply(data_norm, 2, prop.table) -> data_norm
head(data_norm)## X1 X2 X7
## [1,] 0.0078125 0.00070734 0.0013986
## [2,] 0.0086806 0.00212202 0.0076923
## [3,] 0.0086806 0.00707339 0.0111888
## [4,] 0.0069444 0.00106101 0.0244755
## [5,] 0.0060764 0.00247569 0.0055944
## [6,] 0.0052083 0.00459770 0.0174825#Fórmula de entropía
entropy <- function(x) {
return(x * log(x))
}
apply(data_norm, 2, entropy) -> data_norm_2
head(data_norm_2)## X1 X2 X7
## [1,] -0.037906 -0.0051310 -0.009192
## [2,] -0.041204 -0.0130618 -0.037443
## [3,] -0.041204 -0.0350233 -0.050270
## [4,] -0.034513 -0.0072664 -0.090806
## [5,] -0.031010 -0.0148572 -0.029013
## [6,] -0.027383 -0.0247457 -0.070744#Número de variables en el factor:
ncol(data_norm) -> m
#Constante de entropía:
-1 / log(m) -> K
print(K)## [1] -0.91024#Cálculo de las entropías
K * colSums(data_norm_2) -> Ej
print(Ej)## X1 X2 X7
## 4.1805 3.2029 3.7019#Cálculo de las especificidades:
1 - Ej -> vj
print(vj)## X1 X2 X7
## -3.1805 -2.2029 -2.7019#Cálculo de los ponderadores:
prop.table(vj) -> wj #es igual a usar vj/sum(vj)
print(wj)## X1 X2 X7
## 0.39337 0.27245 0.33417(25%) Para el factor 3, utilice el método de Ranking para obtener los ponderadores normalizados para cada variable (utilice la numeración de las variables para establecer la jerarquía).
Serian los componentes X5 Y X6
Jerarquía de Suma
library(magrittr)
#Vector de Jerarquías
rj <- c(1:2)
names(rj) <- c("X5", "X6")
#Función para generar los pesos
ponderadores_subjetivos_rank_suma <- function(vector_jerarquias) {
n <- length(vector_jerarquias)
vector_pesos <- n - vector_jerarquias + 1
list(w_brutos = vector_pesos,
w_normalizados = prop.table(vector_pesos))
}
#Aplicando la función:
pesos_ranking_suma <- ponderadores_subjetivos_rank_suma(rj)
#Pesos brutos
pesos_ranking_suma$w_brutos## X5 X6
## 2 1#Pesos normalizados
pesos_ranking_suma$w_normalizados %>% round(digits = 3)## X5 X6
## 0.667 0.333#Gráfico de los pesos normalizados
barplot(
pesos_ranking_suma$w_normalizados,
main = "Ponderadores para Ranking de Suma",
ylim = c(0, 0.8),
col = "blue"
)
Jerarquía Reciproca
#Función para generar los pesos
ponderadores_subjetivos_rank_reciproco <- function(vector_jerarquias) {
vector_pesos <- 1 / vector_jerarquias
list(w_brutos = vector_pesos,
w_normalizados = prop.table(vector_pesos))
}
#Aplicando la función:
pesos_ranking_reciproco <- ponderadores_subjetivos_rank_reciproco(rj)
#Pesos brutos
pesos_ranking_reciproco$w_brutos %>% round(digits = 3)## X5 X6
## 1.0 0.5#Pesos normalizados
pesos_ranking_reciproco$w_normalizados %>% round(digits = 3)## X5 X6
## 0.667 0.333#Gráfico de los pesos normalizados
barplot(
pesos_ranking_reciproco$w_normalizados,
main = "Ponderadores Ranking Recíproco",
ylim = c(0, 0.8),
col = "yellow"
)
Jerarquía Exponencial
No se estableció el valor de P en el enunciado, por lo tanto se utilicé el valor de 2, ya que solo muestra como se satura en los primeros lugares.
#Función para generar los pesos
ponderadores_subjetivos_rank_exponencial <-
function(vector_jerarquias, p = 2) {
n <- length(vector_jerarquias)
vector_pesos <- (n - vector_jerarquias + 1) ^ p
list(w_brutos = vector_pesos,
w_normalizados = prop.table(vector_pesos))
}
#Aplicando la función:
pesos_ranking_exponencial <-
ponderadores_subjetivos_rank_exponencial(rj)
#Pesos brutos
pesos_ranking_exponencial$w_brutos## X5 X6
## 4 1#Pesos normalizados
pesos_ranking_exponencial$w_normalizados %>% round(digits = 3)## X5 X6
## 0.8 0.2#Gráfico de los pesos normalizados (por default p=2)
barplot(
pesos_ranking_exponencial$w_normalizados,
main = "Ponderadores Ranking Exponencial",
ylim = c(0, 0.9),
col = "purple"
)
Clave B
Sección I
Se pretende construir un indicador multivariado sintético sobre el
Desarrollo en las Economías. Los indicadores a considerar son*: el
índice de alfabetización (alfabet)[+], el incremento de la población
(inc_pob)[+], la esperanza de vida femenina (espvidaf)[+], la mortalidad
infantil (mortinf)[-], el número promedio de hijos por mujer
(fertilid)[+], la tasa de natalidad (tasa_nat)[+], el logaritmo del PIB
(log_pib)[+], la población urbana (urbana)[+] y la tasa de mortalidad
(tasa_mor)[-].
Entre Corchetes aparece la correlación teórica esperada entre la
variable compleja y el indicador.
Carga de datos
library(magrittr)
library(kableExtra)
load("~/Metodos/data_parcial_2_B.RData")
head(data_parcial_2, n = 10) %>%
kable(caption = "**Tabla 1:** Data Original.",
align = "c",
digits = 2) %>%
kable_classic(html_font = "Times New Roman",
font_size = 14) %>%
row_spec(0, bold = T) %>%
footnote(general_title = "**Fuente**:",
general = "Elaboración propia con base data Parcial 2 B.")| PAÍS | POBLAC | DENSIDAD | URBANA | RELIG | ESPVIDAF | ESPVIDAM | ALFABET | INC_POB | MORTINF | PIB_CAP | REGIÓN | CALORÍAS | SIDA | TASA_NAT | TASA_MOR | TASASIDA | LOG_PIB | LOGTSIDA | NAC_DEF | FERTILID | LOG_POB | CREGRANO | ALFABMAS | ALFABFEM | CLIMA |
|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
| Acerbaján | 7400 | 86.0 | 54 | Musulma. | 75 | 67 | 98 | 1.40 | 35.0 | 3000 | 5 | NA | NA | 23 | 7 | NA | 3.48 | NA | 3.29 | 2.80 | 3.87 | 18 | 100 | 100 | 3 |
| Afganistán | 20500 | 25.0 | 18 | Musulma. | 44 | 45 | 29 | 2.80 | 168.0 | 205 | 3 | NA | 0 | 53 | 22 | 0.00 | 2.31 | 0.00 | 2.41 | 6.90 | 4.31 | 12 | 44 | 14 | 3 |
| Alemania | 81200 | 227.0 | 85 | Protest. | 79 | 73 | 99 | 0.36 | 6.5 | 17539 | 1 | 3443 | 11179 | 11 | 11 | 13.77 | 4.24 | 1.69 | 1.00 | 1.47 | 4.91 | 34 | NA | NA | 8 |
| Arabia Saudí | 18000 | 7.7 | 77 | Musulma. | 70 | 66 | 62 | 3.20 | 52.0 | 6651 | 5 | 2874 | 61 | 38 | 6 | 0.34 | 3.82 | 0.81 | 6.33 | 6.67 | 4.26 | 1 | 73 | 48 | 1 |
| Argentina | 33900 | 12.0 | 86 | Católica | 75 | 68 | 95 | 1.30 | 25.6 | 3408 | 6 | 3113 | 3904 | 20 | 9 | 11.52 | 3.53 | 1.63 | 2.22 | 2.80 | 4.53 | 9 | 96 | 95 | 8 |
| Armenia | 3700 | 126.0 | 68 | Ortodoxa | 75 | 68 | 98 | 1.40 | 27.0 | 5000 | 5 | NA | 2 | 23 | 6 | 0.05 | 3.70 | 0.56 | 3.83 | 3.19 | 3.57 | 17 | 100 | 100 | NA |
| Australia | 17800 | 2.3 | 85 | Protest. | 80 | 74 | 100 | 1.38 | 7.3 | 16848 | 1 | 3216 | 4727 | 15 | 8 | 26.56 | 4.23 | 1.93 | 1.88 | 1.90 | 4.25 | 6 | 100 | 100 | 3 |
| Austria | 8000 | 94.0 | 58 | Católica | 79 | 73 | 99 | 0.20 | 6.7 | 18396 | 1 | 3495 | 1150 | 12 | 11 | 14.38 | 4.26 | 1.70 | 1.09 | 1.50 | 3.90 | 17 | NA | NA | 8 |
| Bahrein | 600 | 828.0 | 83 | Musulma. | 74 | 71 | 77 | 2.40 | 25.0 | 7875 | 5 | NA | 13 | 29 | 4 | 2.17 | 3.90 | 1.17 | 7.25 | 3.96 | 2.78 | 2 | 55 | 55 | 3 |
| Bangladesh | 125000 | 800.0 | 16 | Musulma. | 53 | 53 | 35 | 2.40 | 106.0 | 202 | 3 | 2021 | 1 | 35 | 11 | 0.00 | 2.31 | 0.24 | 3.18 | 4.70 | 5.10 | 67 | 47 | 22 | 5 |
| Fuente: | |||||||||||||||||||||||||
| Elaboración propia con base data Parcial 2 B. |
# Cargando Paquetes
library(dplyr)
library(tidyr)##
## Attaching package: 'tidyr'## The following object is masked from 'package:magrittr':
##
## extractlibrary(kableExtra)
# Creando funciones para normalización
norm_directa <- function(x) {
(x - min(x)) / (max(x) - min(x))
}
norm_inversa <- function(x) {
(max(x) - x) / (max(x) - min(x))
}
# Suprimir Val=NULL
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
# Normalizacion de Variables con Correlación Teórica Esperada Positiva
data_parcial_2 %>%
select(ALFABET, INC_POB, ESPVIDAF, FERTILID, TASA_NAT, LOG_PIB, URBANA) %>%
apply(MARGIN = 2,
FUN = norm_directa) %>%
as.data.frame() -> variables_positivas
# Normalizacion de Variables con Correlación Teórica Esperada Negativa
data_parcial_2 %>%
select(MORTINF, TASA_MOR) %>%
apply(MARGIN = 2,
FUN = norm_inversa) %>%
as.data.frame() -> variables_negativas
# Acoplamiento de las variables previamente normalizadas segun su correlación
variables_positivas %>%
bind_cols(variables_negativas) %>%
select(ALFABET,
INC_POB,
ESPVIDAF,
FERTILID,
TASA_NAT,
LOG_PIB,
URBANA,
MORTINF,
TASA_MOR) -> datos_normalizados
# Dandole formato a la muestra
head(datos_normalizados, n = 10) %>%
kable(
caption = "**Tabla 2:** Data Normalizada.",
col.names = c(
"Índice de alfabetización",
"Incremento Poblacional",
"Esperanza de Vida Femenina",
"Mortalidad Infantil",
"Promedio de Hijos por Mujer",
"Tasa de Natalidad",
"Logaritmo del PIB",
"Poblacion Urbana",
"Tasa de Mortalidad"
),
align = "c",
digits = 2
) %>%
kable_classic(html_font = "Times New Roman",
font_size = 14) %>%
row_spec(0, bold = T) %>%
footnote(general_title = "**Fuente**:",
general = "Elaboración propia con base data Parcial 2 B.")| Índice de alfabetización | Incremento Poblacional | Esperanza de Vida Femenina | Mortalidad Infantil | Promedio de Hijos por Mujer | Tasa de Natalidad | Logaritmo del PIB | Poblacion Urbana | Tasa de Mortalidad |
|---|---|---|---|---|---|---|---|---|
| 0.98 | 0.31 | 0.82 | 0.34 | 0.30 | 0.61 | 0.54 | 0.81 | 0.71 |
| 0.29 | 0.56 | 0.03 | 0.84 | 1.00 | 0.10 | 0.18 | 0.00 | 0.08 |
| 0.99 | 0.12 | 0.92 | 0.18 | 0.02 | 0.94 | 0.85 | 0.98 | 0.54 |
| 0.62 | 0.63 | 0.69 | 0.81 | 0.65 | 0.76 | 0.77 | 0.71 | 0.75 |
| 0.95 | 0.29 | 0.82 | 0.34 | 0.23 | 0.63 | 0.86 | 0.87 | 0.62 |
| 0.98 | 0.31 | 0.82 | 0.39 | 0.30 | 0.71 | 0.68 | 0.86 | 0.75 |
| 1.00 | 0.30 | 0.95 | 0.23 | 0.12 | 0.94 | 0.85 | 0.98 | 0.67 |
| 0.99 | 0.09 | 0.92 | 0.18 | 0.05 | 0.95 | 0.58 | 0.98 | 0.54 |
| 0.77 | 0.49 | 0.79 | 0.48 | 0.44 | 0.79 | 0.83 | 0.87 | 0.83 |
| 0.35 | 0.49 | 0.26 | 0.57 | 0.58 | 0.10 | 0.16 | 0.38 | 0.54 |
| Fuente: | ||||||||
| Elaboración propia con base data Parcial 2 B. |
# Matriz Correlación
library(PerformanceAnalytics)
chart.Correlation(as.matrix(datos_normalizados),
histogram = TRUE,
pch = 12)## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
## Warning in par(usr): argument 1 does not name a graphical parameter
Pruebas KMO y Barlett
# Prueba KMO
library(rela)
KMO <- paf(as.matrix(datos_normalizados))$KMO
# Dando formato de Salida al valor KMO
KMO %>%
kable(
caption = "**Tabla 3:** Prueba de adecuación muestral de Kaiser Meyer Olkin.",
col.names = "KMO",
align = "c",
digits = 4
) %>%
kable_classic(html_font = "Times New Roman",
font_size = 14) %>%
row_spec(0, bold = T) %>%
footnote(general_title = "**Fuente**:",
general = "Elaboración propia con base data Parcial 2 B.")| KMO |
|---|
| 0.8528 |
| Fuente: |
| Elaboración propia con base data Parcial 2 B. |
# Prueba de Barlett
library(psych)
Barlett <- cortest.bartlett(datos_normalizados)## R was not square, finding R from data# Dando formato de Salida a Valores de la Prueba de Barlett
frame_bartlett <-
data.frame(Barlett$chisq, Barlett$p.value, Barlett$df)
colnames(frame_bartlett) <- c("Chisq", "P-Value", "Df")
frame_bartlett %>%
kable(caption = "**Tabla 4:** Prueba de Barlett.",
align = "c",
digits = 1) %>%
kable_classic(html_font = "Times New Roman",
font_size = 14) %>%
row_spec(0, bold = T) %>%
footnote(general_title = "**Fuente**:",
general = "Elaboración propia con base data Parcial 2 B.")| Chisq | P-Value | Df |
|---|---|---|
| 1478.1 | 0 | 36 |
| Fuente: | ||
| Elaboración propia con base data Parcial 2 B. |
Ya que la Prueba de Adecuación muestral de Kaiser Meyer Olkin (KMO) > 0.5 y que el P-Value < 0.05, se considera adecuado el emplear Análisis Factorial porque existe multicolinealidad en los valores de la matriz de información.
Numeral 1.1
Usando Análisis Factorial determine cuántos factores deberían retenerse.
Analisis de Componentes
library(FactoMineR)
library(factoextra)
library(kableExtra)
Rx <- cor(datos_normalizados)
PC <-
princomp(x = datos_normalizados, cor = TRUE, fix_sign = FALSE)
variables_pca <- get_pca_var(PC)
factoextra::get_eig(PC) %>%
kable(caption = "**Tabla 5:** Resumen de Análisis de Componentes Principales (PCA)",
col.names = c("Autovalores",
"Varianza (%)",
"Varianza Acumulada (%)"),
align = "c",
digits = 2) %>%
kable_classic(html_font = "Times New Roman",
font_size = 14) %>%
row_spec(0, bold = T) %>%
footnote(general_title = "**Fuente**:",
general = "Elaboración propia con base data Parcial 2.")| Autovalores | Varianza (%) | Varianza Acumulada (%) | |
|---|---|---|---|
| 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 |
| Fuente: | |||
| Elaboración propia con base data Parcial 2. |
Gráfico de sedimentación
fviz_eig(
PC,
choice = "eigenvalue",
barcolor = "#F8A29E",
barfill = "#F8A29E",
addlabels = TRUE,
) + labs(title = "Gráfico de Sedimentación",
subtitle = "Usando princomp, con Autovalores") +
xlab(label = "Componentes") +
ylab(label = "Autovalores") +
geom_hline(yintercept = 1)
Respuesta Numeral 1.1 Bajo el:
Criterio del Autovalor: 2 componentes ya que con estos se explica más
del 75% de la varianza acumulada, en total un 85.44%. Criterio de la
Raíz Latente (Gráfico de Sedimentacion): 2 componentes ya que se nota el
“quiebre en ese componente”.
Numeral 1.2
¿Qué variables quedan representadas en cada factor?
library(corrplot)
# Modelo de 2 Factores (Rotado)
numero_de_factores <- 2
modelo_factores <- principal(
r = Rx,
nfactors = numero_de_factores,
covar = FALSE,
rotate = "varimax"
)
modelo_factores## Principal Components Analysis
## Call: principal(r = Rx, nfactors = numero_de_factores, rotate = "varimax",
## covar = FALSE)
## Standardized loadings (pattern matrix) based upon correlation matrix
## RC1 RC2 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# Graficación
correlaciones_modelo <- variables_pca$coord
rotacion <- varimax(correlaciones_modelo[, 1:numero_de_factores])
correlaciones_modelo_rotada <- rotacion$loadings
corrplot(
correlaciones_modelo_rotada[, 1:numero_de_factores],
is.corr = FALSE,
method = "square",
addCoef.col = "black",
tl.col = "black",
number.cex = 0.75
)
Respuesta Numeral 1.2: ¿Qué variables quedan
representadas en cada factor? En el factor 1 quedan representadas 5
Variables: * ALFABET.
* INC_POB.
* FERTILID.
* TASA_NAT.
* LOG_PIB.
En el factor 2 quedan representadas 4 Variables:
* ESPVIDAF.
* URBANA.
* MORTINF.
* TASA_MOR.
Numeral 1.3
Determine qué pesos deben asignarse a cada factor y a las variables dentro de cada uno de ellos.
# Cargas de cada dimensión
library(kableExtra)
cargas <- rotacion$loadings[1:9, 1:numero_de_factores]
ponderadores <- prop.table(apply(cargas ^ 2, MARGIN = 2, sum))
t(ponderadores) %>%
kable(caption = "**Tabla 6:** Ponderadores de los Factores Extraídos",
col.names = c("Factor 1", "Factor 2"),
align = "c",
digits = 2) %>%
kable_classic(html_font = "Times New Roman",
font_size = 14) %>%
row_spec(0, bold = T) %>%
footnote(general_title = "**Fuente**:",
general = "Elaboración propia con base data Parcial 2 B.")| Factor 1 | Factor 2 |
|---|---|
| 0.57 | 0.43 |
| Fuente: | |
| Elaboración propia con base data Parcial 2 B. |
Respuesta Numeral 1.3: La solucion se presenta por cada variable y Factor(Dim.1 y Dim.2) en la tabla a continuación
library(dplyr)
library(kableExtra)
# Contribuciones
contribuciones <- apply(cargas ^ 2, MARGIN = 2, prop.table)
data.frame(
contribuciones,
row.names = c(
"Índice de alfabetización",
"Incremento Poblacional",
"Esperanza de Vida Femenina",
"Promedio de Hijos por Mujer",
"Tasa de Natalidad",
"Logaritmo del PIB",
"Poblacion Urbana",
"Mortalidad Infantil",
"Tasa de Mortalidad"))%>%
kable(caption = "**Tabla 7:** Contribución de las variables en los Factores.",
col.names = c("Factor 1", "Factor 2"),
align = "c",
digits = 2) %>%
kable_classic(html_font = "Times New Roman",
font_size = 14) %>%
row_spec(0, bold = T) %>%
column_spec(1, bold = T) %>%
footnote(general_title = "**Fuente**:",
general = "Elaboración propia con base data Parcial 2 B.")| Factor 1 | Factor 2 | |
|---|---|---|
| Índice de alfabetización | 0.11 | 0.08 |
| Incremento Poblacional | 0.22 | 0.00 |
| Esperanza de Vida Femenina | 0.09 | 0.17 |
| Promedio de Hijos por Mujer | 0.17 | 0.05 |
| Tasa de Natalidad | 0.19 | 0.05 |
| Logaritmo del PIB | 0.09 | 0.10 |
| Poblacion Urbana | 0.04 | 0.15 |
| Mortalidad Infantil | 0.10 | 0.15 |
| Tasa de Mortalidad | 0.00 | 0.25 |
| Fuente: | ||
| Elaboración propia con base data Parcial 2 B. |
Sección II
Una empresa se encuentra calculando un Indicador del desempeño de sus
líneas de producción, para ello no dispone de información previa, pero
hay una importante consultora que posee expertos en el sector donde se
ubica la empresa en cuestión.
La consultora, ha han determinado 4 variables que definen adecuadamente
el desempeño de las líneas de producción:
X1: Mantenimiento de la línea de producción.
X2: Tamaño de planta.
X3: Logística (entradas y salidas de insumos y producción).
X4: Capacidad de innovación.
La consultora jerarquizó las variables de la siguiente manera:
#Este chun es solo para mostrar el ranking
library(kableExtra)
rango<- c(3,4,2,1) %>% as.data.frame()
rango_transpose <- data.frame(t(rango))
colnames(rango_transpose)<-c("X1", "X2", "X3", "X4")
rownames(rango_transpose)<-"Ranking (Jerarquía)"
rango_transpose %>% kable() %>%
kable_classic(html_font = "Times New Roman",
font_size = 14) %>%
row_spec(0, bold = T)| X1 | X2 | X3 | X4 | |
|---|---|---|---|---|
| Ranking (Jerarquía) | 3 | 4 | 2 | 1 |
Ejercicio 1
Calcule los pesos normalizados, de las variables, usando los métodos de ranking directo, por suma, por reciproco y por ranking exponencial (use p=4).
Por Método de Suma
library(magrittr)
library(kableExtra)
#Vector jerarquías
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
#Función para generar los pesos
ponderadores_subjetivos_rank_suma<-function(vector_jerarquias){
n <- length(vector_jerarquias)
vector_pesos <- n-vector_jerarquias+1
list(w_brutos = vector_pesos,w_normalizados=vector_pesos/sum(vector_pesos))
}
#Aplicando la función:
pesos_ranking_suma<-ponderadores_subjetivos_rank_suma(rj)
#Pesos brutos
pesos_ranking_suma$w_brutos%>%
kable(caption = "**Tabla 8:** Peso Bruto por Método de Suma.",
col.names ="Peso Bruto",
align = "c",
digits = 2) %>%
kable_classic(html_font = "Times New Roman",
font_size = 14) %>%
row_spec(0, bold = T)| Peso Bruto | |
|---|---|
| X1 | 2 |
| X2 | 1 |
| X3 | 3 |
| X4 | 4 |
#Pesos normalizados
pesos_ranking_suma$w_normalizados %>% round(digits = 3)%>%
kable(caption = "**Tabla 9:** Peso Normalizado por Método de Suma.",
col.names ="Peso Normalizado",
align = "c",
digits = 2) %>%
kable_classic(html_font = "Times New Roman",
font_size = 14) %>%
row_spec(0, bold = T)| Peso Normalizado | |
|---|---|
| X1 | 0.2 |
| X2 | 0.1 |
| X3 | 0.3 |
| X4 | 0.4 |
Gráfico de pesos normalizados
barplot(
pesos_ranking_suma$w_normalizados,
main = "Ponderadores jerarquia de suma",
ylim = c(0, 0.5),
col = "#F8A29E"
)
Por método reciproco
#Vector de Jerarquías
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
#Función para generar los pesos
ponderadores_subjetivos_rank_reciproco <-
function(vector_jerarquias) {
vector_pesos <- 1 / vector_jerarquias
list(w_brutos = vector_pesos,
w_normalizados = vector_pesos / sum(vector_pesos))
}
#Aplicando la función:
pesos_ranking_reciproco <- ponderadores_subjetivos_rank_reciproco(rj)
#Pesos brutos
pesos_ranking_reciproco$w_brutos%>%
kable(caption = "**Tabla 10:** Peso Bruto por Método Recíproco",
col.names ="Peso Bruto",
align = "c",
digits = 2) %>%
kable_classic(html_font = "Times New Roman",
font_size = 14) %>%
row_spec(0, bold = T)| Peso Bruto | |
|---|---|
| X1 | 0.33 |
| X2 | 0.25 |
| X3 | 0.50 |
| X4 | 1.00 |
#Pesos normalizados
pesos_ranking_reciproco$w_normalizados %>% round(digits = 3)%>%
kable(caption = "**Tabla 11:** Peso Normalizado por Método de Recíproco",
col.names ="Peso Normalizado",
align = "c",
digits = 2) %>%
kable_classic(html_font = "Times New Roman",
font_size = 14) %>%
row_spec(0, bold = T)| Peso Normalizado | |
|---|---|
| X1 | 0.16 |
| X2 | 0.12 |
| X3 | 0.24 |
| X4 | 0.48 |
Gráfico de pesos normalizados
#Gráfico de los pesos normalizados
barplot(
pesos_ranking_reciproco$w_normalizados,
main = "Ponderadores Ranking Recíproco",
ylim = c(0, 0.5),
col = "#F8A29E"
)
Por Método Exponencial (p=4)
#Vector de Jerarquías
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
#Función para generar los pesos
ponderadores_subjetivos_rank_exponencial <-
function(vector_jerarquias, p = 4) {
n <- length(vector_jerarquias)
vector_pesos <- (n - vector_jerarquias + 1) ^ p
list(w_brutos = vector_pesos,
w_normalizados = vector_pesos / sum(vector_pesos))
}
#Aplicando la función:
pesos_ranking_exponencial <-
ponderadores_subjetivos_rank_exponencial(rj)
#Pesos brutos
pesos_ranking_exponencial$w_brutos%>%
kable(caption = "**Tabla 12:** Peso Bruto por Método Exponencial.",
col.names ="Peso Bruto",
align = "c",
digits = 2) %>%
kable_classic(html_font = "Times New Roman",
font_size = 14) %>%
row_spec(0, bold = T)| Peso Bruto | |
|---|---|
| X1 | 16 |
| X2 | 1 |
| X3 | 81 |
| X4 | 256 |
#Pesos normalizados
pesos_ranking_exponencial$w_normalizados %>% round(digits = 3)%>%
kable(caption = "**Tabla 13:** Peso Bruto por Método Exponencial.",
col.names ="Peso Normalizado",
align = "c",
digits = 2) %>%
kable_classic(html_font = "Times New Roman",
font_size = 14) %>%
row_spec(0, bold = T)| Peso Normalizado | |
|---|---|
| X1 | 0.04 |
| X2 | 0.00 |
| X3 | 0.23 |
| X4 | 0.72 |
Gráfico de pesos normalizados (p=4)
#Gráfico de los pesos normalizados (p=4)
barplot(
pesos_ranking_exponencial$w_normalizados,
main = "Ponderadores Ranking Exponencial",
ylim = c(0, 0.8),
col = "#F8A29E"
)
## Ejercicio 2. Usando la técnica de comparación por pares, calcule los
pesos normalizados para las variables: ) Asumiendo que la opinión de los
3 expertos es igualmente válida. ) Si el experto 1 se pondera con 0.25,
el experto 2 con 0.35 y el experto 3 con 0.4
Experto 1
library(FuzzyAHP)## Loading required package: MASS##
## Attaching package: 'MASS'## The following object is masked from 'package:dplyr':
##
## selectvalores_matriz_comparacion_1 = c(1, 7, 4, 5,
NA, 1, 6, 3,
NA, NA, 1, 2,
NA, NA, NA, 1)
matriz_comparacion_1 <- matrix(
valores_matriz_comparacion_1,
nrow = 4,
ncol = 4,
byrow = TRUE
)
matriz_comparacion_1 <- pairwiseComparisonMatrix(matriz_comparacion_1)
matriz_comparacion_1@variableNames <- c("X1", "X2", "X3", "X4")
show(matriz_comparacion_1)## An object of class "PairwiseComparisonMatrix"
## Slot "valuesChar":
## [,1] [,2] [,3] [,4]
## [1,] "1" "7" "4" "5"
## [2,] "1/7" "1" "6" "3"
## [3,] "1/4" "1/6" "1" "2"
## [4,] "1/5" "1/3" "1/2" "1"
##
## Slot "values":
## [,1] [,2] [,3] [,4]
## [1,] 1.00000 7.00000 4.0 5
## [2,] 0.14286 1.00000 6.0 3
## [3,] 0.25000 0.16667 1.0 2
## [4,] 0.20000 0.33333 0.5 1
##
## Slot "variableNames":
## [1] "X1" "X2" "X3" "X4"# Cálculo de los pesos:
pesos_normalizados_1 = calculateWeights(matriz_comparacion_1)
show(pesos_normalizados_1)## An object of class "Weights"
## Slot "weights":
## w_X1 w_X2 w_X3 w_X4
## 0.606592 0.223310 0.094748 0.075350barplot(
pesos_normalizados_1@weights,
main = "Ponderadores por el Método de Comparación por Pares Experto 1",
ylim = c(0, 0.7),
col = "#F8A29E"
)
Experto 2
valores_matriz_comparacion_2 = c(1, 7, 6, 3,
NA, 1, 5, 2,
NA, NA, 1, 4,
NA, NA, NA, 1)
matriz_comparacion_2 <- matrix(
valores_matriz_comparacion_2,
nrow = 4,
ncol = 4,
byrow = TRUE
)
matriz_comparacion_2 <- pairwiseComparisonMatrix(matriz_comparacion_2)
matriz_comparacion_2@variableNames <- c("X1", "X2", "X3", "X4")
show(matriz_comparacion_2)## An object of class "PairwiseComparisonMatrix"
## Slot "valuesChar":
## [,1] [,2] [,3] [,4]
## [1,] "1" "7" "6" "3"
## [2,] "1/7" "1" "5" "2"
## [3,] "1/6" "1/5" "1" "4"
## [4,] "1/3" "1/2" "1/4" "1"
##
## Slot "values":
## [,1] [,2] [,3] [,4]
## [1,] 1.00000 7.0 6.00 3
## [2,] 0.14286 1.0 5.00 2
## [3,] 0.16667 0.2 1.00 4
## [4,] 0.33333 0.5 0.25 1
##
## Slot "variableNames":
## [1] "X1" "X2" "X3" "X4"# Cálculo de los pesos:
pesos_normalizados_2 = calculateWeights(matriz_comparacion_2)
show(pesos_normalizados_2)## An object of class "Weights"
## Slot "weights":
## w_X1 w_X2 w_X3 w_X4
## 0.60919 0.19879 0.10987 0.08215barplot(
pesos_normalizados_2@weights,
main = "Ponderadores por el Método de Comparación por Pares Experto 2",
ylim = c(0, 0.7),
col = "#F8A29E"
)
Experto 3
valores_matriz_comparacion_3 = c(1, 7, 5, 4,
NA, 1, 3, 2,
NA, NA, 1, 6,
NA, NA, NA, 1)
matriz_comparacion_3 <- matrix(
valores_matriz_comparacion_3,
nrow = 4,
ncol = 4,
byrow = TRUE
)
matriz_comparacion_3 <- pairwiseComparisonMatrix(matriz_comparacion_3)
matriz_comparacion_3@variableNames <- c("X1", "X2", "X3", "X4")
show(matriz_comparacion_3)## An object of class "PairwiseComparisonMatrix"
## Slot "valuesChar":
## [,1] [,2] [,3] [,4]
## [1,] "1" "7" "5" "4"
## [2,] "1/7" "1" "3" "2"
## [3,] "1/5" "1/3" "1" "6"
## [4,] "1/4" "1/2" "1/6" "1"
##
## Slot "values":
## [,1] [,2] [,3] [,4]
## [1,] 1.00000 7.00000 5.00000 4
## [2,] 0.14286 1.00000 3.00000 2
## [3,] 0.20000 0.33333 1.00000 6
## [4,] 0.25000 0.50000 0.16667 1
##
## Slot "variableNames":
## [1] "X1" "X2" "X3" "X4"# Cálculo de los pesos:
pesos_normalizados_3 = calculateWeights(matriz_comparacion_3)
show(pesos_normalizados_3)## An object of class "Weights"
## Slot "weights":
## w_X1 w_X2 w_X3 w_X4
## 0.61676 0.17252 0.14259 0.06812barplot(
pesos_normalizados_3@weights,
main = "Ponderadores por el Método de Comparación de Pares Experto 3",
ylim = c(0, 0.7),
col = "#F8A29E"
)
Numeral 2.1
Asumiendo que la opinión de los 3 expertos es igualmente válida.
library(kableExtra)
ponderacion_expertos <- 1 / 3
pesos_tot <-
(
pesos_normalizados_1@weights + pesos_normalizados_2@weights +
pesos_normalizados_3@weights
)
promedio_tot <- ponderacion_expertos * pesos_tot
# Comprobando que la suma de 1 para verificar que es correcto
sum(promedio_tot)## [1] 1# Muestra y formato de los Resultados
promedio_tot %>%
kable(
caption = "**Tabla 14:** Peso Bruto con una Misma ponderacion de la opinion por Experto.",
col.names = "Peso Bruto",
align = "c",
digits = 4
) %>%
kable_classic(html_font = "Times New Roman",
font_size = 14) %>%
row_spec(0, bold = T)| Peso Bruto | |
|---|---|
| w_X1 | 0.6108 |
| w_X2 | 0.1982 |
| w_X3 | 0.1157 |
| w_X4 | 0.0752 |
normalizacion_1 <- promedio_tot / sum(promedio_tot)
normalizacion_1 %>%
kable(
caption = "**Tabla 15:** Peso Normalizado con una Misma ponderacion de la opinion por Experto.",
col.names = "Peso Normalizacion",
align = "c",
digits = 4
) %>%
kable_classic(html_font = "Times New Roman",
font_size = 14) %>%
row_spec(0, bold = T)| Peso Normalizacion | |
|---|---|
| w_X1 | 0.6108 |
| w_X2 | 0.1982 |
| w_X3 | 0.1157 |
| w_X4 | 0.0752 |
Numeral 2.2
Si el experto 1 se pondera con 0.25, el experto 2 con 0.35 y el experto 3 con 0.4
ponderacion_expertos_distintas <-
(pesos_normalizados_1@weights * 0.25)*100 +
(pesos_normalizados_2@weights * 0.35)*100 +
(pesos_normalizados_3@weights * 0.40)*100
ponderacion_expertos_distintas %>%
kable(
caption = "**Tabla X:** Peso Bruto con Diferente ponderacion de la opinion por Experto.",
col.names = "Peso Bruto",
align = "c",
digits = 2
) %>%
kable_classic(html_font = "Times New Roman",
font_size = 14) %>%
row_spec(0, bold = T)| Peso Bruto | |
|---|---|
| w_X1 | 61.16 |
| w_X2 | 19.44 |
| w_X3 | 11.92 |
| w_X4 | 7.48 |
# Verificando
sum(ponderacion_expertos_distintas)## [1] 100normalizacion_final <-
(ponderacion_expertos_distintas / sum(ponderacion_expertos_distintas))*100
#Verificando
sum(normalizacion_final)## [1] 100normalizacion_final %>%
kable(
caption = "**Tabla 16:** Peso Normalizado con Diferente ponderacion de la opinion por Experto.",
col.names = "Peso Normalizacion",
align = "c",
digits = 2
) %>%
kable_classic(html_font = "Times New Roman",
font_size = 14) %>%
row_spec(0, bold = T)| Peso Normalizacion | |
|---|---|
| w_X1 | 61.16 |
| w_X2 | 19.44 |
| w_X3 | 11.92 |
| w_X4 | 7.48 |
Agrego nota
Para esta practica no le consulte nada Ademir debido a que investigaba o consultaba con alguna compañera y si aún asi no podia solucionar mi problema le consultaria pero logre resolver mis dudas esta es la entrega de las dos claves con mis soluciones
“Si no puedes volar corre.Si no puedes correr , camina. Si no puedes caminar, gatea.Pero hagas lo que hagas, siempre sigue hacia adelante.”