Neste laboratório construiremos classificadores para predizer se um candidato à Câmara Federal dos Deputados será eleito ou não. Ou seja, a nossa tarefa é construir um classificador que diga se um candidato será eleito ou não de acordo com uma série de atributos do candidato.
Os dados foram coletados do TSE, sendo tratados e contemplam informações sobre aproximadamente 4.100 candidatos, os dados podem ser baixados neste link.
observations <- read.csv("~/Documentos/AD2/Lab5/train.csv")
testSamples <- read.csv("~/Documentos/AD2/Lab5/test.csv")Para esse modelo vamos eliminar variável que explicitamente não parecem ser importantes preditoras como setor_economico_receita e setor_economico_despesa.
formula <- as.formula(situacao_final ~ UF + partido + quantidade_doacoes + quantidade_doadores + total_receita + media_receita + recursos_de_outros_candidatos.comites + recursos_de_partidos + recursos_de_pessoas_físicas + recursos_de_pessoas_juridicas + recursos_proprios + quantidade_despesas + quantidade_fornecedores + idade + sexo + grau + estado_civil + descricao_ocupacao + descricao_cor_raca + despesa_max_campanha)for (x in unique(observations$situacao_final)) {
soma = sum(observations$situacao_final == x)
print(paste(x, soma))
}## [1] "nao_eleito 3719"
## [1] "eleito 416"Sim, há um desbalanceamento das classes, existem 3719 instâncias de nao_eleito e apenas 416 de eleito, ou seja, uma proporção de aproximadamente 88.81% de nao_eleito e 11.19% eleito.
Como existe uma classe majoritária com 88.81% dos dados isso pode enviesar o classificador! Se no treinamento o modelo responder que todos os candidatos não serão eleitos, então, ele terá 88.81% de acurácia, porém, não será um modelo representativo! Esse problema é chamado de Accuracy Paradox.
Existem diversas formas de tentar contornar o Accuracy Paradox, as que iremos tentar nesse lab será:
set.seed(1234)
underData <- downSample(x = observations[, -ncol(observations)],
y = observations$situacao_final)
colnames(underData)[ncol(underData)] <- "situacao_final"
table(underData$situacao_final)##
## eleito nao_eleito
## 416 416overData <- upSample(x = observations[, -ncol(observations)],
y = observations$situacao_final)
colnames(overData)[ncol(overData)] <- "situacao_final"
table(overData$situacao_final)##
## eleito nao_eleito
## 3719 3719set.seed(10234)
smoteData <- SMOTE(situacao_final ~ ., data = observations)
table(smoteData$situacao_final)##
## eleito nao_eleito
## 1248 1664roseData <- ROSE(situacao_final ~ ., data = observations)$data
table(roseData$situacao_final)##
## nao_eleito eleito
## 2061 2074É possível observar que as técnicas de reamostragem utilizadas deixaram os dados mais balanceados. Posteriormente serão realizadas comparações de desempenhos dos modelos com os dados balanceados e desbalanceados.
Vamos construir modelos de Regressão Logística com os dados balanceados e desbalanceados.
Primeiro vamos construir um classificador treinado com os dados desbalanceados.
control <- trainControl(method = 'cv', number = 5)
logisticUmbalanced <- train(formula,
data = observations,
method = "glm",
family = "binomial",
trControl = control)## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurredlogisticUmbalanced## Generalized Linear Model
##
## 4135 samples
## 20 predictors
## 2 classes: 'eleito', 'nao_eleito'
##
## No pre-processing
## Resampling: Cross-Validated (5 fold)
## Summary of sample sizes: 3308, 3307, 3309, 3308, 3308
## Resampling results:
##
## Accuracy Kappa
## 0.9378485 0.6235603importance <- varImp(logisticUmbalanced, scale=FALSE)
print(importance)## glm variable importance
##
## only 20 most important variables shown (out of 240)
##
## Overall
## descricao_ocupacaoDEPUTADO 4.448
## descricao_ocupacaoAGRICULTOR 2.742
## descricao_ocupacaoINDUSTRIAL 2.724
## despesa_max_campanha 2.600
## sexoMASCULINO 2.552
## quantidade_doacoes 2.291
## `descricao_ocupacaoCORRETOR DE IMÓVEIS, SEGUROS, TÍTULOS E VALORES` 2.080
## `descricao_ocupacaoPOLICIAL CIVIL` 1.984
## idade 1.974
## `descricao_ocupacaoLOCUTOR E COMENTARISTA DE RÁDIO E TELEVISÃO E RADIALISTA` 1.955
## UFGO 1.924
## UFSE 1.884
## UFAP 1.856
## UFRR 1.788
## `estado_civilVIÚVO(A)` 1.785
## UFAM 1.778
## media_receita 1.748
## partidoPRB 1.711
## `descricao_ocupacaoVENDEDOR DE COMÉRCIO VAREJISTA E ATACADISTA` 1.710
## `grauSUPERIOR COMPLETO` 1.685#plot(importance)
output <- subset(testSamples, select=c(ID))
output$prediction <- predict(logisticUmbalanced, testSamples)
write.csv(output, file = "output-logistic-umbalanced-acc.csv", row.names = FALSE)O desempenho do modelo com os dados desbalanceados foi 95.45%, isso mostra que os dados de teste no kaggle também estão desbalanceados, então vamos construir os próximos modelos tão genéricos quanto o possível evitando o enviesamento dos modelos.
Vamos construir um modelo de regressão logística com Under-Sampling.
control <- trainControl(method = 'cv', number = 5)
logisticDown <- train(formula,
data = underData,
method = "glm",
family = "binomial",
trControl = control)## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurredlogisticDown## Generalized Linear Model
##
## 832 samples
## 20 predictors
## 2 classes: 'eleito', 'nao_eleito'
##
## No pre-processing
## Resampling: Cross-Validated (5 fold)
## Summary of sample sizes: 665, 665, 666, 666, 666
## Resampling results:
##
## Accuracy Kappa
## 0.8558401 0.7116643importance <- varImp(logisticDown, scale=FALSE)
print(importance)## glm variable importance
##
## only 20 most important variables shown (out of 166)
##
## Overall
## quantidade_doacoes 4.670
## recursos_de_outros_candidatos.comites 3.972
## recursos_proprios 3.872
## total_receita 3.869
## recursos_de_pessoas_juridicas 3.858
## recursos_de_partidos 3.857
## recursos_de_pessoas_físicas 3.851
## media_receita 3.327
## UFMT 2.819
## descricao_ocupacaoDEPUTADO 2.640
## UFPI 2.278
## `descricao_ocupacaoCORRETOR DE IMÓVEIS, SEGUROS, TÍTULOS E VALORES` 2.119
## descricao_ocupacaoAGRICULTOR 2.076
## `descricao_ocupacaoPOLICIAL CIVIL` 2.028
## `grauSUPERIOR INCOMPLETO` 1.932
## partidoPTN 1.645
## `grauSUPERIOR COMPLETO` 1.598
## descricao_ocupacaoECONOMISTA 1.570
## `descricao_ocupacaoJORNALISTA E REDATOR` 1.548
## `descricao_ocupacaoSACERDOTE OU MEMBRO DE ORDEM OU SEITA RELIGIOSA` 1.523#plot(importance)
output <- subset(testSamples, select=c(ID))
output$prediction <- predict(logisticDown, testSamples)## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleadingwrite.csv(output, file = "output-logistic-down-acc.csv", row.names = FALSE)O desempenho do modelo com Under-sampling foi de 88.93%.
Vamos construir um modelo de regressão logística com Over-Sampling.
control <- trainControl(method = 'cv', number = 5)
logisticUp <- train(formula,
data = overData,
method = "glm",
family = "binomial",
trControl = control)## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurredlogisticUp## Generalized Linear Model
##
## 7438 samples
## 20 predictors
## 2 classes: 'eleito', 'nao_eleito'
##
## No pre-processing
## Resampling: Cross-Validated (5 fold)
## Summary of sample sizes: 5952, 5950, 5950, 5950, 5950
## Resampling results:
##
## Accuracy Kappa
## 0.941787 0.8835739importance <- varImp(logisticUp, scale=FALSE)
print(importance)## glm variable importance
##
## only 20 most important variables shown (out of 240)
##
## Overall
## descricao_ocupacaoDEPUTADO 7.681
## descricao_ocupacaoAGRICULTOR 4.990
## UFAM 4.971
## UFPI 4.437
## sexoMASCULINO 4.345
## partidoPTN 4.277
## UFAP 4.237
## partidoPR 4.237
## UFMS 4.155
## `grauSUPERIOR COMPLETO` 4.115
## UFRR 4.017
## `estado_civilVIÚVO(A)` 3.932
## `grauSUPERIOR INCOMPLETO` 3.928
## descricao_ocupacaoINDUSTRIAL 3.814
## quantidade_doacoes 3.781
## UFMA 3.708
## partidoPSD 3.640
## partidoPRB 3.531
## `descricao_ocupacaoCORRETOR DE IMÓVEIS, SEGUROS, TÍTULOS E VALORES` 3.263
## despesa_max_campanha 3.217#plot(importance)
output <- subset(testSamples, select=c(ID))
output$prediction <- predict(logisticUp, testSamples)
write.csv(output, file = "output-logistic-up-acc.csv", row.names = FALSE)O desempenho do modelo com Over-sampling foi de 91.69%.
Vamos construir um modelo de regressão logística com SMOTE.
control <- trainControl(method = 'cv', number = 5)
logisticSmote <- train(formula,
data = smoteData,
method = "glm",
family = "binomial",
trControl = control)## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurredlogisticSmote## Generalized Linear Model
##
## 2912 samples
## 20 predictors
## 2 classes: 'eleito', 'nao_eleito'
##
## No pre-processing
## Resampling: Cross-Validated (5 fold)
## Summary of sample sizes: 2330, 2329, 2329, 2331, 2329
## Resampling results:
##
## Accuracy Kappa
## 0.9096773 0.8153227importance <- varImp(logisticSmote, scale=FALSE)
print(importance)## glm variable importance
##
## only 20 most important variables shown (out of 200)
##
## Overall
## quantidade_doacoes 5.465
## descricao_ocupacaoDEPUTADO 5.397
## media_receita 3.836
## partidoPTN 3.725
## `descricao_ocupacaoJORNALISTA E REDATOR` 3.380
## `descricao_ocupacaoLOCUTOR E COMENTARISTA DE RÁDIO E TELEVISÃO E RADIALISTA` 3.016
## descricao_ocupacaoAGRICULTOR 2.855
## idade 2.855
## UFGO 2.660
## partidoPSC 2.507
## partidoPR 2.422
## UFAP 2.307
## descricao_ocupacaoVEREADOR 2.263
## partidoPHS 2.257
## quantidade_fornecedores 2.243
## `descricao_ocupacaoPROFESSOR DE ENSINO MÉDIO` 2.189
## `grauSUPERIOR COMPLETO` 2.048
## `grauSUPERIOR INCOMPLETO` 1.990
## UFRR 1.943
## partidoPTB 1.940#plot(importance)
output <- subset(testSamples, select=c(ID))
output$prediction <- predict(logisticSmote, testSamples)## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleadingwrite.csv(output, file = "output-logistic-smote-acc.csv", row.names = FALSE)O desempenho do modelo com SMOTE foi de 89.72%.
Vamos construir um modelo de regressão logística com ROSE.
control <- trainControl(method = 'cv', number = 5)
logisticRose <- train(formula,
data = roseData,
method = "glm",
family = "binomial",
trControl = control)## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurredlogisticRose## Generalized Linear Model
##
## 4135 samples
## 20 predictors
## 2 classes: 'nao_eleito', 'eleito'
##
## No pre-processing
## Resampling: Cross-Validated (5 fold)
## Summary of sample sizes: 3308, 3308, 3308, 3307, 3309
## Resampling results:
##
## Accuracy Kappa
## 0.90689 0.8137829importance <- varImp(logisticRose, scale=FALSE)
print(importance)## glm variable importance
##
## only 20 most important variables shown (out of 213)
##
## Overall
## descricao_ocupacaoDEPUTADO 8.179
## total_receita 8.037
## quantidade_doacoes 6.443
## recursos_de_pessoas_físicas 5.476
## quantidade_doadores 5.423
## recursos_de_outros_candidatos.comites 5.352
## sexoMASCULINO 5.280
## media_receita 5.178
## quantidade_despesas 4.293
## UFAP 3.865
## descricao_ocupacaoENFERMEIRO 3.757
## partidoPSL 3.729
## descricao_ocupacaoAGRICULTOR 3.720
## `partidoPC do B` 3.647
## recursos_de_pessoas_juridicas 3.625
## UFPE 3.418
## descricao_ocupacaoINDUSTRIAL 3.410
## UFMA 3.352
## `grauSUPERIOR COMPLETO` 3.275
## `grauSUPERIOR INCOMPLETO` 3.047#plot(importance)
output <- subset(testSamples, select=c(ID))
output$prediction <- predict(logisticRose, testSamples)## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleadingwrite.csv(output, file = "output-logistic-rose-acc.csv", row.names = FALSE)O desempenho do modelo com ROSE foi de 88.33%.
Conhecidos os resultados de desempenho dos modelos de regressão logística apresentados, vamos escolher o que se saiu melhor no score do kaggle com os dados balanceados para realizar o tuning e entender melhor o modelo. Logo, a regressão logística com Over-Sampling vai ser eleita.
Modelo com Under-Sampling e métrica de avaliação Accuracy.
trainC <- trainControl(method = 'cv', number = 5)
treeDownACC <- caret::train(formula,
data = underData,
method = "rpart",
trControl = trainC,
metric = 'Accuracy')
treeDownACC## CART
##
## 832 samples
## 20 predictors
## 2 classes: 'eleito', 'nao_eleito'
##
## No pre-processing
## Resampling: Cross-Validated (5 fold)
## Summary of sample sizes: 666, 666, 664, 666, 666
## Resampling results across tuning parameters:
##
## cp Accuracy Kappa
## 0.006009615 0.9038296 0.8076592
## 0.008413462 0.9074441 0.8148881
## 0.831730769 0.7339788 0.4679575
##
## Accuracy was used to select the optimal model using the largest value.
## The final value used for the model was cp = 0.008413462.importance <- varImp(treeDownACC, scale=FALSE)
print(importance)## rpart variable importance
##
## only 20 most important variables shown (out of 240)
##
## Overall
## total_receita 288.9
## quantidade_despesas 253.9
## quantidade_fornecedores 228.1
## recursos_de_pessoas_juridicas 225.1
## media_receita 216.2
## sexoMASCULINO 0.0
## UFAP 0.0
## `descricao_ocupacaoPRODUTOR AGROPECUÁRIO` 0.0
## `descricao_ocupacaoBOMBEIRO CIVIL` 0.0
## partidoPDT 0.0
## `descricao_ocupacaoFOTÓGRAFO E ASSEMELHADOS` 0.0
## descricao_ocupacaoPSICÓLOGO 0.0
## `descricao_ocupacaoPOLICIAL MILITAR` 0.0
## `grauENSINO MÉDIO COMPLETO` 0.0
## `grauSUPERIOR INCOMPLETO` 0.0
## UFMT 0.0
## partidoPSL 0.0
## partidoPHS 0.0
## descricao_ocupacaoESTOFADOR 0.0
## `descricao_ocupacaoTORNEIRO MECÂNICO` 0.0#plot(importance)
output <- subset(testSamples, select=c(ID))
output$prediction <- predict(treeDownACC, testSamples)
write.csv(output, file = "output-tree-down-acc.csv", row.names = FALSE)Desempenho na competição - 88.93% de score
Modelo com Over-Sampling e métrica de avaliação Accuracy.
trainC <- trainControl(method = 'cv', number = 5)
treeUpACC <- caret::train(formula,
data = overData,
method = "rpart",
trControl = trainC,
metric = 'Accuracy')
treeUpACC## CART
##
## 7438 samples
## 20 predictors
## 2 classes: 'eleito', 'nao_eleito'
##
## No pre-processing
## Resampling: Cross-Validated (5 fold)
## Summary of sample sizes: 5950, 5950, 5950, 5951, 5951
## Resampling results across tuning parameters:
##
## cp Accuracy Kappa
## 0.003831675 0.9330477 0.8660969
## 0.004302232 0.9255187 0.8510387
## 0.842161871 0.8347336 0.6696030
##
## Accuracy was used to select the optimal model using the largest value.
## The final value used for the model was cp = 0.003831675.importance <- varImp(treeUpACC, scale=FALSE)
print(importance)## rpart variable importance
##
## only 20 most important variables shown (out of 240)
##
## Overall
## total_receita 2707.094
## quantidade_despesas 2336.064
## quantidade_fornecedores 2103.171
## media_receita 2029.231
## recursos_de_pessoas_juridicas 2002.300
## recursos_de_pessoas_físicas 51.782
## idade 39.192
## quantidade_doadores 38.269
## recursos_proprios 32.098
## despesa_max_campanha 19.068
## sexoMASCULINO 7.189
## descricao_ocupacaoCOMUNICÓLOGO 0.000
## `descricao_ocupacaoMOTORISTA DE VEÍCULOS DE TRANSPORTE COLETIVO DE PASSAGEIROS` 0.000
## descricao_ocupacaoTERAPEUTA 0.000
## `descricao_ocupacaoAGENTE DE VIAGEM` 0.000
## `descricao_ocupacaoPOLICIAL MILITAR` 0.000
## UFAL 0.000
## descricao_ocupacaoCONTADOR 0.000
## `descricao_ocupacaoTRABALHADOR DE FABRICAÇÃO DE ROUPAS` 0.000
## `descricao_ocupacaoTÉCNICO DE LABORATÓRIO E RAIOS X` 0.000#plot(importance)
output <- subset(testSamples, select=c(ID))
output$prediction <- predict(treeUpACC, testSamples)
write.csv(output, file = "output-tree-up-acc.csv", row.names = FALSE)Desempenho na competição - 87.15% de score
Modelo com SMOTE e métrica de avaliação Accuracy.
trainC <- trainControl(method = 'cv', number = 5)
treeSmoteACC <- caret::train(formula,
data = smoteData,
method = "rpart",
trControl = trainC,
metric = 'Accuracy')
treeSmoteACC## CART
##
## 2912 samples
## 20 predictors
## 2 classes: 'eleito', 'nao_eleito'
##
## No pre-processing
## Resampling: Cross-Validated (5 fold)
## Summary of sample sizes: 2330, 2330, 2329, 2329, 2330
## Resampling results across tuning parameters:
##
## cp Accuracy Kappa
## 0.003205128 0.9210176 0.8396486
## 0.004006410 0.9151798 0.8281372
## 0.814102564 0.7053326 0.3245773
##
## Accuracy was used to select the optimal model using the largest value.
## The final value used for the model was cp = 0.003205128.importance <- varImp(treeSmoteACC, scale=FALSE)
print(importance)## rpart variable importance
##
## only 20 most important variables shown (out of 240)
##
## Overall
## total_receita 1035.590
## quantidade_despesas 898.270
## recursos_de_pessoas_juridicas 880.268
## quantidade_doadores 818.640
## quantidade_fornecedores 817.557
## recursos_de_partidos 44.338
## UFSP 18.859
## idade 18.700
## recursos_de_pessoas_físicas 17.732
## quantidade_doacoes 14.684
## descricao_ocupacaoDEPUTADO 11.874
## despesa_max_campanha 8.295
## recursos_de_outros_candidatos.comites 7.674
## `descricao_ocupacaoDONA DE CASA` 0.000
## `descricao_ocupacaoAUXILIAR DE LABORATÓRIO` 0.000
## `descricao_ocupacaoMOTORISTA PARTICULAR` 0.000
## `estado_civilDIVORCIADO(A)` 0.000
## `descricao_ocupacaoOPERADOR DE COMPUTADOR` 0.000
## descricao_ocupacaoFARMACÊUTICO 0.000
## `descricao_ocupacaoTÉCNICO EM INFORMÁTICA` 0.000#plot(importance)
output <- subset(testSamples, select=c(ID))
output$prediction <- predict(treeSmoteACC, testSamples)
write.csv(output, file = "output-tree-smote-acc.csv", row.names = FALSE)Desempenho na competição - 89.72% de score
Modelo com ROSE e métrica de avaliação Accuracy.
trainC <- trainControl(method = 'cv', number = 5)
treeRoseACC <- caret::train(formula,
data = roseData,
method = "rpart",
trControl = trainC,
metric = 'Accuracy')
treeRoseACC## CART
##
## 4135 samples
## 20 predictors
## 2 classes: 'nao_eleito', 'eleito'
##
## No pre-processing
## Resampling: Cross-Validated (5 fold)
## Summary of sample sizes: 3307, 3308, 3308, 3309, 3308
## Resampling results across tuning parameters:
##
## cp Accuracy Kappa
## 0.06695779 0.9105167 0.8210470
## 0.11353712 0.8626216 0.7253755
## 0.67879670 0.7646886 0.5288300
##
## Accuracy was used to select the optimal model using the largest value.
## The final value used for the model was cp = 0.06695779.importance <- varImp(treeRoseACC, scale=FALSE)
print(importance)## rpart variable importance
##
## only 20 most important variables shown (out of 240)
##
## Overall
## recursos_de_partidos 1084.0
## quantidade_despesas 1076.3
## recursos_de_pessoas_juridicas 1074.5
## total_receita 1007.2
## quantidade_fornecedores 978.9
## recursos_de_pessoas_físicas 296.1
## `descricao_ocupacaoTÉCNICO DE MECÂNICA` 0.0
## `descricao_ocupacaoPILOTO DE AVIAÇÃO COMERCIAL, NAVEGADOR, MECÂNICO DE VÔO E ASSEMELHADOS` 0.0
## `descricao_ocupacaoOPERADOR DE COMPUTADOR` 0.0
## descricao_ocupacaoCOZINHEIRO 0.0
## UFPE 0.0
## UFAL 0.0
## `descricao_ocupacaoCORRETOR DE IMÓVEIS, SEGUROS, TÍTULOS E VALORES` 0.0
## descricao_ocupacaoAGRÔNOMO 0.0
## partidoPSB 0.0
## `descricao_ocupacaoMOTORISTA PARTICULAR` 0.0
## descricao_ocupacaoCOMERCIANTE 0.0
## UFPI 0.0
## `descricao_ocupacaoASSISTENTE SOCIAL` 0.0
## descricao_ocupacaoVETERINÁRIO 0.0#plot(importance)
output <- subset(testSamples, select=c(ID))
output$prediction <- predict(treeRoseACC, testSamples)
write.csv(output, file = "output-tree-rose-acc.csv", row.names = FALSE)Desempenho na competição - 92.68% de score
Conhecidos os resultados de desempenho dos modelos de árvore de decisão apresentados, vamos escolher o que se saiu melhor no score do kaggle com os dados balanceados para realizar o tuning e entender melhor o modelo. Logo, a regressão logística com a técnica de resample ROSE será a eleita.
Modelo Adaboost com Over-Sampling no dataset, usando a métrica de avaliação Accuracy.
set.seed(100)
trainC <- trainControl(method = 'cv', number = 3)
adaBoostUpACC <- caret::train(formula,
data = overData,
method = 'adaboost',
metric = 'Accuracy',
trControl = trainC)
adaBoostUpACC## AdaBoost Classification Trees
##
## 7438 samples
## 20 predictors
## 2 classes: 'eleito', 'nao_eleito'
##
## No pre-processing
## Resampling: Cross-Validated (3 fold)
## Summary of sample sizes: 4958, 4959, 4959
## Resampling results across tuning parameters:
##
## nIter method Accuracy Kappa
## 50 Adaboost.M1 0.9788927 0.9577856
## 50 Real adaboost 0.9770102 0.9540206
## 100 Adaboost.M1 0.9802371 0.9604742
## 100 Real adaboost 0.9768758 0.9537517
## 150 Adaboost.M1 0.9799682 0.9599365
## 150 Real adaboost 0.9776823 0.9553646
##
## Accuracy was used to select the optimal model using the largest value.
## The final values used for the model were nIter = 100 and method
## = Adaboost.M1.importance <- varImp(adaBoostUpACC, scale=FALSE)
print(importance)## ROC curve variable importance
##
## Importance
## total_receita 0.9670
## quantidade_despesas 0.9486
## quantidade_fornecedores 0.9384
## quantidade_doacoes 0.9213
## media_receita 0.9195
## quantidade_doadores 0.9183
## recursos_de_pessoas_juridicas 0.9100
## recursos_de_pessoas_físicas 0.9006
## recursos_de_partidos 0.8417
## recursos_proprios 0.7513
## recursos_de_outros_candidatos.comites 0.7418
## descricao_ocupacao 0.6542
## grau 0.6158
## despesa_max_campanha 0.6085
## sexo 0.6012
## descricao_cor_raca 0.6005
## estado_civil 0.5829
## idade 0.5745
## UF 0.5488
## partido 0.5352#plot(importance)
output <- subset(testSamples, select=c(ID))
output$prediction <- predict(adaBoostUpACC, testSamples)
write.csv(output, file = "output-adaboost-up-acc.csv", row.names = FALSE)Esse modelo obteu um score de 94% nos 50% dos dados de teste da competição.
Primeiro realizaremos a avaliação dos modelos elegidos com as métricas de acurácia, precision, recall e f-measure.
Essas métricas são definidas em termos de Verdadeiros Positivos (TP), Verdadeiros Negativos (TN) Falsos Positivos (FP) e Falsos Negativos (FN).
Acurácia = (TP + TN) / (TP + TN + FP + FN) Nos diz a proporção de observações corretamente classificadas.
Precision = TP / (TP + FP) Diz respeito a quantas das observaçoes preditas como positivas são realmente positivas.
Recall = TP / (TP + FN) Diz respeito a quantas das observaçoes positivas foram corretamente classificadas.
F-measure = 2 * (Precision * Recall) / (Precision + Recall) O F1 score or F-measure é uma média harmônica das métricas precision e recall, quanto mais próximo de 1 o valor de F1 score melhor e quanto mais próximo de 0 pior.
Modelo de regressão logística com Over-Sampling.
control <- trainControl(method = 'cv', number = 5)
logisticUp <- train(formula,
data = overData,
method = "glm",
family = "binomial",
trControl = control)## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred## Warning in predict.lm(object, newdata, se.fit, scale = 1, type =
## ifelse(type == : prediction from a rank-deficient fit may be misleading## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurredc_observation <- observations
c_observation$predicao <- predict(logisticUp, c_observation)
TP <- c_observation %>% filter(situacao_final == "eleito", predicao == "eleito") %>% nrow()
TN <- c_observation %>% filter(situacao_final == "nao_eleito" , predicao == "nao_eleito" ) %>% nrow()
FP <- c_observation %>% filter(situacao_final == "nao_eleito" , predicao == "eleito") %>% nrow()
FN <- c_observation %>% filter(situacao_final == "eleito", predicao == "nao_eleito" ) %>% nrow()
accuracy <- (TP + TN)/(TP + TN + FP + FN)
precision <- TP / (TP + FP)
recall <- TP / (TP + FN)
f_measure <- 2*(precision * recall) / (precision + recall)
accuracy## [1] 0.9376058precision## [1] 0.6242138recall## [1] 0.9543269f_measure## [1] 0.7547529Podemos observar com as novas métricas de avaliação do modelo que a F1 score foi moderada 75%. Contudo, nesse modelo com regressão logística existem problemas com Falsos Negativos, já que a métrica precision foi 62%, essas informações são importantes para posteriores propostas de tuning do modelo.
Agora vamos observar a importância das variáveis no modelo de regressão logística.
importance <- varImp(logisticUp, scale=FALSE)
print(importance)## glm variable importance
##
## only 20 most important variables shown (out of 240)
##
## Overall
## descricao_ocupacaoDEPUTADO 7.681
## descricao_ocupacaoAGRICULTOR 4.990
## UFAM 4.971
## UFPI 4.437
## sexoMASCULINO 4.345
## partidoPTN 4.277
## UFAP 4.237
## partidoPR 4.237
## UFMS 4.155
## `grauSUPERIOR COMPLETO` 4.115
## UFRR 4.017
## `estado_civilVIÚVO(A)` 3.932
## `grauSUPERIOR INCOMPLETO` 3.928
## descricao_ocupacaoINDUSTRIAL 3.814
## quantidade_doacoes 3.781
## UFMA 3.708
## partidoPSD 3.640
## partidoPRB 3.531
## `descricao_ocupacaoCORRETOR DE IMÓVEIS, SEGUROS, TÍTULOS E VALORES` 3.263
## despesa_max_campanha 3.217Podemos observar que as 5 variáveis mais importantes são:
Uma proposta de melhora nesse modelo seria a utilização da Penalized Logistic Regression.
Modelo de Árvore de Decisão com ROSE.
trainC <- trainControl(method = 'cv', number = 5)
treeRoseACC <- caret::train(formula,
data = roseData,
method = "rpart",
trControl = trainC,
metric = 'Accuracy')
c_observation <- observations
c_observation$predicao <- predict(treeRoseACC, c_observation)
TP <- c_observation %>% filter(situacao_final == "eleito", predicao == "eleito") %>% nrow()
TN <- c_observation %>% filter(situacao_final == "nao_eleito" , predicao == "nao_eleito" ) %>% nrow()
FP <- c_observation %>% filter(situacao_final == "nao_eleito" , predicao == "eleito") %>% nrow()
FN <- c_observation %>% filter(situacao_final == "eleito", predicao == "nao_eleito" ) %>% nrow()
accuracy <- (TP + TN)/(TP + TN + FP + FN)
precision <- TP / (TP + FP)
recall <- TP / (TP + FN)
f_measure <- 2*(precision * recall) / (precision + recall)
accuracy## [1] 0.9322854precision## [1] 0.636recall## [1] 0.7644231f_measure## [1] 0.6943231Podemos observar com as novas métricas de avaliação do modelo que a F1 score foi moderada 69%. Contudo, nesse modelo com árvore de decisão existem problemas com Falsos Positivos, já que a métrica precision foi 63% e problemas com falsos negativos pelo fato da métrica precision ter sido 76%.
Agora vamos observar a importância das variáveis no modelo de árvore de decisão.
importance <- varImp(treeRoseACC, scale=FALSE)
print(importance)## rpart variable importance
##
## only 20 most important variables shown (out of 240)
##
## Overall
## recursos_de_partidos 1084.0
## quantidade_despesas 1076.3
## recursos_de_pessoas_juridicas 1074.5
## total_receita 1007.2
## quantidade_fornecedores 978.9
## recursos_de_pessoas_físicas 296.1
## `descricao_ocupacaoTÉCNICO DE ELETRICIDADE, ELETRÔNICA E TELECOMUNICAÇÕES` 0.0
## partidoPSC 0.0
## quantidade_doacoes 0.0
## UFAL 0.0
## partidoPCB 0.0
## `descricao_ocupacaoTRABALHADOR DE CONSTRUÇÃO CIVIL` 0.0
## descricao_ocupacaoPEDAGOGO 0.0
## partidoPCO 0.0
## `descricao_ocupacaoATOR E DIRETOR DE ESPETÁCULOS PÚBLICOS` 0.0
## `descricao_ocupacaoTÉCNICO DE ENFERMAGEM E ASSEMELHADOS (EXCETO ENFERMEIRO)` 0.0
## `descricao_ocupacaoSERVIDOR PÚBLICO FEDERAL` 0.0
## partidoPDT 0.0
## UFRO 0.0
## `descricao_ocupacaoMECÂNICO DE MANUTENÇÃO` 0.0Podemos observar com esse modelo que existem apenas 5 variáveis consideradas importantes.
Modelo Adaboost com Over-Sampling no dataset.
c_observation <- observations
c_observation$predicao <- predict(adaBoostUpACC, c_observation)
TP <- c_observation %>% filter(situacao_final == "eleito", predicao == "eleito") %>% nrow()
TN <- c_observation %>% filter(situacao_final == "nao_eleito" , predicao == "nao_eleito" ) %>% nrow()
FP <- c_observation %>% filter(situacao_final == "nao_eleito" , predicao == "eleito") %>% nrow()
FN <- c_observation %>% filter(situacao_final == "eleito", predicao == "nao_eleito" ) %>% nrow()
accuracy <- (TP + TN)/(TP + TN + FP + FN)
precision <- TP / (TP + FP)
recall <- TP / (TP + FN)
f_measure <- 2*(precision * recall) / (precision + recall)
accuracy## [1] 1precision## [1] 1recall## [1] 1f_measure## [1] 1importance <- varImp(adaBoostUpACC, scale=FALSE)
print(importance)## ROC curve variable importance
##
## Importance
## total_receita 0.9670
## quantidade_despesas 0.9486
## quantidade_fornecedores 0.9384
## quantidade_doacoes 0.9213
## media_receita 0.9195
## quantidade_doadores 0.9183
## recursos_de_pessoas_juridicas 0.9100
## recursos_de_pessoas_físicas 0.9006
## recursos_de_partidos 0.8417
## recursos_proprios 0.7513
## recursos_de_outros_candidatos.comites 0.7418
## descricao_ocupacao 0.6542
## grau 0.6158
## despesa_max_campanha 0.6085
## sexo 0.6012
## descricao_cor_raca 0.6005
## estado_civil 0.5829
## idade 0.5745
## UF 0.5488
## partido 0.5352Vamos testar um modelo com Random Forest e com a técnica de resample SMOTE.
trainC <- trainControl(method = 'cv', number = 5)
rfSmote <- caret::train(formula,
data = smoteData,
method = "rf",
trControl = trainC)
rfSmote## Random Forest
##
## 2912 samples
## 20 predictors
## 2 classes: 'eleito', 'nao_eleito'
##
## No pre-processing
## Resampling: Cross-Validated (5 fold)
## Summary of sample sizes: 2331, 2329, 2329, 2329, 2330
## Resampling results across tuning parameters:
##
## mtry Accuracy Kappa
## 2 0.8901055 0.7721615
## 121 0.9505437 0.8994855
## 240 0.9481417 0.8945399
##
## Accuracy was used to select the optimal model using the largest value.
## The final value used for the model was mtry = 121.output <- subset(testSamples, select=c(ID))
output$prediction <- predict(rfSmote, testSamples)
write.csv(output, file = "output-rf-smote.csv", row.names = FALSE)
c_observation <- observations
c_observation$predicao <- predict(rfSmote, c_observation)
TP <- c_observation %>% filter(situacao_final == "eleito", predicao == "eleito") %>% nrow()
TN <- c_observation %>% filter(situacao_final == "nao_eleito" , predicao == "nao_eleito" ) %>% nrow()
FP <- c_observation %>% filter(situacao_final == "nao_eleito" , predicao == "eleito") %>% nrow()
FN <- c_observation %>% filter(situacao_final == "eleito", predicao == "nao_eleito" ) %>% nrow()
accuracy <- (TP + TN)/(TP + TN + FP + FN)
precision <- TP / (TP + FP)
recall <- TP / (TP + FN)
f_measure <- 2*(precision * recall) / (precision + recall)
accuracy## [1] 0.947763precision## [1] 0.6582278recall## [1] 1f_measure## [1] 0.7938931O modelo teve um desempenho de 89.13% nos testes públicos no kaggle. Além disso, podemos observar que o F1-score foi de 79.38%, que é relativamente alto, o recall foi 100% indicando que o modelo testado não atestou nenhum falso negativo o que é muito bom. Contudo, a métrica precision foi de 65.82%, indicando que o modelo possui problemas com falsos positivos.