Análise de Correspondência - perfil investidor aplicacao - ANACOR

---

# install.packages("FactoMineR", "gglot2", "readxl")
# install.packages("devtools")
# devtools::install_github("kassambara/factoextra")
library("ggplot2")
library("FactoMineR")
library("factoextra")
library("readxl")
library("gplots")
library("corrplot")
library("graphics")
library("foreign")
library("readxl")

Ler os dados e atribuir ordem para perfil e aplicação

# ler os dados
investidor <- read_excel("perfil investidor aplicacao.xlsx")
investidor

# atribuir níveis ao perfil e tipo sw aplicação
investidor$perfil <- factor(investidor$perfil, levels = c("Conservador", "Moderado", "Agressivo"))
investidor$aplicacao <-factor(investidor$aplicacao, levels = c("Poupança", "CDB", "Ações"))
tab <- table(investidor$perfil, investidor$aplicacao)
tab

             
              Poupança CDB Ações
  Conservador        8   4     5
  Moderado           5  16     4
  Agressivo          2  20    36

# 1. convert the data as a table
dt <- as.table(as.matrix(tab))
# 2. Graph
balloonplot(t(dt), main ="Tabela de contingência - Perfil x Aplicação ", xlab ="", ylab="",
            label = T, show.margins = T)

As células com os resíduos padronizados absolutos mais elevados contribuem mais para a pontuação total do Qui-quadrado.

chisq <- chisq.test(tab)

Aproxima攼㸷攼㸳o do qui-quadrado pode estar incorreta

chisq

    Pearson's Chi-squared test

data:  tab
X-squared = 31.764, df = 4, p-value = 2.138e-06

# Observed counts
chisq$observed

             
              Poupança CDB Ações
  Conservador        8   4     5
  Moderado           5  16     4
  Agressivo          2  20    36

# Expected counts 
round(chisq$expected,2)

             
              Poupança  CDB Ações
  Conservador     2.55  6.8  7.65
  Moderado        3.75 10.0 11.25
  Agressivo       8.70 23.2 26.10

# residuals padronizados 
round(chisq$residuals, 2)

             
              Poupança   CDB Ações
  Conservador     3.41 -1.07 -0.96
  Moderado        0.65  1.90 -2.16
  Agressivo      -2.27 -0.66  1.94

corrplot(chisq$residuals, is.cor = FALSE)

A contribuição (em %) de uma dada célula para a pontuação total do Qui-quadrado

### Contibution in percentage (%)
contrib <- 100*chisq$residuals^2/chisq$statistic
round(contrib, 3)

             
              Poupança    CDB  Ações
  Conservador   36.670  3.630  2.890
  Moderado       1.312 11.334 14.709
  Agressivo     16.244  1.390 11.822

### Visualize the contribution
corrplot(contrib, is.cor = FALSE)

A inércia total (\(\phi^2\)) é a quantidade de informação contida na tabela de dados

phi2 <- as.numeric(chisq$statistic/sum(tab))
phi2

[1] 0.3176416

o valor \(\phi\) > 0,2 indica uma dependência significativa entre linhas e colunas

O gráfico mosaico é usado para visualizar uma tabela de contingência para examinar a associação entre as variáveis categóricas.

### Mosaic plot of observed values
mosaicplot(tab,  las=2, col="steelblue",
           main = "Países.Disclosure - observed counts")

### Mosaic plot of expected values
mosaicplot(chisq$expected,  las=2, col = "gray",
           main = "Países.Disclosure - expected counts")

Nessas parcelas, as variáveis de coluna são primeiramente divididas (divisão vertical) e, em seguida, as variáveis de linha são divididas (divisão horizontal).

Para cada célula, a altura das barras é proporcional à frequência relativa observada que contém:

O gráfico azul, é o gráfico de mosaico dos valores observados.

O cinzento é o gráfico em mosaico dos valores esperados sob hipótese nula.

Se as variáveis de linha e coluna fossem completamente independentes, as barras de mosaico para os valores observados (gráfico azul) seriam alinhadas como as barras de mosaico para os valores esperados (gráfico cinza).

Também é possível colorir o mosaico de acordo com o valor dos resíduos padronizados:

mosaicplot(tab, shade = TRUE, las=2,main = "Países.Disclosure")

Análise de correspondência

Análise de correspondência (ANACOR) é necessária para a tabela de contingência grande.

Aplica-se para visualizar pontos da linha e pontos da coluna em um espaço dimensional reduzido.

ANACOR é um método de redução dimensional aplicado a uma tabela de contingência.

A informação retida por cada dimensão é chamada autovalor.

A informação total (ou inércia) contida nos dados é chamada phi (\(\phi^2\)) e pode ser calculado da seguinte forma:

\(\phi^2 = \frac{\chi^2}{grand.total}\)

A análise de correspondência é usada para representar graficamente a tabela de distâncias entre variáveis de linha ou entre variáveis de coluna.

A abordagem ANACOR inclui as seguintes etapas:

1.Calcular os resíduos padronizados

Os resíduos padronizados (S) são:

\(S = \frac{o - e}{\sqrt{e}}\)

De fato, S é apenas a raíz quadrada dos termos que compõem a estatística \(\chi^2\).

2. Calcule a decomposição do valor singular (SVD) dos resíduos padronizados.

\(M = \frac{1}{sqrt(grand.total)} \times S\)

SVD significa que queremos encontrar matrizes ortogonais U e V, em conjunto com uma matriz diagonal \(\Delta\), tal que:

\(M = U \Delta V^T\)

• U É uma matriz contendo autovetores de linhas
• Δ É a matriz diagonal. Os números na diagonal da matriz são chamados de valores singulares (SV). Os autovalores são o SV quadrado.
• V É uma matriz contendo autovetores de coluna

O autovalor de um determinado eixo é:

\(\lambda = \delta^2\)

\(\delta\) É o valor singular

As coordenadas das variáveis de linha em um determinado eixo são:

\(row.coord = \frac{U * \delta }{\sqrt{row.mass}}\)

As coordenadas das colunas são

\(col.coord = \frac{V * \delta }{\sqrt{col.mass}}\)

cálculo SVD

### Grand total
n <- sum(tab)
n

[1] 100

### Standardized residuals
residuals <- chisq$residuals/sqrt(n)
residuals

             
                 Poupança         CDB       Ações
  Conservador  0.34129224 -0.10737510 -0.09581095
  Moderado     0.06454972  0.18973666 -0.21615324
  Agressivo   -0.22715127 -0.06643638  0.19378267

### Number of dimensions
nb.axes <- min(nrow(residuals)-1, ncol(residuals)-1)
nb.axes

[1] 2

### Singular value decomposition
res.svd <- svd(residuals, nu = nb.axes, nv = nb.axes)
res.svd

$d
[1] 4.829233e-01 2.905629e-01 1.166671e-18

$u
           [,1]       [,2]
[1,] -0.6716248  0.6155649
[2,] -0.3980015 -0.7691520
[3,]  0.6249119  0.1717122

$v
            [,1]       [,2]
[1,] -0.82178847  0.4179279
[2,] -0.09300977 -0.7689923
[3,]  0.56215025  0.4837221

### singular value
sv <- res.svd$d[1:nb.axes] 
u <-res.svd$u
v <- res.svd$v

### Eigenvalues
eig <- sv^2
### Variances in percentage
variance <- eig*100/sum(eig)
### Cumulative variances
cumvar <- cumsum(variance)
eig<- data.frame(eig = eig, variance = variance,
                     cumvariance = cumvar)
head(eig)

barplot(eig[, 2], names.arg=1:nrow(eig), 
       main = "Variances",
       xlab = "Dimensions",
       ylab = "Percentage of variances",
       col ="steelblue")
### Add connected line segments to the plot
lines(x = 1:nrow(eig), eig[, 2], 
      type="b", pch=19, col = "red")

Quantas dimensões reter ?

1. O número máximo de eixos na ANACOR é:

\(nb.axes = min(r-1, c-1)\)

r e c são respectivamente o número de linhas e colunas na tabela.

Row coordinates

### row sum
row.sum <- apply(tab, 1, sum)
row.sum

Conservador    Moderado   Agressivo 
         17          25          58 

### row mass
row.mass <- row.sum/n
row.mass

Conservador    Moderado   Agressivo 
       0.17        0.25        0.58 

### row coord = sv * u /sqrt(row.mass)
cc <- t(apply(u, 1, '*', sv)) ### each row X sv
row.coord <- apply(cc, 2, '/', sqrt(row.mass))
rownames(row.coord) <- rownames(tab)
colnames(row.coord) <- paste0("Dim.", 1:nb.axes)
round(row.coord,3)

             Dim.1  Dim.2
Conservador -0.787  0.434
Moderado    -0.384 -0.447
Agressivo    0.396  0.066

### plot
plot(row.coord, pch=19, col = "blue")
text(row.coord, labels =rownames(row.coord), pos = 3, col ="blue")

abline(v=0, h=0, lty = 2)

Column coordinates

### Coordinates of columns
col.sum <- apply(tab, 2, sum)
col.mass <- col.sum/n
### coordinates sv * v /sqrt(col.mass)
cc <- t(apply(v, 1, '*', sv))
col.coord <- apply(cc, 2, '/', sqrt(col.mass))
rownames(col.coord) <- colnames(tab)
colnames(col.coord) <- paste0("Dim", 1:nb.axes)
head(col.coord)

                Dim1       Dim2
Poupança -1.02469008  0.3135421
CDB      -0.07101935 -0.3532906
Ações     0.40469167  0.2095221

### plot
plot(col.coord, pch=17, col = "red")
text(col.coord, labels =rownames(col.coord), pos = 3, col ="red")

abline(v=0, h=0, lty = 2)

Biplot de linhas e colunas para ver a associação

xlim <- range(c(row.coord[,1], col.coord[,1]))*1.1
ylim <- range(c(row.coord[,2], col.coord[,2]))*1.1
### Plot of rows
plot(row.coord, pch=19, col = "blue", xlim = xlim, ylim = ylim)
text(row.coord, labels =rownames(row.coord), pos = 3, col ="blue")

### plot off columns
points(col.coord, pch=17, col = "red")
text(col.coord, labels =rownames(col.coord), pos = 3, col ="red")

abline(v=0, h=0, lty = 2)

Você pode interpretar a distância entre pontos de linhas ou entre pontos de coluna, mas a distância entre pontos de coluna e pontos de linha não são significativos.

Diagnóstico

Lembre-se que, a inércia total contida nos dados é:

\(\phi^2 = \frac{\chi^2}{n} = 0.3176\)

Nosso gráfico bidimensional captura 100% da inércia total da tabela.

Contribuição de linhas e colunas

As contribuições de uma linha / coluna para a definição de um eixo principal são:

\(row.contrib = \frac{row.mass * row.coord^2}{eigenvalue}\)

\(col.contrib = \frac{col.mass * col.coord^2}{eigenvalue}\)

Contribuição de linhas em %

### contrib <- row.mass * row.coord^2/eigenvalue
cc <- apply(row.coord^2, 2, "*", row.mass)
row.contrib <- t(apply(cc, 1, "/", eig[1:nb.axes,1])) *100
round(row.contrib, 2)

            Dim.1 Dim.2
Conservador 45.11 37.89
Moderado    15.84 59.16
Agressivo   39.05  2.95

corrplot(row.contrib, is.cor = FALSE)

Contribuição das colunas em %

### contrib <- col.mass * col.coord^2/eigenvalue
cc <- apply(col.coord^2, 2, "*", col.mass)
col.contrib <- t(apply(cc, 1, "/", eig[1:nb.axes,1])) *100
round(col.contrib, 2)

          Dim1  Dim2
Poupança 67.53 17.47
CDB       0.87 59.13
Ações    31.60 23.40

corrplot(col.contrib, is.cor = FALSE)

Qualidade da representação

A qualidade da representação é chamada COS2.

A qualidade da representação de uma linha em um eixo é:

\(row.cos2 = \frac{row.coord^2}{d^2}\)

• Row.coord é a coordenada da linha no eixo
• \(d^2\) É a distância ao quadrado do perfil médio

Lembre-se de que a distância entre cada perfil de linha e o perfil de linha médio é:

\(d^2(row_i, average.profile) = \sum{\frac{(row.profile_i - average.profile)^2}{average.profile}}\)

row.profile <- tab/row.sum
head(round(row.profile, 3))

             
              Poupança   CDB Ações
  Conservador    0.471 0.235 0.294
  Moderado       0.200 0.640 0.160
  Agressivo      0.034 0.345 0.621

average.profile <- col.sum/n
head(round(average.profile, 3))

Poupança      CDB    Ações 
    0.15     0.40     0.45 

O código R abaixo calcula a distância do perfil médio para todas as variáveis de linha

average.rp <- col.sum/n 
d2.row <- apply(row.profile, 1, 
                function(row.p, av.p){sum(((row.p - av.p)^2)/av.p)}, 
                average.rp)
head(round(d2.row,3))

Conservador    Moderado   Agressivo 
      0.807       0.348       0.161 

O cos2 de linhas no mapa de fatores são:

row.cos2 <- apply(row.coord^2, 2, "/", d2.row)
round(row.cos2, 3)

            Dim.1 Dim.2
Conservador 0.767 0.233
Moderado    0.425 0.575
Agressivo   0.973 0.027

corrplot(row.cos2, is.cor = FALSE)

Cos2 das colunas

\(col.cos2 = \frac{col.coord^2}{d^2}\)

col.profile <- t(tab)/col.sum
col.profile <- t(col.profile)
###head(round(col.profile, 3))
average.profile <- row.sum/n
###head(round(average.profile, 3))

O código R abaixo calcula a distância do perfil médio para todas as variáveis da coluna

d2.col <- apply(col.profile, 2, 
        function(col.p, av.p){sum(((col.p - av.p)^2)/av.p)}, 
        average.profile)
round(d2.col,3)

Poupança      CDB    Ações 
   1.148    0.130    0.208 

O cos2 das colunas no mapa de fatores são:

col.cos2 <- apply(col.coord^2, 2, "/", d2.col)
round(col.cos2, 3)

          Dim1  Dim2
Poupança 0.914 0.086
CDB      0.039 0.961
Ações    0.789 0.211

corrplot(col.cos2, is.cor = FALSE)

Pacotes no R para ANACOR

-FactoMineR -ade4 -ca

library(FactoMineR)
res.ca <- CA(tab, graph = F)
res.ca

**Results of the Correspondence Analysis (CA)**
The row variable has  3  categories; the column variable has 3 categories
The chi square of independence between the two variables is equal to 31.76416 (p-value =  2.137594e-06 ).
*The results are available in the following objects:

   name              description                   
1  "$eig"            "eigenvalues"                 
2  "$col"            "results for the columns"     
3  "$col$coord"      "coord. for the columns"      
4  "$col$cos2"       "cos2 for the columns"        
5  "$col$contrib"    "contributions of the columns"
6  "$row"            "results for the rows"        
7  "$row$coord"      "coord. for the rows"         
8  "$row$cos2"       "cos2 for the rows"           
9  "$row$contrib"    "contributions of the rows"   
10 "$call"           "summary called parameters"   
11 "$call$marge.col" "weights of the columns"      
12 "$call$marge.row" "weights of the rows"         

### eigenvalue
head(res.ca$eig)[, 1:2]

### barplot of percentage of variance
barplot(res.ca$eig[,2], names.arg = rownames(res.ca$eig))

### Plot row points
plot(res.ca, invisible ="col")

### Plot column points
plot(res.ca, invisible ="row")

### Biplot of rows and columns
plot(res.ca)