CLAVE A

Desarrolle el siguiente ejercicio:

Se necesita construir un indicador multivariado sintético, que mida la “Seguridad Municipal” Para ello se dispone de la siguiente información:

Variable y Correlación con la variable compleja

X1 % de Negocios victimizados durante el año por - robo o hurto positiva

X2 % de Negocios victimizados durante el año - extorsión o secuestro positiva

X3 % de Negocios que consideran que el crimen fue mayor en el año actual comparado con el año anterior positiva

X4 % de Negocios que consideran que el crimen local es mayor que en los municipios vecinos negativa

X5 Erogaciones municipales per cápita en seguridad pública (US$) positiva

X6 Costo del crimen a negocios por cada US$1,000 de ventas durante el año previo negativa

X7 % de Negocios que califican a la municipalidad como buena en prevención y control del delito positiva

X8 % de Negocios que consideran que la calidad del alumbrado público es adecuada para la seguridad de los negocios en el municipio positiva

Ejercicio 1.

A través del análisis de componentes principales, identifique para un modelo de 3 factores:

a. Los ponderadores normalizados para cada factor.

load("C:/Users/erick/Downloads/data_parcial_2_A_rev.RData")

library(kableExtra)
mat_X<-datos_parcial_2
mat_x1<-mat_X[,c(-1,-2)]
mat_x1 %>% head() %>% 
  kable(caption ="Matriz de información:" ,align = "c",digits = 6) %>% 
  kable_material(html_font = "sans-serif")

Matriz de información:
X1	X2	X3	X4	X5	X6	X7	X8
9	2	20.00000	20.00000	0.00000	0.000000	2	56.4000
10	6	62.50000	50.00000	37.50000	3.947368	11	147.3750
10	20	50.00000	50.00000	50.00000	2.564103	16	135.0000
8	3	42.85714	42.85714	14.28571	1.351351	35	121.1429
7	7	75.00000	75.00000	75.00000	9.090909	8	202.5000
6	13	30.00000	30.00000	30.00000	8.108108	25	81.0000

Normalización de los datos

library(dplyr)

## 
## Attaching package: 'dplyr'

## The following object is masked from 'package:kableExtra':
## 
##     group_rows

## The following objects are masked from 'package:stats':
## 
##     filter, lag

## The following objects are masked from 'package:base':
## 
##     intersect, setdiff, setequal, union

norm_directa<-function(x){(x-min(x))/(max(x)-min(x))}
norm_inversa<-function(x){(max(x)-x)/(max(x)-min(x))}
#Seleccionando las variables con correlación positiva para la Salud Financiera
mat_x1 %>% 
  select(X1,X2,X3,X5,X6,X8) %>% 
  apply(MARGIN = 2,FUN = norm_directa) %>% as.data.frame()->variables_corr_positiva
#Seleccionando las variables con correlación negativa para la Salud Financiera
mat_x1 %>% 
  select(X4,X7) %>% 
  apply(MARGIN = 2,FUN = norm_inversa) %>% as.data.frame()->variables_corr_negativa
#Juntando y reordenando las variables
variables_corr_positiva %>% 
  bind_cols(variables_corr_negativa) %>% 
  select(X1,X2,X3,X4,X5,X6,X7,X8)->datos_normalizados
head(datos_normalizados)

##           X1          X2        X3        X4        X5         X6        X7
## 1 0.19354839 0.000000000 0.0400000 0.8000000 0.0000000 0.00000000 1.0000000
## 2 0.22580645 0.017167382 0.5500000 0.5000000 0.4285714 0.21558704 0.9010989
## 3 0.22580645 0.077253219 0.4000000 0.5000000 0.5714286 0.14003945 0.8461538
## 4 0.16129032 0.004291845 0.3142857 0.5714286 0.1632653 0.07380457 0.6373626
## 5 0.12903226 0.021459227 0.7000000 0.2500000 0.8571429 0.49650350 0.9340659
## 6 0.09677419 0.047210300 0.1600000 0.7000000 0.3428571 0.44282744 0.7472527
##          X8
## 1 0.1582266
## 2 0.5167488
## 3 0.4679803
## 4 0.4133709
## 5 0.7339901
## 6 0.2551724

Matriz de Correlación & Pruebas de Barlett y KMO

#Matriz de correlación
library(PerformanceAnalytics)
chart.Correlation(as.matrix(datos_normalizados),histogram = TRUE,pch=12)

Hay una evidente correlación entre las variables propuestas en la batería de indicadores, se puede ver esto por los asteriscos.Varias de las correlaciones son significativas al 1%

#KMO
library(rela)
KMO<-paf(as.matrix(datos_normalizados))$KMO
print(KMO)

## [1] 0.67931

El valor mínimo de KMO para considerar aceptable el análisis factorial es de 0.5 y la base de datos tiene el 0.68, por lo tal es apropiado continuar con el análisis.

#Prueba de Barlett
library(psych)
options(scipen = 99999)
Barlett<-cortest.bartlett(datos_normalizados)

## R was not square, finding R from data

print(Barlett)

## $chisq
## [1] 1025.9
## 
## $p.value
## [1] 0.0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000046951
## 
## $df
## [1] 28

El P-value es casi 0, quiere decir que no se rechaza la hipótesis alternativa, hay evidencia de correlación poblacional entre la batería de indicadores propuestas.

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/ve3WBa

library(kableExtra)

Rx1<-cor(datos_normalizados)
PC1<-princomp(x = datos_normalizados,cor = TRUE,fix_sign = FALSE)
variables_pca1<-get_pca_var(PC1)
factoextra::get_eig(PC1) %>% kable(caption="Resumen de PCA",
        align = "c",
        digits = 2) %>% 
  kable_material(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("hover"))

Resumen de PCA
	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

Según esto se puede ver la cantidad de factores a retener:

Por el criterio de raíz latente: tendríamos 2 componentes.

Por el criterio de porcentaje acumulado de la varianza: tedríamos tres componentes ya que esas 3 son superior a las 3 cuartas partes de la varianza total.

fviz_eig(PC1,
         choice = "eigenvalue",
         barcolor = "red",
         barfill = "red",
         addlabels = TRUE, 
       )+labs(title = "Gráfico de Sedimentación",subtitle = "Usando princomp, con Autovalores")+
  xlab(label = "Componentes")+
  ylab(label = "Autovalores")+geom_hline(yintercept = 1)

Por este criterio se puede observar que el punto de quiebre ocurre en los primeros dos. Los criterios de extracción se mantienen entre 2 y 3 factores.

library(corrplot)

## corrplot 0.92 loaded

#Modelo de 3 Factores (Rotada)
numero_de_factores1<-3
modelo_factores1<-principal(r = Rx1,
                             nfactors = numero_de_factores1,
                             covar = FALSE,
                             rotate = "varimax")
modelo_factores1

## Principal Components Analysis
## Call: principal(r = Rx1, nfactors = numero_de_factores1, rotate = "varimax", 
##     covar = FALSE)
## Standardized loadings (pattern matrix) based upon correlation matrix
##      RC1   RC2   RC3   h2     u2 com
## X1 -0.16  0.80 -0.03 0.67 0.3316 1.1
## X2  0.08  0.84 -0.03 0.71 0.2879 1.0
## X3  0.93 -0.09  0.28 0.95 0.0493 1.2
## X4 -0.95  0.05 -0.26 0.98 0.0208 1.2
## X5  0.43 -0.06  0.80 0.83 0.1742 1.5
## X6  0.25 -0.03  0.91 0.89 0.1142 1.2
## X7  0.07 -0.83  0.04 0.69 0.3107 1.0
## X8  0.96 -0.06  0.27 0.99 0.0087 1.2
## 
##                        RC1  RC2  RC3
## SS loadings           2.97 2.05 1.68
## Proportion Var        0.37 0.26 0.21
## Cumulative Var        0.37 0.63 0.84
## Proportion Explained  0.44 0.31 0.25
## Cumulative Proportion 0.44 0.75 1.00
## 
## Mean item complexity =  1.2
## Test of the hypothesis that 3 components are sufficient.
## 
## The root mean square of the residuals (RMSR) is  0.06 
## 
## Fit based upon off diagonal values = 0.98

Al hacerlo con 3 factores, en la primer variable, el 0.67% de su varianza es explicada por la solución. La segunda variable, el 0.71% de su varianza es explicada por la extracción. De la tercer variable, el 0.95 de su varianza es explicada. Entonces es una solución representativa de los datos originales.

En los ponderadores que se han extraído, la primera variable que se construya va a tener un ponderador de 0.44, la segunda de 0.31 y la tercera de 0.25.

b. Las variables incluidas en cada factor.

correlaciones_modelo1<-variables_pca1$coord
rotacion1<-varimax(correlaciones_modelo1[,1:numero_de_factores1])
correlaciones_modelo_rotada1<-rotacion1$loadings

corrplot(correlaciones_modelo_rotada1[,1:numero_de_factores1],
         is.corr = FALSE,
         method = "square",
         addCoef.col="grey",
         number.cex = 0.75)

La dimensión 1, está representada con X3, X4 y X8. La dimensión 2 está más asociada con X1, X2 y X7. La dimensión 3 está más asociada con X5 y X6.

library(kableExtra)
cargas1<-rotacion1$loadings[1:8,1:numero_de_factores1]
ponderadores1<-prop.table(apply(cargas1^2,MARGIN = 2,sum))
t(ponderadores1) %>% 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"))

Ponderadores de los Factores Extraídos
Dim.1	Dim.2	Dim.3
0.44	0.31	0.25

Al factor 1 se le debe asignar un peso del 44%, al factor 2 un peso del 31% y al factor 3 un 25%.

contribuciones1<-apply(cargas1^2,MARGIN = 2,prop.table)
contribuciones1 %>% 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"))

Contribución de las variables en los Factores
	Dim.1	Dim.2	Dim.3
X1	0.01	0.31	0.00
X2	0.00	0.34	0.00
X3	0.29	0.00	0.05
X4	0.31	0.00	0.04
X5	0.06	0.00	0.38
X6	0.02	0.00	0.49
X7	0.00	0.33	0.00
X8	0.31	0.00	0.04

Ejercicio 2

Para el factor 1, utilice el método CRITIC para obtener los ponderadores normalizados para cada variable.

Método Critic

library(dplyr)
# Funciones para normalizar los datos
norm_directa_a <- function(x){
  return((x-min(x)) / (max(x)-min(x)))
}

norm_inverza_a <- function(x){
  return((max(x)-x) / (max(x)-min(x)))
}

# Normalización de los datos
mat_x1 %>% dplyr::select(X3,X4,X8) %>% 
  dplyr::transmute(X3 = norm_directa_a(X3),
                   X4 = norm_inverza_a(X4), 
                   X8 = norm_directa_a(X8)) -> data_factor_1
print(data_factor_1)

## # A tibble: 108 × 3
##       X3    X4    X8
##    <dbl> <dbl> <dbl>
##  1 0.04  0.8   0.158
##  2 0.55  0.5   0.517
##  3 0.4   0.5   0.468
##  4 0.314 0.571 0.413
##  5 0.7   0.25  0.734
##  6 0.16  0.7   0.255
##  7 0.673 0.273 0.714
##  8 0.55  0.5   0.446
##  9 0.4   0.563 0.433
## 10 0.68  0.467 0.552
## # … with 98 more rows

#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)

## # A tibble: 1 × 3
##      S3    S4    S8
##   <dbl> <dbl> <dbl>
## 1 0.246 0.201 0.209

#Cálculo de la matriz de correlación

cor(data_factor_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->vj1
print(vj1)

##        S3      S4      S8
## 1 0.48755 0.79129 0.42517

#Cálculo de los ponderadores netos

vj1/sum(vj1)->wj1
print(wj1)

##        S3      S4      S8
## 1 0.28612 0.46437 0.24951

#Ponderadores:
print(round(wj1*100,2))

##      S3    S4    S8
## 1 28.61 46.44 24.95

Ejercicio 3

Para el factor 2, utilice el método de Entropía para obtener los ponderadores normalizados para cada variable.

Método Entropía

mat_x1 %>% dplyr::select(X1,X2,X7)->data_norm1
apply(data_norm1,2,prop.table)->data_norm1
print(data_norm1)

##               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
##   [7,] 0.0095486 0.00318302 0.0062937
##   [8,] 0.0078125 0.00106101 0.0041958
##   [9,] 0.0086806 0.00141468 0.0034965
##  [10,] 0.0104167 0.00212202 0.0041958
##  [11,] 0.0112847 0.00141468 0.0020979
##  [12,] 0.0095486 0.00070734 0.0062937
##  [13,] 0.0104167 0.00424403 0.0013986
##  [14,] 0.0147569 0.00141468 0.0027972
##  [15,] 0.0086806 0.00636605 0.0160839
##  [16,] 0.0104167 0.00070734 0.0048951
##  [17,] 0.0078125 0.00141468 0.0125874
##  [18,] 0.0060764 0.00247569 0.0125874
##  [19,] 0.0069444 0.00318302 0.0027972
##  [20,] 0.0095486 0.00282935 0.0153846
##  [21,] 0.0104167 0.00707339 0.0097902
##  [22,] 0.0095486 0.00565871 0.0013986
##  [23,] 0.0095486 0.00176835 0.0111888
##  [24,] 0.0060764 0.01061008 0.0209790
##  [25,] 0.0069444 0.00565871 0.0027972
##  [26,] 0.0086806 0.00636605 0.0048951
##  [27,] 0.0104167 0.00565871 0.0062937
##  [28,] 0.0052083 0.01061008 0.0111888
##  [29,] 0.0086806 0.06825818 0.0020979
##  [30,] 0.0095486 0.00141468 0.0069930
##  [31,] 0.0086806 0.00070734 0.0013986
##  [32,] 0.0043403 0.00141468 0.0027972
##  [33,] 0.0112847 0.01237843 0.0069930
##  [34,] 0.0069444 0.00141468 0.0055944
##  [35,] 0.0060764 0.00106101 0.0048951
##  [36,] 0.0190972 0.00813439 0.0076923
##  [37,] 0.0086806 0.00212202 0.0034965
##  [38,] 0.0078125 0.00353669 0.0090909
##  [39,] 0.0078125 0.01591512 0.0027972
##  [40,] 0.0078125 0.00282935 0.0013986
##  [41,] 0.0095486 0.00282935 0.0034965
##  [42,] 0.0095486 0.00353669 0.0076923
##  [43,] 0.0052083 0.00070734 0.0139860
##  [44,] 0.0112847 0.00176835 0.0034965
##  [45,] 0.0069444 0.04244032 0.0209790
##  [46,] 0.0069444 0.00070734 0.0013986
##  [47,] 0.0086806 0.00141468 0.0027972
##  [48,] 0.0060764 0.00106101 0.0020979
##  [49,] 0.0086806 0.00353669 0.0069930
##  [50,] 0.0086806 0.00389036 0.0027972
##  [51,] 0.0069444 0.00070734 0.0013986
##  [52,] 0.0052083 0.00389036 0.0076923
##  [53,] 0.0121528 0.00282935 0.0027972
##  [54,] 0.0052083 0.00070734 0.0062937
##  [55,] 0.0130208 0.00159151 0.0209790
##  [56,] 0.0095486 0.00106101 0.0020979
##  [57,] 0.0052083 0.00459770 0.0650350
##  [58,] 0.0182292 0.00070734 0.0041958
##  [59,] 0.0095486 0.00070734 0.0013986
##  [60,] 0.0104167 0.00176835 0.0048951
##  [61,] 0.0069444 0.00247569 0.0125874
##  [62,] 0.0295139 0.08311229 0.0650350
##  [63,] 0.0078125 0.00070734 0.0097902
##  [64,] 0.0104167 0.06825818 0.0440559
##  [65,] 0.0069444 0.00707339 0.0034965
##  [66,] 0.0104167 0.01061008 0.0020979
##  [67,] 0.0086806 0.06790451 0.0118881
##  [68,] 0.0086806 0.00459770 0.0209790
##  [69,] 0.0104167 0.00565871 0.0069930
##  [70,] 0.0052083 0.00070734 0.0111888
##  [71,] 0.0104167 0.01591512 0.0013986
##  [72,] 0.0086806 0.00318302 0.0195804
##  [73,] 0.0086806 0.00212202 0.0041958
##  [74,] 0.0078125 0.00070734 0.0013986
##  [75,] 0.0112847 0.00212202 0.0041958
##  [76,] 0.0086806 0.00212202 0.0020979
##  [77,] 0.0086806 0.06790451 0.0013986
##  [78,] 0.0086806 0.00247569 0.0041958
##  [79,] 0.0086806 0.00106101 0.0027972
##  [80,] 0.0069444 0.00636605 0.0125874
##  [81,] 0.0078125 0.01061008 0.0209790
##  [82,] 0.0295139 0.08311229 0.0650350
##  [83,] 0.0060764 0.06861185 0.0034965
##  [84,] 0.0095486 0.00070734 0.0013986
##  [85,] 0.0086806 0.00176835 0.0034965
##  [86,] 0.0060764 0.00070734 0.0013986
##  [87,] 0.0052083 0.00106101 0.0027972
##  [88,] 0.0130208 0.00176835 0.0062937
##  [89,] 0.0086806 0.00070734 0.0013986
##  [90,] 0.0138889 0.00212202 0.0069930
##  [91,] 0.0078125 0.00176835 0.0062937
##  [92,] 0.0043403 0.00141468 0.0013986
##  [93,] 0.0034722 0.00141468 0.0020979
##  [94,] 0.0121528 0.05057471 0.0027972
##  [95,] 0.0078125 0.00141468 0.0048951
##  [96,] 0.0199653 0.00247569 0.0048951
##  [97,] 0.0086806 0.00141468 0.0027972
##  [98,] 0.0078125 0.00247569 0.0048951
##  [99,] 0.0095486 0.00282935 0.0440559
## [100,] 0.0295139 0.08311229 0.0650350
## [101,] 0.0060764 0.00106101 0.0034965
## [102,] 0.0052083 0.00141468 0.0020979
## [103,] 0.0104167 0.00106101 0.0013986
## [104,] 0.0104167 0.00565871 0.0020979
## [105,] 0.0060764 0.00070734 0.0013986
## [106,] 0.0104167 0.00636605 0.0125874
## [107,] 0.0026042 0.00282935 0.0111888
## [108,] 0.0095486 0.00212202 0.0020979

#Fórmula de entropía
entropy<-function(x){
  return(x*log(x))
}
apply(data_norm1,2,entropy)->data_norm_2
print(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
##   [7,] -0.044414 -0.0183021 -0.031898
##   [8,] -0.037906 -0.0072664 -0.022966
##   [9,] -0.041204 -0.0092815 -0.019776
##  [10,] -0.047545 -0.0130618 -0.022966
##  [11,] -0.050604 -0.0092815 -0.012937
##  [12,] -0.044414 -0.0051310 -0.031898
##  [13,] -0.047545 -0.0231819 -0.009192
##  [14,] -0.062216 -0.0092815 -0.016445
##  [15,] -0.041204 -0.0321917 -0.066426
##  [16,] -0.047545 -0.0051310 -0.026040
##  [17,] -0.037906 -0.0092815 -0.055071
##  [18,] -0.031010 -0.0148572 -0.055071
##  [19,] -0.034513 -0.0183021 -0.016445
##  [20,] -0.044414 -0.0166018 -0.064221
##  [21,] -0.047545 -0.0350233 -0.045293
##  [22,] -0.044414 -0.0292813 -0.009192
##  [23,] -0.044414 -0.0112073 -0.050270
##  [24,] -0.031010 -0.0482329 -0.081068
##  [25,] -0.034513 -0.0292813 -0.016445
##  [26,] -0.041204 -0.0321917 -0.026040
##  [27,] -0.047545 -0.0292813 -0.031898
##  [28,] -0.027383 -0.0482329 -0.050270
##  [29,] -0.041204 -0.1832362 -0.012937
##  [30,] -0.044414 -0.0092815 -0.034705
##  [31,] -0.041204 -0.0051310 -0.009192
##  [32,] -0.023610 -0.0092815 -0.016445
##  [33,] -0.050604 -0.0543636 -0.034705
##  [34,] -0.034513 -0.0092815 -0.029013
##  [35,] -0.031010 -0.0072664 -0.026040
##  [36,] -0.075591 -0.0391399 -0.037443
##  [37,] -0.041204 -0.0130618 -0.019776
##  [38,] -0.037906 -0.0199631 -0.042732
##  [39,] -0.037906 -0.0658963 -0.016445
##  [40,] -0.037906 -0.0166018 -0.009192
##  [41,] -0.044414 -0.0166018 -0.019776
##  [42,] -0.044414 -0.0199631 -0.037443
##  [43,] -0.027383 -0.0051310 -0.059716
##  [44,] -0.050604 -0.0112073 -0.019776
##  [45,] -0.034513 -0.1340968 -0.081068
##  [46,] -0.034513 -0.0051310 -0.009192
##  [47,] -0.041204 -0.0092815 -0.016445
##  [48,] -0.031010 -0.0072664 -0.012937
##  [49,] -0.041204 -0.0199631 -0.034705
##  [50,] -0.041204 -0.0215886 -0.016445
##  [51,] -0.034513 -0.0051310 -0.009192
##  [52,] -0.027383 -0.0215886 -0.037443
##  [53,] -0.053596 -0.0166018 -0.016445
##  [54,] -0.027383 -0.0051310 -0.031898
##  [55,] -0.056526 -0.0102542 -0.081068
##  [56,] -0.044414 -0.0072664 -0.012937
##  [57,] -0.027383 -0.0247457 -0.177730
##  [58,] -0.073003 -0.0051310 -0.022966
##  [59,] -0.044414 -0.0051310 -0.009192
##  [60,] -0.047545 -0.0112073 -0.026040
##  [61,] -0.034513 -0.0148572 -0.055071
##  [62,] -0.103974 -0.2067470 -0.177730
##  [63,] -0.037906 -0.0051310 -0.045293
##  [64,] -0.047545 -0.1832362 -0.137556
##  [65,] -0.034513 -0.0350233 -0.019776
##  [66,] -0.047545 -0.0482329 -0.012937
##  [67,] -0.041204 -0.1826396 -0.052691
##  [68,] -0.041204 -0.0247457 -0.081068
##  [69,] -0.047545 -0.0292813 -0.034705
##  [70,] -0.027383 -0.0051310 -0.050270
##  [71,] -0.047545 -0.0658963 -0.009192
##  [72,] -0.041204 -0.0183021 -0.077014
##  [73,] -0.041204 -0.0130618 -0.022966
##  [74,] -0.037906 -0.0051310 -0.009192
##  [75,] -0.050604 -0.0130618 -0.022966
##  [76,] -0.041204 -0.0130618 -0.012937
##  [77,] -0.041204 -0.1826396 -0.009192
##  [78,] -0.041204 -0.0148572 -0.022966
##  [79,] -0.041204 -0.0072664 -0.016445
##  [80,] -0.034513 -0.0321917 -0.055071
##  [81,] -0.037906 -0.0482329 -0.081068
##  [82,] -0.103974 -0.2067470 -0.177730
##  [83,] -0.031010 -0.1838310 -0.019776
##  [84,] -0.044414 -0.0051310 -0.009192
##  [85,] -0.041204 -0.0112073 -0.019776
##  [86,] -0.031010 -0.0051310 -0.009192
##  [87,] -0.027383 -0.0072664 -0.016445
##  [88,] -0.056526 -0.0112073 -0.031898
##  [89,] -0.041204 -0.0051310 -0.009192
##  [90,] -0.059398 -0.0130618 -0.034705
##  [91,] -0.037906 -0.0112073 -0.031898
##  [92,] -0.023610 -0.0092815 -0.009192
##  [93,] -0.019663 -0.0092815 -0.012937
##  [94,] -0.053596 -0.1509303 -0.016445
##  [95,] -0.037906 -0.0092815 -0.026040
##  [96,] -0.078139 -0.0148572 -0.026040
##  [97,] -0.041204 -0.0092815 -0.016445
##  [98,] -0.037906 -0.0148572 -0.026040
##  [99,] -0.044414 -0.0166018 -0.137556
## [100,] -0.103974 -0.2067470 -0.177730
## [101,] -0.031010 -0.0072664 -0.019776
## [102,] -0.027383 -0.0092815 -0.012937
## [103,] -0.047545 -0.0072664 -0.009192
## [104,] -0.047545 -0.0292813 -0.012937
## [105,] -0.031010 -0.0051310 -0.009192
## [106,] -0.047545 -0.0321917 -0.055071
## [107,] -0.015496 -0.0166018 -0.050270
## [108,] -0.044414 -0.0130618 -0.012937

#Número de variables en el factor:
ncol(data_norm1)->m1
#Constante de entropía:
-1/log(m1)->K1
print(K1)

## [1] -0.91024

#Cálculo de las entropías
K1*colSums(data_norm_2)->Ej2
print(Ej2)

##     X1     X2     X7 
## 4.1805 3.2029 3.7019

#Cálculo de las especificidades:
1-Ej2->vj2
print(vj2)

##      X1      X2      X7 
## -3.1805 -2.2029 -2.7019

#Cálculo de los ponderadores:
prop.table(vj2)->wj2 #es igual a usar vj/sum(vj)
print(wj2)

##      X1      X2      X7 
## 0.39337 0.27245 0.33417

Ejercicio 4

Para el factor 3, utilice el método de Ranking para obtener los ponderadores normalizados para cada variable (utilice la numeración de las variables para establecer la jerarquía).

Por Suma

library(magrittr)
#Vector de Jerarquías
rj1<-c(1,2)
names(rj1)<-c("X5","X6")

#Función para generar los pesos
ponderadores_subjetivos_rank_suma<-function(vector_jerarquias){
  n<-length(vector_jerarquias)
  vector_pesos<-n-vector_jerarquias+1
  list(w_brutos=vector_pesos,w_normalizados=vector_pesos/sum(vector_pesos))
}
#Aplicando la función:
pesos_ranking_suma1<-ponderadores_subjetivos_rank_suma(rj1)

#Pesos brutos
pesos_ranking_suma1$w_brutos

## X5 X6 
##  2  1

#Pesos normalizados
pesos_ranking_suma1$w_normalizados %>% round(digits = 3)

##    X5    X6 
## 0.667 0.333

#Gráfico de los pesos normalizados
barplot(pesos_ranking_suma1$w_normalizados,
        main = "Ponderadores Ranking de Suma",
        ylim = c(0,0.5),col = "red")

Jerarquía Reciproca

#Vector de Jerarquías
rj2<-c(1,2)
names(rj2)<-c("X5","X6")

#Función para generar los pesos
ponderadores_subjetivos_rank_reciproco<-function(vector_jerarquias){
  vector_pesos<-1/vector_jerarquias
  list(w_brutos=vector_pesos,w_normalizados=vector_pesos/sum(vector_pesos))
}
#Aplicando la función:
pesos_ranking_reciproco1<-ponderadores_subjetivos_rank_reciproco(rj2)

#Pesos brutos
pesos_ranking_reciproco1$w_brutos

##  X5  X6 
## 1.0 0.5

#Pesos normalizados
pesos_ranking_reciproco1$w_normalizados %>% round(digits = 3)

##    X5    X6 
## 0.667 0.333

#Gráfico de los pesos normalizados
barplot(pesos_ranking_reciproco1$w_normalizados,
        main = "Ponderadores Ranking Recíproco",
        ylim = c(0,0.5),col = "green")

Jerarquía Exponencial

library(magrittr)
#Vector de Jerarquías
rj3<-c(1,2)
names(rj3)<-c("X5","X6")

#Función para generar los pesos
ponderadores_subjetivos_rank_exponencial<-function(vector_jerarquias,p=2){
  n<-length(vector_jerarquias)
  vector_pesos<-(n-vector_jerarquias+1)^p
  list(w_brutos=vector_pesos,w_normalizados=vector_pesos/sum(vector_pesos))
}
#Aplicando la función:
pesos_ranking_exponencial1<-ponderadores_subjetivos_rank_exponencial(rj3)

#Pesos brutos
pesos_ranking_exponencial1$w_brutos

## X5 X6 
##  4  1

#Pesos normalizados
pesos_ranking_exponencial1$w_normalizados %>% round(digits = 3)

##  X5  X6 
## 0.8 0.2

#Gráfico de los pesos normalizados (por default p=2)
barplot(pesos_ranking_suma1$w_normalizados,
        main = "Ponderadores Ranking Exponencial",
        ylim = c(0,0.5),col = "coral")

#Comparación de valores de "p"

par(mfrow=c(1,3))
for(p in 2:4){
  
  pesos<-ponderadores_subjetivos_rank_exponencial(vector_jerarquias = rj1,p = p)
  barplot(pesos$w_normalizados,main = paste0("p=",p),ylim = c(0,0.7),col = "coral",cex.main=3,cex.axis = 3)
}

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.

Todas las varibles se encuentran el archivo data_parcial_2_B.Rdata

Todas los indicadores se encuentran el archivo data_parcial_2_B.Rdata

Usando Análisis Factorial determine cuántos factores deberían retenerse.

¿Qué variables quedan representadas en cada factor?

Determine qué pesos deben asignarse a cada factor y a las variables dentro de cada uno de ellos.

load("C:/Users/erick/Downloads/data_parcial_2_B_rev.RData")

library(kableExtra)
mat_X2<-data_parcial_2
mat_x2<-mat_X2[,-1]
mat_x2 %>% head() %>% 
  kable(caption ="Matriz de información:" ,align = "c",digits = 6) %>% 
  kable_material(html_font = "sans-serif")

Matriz de información:
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
7400	86.0	54	Musulma.	75	67	98	1.40	35.0	3000	5	NA	NA	23	7	NA	3.4771	NA	3.2857	2.80	3.8692	18	100	100	3
20500	25.0	18	Musulma.	44	45	29	2.80	168.0	205	3	NA	0	53	22	0.000000	2.3118	0.00000	2.4091	6.90	4.3118	12	44	14	3
81200	227.0	85	Protest.	79	73	99	0.36	6.5	17539	1	3443	11179	11	11	13.767241	4.2440	1.68954	1.0000	1.47	4.9096	34	NA	NA	8
18000	7.7	77	Musulma.	70	66	62	3.20	52.0	6651	5	2874	61	38	6	0.338889	3.8229	0.80540	6.3333	6.67	4.2553	1	73	48	1
33900	12.0	86	Católica	75	68	95	1.30	25.6	3408	6	3113	3904	20	9	11.516224	3.5325	1.63028	2.2222	2.80	4.5302	9	96	95	8
3700	126.0	68	Ortodoxa	75	68	98	1.40	27.0	5000	5	NA	2	23	6	0.054054	3.6990	0.55791	3.8333	3.19	3.5682	17	100	100	NA

library(dplyr)
library(tidyr)

## 
## Attaching package: 'tidyr'

## The following object is masked from 'package:magrittr':
## 
##     extract

norm_directa<-function(x){(x-min(x))/(max(x)-min(x))}
norm_inversa<-function(x){(max(x)-x)/(max(x)-min(x))}

mat_x2 %>% replace_na(list(ALFABET = 0, INC_POB = 0, ESPVIDAF = 0, MORTINF = 0, FERTILID = 0, TASA_NAT = 0, LOG_PIB = 0, URBANA = 0, TASA_MOR = 0)) -> data_parcial2

# Seleccionando las variables con correlación positiva para el Desarrollo en las Economías
data_parcial2 %>% 
  select(ALFABET, INC_POB, ESPVIDAF, FERTILID, TASA_NAT, LOG_PIB, URBANA) %>% 
  apply(MARGIN = 2,FUN = norm_directa) %>% as.data.frame() -> variables_corr_positiva
# Seleccionando las variables con correlación negativa para el Desarrollo en las Economías
data_parcial2 %>% 
  select(MORTINF, TASA_MOR) %>% 
  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(ALFABET, INC_POB, ESPVIDAF, MORTINF, FERTILID, TASA_NAT, LOG_PIB, URBANA, TASA_MOR) -> datos_desarrollo_normalizados
datos_desarrollo_normalizados %>% head() %>% 
  kable(caption = "Datos normalizados", 
        align = "c") %>%
  kable_material(html_font = "Time New Roman")

Datos normalizados
ALFABET	INC_POB	ESPVIDAF	MORTINF	FERTILID	TASA_NAT	LOG_PIB	URBANA	TASA_MOR
0.98	0.30686	0.82051	0.81098	0.34188	0.30233	0.60885	0.54	0.70833
0.29	0.55957	0.02564	0.00000	0.84249	1.00000	0.09867	0.18	0.08333
0.99	0.11913	0.92308	0.98476	0.17949	0.02326	0.94458	0.85	0.54167
0.62	0.63177	0.69231	0.70732	0.81441	0.65116	0.76023	0.77	0.75000
0.95	0.28881	0.82051	0.86829	0.34188	0.23256	0.63310	0.86	0.62500
0.98	0.30686	0.82051	0.85976	0.38950	0.30233	0.70598	0.68	0.75000

Matriz de Correlación & Pruebas de Barlett y KMO

#Matriz de correlación
library(PerformanceAnalytics)
chart.Correlation(as.matrix(datos_desarrollo_normalizados),histogram = TRUE,pch=12)

#KMO
library(rela)
KMO<-paf(as.matrix(datos_desarrollo_normalizados))$KMO
print(KMO)

## [1] 0.85275

El valor mínimo para considerar aceptable el análisis factorial es de 0.5 y la base de datos tiene el 0.85275, podemos considerar que es adecuado hacer el análisis.

#Prueba de Barlett
library(psych)
options(scipen = 99999)
Barlett<-cortest.bartlett(datos_desarrollo_normalizados)

## R was not square, finding R from data

print(Barlett)

## $chisq
## [1] 1478.1
## 
## $p.value
## [1] 0.000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000017846
## 
## $df
## [1] 36

El P-value es casi 0, quiere decir que se rechaza la hipótesis nula y no se rechaza la hipótesis alternativa, hay evidencia de correlación poblacional entre la batería de indicadores propuestas.

Análisis Factorial

library(FactoMineR)
library(factoextra)
library(kableExtra)

Rx2<-cor(datos_desarrollo_normalizados)
PC2<-princomp(x = datos_desarrollo_normalizados,cor = TRUE,fix_sign = FALSE)
variables_pca2<-get_pca_var(PC2)
factoextra::get_eig(PC2) %>% kable(caption="Resumen de PCA",
        align = "c",
        digits = 2) %>% 
  kable_material(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("hover"))

Resumen de 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

Podemos ver la cantidad de factores a retener:

Por el criterio de raíz latente: solamente tendríamos dos componentes ya que ambos superan la unidad con 6.45 y 1.24 respectivamente. Por el criterio de porcentaje acumulado de la varianza: también solo tedríamos dos componentes ya que ambos explican más del 75% de la varianza total.

fviz_eig(PC2,
         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)

Se puede observar que el punto de quiebre se da en el segundo componente. Por el momento los criterios de extracción se satisfacen o concluyen de la misma manera.

1.2) ¿Qué variables quedan representadas en cada factor?

library(corrplot)
#Modelo de 2 Factores (Rotada)
numero_de_factores2<-2
modelo_factores2<-principal(r = Rx2,
                             nfactors = numero_de_factores2,
                             covar = FALSE,
                             rotate = "varimax")
modelo_factores2

## Principal Components Analysis
## Call: principal(r = Rx2, nfactors = numero_de_factores2, 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
## MORTINF   0.65  0.71 0.92 0.075 2.0
## 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
## 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

La primer variable, el 0.74% de su varianza es explicada por la solución. La segunda variable tiene un 0.96% de su varianza explicada por la extracción. Entonces es una solución bastante representativa de los datos originales..

En los ponderadores que se han extraído, la primera variable va a tener un ponderador de 0.57 y otra de 0.43.

correlaciones_modelo2<-variables_pca2$coord
rotacion2<-varimax(correlaciones_modelo2[,1:numero_de_factores2])
correlaciones_modelo_rotada2<-rotacion2$loadings

corrplot(correlaciones_modelo_rotada2[,1:numero_de_factores2],
         is.corr = FALSE,
         method = "square",
         addCoef.col="grey",
         number.cex = 0.75)

Para el factor 1, está representado con ALFABET, INC_POB, FERTILID, TASA_NAT y LOG_PIB. El factor 2 está más asociado con ESPVIDAF, MORTINF, URBANA Y TASA_MOR.

1.3) Determine qué pesos deben asignarse a cada factor y a las variables dentro de cada uno de ellos.

library(kableExtra)
cargas2<-rotacion2$loadings[1:9,1:numero_de_factores2]
ponderadores2<-prop.table(apply(cargas2^2,MARGIN = 2,sum))
t(ponderadores2) %>% 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"))

Ponderadores de los Factores Extraídos
Dim.1	Dim.2
0.57	0.43

Al factor 1 se le debe asignar un peso del 57% y al factor 2 un peso del 43%.

contribuciones2<-apply(cargas2^2,MARGIN = 2,prop.table)
contribuciones2 %>% 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"))

Contribución de las variables en los Factores
	Dim.1	Dim.2
ALFABET	0.11	0.08
INC_POB	0.22	0.00
ESPVIDAF	0.09	0.17
MORTINF	0.10	0.15
FERTILID	0.17	0.05
TASA_NAT	0.19	0.05
LOG_PIB	0.09	0.10
URBANA	0.04	0.15
TASA_MOR	0.00	0.25

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:

Dentro de la consultora hay 3 expertos que propusieron la jerarquía anterior, pero también realizaron un ejercicio de comparación por pares y los resultados fueron los siguientes:

Ejercicio 1 [40%]: Calcule los pesos normalizados, de las variables, usando los métodos de ranking directo, por suma, por reciproco y por ranking exponencial (use p=4)

Por Suma

library(magrittr)
#Vector de Jerarquías
rj4<-c(3,4,2,1)
names(rj4)<-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(rj4)

#Pesos brutos
pesos_ranking_suma$w_brutos

## X1 X2 X3 X4 
##  2  1  3  4

#Pesos normalizados
pesos_ranking_suma$w_normalizados %>% round(digits = 3)

##  X1  X2  X3  X4 
## 0.2 0.1 0.3 0.4

#Gráfico de los pesos normalizados
barplot(pesos_ranking_suma$w_normalizados,
        main = "Ponderadores Ranking de Suma",
        ylim = c(0,0.5),col = "red")

Jerarquía Reciproca

library(magrittr)
#Vector de Jerarquías
rj5<-c(3,4,2,1)
names(rj5)<-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(rj5)

#Pesos brutos
pesos_ranking_reciproco$w_brutos

##      X1      X2      X3      X4 
## 0.33333 0.25000 0.50000 1.00000

#Pesos normalizados
pesos_ranking_reciproco$w_normalizados %>% round(digits = 3)

##   X1   X2   X3   X4 
## 0.16 0.12 0.24 0.48

#Gráfico de los pesos normalizados
barplot(pesos_ranking_reciproco$w_normalizados,
        main = "Ponderadores Ranking Recíproco",
        ylim = c(0,0.5),col = "green")

Jerarquía Exponencial

library(magrittr)
#Vector de Jerarquías
rj6<-c(3,4,2,1)
names(rj6)<-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(rj6)

#Pesos brutos
pesos_ranking_exponencial$w_brutos

##  X1  X2  X3  X4 
##  16   1  81 256

#Pesos normalizados
pesos_ranking_exponencial$w_normalizados %>% round(digits = 3)

##    X1    X2    X3    X4 
## 0.045 0.003 0.229 0.723

#Gráfico de los pesos normalizados (por default p=2)
barplot(pesos_ranking_suma$w_normalizados,
        main = "Ponderadores Ranking Exponencial",
        ylim = c(0,0.5),col = "coral")

#Comparación de valores de "p"

par(mfrow=c(1,3))
for(p in 2:4){
  
  pesos<-ponderadores_subjetivos_rank_exponencial(vector_jerarquias = rj6,p = p)
  barplot(pesos$w_normalizados,main = paste0("p=",p),ylim = c(0,0.7),col = "coral",cex.main=3,cex.axis = 3)
}

Ejercicio 2 Usando la técnica de comparación por pares, calcule los pesos normalizados para las variables:

Comparación por pares

library(FuzzyAHP)

## Loading required package: MASS

## 
## Attaching package: 'MASS'

## The following object is masked from 'package:dplyr':
## 
##     select

# Matriz_1
valores_matriz_comparacion_1 = c(1,7,4,5,
                                 NA,1,6,3,
                                 NA,NA,1,2,
                                 NA,NA,NA,1)
matriz_comparacion_1<-matrix(valores_matriz_comparacion_1,
                           nrow = 4, ncol = 4, byrow = TRUE)
matriz_comparacion_1<-pairwiseComparisonMatrix(matriz_comparacion_1)
matriz_comparacion_1@variableNames<-c("X1","X2","X3","X4")
show(matriz_comparacion_1)

## An object of class "PairwiseComparisonMatrix"
## Slot "valuesChar":
##      [,1]  [,2]  [,3]  [,4]
## [1,] "1"   "7"   "4"   "5" 
## [2,] "1/7" "1"   "6"   "3" 
## [3,] "1/4" "1/6" "1"   "2" 
## [4,] "1/5" "1/3" "1/2" "1" 
## 
## Slot "values":
##         [,1]    [,2] [,3] [,4]
## [1,] 1.00000 7.00000  4.0    5
## [2,] 0.14286 1.00000  6.0    3
## [3,] 0.25000 0.16667  1.0    2
## [4,] 0.20000 0.33333  0.5    1
## 
## Slot "variableNames":
## [1] "X1" "X2" "X3" "X4"

# Cálculo de los pesos:
pesos_normalizados_1 = calculateWeights(matriz_comparacion_1)
show(pesos_normalizados_1)

## An object of class "Weights"
## Slot "weights":
##     w_X1     w_X2     w_X3     w_X4 
## 0.606592 0.223310 0.094748 0.075350

barplot(pesos_normalizados_1@weights,
        main = "Ponderadores por método comparación de pares",
        ylim = c(0,0.7),col = "yellow")

# Matriz_2
valores_matriz_comparacion_2 = c(1,7,6,3,
                                 NA,1,5,2,
                                 NA,NA,1,4,
                                 NA,NA,NA,1)
matriz_comparacion_2<-matrix(valores_matriz_comparacion_2,
                           nrow = 4, ncol = 4, byrow = TRUE)
matriz_comparacion_2<-pairwiseComparisonMatrix(matriz_comparacion_2)
matriz_comparacion_2@variableNames<-c("X1","X2","X3","X4")
show(matriz_comparacion_2)

## An object of class "PairwiseComparisonMatrix"
## Slot "valuesChar":
##      [,1]  [,2]  [,3]  [,4]
## [1,] "1"   "7"   "6"   "3" 
## [2,] "1/7" "1"   "5"   "2" 
## [3,] "1/6" "1/5" "1"   "4" 
## [4,] "1/3" "1/2" "1/4" "1" 
## 
## Slot "values":
##         [,1] [,2] [,3] [,4]
## [1,] 1.00000  7.0 6.00    3
## [2,] 0.14286  1.0 5.00    2
## [3,] 0.16667  0.2 1.00    4
## [4,] 0.33333  0.5 0.25    1
## 
## Slot "variableNames":
## [1] "X1" "X2" "X3" "X4"

# Cálculo de los pesos:
pesos_normalizados_2 = calculateWeights(matriz_comparacion_2)
show(pesos_normalizados_2)

## An object of class "Weights"
## Slot "weights":
##    w_X1    w_X2    w_X3    w_X4 
## 0.60919 0.19879 0.10987 0.08215

barplot(pesos_normalizados_2@weights,
        main = "Ponderadores por método comparación de pares",
        ylim = c(0,0.7),col = "blue")

# Matriz_3
valores_matriz_comparacion_3 = c(1,7,5,4,
                                 NA,1,3,2,
                                 NA,NA,1,6,
                                 NA,NA,NA,1)
matriz_comparacion_3<-matrix(valores_matriz_comparacion_3,
                           nrow = 4, ncol = 4, byrow = TRUE)
matriz_comparacion_3<-pairwiseComparisonMatrix(matriz_comparacion_3)
matriz_comparacion_3@variableNames<-c("X1","X2","X3","X4")
show(matriz_comparacion_3)

## An object of class "PairwiseComparisonMatrix"
## Slot "valuesChar":
##      [,1]  [,2]  [,3]  [,4]
## [1,] "1"   "7"   "5"   "4" 
## [2,] "1/7" "1"   "3"   "2" 
## [3,] "1/5" "1/3" "1"   "6" 
## [4,] "1/4" "1/2" "1/6" "1" 
## 
## Slot "values":
##         [,1]    [,2]    [,3] [,4]
## [1,] 1.00000 7.00000 5.00000    4
## [2,] 0.14286 1.00000 3.00000    2
## [3,] 0.20000 0.33333 1.00000    6
## [4,] 0.25000 0.50000 0.16667    1
## 
## Slot "variableNames":
## [1] "X1" "X2" "X3" "X4"

# Cálculo de los pesos:
pesos_normalizados_3 = calculateWeights(matriz_comparacion_3)
show(pesos_normalizados_3)

## An object of class "Weights"
## Slot "weights":
##    w_X1    w_X2    w_X3    w_X4 
## 0.61676 0.17252 0.14259 0.06812

barplot(pesos_normalizados_3@weights,
        main = "Ponderadores por método comparación de pares",
        ylim = c(0,0.7),col = "pink")

2.1 Asumiendo que la opinión de los 3 expertos es igualmente válida.

library(kableExtra)
ponderacion_expertos <-1/3

pesos_total<-(pesos_normalizados_1@weights+pesos_normalizados_2@weights+
              pesos_normalizados_3@weights)

promedio_total<-ponderacion_expertos*pesos_total
show(promedio_total)

##     w_X1     w_X2     w_X3     w_X4 
## 0.610848 0.198207 0.115739 0.075207

sum(promedio_total)

## [1] 1

normalizacion_1<-promedio_total/sum(promedio_total)
show(normalizacion_1)

##     w_X1     w_X2     w_X3     w_X4 
## 0.610848 0.198207 0.115739 0.075207

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_diferentes<-(pesos_normalizados_1@weights*0.25)+(pesos_normalizados_2@weights*0.35)+(pesos_normalizados_3@weights*0.4)

show(ponderacion_expertos_diferentes)

##     w_X1     w_X2     w_X3     w_X4 
## 0.611569 0.194412 0.119180 0.074838

sum(ponderacion_expertos_diferentes)

## [1] 1

normalizacion_2<-ponderacion_expertos_diferentes/sum(ponderacion_expertos_diferentes)
show(normalizacion_2)

##     w_X1     w_X2     w_X3     w_X4 
## 0.611569 0.194412 0.119180 0.074838

Práctica Parcial 2

ERICK ALEXANDER HERRERA RUMALDO HR18008

2022-10-21