SOLUCION CLAVE B

EJERCICIO 1

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

A. Usando Análisis Factorial determine cuántos factores deberían retenerse.

#CARGA DE DATOS

load("C:/Users/8abla/Documents/MAE118/PRACTICA PRE PARCIAL 2/data_parcial_2_B_rev.RData")

#PREPARACION DE LA MATRIZ DE INFORMACIÓN

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))}

#Eliminación de 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 

#Selección de variables con correlación positiva
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

#Selección de variables con correlación negativa
data_parcial_2 %>% 
  dplyr::select(MORTINF,TASA_MOR) %>% 
  apply(MARGIN = 2,FUN = norm_inversa) %>% as.data.frame()->var_corr_negativa 

#Union y reordenamiento de 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_normalizada
head(data_p2_normalizada)

##   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 Rx (de correlación)

library(PerformanceAnalytics)
chart.Correlation(as.matrix(data_p2_normalizada),histogram = TRUE,pch=12)

Pruebas de KMO y Barlett

#KMO
library(rela)
KMO<-paf(as.matrix(data_p2_normalizada))$KMO
print(KMO)

## [1] 0.85275

El valor mínimo de KMO para considerar aceptable el análisis factorial es de 0.5 y la batería de información tiene el 0.85275, por lo tal es apropiado continuar con el análisis.

#Prueba de Barlett
library(psych)
options(scipen = 99999)
Barlett<-cortest.bartlett(data_p2_normalizada)
print(Barlett)

## $chisq
## [1] 1478.1
## 
## $p.value
## [1] 0.000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000017846
## 
## $df
## [1] 36

El P-value es casi 0, quiere decir que no se rechaza la hipótesis alternativa, hay evidencia de correlación poblacional entre la batería de indicadores propuestas.

#ANALISIS FACTORIAL

library(FactoMineR)
library(factoextra)
library(kableExtra)
Rx<-cor(data_p2_normalizada)
PC<-princomp(x = data_p2_normalizada,cor = TRUE,fix_sign = FALSE)
variables_pca<-get_pca_var(PC)
factoextra::get_eig(PC) %>% kable(caption="Resumen sobre PCA",
        align = "c",
        digits = 2) %>% 
  kable_material_dark(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("hover"))

Resumen sobre 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

Según esto se puede ver la cantidad de factores a retener: Por el criterio de raíz latente: tendríamos 2 componentes.

Por el criterio de porcentaje acumulado de la varianza: tedríamos DOS componentes ya que esas 2 son superior a las 3 cuartas partes de la varianza total.

#GRAFICO DE SEDIMENTACIÓN

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

Por este criterio se puede observar que el punto de quiebre ocurre en los primeros dos. Los criterios de extracción se mantienen en 2 factores.

RESPUESTA: SE DEBEN DE RETENER DOS FACTORES

B. ¿Qué variables quedan representadas en cada factor?

library(corrplot)

#modelo de 2 fatores
numero_de_factores<-2
modelo_factores<-principal(r = Rx,
                             nfactors = numero_de_factores,
                             covar = FALSE,
                             rotate = "varimax")
print(modelo_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 aglomeracion de variables

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 = "square",
  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

C. Determine qué pesos deben asignarse a cada factor y a las variables dentro de cada uno de ellos.

#Ponderadores extraidos
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("hover"))

Ponderadores de los Factores Extraídos
Dim.1	Dim.2
0.72	0.28

#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_dark(html_font = "sans-serif") %>%
  kable_styling(bootstrap_options = c("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

RESPUESTA: Al factor 1 debe asignarse el peso 0.72 y al factor 2 el peso 0.28. -Para ALFABET será al factor 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

EJERCICIO 2

Indicaciones: 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. Para ellos se definieron 4 variables X1, X2, X3, X4, debera resolver lo siguiente:

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)

#Metodo de Ranking por suma

library(magrittr)
#Jerarquia
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
#funcion de 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))
}
#aplicacionde 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

#grafico de pesos normalisados por suma
barplot(
  pesos_ranking_suma$w_normalizados,
  main = "Ponderadores jerarquia de suma",
  ylim = c(0, 0.5),
  col = "green"
)

#Metodo de ranking reciprocos

#Jerarquia
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")
#funcion de 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))
}
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

#Grafico de jerarquia por reciprocos
barplot(
  pesos_ranking_reciproco$w_normalizados,
  main = "Ponderadores Ranking Recíproco",
  ylim = c(0, 0.5),
  col = "brown"
)

Metodo de ranking exponencial

#Jerarquia
rj <- c(3, 4, 2, 1)
names(rj) <- c("X1", "X2", "X3", "X4")

#funcion de 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))
  }
#aplicacion de funcion
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 ranking exponencial
barplot(pesos_ranking_exponencial$w_normalizados,
        main = "Ponderadores Ranking Exponencial",
        ylim = c(0,0.8),col = "Blue")

Usando la técnica de comparación por pares, calcule los pesos normalizados para las variables:

library(FuzzyAHP)

#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á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.075350

#Gráfico
barplot(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.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.08215

#Gráfico
barplot(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.06812

#Gráfico
barplot(pesos_normalizados_3@weights,
        main = "Ponderadores por método comparación de pares",
        ylim = c(0,0.7),col = "orange")

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.610848 0.198207 0.115739 0.075207

sum(promedio_tot)

## [1] 1

#ponderacion de expertos normalizadas (iguales)
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

2.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.611569 0.194412 0.119180 0.074838

sum(ponderacion_expertos_distintas)

## [1] 1

#pondedracioones de expertos normalizadas (distintas)
normalizacion_2<-ponderacion_expertos_distintas/sum(ponderacion_expertos_distintas)
show(normalizacion_2)

##     w_X1     w_X2     w_X3     w_X4 
## 0.611569 0.194412 0.119180 0.074838

PRACTICA PRE PARCIAL 2 CLAVE B

MAE118 JOSE ALEJANDRO BLANCO OCHOA BO20007

2022-10-26