Redução de Dimensionalidade e Agrupamento
Fundamentos de Pesquisa em Ciência da Computação
16 de abril de 2016
knitr::opts_chunk$set(echo=TRUE, warning=FALSE, message=FALSE, fig.width=12, fig.height=6)No Brasil os parlamentares dispõe de uma verba destinada a cobrir despesas referentes ao exercicio da atividade parlamentar, o conjunto de dados utilizado pode ser encontrado aqui e é referente aos gastos dos deputados no ano de 2015.
#install.packages('ggfortify')
#install.packages("Rtsne")
#install.packages("fpc")
#install.packages("cluster")
library(ggplot2)
library(dplyr)
library(reshape2)
library(knitr)
library(GGally)
library(ggfortify)
library(dbscan)
library(cluster)
library(dbscan)
cam <- read.csv("AnoAtual.csv", header = TRUE, fileEncoding = "UTF-8")Os dados possuem as seguintes variáveis:
head(cam, n=3)## orgao..nome. codLegislatura datEmissao ideCadastro
## 1 Câmara dos Deputados 55 2015-03-02T00:00:00 73483
## 2 Câmara dos Deputados 54 2015-01-13T00:00:00 74151
## 3 Câmara dos Deputados 55 2015-01-12T00:00:00 74474
## indTipoDocumento nuCarteiraParlamentar nuLegislatura numAno
## 1 0 500 2015 2015
## 2 0 236 2011 2015
## 3 0 530 2015 2015
## numEspecificacaoSubCota numLote numMes numParcela numRessarcimento
## 1 0 1170562 3 0 4944
## 2 0 1162292 1 0 4882
## 3 0 1164115 1 0 4902
## numSubCota sgPartido sgUF txNomeParlamentar
## 1 12 PP RS LUIS CARLOS HEINZE
## 2 12 PSD MG GERALDO THADEU
## 3 12 PCdoB PE CARLOS EDUARDO CADOCA
## txtBeneficiario txtCNPJCPF
## 1 CAPAX DEI EDITORA LTDA 02778649000163
## 2 POSTO NOSSA SENHORA APARECIDA LTDA. 23649825000137
## 3 EMPRESA FOLHA DA MANHÃ S/A. 60579703003163
## txtDescricao txtDescricaoEspecificacao txtNumero
## 1 ASSINATURA DE PUBLICAÇÕES - 00000257
## 2 ASSINATURA DE PUBLICAÇÕES - 1093
## 3 ASSINATURA DE PUBLICAÇÕES - 1210479
## txtPassageiro txtTrecho vlrDocumento vlrGlosa vlrLiquido
## 1 - - 3700.00 0 3700.00
## 2 - - 3504.55 0 3504.55
## 3 - - 1450.90 0 1450.90Com o objetivo de encontrar uma componente que melhor explique os gastos de partidos em 7 categorias e agrupar partidos e empresas beneficiárias com gastos e recebimentos semelhantes, escolheremos os seguintes dados: nomes dos partidos (sgPartido), empresas beneficiárias (txtBeneficiario), valor líquido do gasto (vlrLiquido), identificador único do parlamentar (ideCadastro) e descrião do gasto (txtDescricao). Os demais dados foram filtrados para uma manipulação mais rápida do dataframe.
Neste exercício de redução de dimensionalidade e agrupamento utilizaremos os gastos dos 5 principais partidos brasileiros:
- PMDB
- PT
- PSDB
- PP
- PDT
E as 7 despesas mais recorrentes na câmara:
- Divulgação da Atividade Parlamentar
- Manutenção de Escritório e Apoio à Atividade Parlamentar
- Locação ou Fretamento de Veículos Automotores
- Combustíveis e Lubrificantes
- Emissão de Bilhete Aéreo
- Telefonia
- Consultorias Pesquisas e Trabalhos Técnicos
Para tanto, filtraremos e organizaremos os dados desejados:
# Filtragem dos partidos
cf <- cam %>%
select(sgPartido, txtBeneficiario, sgUF, vlrLiquido, txtDescricao, ideCadastro) %>%
filter(sgPartido == "PT" | sgPartido == "PSDB" | sgPartido == "PMDB" | sgPartido == "PP" | sgPartido == "PDT")
# Filtragem das categorias de gasto
cf <- cf %>%
filter(txtDescricao == "DIVULGACAO DA ATIVIDADE PARLAMENTAR." | txtDescricao == "MANUTENÇÃO DE ESCRITÓRIO DE APOIO À ATIVIDADE PARLAMENTAR" | txtDescricao == "LOCAÇÃO OU FRETAMENTO DE AERONAVES" | txtDescricao == "COMBUSTÍVEIS E LUBRIFICANTES." | txtDescricao == "Emissão Bilhete Aéreo" | txtDescricao == "TELEFONIA" | txtDescricao == "CONSULTORIAS PESQUISAS E TRABALHOS TÉCNICOS.")
#write.csv(cf, file = "filteredData.csv", col.names = TRUE, row.names = FALSE)
#cf <- read.csv("filteredData.csv", header = TRUE, fileEncoding = "UTF-8")
cfw <- dcast(cf, sgPartido + ideCadastro ~ txtDescricao, value.var="vlrLiquido", fun.aggregate=sum)Redução de Dimensionalidade
Nosso exercício de redução de dimensionalidade será encontrar outras componentes que melhor representem os gastos dos partidos nas categorias detalhadas abaixo.
# Renomeando as colunas para facilitar a manipulação
names(cfw)[1] <- "Partido"
names(cfw)[2] <- "Cadastro"
names(cfw)[3] <- "ComustiveisLubrificantes"
names(cfw)[4] <- "ConsultoriaPesquisa"
names(cfw)[5] <- "DivulgaAtividade"
names(cfw)[6] <- "EmissaoBilhete"
names(cfw)[7] <- "LocaFretamento"
names(cfw)[8] <- "ManutencaoEscritorio"
names(cfw)[9] <- "Telefonia"
head(cfw, n=5)## Partido Cadastro ComustiveisLubrificantes ConsultoriaPesquisa
## 1 PDT 133439 1066.40 19220
## 2 PDT 141400 0.00 0
## 3 PDT 141411 2672.08 0
## 4 PDT 141474 3950.03 0
## 5 PDT 141548 0.00 0
## DivulgaAtividade EmissaoBilhete LocaFretamento ManutencaoEscritorio
## 1 15000 1634.47 0 10149.88
## 2 0 0.00 0 0.00
## 3 2000 7147.14 0 6466.96
## 4 0 0.00 0 1087.80
## 5 0 0.00 0 0.00
## Telefonia
## 1 3806.14
## 2 178.07
## 3 2299.34
## 4 548.59
## 5 80.70Organizados os dados, vamos utilizar PCA para as 7 variáveis contínuas e usar a variável categórica para a visualização das componentes.
recorte <- cfw[, 3:9]
partido <- cfw[,1]
#ggpairs(recorte) #+ ggtitle("Correlação e distribuição das variáveis")
recorte$Partido <- cfw$PartidoPara que a magnitude e enviesamento das variáveis não atrapalhem o resultado do PCA, normalizar os valores e centrá-los em torno de zero é fundamental. Abaixo temos os componentes principais:
A fim de evitar uma ou duas variáveis tendo um indevida influência nos componentes principais, é usual codificar as variáveis X1, X2, . . . , Xp para terem médias zero e variâncias um no início de uma análise.
c.p <- prcomp(recorte[,1:7],
center = TRUE, # Deixa os dados em torno de zero, ou seja, faz o ponto médio ser 0
scale. = TRUE) # Normalização dos dadosOs coeficientes dos componentes principais (autovetores) ficam armazenados na tabela rotation.
kable(c.p$rotation)| PC1 | PC2 | PC3 | PC4 | PC5 | PC6 | PC7 | |
|---|---|---|---|---|---|---|---|
| ComustiveisLubrificantes | 0.5310801 | 0.0625950 | -0.1362816 | 0.1188330 | 0.0147529 | -0.7204951 | -0.4025059 |
| ConsultoriaPesquisa | 0.0714912 | -0.6411666 | -0.4514248 | 0.5347653 | -0.2189348 | 0.2038224 | -0.0675283 |
| DivulgaAtividade | 0.1352348 | 0.4818586 | -0.7931305 | -0.1092982 | 0.2119398 | 0.2454079 | 0.0581230 |
| EmissaoBilhete | 0.4016310 | 0.2293941 | 0.1201631 | -0.1501975 | -0.7670477 | 0.3558735 | -0.1845652 |
| LocaFretamento | 0.2143776 | 0.4239880 | 0.3104039 | 0.7649150 | 0.1958593 | 0.1929972 | 0.1312327 |
| ManutencaoEscritorio | 0.4417586 | -0.2760392 | 0.1931942 | -0.2326788 | 0.5289129 | 0.4545256 | -0.3883887 |
| Telefonia | 0.5404985 | -0.2102723 | 0.0217541 | -0.1617558 | 0.0214353 | -0.0929018 | 0.7924131 |
O sumário abaixo descreve a importância de cada componente gerada / utilizada. Na primeira linha vemos o desvio padrão atrelado a cada um dos PCs. Na segunda linha vemos que o primeiro componente principal (PC1) responde por cerca de 28% da variância total dos dados, o segundo responde por 15%, e assim sucessivamente. Na terceira linha temos a proporção cumulativa da variância, por exemplo: PC1, PC2 e PC3 respondem por 58% da variância total dos dados.
summary(c.p)## Importance of components:
## PC1 PC2 PC3 PC4 PC5 PC6 PC7
## Standard deviation 1.4144 1.0477 0.9942 0.9712 0.9121 0.77630 0.73185
## Proportion of Variance 0.2858 0.1568 0.1412 0.1348 0.1188 0.08609 0.07652
## Cumulative Proportion 0.2858 0.4426 0.5838 0.7186 0.8374 0.92348 1.00000O gráfico de escarpa também pode nos ajudar a decidir quantas das PCs explicam a maior parte da variância dos dados.
plot_pve(c.p)
Podemos perceber, segundo o gráfico, que as 3 primeiras PCs juntas explicam quase 60% da variação dos dados.
# Neste gráfico conseguimos uma maior customização da visualização e visualização dos gastos por partido
autoplot(c.p,
data = recorte, colour = 'Partido',
loadings = TRUE,
loadings.colour = 'blue',
loadings.label = TRUE,
loadings.label.size = 4,
label = TRUE,
label.size = 2,
shape = FALSE)
# Neste gráfico conseguimos visualizar melhor os labels dos atributos
biplot(c.p, scale = 0)
Nos gráficos acima os deputados podem ser identificados pelos números, enquanto os autovetores representam as variáveis. Quanto mais próximos os deputados, mais semelhantes são com relação aos gastos nestas categorias; enquanto que o ângulo entre os autovetores determina o quão parecidos são. Por exemplo: gastos em Divulgação de Atividade Parlamentar são semelhantes aos gastos com Locação e Fretamento de Veículos Automotores.
Deputados mais à esquerda são aqueles com menores gastos, enquando deputados à direita possuem gastos maiores.
Na primeira componente, que minimiza a distância média entre os pontos, todas as variáveis têm pesos positivos. Com excessão de Consultoria e Pesquisa, Divulgação da Atividade Parlamentar e Locação e Fretamento de Veículos Automotores, que são os três atributos que mais destoam dos demais, as outras variáveis possuem ordens de grandeza mais parecidas.
De acordo com os gráficos, podemos sugerir gastos muito altos ou muito baixos nas 3 categorias citadas acima, e gastos mais ‘medianos’/comuns nas demais categorias.
Agrupamento
Para o agrupamento utilizaremos também dados dos gastos dos partidos / deputados nas duas maiores categorias faladas no tópico anterior (Divulgação da Atividade Parlamentar e Manutenção de Escritório e Apoio e Atividade Parlamentar) e pelos 5 principais partidos brasileiros (PMDB, PT, PSDB, PP, PDT).
O objetivo deste tópico é encontrar partidos que gastem sua verba de gabinete de forma semelhante.
Inicialmente, para obter um norte sobre em quantos grupos os dados podem ser divididos utilizaremos o agrupamento hierárquico. Essa técnica nos permite, de maneira visual, identificar claramente os grupos formados. Assim:
# Organizando os dados
camAg <- cam %>%
filter(txtDescricao == "DIVULGACAO DA ATIVIDADE PARLAMENTAR." | txtDescricao == "MANUTENÇÃO DE ESCRITÓRIO DE APOIO À ATIVIDADE PARLAMENTAR") %>% dplyr::select(sgPartido, ideCadastro, txtDescricao, vlrLiquido)
gastosPartido <- dcast(camAg, sgPartido ~ txtDescricao, value.var="vlrLiquido", fun.aggregate=sum)
names(gastosPartido)[1] <- "Partido"
names(gastosPartido)[2] <- "DivulgaAtividade"
names(gastosPartido)[3] <- "ManutencaoEscri"
ggplot(gastosPartido, aes(DivulgaAtividade/1e3, ManutencaoEscri/1e3, color = Partido)) + geom_point() + xlab("Divulgação da Atividade Parlamentar / 1000") + ylab("Manutenção de Escritório / 1000")
Realizando o agrupamento:
gastosDist <- dist(gastosPartido[,2:3])
clust <- hclust(gastosDist, method="complete")
#dcw_m <- dist(gastosf[,1:2], method = "manhattan")
plot(clust, hang=-1, labels=gastosPartido$Partido)
Por default, o agrupamento hierárquico utiliza a distância Euclidiana como parâmetro do método. Pelo plot conseguimos identificar entre 3 e 4 a quantidade de grupos de partidos que gastam de maneira semelhante, por mais que não sobressaia aos olhos nenhum partido específico com gastos particulares.
#rect.hclust(clust, k=4)
grupos=4
# Poda na árvore
clusterCut <- cutree(clust, grupos)
table(clusterCut, gastosPartido$Partido)##
## clusterCut - DEM PCdoB PDT PEN PHS PMDB PMN PP PPS PR PRB PROS PRP PRTB
## 1 1 0 0 0 1 1 0 1 0 1 0 0 0 1 1
## 2 0 1 1 1 0 0 0 0 0 0 0 1 1 0 0
## 3 0 0 0 0 0 0 1 0 1 0 1 0 0 0 0
## 4 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
##
## clusterCut PSB PSC PSD PSDB PSDC PSL PSOL PT PTB PTC PTdoB PTN PV SD
## 1 0 0 0 0 1 1 1 0 0 1 1 1 1 0
## 2 1 1 0 0 0 0 0 0 1 0 0 0 0 1
## 3 0 0 1 1 0 0 0 0 0 0 0 0 0 0
## 4 0 0 0 0 0 0 0 1 0 0 0 0 0 0ggplot(gastosPartido, aes(ManutencaoEscri/1e3, DivulgaAtividade/1e3, color = 'pink')) +
geom_point(alpha = 0.4, size = 3.5) + geom_point(col = clusterCut) + ggtitle("Grupos de gasto") + xlab("Divulgação da Atividade Parlamentar / 1000") + ylab("Manutenção de Escritório / 1000")
Podemos identificar na imagem, claramente, a presença de 4 grupos e sugerir algumas interpretações:
Grupo preto: Deputados com gastos mais contidos. Podemos sugerir que desperdiçam menos dinheiro da câmara, entretanto teríamos também que avaliar as demais categorias de gasto.
Grupo vermelho: Deputados com gastos medianos.
Grupo verde e azul: Deputados com gastos extremamente elevados. Interessante ressaltar que gastos altos nessas duas categorias, Divulgação da Atividade Parlamentar e Manutenção de Escritório, geralmente são vistos como uso indevido de dinheiro para fazer campanha partidária fora da época de eleições - o que pode ser um tópico a se olhar mais a fundo.
No mesmo set de dados utilizaremos a técnica K-Means de agrupamento com o objetivo de comparar ambos os resultados. Vejamos o melhor resultado para o agrupamento do K-Means com o mesmo número de grupos do algoritmo Hierárquico e 120 repetições:
set.seed(20) # geração aleatória
gastosCluster <- kmeans(gastosPartido[, 2:3], 4, nstart = 120)
gastosCluster## K-means clustering with 4 clusters of sizes 14, 4, 9, 2
##
## Cluster means:
## DivulgaAtividade ManutencaoEscri
## 1 32359.17 14231.18
## 2 435753.41 270411.10
## 3 246474.30 92910.90
## 4 761115.56 448025.90
##
## Clustering vector:
## [1] 1 3 3 3 1 1 4 1 2 1 2 3 3 1 1 3 3 2 2 1 1 1 4 3 1 1 1 1 3
##
## Within cluster sum of squares by cluster:
## [1] 16418962766 30223071954 42002318581 40841976902
## (between_SS / total_SS = 93.0 %)
##
## Available components:
##
## [1] "cluster" "centers" "totss" "withinss"
## [5] "tot.withinss" "betweenss" "size" "iter"
## [9] "ifault"autoplot(gastosCluster, data = gastosPartido, frame = TRUE)
gastosCluster$cluster <- as.factor(gastosCluster$cluster)
ggplot(gastosPartido, aes(ManutencaoEscri/1e3, DivulgaAtividade/1e3, color = gastosCluster$cluster)) + geom_point() + ggtitle("Grupos de gasto") + xlab("Divulgação da Atividade Parlamentar / 1000") + ylab("Manutenção de Escritório / 1000")
gastosCluster <- kmeans(gastosPartido[, 2:3], 4, nstart = 120)A diferença entre os dois algoritmos é a formação do grupo 4: no agrupamento anterior esse grupo possuia apenas 1 elemento, agora possui 2. Os demais grupos se mantiveram iguais.
Comparando a qualidade dos dos agrupamentos feitos, temos:
plot(silhouette(clusterCut, gastosDist),
main = "Silhouette - Hierarquico")
plot(silhouette(gastosCluster$cluster, gastosDist),
main = "Silhouette - K-Means")
As silhuetas medem o grau de confiança no agrupamento feito para uma variável em particular. Então para observações ‘bem-agrupadas’ temos um valor próximo a 1, já para observação ‘mal-agrupadas’ temos um valor próximo a -1.
Tanto para o agrupamento Hierárquico como para o K-Means os resultados para o grupo melhor agrupado foi semelhante, 0.8, entretanto para uma das observações o K-Means teve um desempenho pior.