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.

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: Variable X1 X2 X3 X4 Ranking 3 4 2 1

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:

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ón

#CARGA DE DATA

load("C:/doc R/GUIAS/PRACTICA_U2/data_parcial_2_B_rev.RData")

#SECCION I ##Determinando cuantod factores deben retenerse

###NORMALIZANDO

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, union
library(tidyr)
norm_directa<-function(x){(x-min(x))/(max(x)-min(x))}
norm_inversa<-function(x){(max(x)-x)/(max(x)-min(x))}

## Eliminando nulls

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 

## uniendo 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.75000000

###Calculando la Matriz RX

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':
## 
##     legend
chart.Correlation(as.matrix(data_p2_normalizados),histogram =TRUE, pch=12)

###Pruebas KMO y Barlett #KMO

library(rela)
KMO<-paf(as.matrix(data_p2_normalizados))$KMO
print(KMO)
## [1] 0.85275

###Prueba Barlett

library(psych)
options(scipen = 99999)
Barlett<-cortest.bartlett(data_p2_normalizados)
## R was not square, finding R from data
print(Barlett)
## $chisq
## [1] 1478.1
## 
## $p.value
## [1] 0.000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000017846
## 
## $df
## [1] 36

Analisis: Al tener que en la prueba KMO > 0.5 y el pvalue < 0.05, podemos decir que se puede proceder al análisis factorial, porque hay multicolinealidad (correlacion entre variables) en los valores de la matriz de información.

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)
## 
## Attaching package: 'kableExtra'
## The following object is masked from 'package:dplyr':
## 
##     group_rows
Rx<-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(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("hover"))
Resumen 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

###Grafico de Sedimentacion

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

#En conclusion, de acuerdo al criterio y analisis de raíz latente ( verificado 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 decimos que, se extraen los primeros 2 componentes.

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)

## variables que representan a cada factor: En el factor uno quedan representadas ALFABET, INC_POB, FERTILID, TASA_NAT Y LOG_PIB En el factor dos 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"))
Ponderadores de los Factores Extraídos
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(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.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

Determinando los pesos que deben asignarse a cada factor y a las variables dentro de cada uno de ellos: Decimos que, 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.23

#SECCION II

##calculano pesos normalizados de las variables por diferentes metodos

###SUMA

library(magrittr)
## 
## Attaching package: 'magrittr'
## The following object is masked from 'package:tidyr':
## 
##     extract
#Vector jerarquías
rj<-c(3,4,2,1)
names(rj)<-c("X1","X2","X3","X4")
#Generando 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

###Gráfico de pesos normalizados, jerarquia suma

barplot(pesos_ranking_suma$w_normalizados,
        main = "Ponderadores jerarquia de suma",
        ylim = c(0,0.5),col = "orange")

##Metodo Reciporoco

#Generando 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 pesos normalizados, jerarquia recíproco

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

#Creando 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 pesos normalizados, jerarquia exponencial con p=4

#Gráfico de los pesos normalizados (p=4)
barplot(pesos_ranking_exponencial$w_normalizados,
        main = "Ponderadores Ranking Exponencial",
        ylim = c(0,0.8),col = "brown")

#EJERCICIO 2

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álculando 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 utilizando comparación de pares",
        ylim = c(0,0.7),col = "green")

# 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"
# Obteniendo 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 utilizando 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.06812
barplot(pesos_normalizados_3@weights,
        main = "Ponderadores utilizando comparación de pares",
        ylim = c(0,0.7),col = "red")

###expertos tienen la misma opinion

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.610848 0.198207 0.115739 0.075207
sum(promedio_tot)
## [1] 1
normalizacion_1<-promedio_tot/sum(promedio_tot)
show(normalizacion_1)
##     w_X1     w_X2     w_X3     w_X4 
## 0.610848 0.198207 0.115739 0.075207

###expertos tienen distintas opiniones

ponderacion_expertos_distintas<-(pesos_normalizados_1@weights*0.4)+(pesos_normalizados_2@weights*0.4)+(pesos_normalizados_3@weights*0.2)

show(ponderacion_expertos_distintas)
##     w_X1     w_X2     w_X3     w_X4 
## 0.609665 0.203343 0.110367 0.076624
sum(ponderacion_expertos_distintas)
## [1] 1
normalizacion_2<-ponderacion_expertos_distintas/sum(ponderacion_expertos_distintas)
show(normalizacion_2)
##     w_X1     w_X2     w_X3     w_X4 
## 0.609665 0.203343 0.110367 0.076624
sum(ponderacion_expertos_distintas)
## [1] 1
normalizacion_2<-ponderacion_expertos_distintas/sum(ponderacion_expertos_distintas)
show(normalizacion_2)
##     w_X1     w_X2     w_X3     w_X4 
## 0.609665 0.203343 0.110367 0.076624
sum(ponderacion_expertos_distintas)
## [1] 1
normalizacion_2<-ponderacion_expertos_distintas/sum(ponderacion_expertos_distintas)
show(normalizacion_2)
##     w_X1     w_X2     w_X3     w_X4 
## 0.609665 0.203343 0.110367 0.076624