Se cargan los datos

load("C:/Users/SANCHEZ/Desktop/GABRIEL2021/Universidad/Ciclo VI/Metodos para el analisis economico/6-2.RData")
dt_parcial<-X6_2
dt_parcial %>% head() %>% 
  kable(caption ="Datos encuesta:" ,align = "c",digits = 6) %>% 
  kable_material(html_font = "sans-serif")
Datos encuesta:
V1 V2 V3 V4 V5 V6 V7 V8 V9 V10
4 1 4 3 3 2 4 4 4 4
5 5 4 4 3 3 4 1 1 3
2 1 3 1 4 2 1 5 4 5
1 1 1 1 4 4 2 5 5 4
1 1 2 1 5 5 4 3 3 2
5 5 5 5 3 3 4 2 2 1

Ejercicio 1

Análisis factorial

library(tidyr)

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
dt_parcial %>% 
  select(V2,V5,V6,V7,V8,V9,V10) %>% 
  apply(MARGIN = 2,FUN = norm_directa) %>% as.data.frame()->variables_corr_positiva
#Seleccionando las variables con correlación negativa
dt_parcial %>% 
  select(V1,V3,V4) %>% 
  apply(MARGIN = 2,FUN = norm_inversa) %>% as.data.frame()->variables_corr_negativa
#Juntando y reordenando las variables
variables_corr_positiva %>% 
  bind_cols(variables_corr_negativa) %>% 
  select(V1,V2,V3,V4,V5,V6,V7,V8,V9,V10)->dt_parcial_norm
head(dt_parcial_norm)
#Matriz de correlación
library(PerformanceAnalytics)
## Cargando paquete requerido: xts
## Cargando paquete requerido: zoo
## 
## Adjuntando el paquete: 'zoo'
## The following objects are masked from 'package:base':
## 
##     as.Date, as.Date.numeric
## 
## ######################### Warning from 'xts' package ##########################
## #                                                                             #
## # The dplyr lag() function breaks how base R's lag() function is supposed to  #
## # work, which breaks lag(my_xts). Calls to lag(my_xts) that you type or       #
## # source() into this session won't work correctly.                            #
## #                                                                             #
## # Use stats::lag() to make sure you're not using dplyr::lag(), or you can add #
## # conflictRules('dplyr', exclude = 'lag') to your .Rprofile to stop           #
## # dplyr from breaking base R's lag() function.                                #
## #                                                                             #
## # Code in packages is not affected. It's protected by R's namespace mechanism #
## # Set `options(xts.warn_dplyr_breaks_lag = FALSE)` to suppress this warning.  #
## #                                                                             #
## ###############################################################################
## 
## Adjuntando el paquete: 'xts'
## The following objects are masked from 'package:dplyr':
## 
##     first, last
## 
## Adjuntando el paquete: 'PerformanceAnalytics'
## The following object is masked from 'package:graphics':
## 
##     legend
chart.Correlation(as.matrix(dt_parcial_norm),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
## 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

# Prueba KMO
library(psych)
PKMO<-KMO(dt_parcial_norm)
print(PKMO)
## Kaiser-Meyer-Olkin factor adequacy
## Call: KMO(r = dt_parcial_norm)
## Overall MSA =  0.7
## MSA for each item = 
##   V1   V2   V3   V4   V5   V6   V7   V8   V9  V10 
## 0.82 0.74 0.84 0.93 0.55 0.32 0.37 0.62 0.68 0.84
#Prueba de Barlett
library(psych)
options(scipen = 99999)
Barlett<-cortest.bartlett(dt_parcial_norm)
## R was not square, finding R from data
print(Barlett)
## $chisq
## [1] 163.4656
## 
## $p.value
## [1] 0.000000000000002362835
## 
## $df
## [1] 45

P-value casi cero, no se rechaza la hipótesis

Análisis factorial

library(FactoMineR)
library(factoextra)
## Cargando paquete requerido: ggplot2
## 
## Adjuntando el paquete: '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)

Rx<-cor(dt_parcial_norm)
PC<-princomp(x = dt_parcial_norm,cor = TRUE,fix_sign = FALSE)
variables_pca<-get_pca_var(PC)
factoextra::get_eig(PC) %>% kable(caption="Resumen de PCA",
        align = "c",
        digits = 2) %>% 
  kable_material(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("hover"))
Resumen de PCA
eigenvalue variance.percent cumulative.variance.percent
Dim.1 5.70 57.01 57.01
Dim.2 2.07 20.69 77.70
Dim.3 0.72 7.20 84.91
Dim.4 0.55 5.48 90.39
Dim.5 0.32 3.16 93.54
Dim.6 0.27 2.71 96.25
Dim.7 0.15 1.46 97.72
Dim.8 0.13 1.28 99.00
Dim.9 0.07 0.68 99.68
Dim.10 0.03 0.32 100.00 
fviz_eig(PC,
         choice = "eigenvalue",
         barcolor = "red",
         barfill = "red",
         addlabels = TRUE, 
       )+labs(title = "Gráfico de Sedimentación",subtitle = "Usando princomp, con Autovalores")+
  xlab(label = "Componentes")+
  ylab(label = "Autovalores")+geom_hline(yintercept = 1)

Por criterio de raíz latente, dos factores Por criterio de porcentaje acumulado, dos factores

library(corrplot)
## corrplot 0.95 loaded
#Modelo de 2 Factores (Rotada)
numero_de_factores<-2
modelo_factores<-principal(r = Rx,
                             nfactors = numero_de_factores,
                             covar = FALSE,
                             rotate = "varimax")
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
## V1   0.87  0.18 0.78 0.22 1.1
## V2  -0.93 -0.02 0.86 0.14 1.0
## V3   0.83  0.19 0.72 0.28 1.1
## V4   0.92  0.20 0.88 0.12 1.1
## V5   0.46  0.77 0.80 0.20 1.6
## V6   0.11  0.91 0.85 0.15 1.0
## V7  -0.34  0.64 0.53 0.47 1.5
## V8   0.87 -0.07 0.77 0.23 1.0
## V9   0.89 -0.05 0.79 0.21 1.0
## V10  0.80 -0.38 0.79 0.21 1.4
## 
##                        RC1  RC2
## SS loadings           5.67 2.10
## Proportion Var        0.57 0.21
## Cumulative Var        0.57 0.78
## Proportion Explained  0.73 0.27
## Cumulative Proportion 0.73 1.00
## 
## Mean item complexity =  1.2
## Test of the hypothesis that 2 components are sufficient.
## 
## The root mean square of the residuals (RMSR) is  0.07 
## 
## Fit based upon off diagonal values = 0.98
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="grey",
         number.cex = 0.75)

A la primera dimensión corresponden las variables V1,V2,V3,V4,V8,V9,V10 mientras que a la dos corresponde V5,V6 y V7

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(html_font = "sans-serif") %>% 
  kable_styling(bootstrap_options = c("striped", "hover"))
Ponderadores de los Factores Extraídos
Dim.1 Dim.2
0.69 0.31 
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
V1 0.22 0.02
V2 0.26 0.00
V3 0.20 0.02
V4 0.25 0.03
V5 0.06 0.38
V6 0.00 0.54 
dt_fact1<-dt_parcial %>% select(V1,V2,V3,V4,V8,V9,V10)
dt_fact2<-dt_parcial %>% select(V5,V6,V7)

Ejercicio 2

Ejercicio 3

Factor 1

Método Critic

### Método CRITIC
ponderadores_critic <- function(matriz_datos) {
  # Desviaciones de las variables
  sigma <- apply(X = matriz_datos, MARGIN = 2, sd)
  # Correlaciones entre las variables
  rho <- cor(matriz_datos)
  # Suma de las correlaciones excedentes
  cj <- apply(X = 1 - rho, MARGIN = 2, sum)
  # Cálculos de ponderadores
  pesos_brutos <- sigma * cj
  pesos_normalizados <- prop.table(pesos_brutos)
  # Salida de resultados
  resultados <- list(pesos_brutos = pesos_brutos,
                     pesos_normalizados = pesos_normalizados)
  return(resultados) 
}
pesos_CRITIC1<-ponderadores_critic(matriz_datos =dt_fact1) %>% print()
## $pesos_brutos
##        V1        V2        V3        V4        V8        V9       V10 
##  7.080502  9.486878  6.392929  9.018288  9.860234 10.520512  9.269014 
## 
## $pesos_normalizados
##        V1        V2        V3        V4        V8        V9       V10 
## 0.1148903 0.1539369 0.1037336 0.1463334 0.1599951 0.1707090 0.1504018

Entropia

### Método de Entropía
ponderadores_entropia <- function(matriz_datos, constante = 0){
  aij <- apply(X = matriz_datos + constante, MARGIN = 2, prop.table)
  log_aij <- apply(X = aij, MARGIN = 2, log10)
  aij_log_aij <- aij * log_aij
  sum_aij_log_aij <- apply(X = aij_log_aij, MARGIN = 2, sum)
  n <- nrow(matriz_datos)
  K <- 1 / log10(n)
  E <- (-K * sum_aij_log_aij)
  pesos_brutos <- 1 - E
  pesos_normalizados <- prop.table(pesos_brutos)
  resultados <- list(pesos_brutos = pesos_brutos,
                     pesos_normalizados = pesos_normalizados)
  return(resultados)
}
pesos_entropia1<-ponderadores_entropia(matriz_datos = dt_fact1) %>% print()
## $pesos_brutos
##         V1         V2         V3         V4         V8         V9        V10 
## 0.02456135 0.04195614 0.02045509 0.05435237 0.03947086 0.04608886 0.04243929 
## 
## $pesos_normalizados
##         V1         V2         V3         V4         V8         V9        V10 
## 0.09119630 0.15578317 0.07594976 0.20181038 0.14655532 0.17112798 0.15757710

Factor 2

CRITIC

pesos_CRITIC2<-ponderadores_critic(matriz_datos =dt_fact2) %>% print()
## $pesos_brutos
##       V5       V6       V7 
## 1.003620 0.988261 1.780402 
## 
## $pesos_normalizados
##        V5        V6        V7 
## 0.2660511 0.2619796 0.4719693

Entropia

pesos_entropia2<-ponderadores_entropia(matriz_datos = dt_fact2) %>% print()
## $pesos_brutos
##         V5         V6         V7 
## 0.01068315 0.01716810 0.02282573 
## 
## $pesos_normalizados
##        V5        V6        V7 
## 0.2108087 0.3387751 0.4504162