Practica 2 Clave B
MONICA MOLINA MARTINEZ-MM18046
2022-10-25
Carga de datos
load("C:/Users/MOLINA/OneDrive/Escritorio/ARCHIVOS DE R/data_parcial_2_B_rev.RData")Seccion 1.
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))}
## Eliminando valores nulos
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
## Seleccionando variables con correlación positiva con desarrollo de economias
data_parcial_2 %>%
select(ALFABET,INC_POB,ESPVIDAF,FERTILID,TASA_NAT,LOG_PIB,URBANA) %>%
apply(MARGIN = 2,FUN = norm_directa) %>% as.data.frame()->var_corr_positiva
## Seleccionando variables con correlación negativa con desarrollo de economias
data_parcial_2 %>%
select(MORTINF,TASA_MOR) %>%
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) %>%
select(ALFABET,INC_POB,ESPVIDAF,FERTILID,TASA_NAT,LOG_PIB,URBANA,MORTINF,TASA_MOR)->data_p2_normalizados
head(data_p2_normalizados)## ALFABET INC_POB ESPVIDAF FERTILID TASA_NAT LOG_PIB URBANA MORTINF
## 1 0.98 0.3068592 0.82051282 0.3418803 0.30232558 0.60885423 0.54 0.8109756
## 2 0.29 0.5595668 0.02564103 0.8424908 1.00000000 0.09867408 0.18 0.0000000
## 3 0.99 0.1191336 0.92307692 0.1794872 0.02325581 0.94458420 0.85 0.9847561
## 4 0.62 0.6317690 0.69230769 0.8144078 0.65116279 0.76022519 0.77 0.7073171
## 5 0.95 0.2888087 0.82051282 0.3418803 0.23255814 0.63309802 0.86 0.8682927
## 6 0.98 0.3068592 0.82051282 0.3894994 0.30232558 0.70597624 0.68 0.8597561
## TASA_MOR
## 1 0.70833333
## 2 0.08333333
## 3 0.54166667
## 4 0.75000000
## 5 0.62500000
## 6 0.75000000Matriz 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_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
#KMO
library(rela)
KMO<-paf(as.matrix(data_p2_normalizados))$KMO
print(KMO)## [1] 0.85275#Prueba de Barlett
library(psych)
options(scipen = 99999)
Barlett<-cortest.bartlett(data_p2_normalizados)## R was not square, finding R from dataprint(Barlett)## $chisq
## [1] 1478.1
##
## $p.value
## [1] 0.000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000017846
##
## $df
## [1] 36## Dado que al pasar la prueba KMO > 0.5 y el pvalue < 0.05, se concluye que se puede proceder al análisis factorial, porque existe multicolinealidad (correlacion entre variables) en los valores de la matriz de informaciónlibrary(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(data_p2_normalizados)
PC<-princomp(x = data_p2_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_dark(html_font = "sans-serif") %>%
kable_styling(bootstrap_options = c("hover"))| eigenvalue | variance.percent | cumulative.variance.percent | |
|---|---|---|---|
| Dim.1 | 6.45 | 71.63 | 71.63 |
| Dim.2 | 1.24 | 13.81 | 85.44 |
| Dim.3 | 0.56 | 6.18 | 91.62 |
| Dim.4 | 0.39 | 4.36 | 95.98 |
| Dim.5 | 0.18 | 2.01 | 97.99 |
| Dim.6 | 0.08 | 0.86 | 98.85 |
| Dim.7 | 0.06 | 0.64 | 99.49 |
| Dim.8 | 0.03 | 0.32 | 99.81 |
| Dim.9 | 0.02 | 0.19 | 100.00 |
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)
1.1. Usando Análisis Factorial determine cuántos factores deberían retenerse
## Basado en el criterio de raíz latente (que se verifica en el gréfico de sedimentación), en el criterio del autovalor mayor que 1, en el criterio que están por encima del turning point y en que ambos explican más del 70% de la varianza acumulada, se extraen los primeros 2 componentes.
## Proceso
library(corrplot)## corrplot 0.92 loaded#Modelo de 2 Factores (Rotada)
numero_de_factores<-2
modelo_2_factores<-princomp( x = data_p2_normalizados,
nfactors = numero_de_factores,
covar = FALSE,
rotate = "varimax")## Warning: In princomp.default(x = data_p2_normalizados, nfactors = numero_de_factores,
## covar = FALSE, rotate = "varimax") :
## extra arguments 'nfactors', 'covar', 'rotate' will be disregardedprint(modelo_2_factores)## Call:
## princomp(x = data_p2_normalizados, nfactors = numero_de_factores,
## covar = FALSE, rotate = "varimax")
##
## Standard deviations:
## Comp.1 Comp.2 Comp.3 Comp.4 Comp.5 Comp.6 Comp.7 Comp.8
## 0.635796 0.239877 0.171260 0.160516 0.104137 0.066796 0.052983 0.042455
## Comp.9
## 0.034075
##
## 9 variables and 109 observations.#Gráfico de aglomeración de las variables en los factores
correlaciones_modelo<-variables_pca$coord
rotacion<-varimax(correlaciones_modelo[,1:numero_de_factores])
correlaciones_modelo_rotada<-rotacion$loadings
corrplot(correlaciones_modelo_rotada[,1:numero_de_factores],
is.corr = FALSE,
method = "circle",
addCoef.col="black",
number.cex = 0.75)
1.2. ¿Qué variables quedan representadas en cada factor?
# En el factor 1 quedan representadas ALFABET, INC_POB, FERTILID, TASA_NAT Y LOG_PIB
#En el factor 2 quedan representadas ESPVIDAF, URBANA, MORTINF Y TASA_MOR.
## Cargas de cada dimensión
library(kableExtra)
cargas<-rotacion$loadings[1:6,1:numero_de_factores]
ponderadores<-prop.table(apply(cargas^2,MARGIN = 2,sum))
t(ponderadores) %>% kable(caption="Ponderadores de los Factores Extraídos",
align = "c",
digits = 2) %>%
kable_material_dark(html_font = "sans-serif") %>%
kable_styling(bootstrap_options = c("striped", "hover"))| Dim.1 | Dim.2 |
|---|---|
| 0.72 | 0.28 |
## 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 | |
|---|---|---|
| ALFABET | 0.13 | 0.17 |
| INC_POB | 0.25 | 0.00 |
| ESPVIDAF | 0.10 | 0.38 |
| FERTILID | 0.20 | 0.11 |
| TASA_NAT | 0.21 | 0.11 |
| LOG_PIB | 0.10 | 0.23 |
1.3. Determine qué pesos deben asignarse a cada factor y a las variables dentro de cada uno de ellos.
# Al factor 1 debe asignarse el peso 0.72 y al factor 2 el peso 0.28.
# Para ALFABET será al facor 1: 0.13 y al factor 2: 0.17
# Para INC_POB serán al F1: 0.25 y F2: 0
# Para ESPVIDAF serán al F1: 0.1 y F2: 0.38
# Para FERTILID serán al F1: 0.2 y F2: 0.11
# Para TASA_NAT serán al F1: 0.2 y F2 0.11
# Para LOG_PIB serán al F1: 0.1 y F2: 0.23SECCION 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:
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)
a. Por suma.
library(magrittr)##
## Attaching package: 'magrittr'## The following object is masked from 'package:tidyr':
##
## extract## Vector jerarquias
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 funcion:
pesos_ranking_suma<-ponderadores_subjetivos_rank_suma(rj)
#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 pesos normalizados, jerarquia suma
barplot(pesos_ranking_suma$w_normalizados,
main = "Ponderadores jerarquia de suma",
ylim = c(0,0.5),col = "black")
b. Por metodo 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## 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 = "light green")
c. Por metodo exponercial, 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## 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 (p=4)
barplot(pesos_ranking_exponencial$w_normalizados,
main = "Ponderadores Ranking Exponencial",
ylim = c(0,0.8),col = "light blue")
Ejercicio 2. Usando la técnica de comparación por pares, calcule los pesos normalizados para las variables:
2.1 Asumiendo que la opinión de los 3 expertos es igualmente válida.
# Matriz 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 método comparación de pares",
ylim = c(0,0.7),col = "orange")
# 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.08215barplot(pesos_normalizados_2@weights,
main = "Ponderadores por método comparación de pares",
ylim = c(0,0.7),col = "gray")
# 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.06812barplot(pesos_normalizados_3@weights,
main = "Ponderadores por método comparación de pares",
ylim = c(0,0.7),col = "pink")