EJERCICIO 2 (20%)

Una empresa especializada en el diseño de automóviles de turismo desea estudiar cuales son los deseos del publico que compra automóviles. Para ello diseña una encuesta con 10 preguntas donde se le pide a cada uno de los 20 encuestados que valore de 1 a 5 si una característica es o no muy importante. Los encuestados deberán contestar con un 5 si la característica es muy importante, un 4 si es importante, un 3 si tiene regular importancia, un 2 si es poco importante y 1 si no es nada importante.

Las 10 caracteristicas (V1 a V10) a valorar son: precio, financiación, consumo, combustible, seguridad, confort, capacidad, prestaciones, modernidad y aerodinámica. El fichero 6-2.RData recoge los datos a ser utilizados.

CARGA DE DATOS

load("C:/Users/Luis Anaya/OneDrive/Desktop/metodos para el analisis economico/UNIDAD II/Data_Parcial2MAE_6-2.RData")

MATRIZ DE INFORMACIÓN

library(kableExtra)
library(dplyr)
library(magrittr)
mat_X<-X6_2
mat_X %>% head() %>% 
  kable(caption ="Matriz de informacion:", align = "c", digits = 6) %>% kable_material(html_font = "sans-serif")
Matriz de informacion:
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

GRÁFICO

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

PRUEBA DE KMO

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

El valor de KMO es 0.70, por lo tal es apropiado continuar con el análisis.

PRUEBA DE BARLETT

library(psych)
options(scipen = 99999)
Barlett<-cortest.bartlett(mat_X)
print(Barlett)
## $chisq
## [1] 163.47
## 
## $p.value
## [1] 0.0000000000000023628
## 
## $df
## [1] 45

Se rechaza Ho ya que p-value< nivel de significancia (5%). Por lo tanto, hay evidencia de correlacion poblacional entre la bateria de indicadores propuesta.

ANALISIS FACTORIAL

library(FactoMineR)
library(factoextra)
library(kableExtra)

Rx<-cor(mat_X)
PC<-princomp(x = mat_X,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

Por el criterio de raíz latente: debemos retenr 2 componentes.

Por el criterio de porcentaje acumulado de la varianza: deberiamos retener 2 componentes porque son las que superan las tres cuartas partes de la varianza total.

GRÁFICO DE SEDIMENTACION

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

ROTACIÓN

library(corrplot)
#Modelo de 3 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

VARIABLES INCLUIDAS EN CADA FACTOR

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)

library(kableExtra)
cargas<-rotacion$loadings[1:8,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.68 0.32 
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.18 0.02
V2 0.20 0.00
V3 0.16 0.02
V4 0.20 0.02
V5 0.05 0.30
V6 0.00 0.43
V7 0.03 0.21
V8 0.18 0.00