Each item corresponds to a candidate, the attributes of each item are as follows:

• ano : Year at which the election took place.
• sequencial_candidato : Sequential ID to map the candidates
• nome : Name of the candidate
• uf : Federate state to which the candidate belongs.
• partido : Political party to which the candidate belongs.
• quantidade_doacoes : Number of donations received during political campaign.
• quantidade_doadores : Number of donators that contributed to the candidate’s political campaign.
• total_receita : Total revenue.
• media_receita : Mean revenue.
• recursos_de_outros_candidatos.comites : Revenue coming from other candidate’s committees.
• recursos_de_pessoas_fisicas : Revenue coming from individuals.
• recursos_de_pessoas_juridicas : Revenue coming from legal entities.
• recursos_proprios : Revenue coming from personal resources.
• recursos_de_partido_politico : Revenue coming from political party.
• quantidade_despesas : Number of expenses.
• quantidade_fornecedores : Number of suppliers.
• total_despesa : Total expenditure.
• media_despesa : Mea expenditure.
• cargo : Position.
• sexo : Sex.
• grau : Level of education.
• estado_civil : Marital status.
• ocupacao : Candidate’s occupation up to the election.
• votos : Number of votes received.

Let’s take a look at the quantitative predictors of interest.

• sequencial candidato has no meaning attached to it so we’ll skip it.

eleicoes_data %>%
  select(id,
         quantidade_despesas,
         quantidade_fornecedores,
         recursos_de_partido_politico,
         recursos_de_pessoas_juridicas,
         recursos_de_pessoas_fisicas,
         recursos_de_outros_candidatos.comites) %>%
  melt(id=c("id"))  %>%
  ggplot(aes(x = value)) + 
  geom_histogram(bins = 30) + 
  facet_wrap(. ~ variable,
             ncol = 2,
             scales = "free_x")  +
  labs(x="Predictor",y="Absolute Frequency")

• We can see a positive skew across checked predictors even if different elections are no longer discriminated.

eleicoes_data %>%
  select(id,
         total_receita,
         media_receita,
         total_despesa,
         media_despesa,
         recursos_proprios,
         quantidade_doacoes,
         quantidade_doadores) %>%
  melt(id=c("id"))  %>%
  ggplot(aes(x = value)) + 
  geom_histogram(bins = 30) + 
  facet_wrap(. ~ variable,
             scales = "free_x") +
  labs(x="Predictor",y="Absolute Frequency")

• The overall positive skew extends to these variables as well even if different elections are no longer discriminated.

Dealing with positive skew

The standard method to deal with a positive skew is to apply a logarithmic transformation to the affected predictor. However, to apply the aforementioned transformation the predictor must not contain any 0.

eleicoes_data %>%
  select(quantidade_doacoes,
         quantidade_doadores,
         total_receita,
         media_receita,
         recursos_de_outros_candidatos.comites,
         recursos_de_pessoas_fisicas,
         recursos_de_pessoas_juridicas,
         recursos_proprios,
         recursos_de_partido_politico,
         quantidade_despesas,
         quantidade_fornecedores,
         total_despesa,
         media_despesa) %>%
  sapply(., function(x) 0 %in% x) %>%
  as.data.frame(row.names = NULL) %>%
  tibble::rownames_to_column() %>%
  set_colnames(c("predictor","contains_zero")) %>%
  arrange(contains_zero)

##                                predictor contains_zero
## 1                     quantidade_doacoes         FALSE
## 2                    quantidade_doadores         FALSE
## 3                    quantidade_despesas         FALSE
## 4                quantidade_fornecedores         FALSE
## 5                          total_receita          TRUE
## 6                          media_receita          TRUE
## 7  recursos_de_outros_candidatos.comites          TRUE
## 8            recursos_de_pessoas_fisicas          TRUE
## 9          recursos_de_pessoas_juridicas          TRUE
## 10                     recursos_proprios          TRUE
## 11          recursos_de_partido_politico          TRUE
## 12                         total_despesa          TRUE
## 13                         media_despesa          TRUE

• There are four predictors on which we may apply the logarithmic transformation
• We’ll resort to square root transformation for the rest.

# apply logarithmic transformation
eleicoes_data %>%
  mutate(log.quantidade_doacoes = log10(quantidade_doacoes),
         log.quantidade_doadores = log10(quantidade_doadores),
         log.quantidade_despesas = log10(quantidade_despesas),
         log.quantidade_fornecedores = log10(quantidade_fornecedores),
         sqrt.total_receita = sqrt(total_receita),
         sqrt.media_receita = sqrt(media_receita),
         sqrt.total_despesa = sqrt(total_despesa),
         sqrt.media_despesa = sqrt(media_despesa),
         sqrt.recursos_proprios = sqrt(recursos_proprios),
         sqrt.recursos_de_pessoas_juridicas = sqrt(recursos_de_pessoas_juridicas),
         sqrt.recursos_de_partido_politico = sqrt(recursos_de_partido_politico),
         sqrt.recursos_de_outros_candidatos.comites = sqrt(recursos_de_outros_candidatos.comites),
         sqrt.recursos_de_pessoas_fisicas = sqrt(recursos_de_pessoas_fisicas)) -> eleicoes_data


# put all quantitative predictors (of interest) in same scale
eleicoes_data %>%
  mutate_at(.vars = vars(quantidade_doacoes,
                         quantidade_doadores,
                         total_receita,
                         media_receita,
                         sqrt.total_receita,
                         sqrt.media_receita,
                         sqrt.recursos_de_outros_candidatos.comites,
                         sqrt.recursos_de_pessoas_fisicas,
                         sqrt.recursos_de_pessoas_juridicas,
                         sqrt.recursos_proprios,
                         sqrt.recursos_de_partido_politico,
                         sqrt.total_despesa,
                         sqrt.media_despesa,
                         log.quantidade_doacoes,
                         log.quantidade_doadores,
                         log.quantidade_despesas,
                         log.quantidade_fornecedores,
                         sequencial_candidato,
                         recursos_de_outros_candidatos.comites,
                         recursos_de_pessoas_fisicas,
                         recursos_de_pessoas_juridicas,
                         recursos_proprios,
                         recursos_de_partido_politico,
                         quantidade_despesas,
                         quantidade_fornecedores,
                         total_despesa,
                         media_despesa),
             .funs = funs(as.numeric(scale(.)))) -> scaled_data

## Warning: funs() is soft deprecated as of dplyr 0.8.0
## please use list() instead
## 
## # Before:
## funs(name = f(.)
## 
## # After: 
## list(name = ~f(.))
## This warning is displayed once per session.

eleicoes_data %>%
  select(id,
         log.quantidade_doacoes,
         log.quantidade_doadores,
         log.quantidade_despesas,
         log.quantidade_fornecedores) %>%
  melt(id=c("id"))  %>%
  ggplot(aes(x = value)) + 
  geom_histogram(bins = 30) + 
  facet_wrap(. ~ variable,
             scales = "free_x") +
  labs(x="Predictor",y="Absolute Frequency")

• We have evidence that the positive skew has been atenuated by the logarithmic transformations.

eleicoes_data %>%
  select(id,
         sqrt.total_receita,
         sqrt.media_receita,
         sqrt.recursos_de_outros_candidatos.comites,
         sqrt.recursos_de_pessoas_fisicas,
         sqrt.recursos_de_pessoas_juridicas,
         sqrt.recursos_proprios,
         sqrt.recursos_de_partido_politico,
         sqrt.total_despesa,
         sqrt.media_despesa) %>%
  melt(id=c("id"))  %>%
  ggplot(aes(x = value)) + 
  geom_histogram(bins = 30) + 
  facet_wrap(. ~ variable,
             scales = "free_x") +
  labs(x="Predictor",y="Absolute Frequency")

• We have evidence that the positive skew has been atenuated by the square root transformation.
  • On a side note, the square root transformation seems less eficient than the logarithmic transformation.

We’ll use the correlogram to have an idea on how the predictors interact with each and with the target variable. How the predictors react with the target votos is of particular interest.

• Predictors whom have been transformed will be replaced by their enhanced versions.

eleicoes_data %>% 
  filter(ano == 2006) %>%
  select(-partido,
         -uf,-nome,-id,
         -estado_civil,
         -ocupacao,-ano,
         -total_receita,
         -media_receita,
         -total_despesa,
         -media_despesa,
         -recursos_proprios,
         -cargo,-grau,-sexo,
         -quantidade_doacoes,
         -quantidade_doadores,
         -quantidade_despesas,
         -quantidade_fornecedores,
         -recursos_de_pessoas_fisicas,
         -recursos_de_partido_politico,
         -recursos_de_pessoas_juridicas,
         -recursos_de_outros_candidatos.comites) %>%
  na.omit() %>%
  ggcorr(palette = "RdBu",
         color = "grey50",
         label = TRUE, hjust = 1,
         label_size = 3, size = 4,
         nbreaks = 5, layout.exp = 7) +
  ggtitle("Correlation plot for 2006 elections")

• sequencial_candidato doesn’t not look meaningful (as expected).
• total_receita, total_despesa and recursos_de_pessoas_juridicas seem very meaningful.

eleicoes_data %>% 
  filter(ano == 2010) %>%
  select(-partido,
         -uf,-nome,-id,
         -estado_civil,
         -ocupacao,-ano,
         -total_receita,
         -media_receita,
         -total_despesa,
         -media_despesa,
         -recursos_proprios,
         -cargo,-grau,-sexo,
         -quantidade_doacoes,
         -quantidade_doadores,
         -quantidade_despesas,
         -quantidade_fornecedores,
         -recursos_de_pessoas_fisicas,
         -recursos_de_partido_politico,
         -recursos_de_pessoas_juridicas,
         -recursos_de_outros_candidatos.comites) %>%
  na.omit() %>%
  ggcorr(palette = "RdBu",
         color = "grey50",
         label = TRUE, hjust = 1,
         label_size = 3, size = 4,
         nbreaks = 5, layout.exp = 7) +
  ggtitle("Correlation plot for 2010 elections")

• sequencial_candidato doesn’t look meaningful (as expected).
• sqrt.total_receita, sqrt.total_despesa and sqrt.recursos_de_pessoas_juridicas seem meaningful.

eleicoes_data %>% 
  select(-partido,
         -uf,-nome,-id,
         -estado_civil,
         -ocupacao,-ano,
         -total_receita,
         -media_receita,
         -total_despesa,
         -media_despesa,
         -recursos_proprios,
         -cargo,-grau,-sexo,
         -quantidade_doacoes,
         -quantidade_doadores,
         -quantidade_despesas,
         -quantidade_fornecedores,
         -recursos_de_pessoas_fisicas,
         -recursos_de_partido_politico,
         -recursos_de_pessoas_juridicas,
         -recursos_de_outros_candidatos.comites) %>%
  na.omit() %>%
  ggcorr(palette = "RdBu",
         color = "grey50",
         label = TRUE, hjust = 1,
         label_size = 3, size = 4,
         nbreaks = 5, layout.exp = 7) +
  ggtitle("Correlation plot for both elections")

• sequencial_candidato does’nt look meaningful (as expected).
• sqrt.total_receita, sqrt.total_despesa and sqrt.recursos_de_pessoas_juridicas seem very meaningful.

Split Data for Cross Validation

• Let’s use the \(50/25/25\) proportions for the train, validate and test datasets.

scaled_data %>%  
   filter(ano == 2006) -> scaled_data_2006

scaled_data_2006 %>%
  sample_n(5)

## # A tibble: 5 x 38
##     ano sequencial_cand… nome  uf    partido quantidade_doac…
##   <int>            <dbl> <chr> <chr> <chr>              <dbl>
## 1  2006           -0.930 JOÃO… SP    PDT              -0.211 
## 2  2006           -0.930 NERY… RS    PFL              -0.203 
## 3  2006           -0.930 SÉRG… SP    PT               -0.0409
## 4  2006           -0.930 PAUL… SP    PV               -0.152 
## 5  2006           -0.930 LUIS… RJ    PTB              -0.228 
## # … with 32 more variables: quantidade_doadores <dbl>,
## #   total_receita <dbl>, media_receita <dbl>,
## #   recursos_de_outros_candidatos.comites <dbl>,
## #   recursos_de_pessoas_fisicas <dbl>,
## #   recursos_de_pessoas_juridicas <dbl>, recursos_proprios <dbl>,
## #   recursos_de_partido_politico <dbl>, quantidade_despesas <dbl>,
## #   quantidade_fornecedores <dbl>, total_despesa <dbl>,
## #   media_despesa <dbl>, cargo <chr>, sexo <chr>, grau <chr>,
## #   estado_civil <chr>, ocupacao <chr>, votos <int>, id <int>,
## #   log.quantidade_doacoes <dbl>, log.quantidade_doadores <dbl>,
## #   log.quantidade_despesas <dbl>, log.quantidade_fornecedores <dbl>,
## #   sqrt.total_receita <dbl>, sqrt.media_receita <dbl>,
## #   sqrt.total_despesa <dbl>, sqrt.media_despesa <dbl>,
## #   sqrt.recursos_proprios <dbl>,
## #   sqrt.recursos_de_pessoas_juridicas <dbl>,
## #   sqrt.recursos_de_partido_politico <dbl>,
## #   sqrt.recursos_de_outros_candidatos.comites <dbl>,
## #   sqrt.recursos_de_pessoas_fisicas <dbl>

set.seed(11) # We set the set for reason of reproducibility

scaled_data_2006 %>% 
  dplyr::sample_frac(.5) -> train_data_2006

encoding <- build_encoding(dataSet = train_data_2006,
                           cols = c("uf","sexo","grau",
                                    "partido","estado_civil"),
                           verbose = F)

train_data_2006 <- one_hot_encoder(dataSet = train_data_2006,
                           encoding = encoding,
                           drop = TRUE,
                           verbose = F)

cat("#### Train Data ",
    "\n##### Observations: ",nrow(train_data_2006),
    "\n##### Variables: ",ncol(train_data_2006))

set.seed(11) # We set the set for reason of reproducibility

dplyr::anti_join(scaled_data_2006, 
                 train_data_2006, 
                 by = 'id') -> intermediate_data

intermediate_data %>% 
  dplyr::sample_frac(.5) -> test_data_2006

test_data_2006 <- one_hot_encoder(dataSet = test_data_2006,
                           encoding = encoding,
                           drop = TRUE,
                           verbose = F)

cat("#### Test Data ",
    "\n##### Observations: ",nrow(test_data_2006),
    "\n##### Variables: ",ncol(test_data_2006))

set.seed(11) # We set the set for reason of reproducibility

dplyr::anti_join(intermediate_data, 
                 test_data_2006, 
                 by = 'id') -> validate_data_2006


validate_data_2006 <- one_hot_encoder(dataSet = validate_data_2006,
                           encoding = encoding,
                           drop = TRUE,
                           verbose = F)
rm(intermediate_data)

cat("#### Validate Data ",
    "\n##### Observations: ",nrow(validate_data_2006),
    "\n##### Variables: ",ncol(validate_data_2006))

Train the model

mod_2006 <- lm(votos ~ log.quantidade_fornecedores * partido.PSDB + sqrt.media_despesa * partido.PMDB +
                  sqrt.total_receita * sqrt.total_despesa + uf.SP * estado.civil.CASADO.A. + 
                  uf.RJ * sqrt.total_despesa + sqrt.total_receita * `grau.SUPERIOR COMPLETO`, 
          data = train_data_2006)

broom::glance(mod_2006)

## # A tibble: 1 x 11
##   r.squared adj.r.squared  sigma statistic   p.value    df  logLik    AIC
##       <dbl>         <dbl>  <dbl>     <dbl>     <dbl> <int>   <dbl>  <dbl>
## 1     0.521         0.517 31581.      116. 8.40e-258    17 -20228. 40492.
## # … with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>

• As these quality metrics come from training they aren’t that meaningful:
  • A decent \(R^2\) and \(adjusted \thinspace R^2\) around \(0.5\).
  • The \(F \thinspace statistic\) (statistic) is way bigger than 1 (a good sign).

broom::tidy(mod_2006,
            conf.int = TRUE,
            conf.level = 0.95)

## # A tibble: 17 x 7
##    term            estimate std.error statistic  p.value conf.low conf.high
##    <chr>              <dbl>     <dbl>     <dbl>    <dbl>    <dbl>     <dbl>
##  1 (Intercept)       33434.     2270.   14.7    2.58e-46   28982.    37885.
##  2 log.quantidade…  -12327.     2032.   -6.07   1.60e- 9  -16312.    -8342.
##  3 partido.PSDB      -3866.     3445.   -1.12   2.62e- 1  -10623.     2892.
##  4 sqrt.media_des…   -2453.     1689.   -1.45   1.47e- 1   -5765.      860.
##  5 partido.PMDB       -981.     2773.   -0.354  7.23e- 1   -6420.     4457.
##  6 sqrt.total_rec…  -14239.    10973.   -1.30   1.95e- 1  -35762.     7283.
##  7 sqrt.total_des…   75440.    11734.    6.43   1.66e-10   52426.    98455.
##  8 uf.SP              4022.     3232.    1.24   2.13e- 1   -2316.    10361.
##  9 estado.civil.C…    1079.     1846.    0.584  5.59e- 1   -2542.     4699.
## 10 uf.RJ              -237.     2661.   -0.0892 9.29e- 1   -5456.     4981.
## 11 `grau.SUPERIOR…     765.     1815.    0.421  6.74e- 1   -2796.     4325.
## 12 log.quantidade…    3952.     3130.    1.26   2.07e- 1   -2186.    10091.
## 13 sqrt.media_des…    -875.     2740.   -0.319  7.50e- 1   -6249.     4500.
## 14 sqrt.total_rec…   -7936.     1255.   -6.32   3.29e-10  -10398.    -5474.
## 15 uf.SP:estado.c…   -5188.     3942.   -1.32   1.88e- 1  -12920.     2543.
## 16 sqrt.total_des…   -1166.     3843.   -0.303  7.62e- 1   -8703.     6372.
## 17 sqrt.total_rec…    4494.     2714.    1.66   9.80e- 2    -830.     9818.

Split Data for Cross Validation

• Let’s use the \(50/25/25\) proportions for the train, validate and test datasets

scaled_data %>%
  filter(ano == 2010) -> scaled_data_2010

scaled_data_2010 %>%
  sample_n(5)

## # A tibble: 5 x 38
##     ano sequencial_cand… nome  uf    partido quantidade_doac…
##   <int>            <dbl> <chr> <chr> <chr>              <dbl>
## 1  2010            0.382 FERN… MG    PRTB              -0.169
## 2  2010           -0.829 EDSO… AC    PSDB              -0.211
## 3  2010            0.988 MARC… RJ    PDT                0.946
## 4  2010           -0.728 ELIA… AL    PR                -0.228
## 5  2010           -0.425 SEGI… BA    PSC               -0.100
## # … with 32 more variables: quantidade_doadores <dbl>,
## #   total_receita <dbl>, media_receita <dbl>,
## #   recursos_de_outros_candidatos.comites <dbl>,
## #   recursos_de_pessoas_fisicas <dbl>,
## #   recursos_de_pessoas_juridicas <dbl>, recursos_proprios <dbl>,
## #   recursos_de_partido_politico <dbl>, quantidade_despesas <dbl>,
## #   quantidade_fornecedores <dbl>, total_despesa <dbl>,
## #   media_despesa <dbl>, cargo <chr>, sexo <chr>, grau <chr>,
## #   estado_civil <chr>, ocupacao <chr>, votos <int>, id <int>,
## #   log.quantidade_doacoes <dbl>, log.quantidade_doadores <dbl>,
## #   log.quantidade_despesas <dbl>, log.quantidade_fornecedores <dbl>,
## #   sqrt.total_receita <dbl>, sqrt.media_receita <dbl>,
## #   sqrt.total_despesa <dbl>, sqrt.media_despesa <dbl>,
## #   sqrt.recursos_proprios <dbl>,
## #   sqrt.recursos_de_pessoas_juridicas <dbl>,
## #   sqrt.recursos_de_partido_politico <dbl>,
## #   sqrt.recursos_de_outros_candidatos.comites <dbl>,
## #   sqrt.recursos_de_pessoas_fisicas <dbl>

set.seed(11) # We set the set for reason of reproducibility

scaled_data_2010 %>% 
  dplyr::sample_frac(.5) -> train_data_2010

encoding <- build_encoding(dataSet = train_data_2010,
                           cols = c("uf","sexo","grau",
                                    "partido","estado_civil"),
                           verbose = F)

train_data_2010 <- one_hot_encoder(dataSet = train_data_2010,
                           encoding = encoding,
                           drop = TRUE,
                           verbose = F)

cat("#### Train Data ",
    "\n##### Observations: ",nrow(train_data_2010),
    "\n##### Variables: ",ncol(train_data_2010))

set.seed(11) # We set the set for reason of reproducibility

dplyr::anti_join(scaled_data_2010, 
                 train_data_2010, 
                 by = 'id') -> intermediate_data

intermediate_data %>% 
  dplyr::sample_frac(.5) -> test_data_2010

test_data_2010 <- one_hot_encoder(dataSet = test_data_2010,
                           encoding = encoding,
                           drop = TRUE,
                           verbose = F)

cat("#### Test Data ",
    "\n##### Observations: ",nrow(test_data_2010),
    "\n##### Variables: ",ncol(test_data_2010))

set.seed(11) # We set the set for reason of reproducibility

dplyr::anti_join(intermediate_data, 
                 test_data_2010, 
                 by = 'id') -> validate_data_2010

validate_data_2010 <- one_hot_encoder(dataSet = validate_data_2010,
                           encoding = encoding,
                           drop = TRUE,
                           verbose = F)

rm(intermediate_data)

cat("#### Validate Data ",
    "\n##### Observations: ",nrow(validate_data_2010),
    "\n##### Variables: ",ncol(validate_data_2010))

P Value isn’t as effective in pointing out who are the most meaningful predictors as it’s in pointing which are the least meaningful.

broom::tidy(mod_2006, 
     conf.int = TRUE, 
     conf.level = 0.95,
     sep=":") %>%
  filter(term != "(Intercept)") %>%
  arrange(p.value) %>%
  slice(1:3) %>%
  ggplot(aes(reorder(term,p.value), p.value)) +
  geom_hline(yintercept = 0.05, colour = "darkred") +
  geom_point(size = 2) +
  labs(x = "Predictor variable",
       y = "Estimated p-value",
       title="Predictors of smallest p.value (2006 elections)")

• We can see the presence of different combinations of the predictors sqrt.total_receita and sqrt.total_despesa as predictors with good pvalues. This corroborates what the correlogram suggested.
• We also have log.quantidade_fornecedores with positive results.

broom::tidy(mod_2010, 
     conf.int = TRUE, 
     conf.level = 0.95,
     sep=":") %>%
  filter(term != "(Intercept)") %>%
  arrange(p.value) %>%
  slice(1:3) %>%
  ggplot(aes(reorder(term,p.value), p.value)) +
  geom_hline(yintercept = 0.05, colour = "darkred") +
  geom_point(size = 2) +
  labs(x = "Predictor variable",
       y = "Estimated p-value",
       title="Predictors of smallest p.value (2010 elections)")

• We can see the presence of different combinations of the predictors sqrt.total_receita and sqrt.total_despesa as predictors with good pvalues. This corroborates what the correlogram suggested.
• We also have log.quantidade_fornecedores and sqrt.media_despesa with positive results.

On both models different combinations of the predictors sqrt.total_receita and sqrt.total_despesa were clearly the best predictors (those that could explain the votes the most).

Resorting to thumb rules regarding Cook’s Distance we’ll use \(D_i > 1\) as a cutoff for highly influential points/outliers

Residual vs Fitted

mod_2006 %>%
  ggplot(aes(.fitted, .resid)) + 
  geom_point() +
  stat_smooth(method="loess") + 
  geom_hline(col="red",
             yintercept=0,
             linetype="dashed") + 
  labs(y="Residuals",
       x="Fitted values",
       title="Residual vs Fitted Plot (2006 elections)")

• There’s indication, although not strong, of a pattern in the residual vs fitted, this is a bad sign for the analyzed model.

mod_2010 %>%
  ggplot(aes(.fitted, .resid)) + 
  geom_point() +
  stat_smooth(method="loess") + 
  geom_hline(col="red",
             yintercept=0,
             linetype="dashed") + 
  labs(y="Residuals",
       x="Fitted values",
       title="Residual vs Fitted Plot (2010 elections)")

• Here we can see rather equally spread residuals around a horizontal line (could be better) without distinct patterns. A good sign for the model.

Normal Q-Q

mod_2006 %>%
  ggplot(aes(sample=rstandard(.))) +
  stat_qq(na.rm = TRUE,
          shape=1,size=3) +      # open circles
  labs(title="Normal Q-Q (2006 elections)",        # plot title
  x="Theoretical Quantiles",      # x-axis label
  y="Standardized Residuals") +   # y-axis label +
  geom_abline(color = "red",
              size = 0.8,
              linetype="dashed")  # dashed reference line

• Our residuals somewhat deviate from a normal distribution. As we have a relatively mild deviation we have a negative yet mild symptom.

mod_2010 %>%
  ggplot(aes(sample=rstandard(.))) +
  stat_qq(na.rm = TRUE,
          shape=1,size=3) +      # open circles
  labs(title="Normal Q-Q (2010 elections)",        # plot title
  x="Theoretical Quantiles",      # x-axis label
  y="Standardized Residuals") +   # y-axis label +
  geom_abline(color = "red",
              size = 0.8,
              linetype="dashed")  # dashed reference line

• Although not perfect we can see that the residuals for this model are closer to normally distributed.

Scale-Location

mod_2006 %>%
  ggplot(aes(.fitted, 
             sqrt(abs(.stdresid)))) + 
  geom_point(na.rm=TRUE) + 
  stat_smooth(method="loess",
              na.rm = TRUE) +
  labs(title = "Scale-Location (2006 elections)",
       x= "Fitted Value",
       y = expression(sqrt("|Standardized residuals|")))

• The residuals are not equally spread. Our model has violated the assumption of \(homoscedasticity\) (equal variance) which is a bad sign.
  • The degree of the violation isn’t so extense, as from around the 50000th fitted value onward the residuals seem very equally spread.

mod_2010 %>%
  ggplot(aes(.fitted, 
             sqrt(abs(.stdresid)))) + 
  geom_point(na.rm=TRUE) + 
  stat_smooth(method="loess",
              na.rm = TRUE) +
  labs(title = "Scale-Location (2010 elections)",
       x= "Fitted Value",
       y = expression(sqrt("|Standardized residuals|")))

• Here we see a scenario similar to the one we just witnessed on the previous model.

Residual vs Leverage Plot

mod_2006 %>%
  ggplot(aes(.hat, .stdresid)) + 
  geom_point(aes(size=.cooksd), na.rm=TRUE) +
  stat_smooth(method="loess", na.rm=TRUE) +
  xlab("Leverage")+ylab("Standardized Residuals") + 
  ggtitle("Residual vs Leverage Plot (2006 elections)") + 
  scale_size_continuous("Cook's Distance", range=c(1,5)) +    
  theme(legend.position="bottom")

• We can see no outliers that would drastically change the results of our model.

mod_2010 %>%
  ggplot(aes(.hat, .stdresid)) + 
  geom_point(aes(size=.cooksd), na.rm=TRUE) +
  stat_smooth(method="loess", na.rm=TRUE) +
  xlab("Leverage")+ylab("Standardized Residuals") + 
  ggtitle("Residual vs Leverage Plot (2010 elections)") + 
  scale_size_continuous("Cook's Distance", range=c(1,5)) +    
  theme(legend.position="bottom")

• Here we have evidence of a outlier that would drastically change the results of our model: \(D_i = 1.2\)

Cook’s dist vs Leverage

mod_2006 %>%
  ggplot(aes(.hat, .cooksd)) + 
  geom_point(na.rm=TRUE) + 
  stat_smooth(method="loess", na.rm=TRUE) + 
  xlab("Leverage hii")+ylab("Cook's Distance") + 
  ggtitle("Cook's dist vs Leverage hii/(1-hii) (2006 elections)") + 
  geom_abline(slope=seq(0,3,0.5), color="gray", linetype="dashed")

• We can see no outliers that would drastically change the results of our model.

mod_2010 %>%
  ggplot(aes(.hat, .cooksd)) + 
  geom_point(na.rm=TRUE) + 
  stat_smooth(method="loess", na.rm=TRUE) + 
  xlab("Leverage hii")+ylab("Cook's Distance") + 
  ggtitle("Cook's dist vs Leverage hii/(1-hii) (2010 elections)") + 
  geom_abline(slope=seq(0,3,0.5), color="gray", linetype="dashed")

• Here we have evidence of a outlier that would drastically change the results of our model: \(D_i = 1.2\) ## Cross Validation

Validate

predictions <- mod_2006 %>% predict(validate_data_2006)

data.frame( R2 = caret::R2(predictions, validate_data_2006$votos),
            RMSE = caret::RMSE(predictions, validate_data_2006$votos),
            MAE = caret::MAE(predictions, validate_data_2006$votos),
            ERR = caret::RMSE(predictions, validate_data_2006$votos)/
              mean(validate_data_2006$votos))

##          R2     RMSE     MAE      ERR
## 1 0.5639769 30668.81 13639.2 1.321718

Now let’s talk about the results taken from the validate data for 2006 elections (more meaningful).

• We got a decent 0.56 R² and adjusted R² approximately (notice the decrease). This means that this model explain approximately 56% of the response variable variability.

• The average difference between the observed known outcome values and the values predicted by the model (RMSE) was of approximately 30669.
  • Our model would miss the mark by approximately 30669 (RMSE), that is if candidate had one million votes we would predict 30669 more than we should (or less than we should).
• The average absolute difference between observed and predicted outcomes (MAE) was approximately 13639.2 .

• The prediction error rate (ERR) was 1.321718.

predictions <- mod_2010 %>% predict(validate_data_2010)

data.frame( R2 = caret::R2(predictions, validate_data_2010$votos),
            RMSE = caret::RMSE(predictions, validate_data_2010$votos),
            MAE = caret::MAE(predictions, validate_data_2010$votos),
            ERR = caret::RMSE(predictions, validate_data_2010$votos)/
              mean(validate_data_2010$votos))

##          R2     RMSE      MAE      ERR
## 1 0.6208835 27599.68 13981.47 1.275393

Now let’s talk about the results taken from the validate data for 2010 elections (more meaningful).

• We got a decent 0.62 R² and adjusted R² approximately (notice the decrease). This means that this model explain approximately 62% of the response variable variability. (Smaller than the previous model)

The average difference between the observed known outcome values and the values predicted by the model (RMSE) was of approximately 27600 + Our model would miss the mark by approximately 27600 (RMSE), that is if candidate had one million votes we would predict 27600 more than we should (or less than we should). The average absolute difference between observed and predicted outcomes (MAE) was approximately 13981. * The prediction error rate (ERR) was 1.275393.

We have signs here of a decent although not brilliant fit of the model for 2006 elections. There’s no clear evidence of overfitting as test, validate and train rendered consonant results.

Test

predictions <- mod_2006 %>% predict(test_data_2006)

data.frame( R2 = caret::R2(predictions, test_data_2006$votos),
            RMSE = caret::RMSE(predictions, test_data_2006$votos),
            MAE = caret::MAE(predictions, test_data_2006$votos),
            ERR = caret::RMSE(predictions, test_data_2006$votos)/
              mean(test_data_2006$votos))

##          R2    RMSE      MAE      ERR
## 1 0.5810708 28937.3 13644.98 1.236634

Now let’s talk about the results taken from the test data for 2006 elections (most meaningful).

• We got a decent 0.58 R² and adjusted R² approximately (notice the decrease). This means that this model explain approximately 58% of the response variable variability. (Smaller than the previous model)

• The average difference between the observed known outcome values and the values predicted by the model (RMSE) was of approximately 28937
  • Our model would miss the mark by approximately 28937 (RMSE), that is if candidate had one million votes we would predict 28937 more than we should (or less than we should).
• The average absolute difference between observed and predicted outcomes (MAE) was approximately 13645.

• The prediction error rate (ERR) was 1.236634.

predictions <- mod_2010 %>% predict(test_data_2010)

data.frame( R2 = caret::R2(predictions, test_data_2010$votos),
            RMSE = caret::RMSE(predictions, test_data_2010$votos),
            MAE = caret::MAE(predictions, test_data_2010$votos),
            ERR = caret::RMSE(predictions, test_data_2010$votos)/
              mean(test_data_2010$votos))

##          R2     RMSE      MAE      ERR
## 1 0.5920504 26772.92 12847.32 1.347477

Now let’s talk about the results taken from the test data for 2006 elections (most meaningful).

• We got a decent 0.59 R² and adjusted R² approximately (notice the decrease). This means that this model explain approximately 59% of the response variable variability. (Smaller than the previous model)

• The average difference between the observed known outcome values and the values predicted by the model (RMSE) was of approximately 26773
  • Our model would miss the mark by approximately 26773 (RMSE), that is if candidate had one million votes we would predict 26773 more than we should (or less than we should).
• The average absolute difference between observed and predicted outcomes (MAE) was approximately 12847.

• The prediction error rate (ERR) was 1.347477.

The model for the 2010 elections also showed of a decent although not brilliant fit. There’s no clear evidence of overfitting as test, validate and train rendered consonant results.

Residue Analysis

mod_2006 %>%
  ggplot(aes(.fitted, .resid)) + 
  geom_point() +
  stat_smooth(method="loess") + 
  geom_hline(col="red",
             yintercept=0,
             linetype="dashed") + 
  labs(y="Residuals",
       x="Fitted values",
       title="Residual vs Fitted Plot (2006 elections)")

mod_2006 %>%
  ggplot(aes(sample=rstandard(.))) +
  stat_qq(na.rm = TRUE,
          shape=1,size=3) +      # open circles
  labs(title="Normal Q-Q (2006 elections)",        # plot title
  x="Theoretical Quantiles",      # x-axis label
  y="Standardized Residuals") +   # y-axis label +
  geom_abline(color = "red",
              size = 0.8,
              linetype="dashed")  # dashed reference line

mod_2006 %>%
  ggplot(aes(.fitted, 
             sqrt(abs(.stdresid)))) + 
  geom_point(na.rm=TRUE) + 
  stat_smooth(method="loess",
              na.rm = TRUE) +
  labs(title = "Scale-Location (2006 elections)",
       x= "Fitted Value",
       y = expression(sqrt("|Standardized residuals|")))

mod_2006 %>%
  ggplot(aes(.hat, .stdresid)) + 
  geom_point(aes(size=.cooksd), na.rm=TRUE) +
  stat_smooth(method="loess", na.rm=TRUE) +
  xlab("Leverage")+ylab("Standardized Residuals") + 
  ggtitle("Residual vs Leverage Plot (2006 elections)") + 
  scale_size_continuous("Cook's Distance", range=c(1,5)) +    
  theme(legend.position="bottom")

mod_2006 %>%
  ggplot(aes(.hat, .cooksd)) + 
  geom_point(na.rm=TRUE) + 
  stat_smooth(method="loess", na.rm=TRUE) + 
  xlab("Leverage hii")+ylab("Cook's Distance") + 
  ggtitle("Cook's dist vs Leverage hii/(1-hii) (2006 elections)") + 
  geom_abline(slope=seq(0,3,0.5), color="gray", linetype="dashed")

Cross Validation

predictions <- mod_2006 %>% predict(validate_data_2006)

data.frame( R2 = caret::R2(predictions, validate_data_2006$votos),
            RMSE = caret::RMSE(predictions, validate_data_2006$votos),
            MAE = caret::MAE(predictions, validate_data_2006$votos),
            ERR = caret::RMSE(predictions, validate_data_2006$votos)/
              mean(validate_data_2006$votos))

##          R2     RMSE      MAE      ERR
## 1 0.5632688 30697.33 13569.11 1.322946

predictions <- mod_2006 %>% predict(test_data_2006)

data.frame( R2 = caret::R2(predictions, test_data_2006$votos),
            RMSE = caret::RMSE(predictions, test_data_2006$votos),
            MAE = caret::MAE(predictions, test_data_2006$votos),
            ERR = caret::RMSE(predictions, test_data_2006$votos)/
              mean(test_data_2006$votos))

##          R2     RMSE      MAE      ERR
## 1 0.5882667 28684.37 13522.92 1.225825

Residue Analysis

mod_2010 %>%
  ggplot(aes(.fitted, .resid)) + 
  geom_point() +
  stat_smooth(method="loess") + 
  geom_hline(col="red",
             yintercept=0,
             linetype="dashed") + 
  labs(y="Residuals",
       x="Fitted values",
       title="Residual vs Fitted Plot (2010 elections)")

mod_2010 %>%
  ggplot(aes(sample=rstandard(.))) +
  stat_qq(na.rm = TRUE,
          shape=1,size=3) +      # open circles
  labs(title="Normal Q-Q (2010 elections)",        # plot title
  x="Theoretical Quantiles",      # x-axis label
  y="Standardized Residuals") +   # y-axis label +
  geom_abline(color = "red",
              size = 0.8,
              linetype="dashed")  # dashed reference line

mod_2010 %>%
  ggplot(aes(.fitted, 
             sqrt(abs(.stdresid)))) + 
  geom_point(na.rm=TRUE) + 
  stat_smooth(method="loess",
              na.rm = TRUE) +
  labs(title = "Scale-Location (2010 elections)",
       x= "Fitted Value",
       y = expression(sqrt("|Standardized residuals|")))

mod_2010 %>%
  ggplot(aes(.hat, .stdresid)) + 
  geom_point(aes(size=.cooksd), na.rm=TRUE) +
  stat_smooth(method="loess", na.rm=TRUE) +
  xlab("Leverage")+ylab("Standardized Residuals") + 
  ggtitle("Residual vs Leverage Plot (2010 elections)") + 
  scale_size_continuous("Cook's Distance", range=c(1,5)) +    
  theme(legend.position="bottom")

mod_2010 %>%
  ggplot(aes(.hat, .cooksd)) + 
  geom_point(na.rm=TRUE) + 
  stat_smooth(method="loess", na.rm=TRUE) + 
  xlab("Leverage hii")+ylab("Cook's Distance") + 
  ggtitle("Cook's dist vs Leverage hii/(1-hii) (2010 elections)") + 
  geom_abline(slope=seq(0,3,0.5), color="gray", linetype="dashed")

Cross Validation

predictions <- mod_2010 %>% predict(validate_data_2010)

data.frame( R2 = caret::R2(predictions, validate_data_2010$votos),
            RMSE = caret::RMSE(predictions, validate_data_2010$votos),
            MAE = caret::MAE(predictions, validate_data_2010$votos),
            ERR = caret::RMSE(predictions, validate_data_2010$votos)/
              mean(validate_data_2010$votos))

##          R2     RMSE      MAE      ERR
## 1 0.6298557 27228.86 14152.26 1.258257

Now let’s talk about the results taken from the validate data (more meaningful).

• We got a decent 0.63 R² and adjusted R² approximately. This means that this model explain approximately 63% of the response variable variability.
• The average difference between the observed known outcome values and the values predicted by the model (RMSE) was of approximately 27229.
  • Our model would miss the mark by approximately 27229 (RMSE), that is if candidate had one million votes we would predict 27229 more than we should (or less than we should).
• The average absolute difference between observed and predicted outcomes (MAE) was approximately 14152.26.
• The prediction error rate (ERR) was 1.258257.

predictions <- mod_2010 %>% predict(test_data_2010)

data.frame( R2 = caret::R2(predictions, test_data_2010$votos),
            RMSE = caret::RMSE(predictions, test_data_2010$votos),
            MAE = caret::MAE(predictions, test_data_2010$votos),
            ERR = caret::RMSE(predictions, test_data_2010$votos)/
              mean(test_data_2010$votos))

##          R2     RMSE      MAE      ERR
## 1 0.6008068 26425.65 13160.91 1.329999

Now let’s talk about the results taken from the test data (most meaningful).

• We got a decent 0.60 R² and adjusted R² approximately (notice the decrease). This means that this model explain approximately 60% of the response variable variability.

• The average difference between the observed known outcome values and the values predicted by the model (RMSE) was of approximately 26426.
  • Our model would miss the mark by approximately 26426 (RMSE), that is if candidate had one million votes we would predict 26426 more than we should (or less than we should).
• The average absolute difference between observed and predicted outcomes (MAE) was approximately 13160.91.

• The prediction error rate (ERR) was 1.329999.

The skimmed model fared quite similarly to the original model in terms of cross validation. Furthermore, we got rid of the overly influential outlier.

Train Data

set.seed(11) # We set the set for reason of reproducibility

dplyr::anti_join(scaled_data, 
                 train_data, 
                 by = 'id') -> intermediate_data

intermediate_data %>% 
  dplyr::sample_frac(.5) -> test_data

test_data <- one_hot_encoder(dataSet = test_data,
                           encoding = encoding,
                           drop = TRUE,
                           verbose = F)

cat("#### Test Data ",
    "\n##### Observations: ",nrow(test_data),
    "\n##### Variables: ",ncol(test_data))

Test Data

set.seed(11) # We set the set for reason of reproducibility

dplyr::anti_join(intermediate_data, 
                 test_data, 
                 by = 'id') -> validate_data

validate_data <- one_hot_encoder(dataSet = validate_data,
                           encoding = encoding,
                           drop = TRUE,
                           verbose = F)

rm(intermediate_data)

cat("#### Validate Data ",
    "\n##### Observations: ",nrow(validate_data),
    "\n##### Variables: ",ncol(validate_data))

Validate Data

mod <- lm(votos ~ sqrt.total_receita * sqrt.total_despesa + 
                  log.quantidade_fornecedores,
          data = train_data)

broom::glance(mod)

## # A tibble: 1 x 11
##   r.squared adj.r.squared  sigma statistic p.value    df  logLik    AIC
##       <dbl>         <dbl>  <dbl>     <dbl>   <dbl> <int>   <dbl>  <dbl>
## 1     0.517         0.517 32532.     1001.       0     5 -44139. 88290.
## # … with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>

Resorting to thumb rules regarding Cook’s Distance we’ll use \(D_i > 1\) as a cutoff for highly influential points/outliers

mod %>%
  ggplot(aes(.fitted, .resid)) + 
  geom_point() +
  stat_smooth(method="loess") + 
  geom_hline(col="red",
             yintercept=0,
             linetype="dashed") + 
  labs(y="Residuals",
       x="Fitted values",
       title="Residual vs Fitted Plot")

• There’s mild indication of a pattern in the residual, this is a bad sign for the analyzed model.

mod %>%
  ggplot(aes(sample=rstandard(.))) +
  stat_qq(na.rm = TRUE,
          shape=1,size=3) +      # open circles
  labs(title="Normal Q-Q",        # plot title
  x="Theoretical Quantiles",      # x-axis label
  y="Standardized Residuals") +   # y-axis label +
  geom_abline(color = "red",
              size = 0.8,
              linetype="dashed")  # dashed reference line

• Our residuals deviate considerably from a normal distribution.

mod %>%
  ggplot(aes(.fitted, 
             sqrt(abs(.stdresid)))) + 
  geom_point(na.rm=TRUE) + 
  stat_smooth(method="loess",
              na.rm = TRUE) +
  labs(title = "Scale-Location",
       x= "Fitted Value",
       y = expression(sqrt("|Standardized residuals|")))

• The residuals are not equally spread. Our model has violated the assumption of \(homoscedasticity\) (equal variance).

mod %>%
  ggplot(aes(.hat, .stdresid)) + 
  geom_point(aes(size=.cooksd), na.rm=TRUE) +
  stat_smooth(method="loess", na.rm=TRUE) +
  xlab("Leverage")+ylab("Standardized Residuals") + 
  ggtitle("Residual vs Leverage Plot") + 
  scale_size_continuous("Cook's Distance", range=c(1,5)) +    
  theme(legend.position="bottom")

• We can see no outliers that would drastically change the results of our model.

mod %>%
  ggplot(aes(.hat, .cooksd)) + 
  geom_point(na.rm=TRUE) + 
  stat_smooth(method="loess", na.rm=TRUE) + 
  xlab("Leverage hii")+ylab("Cook's Distance") + 
  ggtitle("Cook's dist vs Leverage hii/(1-hii)") + 
  geom_abline(slope=seq(0,3,0.5), color="gray", linetype="dashed")

• We can see no outliers that would drastically change the results of our model.