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)

Enunciado 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/lupita nieto/Downloads/data_parcial_2_A_rev.RData")
library(kableExtra)
matriz_X<-datos_parcial_2
matriz_X1<-matriz_X[,c(-1,-2)]
matriz_X1 %>% head() %>% 
  kable(caption ="Matriz de Referencia:" ,align = "c",digits = 6) %>% 
  kable_material(html_font = "sans-serif")
Matriz de Referencia:
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)
library(tidyr)
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
matriz_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
matriz_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
library(PerformanceAnalytics)
chart.Correlation(as.matrix(datos_normalizados),
                  histogram = TRUE,
                  pch = 12)

Verificación de supuestos: Prueba de Barlett y KMO

#Prueba KMO
library(rela)
KMO <- paf(as.matrix(datos_normalizados))$KMO
print(KMO)
## [1] 0.67931

Nuestro KMO es de 0.67 y el valor minimo para considerar aceptable el analisis factorial es de 0.5, por lo que nuestros datos son adecuados y podemos seguir con el análisis.

#Prueba Barlett
library(psych)
Barlett <- cortest.bartlett(datos_normalizados)
## R was not square, finding R from data
print(Barlett)
## $chisq
## [1] 1025.9
## 
## $p.value
## [1] 4.6951e-198
## 
## $df
## [1] 28

Podemos observar con los resultados de la prueba Barlett, podemos determinar que la H0 se rechaza, esto porque el p.value<0.05. Entonces decimos que existe correlacion entre la bateria de indicadores. Podemos realizar un analisis factorial.

Analisis Factorial

library(FactoMineR)
library(factoextra)
library(kableExtra)
Rx <- cor(datos_normalizados)
PC <- princomp(x = datos_normalizados, cor = TRUE, fix_sign = FALSE)
variables_pca <- get_pca_var(PC)
factoextra::get_eig(PC) %>% kable(caption="Resumen PCA",
        align = "c",
        digits = 2) %>% 
  kable_material(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("striped", "hover"))
Resumen 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

Gráfico de sedimentación

fviz_eig(
  PC,
  choice = "eigenvalue",
  barcolor = "yellow",
  barfill = "orange",
  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 ver que el punto de quiebre se da en los primeros dos componentes, y tomando en cuenta los datos del resumen de PCA, el criterio de extracción se mantienen entre 2 y 3 factores.

Variables representadas por factor

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

b. Las variables incluidas en cada factor.

correlaciones_modelo<-variables_pca$coord
rotacion<-varimax(correlaciones_modelo[,1:numero_factores])
correlaciones_modelo_rotada<-rotacion$loadings

corrplot(correlaciones_modelo_rotada[,1:numero_factores],
         is.corr = FALSE,
         method = "circle",
         addCoef.col="grey",
         number.cex = 0.75)

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

Asignacion de los pesos a cada factor y variables dentro de cada uno de ellos.

# Extracción de ponderadores 

library(kableExtra)
cargas <- rotacion$loadings[1:8, 1:numero_factores]
ponderadores <- prop.table(apply(cargas ^ 2, MARGIN = 2, sum))
t(ponderadores) %>% 
  kable(caption="Ponderadores De Los Factores Extraidos",
        align = "c",
        digits = 2) %>% 
  kable_material(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("striped", "hover"))
Ponderadores De Los Factores Extraidos
Dim.1 Dim.2 Dim.3
0.44 0.31 0.25

Los pesos a ser asignados en cada factor son: factor 1: peso de 0.44; factor 2: peso de 0.31; y factor 3: peso de 0.25.

Contribucion de las variables en los factores

library(dplyr)
contribuciones <- apply(cargas^2, MARGIN = 2, prop.table)
contribuciones %>%  kable(caption="Contribución de las variables en los Factores",
        align = "c",
        digits = 2) %>% 
  kable_material(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

Para el caso de las variables, los pesos para cada factor serán segun lo obtenido en la tabla anterior “Contribución de las variables en los Factores”.

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

library(dplyr)

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

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

# Normalización de los datos
datos_parcial_2 %>% dplyr::select(X3,X4,X8) %>% 
  dplyr::transmute(X3 = norm_directa_seg(X3),
                   X4 = norm_inverza_seg(X4), 
                   X8 = norm_directa_seg(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->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

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

library(dplyr)
matriz_X1 %>% dplyr::select(X1,X2,X7)->data_normalizada
apply(data_normalizada,2,prop.table)->data_normalizada
print(data_normalizada)
##               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 entropia
entropy<-function(x){
  return(x*log(x))
}
apply(data_normalizada,2,entropy)->data_normalizada_2
print(data_normalizada_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_normalizada)->m

#Constante de entropía:
-1/log(m)->K
print(K)
## [1] -0.91024
#Cálculo de las entropías
K*colSums(data_normalizada_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

Literal 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).

Método de Ranking por suma

library(magrittr)
## 
## Attaching package: 'magrittr'
## The following object is masked from 'package:tidyr':
## 
##     extract
library(tidyr)
#Jerarquia
rj <- c(1,2)
names(rj) <- c("X5","X6")

#Función de pesos
rank_suma_ponderadores_subjetivos <- 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))
}
#Aplicación de función
ranking_suma_pesos <- rank_suma_ponderadores_subjetivos(rj)

#Pesos brutos
ranking_suma_pesos$w_brutos
## X5 X6 
##  2  1
#Pesos normalizados
ranking_suma_pesos$w_normalizados %>% round(digits = 3)
##    X5    X6 
## 0.667 0.333
#Gráfico de pesos normalizados por suma
barplot(
  ranking_suma_pesos$w_normalizados,
  main = "Ponderadores Ranking de Suma",
  ylim = c(0, 0.5),
  col = "orange"
)

Metodo de Ranking reciprocos

#Jerarquia
rj <- c(1,2)
names(rj) <- c("X5","X6")

#Función de pesos
rank_reciproco_ponderadores_subjetivos <- function(vector_jerarquias) {
  vector_pesos <- 1 / vector_jerarquias
  list(w_brutos = vector_pesos,
       w_normalizados = vector_pesos / sum(vector_pesos))
}

#Aplicando la función
ranking_reciproco_pesos <- rank_reciproco_ponderadores_subjetivos(rj)

#Pesos brutos
ranking_reciproco_pesos$w_brutos
##  X5  X6 
## 1.0 0.5
#Pesos normalizados
ranking_reciproco_pesos$w_normalizados %>% round(digits = 3)
##    X5    X6 
## 0.667 0.333
#Gráfico de jerarquia por reciprocos
barplot(
  ranking_reciproco_pesos$w_normalizados,
  main = "Ponderadores Ranking Recíproco",
  ylim = c(0, 0.5),
  col = "blue"
)

Metodo de Ranking exponencial

#Jerarquia
rj <- c(1,2)
names(rj) <- c("X5","X6")

#Función de pesos
rank_exponencial_ponderadores_subjetivos <-
  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))
  }

#Aplicación de función
ranking_exponencial_pesos <-
  rank_exponencial_ponderadores_subjetivos(rj)

#Pesos brutos
ranking_exponencial_pesos$w_brutos
## X5 X6 
##  4  1
#Pesos normalizados
ranking_exponencial_pesos$w_normalizados %>% round(digits = 3)
##  X5  X6 
## 0.8 0.2
#Gráfico de ranking exponencial
barplot(ranking_exponencial_pesos$w_normalizados,
        main = "Ponderadores Ranking Exponencial",
        ylim = c(0,0.5),col = "yellow")

#Comparación de valores de "p"

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