Regis A. Ely

Mercado de trabalho brasileiro pós-pandemia

Sat, 11 Jul 2020 00:00:00 +0000

Os efeitos da pandemia do COVID-19 e do isolamento social no mercado de trabalho brasileiro têm características peculiares. A maneira distinta como cada setor absorve este choque acaba gerando impactos heterogêneos no mercado de trabalho, e consequentemente os trabalhadores são afetados de maneira desigual.

Com o intuito de levantar informações sobre os impactos da pandemia para os diferentes grupos populacionais, o IBGE divulgou em de junho de 2020 os resultados da pesquisa PNAD COVID19. Esta pesquisa utiliza como base a amostra de domicílios da Pesquisa Nacional por Amostra de Domicílios Contínua (PNAD Contínua), sendo a amostra original obtida por um plano amostral conglomerado em dois estágios com estratificação das unidades primárias de amostragem (UPA).

Resumindo, a PNAD COVID19 é uma pesquisa com amostra complexa, e portanto, para se fazer generalizações sobre a população brasileira, devemos levar em conta o plano amostral e as ponderações. Maiores detalhes metodológicos sobre a amostragem da pesquisa PNAD COVID19 podem ser obtidos aqui.

Neste post, vamos utilizar esta pesquisa para responder algumas perguntas sobre como o mercado de trabalho brasileiro se comportou após a pandemia. As questões que vamos investigar são:

Quem pode fazer home office? Quais são as características socioeconômicas destes trabalhadores? Em quais Estados o trabalho remoto é mais comum?
Qual foi o efeito da pandemia no salário médio dos trabalhadores por tipo de vínculo empregatício? Os trabalhadores do setor privado foram mais afetados do que os funcionários públicos?
Quem recebe auxílio emergencial do governo? Este programa está alcançando pessoas de baixa renda? Em quais Estados as pessoas procuraram mais o auxílio?

Para responder essas perguntas vamos primeiro ler alguns pacotes no R:

library(tidyverse) ## Para manipulação de dados
library(srvyr) ## Para lidar com amostras complexas
library(readxl) ## Para ler dados do excel
library(viridis) ## Paleta de cores para gráficos

Carregando os dados da PNAD COVID19

Vamos primeiro fazer o download dos dados da pesquisa. A url que contém a base de dados é salva na variável pnad_url, e então fazemos o download e descompactamos o arquivo:

pnad_url <- paste0(
  "ftp://ftp.ibge.gov.br/Trabalho_e_Rendimento",
  "/Pesquisa_Nacional_por_Amostra_de_Domicilios_PNAD_COVID19",
  "/Microdados/PNAD_COVID_052020_20200701.zip"
)
download.file(pnad_url, "pnad_covid.zip")
unzip("pnad_covid.zip")

Após estes comandos, alguns arquivos serão baixados no seu diretório de trabalho. Um deles será o arquivo de dados em formato csv, e o outro será um arquivo de dicionário com a descrição das variáveis, em formato xls.

Agora vamos ler os dados na varíavel pnad.

pnad <- read_csv(
  "PNAD_COVID_052020.csv",
  col_types = cols(.default = "d")
)

Podemos sempre utilizar o dicionário para criar variáveis novas ou alterar o nome de algumas variáveis codificadas, como por exemplo, a variável UF. Vamos criar uma variável com o nome dos Estados para cada código da variável UF, e adicionar o nome dos Estados a base de dados original com o comando left_join:

estados <- read_excel(
  "Dicionario_PNAD_COVID.xls", 
  sheet = "dicionário pnad covid",
  skip = 4, n_max = 27
) %>%
  select(UF = ...5, estado = ...6)

pnad <- pnad %>%
  left_join(estados, by = "UF")

Agora devemos especificar o desenho amostral complexo da pesquisa. Para isso utilizaremos o pacote srvyr, que permite utilizar a sintaxe do pacote dplyr em dados amostrais complexos.

Para especificar o desenho da amostra da PNAD COVID19, é necessário identificar a unidade primária de amostragem (UPA) no argumento ids, o estrato no argumento strata, e os pesos dos domicílios no argumento weights. Essas variáveis podem ser obtidas no dicionário. Note que existem dois pesos, o V1031 e o V1032. O segundo é o peso pós-estratificação, que é o que utilizaremos. Se você utilizar o primeiro peso, deve realizar a estratificação manualmente através do comando postStratify.

pnad_design <- pnad %>%
  as_survey_design(
    ids = UPA,
    strata = Estrato,
    weights = V1032,
    nest = TRUE
  )

Agora que definimos o desenho amostral complexo da PNAD, vamos criar algumas variavéis auxiliares para a nossa análise a partir dos códigos descritos no dicionário. Podemos utilizar a sintaxe do pacote dplyr para criação das variáveis.

pnad_design <- pnad_design %>%
  mutate(
    one = 1,
    estado = fct_reorder(estado, desc(estado)),
    sexo = ifelse(A003 == 1, "Homem", "Mulher"),
    idade = case_when(
      A002 %in% 16:24 ~ "16-24",
      A002 %in% 25:34 ~ "25-34",
      A002 %in% 35:49 ~ "35-49",
      A002 %in% 50:64 ~ "50-64",
      A002 > 64 ~ "65+"
    ),
    cor = case_when(
      A004 == 1 ~ "Branca",
      A004 %in% c(2, 4) ~ "Preta ou Parda"
    ),
    escolaridade = factor(
      case_when(
        A005 %in% 1:2 ~ "Fundamental incompleto",
        A005 %in% 3:4 ~ "Fundamental completo",
        A005 %in% 5:6 ~ "Médio completo",
        A005 == 7 ~ "Superior completo",
        A005 == 8 ~ "Pós-graduação"
      ),
      levels = c(
        "Fundamental incompleto", "Fundamental completo",
        "Médio completo", "Superior completo", "Pós-graduação"
      )
    ),
    tipo_emprego = case_when(
      C007 == 2 ~ "Militar",
      C007 == 3 ~ "Policial ou bombeiro",
      C007 == 4 ~ "Setor privado",
      C007 == 5 ~ "Setor público",
      C007 == 6 ~ "Empregador",
      C007 == 7 ~ "Conta própria",
    ),
    tipo_emprego_curto = ifelse(
      tipo_emprego %in% c("Militar", "Policial ou bombeiro"),
      NA, tipo_emprego
    ),
    salario_usual = C01012,
    salario_maio = C011A12,
    home = ifelse(C013 == 1, "Home Office", "Presencial"),
    auxilio = ifelse(D0051 == 1, "Auxílio", "Sem auxílio"),
    faixa_renda = factor(
      case_when(
        C01012 < 1000 ~ "1000-",
        C01012 %in% c(1000:2999) ~ "1000-2999",
        C01012 %in% c(3000:4999) ~ "3000-4999",
        C01012 %in% c(5000:6999) ~ "5000-6999",
        C01012 %in% c(7000:9999) ~ "7000-9999",
        C01012 >= 10000 ~ "10000+"
      ),
      levels = c(
        "1000-", "1000-2999", "3000-4999",
        "5000-6999", "7000-9999", "10000+"
      )
    )
  )

Por fim, devemos conferir se o nosso desenho amostral está compatível com os dados reportados pelo IBGE. Vamos verificar o número de homens e mulheres na população brasileira e comparar com os resultados reportados na tabela do IBGE.

pnad_design %>%
  group_by(sexo) %>%
  summarise(Total = survey_total(vartype = "ci"))

## # A tibble: 2 x 4
##   sexo        Total  Total_low  Total_upp
##   <chr>       <dbl>      <dbl>      <dbl>
## 1 Homem  103090474. 101888068. 104292880.
## 2 Mulher 107778927. 106547976. 109009878.

Os valores de 103 milhões de homens e 107 milhões de mulheres na população brasileira conferem com os valores das linhas 9 e 10 da tabela do IBGE. Podemos seguir realizando nossa análise, sempre levando em consideração o plano amostral complexo.

Quem pode fazer home office?

Nem todo trabalho tem características que possibilitam os trabalhadores realizarem suas tarefas de casa. Alguns pessoas podem ter características que a fazem ser mais propensas a exercerem atividades em que o trabalho remoto é mais plausível. Quais são as características socioeconômicas destes trabalhadores?

Vamos primeiro olhar para os dados de home office divididos em grupos baseados no sexo e na cor dos indivíduos. Para isso, primeiro calculamos o total de indivíduos que estavam realizando trabalho remoto na semana anterior a pesquisa. Este dado pode ser obtido na variável C013. Depois obtemos o total de trabalhadores na variável C001, ou seja, indivíduos que realizaram algum tipo de trabalho na semana anterior a pesquisa. A razão destas duas variáveis corresponde a proporção de trabalhadores que realizaram trabalho remoto. Antes de fazermos este cálculo, iremos agrupar os indivíduos por sexo e cor.

home_sexo_cor <- pnad_design %>%
  group_by(sexo, cor) %>%
  summarise(
    home_office = survey_total(C013 == 1, na.rm = TRUE),
    trabalhadores = survey_total(C001 == 1, na.rm = TRUE)
  ) %>%
  mutate("Home Office (%)" = (home_office / trabalhadores) * 100) %>%
  drop_na()

Com os dados calculados, podemos agora plotar um gráfico de barras com o sexo dos indivíduos no eixo vertical e a cor no preenchimento das barras.

home_sexo_cor %>%
  ggplot(aes(fill = cor, y = `Home Office (%)`, x = sexo)) +
  geom_bar(position = "dodge", stat = "identity") +
  scale_fill_viridis(discrete = T) +
  theme_classic(base_size = 16) +
  labs(
    x = "", fill = "Cor",
    title = "Percentual de trabalhadores em home office"
  )

Podemos tirar duas conclusões com estes dados:

As mulheres realizam trabalho remoto com mais frequência do que os homens,
A proporção de pessoas da cor branca que realizam trabalho remoto é muito maior em relação as pessoas de cor preta ou parda.

Parte desta diferença talvez possa ser explicada por outras variáveis, como a escolaridade. Vamos agrupar os dados por escolaridade e cor, e então plotar o mesmo gráfico de antes.

home_edu_cor <- pnad_design %>%
  group_by(escolaridade, cor) %>%
  summarise(
    home_office = survey_total(C013 == 1, na.rm = TRUE),
    trabalhadores = survey_total(C001 == 1, na.rm = TRUE)
  ) %>%
  mutate("Home Office (%)" = (home_office / trabalhadores) * 100) %>%
  drop_na()

home_edu_cor %>%
  ggplot(aes(fill=escolaridade, y=`Home Office (%)`, x=cor)) +
  geom_bar(position="dodge", stat="identity") +
  scale_fill_viridis(discrete = T) +
  theme_classic(base_size = 16) +
  labs(
    x = "", fill = "Escolaridade",
    title = "Percentual de trabalhadores em home office"
  )

Embora a diferença entre pessoas da cor branca e pessoas da cor preta ou parda ainda exista, boa parte da variação parece ser explicada pela escolaridade. Pessoas com nível mais alto de escolaridade tendem a ter atividades profissionais mais suscetíveis ao trabalho remoto.

Este gráfico mostra um retrato impiedoso das políticas de isolamento social. Profissionais com menores níveis de escolaridade têm possibilidades baixíssimas de realizar trabalho remoto, de modo que estão mais sujeitos a demissão ou redução salarial.

De maneira semelhante, podemos olhar para grupos separados por faixa etária e sexo.

home_sexo_idade <- pnad_design %>%
  group_by(sexo, idade) %>%
  summarise(
    home_office = survey_total(C013 == 1, na.rm = TRUE),
    trabalhadores = survey_total(C001 == 1, na.rm = TRUE)
  ) %>%
  mutate("Home Office (%)" = (home_office / trabalhadores) * 100) %>%
  drop_na()

home_sexo_idade %>%
  ggplot(aes(fill=idade, y=`Home Office (%)`, x=sexo)) +
  geom_bar(position="dodge", stat="identity") +
  scale_fill_viridis(discrete = T) +
  theme_classic(base_size = 16) +
  labs(
    x = "", fill = "Faixa etária",
    title = "Percentual de trabalhadores em home office"
  )

Alguns padrões interessantes podem ser observados no gráfico acima:

Como visto anteriormente, os homens fazem menos trabalho remoto do que as mulheres, possivelmente por estarem em profissões que demandam mais presença física,
Jovens fazem menos trabalho remoto do que adultos e idosos, o que pode ser reflexo da falta de experiência profissional,
Homens idosos, com mais de 65 anos, fazem mais trabalho remoto do que homens de outras faixas etárias, entretanto, isso não é verdade para as mulheres. Uma possível explicação seria o fato de homens idosos alcançarem promoções em suas profissões com mais frequência do que mulheres idosas.

Outra possível variável que explica estas diferenças pode ser o Estado de residência do indivíduo. Vamos explorar quais as diferenças na realização de trabalho remoto entre os Estados.

home_uf <- pnad_design %>%
  group_by(estado) %>%
  summarise(
    home_office = survey_total(C013 == 1, na.rm = TRUE),
    trabalhadores = survey_total(C001 == 1, na.rm = TRUE)
  ) %>%
  mutate("Home Office (%)" = (home_office / trabalhadores) * 100) %>%
  drop_na()

home_uf %>%
  ggplot(aes(fill = estado, y = `Home Office (%)`, x = estado)) + 
  geom_bar(position = "dodge", stat = "identity") +
  geom_text(
    aes(
      label = paste0(round(`Home Office (%)`, 2), "%"),
      y = `Home Office (%)` + 1.5, size = 4
    )
  ) +
  coord_flip() +
  scale_fill_viridis(discrete = T) +
  theme_classic(base_size = 16) +
  theme(
    axis.line = element_blank(),
    axis.ticks = element_blank(),
    axis.text.x = element_blank(),
    legend.position = "none"
  ) +
  labs(
    x = "", y = "",
    title = "Percentual de trabalhadores em home office"
  )

Os três Estados em que os trabalhadores mais realizam trabalho remoto são o Distrito Federal, o Rio de Janeiro e São Paulo.

O Distrito Federal chama a atenção, pois lá existem muitos funcionários públicos. O tipo de vínculo empregatício pode ser uma variável relevante para explicar as diferenças observadas entre os grupos. Por isso vamos agrupar os dados por tipo de emprego e plotar um gráfico de barras com estas informações.

home_emprego <- pnad_design %>%
  group_by(tipo_emprego) %>%
  summarise(
    home_office = survey_total(C013 == 1, na.rm = TRUE),
    trabalhadores = survey_total(C001 == 1, na.rm = TRUE)
  ) %>%
  mutate("Home Office (%)" = (home_office / trabalhadores) * 100) %>%
  drop_na()

home_emprego %>%
  ggplot(aes(fill=tipo_emprego, y=`Home Office (%)`, x=tipo_emprego)) + 
  geom_bar(position="dodge", stat="identity") +
  geom_text(
    aes(
      label = paste0(round(`Home Office (%)`, 2), "%"),
      y = `Home Office (%)` + 2, size = 5
    )
  ) +
  coord_flip() +
  scale_fill_viridis(discrete = T) +
  theme_classic(base_size = 16) +
  theme(
    axis.line.y = element_blank(),
    axis.ticks.y = element_blank(),
    legend.position = "none"
  ) +
  labs(
    x = "",
    title = "Percentual de trabalhadores em home office"
  )

Aqui um outro retrato particular do isolamento social surge. Trabalhadores da iniciativa pública são os que mais realizam trabalho remoto. A probabilidade de um trabalhador do setor público realizar trabalho remoto é mais do que o dobro da probabilidade de um trabalhador do setor privado realizar trabalho remoto.

Por outro lado, há um percentual muito baixo de policiais, militares e trabalhadores conta própria que podem realizar trabalho remoto. Estes trabalhadores acabam tendo que decidir entre continuar exercendo suas atividades de forma presencial ou sofrer as consequências em termos de redução salarial ou demissão. Será que podemos observar algum padrão nas variações salariais pré e pós pandemia entre estes grupos?

Quem perde mais renda com a pandemia?

Como vimos, alguns trabalhadores têm maiores possibilidades de realizar trabalho remoto. Isso pode criar uma margem de segurança para estes trabalhadores, uma vez que eles serão menos suscetíveis a demissões ou reduções salariais.

Podemos observar a variação de salário pré e pós pandemia para trabalhadores com diferentes tipos de vínculos. Isso é possível pois na PNAD COVID19 há duas perguntas relativas ao salário do indivíduo. A primeira pede sobre o salário que ele recebeu na semana de referência, e a segunda pede sobre o salário usual que ele costumava receber. Para obter maiores detalhes veja o questionário.

Vamos construir um gráfico em que plotamos o salário antes e depois da pandemia para diversos tipos de emprego. O código para gerar o gráfico vai ser um pouco mais longo, pois faremos algumas anotações com a variação percentual do salário no gráfico.

covid_salario <- pnad_design %>%
  group_by(tipo_emprego_curto) %>%
  summarise(
    salario_antes = survey_mean(salario_usual, na.rm = TRUE),
    salario_depois = survey_mean(salario_maio, na.rm = TRUE)
  ) %>%
  drop_na() %>%
  mutate(Variacao = (salario_depois / salario_antes) - 1)

covid_salario %>%
  ggplot() +
  geom_segment(
    aes(
      x = 1, xend = 2, y = salario_antes,
      yend = salario_depois, col = tipo_emprego_curto
    ),
    size = 0.75
  ) + 
  geom_vline(xintercept = 1, linetype = "dashed", size = .1) + 
  geom_vline(xintercept = 2, linetype = "dashed", size = .1) +
  geom_text(
    aes(
      label = round(salario_antes, 0), y = salario_antes,
      x = rep(1, length(salario_antes))
    ),
    hjust = 1.1, size = 5
  ) +
  geom_text(
    aes(
      label = round(salario_depois, 0),
      y = salario_depois,
      x = rep(2, length(salario_depois))
    ),
    hjust=-0.1, size=5
  ) + 
  geom_text(
    aes(
      label = "Antes", x = 1,
      y = 1.1*(max(salario_antes, salario_depois))
    ),
    hjust = 1.2, size = 6
  ) +
  geom_text(
    aes(
      label = "Depois", x = 2,
      y = 1.1*(max(salario_antes, salario_depois))
    ),
    hjust = -0.1, size = 6
  ) +
  geom_text(
    aes(
      label = paste0(round(Variacao*100, 2), "%"),
      y = (salario_antes + salario_depois)/2 - 300,
      x = rep(1.5, length(salario_depois)),
      col = tipo_emprego_curto
    ),
    size = 5,
    show.legend = FALSE
  ) +
  xlim(.8, 2.2) +
  theme_classic(base_size = 16) +
  theme(
    axis.ticks = element_blank(),
    axis.text = element_blank(),
    axis.line = element_blank(),
    plot.title = element_text(hjust = 0.5),
    legend.position = "bottom"
  ) +
  labs(
    x = "", y = "", color = "",
    title = "Salário médio pré e pós isolamento social no Brasil",
    caption = "Fonte dos dados: PNAD COVID19"
  )

Observamos que os trabalhadores conta própria foram de fato os mais afetados pelo isolamento social, uma vez que a renda média deste grupo caiu mais de 40%. Em segundo lugar vem os empregadores, com uma queda de cerca de 30% em sua renda média. Parece que o único grupo que foi pouco afetado pelo isolamento social em termos de salário foram os funcionários públicos. Agora podemos entender o reflexo dos altos níveis de trabalho remoto no Distrito Federal em termos de salário.

Quem recebeu auxílio emergencial?

Como forma de atenuar os efeitos da crise econômica causada pela pandemia, o Governo Federal instituiu o Auxílio Emergencial, um benefício financeiro destinado aos trabalhadores informais, microempreendedores individuais, autônomos e desempregados.

O benefício do auxílio emergencial corresponde ao valor de R$ 600,00, que é pago por três meses para até duas pessoas da mesma família. Para ter acesso ao auxílio, a pessoa deve cumprir os seguintes requisitos:

Ser maior de 18 anos ou mãe adolescente,
Não ter emprego formal,
Não receber benefício previdenciário ou assistencial (como seguro-desemprego),
Ter renda familiar mensal per capita de até meio salário mínimo (R$ 522,50), ou renda familiar mensal total de até três salários mínimos (R$ 3.135,00),
Não ter recebido rendimento tributáveis acima de R$ 28.559,70 durante o ano de 2018,
Estar desempregado ou exercendo atividades de microempreendedor individual ou trabalho informal

Apesar de todos estes critérios, houve inúmeros relatos de casos em que pessoas solicitaram o auxílio mesmo não se enquadrando nos critérios para recebê-lo. Da mesma forma, algumas pessoas que necessitavam do auxílio acabaram não recebendo por problemas cadastrais ou falta de acesso aos bancos e aplicativos.

Com os dados da PNAD COVID19 podemos ter alguma ideia sobre a focalização destes benefícios, uma vez que os entrevistados respondem se receberam ou não o auxílio, além de reportarem a renda no caso em que exerceram algum tipo de atividade, mesmo que informal.

Vamos olhar para a proporção de indivíduos que receberam auxílio por faixa de renda. Neste caso, estamos olhando apenas para os beneficiários que exerceram algum tipo de trabalho na semana de referência.

auxilio_renda <- pnad_design %>%
  group_by(faixa_renda) %>%
  summarise(
    auxilio = survey_total(D0051 == 1, na.rm = TRUE),
    total = survey_total(one, na.rm = TRUE)
  ) %>%
  mutate("Auxílio Emergencial (%)" = (auxilio / total) * 100) %>%
  drop_na()

auxilio_renda %>%
  ggplot(
    aes(
      fill = faixa_renda,
      y = `Auxílio Emergencial (%)`,
      x = faixa_renda
    )
  ) +
  geom_bar(position = "dodge", stat = "identity") +
  geom_text(
    aes(
      label = paste0(round(`Auxílio Emergencial (%)`, 2), "%"),
      y = `Auxílio Emergencial (%)` + 6
    ),
    size = 6
  ) +
  coord_flip() +
  scale_fill_viridis(discrete = T) +
  theme_classic(base_size = 16) +
  theme(
    axis.line.y = element_blank(),
    axis.ticks.y = element_blank()
  ) +
  labs(
    x = "", fill = "Faixa de renda",
    title = "Percentual de trabalhadores que receberam auxílio emergencial"
  )

Como esperado, o percentual de beneficiários nos estratos inferiores de renda é significativamente maior, correspondendo a cerca de 2/3 da amostra. Note que, além da renda, há uma série de outros critérios que os indivíduos devem respeitar para receber o benefício, logo, não é esperado que todos aqueles que reportem renda baixa recebam o benefício. Mas, por outro lado, deve haver uma alta correlação entre receber auxílio e ter renda baixa caso o programa esteja bem focalizado.

Podemos olhar também para o percentual de pessoas em cada Estado que receberam o auxílio emergencial, considerando agora não só os trabalhadores, mas toda a população do Estado.

auxilio_uf <- pnad_design %>%
  group_by(estado) %>%
  summarise(
    auxilio = survey_total(D0051 == 1, na.rm = TRUE),
    total = survey_total(one, na.rm = TRUE)
  ) %>%
  mutate("Auxílio Emergencial (%)" = (auxilio / total) * 100) %>%
  drop_na()

auxilio_uf %>%
  ggplot(
    aes(fill = estado, y = `Auxílio Emergencial (%)`, x = estado)
  ) +
  geom_bar(position = "dodge", stat = "identity") +
  geom_text(
    aes(
      label = paste0(round(`Auxílio Emergencial (%)`, 2), "%"),
      y = `Auxílio Emergencial (%)` + 3
    ),
    size = 4
  ) +
  coord_flip() +
  scale_fill_viridis(discrete = T) +
  theme_classic(base_size = 16) +
  theme(
    axis.line = element_blank(),
    axis.ticks = element_blank(),
    axis.text.x = element_blank(),
    legend.position = "none"
  ) +
  labs(
    x = "",
    y = "",
    title = "Percentual de trabalhadores que receberam auxílio emergencial"
  )

Os números são surpreendentemente grandes. De acordo com os dados do IBGE, o alcance do auxílio emergencial chegou a mais de 60% das pessoas em alguns Estados, como no Alagoas, Amapá, Amazonas, Bahia, Ceará, Maranhão, Pará e Piauí. Por outro lado, os Estados com o menor número de beneficiários são Santa Catarina, Rio Grande do Sul e Distrito Federal.

Acabamos por aqui! Ainda há bastante coisa para explorar nestes dados, mas acredito que este post pode ser útil para quem queira utilizar a PNAD COVID19 em suas análises no R.

Mercados financeiros e a COVID-19: um comparativo das respostas à crise

Sun, 31 May 2020 00:00:00 +0000

Os efeitos de crises econômicas costumam ser heterogêneos entre países com características institucionais distintas. Isto não deve ser exceção para a crise atual gerada pela pandemia do COVID-19. O Brasil parece ter sido um dos países mais afetados pela depreciação do câmbio e pela desvalorização do mercado acionário. As razões disso ainda não são claras, mas talvez duas hipóteses podem ser levantadas:

A resposta da política monetária foi muito agressiva, ocasionando uma saída de capital maior em relação a outros países;
A depreciação do câmbio e a desvalorização no mercado acionário é reflexo de expectativas relativas à crise política e/ou à situação fiscal das contas públicas.

O ponto 1 parece ser relativamente fácil de verificarmos comparando a resposta da política monetária no Brasil em relação a outros países. Já o ponto 2 parece ser uma hipótese teórica razoável caso 1 não seja válido, uma vez que é natural pensar que países mais endividados e com situação política mais agravada sofram de maneira mais intensa durante esta crise.

Podemos utilizar o R para inferir sobre a validade da hipótese 1. Vamos verificar quais foram as consequências desta crise no mercado acionário e cambial para diversos países, bem como analisar a resposta da política monetária.

Primeiro vamos carregar alguns pacotes que serão necessários na análise. Para replicar os resultados é necessário instalar estes pacotes no R.

library(tidyverse) ## Para manipulação de dados
library(lubridate) ## Para lidar com datas no R
library(tidyquant) ## Para baixar dados dos mercados acionários
library(Quandl) ## Para baixar dados das taxas de câmbio
library(OECD) ## Para baixar dados das taxas de juros
library(slider) ## Para criar médias móveis de séries de tempo

Efeito da crise nos mercados acionários

Com o pacote tidyquant podemos baixar os dados dos principais índices do mercado acionário disponíveis no Yahoo! Finance. Uma lista completa dos índices e códigos desta base de dados pode ser obtida aqui. Vamos primeiro criar um tibble com os códigos e nomes dos índices que utilizaremos e depois baixar os dados de janeiro de 2020 a maio de 2020.

indexes <- tibble(
  symbol = c(
    "^BVSP", "^GSPC", "^DJI", "^IXIC", "^FTSE", "^GDAXI", "^FCHI",
    "^STOXX50E", "IMOEX.ME", "^N225", "^HSI", "000001.SS", "^STI",
    "^AXJO", "^BSESN", "^JKSE", "^KLSE", "^NZ50", "^KS11", "^TWII",
    "^GSPTSE", "^MXX", "^MERV", "^TA125.TA", "^JN0U.JO"
  ),
  exchange = c(
    "Ibovespa", "S&P 500", "Dow Jones", "Nasdaq", "FTSE 100", "DAX",
    "CAC 40", "Euro Stoxx 50", "MOEX Russia", "Nikkei 225",
    "Hang Seng Index", "SSE Index", "STI Index", "S&P/ASX 200",
    "S&P BSE SENSEX", "Jakarta Index", "FBM KLCI", "S&P/NZX 50",
    "KOSPI Index", "TSEC Index", "S&P/TSX", "IPC Mexico", "Merval",
    "TA-125", "South Africa Top 40"
  )
)
  
ind_quotes <- tq_get(
  indexes$symbol, get  = "stock.prices", from = "2020-01-01", to = "2020-05-29"
)

Podemos adicionar os nomes das bolsas de valores à variável ind_quotes com o comando left_join e então comparar a evolução dos índices calculando o retorno acumulado a partir de janeiro de 2020. Para suavizar os dados, vamos tirar uma média móvel de 5 dias desse retorno acumulado. É importante removermos os dados faltantes dos valores ajustados dos índices e agruparmos as observações por índice antes de fazermos este cálculo.

ind_ret <- ind_quotes %>%
  left_join(indexes, by = "symbol") %>%
  drop_na(adjusted) %>%
  group_by(symbol) %>%
  mutate(cumret = adjusted / first(adjusted) - 1) %>%
  mutate(MA = slide_dbl(cumret, mean, .before = 5, .complete = TRUE)) %>%
  ungroup()

Agora plotamos a média móvel de 5 dias do retorno acumulado de todos os índices para compararmos os países, destacando o Ibovespa no gráfico.

ind_ret %>%
  drop_na(MA) %>%
  ggplot(aes(x = date, y = MA, color = exchange, size = exchange)) +
  geom_line() +
  scale_size_manual(values = c(rep(0.5, 7), 1.5, rep(0.5, dim(indexes)[1]-8))) +
  theme_bw(base_size = 18) +
  theme(
    legend.justification = c(0, 0),
    legend.position = c(0, 0),
    legend.background = element_rect("transparent"),
    legend.key = element_rect("transparent")
  ) +
  labs(
    x = "", y = "Cumulative percent return",
    color = "Stock Exchanges",
    size = "Stock Exchanges",
    title = "5-day Moving Average of Cumulative Percent Returns of Stock Exchanges in 2020",
    caption = "Source: Yahoo! Finance"
  )

Dentre as 26 bolsas analisadas, a Ibovespa foi a que teve o pior retorno acumulado durante o ano de 2020. Talvez esse resultado negativo também esteja associado as movimentações no mercado cambial.

Efeito da crise nos mercados cambiais

Vamos tentar fazer um gráfico semelhante para os mercados cambiais. Para isso utilizaremos a base de dados do banco central americano, Federal Reserve Economic Data (FRED). Os dados serão acessados através da plataforma Quandl. Para você replicar este estudo, deve fazer um login no site e obter um código de acesso à API do Quandl. Com o código em mãos, basta rodar o seguinte comando no R:

Quandl.api_key("your_api_here")

Para carregar os dados das taxas de câmbio de vários países em relação ao dólar, vamos primeiro criar um tibble com os códigos e nomes das moedas e em seguida baixar os dados com o comando Quandl. Uma lista detalhada das taxas de câmbio disponíveis para download no Quandl pode ser encontrada aqui.

currs <- tibble(
  code = c("DEXUSAL", "DEXBZUS", "DEXUSUK", "DEXCAUS", "DEXCHUS", "DEXDNUS",
           "DEXUSEU", "DEXHKUS", "DEXINUS", "DEXJPUS", "DEXMAUS", "DEXMXUS",
           "DEXTAUS", "DEXUSNZ", "DEXNOUS", "DEXSIUS", "DEXSFUS", "DEXKOUS",
           "DEXSLUS", "DEXSDUS", "DEXSZUS", "DEXTHUS"),
  Currency = c("Australian Dollar (AUD)", "Brazilian Real (BRL)",
               "British Pound (GBP)", "Canadian Dollar (CAD)",
               "Chinese Yuan (CNY)", "Denish Krone (DKK)", "Euro (EUR)",
               "Hong Kong Dollar (HKD)", "Indian Rupee (INR)",
               "Japanese Yen (JPY)", "Malaysian Ringgit (MYR)",
               "Mexican Peso (MXN)", "New Taiwan Dollar (TWD)",
               "New Zealand Dollar (NZD)", "Norwegian Krone(NOK)",
               "Singapore Dollar (SGD)", "South African Rand(ZAR)",
               "South Korean Won (KRW)", "Sri Lankan Rupee(LKR)",
               "Swedish Krona (SEK)", "Swiss Franc (CHF)", "Thai Baht (THB)")
)

fx_rates <- Quandl(
  paste0("FRED/", currs$code), type = "raw", order = "asc",
  start_date = "2020-01-01", end_date = "2020-05-29"
)
colnames(fx_rates) <- c("date", currs$code)

É importante observar que algumas moedas têm relação inversa com o dólar. Mais precisamente, são quatro moedas na base do FRED que devem ser corrigidas: Australian Dollar (AUD), British Pound (GBP), Euro (EUR) e New Zealand Dollar (NZD).

Vamos corrigir estes detalhes, adicionar o nome completo das moedas, calcular a variação acumulada a partir de janeiro de 2020 e tirar uma média móvel de 5 dias dessa variação. Tudo em alguns simples comandos no R:

inverted <- c("DEXUSAL", "DEXUSUK", "DEXUSEU", "DEXUSNZ")
fx_rates <- fx_rates %>%
  pivot_longer(-date, names_to = "code", values_to = "rate") %>%
  left_join(currs, by = "code") %>%
  mutate(rate = if_else(code %in% inverted, 1/rate, rate)) %>%
  drop_na() %>%
  group_by(code) %>%
  mutate(cumrate = (rate / first(rate)) - 1) %>%
  mutate(MA = slide_dbl(cumrate, mean, .before = 5, .complete = TRUE)) %>%
  ungroup()

Agora vamos fazer um gráfico semelhante ao dos mercados acionários, destacando o Brasil.

fx_rates %>%
  drop_na(MA) %>%
  ggplot(aes(x = date, y = MA, color = Currency, size = Currency)) +
  geom_line() +
  scale_size_manual(values = c(0.5, 1.5, rep(0.5, dim(currs)[1]-2))) +
  theme_bw(base_size = 18) +
  theme(
    legend.justification = c(0, 1),
    legend.position = c(0, 1),
    legend.background = element_rect("transparent"),
    legend.key = element_rect("transparent")
  ) +
  labs(
    x = "", y = "Cumulative percent change",
    title = "5-day Moving Average of Cumulative Percent Change of Exchange Rates in 2020",
    caption = "Source: Federal Reserve Economic Data (FRED)"
  )

Entre as taxas de câmbio disponíveis na base de dados do FRED, o Brasil teve a maior depreciação da moeda durante o ano de 2020. Os dados até aqui comprovam que o Brasil foi provavelmente o país mais afetado em termos do mercado acionário e cambial. Ambos os mercados refletem expectativas dos agentes econômicos. Agora resta verificarmos se a hipótese 1 faz sentido, ou seja, será que as expectativas dos agentes foram afetadas negativamente em resposta a uma política monetária muito agressiva por parte do Banco Central do Brasil durante a crise?

Respostas da política monetária ao COVID-19

Para verificarmos como os Bancos Centrais atuaram durante a crise, vamos baixar os dados de taxa de juros da OECD Main Economic Indicators (MEI). Podemos obter os dados com o pacote OECD. Primeiro verificamos a estrutura dos dados através da função get_data_structure.

info_oecd <- get_data_structure("MEI_FIN")
info_oecd$VAR_DESC

##                 id        description
## 1          SUBJECT            Subject
## 2         LOCATION            Country
## 3        FREQUENCY          Frequency
## 4             TIME               Time
## 5        OBS_VALUE  Observation Value
## 6      TIME_FORMAT        Time Format
## 7       OBS_STATUS Observation Status
## 8             UNIT               Unit
## 9        POWERCODE    Unit multiplier
## 10 REFERENCEPERIOD   Reference period

As variáveis disponíveis estão descritas em SUBJECT. Vamos utilizar a variável Immediate interest rates (per cent per annum), que reflete as mudanças de curtíssimo prazo que ocorreram na definição da taxa de juros. Esta variável tem frequência mensal, reportando a média da taxa de juros relativa a todos os dias do mês, sendo que a última atualização é referente ao mês de abril, não contendo as últimas mudanças que ocorreram na taxa de juros durante o mês de maio.

É importante ressaltar que, no início de maio, ocorreu a 230º reunião do Copom, que decidiu por reduzir a taxa Selic para 3,00% ao ano, adicionando um corte de 0,75 pontos percentuais. Para não precisarmos esperar pela atualização da base de dados por parte da OCDE, podemos adicionar essa informação manualmente. Entretanto, outros países também podem ter reduzido suas taxas de juros. Para manter a comparação razoável, vamos utilizar os dados referentes a abril mesmo. Posteriormente é possível atualizar os dados com as novas informações.

tibble(info_oecd$SUBJECT)

## # A tibble: 12 x 2
##    id       label                                                               
##    <chr>    <chr>                                                               
##  1 MANM     Narrow Money (M1) Index, SA                                         
##  2 IRLT     Long-term interest rates, Per cent per annum                        
##  3 IR       Interest Rates                                                      
##  4 CCUS     Currency exchange rates, monthly average                            
##  5 IR3TIB   Short-term interest rates, Per cent per annum                       
##  6 MABM     Broad Money (M3) Index, SA                                          
##  7 CCRETT01 Relative consumer price indices                                     
##  8 IRSTCI   Immediate interest rates, Call Money, Interbank Rate, Per cent per …
##  9 MA       Monetary Aggregates                                                 
## 10 CCRETT02 Relative unit labour costs                                          
## 11 SP       Share Prices, Index                                                 
## 12 CC       Exchange Rates

Os países disponíveis na base de dados da OCDE podem ser visualizados em LOCATION.

tibble(info_oecd$LOCATION)

## # A tibble: 51 x 2
##    id    label         
##    <chr> <chr>         
##  1 AUS   Australia     
##  2 AUT   Austria       
##  3 BEL   Belgium       
##  4 CAN   Canada        
##  5 CHL   Chile         
##  6 COL   Colombia      
##  7 CZE   Czech Republic
##  8 DNK   Denmark       
##  9 EST   Estonia       
## 10 FIN   Finland       
## # … with 41 more rows

Vamos salvar o código e o nome de todos os países em um tibble para fazermos o download dos dados.

intrates <- info_oecd$LOCATION %>%
  rename(code = id, Country = label)

Agora utilizamos o comando get_dataset para baixar todos os dados, filtrando pelo código das séries que desejamos (IRSTCI), pelos países disponíveis (intrates$code), e selecionando a frequência mensal (M). Aproveitamos para renomear as variáveis, definir uma variável do tipo data, selecionar as colunas relevantes e adicionar o nome completo dos países.

interest_rates <- get_dataset(
  "MEI_FIN",
  filter = list("IRSTCI", intrates$code, "M")
) %>%
  rename(code = LOCATION, date = obsTime, rate = obsValue) %>%
  mutate(date = ymd(paste0(date, "-01"))) %>%
  select(date, code, rate) %>%
  left_join(intrates, by = "code")

Na variável interest_rates está todo o histórico das taxas de juros para um conjunto de 31 países, em formato de painel. Para nós, o interessante é apenas a variação na taxa de juros que ocorreu após a crise. Por isso vamos criar uma variável que contém as taxas de juros antes da crise, em fevereiro de 2020, e após a crise, em abril de 2020. Também removemos os países que não possuem dados para algum destes dois meses e os ordenamos pelo tamanho da diferença entre essas duas taxas.

int_changes <- interest_rates %>%
  filter(date %in% c(ymd("2020-02-01"), ymd("2020-04-01"))) %>%
  pivot_wider(names_from = "date", values_from = rate) %>%
  mutate(before = `2020-02-01`, after = `2020-04-01`, diff = after - before) %>%
  drop_na() %>%
  arrange(desc(diff)) %>%
  select(Country, before, after)

Com a variável int_changes pronta, podemos plotar um gráfico para descrever as mudanças que ocorreram nas taxas de juros antes e depois da crise para diversos países. Os países estão ordenados pelo maior corte de juros em pontos percentuais.

ggplot(
  int_changes %>%
  mutate(Country = factor(Country, levels = int_changes$Country)),
  aes(x = before, xend = after, y = Country, color = c("Feb 2020", "Apr 2020"))
) + 
  geom_segment(
    aes(x = before, xend = after, y = Country, yend = Country),
    color = "grey", size = 1.5
  ) +
  geom_point(aes(x = before, y = Country, color = "Apr 2020"), size = 6) +
  geom_point(aes(x = after, y = Country, color = "Feb 2020"), size = 6) +
  geom_text(
    aes(
      x = before, label = format(round(before, 2), nsmall = 2),
      hjust = -0.5 + if_else(sign(before - after) > 0, 0, 2)
    ), color = "black", size = 5
  ) +
  geom_text(
    aes(
      x = after, label = format(round(after, 2), nsmall = 2),
      hjust = 1.5 + if_else(sign(before - after) > 0, 0, -2)
    ), color = "black", size = 5
  ) +
  scale_x_continuous(limits = c(-1.5, 7), breaks = -1:7) +
  scale_color_manual(
    name = element_blank(),
    labels = c("Feb 2020", "Apr 2020"),
    values = c("#33B31A80", "#B3331A80")
  ) +
  theme_bw(base_size = 18) +
  theme(legend.position = "bottom", panel.grid.minor = element_blank()) +
  labs(
    x = NULL, y = NULL, 
    title = "Interest rate changes in response to COVID-19",
    subtitle = "Monthly average of interest rates (per cent per annum)", 
    caption = "Source: OECD - Main Economic Indicators"
  )

O Brasil está perto da mediana dos países, ou seja, parece que a resposta do Banco Central do Brasil não foi tão agressiva. Os países com o maior corte em pontos percentuais são a África do Sul e os Estados Unidos.

Como a magnitude das taxas se diferenciam, podemos calcular o tamanho do corte dos juros em termos percentuais para cada país e verificar se o Brasil ainda se encontra perto da mediana dos países. Nos comandos abaixo calculamos este percentual, deixamos apenas os países que tiveram cortes na taxa de juros e então plotamos um gráfico de barras ordenando os países pelo tamanho do corte em termos percentuais.

int_changes %>%
  mutate(percent = (after / before - 1) * 100) %>%
  filter(percent < -0.5) %>%
  ggplot(aes(y = reorder(Country, -percent), x = -percent)) +
  geom_bar(stat = "identity", fill = "#2297E6") +
  theme_bw(base_size = 18) +
  theme(legend.position = "none") +
  labs(
    x = "Negative Percent Change", y = NULL, 
    title = "Negative percent changes in interest rates after COVID-19",
    subtitle = "Monthly average of interest rates from Feb 2020 to Apr 2020", 
    caption = "Source: OECD - Main Economic Indicators"
  )

Agora os Estados Unidos aparecem no topo, como o país que mais reduziu juros em termos percentuais. O Brasil se encontra no final, reafirmando a rejeição da nossa hipótese 1, ou seja, a política de juros parece não ter sido agressiva após a crise.

Entretanto, é importante salientar que o Brasil já estava reduzindo sua taxa de juros consistentemente ao longo dos anos. Com isso, a crise pode ter intensificado a saída de capital estrangeiro que já estava naturalmente acontecendo. No gráfico abaixo plotamos o histórico da taxa de juros no Brasil ao longo dos últimos 20 anos.

interest_rates %>%
  filter(Country == "Brazil" & date >= "2000-01-01") %>%
  ggplot(aes(x = date, y = rate)) +
  geom_line() +
  theme_bw(base_size = 18) +
  labs(
    x = NULL, y = "Interest rate", 
    title = "Interest rate in Brazil since 2000",
    subtitle = "Monthly average of interest rates (per cent per annum)", 
    caption = "Source: OECD - Main Economic Indicators"
  )

Para finalizar, podemos concluir que a resposta da política monetária no Brasil após a crise parece não ter sido desproporcional. Entretanto, a tendência de queda nos juros, o aumento do grau de incerteza dos agentes econômicos, a instabilidade política e institucional, e a situação fiscal do país, podem ser algumas das razões que explicam o fato de o mercado acionário e cambial brasileiro estarem entre os mais afetados durante a pandemia da COVID-19.

O tradeoff entre viés e variância em três gráficos

Thu, 25 Aug 2016 13:00:00 +0000

Ao fazer previsões devemos separar a nossa amostra em uma parte em que estimaremos nosso modelo (train set) e outra parte em que avaliaremos a qualidade da previsão (test set). Quando se trata de escolher o modelo, parâmetros e variáveis a serem utilizadas, nos deparamos com as seguintes opções:

Utilizar um modelo complexo que é capaz de reduzir consideravelmente o erro de previsão no train set, mas ao mesmo tempo não é tão generalizável a ponto de apresentar um bom resultado no test set. Nesse caso estamos optando por estimar um modelo com viés baixo e variância alta. Ou seja, no train set, o modelo irá ter um erro de previsão baixo, mas quando avaliamos o modelo em um novo conjunto de dados (test set), o erro sobe consideravelmente, e por isso dizemos que sua variância é alta. Este é o típico caso de overfitting.
Utilizar um modelo simples que é bem generalizável, mas não reduz consideravelmente o erro de previsão no train set. Nesse caso estamos optando por um modelo com viés mais alto, mas variância baixa. Assim, iremos permitir um erro de previsão maior no train set de modo a obter um erro de previsão semelhante (com pouca variância) no test set. Esse é o típico caso de underfitting.

Matematicamente, o erro de previsão de um modelo pode ser dado por:

\[E[(y-\hat{f}(x))^2] = Bias[\hat{f}(x)]^2 + Var[\hat{f}(x)] + \sigma^2,\]

onde,

\[Bias[\hat{f}(x)] = E[\hat{f}(x) - f(x)],\]

\[Var[\hat{f}(x)] = E[\hat{f}(x)^2] - E[\hat{f}(x)]^2.\]

Assim, a nossa tarefa é escolher a f(x), sendo que tanto o viés quanto a variância aumenta o erro de previsão. Obviamente a escolha entre 1 e 2 é um tradeoff, e o ideal é permanecermos em um meio termo entre um modelo complexo e bem generalizável. Nesse post faremos um exercício de simulação no R e construiremos três gráficos para entender melhor este tradeoff. Para a construção destes gráficos também estimaremos vários modelos de previsão no R. A primeira etapa é carregar os pacotes necessários (instale-os com install.packages("nomedopacote") caso não os tenha em seu sistema).

library(Metrics) # RMSE function
library(rpart) # CART
library(FNN) # K-nearest neighbour regression
library(e1071) # Support Vector Regression
library(fields) # Thin Plate Spline
library(randomForest) # Random forest
library(xgboost) # Extreme gradient boosting trees

Uma vez instalados os pacotes com os modelos que utilizaremos, vamos simular duas variáveis (x e y) com o objetivo de utilizar a variável x para prever y. Iremos criar uma variável x com variabilidade suficiente e bem espaçada para facilitar a visualização dos gráficos, bem como supor uma relação cúbica entre x e y, adicionando ruídos nessa relação.

# Gerando os dados (relação cúbica entre x e y)
set.seed(123)
x <- seq(-10, 10, length.out=50)
y <- 2*x - 0.5*x^2 + x^3 + rnorm(50, 0, 100)

O tradeoff entre viés e variância (Underfitting e Overfitting)

O primeiro gráfico que construiremos é este:

Um dos modelos mais simples que podemos estimar é uma regressão linear através de mínimos quadráticos ordinários, que sabemos que é o melhor estimador linear não viesado. Entretanto estimadores lineares em geral possuem alto viés, pois se distanciam bastante das observações da amostra. A regressão linear será o nosso caso extremo para o item 2 acima, ou seja, um modelo muito simples, mas que pode ser generalizável. Assim, o erro de previsão será alto no train set, e será também alto, mas semelhante, no test set. Este é o típico caso de viés alto e variância baixa, ou underfitting.

Podemos também pensar num modelo bem mais complexo, que passe por todos os pontos do train set, ou seja, uma interpolação. Esse modelo pode ser obtido através de um spline cúbico, e será o caso extremo do item 1 acima. Obviamente, o erro de previsão será zero no train set, mas quando considerarmos os dados novos do test set o erro de previsão será bem mais alto. Este é o típico caso de viés baixo e variância alta, ou overfitting.

Bom, para gerar o gráfico acima, começamos plotando um gráfico com as variáveis x e y e o valor previsto para estes dois modelos.

# Plot data
plot(x, y, xlim = c(min(x), max(x)), ylim = c(min(y), max(y)), pch=16,
     cex = 0.5, ylab = "Response", xlab = "Predictor",
     main = "Bias-variance tradeoff")

# Linear regression
reg <- lm(y ~ x)
summary(reg)
abline(reg, col = "orange", lty = 6)

# Interpolating cubic spline 
lines(spline(x, y), col = "purple", lty = 1)

Agora vamos adicionar novos pontos em vermelho gerados pelo mesmo processo, interpretando-os como se fosse o nosso test set. Com isso veremos como a interpolação cúbica se distancia desses novos pontos, fazendo com que o erro de previsão seja grande nesse test set.

# Plot new test set
set.seed(321)
y_new <- 2*x - 0.5*x^2 + x^3 + rnorm(50, 0, 100)
points(x, y_new, col = "red", pch = "*")

Gostaríamos de um modelo que estivesse no meio termo do tradeoff viés-variância. Para isso utilizaremos um support vector regression com kernel polinomial. Também incluimos o modelo correto através da função curve (note que em uma aplicação real nunca saberemos este modelo correto). Comparando o nosso modelo com o função geradora dos dados (na curva preta), vemos que ele faz um excelente trabalho.

# Support vector regression com kernel polynomial
svmreg <- svm(y ~ x, kernel = "polynomial")
svmpred <- predict(svmreg, x)
lines(x, svmpred, col = "royalblue", lty = 5)

# Modelo correto
curve(2*x - 0.5*x^2 + x^3, min(x), max(x), add = TRUE)

Ainda falta incluir as legendas:

# Add legend
legend("topleft",
       c("Linear Regression", "Interpolating Cubic Spline",
         "Support Vector Regression", "Correct Model",
         "Train data", "Test data"),
       col=c("orange", "purple", "royalblue", "black", "black", "red"),
       lty = c(1, 6, 5, 1, NA, NA), pch = c(NA, NA, NA, NA, "*", "*"),
       lwd = 2)

Por fim, calculamos a raíz do erro quadrático médio de previsão nos conjuntos test e train, incluindo essa informação no gráfico na forma de texto. Note como nos modelos simples, ambos os erros são altos (underfitting), enquanto que nos modelos complexos o erro no train set é baixo mas no test set é alto. O ideal é que ambos se aproximem, mas na prática sempre queremos minimizar o erro no test set pois estes são os dados novos em que avaliaremos nossa previsão.

# Calcular RMSEs
rmse.reg <- rmse(y, predict(reg, data.frame(x)))
rmse.spline <- rmse(y, spline(x, y, n = 50)$y)
rmse.svm <- rmse(y, svmpred)
rmse.reg.test <- rmse(y_new, predict(reg, data.frame(x)))
rmse.spline.test <- rmse(y_new, spline(x, y, n = 50)$y)
rmse.svm.test <- rmse(y_new, svmpred)

# Adicionar RMSEs ao gráfico
text(2, 600, "Underfitting", col = "orange")
text(2, 500, paste("Train RMSE:",
                   round(rmse.reg, digits = 2)), col = "orange")
text(2, 400, paste("Test RMSE:",
                   round(rmse.reg.test, digits = 2)), col = "orange")
text(7, 0, "Overfitting", col = "purple")
text(7, -100, paste("Train RMSE:",
                    round(rmse.spline, digits = 2)), col = "purple")
text(7, -200, paste("Test RMSE:",
                    round(rmse.spline.test, digits = 2)), col = "purple")
text(-2, -350, "Good fitting", col = "royalblue")
text(-2, -450, paste("Train RMSE:",
                    round(rmse.svm, digits = 2)), col = "royalblue")
text(-2, -550, paste("Test RMSE:",
                    round(rmse.svm.test, digits = 2)), col = "royalblue")

Tradeoff entre viés e variância em vários modelos de previsão

A ideia até aqui é que modelos mais simples tem viés alto mas variância baixa (underfitting), enquanto que modelos mais complexos tem viés baixo mas variância alta (overfitting). Mas o que significa um modelo ser mais complexo? Em geral, a complexidade de um modelo aumenta conforme o número de previsores aumenta, e conforme a capacidade do modelo de captar relações não lineares e interações entre os previsores aumenta. Como nosso exemplo tem apenas um previsor, iremos adicionar complexidade através da não linearidade. Em caso de inúmeros previsores, até mesmo um modelo de regressão linear pode se tornar complexo demais, exigindo técnicas de regularização como LASSO ou Ridge Regression para diminuir a possibilidade de overfitting. Para exemplificar o conceito de tradeoff entre viés e variância, bem como de underfitting e overfitting vamos estimar uma série de modelos com grau crescente de complexidade. O objetivo é gerar o seguinte gráfico:

O código com a estimação, previsão e o plot dos gráficos para cada modelo se encontra abaixo. No gráfico, estimamos 9 modelos distintos:

O primeiro modelo é a Regressão Linear, que possui alto viés e baixa variância, de modo que os erros do train e test set são altos mas semelhantes.
O segundo modelo é o CART, de regressão com árvores. A ideia é estimar uma constante para diferentes níveis da variável previsora x. Esse modelo diminui um pouco os erros no train e test set, mas ainda assim, no nosso caso, o viés é alto.
O terceiro modelo é o K-nearest neighbour com K=2. Este é um modelo não-paramétrico que calcula a distância do ponto a ser previsto em relação aos outros pontos da amostra, e utiliza a média dos 2 pontos mais próximos como previsor. Este modelo diminui consideravelmente os erros do train e test set, entretanto ele parece não realizar uma boa previsão nos valores extremos de x, visto que ao calcular a média dos vizinhos mais próximos a relação polinomial se perde nos extremos.
O quarto modelo é o Support Vector Regression com kernel polinomial. Este modelo é o que faz o melhor trabalho como previsor, o que é de se esperar, visto que a função geradora dos dados é polinomial.
O quinto modelo é uma Regressão Polinomial, que obviamente também faz um excelente trabalho de previsão, visto que a função que gerou os dados é um polinômio.
O sexto modelo é um Thin Plate Spline, onde suavizamos a interpolação escolhendo o parâmetro de suavização através de validação cruzada (CV). Este modelo também consegue captar adequadamente a relação polinomial, embora ele tenha um erro no test set um pouco mais alto que os dois anteriores e o erro no train set um pouco mais baixo, indicando o início de um overfitting.
O sétimo modelo é um Random Forest, que constrõe diversas árvores completas no estilo do modelo CART reordenando os dados através de um algoritmo de bootstrap, e então utiliza a média delas para diminuir a possibilidade de overfitting. A esta estratégia se dá o nome de Bagging. Entretanto, no nosso caso, o modelo ainda assim passa do ponto ideal, tendo um erro no test set um pouco maior do que os quatro modelos anteriores, apesar de ter o menor erro no train set. Isso indica que o modelo está incorrendo em overfitting.
O oitavo modelo é o Gradient Boosting Trees, implementado através do pacote xgboost do R. Este é um dos modelos mais utilizados para previsão hoje em dia por sua flexibilidade e adaptabilidade a diferentes problemas. A ideia do modelo é estimar diversas árvores como no modelo CART, mas ao invés de estimar árvores completas e tirar a média como no Random Forest, o modelo começa estimando uma árvore simples, e então utiliza os pontos em que esta árvore não faz um bom trabalho de previsão para estimar outra árvore simples, e assim por diante. A esta estratégia se dá o nome de Boosting. A ideia é diminuir o viés, porém em geral este modelo terá uma variância maior do que Random Forest, podendo facilmente incorrer em overfitting, como acontece no nosso caso, em que o erro no train set é bem baixo, mas no test set é bem maior.
O último modelo é a interpolação com Spline Cúbico, que passa exatamente por todos os pontos do train set, zerando o erro de previsão. Entretanto, ao avaliar a qualidade da previsão no test set obtemos um erro bem maior. Esse modelo está ocorrendo em um overfitting extremo, sendo complexo demais para gerar uma boa previsão.

Note que dependendo dos dados, os erros do train e test set podem ser completamente diferentes deste gráfico e nem sempre os modelos estarão posicionados exatamente nesta ordem de complexidade do gráfico. Um modelo CART pode ser mais complexo do que um Support Vector Regression, ou até mesmo um Random Forest pode ser mais complexo do que Gradient Boosting Trees, dependendo da parametrização e do conjunto de dados e previsores que se está utilizando. Para o nosso caso, em que o modelo correto é um polinômio, é natural que o Support Vector Regression com kernel polinomial e a Regressão Polinomial apresentem o melhor resultado, mas em geral, com um conjunto de dados mais complexo, com vários previsores, modelos como Random Forest e Gradient Boosting Trees podem ter resultados bem melhores no test set.

# Estimar e plotar 9 modelos diferentes
set.panel(3,3)

## Linear Regression
plot(x, y, xlim = c(min(x), max(x)), ylim = c(min(y), max(y)), pch=16,
     cex = 0.5, ylab = "Response", xlab = "Predictor",
     main = "Linear Regression")
reg <- lm(y ~ x)
abline(reg, col = "#FF0000FF")
text(4.5, -800, cex = 0.8,
     paste("Train RMSE:",
           round(rmse(y, predict(reg, data.frame(x))), digits = 2)))
text(4.5, -1000, cex = 0.8,
     paste("Test RMSE:",
           round(rmse(y_new, predict(reg, data.frame(x))), digits = 2)))

## Regression Tree (CART)
plot(x, y, xlim = c(min(x), max(x)), ylim = c(min(y), max(y)), pch=16,
     cex = 0.5, ylab = "Response", xlab = "Predictor",
     main = "Regression Tree (CART)")
tree <- rpart(y ~ x)
lines(x, predict(tree), col = "#FFAA00FF")
text(4.5, -800, cex = 0.8,
     paste("Train RMSE:",
           round(rmse(y, predict(tree)), digits = 2)))
text(4.5, -1000, cex = 0.8,
     paste("Test RMSE:",
           round(rmse(y_new, predict(tree)), digits = 2)))

## K-nearest neighbour
plot(x, y, xlim = c(min(x), max(x)), ylim = c(min(y), max(y)), pch=16,
     cex = 0.5, ylab = "Response", xlab = "Predictor",
     main = "K-Nearest Neighbour (K=2)")
knnfit <- knn.reg(train=x, y=y, k = 2)
lines(x, knnfit$pred, col = "#AAFF00FF")
text(4.5, -800, cex = 0.8,
     paste("Train RMSE:",
           round(rmse(y, knnfit$pred), digits = 2)))
text(4.5, -1000, cex = 0.8,
     paste("Test RMSE:",
           round(rmse(y_new, knnfit$pred), digits = 2)))

## Support vector regression with polynomial kernel
plot(x, y, xlim = c(min(x), max(x)), ylim = c(min(y), max(y)), pch=16,
     cex = 0.5, ylab = "Response", xlab = "Predictor",
     main = "Support Vector Regression")
svmreg <- svm(y ~ x, kernel = "polynomial")
svmpred <- predict(svmreg, x)
lines(x, svmpred, col = "#FF00AAFF")
text(4.5, -800, cex = 0.8,
     paste("Train RMSE:",
           round(rmse(y, svmpred), digits = 2)))
text(4.5, -1000, cex = 0.8,
     paste("Test RMSE:",
           round(rmse(y_new, svmpred), digits = 2)))

## Polynomial regression
plot(x, y, xlim = c(min(x), max(x)), ylim = c(min(y), max(y)), pch=16,
     cex = 0.5, ylab = "Response", xlab = "Predictor",
     main = "Polynomial Regression")
polyreg <- lm(y ~ poly(x, 3))
lines(x, predict(polyreg, data.frame(x)), col = "#00FFAAFF")
text(4.5, -800, cex = 0.8,
     paste("Train RMSE:",
           round(rmse(y, predict(polyreg, data.frame(x))), digits = 2)))
text(4.5, -1000, cex = 0.8,
     paste("Test RMSE:",
           round(rmse(y_new, predict(polyreg, data.frame(x))), digits = 2)))

## Thin plate spline with CV (smoothing)
plot(x, y, xlim = c(min(x), max(x)), ylim = c(min(y), max(y)), pch=16,
     cex = 0.5, ylab = "Response", xlab = "Predictor",
     main = "Thin Plate Spline with CV")
tps <- Tps(x, y)
lines(x, predict(tps, x), col = "#00FF00FF", lty = 5)
text(4.5, -800, cex = 0.8,
     paste("Train RMSE:",
           round(rmse(y, predict(tps, x)), digits = 2)))
text(4.5, -1000, cex = 0.8,
     paste("Test RMSE:",
           round(rmse(y_new, predict(tps, x)), digits = 2)))

## Random forest
plot(x, y, xlim = c(min(x), max(x)), ylim = c(min(y), max(y)), pch=16,
     cex = 0.5, ylab = "Response", xlab = "Predictor",
     main = "Random Forest")
set.seed(123)
rf <- randomForest(y ~ x)
lines(x, predict(rf, x), col = "#00AAFFFF")
text(4.5, -800, cex = 0.8,
     paste("Train RMSE:",
           round(rmse(y, predict(rf, x)), digits = 2)))
text(4.5, -1000, cex = 0.8,
     paste("Test RMSE:",
           round(rmse(y_new, predict(rf, x)), digits = 2)))

## Extreme gradient boosting trees
plot(x, y, xlim = c(min(x), max(x)), ylim = c(min(y), max(y)), pch=16,
     cex = 0.5, ylab = "Response", xlab = "Predictor",
     main = "Gradient Boosting Trees")
xgb <- xgboost(data = as.matrix(x), label = y, nrounds = 500, eta = 0.01)
lines(x, predict(xgb, as.matrix(x)), col = "#0000FFFF")
text(4.5, -800, cex = 0.8,
     paste("Train RMSE:",
           round(rmse(y, predict(xgb, as.matrix(x))), digits = 2)))
text(4.5, -1000, cex = 0.8,
     paste("Test RMSE:",
           round(rmse(y_new, predict(xgb, as.matrix(x))), digits = 2)))

## Interpolating Cubic Spline
plot(x, y, xlim = c(min(x), max(x)), ylim = c(min(y), max(y)), pch=16,
     cex = 0.5, ylab = "Response", xlab = "Predictor",
     main = "Cubic Spline")
lines(spline(x, y), col = "#AA00FFFF")
text(4.5, -800, cex = 0.8,
     paste("Train RMSE:",
           round(rmse(y, spline(x, y, n = 50)$y), digits = 2)))
text(4.5, -1000, cex = 0.8,
     paste("Test RMSE:",
           round(rmse(y_new, spline(x, y, n = 50)$y), digits = 2)))

Erro de previsão no train e test set

Por fim, para resumir a relação entre erro de previsão no train e test set com a complexidade do modelo, podemos gerar o seguinte gráfico:

Note que aumentando a complexidade do modelo diminuimos o erro no train e test set até o ponto em que o erro no test set começa aumentar. A partir daí o aumento na variância não compensa a diminuição no viés e nosso modelo passa a ter uma má performance em conjuntos novos de dados. A tarefa essencial de previsão é selecionar um modelo que se aproxime do ponto mínimo da curva de erro do test set. O código para gerar o gráfico encontra-se abaixo:

# Calculando RMSE para alguns modelos no train e test set
RMSE <- data.frame(
  Train = c(rmse(y, predict(reg, data.frame(x))),
            rmse(y, predict(polyreg, data.frame(x))),
            rmse(y, predict(tps, x)),
            rmse(y, spline(x, y, n = 50)$y)),
  Test = c(rmse(y_new, predict(reg, data.frame(x))),
            rmse(y_new, predict(polyreg, data.frame(x))),
            rmse(y_new, predict(tps, x)),
            rmse(y_new, spline(x, y, n = 50)$y)))
rownames(RMSE) <- c("Linear Regression", "Polynomial Regression",
                    "Thin Plate Spline", "Cubic Spline")

# Plotando relação entre RMSE e Complexidade dos modelos
dev.new()
plot(RMSE$Train, col = "red", pch = 20, xaxt = "n",
     ylim = c(min(RMSE$Train), max(RMSE$Test)),
     xlab = "Complexity", ylab = "RMSE",
     main = "Train vs Test Error")
points(RMSE$Test, col = "blue", pch = 20)
text(c(1.5, 2.0, 2.9, 3.8), c(190, 70, 70, 90),
     labels = rownames(RMSE), cex = 0.8)
lines(spline(1:nrow(RMSE), RMSE$Train), col = "red")
lines(spline(1:nrow(RMSE), RMSE$Test), col = "blue")
legend("topright", c("Train data", "Test data"),
       col = c("red", "blue"), lwd=2)

A árvore do Impeachment

Fri, 01 Apr 2016 13:00:00 +0000

Este post fez um exercício de previsão para o Impeachment brasileiro utilizando um modelo de regressão particionada através do uso de árvores. As previsões foram atualizadas diariamente e o resultado percentual se referia à proporção de Deputados a favor do Impeachment em relação a totalidade dos membros, considerando diferentes índices de ausência.

Com objetivos didáticos, publiquei o modelo no dia 1º de abril e foi o primeiro do gênero que apareceu na internet. Desde o início, as previsões indicavam grande probabilidade de o Impeachment passar pela etapa de julgamento de admissibilidade na Câmara com cerca de 70% a 75% de votos favoráveis, variando de acordo com a mudança dos dados/fonte. A última atualização do modelo e o resultado final podem ser vistos abaixo:

Previsão com dados do Vem Pra Rua

Ausência	0%	2,5%	5%	7,5%	10%
Estimativa final	71,73%	69,20%	69,00%	66,67%	64,91%
Resultado:	A favor	A favor	A favor	A favor	Contra

Dados obtidos em: 16/04/2016 às 16:00 (último arquivo aqui)

Resultado Final: 367 de 513 votos favoráveis -> 71,54% (A favor)

Taxa de ausência: 2 de 513 deputados -> 0,39%

Como pode ser visto, a estimativa final indicava cerca de 368 votos favoráveis com taxa próxima de 0% de ausência e o resultado final foi de 367 com taxa de ausência de 0,39%. Assim, apesar das limitações do modelo, ele fez um excelente trabalho em prever o resultado final do processo de Impeachment na Câmara brasileira.

O modelo, apesar de parecer complicado, intuitivamente é bem simples, ele apenas considerava a informação partidária e do Estado dos Deputados que já haviam manifestado voto e a partir daí construía uma árvore com as divisões entre partido e Estado para inferir sobre os votos dos indecisos. Muitas limitações foram levantadas a respeito do modelo, as quais, em boa parte, eu concordava. Um exemplo é o fato de ele não captar a barganha e o jogo político por trás das decisões. Entretanto, na semana que antecedeu o Impeachment, a dinâmica da definição dos votos acabou se dando primeiro através de uma deliberação dentro do partido e posteriormente pelo apoio dos Deputados à decisão da maioria, com apenas alguns dissidentes. Como o pressuposto do modelo era de que os Deputados seguiriam a orientação partidária, então ele acabou se mostrando bem eficaz na previsão dos votos. Também o Estado do Deputado teve um peso grande nas manifestações de voto. Afinal, parece que a política brasileira não era tão complicada de se entender!

Após a publicação, o modelo fez bastante sucesso entre estudantes e acadêmicos e acabou ganhando notoriedade na mídia. Conforme as atualizações eram feitas, novas notícias apareciam. Algumas repercussões foram:

Artigos em jornais

Entrevistas em rádios:

Rádio Bandeirantes

Rádio Jovem Pan SP

Rádio Canção Nova.

Sobre a votação no Senado, para a admissibilidade é necessário maioria simples, e para o julgamento é necessário 2/3. Decidi por enquanto não manter as atualizações da previsão para o Senado pelos seguintes motivos:

Já é praticamente certo que a votação terá maioria simples, pois já há manifestação de mais de 50% da Casa a favor do Impeachment;
Após a admissibilidade no Senado passar, a Presidente será destituída por 180 dias antes do julgamento final, o que é um grande período de tempo, podendo ocorrer muitos fatos políticos relevantes até lá;

Caso aparente ser necessário, poderei incluir algumas projeções para o Senado quando o julgamento se aproximar.

Após a publicação deste post, recebi inúmeras sugestões, contribuições e apoio. Gostaria de agradecer principalmente o empenho do Prof. Cláudio Shikida na divulgação, as sugestões dadas pelo Gabriel Torres, Prof. Bruno Speck, membros da comunidade de usuários do R, entre outras pessoas. Ao Fernando Barbosa por me disponibilizar os dados do Estadão através de uma macro em VBA, ao Adriano Filho por traduzir o meu script de coleta dos dados de Python para R. Ao Datafolha por me disponibilizar os dados antecipadamente para análise. E a todas as outras pessoas que ajudaram na divulgação do trabalho. Achei muito gratificante a repercussão que o post teve pois a maior parte dos trabalhos ou consultorias que aparecem na mídia não disponibilizam a metodologia ou as etapas para replicação das projeções feitas. Acredito que estamos em uma nova era da ciência, em que a produção de conhecimento deve estar aberta para o escrutínio do público, possibilitando assim a crítica detalhada do método, e com isso melhorando o resultado e objetivo final do exercício. Entendo que muitas pessoas somente lêem as manchetes, mas pelo menos desta vez havia um link nas reportagens que levava a este post, que mostra as etapas para replicação dos resultados obtidos. Para finalizar, obrigado a todos e aproveitem a leitura!

22 de abril de 2016

Regis A. Ely

Cenário do Impeachment

Nota: A Tabela acima contém a última atualização da previsão feita, mas o post abaixo, bem como todas as informações nele, são referentes a 1º de abril.

A favor ou contra? Parece que todo cidadão brasileiro já tem uma opinião formada sobre o Impeachment, com exceção dos políticos, que estão um tanto indecisos. O site vem pra rua fez um serviço de utilidade pública ao elencar a intenção de voto de todos os deputados e senadores brasileiros. Mas a verdade é que ainda resta muita dúvida sobre qual será o resultado dessa votação. Uma vez que os dados estão disponíveis, podemos tentar realizar uma tarefa quase impossível: prever qual será o desfecho da situação política brasileira. Para isso vamos utilizar um simples modelo de regressão baseado em árvores, implementado no pacote rpart do R. Primeiro vamos aos fatos:

Atualmente temos 513 deputados e 81 senadores no Brasil;
O processo de Impeachment pode ser dividido em duas etapas: o juízo de admissibilidade e o julgamento do impedimento;
Para o pedido ser admitido é necessário 2/3 de votos favoráveis na Câmara dos Deputados e 1/2 de votos favoráveis no Senado Federal;
Para o impedimento da Presidente é necessário 2/3 de votos favoráveis no Senado Federal;
Considerando os números, para termos um novo Presidente é necessário que 342 Deputados e 41 Senadores sejam favoráveis a admissibilidade, e que 54 Senadores sejam favoráveis ao impedimento (crédito ao Gabriel Torres por lembrar das recentes mudanças feitas pelo STF).

Para conhecer um pouco mais sobre o processo de Impeachment você pode ler a legislação.

Obtendo os dados

Como a política brasileira é mais imprevisível que episódio de Game of Thrones, vale a pena automatizar a coleta de dados para podermos atualizar constantemente a previsão - neste exato momento em que escrevo este post já ocorreram mudanças na intenção de voto de 2 Deputados. Para isso, escrevi um pequeno script em Python2.7 que coleta os dados do site vem pra rua e grava em um arquivo csv com o nome imp.csv, deixando-o pronto para ser analisado no R. Você pode ver este script aqui. Se estiver interessado em um script que faz o mesmo para R, você pode ver a versão feita pelo Adriano Azevedo Filho aqui.

Uma vez obtidos os dados podemos carregá-lo no R digitando:

data <- read.csv("imp.csv", sep = ";")

Aqui estão as primeiras 10 observações:

      Voto                   Nome Partido Estado Senador
A favor            Aecio Neves    PSDB     MG       1
A favor Aloysio Nunes Ferreira    PSDB     SP       1
A favor            Alvaro Dias      PV     PR       1
A favor             Ana Amelia      PP     RS       1
A favor      Antonio Anastasia    PSDB     MG       1
A favor       Ataides Oliveira    PSDB     TO       1
A favor           Blairo Maggi      PR     MT       1
A favor      Cassio Cunha Lima    PSDB     PB       1
A favor      Cristovam Buarque     PPS     DF       1
A favor          Dalirio Beber    PSDB     SC       1

A variável Voto contém três possíveis valores: “A favor”, “Contra” ou em branco (indecisos). Já a variável Senador é uma dummy que é igual a um quando o político é Senador e zero quando é Deputado. As outras três variáveis são o Nome, o Partido e o Estado.

Para prevermos o resultado do Impeachment vamos utilizar o método de regressão com particionamento recursivo, implementado pelo pacote rpart. A ideia é que podemos separar as decisões dos políticos em grupos baseados em seus Partidos e Estados. Esse método é ideal para o caso brasileiro, pois sabemos que existem cisões entre os partidos brasileiros dependendo do Estado.

Implementação do modelo

Uma vez carregados os dados na variável data, vamos ler o pacote rpart, criar algumas novas variáveis que serão úteis e fazer pequenos ajustes:

install.packages("rpart") # instale o pacote rpart caso não o tenha feito
library(rpart)

# Transforma os indecisos em NA
data[which(data$Voto == ''),"Voto"] <- NA
data$Voto <- droplevels(data$Voto)

# Cria variáveis para os senadores e deputados
senadores <- data[which(data$Senador == 1),]
deputados <- data[which(data$Senador == 0),]
n_sen <- nrow(senadores) # número de senadores
n_dep <- nrow(deputados) # número de deputados

# Separa deputados indecisos e decididos
train_dep <- na.omit(deputados) # deputados decididos
test_dep <- deputados[which(is.na(deputados$Voto)),] # deputados indecisos
train_sen <- na.omit(senadores) # senadores decididos
test_sen <- senadores[which(is.na(senadores$Voto)),] # senadores indecisos

Note que chamamos o conjunto dos Senadores e Deputados que já estão decididos de train, pois estes serão os dados utilizados para treinar nosso modelo. Posteriormente, aplicaremos os resultados do modelo nos dados denominados test, que é o conjunto dos políticos indecisos, e então teremos nossa previsão.

Para estimar o modelo digitamos:

# Estimação do modelo
formula = Voto ~ Partido + Estado # o voto é função do Partido e Estado
fit_dep = rpart(formula, method = "class", data = train_dep)
fit_sen = rpart(formula, method = "class", data = train_sen)
fit_dep
fit_sen

Ao avaliar os resultados da variável fit_dep, obtemos os nódulos de divisão para os Deputados:

n= 384 

node), split, n, loss, yval, (yprob)
      * denotes terminal node

 1) root 384 119 A favor (0.69010417 0.30989583)  
   2) Partido=DEM,PEN,PHS,PMDB,PP,PPS,PR,PRB,PROS,PSB,PSC,PSD,PSDB,PSL,PTB,PTdoB,PTN,PV,REDE,SD 299  36 A favor (0.87959866 0.12040134)  
     4) Estado=AC,AL,DF,ES,GO,MG,MS,RJ,RO,RS,SC,SP 174   4 A favor (0.97701149 0.02298851) *
     5) Estado=AM,AP,BA,CE,MA,MT,PA,PB,PE,PI,PR,RN,RR,SE,TO 125  32 A favor (0.74400000 0.25600000)  
      10) Partido=DEM,PHS,PPS,PRB,PSB,PSC,PSD,PSDB,PSL,PV,REDE,SD 75   4 A favor (0.94666667 0.05333333) *
      11) Partido=PEN,PMDB,PP,PR,PROS,PTB,PTdoB,PTN 50  22 Contra (0.44000000 0.56000000)  
        22) Estado=AM,BA,CE,PE,PR,RN,TO 35  15 A favor (0.57142857 0.42857143)  
          44) Partido=PEN,PMDB,PR,PTB 20   5 A favor (0.75000000 0.25000000) *
          45) Partido=PP,PROS,PTdoB,PTN 15   5 Contra (0.33333333 0.66666667) *
        23) Estado=MA,MT,PA,PB,PI,RR,SE 15   2 Contra (0.13333333 0.86666667) *
   3) Partido=PCdoB,PDT,PSOL,PT 85   2 Contra (0.02352941 0.97647059) *> fit_dep

Parece complicado, mas uma maneira mais fácil de visualizar estes nódulos é graficamente. Para isso utilizamos a função plot no R. Para construirmos árvores mais bonitas utilizamos a função text com alguns argumentos especiais (digite ?plot.rpart no R para mais informações).

# Plota árvore dos deputados decididos
plot(fit_dep, uniform = TRUE,
     main = "Árvore do Impeachment - Câmara (decididos)", margin = 0.2)
text(fit_dep, use.n = TRUE, all = TRUE, cex = .8, pretty = TRUE,
     fancy = TRUE, minlength = 12, bg = "yellow")
mtext("Valores são: A favor/Contra", side = 1)

# Plota árvore dos senadores decididos
plot(fit_sen, uniform = TRUE,
     main = "Árvore do Impeachment - Senado (decididos)", margin = 0.2)
text(fit_sen, use.n = TRUE, all = TRUE, cex = .8, pretty = TRUE,
     fancy = TRUE, minlength = 12, bg = "yellow")
mtext("Valores são: A favor/Contra", side = 1)

Assim, obtemos os seguintes gráficos:

Ainda assim não é tão simples, mas quem disse que a política brasileira era fácil de entender. Vamos primeiro analisar o Congresso. Repare que no primeiro nódulo há uma divisão partidária, com o grupo PCdoB, PDT, PSOL e PT de um lado, sendo que 2 Deputados são a favor e 83 contra o Impeachment. No resto dos partidos, existem divisões de acordo com o Estado. No grupo AC,AL,DF,ES,GO,MG,MS,RJ,RO,RS,SC,SP temos 170 Deputados a favor e apenas 4 contra, mas no restante dos Estados há divisões partidárias e por região. Resumindo, me parece que os partidos estão mais rachados nos Estados do Nordeste. No Senado a divisão é mais simples e parece ser explicada bastante pelo Estado do Senador.

Previsão dos votos indecisos

Após estimar o modelo podemos calcular a acurácia do mesmo utilizando as funções printcp() e plotcp(). Uma maneira rápida de obter a acurácia do modelo no conjunto train é digitando:

# Acurácia no conjunto train para Deputados
prev_class_dep <- table(predict(fit_dep, type="class"), train_dep$Voto)
sum(diag(prev_class_dep))/sum(prev_class_dep)

# Acurácia no conjunto train para Senadores
prev_class_sen <- table(predict(fit_sen, type="class"), train_sen$Voto)
sum(diag(prev_class_sen))/sum(prev_class_sen)

O resultado é:

[1] 0.9402597 # Deputados
[1] 0.9032258 # Senadores

Entretanto, ao utilizar uma estrutura muito complicada para o nosso modelo, podemos acabar cometendo o erro de overfitting em nossa previsão. Para evitar isso, devemos verificar qual a estrutura de árvores que gera o menor erro de previsão em um conjunto independente, chamado cross-validated. Para obter a acurácia do modelo de previsão nesse conjunto no caso dos Deputados podemos utilizar a informação da função printcp(fit_dep):

Classification tree:
rpart(formula = formula, data = train_dep, method = "class")

Variables actually used in tree construction:
[1] Partido

Root node error: 119/385 = 0.30909

n= 385 

       CP nsplit rel error  xerror     xstd
1 0.67227      0   1.00000 1.00000 0.076197
2 0.02521      1   0.32773 0.35294 0.051404

O taxa de erro do conjunto cross-validated (10-fold) pode ser obtida multiplicando-se o Root node error pelo menor valor do xerror, que corresponde ao melhor modelo. Assim, obtemos um erro de 0.1090902, o que nos dá uma acurácia de 0.8909098. No código abaixo faço a seleção automática do modelo com menor erro no conjunto cross-validated e estimo-o novamente com a função prune.

# Seleção do modelo com menor erro
fit_dep <- prune(fit_dep,
                 cp = fit_dep$cptable[which.min(fit_dep$cptable[,"xerror"]),
                                      "CP"])
fit_sen <- prune(fit_sen,
                 cp = fit_sen$cptable[which.min(fit_sen$cptable[,"xerror"]),
                                      "CP"])

Uma vez obtido o modelo com o menor erro, podemos utilizar os dados referentes aos parlamentares indecisos para realizar a previsão do voto e calcular o percentual de votos a favor com essas novas previsões:

# Previsão do modelo
prev_dep <- predict(fit_dep, test_dep, type = "class")
prev_sen <- predict(fit_sen, test_sen, type = "class")

# Previsão do percentual de votação a favor
n_dep_favor <- nrow(train_dep[which(train_dep$Voto == "A favor"),])
n_sen_favor <- nrow(train_sen[which(train_sen$Voto == "A favor"),])
n_dep_favor_prev <- length(which(prev_dep == "A favor"))
n_sen_favor_prev <- length(which(prev_sen == "A favor"))
percentual_dep <- (n_dep_favor + n_dep_favor_prev)/n_dep
percentual_sen <- (n_sen_favor + n_sen_favor_prev)/n_sen
percentual_dep
percentual_sen

E o resultado será:

[1] 0.7465887 # Câmara dos Deputados
[1] 0.5308642 # Senado Federal

Parece que na situação atual, o Impeachment passa pela etapa de admissibilidade mas esbarra no julgamento do Senado Federal.

Árvores com previsão

Para finalizar, vamos construir a árvore final que inclui os indecisos e utiliza o modelo simplificado com menor erro de previsão:

# Altera os dados originais para incluir a previsão dos indecisos
new_dep <- deputados
new_dep[names(prev_dep), "Voto"] <- prev_dep
new_sen <- senadores
new_sen[names(prev_sen), "Voto"] <- prev_sen

# Constrõe a árvore com os indecisos
fit_dep_prev = rpart(formula, method = "class", data = new_dep)
fit_sen_prev = rpart(formula, method = "class", data = new_sen)

# Plota a árvore dos Deputados com os indecisos
plot(fit_dep_prev, uniform = TRUE,
    main = "Árvore do Impeachment - Câmara (com previsão de indecisos)",
    margin = 0.2)
text(fit_dep_prev, use.n = TRUE, all = TRUE, cex = .8, pretty = TRUE,
     fancy = TRUE, minlength = 12, bg = "yellow")
mtext("Valores são: A favor/Contra", side = 1)
mtext(paste0("Percentual previsto a favor: ",
             round(percentual_dep*100, digits = 2), "%"))

# Plota a árvore dos Senadores com os indecisos
plot(fit_sen_prev, uniform = TRUE,
    main = "Árvore do Impeachment - Senado (com previsão de indecisos)",
    margin = 0.3)
text(fit_sen_prev, use.n = TRUE, all = TRUE, cex = .8, pretty = TRUE,
     fancy = TRUE, minlength = 12, bg = "yellow")
mtext("Valores são: A favor/Contra", side = 1)
mtext(paste0("Percentual previsto a favor: ",
             round(percentual_sen*100, digits=2), "%"))

O resultado está abaixo:

A árvore do Senado Federal nos mostra que a maior resistência ao Impeachment parece ser os partidos do PCdoB, PDT, PMDB, PP, PR, PRB, PSB, PSD, PT e PTB nos Estados AL, AM, AP, BA, MA, PA, PE, PI, PR, RJ, RN, RR, TO. O Impeachment precisa de 54 votos no Senado. Atualmente existem 36 Senadores com intenção de voto a favor e 26 contra. Assim, são necessários 18 votos dos 19 indecisos para a Presidente ser destituída do Cargo, ou então uma mudança no voto dos Senadores que se declararam contra o Impeachment.

Podemos visualizar a lista dos Senadores indecisos segundo o site vem pra rua com o comando:

senadores[which(is.na(senadores$Voto)), ]

O resultado nos dá:

<NA>             Acir Gurgacz         PDT     RO       1
<NA> Antonio Carlos Valadares         PSB     SE       1
<NA>            Ciro Nogueira          PP     PI       1
<NA>       Delcidio do Amaral Sem partido     MS       1
<NA>           Douglas Cintra         PTB     PE       1
<NA>            Elmano Ferrer         PTB     PI       1
<NA>  Fernando Bezerra Coelho         PSB     PE       1
<NA>               Helio Jose        PMDB     DF       1
<NA>       Joao Alberto Souza        PMDB     MA       1
<NA>            Jose Maranhao        PMDB     PB       1
<NA>              Lucia Vania         PSB     GO       1
<NA>         Marcelo Crivella         PRB     RJ       1
<NA>                Omar Aziz         PSD     AM       1
<NA>            Raimundo Lira        PMDB     PB       1
<NA>            Roberto Rocha         PSB     MA       1
<NA>                  Romario         PSB     RJ       1
<NA>              Romero Juca        PMDB     RR       1
<NA>             Sandra Braga        PMDB     AM       1
<NA>         Vicentinho Alves          PR     TO       1

Lidando com os ausentes

A ausência ou a abstenção pode trazer uma influência grande no resultado da votação, visto que o cálculo do percentual é feito sobre a totalidade dos membros e não apenas sobre os presentes (crédito ao Prof. Bruno Speck da USP por lembrar disto). Assim, decidi fazer uma simulação com diferentes taxas de ausência/abstenção, onde os deputados e senadores ausentes são selecionados aleatoriamente. Para criar os novos percentuais, basta digitar:

# Ausência de 2,5% dos Deputados
n_dep_pres <- floor(nrow(new_dep) * 0.975)
dep_pres <- new_dep[sample(seq_len(nrow(new_dep)), n_dep_pres),]

# Ausência de 2,5% dos Senadores
n_sen_pres <- floor(nrow(new_sen) * 0.975)
dep_pres <- new_sen[sample(seq_len(nrow(new_sen)), n_sen_pres),]

# Percentual de favoráveis
n_dep_favor_pres <- length(which(dep_pres == "A favor"))
n_sen_favor_pres <- length(which(sen_pres == "A favor"))
percentual_dep_pres <- n_dep_favor_pres/n_dep
percentual_sen_pres <- n_sen_favor_pres/n_sen
percentual_dep_pres
percentual_sen_pres

O percentual de Deputados favoráveis ao Impeachment quando a abstenção é de 2,5% é de 72,90%, e de Senadores é 51,85%. Para realizar a análise com outras taxas de abstenção basta mudar os percentuais. Ainda assim, a acurácia da previsão depende do fato de que a ausência seja aleatória, e não correlacionada com a intenção de voto, Partido ou Estado.

Atualizando as previsões

Como toda previsão é melhor a medida que incorpora a chegada de novas informações, fiz uma rotina para atualizar os resultados dessa previsão diariamente e publicar na tabela do início deste post.

Tem sugestões para melhorar o algoritmo? Tem dúvidas sobre a implementação? Encontrou algum typo no texto? Me avise nos comentários ou por email.