Practica 2, Clave-A
MONICA MOLINA MARTINEZ-MM18046
2022-10-26
Se necesita construir un indicador multivariado sintético, que mida la “Seguridad Municipal” Para ello se dispone de la siguiente información:Variable Correlación con la variable complejaX1% de Negocios victimizados durante el año por - robo o hurtopositiva; X2% de Negocios victimizados durante el año - extorsión o secuestropositiva; 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.
Carga de datos.
load("C:/Users/MOLINA/OneDrive/Escritorio/ARCHIVOS DE R/data_parcial_2_A_rev.RData")1. A través del análisis de componentes principales, identifique para un modelo de 3 factores:
library(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(tidyr)
norm_directa<-function(x){(x-min(x))/(max(x)-min(x))}
norm_inversa<-function(x){(max(x)-x)/(max(x)-min(x))}
## Seleccionando variables con correlación positiva
datos_parcial_2 %>%
dplyr::select(X1,X2,X3,X5,X7,X8) %>%
apply(MARGIN = 2,FUN = norm_directa) %>% as.data.frame()->var_corr_positiva
## Seleccionando variables con correlación negativa
datos_parcial_2 %>%
dplyr::select(X4,X6) %>%
apply(MARGIN = 2,FUN = norm_inversa) %>% as.data.frame()->var_corr_negativa
## Juntando y reordenando las variables
var_corr_positiva %>%
bind_cols(var_corr_negativa) %>%
dplyr::select(X1,X2,X3,X4,X5,X6,X7,X8) ->data_p2_norm
head(data_p2_norm)## 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 Rx
## 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(data_p2_norm),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
## Pruebas KMO y Barlett.
# KMO
library(rela)
KMO<-paf(as.matrix(data_p2_norm))$KMO
print(KMO)## [1] 0.67931#Prueba de Barlett
library(psych)
options(scipen = 99999)
Prueba_Barlett<-cortest.bartlett(data_p2_norm)## R was not square, finding R from dataprint(Prueba_Barlett)## $chisq
## [1] 1025.9
##
## $p.value
## [1] 0.0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000046951
##
## $df
## [1] 28Debido que el pvalue < 0.05, se puede procederse al análisis factorial porque existe multicolinealidad en los valores de la matriz de información
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(data_p2_norm)
PC<-princomp(x = data_p2_norm,cor = TRUE,fix_sign = FALSE)
variables_pca<-get_pca_var(PC)
factoextra::get_eig(PC) %>% kable(caption="Resumen PCA",
align = "c",
digits = 2) %>%
kable_material_dark(html_font = "sans-serif") %>%
kable_styling(bootstrap_options = c("hover"))| eigenvalue | variance.percent | cumulative.variance.percent | |
|---|---|---|---|
| Dim.1 | 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 = "pink",
barfill = "black",
addlabels = TRUE,
)+labs(title = "Gráfico de Sedimentación",subtitle = "Usando princomp, con Autovalores")+
xlab(label = "Componentes")+
ylab(label = "Autovalores")+geom_hline(yintercept = 1)
library(corrplot)## corrplot 0.92 loaded#Modelo de 2 Factores (Rotada)
numero_factores<-3
modelo_factores<-principal(r = Rx,
nfactors = numero_factores,
covar = FALSE,
rotate = "varimax")
print(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#Gráfico de aglomeración de las variables en los factores
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="black",
number.cex = 0.75)
# Cargas de cada dimensión
library(kableExtra)
cargas<-rotacion$loadings[1:6,1:numero_factores]
ponderadores<-prop.table(apply(cargas^2,MARGIN = 2,sum))
t(ponderadores) %>% kable(caption="Ponderadores de los Factores Extraídos",
align = "c",
digits = 2) %>%
kable_material_dark(html_font = "sans-serif") %>%
kable_styling(bootstrap_options = c("striped", "hover"))| Dim.1 | Dim.2 | Dim.3 |
|---|---|---|
| 0.41 | 0.27 | 0.32 |
# Contribuciones
contribuciones<-apply(cargas^2,MARGIN = 2,prop.table)
contribuciones %>% kable(caption="Contribución de las variables en los Factores",
align = "c",
digits = 2) %>%
kable_material_dark(html_font = "sans-serif") %>%
kable_styling(bootstrap_options = c("striped", "hover"))| Dim.1 | Dim.2 | 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 |
A) Los ponderadores normalizados para cada factor
# Al factor 1 se le debe asignar 0.41, al factor 2 se le debe asignar 0.27 y al factor 3 se le debe asignar 0.32B) Las variables incluidas en cada factor.
# FACTOR 1 estan incluidas las variables X3, X4 FACTOR 2 estan incluidas las variables X1, X2 # FACTOR 3 estan incluidas las variables X5, X62. METODO CRITIC
Normalización de datos y cálculo.
# Funciones para normalizar los datos
norm_directa_c<- function(x){
return((x-min(x)) / (max(x)-min(x)))
}
norm_inverza_c<- function(x){
return((max(x)-x) / (max(x)-min(x)))
}
# Normalización de los datos
library(dplyr)
datos_parcial_2 %>% dplyr::select(X3,X4) %>% dplyr::transmute(X3=norm_directa_c(X3),X4=norm_inverza_c(X4)) ->data_factor_1
print(data_factor_1)## # A tibble: 108 × 2
## X3 X4
## <dbl> <dbl>
## 1 0.04 0.8
## 2 0.55 0.5
## 3 0.4 0.5
## 4 0.314 0.571
## 5 0.7 0.25
## 6 0.16 0.7
## 7 0.673 0.273
## 8 0.55 0.5
## 9 0.4 0.563
## 10 0.68 0.467
## # … 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))-> sd_vector
print(sd_vector)## # A tibble: 1 × 2
## S3 S4
## <dbl> <dbl>
## 1 0.246 0.201# Cálculo de la matriz de correlación
cor(data_factor_1)->mat_R_F1
print(mat_R_F1)## X3 X4
## X3 1.00000 -0.93872
## X4 -0.93872 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
## 1 0.47747 0.3899#Cálculo de los ponderadores netos
vj/sum(vj)->wj
print(wj)## S3 S4
## 1 0.55048 0.44952#Ponderadores:
print(round(wj*100,2))## S3 S4
## 1 55.05 44.95METODO ENTROPÍA
# Normalización de los datos
library(dplyr)
datos_parcial_2 %>% dplyr::select(X1,X2) %>% dplyr::transmute(X1=norm_directa_c(X1),X2=norm_directa_c(X2)) ->data_factor_2
print(data_factor_2)## # A tibble: 108 × 2
## X1 X2
## <dbl> <dbl>
## 1 0.194 0
## 2 0.226 0.0172
## 3 0.226 0.0773
## 4 0.161 0.00429
## 5 0.129 0.0215
## 6 0.0968 0.0472
## 7 0.258 0.0300
## 8 0.194 0.00429
## 9 0.226 0.00858
## 10 0.290 0.0172
## # … with 98 more rows# Formula
entropy<-function(x){
return(x*log(x))
}
apply(data_factor_2,2,entropy)->data_factor_2.1
print(data_factor_2.1)## X1 X2
## [1,] -0.31785 NaN
## [2,] -0.33602 -0.069781
## [3,] -0.33602 -0.197820
## [4,] -0.29428 -0.023395
## [5,] -0.26422 -0.082438
## [6,] -0.22600 -0.144140
## [7,] -0.34956 -0.105304
## [8,] -0.31785 -0.023395
## [9,] -0.33602 -0.040840
## [10,] -0.35906 -0.069781
## [11,] -0.36497 -0.040840
## [12,] -0.34956 NaN
## [13,] -0.35906 -0.135127
## [14,] -0.35900 -0.040840
## [15,] -0.33602 -0.183928
## [16,] -0.35906 NaN
## [17,] -0.31785 -0.040840
## [18,] -0.26422 -0.082438
## [19,] -0.29428 -0.105304
## [20,] -0.34956 -0.094230
## [21,] -0.35906 -0.197820
## [22,] -0.34956 -0.168960
## [23,] -0.34956 -0.056040
## [24,] -0.26422 -0.254624
## [25,] -0.29428 -0.168960
## [26,] -0.33602 -0.183928
## [27,] -0.35906 -0.168960
## [28,] -0.22600 -0.254624
## [29,] -0.33602 -0.162936
## [30,] -0.34956 -0.040840
## [31,] -0.33602 NaN
## [32,] -0.17683 -0.040840
## [33,] -0.36497 -0.276822
## [34,] -0.29428 -0.040840
## [35,] -0.26422 -0.023395
## [36,] -0.30005 -0.216896
## [37,] -0.33602 -0.069781
## [38,] -0.31785 -0.115763
## [39,] -0.31785 -0.311859
## [40,] -0.31785 -0.094230
## [41,] -0.34956 -0.094230
## [42,] -0.34956 -0.115763
## [43,] -0.22600 NaN
## [44,] -0.36497 -0.056040
## [45,] -0.29428 -0.344557
## [46,] -0.29428 NaN
## [47,] -0.33602 -0.040840
## [48,] -0.26422 -0.023395
## [49,] -0.33602 -0.115763
## [50,] -0.33602 -0.125684
## [51,] -0.29428 NaN
## [52,] -0.22600 -0.125684
## [53,] -0.36765 -0.094230
## [54,] -0.22600 NaN
## [55,] -0.36739 -0.048656
## [56,] -0.34956 -0.023395
## [57,] -0.22600 -0.144140
## [58,] -0.31565 NaN
## [59,] -0.34956 NaN
## [60,] -0.35906 -0.056040
## [61,] -0.29428 -0.082438
## [62,] 0.00000 0.000000
## [63,] -0.31785 NaN
## [64,] -0.35906 -0.162936
## [65,] -0.29428 -0.197820
## [66,] -0.35906 -0.254624
## [67,] -0.33602 -0.166364
## [68,] -0.33602 -0.144140
## [69,] -0.35906 -0.168960
## [70,] -0.22600 NaN
## [71,] -0.35906 -0.311859
## [72,] -0.33602 -0.105304
## [73,] -0.33602 -0.069781
## [74,] -0.31785 NaN
## [75,] -0.36497 -0.069781
## [76,] -0.33602 -0.069781
## [77,] -0.33602 -0.166364
## [78,] -0.33602 -0.082438
## [79,] -0.33602 -0.023395
## [80,] -0.29428 -0.183928
## [81,] -0.31785 -0.254624
## [82,] 0.00000 0.000000
## [83,] -0.26422 -0.159486
## [84,] -0.34956 NaN
## [85,] -0.33602 -0.056040
## [86,] -0.26422 NaN
## [87,] -0.22600 -0.023395
## [88,] -0.36739 -0.056040
## [89,] -0.33602 NaN
## [90,] -0.36444 -0.069781
## [91,] -0.31785 -0.056040
## [92,] -0.17683 -0.040840
## [93,] -0.11077 -0.040840
## [94,] -0.36765 -0.303954
## [95,] -0.31785 -0.040840
## [96,] -0.28275 -0.082438
## [97,] -0.33602 -0.040840
## [98,] -0.31785 -0.082438
## [99,] -0.34956 -0.094230
## [100,] 0.00000 0.000000
## [101,] -0.26422 -0.023395
## [102,] -0.22600 -0.040840
## [103,] -0.35906 -0.023395
## [104,] -0.35906 -0.168960
## [105,] -0.26422 NaN
## [106,] -0.35906 -0.183928
## [107,] NaN -0.094230
## [108,] -0.34956 -0.069781#Número de variables en el factor:
ncol(data_factor_2)->m
#Constante de entropía:
-1/log(m)->K
print(K)## [1] -1.4427#Cálculo de las entropías
K*colSums(data_factor_2.1)->Ej
print(Ej)## X1 X2
## NaN NaN#Cálculo de las especificidades:
1-Ej->vj
print(vj)## X1 X2
## NaN NaN#Cálculo de los ponderadores:
prop.table(vj)->wj #es igual a usar vj/sum(vj)
print(wj)## X1 X2
## NaN NaNMétodo de Ranking
Jerarquia de Suma
library(magrittr)##
## Attaching package: 'magrittr'## The following object is masked from 'package:tidyr':
##
## extract#Vector de Jerarquías
rj<-c(0.40,0.51)
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=vector_pesos/sum(vector_pesos))
}
#Aplicando la función:
pesos_ranking_suma<-ponderadores_subjetivos_rank_suma(rj)
#Pesos brutos
pesos_ranking_suma$w_brutos## X5 X6
## 2.60 2.49#Pesos normalizados
pesos_ranking_suma$w_normalizados %>% round(digits = 3)## X5 X6
## 0.511 0.489#Gráfico de los pesos normalizados
barplot(pesos_ranking_suma$w_normalizados,
main = "Ponderadores Ranking de Suma",
ylim = c(0,0.5),col = "orange")
Jerarquia Reciproca.
library(magrittr)
#Vector de Jerarquías
rj<-c(0.40,0.51)
names(rj)<-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_reciproco<-ponderadores_subjetivos_rank_reciproco(rj)
#Pesos brutos
pesos_ranking_reciproco$w_brutos## X5 X6
## 2.5000 1.9608#Pesos normalizados
pesos_ranking_reciproco$w_normalizados %>% round(digits = 3)## X5 X6
## 0.56 0.44#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
rj<-c(0.40,0.51)
names(rj)<-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_exponencial<-ponderadores_subjetivos_rank_exponencial(rj)
#Pesos brutos
pesos_ranking_exponencial$w_brutos## X5 X6
## 6.7600 6.2001#Pesos normalizados
pesos_ranking_exponencial$w_normalizados %>% round(digits = 3)## X5 X6
## 0.522 0.478#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 = "navy")