Planteamiento del Ejercicio

Ejercicio Adaptado de Moreno, A. B., & Chávez, A. G. (2007). 100 problemas resueltos de estadística multivariante. Delta Publicaciones. ver texto

Un banco dispone de una muestra de 51 entidades financieras que cotizan ciertos derivados financieros cuyo valor en mercado permite estimar la probabilidad de que la empresa quiebre en el plazo de un año y, en caso de quiebra, la tasa de recuperación de la misma. Las empresas observadas también han sido analizadas por dos agencias de calificación externas, que han estimado la probabilidad de quiebra a un año basándose en auditorías realizadas. En la Tabla 7.2 se pueden ver las observaciones de las siguientes variables:

X1 = Nivel crediticio otorgado por el banco internamente a la entidad,
X2 = Número de días que ha cotizado en mercado el derivado financiero,
X3 = Probabilidad de quiebra deducida del derivado,
X4 = Tasa de recuperación deducida del derivado,
X5 = Probabilidad de quiebra emitida por la primera agencia externa,
X6 = Probabilidad de quiebra emitida por la segunda agencia externa.

Cálcule los ponderadores para un Indicador Multivariado Sintético, que muestre el estado de la salud financiera del banco estudiado.
Correlación de las variables con la salud financiera del Banco:
X1 (-)
X2 (+)
X3 (-)
X4 (+)
X5 (-)
X6 (-)

library(readr)
nombre_archivo<-"http://halweb.uc3m.es/esp/Personal/personas/agrane/libro/ficheros_datos/capitulo_7/entidades_financieras.txt"
datos_financieros<-read_table2(nombre_archivo,col_names = FALSE)
head(datos_financieros)
## # A tibble: 6 × 6
##      X1    X2      X3    X4      X5      X6
##   <dbl> <dbl>   <dbl> <dbl>   <dbl>   <dbl>
## 1   7.6   630 0.0007   0.36 0.00041 0.00003
## 2   7.8   630 0.00056  0.39 0.00041 0.00003
## 3   8.1   630 0.00049  0.4  0.00041 0.00003
## 4   7.5   630 0.0006   0.39 0.00041 0.00026
## 5   7.5   630 0.00047  0.4  0.00041 0.00026
## 6   8.3   630 0.00055  0.4  0.00041 0.00019

Normalización de Datos usando across y los helpers

library(dplyr)
norm_directa<-function(x){(x-min(x))/(max(x)-min(x))}
norm_inversa<-function(x){(max(x)-x)/(max(x)-min(x))}
df<-datos_financieros
nombres_originales<-names(df)
tipo_correlacion<-c("inversa","directa","inversa","directa","inversa","inversa")
names(df)<-paste0(names(df),"_",tipo_correlacion)
df<-df |> 
  mutate(across(all_of(ends_with("directa")),norm_directa)) |> 
  mutate(across(all_of(ends_with("inversa")),norm_inversa))
names(df)<-nombres_originales
datos_financieros_normalizados<-df
head(datos_financieros_normalizados)
## # A tibble: 6 × 6
##      X1    X2    X3    X4    X5    X6
##   <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 0.429     1 0.878 0.286 0.937 0.996
## 2 0.371     1 0.914 0.5   0.937 0.996
## 3 0.286     1 0.932 0.571 0.937 0.996
## 4 0.457     1 0.904 0.5   0.937 0.967
## 5 0.457     1 0.938 0.571 0.937 0.967
## 6 0.229     1 0.917 0.571 0.937 0.976

Matriz de Correlación & Pruebas de Barlett y KMO

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

#KMO
library(rela)
KMO<-paf(as.matrix(datos_financieros_normalizados))$KMO
print(KMO)
## [1] 0.71477
#Prueba de Barlett
library(psych)
options(scipen = 99999)
Barlett<-cortest.bartlett(datos_financieros_normalizados)
print(Barlett)
## $chisq
## [1] 295.14
## 
## $p.value
## [1] 0.0000000000000000000000000000000000000000000000000000057222
## 
## $df
## [1] 15

Análisis Factorial

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

Rx<-cor(datos_financieros_normalizados)
PC<-princomp(x = datos_financieros_normalizados,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 3.88 64.73 64.73
Dim.2 1.16 19.34 84.07
Dim.3 0.58 9.67 93.73
Dim.4 0.24 3.96 97.70
Dim.5 0.11 1.84 99.53
Dim.6 0.03 0.47 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)

library(corrplot)
#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
## X1 -0.86 -0.14 0.76 0.242 1.1
## X2 -0.05  0.88 0.79 0.215 1.0
## X3  0.90  0.35 0.93 0.068 1.3
## X4  0.91 -0.13 0.84 0.160 1.0
## X5  0.61  0.68 0.84 0.165 2.0
## X6  0.74  0.59 0.89 0.107 1.9
## 
##                        RC1  RC2
## SS loadings           3.29 1.76
## Proportion Var        0.55 0.29
## Cumulative Var        0.55 0.84
## Proportion Explained  0.65 0.35
## Cumulative Proportion 0.65 1.00
## 
## Mean item complexity =  1.4
## Test of the hypothesis that 2 components are sufficient.
## 
## The root mean square of the residuals (RMSR) is  0.09 
## 
## 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)

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.65 0.35 
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
X1 0.22 0.01
X2 0.00 0.45
X3 0.25 0.07
X4 0.25 0.01
X5 0.11 0.26
X6 0.16 0.20