Predição de deputados eleitos
Paulo Vinicius Soares
26 de fevereiro de 2018
Introdução
Essa semana iremos utilizar mais uma vez os dados sobre deputados e tentaremos prever se este deputado será eleito ou não com base nos atributos que temos na nossa base de dados.
library(readr)
library(knitr)
library(tidyverse)## Loading tidyverse: ggplot2
## Loading tidyverse: tibble
## Loading tidyverse: tidyr
## Loading tidyverse: purrr
## Loading tidyverse: dplyr## Conflicts with tidy packages ----------------------------------------------## filter(): dplyr, stats
## lag(): dplyr, statslibrary(caret)## Loading required package: lattice##
## Attaching package: 'caret'## The following object is masked from 'package:purrr':
##
## liftsource("../utils/importa_dados_deputados.R")Vamos importar os dados dos deputados. Vamos retirar, além disso, algumas variáveis que não possuem tanta influência no modelo (Visto previamente em análise). Vamos adicionar três novos campos para otimizar a geração dos modelos: is_deputado, is_homem e is_superior_completo. Essas variáveis são derivadas de descricao_ocupacao, sexo e grau, respectivamente. Como estas variáveis possuem muitos fatores, o mais sensato é derivar os fatores que tem maior influência para reduzir o tempo de produção do modelo.
deputados <- get_kaggle_data() %>%
mutate(is_deputado = ifelse(descricao_ocupacao=="DEPUTADO",TRUE,FALSE),
is_homem = ifelse(sexo=="MASCULINO",TRUE,FALSE),
is_superior_completo=ifelse(grau=="SUPERIOR COMPLETO",TRUE,FALSE)) %>%
select(-nome, -numero_cadidato, -setor_economico_despesa, -setor_economico_receita,
-partido,-UF,-total_despesa,-idade,-estado_civil,-descricao_cor_raca,-descricao_ocupacao,-sexo,-grau)Perguntas
1.Há desbalanceamento das classes (isto é, uma classe tem muito mais instâncias que outra)? Em que proporção? Quais efeitos colaterais o desbalanceamento de classes pode causar no classificador?
Para responder essa pergunta utilizaremos um histograma que contará a frequência de deputados eleitos e não eleitos.
# Frequência de eleitos e não eleitos
deputados %>%
ggplot(aes(situacao_final)) + geom_histogram(stat="count")## Warning: Ignoring unknown parameters: binwidth, bins, pad
Podemos observar que há um claro desbalanceamento entre as classes, havendo muito mais deputados não eleitos do que deputados eleitos. Os riscos que essa situação acarreta, em primeira instância, é o perigo de enviesamento da previsão para uma das classes presentes nos dados. Como a proporção de deputados eleitos para não eleitos é de aproximadamente 500 para 3500, é muito provável que ele preveja “não eleito” para determinados casos. Isso pode ocorrer ao utilizar os algoritmos de Árvore de Decisão. As soluções para esse tipo de problema são o undersampling da classe majoritária ou o oversampling da classe minoritária. O undersampling consiste em retirar amostras da classe que possui maior frequência a fim de igualar as observações com a classe de menor frequência. O oversampling consiste em aumentar o número de observações da amostra de menor frequência através de reamostragem. Aqui a estratégia adotada será o oversampling para evitar a perda de informações.
2.Treine: um modelo de regressão logística, uma árvore de decisão e um modelo de adaboost. Tune esses modelos usando validação cruzada e controle overfitting se necessário, considerando as particularidades de cada modelo.
Vamos utilizar o pacote do Caret para dividir os dados em treino e teste.
# Dividir os dados em treino e teste
set.seed(123)
dataPartition <- createDataPartition(y = deputados$situacao_final, p=0.75, list=FALSE)
treino <- deputados[dataPartition,]
teste <- deputados[-dataPartition,]Vamos adotar a estratégia de oversampling no próprio Caret utilizando o parâmetro sampling = up.
# Validação cruzada
# fitControlUndersampling <- trainControl(method = "repeatedcv", number = 5, repeats = 5, sampling="down")
fitControlOversampling <- trainControl(method = "repeatedcv", number = 5, repeats = 5, sampling="up")
preProcessing <- c("scale", "center", "nzv")
formula_modelo <- as.formula(situacao_final ~ . - ID)Regressão logística
Utilizando o modelo de Regressão Logística, temos:
# modelo_regressao <- train(formula_modelo, data = treino, method="glm", family="binomial",
# na.action = na.omit, trControl = fitControlOversampling, preProcess = preProcessing)
# saveRDS(modelo_regressao, file = "modelo_regressao.rds")
modelo_regressao <- readRDS("modelo_regressao.rds")Árvore de decisão
Utilizando o modelo de Árvore De Regressão, temos:
# modelo_arvore <- train(formula_modelo, data=treino, method="rpart", na.action = na.omit,
# trControl = fitControlOversampling, preProcess = preProcessing, cp=0.001, maxdepth=20)
#
# saveRDS(modelo_arvore, file = "modelo_arvore.rds")
modelo_arvore <- readRDS("modelo_arvore.rds")Adaboost
Utilizando o modelo Adaboost, temos:
# modelo_adaboost <- train(formula_modelo, data=treino, method="adaboost", na.action = na.omit,
# preProcess = preProcessing)
# saveRDS(modelo_adaboost, file = "modelo_adaboost.rds")
modelo_adaboost <- readRDS("modelo_adaboost.rds")3.Reporte acurácia, precision, recall e f-measure no treino e validação. Como você avalia os resultados? Justifique sua resposta.
Esses parâmetros são calculados em termos de Verdadeiros Positivos (TP), Verdadeiros Negativos (TN), Falsos Positivos (FP) e Falsos Negativos (FN).
A acurácia geralmente é dada no cálculo da matriz de confusão. Os demais parâmetros são calculados da seguinte forma:
precision <- function(tp,fp){
tp/(tp+fp)
}
recall <- function(tp,fn){
tp/(tp+fn)
}
f_measure <- function(precision, recall) {
2*((precision*recall)/(precision+recall))
}Analisando cada modelo, temos:
Regressão logística
Para os dados de treino, o modelo retorna os seguintes parâmetros:
summary(modelo_regressao)##
## Call:
## NULL
##
## Deviance Residuals:
## Min 1Q Median 3Q Max
## -2.3862 -0.2006 0.0101 0.3744 5.0535
##
## Coefficients:
## Estimate Std. Error z value
## (Intercept) -1.26468 0.09285 -13.621
## quantidade_doacoes -0.08615 0.25713 -0.335
## quantidade_doadores -0.76684 0.20114 -3.813
## total_receita 33.54765 18.38699 1.825
## media_receita -0.39938 0.13963 -2.860
## recursos_de_outros_candidatos.comites -6.96031 3.06717 -2.269
## recursos_de_partidos -19.98242 10.43006 -1.916
## recursos_de_pessoas_físicas -5.66619 2.53669 -2.234
## recursos_de_pessoas_juridicas -16.39327 8.06723 -2.032
## recursos_proprios -8.11479 4.19126 -1.936
## quantidade_despesas -2.35314 0.50870 -4.626
## quantidade_fornecedores 2.59677 0.38439 6.756
## media_despesa -0.60851 0.09940 -6.122
## despesa_max_campanha 0.26942 0.05578 4.830
## is_deputadoTRUE -0.92964 0.07004 -13.272
## is_homemTRUE -0.27348 0.05772 -4.738
## is_superior_completoTRUE -0.42972 0.05314 -8.086
## Pr(>|z|)
## (Intercept) < 2e-16 ***
## quantidade_doacoes 0.737606
## quantidade_doadores 0.000138 ***
## total_receita 0.068072 .
## media_receita 0.004233 **
## recursos_de_outros_candidatos.comites 0.023250 *
## recursos_de_partidos 0.055384 .
## recursos_de_pessoas_físicas 0.025503 *
## recursos_de_pessoas_juridicas 0.042145 *
## recursos_proprios 0.052853 .
## quantidade_despesas 3.73e-06 ***
## quantidade_fornecedores 1.42e-11 ***
## media_despesa 9.25e-10 ***
## despesa_max_campanha 1.37e-06 ***
## is_deputadoTRUE < 2e-16 ***
## is_homemTRUE 2.16e-06 ***
## is_superior_completoTRUE 6.15e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 7735.5 on 5579 degrees of freedom
## Residual deviance: 2770.3 on 5563 degrees of freedom
## AIC: 2804.3
##
## Number of Fisher Scoring iterations: 8De acordo com o modelo de regressão linear, os parâmetros que têm maior influência no modelo são is deputado, is superior completo e quantidade de doadores, media despesa e quantidade fornecedores, além disso, as demais variáveis também possuem leve influência no modelo. A análise foi feita considerando o p valor. Quanto mais baixo, maior a influência deste na variável resposta.
Na validação utilizando os dados de teste, temos:
predictions_regressao <- predict(modelo_regressao, teste)
matriz_regressao <- confusionMatrix(predictions_regressao, teste$situacao_final)
matriz_regressao## Confusion Matrix and Statistics
##
## Reference
## Prediction eleito nao_eleito
## eleito 94 67
## nao_eleito 10 862
##
## Accuracy : 0.9255
## 95% CI : (0.9077, 0.9407)
## No Information Rate : 0.8993
## P-Value [Acc > NIR] : 0.00224
##
## Kappa : 0.6689
## Mcnemar's Test P-Value : 1.75e-10
##
## Sensitivity : 0.9038
## Specificity : 0.9279
## Pos Pred Value : 0.5839
## Neg Pred Value : 0.9885
## Prevalence : 0.1007
## Detection Rate : 0.0910
## Detection Prevalence : 0.1559
## Balanced Accuracy : 0.9159
##
## 'Positive' Class : eleito
## A acurácia nos é dada pelo próprio modelo, que é de 92%, com intervalo de confiança de 95%. A precisão e o Recall são dados abaixo:
prec_reg <- precision(tp = matriz_regressao$table[1], fp = matriz_regressao$table[3])
prec_reg## [1] 0.5838509rec_reg <- recall(matriz_regressao$table[1], fn = matriz_regressao$table[2])
rec_reg## [1] 0.9038462f_measure(precision = prec_reg, recall = rec_reg)## [1] 0.709434Árvores de Decisão
Para os dados de treino, o modelo retorna os seguintes parâmetros:
modelo_arvore## CART
##
## 3102 samples
## 17 predictors
## 2 classes: 'eleito', 'nao_eleito'
##
## Pre-processing: scaled (16), centered (16)
## Resampling: Cross-Validated (5 fold, repeated 5 times)
## Summary of sample sizes: 2481, 2481, 2482, 2482, 2482, 2482, ...
## Addtional sampling using up-sampling prior to pre-processing
##
## Resampling results across tuning parameters:
##
## cp Accuracy Kappa
## 0.02083333 0.8973544 0.5972906
## 0.06250000 0.8973544 0.5972906
## 0.32692308 0.8973544 0.5972906
##
## Accuracy was used to select the optimal model using the largest value.
## The final value used for the model was cp = 0.3269231.A acurácia para os dados de treino foi de aproximadamente 90%, de forma semelhante para os testes.
Na validação utilizando os dados de teste, temos:
predictions_arvore <- predict(modelo_arvore, teste)
matriz_arvore <- confusionMatrix(predictions_arvore, teste$situacao_final)
matriz_arvore## Confusion Matrix and Statistics
##
## Reference
## Prediction eleito nao_eleito
## eleito 97 92
## nao_eleito 7 837
##
## Accuracy : 0.9042
## 95% CI : (0.8846, 0.9214)
## No Information Rate : 0.8993
## P-Value [Acc > NIR] : 0.3248
##
## Kappa : 0.6117
## Mcnemar's Test P-Value : <2e-16
##
## Sensitivity : 0.9327
## Specificity : 0.9010
## Pos Pred Value : 0.5132
## Neg Pred Value : 0.9917
## Prevalence : 0.1007
## Detection Rate : 0.0939
## Detection Prevalence : 0.1830
## Balanced Accuracy : 0.9168
##
## 'Positive' Class : eleito
## prec_arv <- precision(tp = matriz_arvore$table[1], fp = matriz_arvore$table[3])
prec_arv## [1] 0.5132275rec_arv <- recall(tp = matriz_arvore$table[1], fn = matriz_arvore$table[2])
rec_arv## [1] 0.9326923f_measure(precision = prec_arv, recall = rec_arv)## [1] 0.662116Adaboost
Para os dados de treino, o modelo retorna os seguintes parâmetros:
modelo_adaboost## AdaBoost Classification Trees
##
## 3102 samples
## 17 predictors
## 2 classes: 'eleito', 'nao_eleito'
##
## Pre-processing: scaled (16), centered (16)
## Resampling: Bootstrapped (25 reps)
## Summary of sample sizes: 3102, 3102, 3102, 3102, 3102, 3102, ...
## Resampling results across tuning parameters:
##
## nIter method Accuracy Kappa
## 50 Adaboost.M1 0.9404770 0.6515709
## 50 Real adaboost 0.9401343 0.6429888
## 100 Adaboost.M1 0.9398010 0.6464661
## 100 Real adaboost 0.9424094 0.6579842
## 150 Adaboost.M1 0.9402244 0.6492197
## 150 Real adaboost 0.9424528 0.6596178
##
## Accuracy was used to select the optimal model using the largest value.
## The final values used for the model were nIter = 150 and method =
## Real adaboost.Na validação utilizando os dados de teste, temos:
predictions_adaboost <- predict(modelo_adaboost, teste)
matriz_adaboost <- confusionMatrix(predictions_adaboost, teste$situacao_final)
matriz_adaboost## Confusion Matrix and Statistics
##
## Reference
## Prediction eleito nao_eleito
## eleito 70 29
## nao_eleito 34 900
##
## Accuracy : 0.939
## 95% CI : (0.9226, 0.9528)
## No Information Rate : 0.8993
## P-Value [Acc > NIR] : 3.976e-06
##
## Kappa : 0.6559
## Mcnemar's Test P-Value : 0.6143
##
## Sensitivity : 0.67308
## Specificity : 0.96878
## Pos Pred Value : 0.70707
## Neg Pred Value : 0.96360
## Prevalence : 0.10068
## Detection Rate : 0.06776
## Detection Prevalence : 0.09584
## Balanced Accuracy : 0.82093
##
## 'Positive' Class : eleito
## prec_ada <- precision(tp = matriz_adaboost$table[1], fp = matriz_adaboost$table[3])
prec_ada## [1] 0.7070707rec_ada <- recall(tp = matriz_adaboost$table[1], fn = matriz_adaboost$table[2])
rec_ada## [1] 0.6730769f_measure(precision = prec_ada, recall = rec_ada)## [1] 0.68965524.Interprete as saídas dos modelos. Quais atributos parecem ser mais importantes de acordo com cada modelo? Crie pelo menos um novo atributo que não está nos dados originais e estude o impacto desse atributo.
Em todos os modelos vistos, os atributos mais importantes parecem ser se o candidato já era deputado, o grau superior completo, a quantidade de doadores, a média da despesa nas eleições e a quantidade de fornecedores. Foram criados 3 novos atributos para agilizar o modelo e eliminar os fatores que não influenciavam na variável resposta. O tempo de produção do modelo reduziu drasticamente, além de elevar a acurácia deste.
5. Envie os melhores modelos para o Kaggle:
# dados_teste <- get_kaggle_data_test() %>%
# mutate(is_deputado = ifelse(descricao_ocupacao=="DEPUTADO",TRUE,FALSE),
# is_homem = ifelse(sexo=="MASCULINO",TRUE,FALSE),
# is_superior_completo=ifelse(grau=="SUPERIOR COMPLETO",TRUE,FALSE)) %>%
# select(-nome, -numero_cadidato, -setor_economico_despesa, -setor_economico_receita,
# -partido,-UF,-total_despesa,-idade,-estado_civil,-descricao_cor_raca,-descricao_ocupacao,-sexo,-grau)
#
#
# predictions_regressao_teste_kaggle <- predict(modelo_regressao, dados_teste)
#
# dados_teste$situacao_final <- predictions_regressao_teste_kaggle
#
# dados_teste %>%
# select(ID, prediction = situacao_final) %>%
# write.csv("respostas.csv", row.names = FALSE)
#
# pred_adaboost <- predict(modelo_adaboost, dados_teste)
# dados_teste$situacao_final <- pred_adaboost
# model_rf <- train(formula_modelo, data = treino, method="rf", na.action = na.omit,
# trControl = fitControlOversampling, preProcess = preProcessing, prox = TRUE, allowParallel=TRUE)