# Carga de datos
datos_A<- load("C:/Users/hazel/Desktop/CICLO II-2022/METODOS/UNIDAD II/PARCIAL 2/data_parcial_2_A_rev.Rdata")

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) ->datos_A2_norm
head(datos_A2_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.2551724

Matriz Rx

## Matriz de correlación
chart.Correlation(as.matrix(datos_A2_norm),histogram = TRUE,pch=12)

Pruebas KMO y Barlett

#KMO

KMO<-paf(as.matrix(datos_A2_norm))$KMO
print(KMO)
## [1] 0.67931

Es adecuado hacer el analisis factorial; KM0 > 0.5, ya que hay una alta correlacion entre las variables

#Prueba de Barlett

options(scipen = 99999)
Prueba_Barlett<-cortest.bartlett(datos_A2_norm)
print(Prueba_Barlett)
## $chisq
## [1] 1025.9
## 
## $p.value
## [1] 0.0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000046951
## 
## $df
## [1] 28

Debido que el pvalue < 0.05 y se rechaza la Ho, se puede procederse al análisis factorial porque existe multicolinealidad en la bateria de indicadores propuestos

Análisis Factorial

Rx<-cor(datos_A2_norm)
PC<-princomp(x = datos_A2_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_classic_2(html_font = "helvetica") %>% kable_styling(bootstrap_options = c("hover"))
Resumen PCA
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 = "black",
         barfill = "pink",
         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. A través del análisis de componentes principales, identifique para un modelo de 3 factores

#Modelo de 3 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 = "square",
         addCoef.col="black",
         number.cex = 0.75)

a) Los ponderadores normalizados para cada factor

# Cargas de cada dimensión
cargas<-rotacion$loadings[1:8,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_classic_2(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("striped", "hover"))
Ponderadores de los Factores Extraídos
Dim.1 Dim.2 Dim.3
0.44 0.31 0.25

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.32

b) Las variables incluidas en cada factor.

# 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_classic_2(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("striped", "hover"))
Contribución de las variables en los Factores
Dim.1 Dim.2 Dim.3
X1 0.01 0.31 0.00
X2 0.00 0.34 0.00
X3 0.29 0.00 0.05
X4 0.31 0.00 0.04
X5 0.06 0.00 0.38
X6 0.02 0.00 0.49
X7 0.00 0.33 0.00
X8 0.31 0.00 0.04

FACTOR 1 estan incluidas las variables X3, X4, X8

FACTOR 2 estan incluidas las variables X1, X2, X7

FACTOR 3 estan incluidas las variables X5, X6

2. METODO CRITIC, para el factor 1

Normalización de datos y cálculos

#Funciones para normalizar los datos
norm_directa<-function(x){(x-min(x))/(max(x)-min(x))}
norm_inversa<-function(x){(max(x)-x)/(max(x)-min(x))}

#Seleccionando las variables con correlación positiva
datos_parcial_2 %>% 
  dplyr::select(X3,X8) %>% 
  apply(MARGIN = 2,FUN = norm_directa) %>% as.data.frame()->v_corr_positiva

#Seleccionando las variables con correlación negativa
datos_parcial_2 %>% 
  dplyr::select(X4) %>% 
  apply(MARGIN = 2,FUN = norm_inversa) %>% as.data.frame()->v_corr_negativa

#Juntando y reordenando las variables
data_factor_1 <- v_corr_positiva %>% 
  bind_cols(v_corr_negativa) %>% 
  dplyr::select(X3, X4, X8)
head(data_factor_1)
##        X3      X4      X8
## 1 0.04000 0.80000 0.15823
## 2 0.55000 0.50000 0.51675
## 3 0.40000 0.50000 0.46798
## 4 0.31429 0.57143 0.41337
## 5 0.70000 0.25000 0.73399
## 6 0.16000 0.70000 0.25517

Cálculo de las desviaciones estándar de cada variable

data_factor_1 %>% dplyr::summarise(S3=sd(X3),S4=sd(X4),S8=sd(X8))-> sd_vector
print(sd_vector)
##        S3      S4      S8
## 1 0.24628 0.20111 0.20874

Cálculo de la matriz de correlación

cor(data_factor_1)->mat_R_F1
print(mat_R_F1)
##          X3       X4       X8
## X3  1.00000 -0.93872  0.95904
## X4 -0.93872  1.00000 -0.99585
## X8  0.95904 -0.99585  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      S8
## 1 0.48755 0.79129 0.42517

Cálculo de los ponderadores netos

vj/sum(vj)->wj
print(wj)
##        S3      S4      S8
## 1 0.28612 0.46437 0.24951

Ponderadores:

print(round(wj*100,2))
##      S3    S4    S8
## 1 28.61 46.44 24.95

3. METODO ENTROPÍA, para el factor 2

# Normalización de los datos

datos_parcial_2 %>% dplyr::select(X1,X2,X7) ->data_factor_2
apply(data_factor_2,2,prop.table)->data_factor_2
head (data_factor_2, 10)
##              X1         X2        X7
##  [1,] 0.0078125 0.00070734 0.0013986
##  [2,] 0.0086806 0.00212202 0.0076923
##  [3,] 0.0086806 0.00707339 0.0111888
##  [4,] 0.0069444 0.00106101 0.0244755
##  [5,] 0.0060764 0.00247569 0.0055944
##  [6,] 0.0052083 0.00459770 0.0174825
##  [7,] 0.0095486 0.00318302 0.0062937
##  [8,] 0.0078125 0.00106101 0.0041958
##  [9,] 0.0086806 0.00141468 0.0034965
## [10,] 0.0104167 0.00212202 0.0041958

Fórmula de entropía

entropy<-function(x){
  return(x*log(x))
}
apply(data_factor_2,2,entropy)->data_factor_2.1
head (data_factor_2.1, 10)
##              X1         X2        X7
##  [1,] -0.037906 -0.0051310 -0.009192
##  [2,] -0.041204 -0.0130618 -0.037443
##  [3,] -0.041204 -0.0350233 -0.050270
##  [4,] -0.034513 -0.0072664 -0.090806
##  [5,] -0.031010 -0.0148572 -0.029013
##  [6,] -0.027383 -0.0247457 -0.070744
##  [7,] -0.044414 -0.0183021 -0.031898
##  [8,] -0.037906 -0.0072664 -0.022966
##  [9,] -0.041204 -0.0092815 -0.019776
## [10,] -0.047545 -0.0130618 -0.022966
#Número de variables en el factor:
ncol(data_factor_2)->m
#Constante de entropía:
-1/log(m)->K
print(K)
## [1] -0.91024
#Cálculo de las entropías
K*colSums(data_factor_2.1)->Ej
print(Ej)
##     X1     X2     X7 
## 4.1805 3.2029 3.7019
#Cálculo de las especificidades:
1-Ej->vj
print(vj)
##      X1      X2      X7 
## -3.1805 -2.2029 -2.7019
#Cálculo de los ponderadores:
prop.table(vj)->wj #es igual a usar vj/sum(vj)
print(wj)
##      X1      X2      X7 
## 0.39337 0.27245 0.33417

4. MÉTODO DE RANKING, para el factor 3

Jerarquia de Suma

#Vector de Jerarquías
rj<-c(0.38,0.49)
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.62 2.51
#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 = "light green")

Jerarquia Reciproca

#Vector de Jerarquías
rj<-c(0.38,0.49)
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.6316 2.0408
#Pesos normalizados
pesos_ranking_reciproco$w_normalizados %>% round(digits = 3)
##    X5    X6 
## 0.563 0.437
#Gráfico de los pesos normalizados
barplot(pesos_ranking_reciproco$w_normalizados,
        main = "Ponderadores Ranking Recíproco",
        ylim = c(0,0.5),col = "purple")

Jerarquía Exponencial

#Vector de Jerarquías
rj<-c(0.38,0.49)
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.8644 6.3001
#Pesos normalizados
pesos_ranking_exponencial$w_normalizados %>% round(digits = 3)
##    X5    X6 
## 0.521 0.479
#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 = "coral")