parcial B
DEBEE BERENICE PEREZ VIDES
2022-10-22
Sección I. 25%
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/50379/Desktop/practica parcial B 2021/data_parcial_2_B_rev.RData")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%>%
dplyr::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 %>%
dplyr::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) %>%
dplyr::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.75000000## 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
library(psych)
options(scipen = 99999)
Barlett<-cortest.bartlett(data_p2_normalizados)## R was not square, finding R from dataprint(Barlett)## $chisq
## [1] 1478.145
##
## $p.value
## [1] 0.00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001784625
##
## $df
## [1] 36Se tiene que puede procederse al análisis factorial porque existe multicolinealidad en los valores de la matriz de información
ANALISIS FACTORIAL
library(FactoMineR)
library(factoextra)## Loading required package: ggplot2##
## Attaching package: 'ggplot2'## The following objects are masked from 'package:psych':
##
## %+%, alpha## Welcome! Want to learn more? See two factoextra-related books at https://goo.gl/ve3WBalibrary(kableExtra)##
## Attaching package: 'kableExtra'## The following object is masked from 'package:dplyr':
##
## group_rowsRx<-cor(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 |
fviz_eig(PC,
choice = "eigenvalue",
barcolor = "red",
barfill = "purple",
addlabels = TRUE,
)+labs(title = "Gráfico de Sedimentación",subtitle = "Usando princomp, con Autovalores")+
xlab(label = "Componentes")+
ylab(label = "Autovalores")+geom_hline(yintercept = 1)
## Basado en el criterio de raíz latente (que se verifica en el grafico
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.
1.2) ¿Qué variables quedan representadas en cada factor?
library(corrplot)## corrplot 0.92 loaded#Modelo de 2 Factores (Rotada)
numero_de_factores<-2
modelo_2_factores<-principal(r = Rx,
nfactors = numero_de_factores,
covar = FALSE,
rotate = "varimax")
print(modelo_2_factores)## Principal Components Analysis
## Call: principal(r = Rx, nfactors = numero_de_factores, rotate = "varimax",
## covar = FALSE)
## Standardized loadings (pattern matrix) based upon correlation matrix
## RC1 RC2 h2 u2 com
## ALFABET 0.70 0.51 0.74 0.260 1.8
## INC_POB -0.98 0.04 0.96 0.041 1.0
## ESPVIDAF 0.62 0.76 0.95 0.048 1.9
## FERTILID -0.87 -0.40 0.91 0.091 1.4
## TASA_NAT -0.90 -0.40 0.96 0.036 1.4
## LOG_PIB 0.62 0.59 0.73 0.270 2.0
## URBANA 0.39 0.71 0.66 0.342 1.6
## MORTINF 0.65 0.71 0.92 0.075 2.0
## TASA_MOR -0.03 0.92 0.85 0.148 1.0
##
## RC1 RC2
## SS loadings 4.35 3.34
## Proportion Var 0.48 0.37
## Cumulative Var 0.48 0.85
## Proportion Explained 0.57 0.43
## Cumulative Proportion 0.57 1.00
##
## Mean item complexity = 1.6
## Test of the hypothesis that 2 components are sufficient.
##
## The root mean square of the residuals (RMSR) is 0.05
##
## Fit based upon off diagonal values = 0.99#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)
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
1.3) Determine que pesos deben asignarse a cada factor y a las variables dentro de cada uno de ellos.
# Cargas de cada dimensión
library(kableExtra)
cargas<-rotacion$loadings[1: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 |
En el factor 1 debe asignarsele 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.23
SECCION 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)
#SUMA
library(magrittr)##
## Attaching package: 'magrittr'## The following object is masked from 'package:tidyr':
##
## extract#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_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## 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### GRAFICO
#Gráfico de los pesos normalizados
barplot(pesos_ranking_suma$w_normalizados,
main = "Ponderadores Ranking de Suma",
ylim = c(0,0.5),col = "darkblue")
## Por 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.3333333 0.2500000 0.5000000 1.0000000#Pesos normalizados
pesos_ranking_reciproco$w_normalizados %>% round(digits = 3)## X1 X2 X3 X4
## 0.16 0.12 0.24 0.48### Grafico
#Gráfico de los pesos normalizados
barplot(pesos_ranking_reciproco$w_normalizados,
main = "Ponderadores Ranking Recíproco",
ylim = c(0,0.5),col = "cyan4")
#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### Grafica
#Gráfico de los pesos normalizados (por default p=4)
barplot(pesos_ranking_exponencial$w_normalizados,
main = "Ponderadores Ranking Exponencial",
ylim = c(0,0.8),col = "darkmagenta")
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.0000000 7.0000000 4.0 5
## [2,] 0.1428571 1.0000000 6.0 3
## [3,] 0.2500000 0.1666667 1.0 2
## [4,] 0.2000000 0.3333333 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.60659194 0.22331004 0.09474784 0.07535018barplot(pesos_normalizados_1@weights,
main = "Ponderadores por método comparación de pares",
ylim = c(0,0.7),col = "cadetblue")
# 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.0000000 7.0 6.00 3
## [2,] 0.1428571 1.0 5.00 2
## [3,] 0.1666667 0.2 1.00 4
## [4,] 0.3333333 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.60919010 0.19878595 0.10987399 0.08214997barplot(pesos_normalizados_2@weights,
main = "Ponderadores por método comparación de pares",
ylim = c(0,0.7),col = "yellow")
# 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.0000000 7.0000000 5.0000000 4
## [2,] 0.1428571 1.0000000 3.0000000 2
## [3,] 0.2000000 0.3333333 1.0000000 6
## [4,] 0.2500000 0.5000000 0.1666667 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.61676222 0.17252382 0.14259384 0.06812013barplot(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_tot<-(pesos_normalizados_1@weights+pesos_normalizados_2@weights+
pesos_normalizados_3@weights)
promedio_tot<-ponderacion_expertos*pesos_tot
show(promedio_tot)## w_X1 w_X2 w_X3 w_X4
## 0.61084809 0.19820660 0.11573855 0.07520676sum(promedio_tot)## [1] 1normalizacion_1<-promedio_tot/sum(promedio_tot)
show(normalizacion_1)## w_X1 w_X2 w_X3 w_X4
## 0.61084809 0.19820660 0.11573855 0.075206762.2 Si el experto 1 se pondera con 0.25, el experto 2 con 0.35 y el experto 3 con 0.4
ponderacion_expertos_distintas<-(pesos_normalizados_1@weights*0.25)+(pesos_normalizados_2@weights*0.35)+(pesos_normalizados_3@weights*0.4)
show(ponderacion_expertos_distintas)## w_X1 w_X2 w_X3 w_X4
## 0.61156941 0.19441212 0.11918039 0.07483808sum(ponderacion_expertos_distintas)## [1] 1normalizacion_2<-ponderacion_expertos_distintas/sum(ponderacion_expertos_distintas)
show(normalizacion_2)## w_X1 w_X2 w_X3 w_X4
## 0.61156941 0.19441212 0.11918039 0.07483808