Análise de Correspondência - disclosure - ANACOR

---

Imagine que um pesquisador esteja interessado em investigar se existe algum tipo de relação entre a origem de capital (controle acionário: asiático, brasileiro, americano, europeu ou latino) e o nível de transparência (disclosure) das informações contábeis (alto, médio ou baixo) das empresas pertencentes a uma amostra com 216 empresas

# install.packages("FactoMineR", "gglot2", "readxl")
# install.packages("devtools")
# devtools::install_github("kassambara/factoextra")
rm(list=ls(all=TRUE))
library("ggplot2")
library("FactoMineR")
library("factoextra")
library("readxl")
library("gplots")
library("corrplot")
library("graphics")

# ler e carregar os dados
disclosure <- read_excel("disclosure.xls")
head(disclosure)

str(disclosure)

Classes ‘tbl_df’, ‘tbl’ and 'data.frame':   216 obs. of  2 variables:
 $ pais      : num  1 1 1 1 1 1 1 1 1 1 ...
 $ disclosure: num  3 3 3 3 3 3 1 1 1 2 ...

# atribuindo categorias aos números (VA qualitativa)
disclosure$pais <- factor(disclosure$pais, labels = c("asiático", "brasileiro", "americano", "europeu", "latino"))
disclosure$disclosure <- factor(disclosure$disclosure, labels = c("baixo", "médio", "alto"))
head(disclosure)

tab <- table(disclosure)
tab

            disclosure
pais         baixo médio alto
  asiático       8    10   13
  brasileiro    34    27   14
  americano     16    19   39
  europeu        3     2    1
  latino        10    17    3

### 1. convert the data as a table
dt <- as.table(as.matrix(tab))
### 2. Graph
balloonplot(t(dt), main ="País - Disclosure", 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 = 33.149, df = 8, p-value = 5.791e-05

### Observed counts
chisq$observed

            disclosure
pais         baixo médio alto
  asiático       8    10   13
  brasileiro    34    27   14
  americano     16    19   39
  europeu        3     2    1
  latino        10    17    3

### Expected counts
round(chisq$expected,2)

            disclosure
pais         baixo médio  alto
  asiático   10.19 10.76 10.05
  brasileiro 24.65 26.04 24.31
  americano  24.32 25.69 23.98
  europeu     1.97  2.08  1.94
  latino      9.86 10.42  9.72

# residuals
round(chisq$residuals, 3)

            disclosure
pais          baixo  médio   alto
  asiático   -0.686 -0.233  0.932
  brasileiro  1.883  0.188 -2.090
  americano  -1.688 -1.321  3.067
  europeu     0.732 -0.058 -0.677
  latino      0.044  2.040 -2.156

#ou 
#(chisq$observed-chisq$expected)^2/chisq$expected
corrplot(chisq$residuals, is.cor = FALSE)

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

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

            disclosure
pais          baixo  médio   alto
  asiático    1.420  0.164  2.620
  brasileiro 10.691  0.106 13.182
  americano   8.594  5.262 28.374
  europeu     1.616  0.010  1.384
  latino      0.006 12.552 14.022

### 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.1534655

A raiz quadrada de \(\phi^2\) é chamada traço e pode ser interpretada como um coeficiente de correlação

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}\)

Para um determinado eixo, o autovalor (λ) é calculado da seguinte forma:

\(\lambda_{axis} = \sum{\frac{row.sum}{grand.total} * row.coord^2}\)

\(\lambda_{axis} = \sum{\frac{col.sum}{grand.total} * col.coord^2}\)

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)
### Standardized residuals
residuals <- chisq$residuals/sqrt(n)
### Number of dimensions
nb.axes <- min(nrow(residuals)-1, ncol(residuals)-1)
### Singular value decomposition
res.svd <- svd(residuals, nu = nb.axes, nv = nb.axes)
res.svd

$d
[1] 3.682595e-01 1.336053e-01 1.766556e-17

$u
           [,1]        [,2]
[1,] -0.2123970 -0.13641520
[2,]  0.4812011  0.54991331
[3,] -0.6910928 -0.04463595
[4,]  0.1576045  0.26465257
[5,]  0.4699837 -0.77907182

$v
           [,1]        [,2]
[1,]  0.4349627  0.69433693
[2,]  0.3699150 -0.71829008
[3,] -0.8209570  0.04422198

### singular value
sv <- res.svd$d[1:nb.axes] 
u <-res.svd$u
v <- res.svd$v
# inércia total
sum(sv^2)

[1] 0.1534655

### 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 mass
row.mass <- row.sum/n
### 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
asiático   -0.206 -0.048
brasileiro  0.301  0.125
americano  -0.435 -0.010
europeu     0.348  0.212
latino      0.464 -0.279

### 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
baixo  0.2793854  0.16180484
médio  0.2311811 -0.16286196
alto  -0.5310706  0.01037862

### 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)

Diagnóstico

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

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

Nosso gráfico bidimensional captura cerca de 88% 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
asiático    4.51  1.86
brasileiro 23.16 30.24
americano  47.76  0.20
europeu     2.48  7.00
latino     22.09 60.70

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
baixo 18.92 48.21
médio 13.68 51.59
alto  67.40  0.20

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))

            disclosure
pais         baixo médio  alto
  asiático   0.258 0.323 0.419
  brasileiro 0.453 0.360 0.187
  americano  0.216 0.257 0.527
  europeu    0.500 0.333 0.167
  latino     0.333 0.567 0.100

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

baixo médio  alto 
0.329 0.347 0.324 

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))

  asiático brasileiro  americano    europeu     latino 
     0.045      0.106      0.189      0.166      0.294 

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
asiático   0.949 0.051
brasileiro 0.853 0.147
americano  0.999 0.001
europeu    0.729 0.271
latino     0.734 0.266

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)

baixo médio  alto 
0.104 0.080 0.282 

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
baixo 0.749 0.251
médio 0.668 0.332
alto  1.000 0.000

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

Pacotes no R para ANACOR

-FactoMineR -ade4 -ca

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

Call:
CA(X = tab, graph = F) 

The chi square of independence between the two variables is equal to 33.14854 (p-value =  5.790601e-05 ).

Eigenvalues
                       Dim.1   Dim.2
Variance               0.136   0.018
% of var.             88.368  11.632
Cumulative % of var.  88.368 100.000

Rows
             Iner*1000    Dim.1    ctr   cos2    Dim.2    ctr   cos2  
asiático   |     6.450 |  0.206  4.511  0.949 | -0.048  1.861  0.051 |
brasileiro |    36.800 | -0.301 23.155  0.853 |  0.125 30.240  0.147 |
americano  |    64.807 |  0.435 47.761  0.999 | -0.010  0.199  0.001 |
europeu    |     4.619 | -0.348  2.484  0.729 |  0.212  7.004  0.271 |
latino     |    40.790 | -0.464 22.088  0.734 | -0.279 60.695  0.266 |

Columns
             Iner*1000    Dim.1    ctr   cos2    Dim.2    ctr   cos2  
baixo      |    34.263 | -0.279 18.919  0.749 |  0.162 48.210  0.251 |
médio      |    27.767 | -0.231 13.684  0.668 | -0.163 51.594  0.332 |
alto       |    91.435 |  0.531 67.397  1.000 |  0.010  0.196  0.000 |

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

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

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