Paixão por Dados

Anunciando um "novo" dataset no Kaggle: Pesquisa Origem Destino do Metrô SP

Thu, 04 Jul 2019 00:00:00 +0000

Motivação

Esta matéria da Folha de São Paulo me motivou a fazer algo que sempre tive muito interesse e que foi responsável por ajudar a desenvolver meu raciocínio analítico: baixar um conjunto de dados público, fazer minhas próprias análises e tirar conclusões que considero interessantes.

Ao baixar o dataset neste link, contudo, meu primeiro obstáculo foi o formato em que os dados foram disponbilizados. Problemas como células mescladas, problemas de encoding, formato matricial (e não tidy) de tabelas, etc. Além disso, o próprio nome dos arquivos não esclarece seu conteúdo e não facilita o trabalho de quem deseja juntar as diferentes tabelas para tirar conclusões criativas.

Por exemplo, existe relação entre renda familiar e a “popularidade” de uma zona de destino de viagens? Bairros mais ricos recebem mais trabalhadores da indústria, de serviços ou de comércio? Quais distritos de São Paulo mais “exportam” pessoas que pegam metrô para buscar emprego? As possibilidades de análises e modelagens são muitas.

Com esta motivação, ao perceber que o trabalho de limpeza de dados, realizado neste código, poderia ser trabalhoso para mais gente além de mim, decidi exportar os arquivos no Kaggle em um arquivo SQLite que contem as tabelas, além de salvar as tabelas individualmente em arquivos csv após passar pelo processo de limpeza e padronização de dados.

Como usar os dados

O dplyr tem um recurso muito legal: pode interagir diretamente com arquivos SQL, sejam eles como arquivo local ou como um sistema de banco de dados hospedado em algum servidor. O Rstudio possui um site com vários tutoriais sobre trabalhar com bancos de dados SQL.

library(RSQLite)
library(tidyverse)
# apos baixar o arquivo SQLITE chamado DB_ORIGEM_DESTINO_SP do Kaggle,
# indique abaixo o caminho para o arquivo
arquivo_db <- "/home/sillas/R/Projetos/pesquisa_origem_destino/data/DB_ORIGEM_DESTINO_SP"
# criar conexao com o banco
con <- dbConnect(RSQLite::SQLite(), dbname = arquivo_db)

A função dbListTables exibe quais tabelas estão disponíveis:

dbListTables(con)

##  [1] "dados_geograficos_das_zonas"                                                                           
##  [2] "dados_gerais"                                                                                          
##  [3] "dados_gerais_por_zona_de_pesquisa_2017"                                                                
##  [4] "dicionario_das_variaveis_da_tabela_dados_gerais"                                                       
##  [5] "dicionarios_de_variaveis_da_tabela_de_dados_gerais_encodificadas"                                      
##  [6] "empregos_com_trabalho_externo_ou_interno_por_zona_de_emprego_2017"                                     
##  [7] "empregos_em_endereco_fixo_na_propria_residencia_e_sem_endereco_fixo_por_zona_de_emprego_2017"          
##  [8] "empregos_por_classe_de_atividade_e_zona_de_emprego_2017"                                               
##  [9] "empregos_por_setor_de_atividade_e_zona_de_emprego_2017"                                                
## [10] "empregos_por_vinculo_empregaticio_e_zona_de_emprego_2017"                                              
## [11] "familias_por_numero_de_automoveis_particulares_e_zona_de_residencia_2017"                              
## [12] "matriculas_escolares_por_tipo_de_estabelecimento_e_zona_de_escola_2017"                                
## [13] "populacao_por_condicao_de_atividade_e_zona_de_residencia_2017"                                         
## [14] "populacao_por_faixa_de_renda_familiar_mensal_e_zona_de_residencia_2017"                                
## [15] "populacao_por_faixa_etaria_e_zona_de_residencia_2017"                                                  
## [16] "populacao_por_genero_e_zona_de_residencia_2017"                                                        
## [17] "populacao_por_grau_de_instrucao_e_zona_de_residencia_2017"                                             
## [18] "populacao_que_trabalha_por_vinculo_empregaticio_do_primeiro_trabalho_e_zona_de_residencia_2017"        
## [19] "renda_total_renda_media_familiar_renda_per_capita_e_renda_mediana_familiar_por_zona_de_residencia_2017"
## [20] "tempo_medio_das_viagem_produzidas_por_tipo_de_viagem_e_zona_de_origem_2017"                            
## [21] "viagens_diarias_a_pe_por_zonas_de_origem_e_destino_2017"                                               
## [22] "viagens_diarias_atraidas_por_modo_principal_e_zona_de_destino_2017"                                    
## [23] "viagens_diarias_atraidas_por_motivo_e_zona_de_destino_2017"                                            
## [24] "viagens_diarias_atraidas_por_tipo_e_zona_de_destino_2017"                                              
## [25] "viagens_diarias_motorizadas_por_zonas_de_origem_e_destino_2017"                                        
## [26] "viagens_diarias_nao_motorizadas_por_zonas_de_origem_e_destino_2017"                                    
## [27] "viagens_diarias_por_bicicleta_e_zonas_de_origem_e_destino_2017"                                        
## [28] "viagens_diarias_por_modo_coletivo_e_zonas_de_origem_e_destino_2017"                                    
## [29] "viagens_diarias_por_modo_individual_e_zonas_de_origem_e_destino_2017"                                  
## [30] "viagens_diarias_produzidas_a_pe_por_razao_de_escolha_do_modo_e_zona_de_origem_2017"                    
## [31] "viagens_diarias_produzidas_por_modo_principal_e_zona_de_origem_2017"                                   
## [32] "viagens_diarias_produzidas_por_motivo_e_zona_de_origem_2017"                                           
## [33] "viagens_diarias_produzidas_por_tipo_e_zona_de_origem_2017"                                             
## [34] "viagens_diarias_totais_por_zonas_de_origem_e_destino_2017"

Para iniciantes nesse dataset, as tabelas mais importantes são estas:

dbListTables(con)[c(1, 4, 5)]

## [1] "dados_geograficos_das_zonas"                                     
## [2] "dicionario_das_variaveis_da_tabela_dados_gerais"                 
## [3] "dicionarios_de_variaveis_da_tabela_de_dados_gerais_encodificadas"

Para interagir com uma tabela desse banco de dados, usa-se a função tbl():

tbl(con, # arquivo de conexao com o banco
    "dicionario_das_variaveis_da_tabela_dados_gerais") # nome da tabela)

## # Source:   table<dicionario_das_variaveis_da_tabela_dados_gerais> [?? x
## #   2]
## # Database: sqlite 3.22.0
## #   [/home/sillas/R/Projetos/pesquisa_origem_destino/data/DB_ORIGEM_DESTINO_SP]
##    VAR_NOME VAR_CONTEUDO                             
##    <chr>    <chr>                                    
##  1 ZONA     Zona do Domicílio                        
##  2 MUNI_DOM Município de Domicílio                   
##  3 CO_DOM_X Coordenada X Domicílio                   
##  4 CO_DOM_Y Coordenada Y Domicílio                   
##  5 ID_DOM   Identifica Domicílio                     
##  6 F_DOM    Identifica Primeiro Registro do Domicílio
##  7 FE_DOM   Fator de Expansão do Domicílio           
##  8 DOM      Número do Domicílio                      
##  9 CD_ENTRE Código de Entrevista                     
## 10 DATA     Data da Entrevista                       
## # … with more rows

O dplyr faz, então, algo que se chama de consulta lazy: o output acima não é um dataframe ou tibble, mas sim uma breve exibição das primeiras linhas do resultado da consulta à tabela. O benefício disso é que o resultado da consulta não foi carregado para a memória RAM, o que é muito útil ao lidar com bancos de dados muito grandes e queries complexas.

No código abaixo, por exemplo, eu junto duas tabelas diferentes e filtro as zonas da cidade de São Paulo para só então “baixar” ou trazer os dados para a memória RAM com a função collect():

df_zonas_sp <- tbl(con, "dados_gerais") %>% 
  left_join(tbl(con, "dados_geograficos_das_zonas"),
            by = c("ZONA" = c("COD_ZONA"))) %>% 
  # filtrar zonas de SP
  filter(NOME_MUNICIPIO == "São Paulo") %>% 
  collect()

A partir dos dados obtidos, podemos fazer qualquer tipo de análise desejada. Por exemplo, um gráfico contendo a renda familiar mediana por distrito na cidade de São Paulo:

# distritos por renda familiar
renda_por_distrito <- df_zonas_sp %>% 
  filter(!is.na(RENDA_FA)) %>% 
  group_by(NOME_AREA_SP_CAPITAL, NOME_DISTRITO) %>% 
  summarise(RENDA_MEDIANA = median(RENDA_FA))

quartis <- quantile(renda_por_distrito$RENDA_MEDIANA,
                    prob = c(.25, .50, .75))

renda_por_distrito %>% 
  ggplot(aes(x = fct_reorder(NOME_DISTRITO, RENDA_MEDIANA),
             y = RENDA_MEDIANA)) +
  geom_col(fill = "#A82B2EFE") +
  geom_hline(yintercept = quartis, linetype = "dashed") +
  facet_wrap(vars(NOME_AREA_SP_CAPITAL), scales = "free_y") +
  labs(x = NULL, y = NULL,
       title = "Mediana da renda familiar por zona na cidade de SP") +
  scale_y_continuous(breaks = seq(0, 10000, 2000),
                     minor_breaks = NULL) +
  coord_flip()

Outro tipo de análise possível pelo cruzamento de tabelas: Para onde vão as pessoas que partem da Luz?

# para onde as pessoas que moram na luz vão?
tb_zona_de_para <- tbl(con, "dados_geograficos_das_zonas") %>% 
  select(COD_ZONA, NOME_ZONA)


tbl(con, "viagens_diarias_totais_por_zonas_de_origem_e_destino_2017") %>% 
  left_join(tb_zona_de_para, by = c("COD_ZONA_ORIGEM" = "COD_ZONA")) %>% 
  rename(NOME_ZONA_ORIGEM = NOME_ZONA) %>% 
  left_join(tb_zona_de_para, by = c("COD_ZONA_DESTINO" = "COD_ZONA")) %>% 
  rename(NOME_ZONA_DESTINO = NOME_ZONA) %>% 
  filter(NOME_ZONA_ORIGEM == "Luz") %>% 
  select(NOME_ZONA_DESTINO, QTD) %>% 
  arrange(desc(QTD))

## # Source:     lazy query [?? x 2]
## # Database:   sqlite 3.22.0
## #   [/home/sillas/R/Projetos/pesquisa_origem_destino/data/DB_ORIGEM_DESTINO_SP]
## # Ordered by: desc(QTD)
##    NOME_ZONA_DESTINO     QTD
##    <chr>               <dbl>
##  1 Luz                18425.
##  2 Bom Retiro          3702.
##  3 Parque Dom Pedro    2752.
##  4 Santa Ifigênia      2550.
##  5 Santa Cecília       1945.
##  6 Ponte Pequena       1712.
##  7 Saúde               1392.
##  8 Vila Formosa        1368.
##  9 Pari                1304.
## 10 Ermelino Matarazzo  1261.
## # … with more rows

E Python?

Também é bem fácil importar um arquivo SQLite no Python combinando os módulos sqlite3 e pandas.

import sqlite3
import pandas as pd


x = '/home/sillas/R/Projetos/pesquisa_origem_destino/data/DB_ORIGEM_DESTINO_SP'
con = sqlite3.connect(x)
# importar tabela como um dataframe no pandas
tb = pd.read_sql_query('SELECT * FROM dicionario_das_variaveis_da_tabela_dados_gerais', con)

Qual o melhor serviço de streaming de filmes e séries no Brasil? O R responde.

Sat, 23 Feb 2019 00:00:00 +0000

Introdução

Recentemente, li um artigo sobre a Balcanização dos serviços de streaming que me fez refletir sobre essa indústria. Dado que assinar mais de um serviço de streaming pode ser um desperdício, devido a falta de tempo para consumir tanto material, as pessoas costumam optar por apenas um dos existentes: Netflix, Amazon Prime Video ou algum outro. Como saber qual escolher?

O serviço JustWatch ajuda um pouco. Nele, é possível pesquisar por um filme ou seriado e descobrir em quais serviços ele está disponível. Assim, se temos em mão os dados dos catálogos dos serviços, podemos avaliar a quantidade e qualidade dos filmes em cada um para decidir o melhor.

Existe um módulo Python que permite extrair os dados do JustWatch em json, tornando os dados muito fáceis para trabalhar. Por isso, este projeto usará código não só em R como em Python.

Este projeto consiste em coletar os 5000 melhores filmes e seriados do IMDB, coletar dados de cada usando a API do Justwatch e analisar os resultados para concluir sobre o melhor serviço de streaming no Brasil.

Primeiro passo: Coletando nomes de filmes e seriados

Infelizmente, a API do Justwatch não nos permite coletar todo o catálogo do site, existindo um limite dos 1000 primeiros resultados, mesmo que se altere os parâmetros page e page_size da função.

Por outro lado, a função não impõe um limite de requisições feitas sequencialmente. Por isso, a melhor estratégia é iterar a função sobre uma lista de filmes a pesquisar.

Onde coletar essa lista de filmes? A ideia que eu tive foi usar o IMDB para isso. Eu coletei os 5000 melhores filmes e seriados (sem distinção) para ter os resultados. Como o código é relativamente simples e os dados bem grandes, não vou descrever essa parte do projeto aqui. Os interessados podem consultar como eu fiz para coletar os dados do IMDB neste gist.

Usar o módulo Python para coletar dados da API do JustWatch

O código é bem simples: eu leio o arquivo com a lista de filmes salvos na parte anterior, itero sobre o dataframe, junto todos os resultados em um dicionário e salvo os dados em formato json.

O comportamento da função just_watch.search_for_item() é o mesmo de você pesquisar manualmente no site. Isto é, ao digitar na caixa de busca o título desejado, aparecerá uma lista com os resultados relacionados, sendo que provavelmente apenas o primeiro resultado é o que interessa. Por isso, no código abaixo, eu extraio o primeiro resultado da busca. Funciona na maioria das vezes.

from justwatch import JustWatch
import csv
import json
import pandas as pd
just_watch = JustWatch(country='BR')

# ler lista de filmes
arquivo = '/home/sillas/R/data/imdb/lista_filmes_imdb.csv'
titulos = pd.read_csv(arquivo)

out = list()

for index, row in titulos.iterrows():
    # imprimir status do loop
    if index % 100 == 0:
        print(index)
    # consultar api
    api_data = just_watch.search_for_item(query = row["full_title"])["items"]
    
    # salvar dados apenas se houver resultado
    if len(api_data) > 0:
        first_item_data = api_data[0]
        first_item_data["tconst"] = row["tconst"]
        out.append(first_item_data)
    
# salvar resultados em json
with open('/home/sillas/R/data/imdb/justwatchdata.json', 'w') as fp:
    json.dump(out, fp)
    
# salvar dados de sites de streaming
provider_details = just_watch.get_providers()

with open('/home/sillas/R/data/imdb/justwatchdata_providers.json', 'w') as fp:
    json.dump(provider_details, fp)

Juntando os dados

Finalmente, chegamos à parte divertida. Abaixo eu importo os pacotes usados e o arquivo json salvo acima.

library(tidyverse)
library(jsonlite)
library(UpSetR)
library(ggridges)

# gist com o json: 
jw <- jsonlite::fromJSON("/home/sillas/R/data/imdb/justwatchdata.json") %>% 
  as_tibble() %>% 
  # selecionar colunas importantes
  select(tconst, original_title, original_release_year,
         tmdb_popularity, object_type, offers, scoring) 

glimpse(jw)

## Observations: 4,442
## Variables: 7
## $ tconst                <chr> "tt0903747", "tt0111161", "tt0068646", "tt…
## $ original_title        <chr> "Breaking Bad", "The Shawshank Redemption"…
## $ original_release_year <int> 2008, 1994, 1972, 2013, 1974, 1994, 1993, …
## $ tmdb_popularity       <dbl> 76.613, 30.009, 26.993, 82.621, 19.567, 32…
## $ object_type           <chr> "show", "movie", "movie", "show", "movie",…
## $ offers                <list> [<data.frame[5 x 14]>, <data.frame[13 x 1…
## $ scoring               <list> [<data.frame[4 x 2]>, <data.frame[10 x 2]…

A estrutura deste dataframe não é necessariamente tabular, como se costuma ver. As colunas offers e scoring são da classe list, pois cada valor dessas duas variáveis é um dataframe. Ou seja, no R é possível termos dataframes dentro de um dataframe.

Para tornar o dataframe mais simples de ser usado, vamos transformar essas duas colunas em dataframes separados.

# criar funcao para extrair apenas as colunas importantes de offers
extract_offers_data <- function(offers){
  if(!is.null(offers)){
    offers %>% 
      select(monetization_type, provider_id,
             date_created, presentation_type)
  }
}

tbl_offers <- jw %>% 
  select(tconst, offers) %>% 
  # remover filmes sem dados de streaming
  filter(!map_lgl(offers, is.null)) %>% 
  # usar funcao criada acima para extrair colunas
  mutate(offers = map(offers, extract_offers_data)) %>% 
  unnest(offers) %>% 
  # filtrar apenas filmes de serviços onde se paga uma taxa mensal para ter
  # acesso aos filmes, ao inves de um preço para cada filme, como se fosse
  # uma loja.
  filter(monetization_type == "flatrate") %>% 
  distinct(tconst, provider_id)

tbl_scoring <- jw %>% 
  select(tconst, scoring) %>% 
  filter(!map_lgl(scoring, is.null)) %>% 
  unnest(scoring) %>% 
  rename(scoring_provider_type = provider_type)

# no dataframe principal, remover essas duas colunas
tbl_jw <- jw %>% 
  select(-c(offers, scoring))

# importar arquivos com os metadados dos sites de streaming
tbl_providers <- fromJSON("/home/sillas/R/data/imdb/justwatchdata_providers.json") %>% 
  as_tibble() %>%
  select(provider_id = id, provider_name = slug) %>% 
  mutate(provider_name = str_replace_all(provider_name, "-", "_"))

tbl_offers_prov <- left_join(tbl_offers, tbl_providers, by = "provider_id")

# criar dataset das analises
tbl_jw <- tbl_jw %>% 
  left_join(tbl_offers_prov, by = "tconst") %>% 
  left_join(tbl_scoring, by = "tconst") %>% 
  select(-provider_id)

Este é o dataset das nossas análises:

# dataset das analises
tbl_jw

## # A tibble: 41,085 x 8
##    tconst original_title original_releas… tmdb_popularity object_type
##    <chr>  <chr>                     <int>           <dbl> <chr>      
##  1 tt090… Breaking Bad               2008            76.6 show       
##  2 tt090… Breaking Bad               2008            76.6 show       
##  3 tt090… Breaking Bad               2008            76.6 show       
##  4 tt090… Breaking Bad               2008            76.6 show       
##  5 tt011… The Shawshank…             1994            30.0 movie      
##  6 tt011… The Shawshank…             1994            30.0 movie      
##  7 tt011… The Shawshank…             1994            30.0 movie      
##  8 tt011… The Shawshank…             1994            30.0 movie      
##  9 tt011… The Shawshank…             1994            30.0 movie      
## 10 tt011… The Shawshank…             1994            30.0 movie      
## # … with 41,075 more rows, and 3 more variables: provider_name <chr>,
## #   scoring_provider_type <chr>, value <dbl>

Resultados

Quais sites possuem mais filmes e seriados?

tbl_jw %>% 
  distinct(tconst, object_type, provider_name) %>% 
  count(provider_name, object_type) %>% 
  group_by(object_type) %>% 
  mutate(pct = 100 * n/sum(n)) %>% 
  ggplot(aes(x = fct_rev(provider_name), y = pct)) +
  geom_col() +
  coord_flip() +
  facet_wrap(~ object_type, ncol = 1) +
  labs(x = NULL, y = "%",
       title = "Presença dos melhores filmes e seriados \nnos sites de streaming no Brasil") +
  theme_bw()

Os resultados são bem interessantes. Para quem adora seriados, a Netflix reina absoluta tendo em seu portfolio 40% dos melhores seriados, enquanto que o segundo melhor neste quesito, o Amazon Prime Video, possui apenas 10%. Em termos de filmes, a Netflix também é a melhor, sendo seguida de perto pelo Telecine Play. O portfolio do Amazon Prime Video para filmes deixa bastante a desejar.

Ainda sobre filmes, é bastante importante mencionar que mais da metade das produções não está disponível em nenhum serviço de streaming de vídeo por assinatura no Brasil, um resultado bem lamentável para cinéfilos.

Para o restante deste post, vamos focar apenas nesses 3 principais streamings:

prvs <- c("netflix", "amazon_prime_video", "telecine_play")

tbl_jw_principais <- tbl_jw %>% 
  filter(is.na(provider_name) | provider_name %in% prvs) %>% 
  mutate(provider_name = tidyr::replace_na(provider_name, "nenhum"))

Quais sites possuem os filmes mais recentes?

range(tbl_jw_principais$original_release_year)

## [1] 1920 2019

tbl_jw_principais %>% 
  ggplot(aes(x = original_release_year, color = provider_name)) +
  stat_ecdf() +
  theme_bw() +
  scale_x_continuous(breaks = seq(1920, 2020, by  = 10), 
                     minor_breaks = NULL) +
  scale_y_continuous(breaks = seq(0, 1, .1), 
                     minor_breaks = NULL,
                     labels = scales::percent) +
  theme(legend.position = "bottom") +
  facet_wrap(~ object_type, ncol = 2) +
  labs(title = "Distribuição da idade de títulos por serviço de streaming",
       x = NULL, 
       y = NULL)

O formato da curva referente à Netflix é muito interessante. Note como ela cresce numa velocidade muito maior a partir de 2010. Olhando para este ponto no eixo vertical, nota-se que 70% dos filmes e incríveis 80% dos seriados foram lançados a partir de 2010. De todos os 3 serviços de streaming, a Netflix é a mais enviesada para produções recentes. Note também como 70% dos filmes que não estão presentes em nenhum serviço por assinatura foram lançados antes de 2010. Na verdade, Netflix e Amazon Prime Video não possuem nenhum filme lançado antes de 1960.

Outra maneira de visualizar os resultados acima é separando os anos por década:

tbl_jw_principais %>% 
  mutate(decada = as.character(round(original_release_year %/% 10) * 10)) %>% 
  count(decada, object_type, provider_name) %>% 
  ggplot(aes(x = decada, y = n, fill = provider_name)) +
  geom_col(position = position_dodge()) +
  theme_bw() +
  labs(title = "Quantidade de títulos por década",
       x = NULL, 
       y = NULL) +
  facet_wrap(~ object_type, scales = "free_y", ncol = 1) +
  theme(legend.position = "bottom")

Qualidade dos filmes

Como parâmetro para qualidade dos filmes, usei a nota do IMDB, que também é fornecida no dataset do JustWatch.

tbl_jw_principais %>% 
  # filtrar filmes com nota IMDB acima de 7 para eliminar entradas erradas
  filter(scoring_provider_type == "imdb:score", value >= 7) %>% 
  mutate(value = cut(value, breaks = 0:10)) %>% 
  count(object_type, provider_name, value) %>% 
  ggplot(aes(x = value, y = n, fill = provider_name)) +
  geom_col(position = position_fill()) +
  theme_bw() +
  scale_y_continuous(breaks = seq(0, 1, .1),
                     labels = scales::percent) +
  facet_wrap(~ object_type) +
  labs(x = NULL,
       y = NULL,
       title = "Percentual de títulos por faixa de nota no IMDB") +
  theme(legend.position = "bottom")

Não aparenta haver diferença em relação à nota dos filmes e seriados de acordo com o streaming.

Exclusividade de conteúdo

Por último, mas não menos importante, existe o critério de exclusividade entre as plataformas, algo comum nesta indústria. Quantos filmes estão presentes apenas, por exemplo no Telecine Play? Quantos são possíveis de encontrar em mais de uma plataforma?

# criar matriz binaria
tbl_jw_principais_wide <- tbl_jw_principais %>% 
  distinct(tconst, provider_name) %>%
  mutate(provider_name = replace_na(provider_name, "nenhum")) %>% 
  mutate(tem = 1) %>% 
  spread(provider_name, tem) %>% 
  mutate_at(vars(-tconst), replace_na, 0) %>% 
  as.data.frame()

# grafico upset
upset(tbl_jw_principais_wide, nsets = 10,
      mainbar.y.label = NULL)

Também neste quesito a Netflix é disparado o melhor dentre os 3. 979 dos títulos são exclusivos da Netflix, muito mais que a soma dos outros dois serviços. É curioso que exista pouquíssima interseção entre as plataformas: apenas 17 títulos estão presentes tanto na Netflix como no Amazon Prime Video.

Bônus: Diagrama de Venn

Outra forma de visualizar os resultados acima é por meio de um diagrama de Venn:

lst <- tbl_jw_principais %>% 
  distinct(tconst, provider_name) %>% 
  split(.$provider_name) %>% 
  map("tconst")

gplots::venn(lst)

Conclusão

Usando o universo dos 5000 melhores títulos de filmes e seriados de acordo com o IMDB, a Netflix é bem superior às concorrentes no Brasil.

A equação mais perigosa do mundo e o efeito do tamanho da amostra nos resultados

Sun, 01 Jul 2018 00:00:00 +0000

Introdução

Nesta thread no subreddit de Data Science, um usuário fez o seguinte comentário:

So basically, I was asked to make inference on 10 people and expect those to generalize to the entire study population. I said the study was poorly designed, and that if I made up random numbers we would do a better job of understanding the customer base.

É muito comum pessoas que não são muito familiares com conceitos de inferência estatística ignorar o fato de que tomar conclusões a partir de amostras muito pequenas pode ser bastante perigoso.

Neste artigo escrito por Howard Wainer (Aviso: Link para PDF), são citados dois motivos para que uma equação possa ser perigosa: o fato de elas serem conhecidas e o fato de elas serem desconhecidas. A equação de Moivre, que descreve o desvio padrão da distribuição amostral da média, se encontra no segundo caso:

$\sigma_{\bar{x}}= \frac{\sigma}{\sqrt{n}}$

Onde $\sigma_{\bar{x}}$ é o erro padrão da média, $\sigma$ o desvio padrão da amostra e $n$ o tamanho da amostra. Em outras palavras, dado que $\sigma$ é um parâmetro conhecido, quanto menor o tamanho da amost, maior será erro da estimativa, que corresponde a variação da média amostral em relação à média da população. O paper inteiro é muito bom e fácil de ler, então recomendo a leitura.

O objetivo deste post é um exercício simples para mostrar o efeito do tamanho da amostra na variabilidade dos resultados, mesmo quando se sabem os valores verdadeiros dos parâmetros de toda a população.

Geração dos dados por simulação

library(tidyverse)

O primeiro passo é gerar uma população de dados cujos parâmetros são conhecidos. Aqui, duas variáveis aleatórias ´x´ e ´y´ são definidas, em que x é uma variável aleatória e ´y´ deriva de x, com algum ruído:

n <- 1e5
set.seed(123)
x <- rnorm(n, mean = 0, sd = 0.5)
y <- 2 * x + 5 + rnorm(n, mean = 0, sd = 0.25)

df <- data.frame(x = x, y = y)

mod_populacao <- lm(y ~ x, data = df)
summary(mod_populacao)

## 
## Call:
## lm(formula = y ~ x, data = df)
## 
## Residuals:
##     Min      1Q  Median      3Q     Max 
## -1.0972 -0.1685 -0.0002  0.1683  1.0506 
## 
## Coefficients:
##              Estimate Std. Error t value Pr(>|t|)    
## (Intercept) 5.0013045  0.0007937    6302   <2e-16 ***
## x           1.9986648  0.0015877    1259   <2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Residual standard error: 0.251 on 99998 degrees of freedom
## Multiple R-squared:  0.9406, Adjusted R-squared:  0.9406 
## F-statistic: 1.585e+06 on 1 and 99998 DF,  p-value: < 2.2e-16

Como esperado, a partir do modelo de regressão obtido acima a partir da população de parâmetros são conhecidos que o processo de geração da variável resposta ´y´ pode ser representado pela equação abaixo:

$y = 2x + 5 + \epsilon$

O histograma dos resíduos do modelo é mais uma evidência de que o modelo obtido possui boas propriedades:

hist(resid(mod_populacao),
     main = "Distribuição dos resíduos do modelo da população",
     xlab = NULL)

Assim, se tirarmos uma amostra da população e criarmos um modelo $y = f(x)$, os parâmetros do modelo dessa amostra serão os mesmos ou próximos ao da população, correto? Depende de seu tamanho.

Geração das amostras

A função abaixo cria 1000 amostras de tamanho sample_size do dataframe df dos dados da população e, para cada uma das amostras, ajusta um modelo de regressão linear, extrai o coeficiente de x da regressão e retorna um dataframe com os resultados:

coef_x_sample <- function(sample_size){
  repl <- purrr::rerun(1000, sample_n(df, sample_size))
  
  vec_coef_x <- repl %>% 
    map(~ lm(y ~ x, data = .)) %>% 
    map_dbl(~ coef(.)["x"])
  
  data.frame(size = sample_size, coef_x = vec_coef_x)
}

# exemplo
set.seed(123)
head(coef_x_sample(10))

##   size   coef_x
## 1   10 2.065196
## 2   10 2.320681
## 3   10 2.142100
## 4   10 2.069578
## 5   10 2.036510
## 6   10 1.704862

Nas 6 primeiras amostras de tamanho 10, o coeficiente de x foi desde 1,70 a 2,32, mostrando uma certa variabilidade.

O código abaixo repete o processo acima para valores diferentes do tamanho da amostra:

vec_samp_size <- c(5, 10, 15, 20, 50, 75, 100, 150, 200, 250, 500, 750, 1000, 5000)

df_result <- vec_samp_size  %>% map_dfr(coef_x_sample)

df_result <- df_result %>% 
  mutate(size = factor(size, levels = vec_samp_size))

Análise dos resultados

Vários gráficos podem ser feitos para ilustrar os resultados da variabilidade do parâmetro da regressão em funcão do tamanho da amostra, como o boxplot abaixo:

df_result %>% 
  ggplot(aes(x = size, y = coef_x)) + 
  geom_boxplot() + 
  scale_y_continuous(breaks = seq(-4, 4, by = 1)) + 
  labs(x = NULL, y = NULL,
       title = "Variabilidade do coeficiente de x em função do tamanho da amostra") + 
  theme_minimal()

O gráfico acima mostra que, apesar de a mediana ser aproximadamente 2 em todos os tamanhos amostrais testados, a variabilidade é muito maior nas menores amostras. A medida que se aumenta o número de indivíduos na amostra, a distribuição dos resultados converge para o valor verdadeiro. Para amostras de 5 indivíduos, foram observados resultados no seguinte intervalo:

# intervalo para menor tamanho amostral
range(df_result$coef_x[df_result$size == "5"])

## [1] 0.3693973 3.6749739

# intervalo para maior tamanho amostral
range(df_result$coef_x[df_result$size == "5000"])

## [1] 1.973962 2.022880

Ou seja, mesmo que uma amostra seja oriunda de uma população descrita por parâmetros já determinados, usar resultados de uma amostra pequena pode levar a conclusões erradas.

Análise e simulação de investimentos com o pacote calcCidadao

Sat, 09 Jun 2018 00:00:00 +0000

Calculadora do Cidadão

Devido a um fenômeno econômico chamado de Inflação, o valor do dinheiro muda com o tempo. R\$100,00 hoje não possuem o mesmo valor monetário ou poder de compra que R\$100,00 daqui a 10 anos, ou mesmo 10 anos atrás. Uma técnica que pode ser usada para corrigir esse efeito é a de deflacionar esses valores, como mostrado neste post do blog Análise Macro. Um outro serviço que pode ser usado é a Calculadora do Cidadão, um produto desenvolvido pelo Banco Central do Brasil para facilitar o trabalho das pessoas que desejam corrigir valores pela inflação de maneira muito simples: Basta adicionar os dados nesta página de data inicial, data final e valor a ser corrigido. A ferramenta então informará o índice de correção no período, o valor percentual correspondente e o valor corrigido na data final. Assim, descobrimos que, por exemplo, R\$1,00 em Janeiro de 2008 equivale a R\$1,81 em Janeiro de 2018, de acordo com o IPCA-E, índice desenvolvido pelo IBGE.

Além da correção de valores pela inflação, a Calculadora do Cidadão fornece outros serviços de atualização de valores monetários, como:

TR: Taxa Referencial. Taxa obtida a partir das médias dos CDBs de 30 dias a taxas pré-fixadas praticadas por bancos comerciais.
Poupança: Os rendimentos da poupança são creditados mensalmente, na data equivalente à data de aplicação (data-base). Dessa forma, se uma aplicação na poupança for resgatada antes de chegar à sua primeira data-base, não fará jus a qualquer correção, e o valor final será igual ao inicial.
Selic: Utiliza para correção a taxa apurada no Selic. Esta taxa é obtida mediante o cálculo da taxa média ponderada e ajustada das operações de financiamento por um dia, lastreadas em títulos públicos federais e cursadas no referido sistema ou em câmaras de compensação e liquidação de ativos, na forma de operações compromissadas.
CDI: Depósito Interfinanceiro. É uma operação realizada exclusivamente entre instituições financeiras, para permitir a troca de reservas bancárias entre elas. Tem registro no CETIP - Câmara de Custódia e Liquidação. Foi autorizada pelo Decreto-Lei nº 2.284/86 e regulamentada pela Resolução nº 1.647/89. A taxa do CDI é calculada como a média das taxas das operações registradas, ponderadas pelos volumes negociados, em determinado dia útil.

Uma das utilizações dessas ferramentas é poder saber, por exemplo, quanto uma aplicação de R\$1000,00 teria rendido nessas diferentes modalidades de renda fixa em um determinado período no passado.

Pensando em todas essas utilidades da Calculadora do Cidadão, eu criei há um tempo o pacote calcCidadao, cujo objetivo é automatizar as consultas de tais informações na plataforma do BCB. Um ponto negativo do pacote é que, como o Banco Central não fornece uma API para a Calculadora do Cidadão, as funções do calcCidadao funcionam por meio de Web Scraping, o que pode tornar o código lento para muitas requisições (não é a toa que eu paralelizei as iterações neste post). Neste post, darei uma sugestão de como o pacote pode ser usado na análise de investimentos.

Funções básicas do pacote

library(tidyverse)
library(calcCidadao)
library(lubridate)
library(quantmod)
library(furrr)

O pacote possui uma função para cada tipo de correção fornecida pela Calculadora do Cidadão:

ls("package:calcCidadao")

## [1] "inflation_indices" "return_cdi"        "return_inflation" 
## [4] "return_poupanca"   "return_selic"      "return_tr"

inflation_indices é uma função que retorna os nomes e códigos dos índices de inflação que podem ser usados como input na função return_inflation:

print(inflation_indices())

##             IGP-M            IGP-DI              INPC             IPC-A 
##      "00189IGP-M"     "00190IGP-DI"       "00188INPC"      "00433IPC-A" 
##            IPCA-E        IPC-BRASIL            IPC-SP 
##      "10764IPC-E" "00191IPC-BRASIL"     "00193IPC-SP"

Para corrigir um valor de 10 anos atrás de acordo com o IPCA-E, fazemos assim:

d1 <- as.Date("2008-01-01")
d2 <- as.Date("2018-01-01")

return_inflation("IPCA-E", start_date = d1, end_date = d2)

## [1] 1.811145

O fator de correção do IPCA-E no período é de 1,811145. Assim, R\$1000 em 01/01/2008 valiam o equivalente a R\$1811,45 10 anos depois.

O mesmo pode ser feito com os índices de renda fixa. Quanto o CDI e a Selic renderam a mais que a Poupança nesse mesmo período?

renda_fixa_10_anos <- c(
  return_cdi(d1, d2),
  return_selic(d1, d2),
  return_poupanca(d1, d2)
  )

renda_fixa_10_anos

## [1] 2.785752 2.801270 2.009103

Os resultados acima mostram algo que já é sabido: A poupança é um investimento muito pior que investimentos atrelados a CDI e Selic (a não ser que a taxa seja muito ruim).

Estudo de caso para o pacote: Análise de um Título Pré-Fixado

Em um fórum de investimentos que participo, havia uma discussão sobre como avaliar a “qualidade” de um título CDB pré-fixado de um prazo relativamente longo, como 6 anos. Mesmo que a taxa seja atrativa (um rendimento de 14% ao ano pode fazer o capital investido dobrar no período), 6 anos é um prazo muito longo em um país onde até o passado é imprevisível. É natural surgir perguntas como E se a inflação acumulada no período for maior? ou E se um título pós-fixado a 100% do CDI render mais, me fazendo ter um custo de oportunidade?.

De fato, a não ser que você trabalhe na Empiricus, não dá para saber como estará a Selic e a inflação ao longo dos próximos 6 anos. É simplesmente impossível prever variáveis tão complexas em um período tão distante no período no futuro. Contudo, é possível ter alguma noção desses valores a partir de simulação de rendimentos passados do mesmo intervalo de tempo.

Vamos então tomar como exemplo um produto que eu recebi por e-mail da Easynvest: um CDB prefixado de 15,07% ao ano do Banco Pine com prazo de 6 anos. Para calcular seu retorno líquido ao final do período, basta usar uma fórmula de juros compostos:

juros_compostos <- function(i, t, imposto){
  bruto <- (1 + i)^t - 1
  liquido <- bruto * (1 - imposto)
  liquido
  }
# taxa de 15.07%aa para 6 anos, considerando 15% de IR
retorno_cdb <- juros_compostos(0.1507, 6, 0.15)
retorno_cdb

## [1] 1.123293

# montante liquido no resgate para um capital de 1000 reais
valor_liquido_cdb <- round(1000 * (1 + retorno_cdb), 2)

Como vimos, o CDB mais que dobra o dinheiro investido no período. Mas será que isso é suficiente para bater a inflação e o CDI? Isso pode ser respondido por meio de simulação.

O método da simulação consiste em obter o retorno desses indicadores para cerca de 200 pares de datas com 6 anos de diferença entre elas.

# data para gerar vetor de datas para tras
data_base <- floor_date(today() - 31, "month")

qtd_sim <- 200

# gerar vetor de datas começando  no primeiro dia de cada mes
d1 <- d2 <- sort(unique(floor_date(data_base - ddays(seq_len(qtd_sim) * 30), "month")))
# descontar para a data inicial 6 anos
year(d1) <- year(d1) - 6 
# exemplo de como ficou
head(tibble(d1, d2))

## # A tibble: 6 x 2
##   d1         d2        
##   <date>     <date>    
## 1 1995-11-01 2001-11-01
## 2 1995-12-01 2001-12-01
## 3 1996-01-01 2002-01-01
## 4 1996-02-01 2002-02-01
## 5 1996-03-01 2002-03-01
## 6 1996-04-01 2002-04-01

Temos então dois vetores de datas d1 e d2 em que $d{_2}_t \simeq (365 * 5) + d{_1}_t$. Esses serão usados como inputs das funções do calcCidadao.

Como são muitas requisições, o processo pode ser bem lento. Por isso, eu uso o pacote furrr para paralelizar as iterações:

plan(multiprocess)
inflacao_6 <-  furrr::future_map2_dbl(
  d1, d2, ~return_inflation("IPCA-E", start_date = .x, end_date = .y),
  .progress = FALSE)

cdi_6 = furrr::future_map2_dbl(
  d1, d2, ~return_cdi(start_date = .x, end_date = .y),
  .progress = FALSE)

# salvar resultados em um tibble
df_results <- tibble(
  data_aplicacao = d1,
  data_resgate = d2,
  # no caso dos valores extraidos pelas funcoes do calcCidadao,
  # nao eh necessario somar 1, visto que as funcoes ja retornam
  # o indice de correcao
  valor_corrigido_ipca = round(1000 * inflacao_6, 2),
  valor_corrigido_cdi =  round(1000 * cdi_6, 2)
)

head(df_results)

## # A tibble: 6 x 4
##   data_aplicacao data_resgate valor_corrigido_ipca valor_corrigido_cdi
##   <date>         <date>                      <dbl>               <dbl>
## 1 1995-11-01     2001-11-01                  1498.               3603.
## 2 1995-12-01     2001-12-01                  1484.               3552.
## 3 1996-01-01     2002-01-01                  1473.               3506.
## 4 1996-02-01     2002-02-01                  1456.               3471.
## 5 1996-03-01     2002-03-01                  1445.               3435.
## 6 1996-04-01     2002-04-01                  1447.               3407.

Já que estamos falando de comparação de investimentos, por que não incluir também a renda variável no estudo? O código abaixo extrai preços de fechamento ajustados do IBOVESPA, agrega os dados pelo primeiro dia de operação de cada mês, e calcula o “valor corrigido” usando o preço de fechamento ajustado após 72 meses.

ibov <- quantmod::getSymbols("^BVSP", from = min(d1), auto.assign = FALSE)
head(Ad(ibov))

##            BVSP.Adjusted
## 1995-11-01        4099.8
## 1995-11-02            NA
## 1995-11-03        4158.8
## 1995-11-06        4094.3
## 1995-11-07        4111.2
## 1995-11-08        4117.1

df_ibov <- tibble(date = index(ibov), price = as.numeric(Ad(ibov))) %>% 
  na.omit() %>% 
  group_by(mes = floor_date(date, "month")) %>% 
  filter(date == min(date)) %>% 
  ungroup() %>% 
  mutate(fator_ibov = dplyr::lead(price, 72)/price,
         valor_corrigido_ibov = round(1000 * fator_ibov, 2)) %>% 
  select(data_aplicacao = mes, valor_corrigido_ibov)

# juntar em um dataframe so
df_completo <- left_join(df_results, df_ibov, by = "data_aplicacao")
names(df_completo)[3:5] <- str_remove_all(names(df_completo)[3:5], "valor_corrigido_")

df_completo[1,]

## # A tibble: 1 x 5
##   data_aplicacao data_resgate  ipca   cdi  ibov
##   <date>         <date>       <dbl> <dbl> <dbl>
## 1 1995-11-01     2001-11-01   1498. 3603. 2778.

No exemplo acima, apenas a inflação não foi superior ao nosso CDB prefixado de exemplo: Tanto o CDI como o IBOV eram opções melhores (partindo do pressuposto que em 01/11/1995 você era capaz de prever tais índices 6 anos depois).

O gráfico abaixo ilustra a distribuição dos resultados de cada índice comparado com o CDB de interesse:

df_completo %>% 
  gather(indice, novo_valor, ipca:ibov) %>% 
  ggplot(aes(x = novo_valor)) + 
  geom_histogram(binwidth = 100) + 
  geom_vline(xintercept = valor_liquido_cdb, color =  "red", linetype = "dashed") + 
  facet_wrap(~ indice, scales = "fixed", ncol = 1) + 
  theme_minimal() + 
  labs(x = "Valor corrigido líquido (R$)", y = NULL,
       title = "CDI, IBOV e Inflação vs. CDB Prefixado de 15,07% a.a.",
       subtitle = "Prazo de 6 anos")

O gráfico acima mostra que esse CDB prefixado pode não ser um investimento tão bom assim. Muitas vezes o CDI e o IBOV trouxeram resultados melhores para o mesmo intervalo de 6 anos. Numericamente, os resultados são:

df_completo %>% 
  summarise_at(vars(ipca:ibov), ~ mean(.x >= valor_liquido_cdb, na.rm = TRUE))

## # A tibble: 1 x 3
##    ipca   cdi  ibov
##   <dbl> <dbl> <dbl>
## 1    0. 0.533 0.487

Ou seja: o CDI e o IBOV foram melhores que o CDB em 53,3% e 48,7% das vezes, respectivamente. Levando em conta que o Ibovespa se trata de renda variável e apresenta um risco maior (levando em conta que o CDB possui proteção do FGC), pode-se dizer que o resultado do CDB é aceitável em comparação com a bolsa de valores.

Será que a distribuição desses resultados é uniforme com o tempo? Certamente não, visto que tanto o Ibovespa quanto a taxa Selic (que apresenta resultados muito parecidos com o CDI) variaram muito desde 1995. Por isso a utilidade do gráfico abaixo:

df_completo %>% 
  gather(indice, novo_valor, ipca:ibov) %>% 
  ggplot(aes(x = data_aplicacao, y = novo_valor)) + 
  geom_line(aes(color = indice)) + 
  geom_hline(yintercept = valor_liquido_cdb, linetype = "dashed") +
  geom_hline(yintercept = 1000, linetype = "dotted") +
  theme_minimal()  +  
  scale_x_date(date_breaks = "1 year", date_labels = "%Y") +
  scale_y_continuous(breaks = scales::pretty_breaks(n = 6)) +
  annotate("rect", fill = "red", alpha = 0.15,
           xmin = as.Date(-Inf), xmax = as.Date(Inf),
           ymin = -Inf, ymax = 1000) +
  labs(x = NULL, y = "R$",
       title = "Valor de R$ 1000 corrigido por diferentes índices",
       subtitle = "Resultados em função da data de aplicação apos um período de 6 anos") + 
  theme(panel.grid.minor.x = element_blank())

O que o gráfico acima mostra é que observar os resultados levando em conta o fator tempo muda completamente a interpretação: a partir do fim de 2005, nenhum investimento tem proporcionado um rendimento líquido superior ao CDB préfixado de 15,07% ao ano. Outra observação interessante a partir do gráfico é comprovar que a bolsa de valores é muito mais volátil que a renda fixa, chegando em alguns momentos a ficar abaixo da inflação ou até a dar prejuízo ao investidor.

Conclusão

Espero que este post tenha sido útil não só para mostrar o potencial de aplicação do pacote calcCidadao mas também para propor uma nova abordagem na análise de investimentos. De fato, retornos passados não indicam retornos futuros, ainda mais se tratando de indicadores financeiros. Contudo, uma simples análise probabilística pode ajudar a dirimir algumas incertezas na consideração de investimentos.

Mapeando a abertura de escolas municipais em São Paulo ao longo dos anos com um GIF

Mon, 14 May 2018 00:00:00 +0000

Pessoas adoram mapas. Sempre que puder fazer mapas para representar visualmente uma determinada informação, faça!

Suponha que você deseja fazer uma visualização da taxa de homicídio por estados brasileiros. Nada te impede de fazer um gráfico de barras, onde cada UF seria representado por uma barra cujo tamanho seria dependente do valor da taxa, mas teria um impacto visual menor em que cada estado estaria colorido de acordo com essa variável.

Contudo, em algumas situações, um mapa é a única maneira possível de transmitir com clareza uma ideia. Esta é a ideia deste post: mostrar como um mapa pode ser útil para mostrar a evolução das abertudas de escolas municipais na cidade de São Paulo.

Coleta e limpeza dos dados

Eu já tive a oportunidade de participar de uma palestra do pessoal da Secretaria Municipal de Educação de São Paulo, onde conheci suas iniciativas de dados abertos. Esses projetos são benéficos não só para a população como um todo, por toda a questão da transparência, mas especialmente para quem deseja desenvolver projetos para praticar análise de dados, ganhando assim experiência real para lidar com tarefas de limpeza, manuseio e visualização de dados.

O dataset de interesse deste post é o Cadastro de escolas municipais, conveniadas e privadas.

# pacotes
library(tidyverse)
library(ggmap)
library(gganimate)
library(lubridate)

# definir locale para lidar com caracteres especiais
lcl <- locale(encoding = "ISO-8859-1")
df <- read_csv2("/home/sillas/R/Projetos/paixaopordados-blogdown/data/escolasr34dez2017.csv",
                locale = lcl)

# dimensoes do dataset
dim(df)

## [1] 6878   53

O dataset possui 53 colunas, mas só precisamos de realmente 3: as colunas de coordenadas geográficas e a de data de fundação das escolas.

df <- df %>% 
  select(DATA = DT_CRIACAO, LAT = LATITUDE, LON = LONGITUDE)

knitr::kable(head(df))

DATA	LAT	LON
13-jun-88	-23553905	-46398452
04-jul-88	-23489728	-46670198
05-jul-88	-23478312	-46427344
27-mai-88	-23612237	-46749888
22-jun-88	-23486142	-46733901
07-jun-88	-23611929	-46750176

O output acima revela a necessidade de alguns ajustes de limpeza: converter a coluna DATA para a classe Date e dividir as colunas de latitude e longitude por um milhão para obter os valores corretos.

A transformação da coluna DATA poderia ser feita por funções automáticas, como a strptime, mas isso dependeria de algumas configurações internas do seu sistema operacional. Por isso, eu uso uma solução mais manual:

converter_mes <- function(x){
  nomes <- c("jan", "fev", "mar", "abr", "mai", "jun",
             "jul", "ago", "set", "out", "nov", "dez")
  
  numeros <- str_pad(1:12, width = 2, pad = "0")
  
  x <- str_replace_all(x, nomes[1], numeros[1])
  x <- str_replace_all(x, nomes[2], numeros[2])
  x <- str_replace_all(x, nomes[3], numeros[3])
  x <- str_replace_all(x, nomes[4], numeros[4])
  x <- str_replace_all(x, nomes[5], numeros[5])
  x <- str_replace_all(x, nomes[6], numeros[6])
  x <- str_replace_all(x, nomes[7], numeros[7])
  x <- str_replace_all(x, nomes[8], numeros[8])
  x <- str_replace_all(x, nomes[9], numeros[9])
  x <- str_replace_all(x, nomes[10], numeros[10])
  x <- str_replace_all(x, nomes[11], numeros[11])
  x <- str_replace_all(x, nomes[12], numeros[12])
  
  x
  
}

Escrita a função, passo para a transformação das colunas:

df <- df %>% 
  mutate(DATA_CLEAN = dmy(converter_mes(DATA)),
         LAT = LAT/1e6,
         LON = LON/1e6
         ) %>% 
  mutate(ANO = year(DATA_CLEAN)) %>% 
  # remover linhas onde LAT ou LON é NA
  na.omit()

summary(df)

##      DATA                LAT              LON           DATA_CLEAN        
##  Length:4576        Min.   :-23.89   Min.   :-47.05   Min.   :1969-01-30  
##  Class :character   1st Qu.:-23.63   1st Qu.:-46.71   1st Qu.:2004-10-24  
##  Mode  :character   Median :-23.57   Median :-46.63   Median :2011-10-23  
##                     Mean   :-23.57   Mean   :-46.60   Mean   :2008-10-17  
##                     3rd Qu.:-23.51   3rd Qu.:-46.48   3rd Qu.:2015-05-08  
##                     Max.   :-22.89   Max.   :-46.37   Max.   :2068-12-12  
##       ANO      
##  Min.   :1969  
##  1st Qu.:2004  
##  Median :2011  
##  Mean   :2008  
##  3rd Qu.:2015  
##  Max.   :2068

Surgiu um novo erro: a coluna ANO possui valores acima do ano atual (2018). Isso provavelmente foi causado na conversão de datas como 30/08/68, que o R retornou 2068 ao invés de 1968. Sinceramente, não parei para investigar o motivo disso, até porque é facilmente consertado:

df <- df %>% 
  mutate(ANO = if_else(ANO > year(today()), ANO - 100, ANO))

Apresentação dos dados

Primeiramente, qual a distribuição da abertura de novas escolas por ano?

df %>% 
  count(ANO) %>% 
  ggplot(aes(x = ANO, y = n)) + 
  geom_col(fill = "darkorange1") + 
  theme_minimal() +
  labs(x = NULL, y = NULL,
       title = "Quantidade de escolas fundadas por ano em São Paulo") +
  scale_x_continuous(breaks = scales::pretty_breaks(n = 10))

A grande maioria das escolas foi criada a partir do ano de 2005. Confesso que esperava uma distribuição mais uniforme.

Criando o mapa

Existem diversas maneiras de criar um mapa no R. O melhor método depende basicamente do tipo de dados que se tem em mãos. Caso seja necessário, por exemplo, plotar polígonos, áreas e fronteiras, o indicado é o combo do pacote sf e da função ggplot2::geom_sf. No nosso caso, como estamos interessados em plotar pontos e já possuímos os dados das coordenadas geográficas, uma das melhores opções é usar o pacote ggmap.

Para criar um mapa, são necessários dois parâmetros iniciais: um ponto central e um nível de zoom, que define a escala do gráfico.

# para o centro de sp, usei as coordenadas da praca da se, que peguei no google maps
praca_se <- c(lon = -46.634123, lat = -23.548408)
# o zoom é calculado pela funcao calc_zoom do ggmap
zoom_sp <- calc_zoom(lon = LON, lat = LAT, data = df)

Apenas com esses dois parâmetros, já é possível plotar um mapa base:

mapa_sp <- get_map(location = praca_se,
                   zoom = zoom_sp,
                   maptype = "toner-lite")

ggmap(mapa_sp) +
  # plotar praça da sé
  geom_point(x = praca_se[1], y = praca_se[2], color = "red")

Vamos então adicionar um pouco de vida ao gráfico e plotar todas as escolas presentes no dataset:

ggmap(mapa_sp) +
  geom_point(data = df, aes(x = LON, y = LAT),
             color = "red", alpha = 0.1)

Aparantemente existe uma concentração de escolas perto, entre outras, da área de Itaquaquecetuba. Uma maneira de visualizar densidade de pontos é por meio do geom_density2d:

ggmap(mapa_sp) +
  geom_density2d(data = df, aes(x = LON, y = LAT),
                 color = "red")

Acrescentando o elemento tempo no mapa

Ainda não mostrei como representar o fator tempo na visualização. Penso que isto pode ser feito de três maneiras: colorir as escolas de acordo com o ano de fundação, separar o gráfico em facets por ano ou, minha preferida, criar um gif composto por uma série de gráficos sobrepostos. Fazer isso é muito fácil com o auxílio do pacote gganimate:

Para criar uma sobreposição de gráficos ggplot com o pacote gganimate, basta setar a aesthetic especial frame com o nome da variável que você deseja usar para separar os gráficos em unidades individuais. O argumento cumulative é usado para que as escolas de anos mais recentes permaneçam no gráfico ao longo dos anos:

p <- ggmap(mapa_sp) +
  geom_point(data = df,
             aes(x = LON, y = LAT, frame = ANO,
                 cumulative  = TRUE), color = "red", alpha = 0.1) + 
  labs(x = NULL, y = NULL, title = "Escolas em São Paulo em ")

# o argumento interval define o intervalo de transição do gif em segundos
gganimate(p = p, interval = .075)

Taí! Com o auxílio do gráfico, é possível perceber (pelo menos foi o que vi, vai que é uma miragem) que, de acordo com o dataset, nas primeiras décadas foram priorizadas as áreas mais periféricas de São Paulo. A região mais central aparenta ter recebido mais escolas apenas a partir das últimas duas décadas.

Topic Modeling: Um algoritmo consegue entender sobre o que fala a youtuber Nathalia Arcuri?

Sat, 14 Apr 2018 00:00:00 +0000

No meu último post sobre Mineração de Texto, usei algumas ferramentas do R para analisar textos clássicos da literatura brasileira. Desta vez, o foco da análise será algo mais contemporâneo: uma youtuber. Mais precisamente, a Nathalia Arcuri, responsável por um dos principais canais de educação financeira, o Me Poupe.

Além do objeto da análise, a abordagem aqui também é diferente: vou mostrar como Topic Modeling pode ser usado para descobrir temas gerais em um conjunto de dados textuais.

Assim, este post se dedica ao seguinte problema de pesquisa: é possível identificar, por meio de um algoritmo de inteligência artificial, temas gerais que uma youtuber com mais de 300 vídeos publicados fala sobre?

library(reticulate)
reticulate::use_python("/home/sillas/anaconda3/bin/python", required = TRUE)
library(lexiconPT)
library(tidytext)
library(tidyverse)
library(magrittr)
library(stm)
library(tm)
library(ggridges)
library(formattable)
options(scipen = 999)

Coleta dos dados

Para analisar o conteúdo de vídeos de youtube, precisamos das legendas dos vídeos. Alguns (bem poucos) canais produzem suas próprias legendas manualmente, mas a grande maioria, como o Me Poupe, o canal da Nathalia Arcuri, não o faz. Sendo assim, precisamos nós mesmo produzir essas legendas.

Isso seria uma tarefa muito árdua, mas felizmente o próprio Youtube tem seu próprio serviço de inteligência artifical de reconhecimento de fala, que cria automaticamente legendas para um vídeo. Apesar de algumas vezes as legendas produzidas pelo algoritmo do Youtube não serem muito fiéis, elas serão usadas como dados brutos para a modelagem por tópicos. Os resultados apresentados no post mostram que essas legendas automáticas podem sim serem usadas para fins de estudo.

Para coletar as legendas dos vídeo, eu uso um utilitário de linha de comando chamado youtube-dl, que é bem simples de usar. No código abaixo, que mistura R com shell script, eu mostro como montar uma query para baixar as legendas do vídeo em arquivos de texto cujos nomes contem alguns metadados do vídeo, descritos na variável fields_raw. Caso você deseje realizar este mesmo estudo com outro youtuber, basta atribuir a url do canal na variável channel_url.

fields_raw <- c("id", "title", "alt_title", "creator", "release_date",
                "timestamp", "upload_date", "duration", "view_count",
                "like_count", "dislike_count", "comment_count")

fields <- fields_raw %>% 
  map_chr(~paste0("%(", ., ")s")) %>% 
  # usar &&& como separador de fields
  paste0(collapse = "&&&") %>% 
  # acrescentar aspas no inicio e no final do string
  paste0('"', ., '"')

# canal do me poupe
channel_url <- "https://www.youtube.com/channel/UC8mDF5mWNGE-Kpfcvnn0bUg"

# montar query (comando) do youtube-dl
cmd_ytdl <- str_glue("youtube-dl -o {fields} -i -v -w --skip-download --write-auto-sub --sub-lang pt {channel_url}")

# acrescentar diretorio
pasta_captions <- "/home/sillas/R/Projetos/paixaopordados-blogdown/data/mepoupe"
fs::dir_create(pasta_captions)
cmd <- str_glue("cd {pasta_captions} && {cmd_ytdl}")

# imprimir comando para ver como ficou
cat(cmd)

## cd /home/sillas/R/Projetos/paixaopordados-blogdown/data/mepoupe && youtube-dl -o "%(id)s&&&%(title)s&&&%(alt_title)s&&&%(creator)s&&&%(release_date)s&&&%(timestamp)s&&&%(upload_date)s&&&%(duration)s&&&%(view_count)s&&&%(like_count)s&&&%(dislike_count)s&&&%(comment_count)s" -i -v -w --skip-download --write-auto-sub --sub-lang pt https://www.youtube.com/channel/UC8mDF5mWNGE-Kpfcvnn0bUg

Portanto, temos o comando para baixar as legendas dos vídeos na pasta indicada. Para rodar o comando, basta a variável cmd como argumento da função system() ou o copiar e colar no terminal.

Uma amostra dos arquivos baixados:

dir(pasta_captions)[1:3]

## [1] "039orzgCUt0&&&10 DILEMAS MAIS FREQUENTES SOBRE TESOURO DIRETO! Tire as dúvidas e invista!&&&NA&&&NA&&&NA&&&NA&&&20170424&&&642&&&272848&&&33970&&&137&&&NA.pt.vtt"                 
## [2] "0bqZrSaitDo&&&PLANILHA DE INDEPENDÊNCIA FINANCEIRA! Aprenda a usar! Série especial_ Office 365 #AjudaaNath&&&NA&&&NA&&&NA&&&NA&&&20170328&&&988&&&260474&&&18439&&&206&&&NA.pt.vtt"
## [3] "0eSSqsHSr2A&&&Série empreendedorismo na veia Ep 3_ EXPERIENTES TAMBÉM FALHAM!&&&NA&&&NA&&&NA&&&NA&&&20161225&&&282&&&32361&&&2307&&&21&&&NA.pt.vtt"

Limpeza dos dados

O Youtube tem um formato próprio de arquivos para legendas chamado vtt. Veja como são os arquivos de texto baixados na etapa anterior:

arquivos_captions <- dir(pasta_captions, pattern = '*.vtt', full.names = TRUE)
amostra <- arquivos_captions[1]

read_lines(amostra)[1:30]

##  [1] "WEBVTT"                                                                                                                                                                                                    
##  [2] "Kind: captions"                                                                                                                                                                                            
##  [3] "Language: pt"                                                                                                                                                                                              
##  [4] "Style:"                                                                                                                                                                                                    
##  [5] "::cue(c.colorCCCCCC) { color: rgb(204,204,204);"                                                                                                                                                           
##  [6] " }"                                                                                                                                                                                                        
##  [7] "::cue(c.colorE5E5E5) { color: rgb(229,229,229);"                                                                                                                                                           
##  [8] " }"                                                                                                                                                                                                        
##  [9] "##"                                                                                                                                                                                                        
## [10] ""                                                                                                                                                                                                          
## [11] "00:00:00.000 --> 00:00:02.419 align:start position:0%"                                                                                                                                                     
## [12] " "                                                                                                                                                                                                         
## [13] "olha<00:00:00.329><c> o</c><00:00:00.420><c> data</c><c.colorE5E5E5><00:00:00.840><c> mtow</c><00:00:01.260><c> que</c><00:00:01.350><c> apurou</c><00:00:01.709><c> que</c><00:00:01.979><c> esta</c></c>"
## [14] ""                                                                                                                                                                                                          
## [15] "00:00:02.419 --> 00:00:02.429 align:start position:0%"                                                                                                                                                     
## [16] "olha o data<c.colorE5E5E5> mtow que apurou que esta"                                                                                                                                                       
## [17] " </c>"                                                                                                                                                                                                     
## [18] ""                                                                                                                                                                                                          
## [19] "00:00:02.429 --> 00:00:04.640 align:start position:0%"                                                                                                                                                     
## [20] "olha o data<c.colorE5E5E5> mtow que apurou que esta</c>"                                                                                                                                                   
## [21] "<c.colorCCCCCC>pergunta</c><c.colorE5E5E5><00:00:03.210><c> este</c><00:00:03.389><c> dilema</c><00:00:03.780><c> é</c><00:00:04.170><c> o</c><00:00:04.259><c> mais</c></c>"                              
## [22] ""                                                                                                                                                                                                          
## [23] "00:00:04.640 --> 00:00:04.650 align:start position:0%"                                                                                                                                                     
## [24] "<c.colorCCCCCC>pergunta</c><c.colorE5E5E5> este dilema é o mais"                                                                                                                                           
## [25] " </c>"                                                                                                                                                                                                     
## [26] ""                                                                                                                                                                                                          
## [27] "00:00:04.650 --> 00:00:06.650 align:start position:0%"                                                                                                                                                     
## [28] "<c.colorCCCCCC>pergunta</c><c.colorE5E5E5> este dilema é o mais</c>"                                                                                                                                       
## [29] "<c.colorE5E5E5>freqüente<00:00:05.190><c> de</c><00:00:05.310><c> tudo</c><00:00:05.700><c> o</c><00:00:05.790><c> que</c></c><c.colorCCCCCC><00:00:05.970><c> investiu</c><00:00:06.509><c> uma</c></c>"  
## [30] ""

Temos vários problemas de dados não estruturados aí, como timestamps, formatação de estilo como cor e alinhamento e repetição de frases em diferentes linhas (note como as frases nas linhas 24 e 28 são as mesmas). Entretanto, limpar esses dados é mais simples que se imagina. Segue o passo-a-passo:

Começando pelo mais crítico, vamos remover toda a formatação de legendas do texto, deixando apenas as frases. Para isso, uso um módulo Python (sim, eu me rendi, esta é a primeira vez que uso Python no blog) chamado webvtt:

from webvtt import WebVTT
def caption_to_vector(file):
  x = WebVTT().read(file)
  txt = [caption.text for caption in x]
  return(txt)

Vejam com essa função faz todo o trabalho bruto de limpar os metadados da legenda:

x <- amostra %>% caption_to_vector()
x[1:20]

##  [1] " \nolha o data mtow que apurou que esta"                                      
##  [2] "olha o data mtow que apurou que esta\n "                                      
##  [3] "olha o data mtow que apurou que esta\npergunta este dilema é o mais"          
##  [4] "pergunta este dilema é o mais\n "                                             
##  [5] "pergunta este dilema é o mais\nfreqüente de tudo o que investiu uma"          
##  [6] "freqüente de tudo o que investiu uma\n "                                      
##  [7] "freqüente de tudo o que investiu uma\nvez só ou possa investir todo mês"      
##  [8] "vez só ou possa investir todo mês\n "                                         
##  [9] "vez só ou possa investir todo mês\nfilho olha esse aqui se não ficar nos"     
## [10] "filho olha esse aqui se não ficar nos\n "                                     
## [11] "filho olha esse aqui se não ficar nos\nvídeos em alta do yuan subir é"        
## [12] "vídeos em alta do yuan subir é\n "                                            
## [13] "vídeos em alta do yuan subir é\nmarmelada hoje vou falar para você"           
## [14] "marmelada hoje vou falar para você\n "                                        
## [15] "marmelada hoje vou falar para você\nquais são os dez maiores dilemas de"      
## [16] "quais são os dez maiores dilemas de\n "                                       
## [17] "quais são os dez maiores dilemas de\nquem quer investir no tesouro direto mas"
## [18] "quem quer investir no tesouro direto mas\n "                                  
## [19] "quem quer investir no tesouro direto mas\nainda não sabe muito bem como fazer"
## [20] "ainda não sabe muito bem como fazer\n "

Ainda temos alguns problemas, como as linhas repetidas, mas isso é o de menos. Resolvemos todos os problemas de limpeza de dados com a função abaixo:

limpar_caption <- function(arquivo){
  caption_raw <- caption_to_vector(arquivo)
  n <- length(caption_raw)
  # remover \n das linhas com exceção da ultima
  caption <- c(stringr::str_remove_all(caption_raw[-n], "[\n].*"),
               caption_raw[n])
  # remover duplicatas
  caption <- unique(caption)
  # remover acentos
  caption <- iconv(caption, from = "UTF-8", to = "ASCII//TRANSLIT")
  # juntar todo o vector em um so
  caption <- paste0(caption, collapse = "\n")
  caption
}

# exemplo
# amostra %>% limpar_caption()

Além disso, precisamos também extrair os metadados dos vídeos salvos nos nomes dos arquivos:

# funcao para extrair metadados do video baseado no titulo
extrair_metadados <- function(arquivo, pasta = pasta_captions,
                              fields = fields_raw){
  mat <- str_split(arquivo, "&{3}", simplify = TRUE)
  # substituir elemento da primeira coluna por id (remover pasta do nome)
  mat[1,1] <- mat[1,1] %>% str_remove_all(pasta) %>% str_remove_all("/")
  
  # renomear colunas
  cols <- fields[1:ncol(mat)]
  colnames(mat) <- cols
  as.tibble(mat)
}

Finalmente, a função abaixo cria um dataframe com as colunas de metadados e de legenda, que chamo de caption:

# funcao para juntar tudo num dataframe so
caption_to_df <- function(arquivo, ...){
  
  caption <- limpar_caption(arquivo)
  meta <- extrair_metadados(arquivo, ...)
  meta <- meta %>% mutate(caption = caption)
  
  meta
}

### gerar dataframe para todos os videos
df <- arquivos_captions %>% 
  map_df(caption_to_df) %>% 
  # remover coluna que nao uso
  select(-comment_count) %>% 
  # converter a classe de algumas colunas
  mutate(upload_date = lubridate::ymd(upload_date)) %>% 
  mutate_at(vars(duration:dislike_count), as.numeric)

# vendo como ficou
glimpse(df)

## Observations: 319
## Variables: 12
## $ id            <chr> "039orzgCUt0", "0bqZrSaitDo", "0eSSqsHSr2A", "0G...
## $ title         <chr> "10 DILEMAS MAIS FREQUENTES SOBRE TESOURO DIRETO...
## $ alt_title     <chr> "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", ...
## $ creator       <chr> "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", ...
## $ release_date  <chr> "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", ...
## $ timestamp     <chr> "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", ...
## $ upload_date   <date> 2017-04-24, 2017-03-28, 2016-12-25, 2016-02-15,...
## $ duration      <dbl> 642, 988, 282, 440, 670, 647, 574, 396, 615, 614...
## $ view_count    <dbl> 272848, 260474, 32361, 242366, 262462, 53146, 11...
## $ like_count    <dbl> 33970, 18439, 2307, 13163, 14439, 3868, 9369, 17...
## $ dislike_count <dbl> 137, 206, 21, 371, 453, 89, 110, 176, 87, 149, 1...
## $ caption       <chr> " \nolha o data mtow que apurou que esta\npergun...

Topic Modeling

Antes de partir para o código aplicado a Topic Modeling, uma brevíssima introdução teórica.

No contexto de Text Mining, um tópico $T$ é definido como um conjunto de palavras ou tokens ($w_1, w_2, ... w_n$) onde cada palavra possui uma probabilidade de pertencer a um tópico, e um documento é definido como um conjunto de tópicos, onde cada um possui uma proporção de presença dentro do documento. A soma da proporção de cada tópico dentro de um documento é igual a 1, assim como a soma das probabilidades de cada palavra para um dado tópico, que também é igual a 1. Nesta análise, um documento corresponde a cada vídeo lançado no canal Me Poupe.

Topic Modeling, portanto, é definido como uma ténica não-supervisionada de Machine Learning que busca que identica clusteres ou grupos de palavras que ocorrem juntas, descobrindo assim tópicos abstratos que ocorrem em um conjunto de documentos. O objetivo é descobrir subestruturas semânticas dentro de um conjunto de textos.

Existem alguns algoritmos de Topic Modeling, muitos deles presentes no pacote topicmodels. Apenas devido a preferência pessoal, vou usar neste post o algoritmo Structural Topic Models (STM), presente no pacote stm.

A qualidade de um tópico encontrado por um algoritmo pode ser medida por algumas métricas, como exclusividade e coerência semântica, cuja ideia é que, em um modelo de tópicos que é semanticamente coerente, as palavras que são mais prováveis de pertencer a um tópico devem ocorrer dentro de um mesmo documento. A formulação matemática dessas métricas é razoavelmente mais complicadas que essas explicações. Caso você deseja conhecer essas métricas com mais detalhes, confira as referências no final do post.

Pré-processamento

Mesmo após o processo de limpeza, é necessário realizar alguns pré-processamentos antes de aplicar o algoritmo de Topic Modeling.

Um dos procedimentos necessários é a remoção de stopwords, que são palavras que ocorrem tão frequentemente que não acrescentam nenhum valor semântico a um texto, como “e”, “vai”, “lá”, etc. O pacote tm fornece uma lista de stopwords em vários idiomas, incluindo Português.

O código abaixo retorna as palavras mais faladas nos vídeos do Me Poupe, após a remoção de stopwords:

# stopwords da lingua portuguesa sem acento
sw_pt_tm <- tm::stopwords("pt") %>% iconv(from = "UTF-8", to = "ASCII//TRANSLIT")

# criar dataframe com uma linha por palavra
df_palavra <- df %>% 
  unnest_tokens(palavra, caption) %>% 
  # filtrar fora stopword
  filter(!palavra %in% sw_pt_tm)

df_palavra %>% 
  count(palavra) %>% 
  arrange(desc(n)) %>% 
  head(20) %>% 
  formattable()

palavra	n
vai	5467
gente	3297
porque	3077
aqui	3047
pra	3001
dinheiro	2731
fazer	2373
entao	2256
pode	2119
la	2097
ter	1645
ai	1614
agora	1520
ser	1516
pessoas	1354
canal	1334
vou	1334
hoje	1319
video	1267
tudo	1243

Como muitas dessas palavras não possuem um grande valor semântico para a separação de tópicos, podemos as acrescentar à lista de stopwords.

minhas_sw <- c("vai", "porque", "vou", "ai", "pra", "entao")
sw_pt <- c(minhas_sw, sw_pt_tm)

Partimos então para o processamento de textos com as funções do pacote stm.

proc <- stm::textProcessor(df$caption, metadata = df, language = "portuguese",
                           customstopwords = sw_pt)

## Building corpus... 
## Converting to Lower Case... 
## Removing punctuation... 
## Removing stopwords... 
## Remove Custom Stopwords...
## Removing numbers... 
## Stemming... 
## Creating Output...

out <- stm::prepDocuments(proc$documents, proc$vocab, proc$meta,
                          lower.thresh = 10)

## Removing 14665 of 16857 terms (33357 of 129408 tokens) due to frequency 
## Your corpus now has 319 documents, 2192 terms and 96051 tokens.

Criação do modelo de tópicos e interpretação dos resultados

A quantidade de tópicos $K$ que desejamos extrair dos textos é, na verdade, escolhida pelo ser humano. Não há uma regra precisa que defina o número ótimo de clusteres. No entanto, é possível usar a função stm::searchK para rodar o STM para diferentes valores do parâmetro K para encontrar o valor que otimiza a exclusividade e a coerência semântica do modelo.

storage <- stm::searchK(out$documents, out$vocab, K = c(3:15),
                          data = out$meta)

Após uma inspeção manual, decidi usar $K = 10$ para encontrar 10 tópicos sobre os quais a Nathalia Arcuri mais fala.

fit <- stm(
  documents = out$documents, vocab = out$vocab, data = out$meta,  K = 10,
  max.em.its = 75, init.type = "Spectral", verbose = FALSE
  )

Após a construção do modelo, a melhor forma de visualizar os resultados é por meio de um gráfico:

plot(fit, "summary")

Ou mesmo por texto:

stm::labelTopics(fit)

## Topic 1 Top Words:
##       Highest Prob: gent, aqui, coisa, fazer, pode, assim, casa 
##       FREX: roupa, cabelo, peca, barato, economizar, comer, loja 
##       Lift: energia, cor, tratamento, sapato, ovo, armario, compro 
##       Score: energia, tratamento, ovo, cabelo, pared, loja, dica 
## Topic 2 Top Words:
##       Highest Prob: gent, aqui, pessoa, pergunta, agora, vamo, fazer 
##       FREX: milhao, hashtag, galera, pergunta, poup, job, inscrito 
##       Lift: bilhao, premio, jornalista, seguidor, contrata, hashtag, orgulho 
##       Score: bilhao, live, job, milhao, premio, hashtag, conteudo 
## Topic 3 Top Words:
##       Highest Prob: dinheiro, reai, ano, aqui, fazer, video, mil 
##       FREX: meta, planilha, tarefa, viver, aposentadoria, reai, poupar 
##       Lift: vitoria, offic, aposentar, caderno, planilha, metodo, produtividad 
##       Score: vitoria, caderno, meta, offic, planilha, joaquina, metodo 
## Topic 4 Top Words:
##       Highest Prob: dinheiro, coisa, mulher, vida, pessoa, pode, ser 
##       FREX: mulher, mae, present, crianca, casamento, maravilha, pai 
##       Lift: gostam, casamento, adulto, maravilha, honesto, casar, present 
##       Score: gostam, casamento, natal, present, maravilha, adulto, objetivo 
## Topic 5 Top Words:
##       Highest Prob: gent, cidad, aqui, rio, janeiro, fazer, candidato 
##       FREX: cidad, candidato, prefeitura, janeiro, rio, prefeito, municipio 
##       Lift: arrecadou, evasiva, habitacao, municipio, prefeitura, promovida, tocar 
##       Score: municipio, tocar, candidato, prefeitura, habitacao, corrupcao, prefeito 
## Topic 6 Top Words:
##       Highest Prob: tesouro, dinheiro, taxa, fundo, direto, aqui, investimento 
##       FREX: tesouro, selic, fundo, direto, taxa, titulo, corretora 
##       Lift: digit, garantidor, imobiliario, ipc, ipc-, cdi, tesouro 
##       Score: digit, tesouro, selic, imobiliario, corretora, taxa, rentabilidad 
## Topic 7 Top Words:
##       Highest Prob: empresa, pessoa, aqui, pode, fazer, dinheiro, valor 
##       FREX: aco, aplicativo, empresa, aluguel, mercado, bolsa, acao 
##       Lift: placa, aco, lucro, bolo, alugar, documento, moeda 
##       Score: placa, aco, investidor, alugar, bolo, empresa, lucro 
## Topic 8 Top Words:
##       Highest Prob: ponto, cartao, gent, credito, aqui, pode, fazer 
##       FREX: multiplus, ponto, acumular, multiplo, cartao, black, site 
##       Lift: milha, anuidad, multiplus, multiplo, passagen, acumular, acumula 
##       Score: multiplus, anuidad, multiplo, ponto, black, acumular, cartao 
## Topic 9 Top Words:
##       Highest Prob: divida, dinheiro, pagar, carro, credito, cartao, pode 
##       FREX: divida, carro, parcela, pagar, juro, credito, ajuda 
##       Lift: chequ, financiado, quitar, devendo, divida, parcelar, parcela 
##       Score: chequ, divida, credito, cartao, financiamento, parcela, consorcio 
## Topic 10 Top Words:
##       Highest Prob: pessoa, gent, fazer, ser, aqui, dinheiro, ter 
##       FREX: ingl, empreendedor, curso, faculdad, sucesso, segredo, negocio 
##       Lift: encontrei, mestr, ingl, atividad, consequencia, tecnico, milionaria 
##       Score: encontrei, live, faculdad, empreendedor, conteudo, ingl, chefe

Na tabela acima, existe para cada tópico uma lista de palavras-chave, de acordo com uma métrica de associação. As métricas mais interessantes a serem olhadas são Highest prob, que é basicamente uma contagem de cada palavra no tópico, e FREX, que é combina frequência e exclusividade para identificar palavras que mais representam o tópico.

Assim, a interpretação dos tópicos pode ser feita desta maneira:

Tópico 1: Dicas de economia doméstica, como que para reduzir despesas em casa;
Tópico 2: Genérico;
Tópico 3: Planejamento Financeiro, com temas como planilhas e aposentadoria;
Tópico 4: Vídeos focados para mulheres ou famílias;
Tópico 5: Política;
Tópico 6: Renda Fixa (este ficou bem claro);
Tópico 7: Dificil saber. Talvez renda variável;
Tópico 8: Cartão de cŕedito e temas afins, como programas de milhas;
Tópico 9: Dívidas e despesas;
Tópico 10: Empreendedorimo.

É possível representar visualmente a diferença entre um par de tópicos, como o 6 e o 9:

plot(fit, "perspective", topics = c(9, 6))

Percebe-se que as palavras “dívida” e “tesouro” separam bem esses dois tópicos.

Atribuição de tópicos a vídeos

Um dos possíveis produtos da análise de Topic Modeling é atribuir a cada documento (ou vídeo) um tópico, de acordo com a proporção de cada tópico nele.

O objeto fit possui internamente um elemento que é uma matriz $N \times K$, onde N é o número de documentos. Assim, para cada vídeo, existe um porcentual de participação de cada tópico, cuja soma é igual a 1.

Vejamos essa matriz para os cinco primeiros vídeos:

head(fit$theta)

##             [,1]        [,2]        [,3]         [,4]         [,5]
## [1,] 0.000273920 0.003253428 0.004040834 0.0009959664 0.0001388210
## [2,] 0.018310800 0.030741680 0.708967915 0.0118358411 0.0006963748
## [3,] 0.070843633 0.041732621 0.013845361 0.0304166112 0.0839133871
## [4,] 0.008194601 0.002381194 0.008008110 0.0033322595 0.0018488345
## [5,] 0.010782705 0.026464694 0.010263833 0.0477243086 0.1095574639
## [6,] 0.006023939 0.872040010 0.005714869 0.0059672704 0.0481083479
##             [,6]        [,7]         [,8]        [,9]        [,10]
## [1,] 0.985509536 0.002881037 0.0001246733 0.002037421 0.0007443629
## [2,] 0.183050228 0.005301315 0.0292175603 0.008811973 0.0030663133
## [3,] 0.010378165 0.176350442 0.0412429834 0.262069287 0.2692075093
## [4,] 0.001888864 0.106774265 0.8546355488 0.011153510 0.0017828124
## [5,] 0.047119628 0.504319587 0.0113556114 0.156215296 0.0761968712
## [6,] 0.019619518 0.011139023 0.0019899886 0.006333920 0.0230631152

Observando a primeira linha, nota-se que existe um claro predomínio do Tópico 6, que representa 98% da distribuição de tópicos. Qual é esse vídeo?

df %>% 
  filter(row_number() == 1) %>% 
  select(id, title)

## # A tibble: 1 x 2
##   id          title                                                       
##   <chr>       <chr>                                                       
## 1 039orzgCUt0 10 DILEMAS MAIS FREQUENTES SOBRE TESOURO DIRETO! Tire as dú…

Vemos que o algoritmo acertou na mosca, pois de fato o vídeo é sobre Renda Fixa.

A qual tópico pertence o vídeo mais assistido do Me Poupe?

# id do video Meu Primeiro Milhao
ind <- which(df$id == "4jaWDfTbytA")
t(fit$theta[ind,])

##            [,1]       [,2]      [,3]       [,4]         [,5]        [,6]
## [1,] 0.05483404 0.03399528 0.5101044 0.01345342 0.0007212358 0.003021568
##             [,7]        [,8]        [,9]     [,10]
## [1,] 0.003167582 0.001051847 0.003699136 0.3759515

Os tópicos predominantes são 3 (Planejamento financeiro), com probabilidade de 51% e 10 (empreendedorismo), com 38%. Faz sentido, porque neste vídeo a Nathalia conta sua história como empreendedora para atingir seu primeiro milhão por meio de muito planejamento financeiro (não tô forçando, eu vi o vídeo).

Vamos então, para cada vídeo, extrair seu tópico predominante e contar a frequência de videos por tópico:

nomes_topicos <- c("economia_domestica", "generico", "plan_financeiro",
                   "mulher_familia", "politica", "renda_fixa", "renda_variavel",
                   "cartao_de_credito", "dividas", "empreendedorismo")
# extrair a maior probabilidade pra cada video
maior_prob <- apply(fit$theta, 1, max)
# extrair o nome do topico com a maior probabilidade
topico_video <- nomes_topicos[apply(fit$theta, 1, which.max)]

# acrescentar esses dados no dataframe principal
df_topico <- df %>% 
  mutate(maior_prob = maior_prob,
         topico = topico_video)

roxo <- "mediumpurple4"

# grafico da quantidade de videos por topico
df_topico %>% 
  count(topico) %>% 
  # classificar em ordem decrescente
  mutate(topico = forcats::fct_reorder(topico, n)) %>% 
  ggplot(aes(x = topico, y = n)) + 
  geom_col(fill = roxo) +
  theme_minimal() + 
  labs(x = NULL, y = "Vídeos",
       title = "Quantidade de vídeos por tópico") +
  coord_flip()

Os tópicos sobre os quais a Nathalia mais fala são Renda Fixa, Economia Doméstica e Dívidas. Quem acompanha seu canal não vai ficar surpreso com estes resultados, o que é um índicio da qualidade do modelo construído neste post.

Também é possível extrair os vídeos chaves de cada tópico, isto é, os vídeos com a maior probabilidade para cada tópico:

df_topico %>% 
  group_by(topico) %>% 
  filter(maior_prob == max(maior_prob)) %>% 
  select(id, title, topico, maior_prob) %>% 
  knitr::kable()

id	title	topico	maior_prob
_alsKxI3-TI	NATH AO VIVO! COMO VIAJAR SEM COLOCAR A MÃO NO BOLSO! Dicas preciosas dos viciados por pontos!	cartao_de_credito	0.9906875
eMQZRHoIgtQ	COMO EU TIRO AS METAS DO PAPEL! Técnica simples pra juntar mais dinheiro do que nunca!	plan_financeiro	0.9773071
FHqHW8-xvLQ	Dia das crianças - COMO FALAR QUE A GRANA TÁ CURTA	mulher_familia	0.9717965
iA9Iqx2uByo	Entrevista - Carlos Osório - Que Candidato é esse	politica	0.9907593
kddZm50Gluw	Perguntas e respostas #5 - Cartão de crédito e FIM DE NAMORO!	dividas	0.9629534
liIQENCBlF0	SE VOCÊ NÃO ENTENDER ISSO, NUNCA VAI INVESTIR NA BOLSA!_ Renda variável do jeito mais simples	renda_variavel	0.9695903
R0AQyTIvcvI	O que é SELIC E CDI Entenda isso HOJE e pare de PERDER DINHEIRO! _ SÉRIE INVESTIDORES INICIANTES	renda_fixa	0.9899924
SfG934AzjYU	COMO EU COMPRO ROUPAS DUAS VEZES AO ANO! Episódio final _ A negociação!	economia_domestica	0.9877744
WtFV03Suheg	A FINAL DA CONTRATAÇÃO QUE VOCÊ RESPEITA! Quem a Nath vai contratar (AGORA GRAVADO)	generico	0.9605720
Zla1-t3aOZw	3 ESCOLHAS QUE ENRIQUECERAM O CERBASI _ meu guru	empreendedorismo	0.9151230

Eu, pessoalmente, estou bastante satisfeito com os resultados. A modelagem de tópicos funcionou muito bem.

Vamos estão analisar algumas estatísticas básicas para cada tópico: quais têm os vídeos mais longos? Quais são os mais populares?

meu_grafico <- function(df, var){
  quo_var <- enquo(var)

  mediana_geral <- df %>% 
    summarise_at(vars(!!quo_var), median, na.rm = TRUE) %>% 
    pull()
  
  # obter grafico
  p <- df %>% 
    group_by(topico) %>% 
    summarise(m = median(!!quo_var, na.rm = TRUE)) %>% 
    ggplot(aes(x = topico, y = m)) +
    geom_col(fill = roxo) +
    geom_hline(yintercept = mediana_geral, linetype = "dashed") +
    theme_minimal() +
    coord_flip() +
    labs(x =  NULL, y = NULL)
  
  p
}
  
meu_grafico(df_topico, duration) + ggtitle("Média da duração dos vídeos por tópico do Me Poupe")

meu_grafico(df_topico, view_count) + ggtitle("Média de views por tópico do Me Poupe")

meu_grafico(df_topico, like_count) + ggtitle("Média de likes por tópico do Me Poupe")

Com estes gráficos, aprendemos que os vídeos sobre renda fixa, planejamento financeiro e empreendedorismo são os mais populares entre os “me poupeiros” (como a Nathalia chama quem acompanha o canal), pois possuem mais visualizações e curtidas. Outro fato interessante é que os vídeos categorizados como política são, por assim dizer, improdutivos, pois, apesar de serem os mais longos, possuem muitos poucos views. Existem alguns possíveis tipos de viés que poderiam explicar este dado, como o temporal.

Análise de Sentimento

Finalmente, vamos aplicar uma abordagem de análise de sentimento para analisar se os tópicos apresentam diferentes polaridades entre si. Quais tópicos são mais negativos?

data("sentiLex_lem_PT02")
dict <- unique(sentiLex_lem_PT02)

# criacao do dataframe de sentimento por topico
df_sent <- df %>% 
  unnest_tokens(palavra, caption) %>% 
  inner_join(sentiLex_lem_PT02, by = c("palavra" = "term")) %>% 
  group_by(id) %>% 
  summarise(
    sentimento_soma = sum(polarity),
    sentimento_media = mean(polarity)
  )

# acrescentar ao dafaframe principal
df_topico_sent <- inner_join(df_topico, df_sent, by = "id") 


# calcular sentimento geral dos videos
sent_medio_geral <- median(df_topico_sent$sentimento_media)

df_topico_sent %>% 
  mutate(topico = forcats::fct_reorder(topico, sentimento_media, median)) %>% 
  ggplot(aes(x = sentimento_media, y = topico)) +
  geom_density_ridges(fill = roxo) +
  geom_vline(xintercept = sent_medio_geral, linetype = "dashed") +
  theme_minimal() +
  labs(x = "Sentimento", y = NULL,
       title = "Distribuição dos sentimentos por tópico do Me Poupe")

## Picking joint bandwidth of 0.0756

Em novamente o que eu considero um acerto da metodologia, os vídeos de dívidas apresentaram polaridades mais baixas, ou sejas, um nível de sentimento mais negativo.

Conclusão

É relativamente difícil avaliar a acurácia e precisão de um algoritmo de topic modeling por essa técnica ser não-supervisionada, ou seja, os dados não possuírem um output com a resposta correta.

Contudo, os resultados apresentados neste post mostram que é possível sim usar esse tipo de técnica, com um certo auxílio de interpretação humana, para categorizar um conjunto de vídeos sem ser necessário os assistir ou mesmo sem saber seus títulos.

Referências

Antes das referências formais, gostaria de indicar o post do Júlio Trecenti, que é um outro exemplo de uso criativo de análise de dados para youtubers.

https://en.wikipedia.org/wiki/Topic_model

Mimno, D., Wallach, H. M., Talley, E., Leenders, M., & McCallum, A. (2011, July). “Optimizing semantic coherence in topic models.” In Proceedings of the Conference on Empirical Methods in Natural Language Processing (pp. 262-272). Association for Computational Linguistics. Chicago

Roberts, M., Stewart, B., Tingley, D., Lucas, C., Leder-Luis, J., Gadarian, S., Albertson, B., et al. (2014). “Structural topic models for open ended survey responses.” American Journal of Political Science, 58(4), 1064-1082

Margaret E. Roberts, Brandon M. Stewart and Dustin Tingley (2018). stm: R Package for Structural Topic Models. URL http://www.structuraltopicmodel.com.

BBB no R: Estudando as interações entre membros por análise de redes

Thu, 22 Feb 2018 00:00:00 +0000

Eu realmente não acredito que estou escrevendo um post sobre Big Brother Brasil.

Ok, respirei fundo, vamos lá…

Sejam bem-vindos a mais um post! Em 2018, um dos projetos mais incríveis que vou tocar é um curso online de Análise de Redes Sociais (ARS) no R a ser oferecido por mim e pelo IBPAD, que é referência nacional em ARS e em outras coisas. A previsão é de que o curso seja lançado até Maio de 2018.

Como um aperitivo do conteúdo a ser abordado no curso, lhes apresento uma simples porém criativa (para quem gosta, né) e prática aplicação de ARS: analisar interações de brothers e sisters (meu Deus, que termos ridículos), descobrir participantes influentes e aplicar algoritmos de detecção de comunidades. Com isso, minha intenção é demonstrar que você pode usar seus conhecimentos em R para aplicar em basicamente qualquer projeto que você quiser.

Uma breve introdução sobre ARS pode ser vista neste artigo na Wikipedia. Se prefere um conteúdo mais elaborado e completo, sugiro adquirir este livro dos caras do IBPAD.

# pacotes usados
library(tidyverse)
library(rvest)
library(igraph)
library(Rfacebook)
library(knitr)
library(viridis)

Coleta dos dados

Para preparar os dados para a realização da ARS no R, precisamos obter um dataset neste formato:

tribble(
  ~pessoa_1, ~pessoa_2,
  "Fulano", "Ciclano",
  "Fulano", "Beltrano",
  "Ciclano", "Beltrano"
)

## # A tibble: 3 x 2
##   pessoa_1 pessoa_2
##   <chr>    <chr>   
## 1 Fulano   Ciclano 
## 2 Fulano   Beltrano
## 3 Ciclano  Beltrano

Ou seja, o formato desejado é uma simples matriz de 2 colunas onde cada linha representa uma interação entre a Pessoa 1 e a Pessoa 2. A ordem (ex.: Fulano na coluna 1 ou 2) não importa, porque não se trata de uma rede direcionada (directed).

Como, então, obter esses dados?

Existem diversas alternativas. Minha solução foi coletar as manchetes do site do BBB (após me recuperar do desgaste psicológico que é entrar em contato com um material literário tão rico) e extrair os nomes presentes na manchete.

Por exemplo, a partir da “notícia” Diego, Kaysar e Lucas limpam espelho do banheiro, será retornado um dataframe com todas as possíveis combinações de duplas formadas pelos três participantes presentes no título.

Para coletar todas as notícias sobre o BBB já publicadas no site, utilizei a mesma estratégia descrita neste post sobre o G1, ou seja: coletar todos os links já publicados na página do BBB no Facebook.

posts <- getPage("BigBrotherBrasil", token, n = 5000, since = "2018/01/22")
links <- posts$link[posts$type == "link"]

Após extrair os links, o código abaixo faz um webscraping bem simples e extrair o título e o corpo das matérias.

extrair_bbb <- function(url){
  url <- url %>% read_html()
  
  css_titulo <- ".content-head__title"
  css_texto <- ".content-text__container"
  
  noticia_titulo <- url %>% 
    html_nodes(css = css_titulo) %>% 
    html_text()
  
  noticia_texto <- url %>% 
    html_nodes(css = css_texto) %>% 
    html_text() %>% 
    dplyr::first()
  
  tibble(noticia_titulo, noticia_texto)
}

lst <- links %>% map(extrair_bbb)

# juntar a lista em um dataframe
df_bbb <- bind_rows(lst)
# remover noticias de resumo
df_bbb <- df_bbb %>% filter(!str_detect(noticia_titulo, "Resumo"))

glimpse(df_bbb)

## Observations: 595
## Variables: 2
## $ noticia_titulo <chr> "Wagner elogia Gleici: 'Você tá linda'", "Ayrto...
## $ noticia_texto  <chr> " Na sala, Gleici chega perto de Wagner e eles ...

A seguir, mostro funções para extrair os participantes mencionados nos títulos e retornar as combinações de duplas.

participantes <- c("Ayrton", "Ana Clara", "Ana Paula", "Breno", "Caruso", "Diego",
                   "Gleici", "Jaqueline", "Jéssica", "Kaysar", "Lucas", "Mahmoud",
                   "Mara", "Nayara", "Patrícia", "Paula", "Viegas", "Wagner")

extrair_mencionados <- function(x){
  participantes[str_detect(x, participantes)]
}

mencionados <- df_bbb$noticia_titulo %>% map(extrair_mencionados)
# manter na lista apenas onde length(.) > 2
mencionados <- mencionados %>% keep(~length(.) > 1)

# gerar lista de combinacoes entre todos os mencionados
gerar_pares <- function(x){
  x <- sort(unique(x))
  x <- x %>% combn(m = 2, simplify = TRUE) %>% t()
  x <- as.tibble(x)
  colnames(x) <- c("P1", "P2")
  x
}
# exemplo
gerar_pares(c("A", "B", "C"))

## # A tibble: 3 x 2
##   P1    P2   
##   <chr> <chr>
## 1 A     B    
## 2 A     C    
## 3 B     C

df_mencionados <- mencionados %>%
  map(gerar_pares) %>%
  bind_rows() %>% 
  group_by_all() %>% 
  summarise(n = n())

kable(head(df_mencionados))

P1	P2	n
Ana Clara	Ana Paula	3
Ana Clara	Ayrton	11
Ana Clara	Breno	12
Ana Clara	Caruso	4
Ana Clara	Diego	3
Ana Clara	Gleici	9

Visualização dos dados

Antes de partir para ARS, vamos ver como se dá a frequência de interações entre os participantes:

df_mencionados %>% 
  ggplot(aes(x = P1, y = P2, fill = n)) +
  geom_tile() +
  viridis::scale_fill_viridis() +
  geom_text(aes(label = n), color = "black") + 
  theme_classic() +
  theme(axis.text.x = element_text(angle = 90))

Temos que, praticamente, todo mudo interage com todo mundo. Por isso, antes mesmo de plotar o grafo dessa rede, espera-se que ela seja bem densa, com todos os vértices se ligando.

Entretanto, não deixa de ser interessante notar que, dentro de um grupo de apenas 18 pessoas confinadas em um espaço limitado como uma casa durante algumas semanas ou meses, é incrível como existem pares que simplesmente não interagem entre si (de acordo com a metodologia deste post).

Para deixar a análise interessante, vou remover os nós em que existem menos de 3 interações.

df_mencionados <- df_mencionados %>% filter(n > 3)

Análise da Rede

Para definir o grafo, vamos criar um dataframe de metadados sobre os vértices (os participantes), como sexo:

vertices <- tibble(
  nome = participantes,
  sexo = c("M", "F", "F", "M", "M", "M", "F", "F", "F", "M", "M", "M", "F", "F",
           "F", "F", "M", "M")
)

vertices <- vertices %>%
  filter(nome %in% df_mencionados$P1 | nome %in% df_mencionados$P2)

g <- graph_from_data_frame(d = df_mencionados, vertices = vertices,
                           directed = FALSE)

# adicionar cor aos pontos de acordo com o sexo
V(g)$color <- ifelse(V(g)$sexo == "M", "lightblue", "pink")
# adicionar peso aos nós
E(g)$weight <- df_mencionados$n

Finalmente, o grafo em si:

set.seed(123)
plot(g, vertex.label.color = "black", layout = layout_with_kk(g),
     vertex.size = 20) #,edge.width = E(g)$n/50)

Ok, me tornei o que mais temia, um crítico de BBB, mas vamos lá:

Pela grafo, nota-se que existem alguns participantes mais isolados, como Viegas, Jaqueline e Wagner. Sobre Jaqueline, existe um viés causado pelo tempo, visto que ela já foi eliminada no momento em que vos escrevo.

Outra observação é que de fato existem alguns participantes mais importantes na rede, como Paula, Lucas e Patrícia, visto que estão localizados mais ao centro do grafo.

Uma medida que pode ser usada para mensurar a importância de cada pessoa na rede é o betweenness:

rev(sort(betweenness(g)))

##     Nayara     Kaysar    Jéssica     Caruso      Lucas     Gleici 
## 21.9166667 16.8333333 16.5000000 13.2500000  9.7500000  9.4166667 
##      Paula    Mahmoud      Diego      Breno  Jaqueline     Wagner 
##  7.0000000  4.0000000  2.5833333  2.3333333  1.0000000  0.3333333 
##     Viegas   Patrícia  Ana Paula  Ana Clara     Ayrton 
##  0.0000000  0.0000000  0.0000000  0.0000000  0.0000000

De acordo com essa métrica, Nayara, Kaysar e Jéssica são os brothers com maior articulação entre todos.

Outra medida é o degree, que é simplesmente a contagem de outras pessoas com as quais cada participante está conectado:

rev(sort(degree(g)))

##     Paula     Lucas    Kaysar    Gleici   Mahmoud    Caruso  Patrícia 
##        14        13        12        11        10        10         9 
##    Nayara   Jéssica     Diego     Breno Ana Paula Ana Clara    Wagner 
##         9         9         7         7         7         7         4 
## Jaqueline    Ayrton    Viegas 
##         3         3         1

Uma aplicação muito interessante em ARS é a detecção de comunidade. Com o perdão por não entrar em detalhes sobre o funcionamento do algoritmo (isso eu deixo para meu curso), segue abaixo um exemplo disso:

cluster <- fastgreedy.community(g)
cluster

## IGRAPH clustering fast greedy, groups: 3, mod: 0.23
## + groups:
##   $`1`
##   [1] "Ayrton"    "Ana Clara" "Breno"     "Caruso"    "Gleici"   
##   [6] "Jaqueline" "Nayara"    "Viegas"    "Wagner"   
##   
##   $`2`
##   [1] "Ana Paula" "Diego"     "Kaysar"    "Mahmoud"   "Patrícia" 
##   [6] "Paula"    
##   
##   $`3`
##   [1] "Jéssica" "Lucas"  
##   + ... omitted several groups/vertices

set.seed(123)
plot(cluster, g)

O algoritmno encontrou três comunidades dentro da rede, sendo um deles formados apenas por Jéssica e Lucas.

Conclusão

Você talvez tenha percebido pelo meu tom jocoso no post que não sou lá muito fã de BBB. Contudo, isso não me impediu de pensar nessa aplicação como exemplo de demonstração de situações em que é possível aplicar a Análise de Redes Sociais. Como tudo na vida quando se sabe R, os limites dependem da sua criatividade :)

Sobre gráficos e a mensagem que eles querem transmitir

Sun, 26 Nov 2017 00:00:00 +0000

Recentemente, quando estava no trabalhando lendo uma revista de negócios sobre o varejo, me deparei com o seguinte gráfico:

knitr::include_graphics("https://i.imgur.com/f1dh4uw.jpg")

Mesmo sem contexto, é possível perceber que essa visualização foi criada para mostrar a divergência de opiniões sobre a importância dada a fatores de compra pelos executivos de varejo e pelos consumidores. Imediatamente, eu pensei que o jornalista perdeu uma ótima oportunidade de representar melhor a informação desejada.

Primeiramente, a ordem dos fatores no gráfico não segue uma ordem clara. Se o gráfico foi feito para enfatizar essa divergência de opiniões, teria sido melhor que os fatores fossem ordenados no gráfico pela diferença numérica entre executivos e consumidores. Veja que o ponto onde há maior disparidade, Acesso a informações, venda e serviços, aparece no canto inferior direito, fazendo com que os olhos do leitor tenham de percorrer o gráfico quase que até seu final para extrair sua informação mais importante. Além disso, o fator de compra que apresenta maior uniformidade, Informações em tempo real sobre inventário e disponibilidade de informações, aparece logo ao lado da que apresenta mais divergência.

Outra oportunidade perdida é que não é dada uma ênfase ao que os consumidores, os responsáveis pela empresa existir, preferem. Como esta é uma revista voltada para o segmento de varejo, seu público-alvo são executivos do setor, que estão sedentos por saber o que os clientes pensam. Contudo, os fatores que os consumidores mais preferem, Pagamento simples e fluido e Acesso a informaçoes, venda e serviços, aparecem em ordem aleatória no gráfico (em quinto e em oitavo lugar, respectivamente).

Por isso, este post é dedicado a propor uma nova versão dessa visualização de dados, de maneira que atenda aos pontos citados acima. Ou seja, um gráfico que:

Ordene os fatores de acordo com o grau de divergência entre consumidores e executivos;
Destaque de alguma maneira os fatores que os consumidores consideram mais importantes que os executivos.

library(tidyverse)

Recriando o dataset do gráfico:

df <- tribble(
  ~fator, ~Executivos, ~Consumidores,
  "Experiência personalizada", 43, 27,
  "Experiência fluida em todos os canais", 42, 26,
  "Pagamento simples e fluido", 41, 50,
  "Tecnologia em loja", 38, 18,
  "Informações em tempo real sobre inventário e disponibilidade de informações", 37, 38,
  "Plataformas mobile e aplicativos de compra", 36, 19,
  "Habilidade de customizar produtos e serviços", 35, 24,
  "Engajamento e presença em redes sociais", 35, 14,
  "Pagamento digital e opções de câmbio", 34, 31,
  "Acesso a informações, venda e serviços", 31, 50,
  "Gamificação e experiência digital interativa", 21, 9
)

Em seguida, calculamos a diferença entre as duas colunas numéricas e usamos a funçao forcats::fct_reorder() para ordenar os fatores de acordo com essa diferença.

df <- df %>% 
  mutate(diferenca = abs(Executivos - Consumidores),
         # Quebrar o string do fator em parágrafos e reordenar
         fator = str_wrap(fator, 40),
         fator = fct_reorder(fator, diferenca, .desc = FALSE)) %>% 
  # criar colunas para armazenar os valores maximo e minimo entre executivos e consumidores 
  rowwise() %>% 
   mutate(maior_percentual = max(Executivos, Consumidores),
          menor_percentual = min(Executivos, Consumidores))

# criar coluna para identificar

O código desse gráfico é um pouco mais complexo do que o usual. Como eu queria que o label de cada ponto ficasse à esquerda no caso do menor número e à direita do maior, é necessário criar duas camadas de geom_text() separadamente, uma para o valor mínimo de cada fator e outra para o valor máximo, sendo que cada possui um valor diferente de hjust.

df.long <- df %>% 
  # transformar para formato tidy (long)
  gather(fonte_opiniao, valor, 2:3)

p <- ggplot(df.long, aes(x = valor, y = fator)) +
  geom_point(aes(color = fonte_opiniao), size = 3) +
  # ajustar pontos
  scale_x_continuous(limits = c(0, 55), breaks = seq(0, 50, 10)) +
  # mudar aparencia. isso é opcional.
  theme_minimal() + 
  # adicionar manualmente o label do valor que cada ponto representa
  geom_text(data = df, aes(x = maior_percentual, label = maior_percentual), hjust = -0.3) +
  geom_text(data = df, aes(x = menor_percentual, label = menor_percentual), hjust = 1.4) +
  # mudar titulos dos eixos e do grafico
  labs(x = "%", y = NULL, color = NULL, title = "Quais fatores influenciam a compra?") +
  theme(legend.position = "bottom")

p

Com este gráfico, creio que atendemos ao primeiro ponto. Veja que, além dos objetivos listados anteriormente, o gráfico apresenta outras melhorias em relação ao original. Uma delas é que é possível descobrir muito mais facilmente quais são os fatores que os consumidores menos se lembram (Gamificação).

Para atender à segunda melhoria proposta, a de destacar de alguma maneira os fatores considerados mais importantes pelos consumidores, decidi usar o seguinte método: plotar um segmento ligando os pontos em cada fator, sendo que, nos fatores de compra que foram mais lembrados por consumidores do que por executivos, o segmento fosse mais destacado (ou menos transparente) no gráfico.

Para isso, vamos criar uma coluna onde o valor do alpha do segmento, que correspondência ao seu nível de opacidade, seja definido manualmente:

# criar coluna para identificar quem da mais importancia ao fator
df <- df %>% 
  mutate(alpha_segmento = if_else(Executivos - Consumidores > 0, 0.2, 1))

Vamos então adicionar esse novo elemento no gráfico.

p + 
  # para não fazer que o segmento fique em cima do ponto, eu removo 0,3 de cada lado dele
  geom_segment(data = df, aes(x = maior_percentual-0.3, xend = menor_percentual+0.3,
                              y = fator, yend = fator,
                              alpha = alpha_segmento),
               inherit.aes = FALSE, show.legend = FALSE) +
  scale_alpha_identity()

Acredito que, com essa visualização, as mensagens que o gráfico da revista foi criado para mostrar são transmitidas mais claramente.

Anunciando o lançamento de literaturaBR

Tue, 21 Nov 2017 00:00:00 +0000

Paixão por Dados de cara nova!

O blog está de cara nova! O endereço antigo do blog começou a apresentar alguns bugs bem chatos, então tomei a decisão de finalmente migrar para uma nova plataforma, utilizando o pacote blogdown, a mesma que o pessoal do Curso-R usa no site deles. Para comemorar essa migração, anuncio o lançamento do meu terceiro pacote R: o literaturaBR.

literaturaBR, o mais novo pacote da comunidade R Brasil

Após lançar o pacote lexiconPT, senti que a carência de datasets textuais na língua portuguesa poderia restringir seu potencial de alcance de desenvolvedores e cientistas de dados interessados em usar os léxicos para fazer análise de sentimento. Apesar de ter feito um post mostrando seu uso em dados obtidos do Facebook, eu admito que é complicado ter que fazer web scraping de algum site toda vez que se deseja praticar ou ensinar mineração de texto com textos em Português.

Esse problema me inspirou a desenvolver mais um pacote R para facilitar pequenas demonstrações de Text Mining. Assim como a Julia Silge criou o janeaustenr com livros clássicos da Jane Austen, eu criei o literaturaBR, um data package criado para disponibilizar livros clássicos da literatura brasileira já prontos para serem importados e manuseados no R. Para saber quais livros estão disponíveis na versão atual do pacote e outras informações úteis, visite seu repositório.

Este post se destina a apresentar algumas exemplos simples de tarefas de Text Mining, como:
* Análise de Sentimento;
* Complexidade Léxica;
* Analise de ocorrência de palavras em específico.

Introdução

Os pacotes usados neste post são:

library(literaturaBR) # meio obvio
library(tidytext) # excelente pacote de text mining
library(tidyverse) # <3
library(stringr) # indispensavel para manipulacao de texto
library(quanteda) # otimas funcoes para analise quantitativa de texto
library(qdap) # similar ao quanteda, embo ra eu nao me lembre exatamente se eu o uso neste post
library(forcats) # manipulacao de fatores
library(ggthemes) # temas para o ggplot2
library(lexiconPT)

Vamos então importar os datasets presentes no literaturaBR na data de hoje e os transformar em um dataset só:

data("memorias_de_um_sargento_de_milicias")
data("memorias_postumas_bras_cubas")
data("alienista")
data("escrava_isaura")
data("ateneu")

df <- bind_rows(memorias_de_um_sargento_de_milicias,
                memorias_postumas_bras_cubas,
                alienista,
                escrava_isaura,
                ateneu)


# Olhando a estrutura do dataframe
glimpse(df)

## Observations: 5,149
## Variables: 5
## $ book_name        <chr> "Memórias de um Sargento de Milícias", "Memór...
## $ chapter_name     <chr> "Capítulo 1 - Origem, nascimento e batismo", ...
## $ url              <chr> "https://pt.wikisource.org/wiki/Mem%C3%B3rias...
## $ paragraph_number <int> 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 1, 2, ...
## $ text             <chr> "Era no tempo do rei.", "Uma das quatro esqui...

Todos os datasets fornecidos pelo literaturaBR possuem a mesma estrutura, onde cada linha corresponde a um parágrafo de um livro e contêm 5 variáveis:
* book_name: Nome original do livro;
* chapter_name: Nome original do capítulo do livro do parágrafo;
* url: Link para artigo do Wikisouce de onde o capítulo do parágrafo foi extraído;
* paragraph_number: Ordem do parágrafo em seu capítulo;
* text: Texto do parágrafo. Contem acentos e pontuação.

Um rápido adendo: os nomes das colunas está em inglês porque só tomei a decisão de escrever toda a documentação do pacote em Português meio tardiamente.

Análise básica

Para usar (parte) das funções do pacote quanteda, precisamos converter o dataframe dos livros em um objeto do tipo corpus.

df_corpus <- df %>% 
  # agrupar por livro
  group_by(book_name) %>% 
  # formatar o dataframe para que so tenha uma linha por livro
  summarise(text = paste0(text, sep = "", collapse = ". "))

dim(df_corpus)

## [1] 5 2

meu_corpus <- quanteda::corpus(df_corpus$text, docnames = df_corpus$book_name)
summary(meu_corpus)

## Corpus consisting of 5 documents:
## 
##                                 Text Types Tokens Sentences
##                     A escrava Isaura  9349  64929      1751
##  Memórias de um Sargento de Milícias  8703  71391      2287
##      Memórias Póstumas de Brás Cubas 11058  74223      3199
##                          O Alienista  4387  19977       770
##                             O Ateneu 15341  73063      3551
## 
## Source:  /home/sillas/R/Projetos/paixaopordados-blogdown/content/post/* on x86_64 by sillas
## Created: Wed Nov 22 20:34:35 2017
## Notes:

Como vemos, a função quanteda::corpus() identificou a quantidade de Types (número de palavras distintas em um corpus), Tokens (número total de palavras em um corpus) e Sentences (frases) em cada livro.

Vamos então criar uma document-feature matrix a partir desse corpus criado, tomando o cuidade de remover pontuações e stopwords:

corpus_dfm <- dfm(meu_corpus, remove_punct = TRUE,
                  remove = quanteda::stopwords("portuguese"),
                  groups = df_corpus$book_name)

# Analisando as 15 palavras mais comuns no geral por livro
dfm_sort(corpus_dfm)[, 1:15]

## Document-feature matrix of: 5 documents, 15 features (5.33% sparse).
## 5 x 15 sparse Matrix of class "dfm"
##                                      features
## docs                                    é casa tempo ainda tudo bem todos
##   A escrava Isaura                    424   98    81   121   78 175    78
##   Memórias de um Sargento de Milícias 305  193   207   131  192 126   139
##   Memórias Póstumas de Brás Cubas     492  107   108    89   98  65    69
##   O Alienista                          88  108    20    29   26  10    37
##   O Ateneu                            199   51    56    97   56  56    91
##                                      features
## docs                                  tão ser havia   d leonardo coisa
##   A escrava Isaura                    137  96    56  20        0    35
##   Memórias de um Sargento de Milícias  63  75   153 194      366   128
##   Memórias Póstumas de Brás Cubas      95  97    53  83        0   140
##   O Alienista                          31  25     7  44        0    23
##   O Ateneu                             47  78   101  26        0    38
##                                      features
## docs                                  disse dia
##   A escrava Isaura                       67  41
##   Memórias de um Sargento de Milícias   119 128
##   Memórias Póstumas de Brás Cubas       130  89
##   O Alienista                            30  21
##   O Ateneu                               11  77

A função dfm_sort() retorna a ocorrência de cada palavra (também chamado de token ou feature) em cada livro. Para pesquisar a ocorrência de alguma palavra específica nos documentos, use a função dfm_select():

# ocorrencias da palavra amor
dfm_select(corpus_dfm, "amor")

## Document-feature matrix of: 5 documents, 1 feature (0% sparse).
## 5 x 1 sparse Matrix of class "dfm"
##                                      features
## docs                                  amor
##   A escrava Isaura                      71
##   Memórias de um Sargento de Milícias   30
##   Memórias Póstumas de Brás Cubas       53
##   O Alienista                            3
##   O Ateneu                              45

Curioso para saber o contexto em que essa palavra aparece? Você pode usar a função kwic() para isso:

# usar a função head() para o output nao ficar mt grande
kwic(meu_corpus, "amor") %>% head()

##                                                              
##  [A escrava Isaura, 2011]    , bem pode conquistar o | amor |
##  [A escrava Isaura, 5090]    não se havia casado por | amor |
##  [A escrava Isaura, 5173]     o mais cego e violento | amor |
##  [A escrava Isaura, 6555] pudesse obter também o teu | amor |
##  [A escrava Isaura, 7215]          Ora, senhor, pelo | amor |
##  [A escrava Isaura, 7686]  disputar com o senhor por | amor |
##                         
##  de algum guapo mocetão,
##  , sentimento esse a que
##  , que de dia em        
##  !... És                
##  de Deus!..             
##  de uma escrava..

Para saber as palavras mais usadas, dentre os vários métodos possíveis para isso, pode-se usar a função topfeatures()

topfeatures(corpus_dfm, groups = df_corpus$book_name)

## $`A escrava Isaura`
##       é  isaura  senhor leôncio  álvaro escrava     bem     tão     pai 
##     424     344     243     205     188     180     175     137     127 
##   ainda 
##     121 
## 
## $`Memórias de um Sargento de Milícias`
## leonardo        é    maria  comadre    tempo    porém        d     casa 
##      366      305      231      209      207      205      194      193 
##     tudo    major 
##      192      179 
## 
## $`Memórias Póstumas de Brás Cubas`
##        é virgília    coisa    olhos    disse     nada    outro    outra 
##      492      199      140      138      130      125      122      116 
##     vida   porque 
##      116      113 
## 
## $`O Alienista`
##      casa alienista         é     verde bacamarte  barbeiro    câmara 
##       108       106        88        77        59        54        52 
##   itaguaí     simão  evarista 
##        49        49        45 
## 
## $`O Ateneu`
##         é     sobre aristarco   diretor     havia     ainda    ateneu 
##       199       167       148       104       101        97        93 
##     todos       ser      dois 
##        91        78        77

Análise comparativa entre os livros

Algo interessante a se fazer é quantificar a similaridade e a dissimilaridade ou distância entre os livros. As funções textstat_simil e textstat_dist implementam diversas técnicas e algoritmos para isso. Sugiro ler a documentação completa das funções e ler as referências indicadas para conhecer melhor os métodos de cálculo.

Vamos então calcular a similaridade entre os livros presentes no pacote:

# normalizar os livros pelo seu tamanho
corpus_dfm_norm <- dfm_weight(corpus_dfm, "relfreq")
corpus_simil <- textstat_simil(corpus_dfm_norm, method = "correlation",
                               margin = "documents", upper = TRUE,
                               diag = FALSE)
# ver os resultados individualmente para cada livro
round(corpus_simil, 3)

##                                     A escrava Isaura
## A escrava Isaura                                    
## Memórias de um Sargento de Milícias            0.524
## Memórias Póstumas de Brás Cubas                0.625
## O Alienista                                    0.431
## O Ateneu                                       0.512
##                                     Memórias de um Sargento de Milícias
## A escrava Isaura                                                  0.524
## Memórias de um Sargento de Milícias                                    
## Memórias Póstumas de Brás Cubas                                   0.642
## O Alienista                                                       0.502
## O Ateneu                                                          0.550
##                                     Memórias Póstumas de Brás Cubas
## A escrava Isaura                                              0.625
## Memórias de um Sargento de Milícias                           0.642
## Memórias Póstumas de Brás Cubas                                    
## O Alienista                                                   0.585
## O Ateneu                                                      0.631
##                                     O Alienista O Ateneu
## A escrava Isaura                          0.431    0.512
## Memórias de um Sargento de Milícias       0.502    0.550
## Memórias Póstumas de Brás Cubas           0.585    0.631
## O Alienista                                        0.450
## O Ateneu                                  0.450

Alguns resultados são bem interessantes. O Alienista é mais diferente de todos, tendo uma correlação superior a 0,51 apenas com o livro Memórias Póstumas de Brás Cubas, coincidentemente ou não ambos do mesmo autor. A maior correlação pertence aos livros Memórias Póstumas de Brás Cubas e Memórias de um Sargento de Milícias.

Passemos então para a análise da dissimilaridade ou distância entre os livros, com o auxílio de um dendograma:

corpus_dist <- textstat_dist(corpus_dfm_norm, method = "euclidean",
                               margin = "documents", upper = TRUE,
                               diag = FALSE)
# ver os resultados individualmente para cada livro
plot(hclust(corpus_dist))

Análise de Sentimento

Como já publiquei no blog um post sobre Análise de Sentimento, não vou me alongar em repetir conceitos sobre o tema. Segue o código comentado:

# Criar um dataframe em que cada linha corresponda a uma unica palavra
df.token <- df %>%
  unnest_tokens(term, text)

glimpse(df.token)

## Observations: 252,299
## Variables: 5
## $ book_name        <chr> "Memórias de um Sargento de Milícias", "Memór...
## $ chapter_name     <chr> "Capítulo 1 - Origem, nascimento e batismo", ...
## $ url              <chr> "https://pt.wikisource.org/wiki/Mem%C3%B3rias...
## $ paragraph_number <int> 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, ...
## $ term             <chr> "era", "no", "tempo", "do", "rei", "uma", "da...

# importar lexico de sentimentos
data("oplexicon_v3.0")
df.token <- df.token %>%
  inner_join(oplexicon_v3.0, by = "term")

Um pergunta muito interessante a se fazer é se o sentimento varia ao longo dos capítulos dos livros. Os livros ficam mais (ou menos) positivos a medida em que se aproximam do final?

Para isso, primeiro precisamos normalizar os livros, visto que eles apresentam tamanhos e quantidades de capítulos diferentes.

# extrair capitulos de cada livro
df_chapter_number <- df.token %>%
  distinct(book_name, chapter_name) %>%
  group_by(book_name) %>%
  # normalizar capitulo de acordo com sua posicao no livro
  mutate(chapter_number_norm = row_number()/max(row_number()))

glimpse(df_chapter_number)

## Observations: 252
## Variables: 3
## $ book_name           <chr> "Memórias de um Sargento de Milícias", "Me...
## $ chapter_name        <chr> "Capítulo 1 - Origem, nascimento e batismo...
## $ chapter_number_norm <dbl> 0.02083333, 0.04166667, 0.06250000, 0.0833...

Agora calculamos o sentimento de cada capítulo, que corresponde à soma da polaridade de suas palavras:

df.sentiment <- df.token %>%
  # calcular sentimento por capitulo
  group_by(book_name, chapter_name) %>%
  summarise(polarity = sum(polarity, na.rm = TRUE)) %>%
  ungroup() %>%
  # retornar posicao relativa (ou normalizada) do capitulo de cada livro
  left_join(df_chapter_number) %>%
  arrange(book_name, chapter_number_norm)

# grafico
df.sentiment %>%
  ggplot(aes(x = chapter_number_norm, y = polarity)) +
    geom_line() +
    facet_wrap(~ book_name, ncol = 5, labeller = label_wrap_gen(20)) +
    labs(x = "Posição relativa no livro", y = "Sentimento") +
    theme_bw()

Os resultados são muito interessantes: De acordo com esse método, A Escrava Isaura e O Ateneu são verdadeiras montanhas-russas de emoções, enquanto que livros os “dois Memórias” são mais estáveis. O Alienista apresenta um sentimento que tem uma tendência decrescente até a metade e crescente após ela.

Complexidade léxica e ocorrência de palavras

A função textstat_lexdiv traz várias métricas de complexidade e diversidade léxicas. Novamente, recomendo a leitura de sua documentação para conhecer as métricas disponíveis.

# aplicando a funcao no objeto sem stopwords e pontuação
lexdiv <- textstat_lexdiv(corpus_dfm, measure = "TTR")
lexdiv

##                    A escrava Isaura Memórias de um Sargento de Milícias 
##                           0.3062233                           0.2517707 
##     Memórias Póstumas de Brás Cubas                         O Alienista 
##                           0.3139269                           0.4291334 
##                            O Ateneu 
##                           0.4134223

#grafico
lexdiv %>% 
  as.data.frame() %>% 
  magrittr::set_colnames("TTR") %>% 
  tibble::rownames_to_column("livro") %>% 
  mutate(livro = forcats::fct_reorder(livro, TTR)) %>% 
  ggplot(aes(x = livro, y = TTR)) + 
    geom_col(fill = "cadetblue4") +
    coord_flip() + 
    labs(x = NULL, y = "TTR") +
    theme_minimal()

O livro que apresenta a maior diversidade léxica, de acordo com a métrica Type-Token Ratio (TTR), é O Alienista. Memórias de um Sargento de Milícias vem bem atrás dos demais.

De todas os gráficos que apresentei neste post, o mais legal vem a seguir. É possível plotar a ocorrência de uma determinada palavra ao longo dos livros analisados. Por exemplo, a ocorrência da palavra amor é uniformemente distribuída nos livros?

kwic(meu_corpus, "amor") %>% textplot_xray(scale = "relative")

Com o gráfico acima, é possível ver que a palavra amor aparece, no livro Ateneu, muito mais frequentemente na primeira metade do que na segunda. Nos demais livros, a ocorrência da palavra é mais uniforme.

Outro exemplo interessante surge com a busca da palavra fogo. Quem já leu O Ateneu já consegue imaginar como serão os resultados:

kwic(meu_corpus, "fogo") %>% textplot_xray(scale = "relative")

Conclusão

Eu realmente torço para que o literaturaBR e o lexiconPT atinjam seus potenciais e sejam dois grandes marcos em pesquisas em Text Mining com textos em português. Toda sugestão ou pedido de melhorias serão muitíssimos bem-vindos.

Mineração de textos em notícias de G1: O que diferencia notícias sobre Rio de Janeiro e São Paulo?

Sun, 15 Oct 2017 00:00:00 +0000

library(rvest)
library(tidyverse)
library(magrittr)
library(stringr)
library(Rfacebook)
library(tidytext)
library(tm)

Motivação para o post

Apesar de hoje em dia eu morar no Rio de Janeiro, morei e vivi (quase) a vida toda em Aracaju, a capital do menor estado do Brasil. Devido à irrelevância que a cidade tem (desculpa mas é verdade) no cenário político e econômico do país, era (e ainda é) muito raro ver qualquer notícia em um veículo de audiência nacional (como o Jornal Nacional ou a homepage do G1 ou Estadão) relacionada a Aracaju ou a Sergipe que não seja desgraça ou por um acontecimento inusitadamente ruim. Voltei a notar isso recentemente, quando saiu na homepage do G1 uma notícia de Sergipe sobre o desabamento de um camarote durante a Odonto Fantasy, uma das maiores festas a fantasia do Brasil.

Como bom entusiasta por Data Science, decidi não me ater ao senso comum de que Sergipe só tem destaque nacional por motivos de desgraça e sujei as mãos: é possível testar a hipótese de que certos temas são mais associados a algumas cidades que outras? O que destaca as notícias sobre estados menores que saem na homepage do G1 comparadas com as de estados maiores?

Consigo pensar em pelo menos dois (possivelmente existem mais) métodos para realizar essa análise: além da análise de frequência mencionada acima (a palavra X está mais associada a cidade Y1 do que a cidade Y2), poderia ser aplicada uma análise de sentimento para distinguir o sentimento de notícias relacionadas a Aracaju em comparação com o de cidades maiores. Neste post, o foco será na primeira alternativa.

Coleta dos dados

Vejam que fui enfático sobre a notícia em si ter saído na homepage do G1 ou não. Ou seja, não basta ela ter saído na página local do estado (como a de Sergipe). O primeiro problema é então ter um histórico de notícias que saíram na primeira página, o que não existe em nenhum lugar público na Internet. Não bastaria entrar na página de cada estado e coletar as notícias. Nesta análise, é fundamental ter a certeza de que pessoas de todo o Brasil puderam ter acesso fácil ao artigo.

Para resolver o problema, utilizei o pressuposto de que, se a notícia foi postada na página do G1 no Facebook, é porque ela saiu na home. Não sei o quanto que isso é verdade, mas acredito que seja uma hipótese válida.

Para extrair os links postados na página do G1 no Facebook, utilizamos o pacote Rfacebook:

token <- readRDS("/home/sillas/R/facebook_token.Rds")
g1 <- Rfacebook::getPage("180562885329138", token = token, n = 5000)

O intervalo pesquisado é:

range(sort(g1$created_time))

## [1] "2006-09-18T07:00:00+0000" "2017-10-14T20:46:01+0000"

g1_links <- g1$link

Nem todos os links postados pela página redirecionam ao G1: alguns são de vídeos postados no próprio Facebook. Por isso, é necessário limpar os dados:

# remover links de videos do facebook
g1_links <- g1_links[!str_detect(g1_links, "www.facebook.com")]

# ver links mais comuns
str_replace_all(g1_links, "http://|https://", "") %>% str_replace_all("/.*", "") %>% table()

## .
##                 bit.ly   fantastico.globo.com           g1.globo.com 
##                      8                      1                    717 
##                 glo.bo globoesporte.globo.com        media.giphy.com 
##                    895                      8                      1 
##          s2.glbimg.com 
##                      1

Ainda existem alguns links meio nebulosos. Vamos nos ater aos que são do G1 (g1.globo.com) e do encurtador de URLs da Globo.com (glo.bo). Para estes últimos, como precisamos extrair o estado da notícia da URL (de https://g1.globo.com/se/sergipe/noticia/camarote-desaba-durante-show-de-ivete-sangalo-em-aracaju.ghtml precisamos extrair “se”, a sigla de Sergipe), uso uma função postada no meu Gist para converter uma URL encurtada em normal:

# manter apenas links glo.bo e g1.globo.com
g1_links <- g1_links[str_detect(g1_links, "g1.globo.com|glo.bo") & !is.na(g1_links)]
# carregar funcao para transformar url encurtada
devtools::source_gist("2e92f880811f460c7edd0a622563a17a", filename = "getLongURL.R")
# converter links glo.bo para urls inteiras
ind <- str_which(g1_links, "glo.bo")
getLongURL.curl.possibly <- possibly(getLongURL.curl, otherwise = NA)
novos_links <- g1_links[ind] %>% map_chr(getLongURL.curl.possibly)
g1_links[ind] <- novos_links
# manter apenas links glo.bo e g1.globo.com (para remover links de outros sites da globo, como o Globoesporte.com)
g1_links <- g1_links[str_detect(g1_links, "g1.globo.com|glo.bo") & !is.na(g1_links)]

Tendo os links corrigidos, podemos então criar uma função que extraia o corpo da notícia do link. Como o foco deste post não é o Web Scraping em si e sim os dados resultantes dele, não vou descrever muito o que a função abaixo faz. Em caso de dúvidas, escreva nos comentários do post ou entre em contato comigo que eu responderei com grande prazer.

# criar função
extrair_g1 <- function(url_g1){
  # exemplo de url:
  # "https://g1.globo.com/rio-de-janeiro/noticia/imagens-mostram-acao-de-criminosos-durante-assalto-na-zona-norte-do-rio.ghtml"
  if (!str_detect(url_g1, "glo.bo") & !str_detect(url_g1, "g1.globo")){
    warning(paste0("Link inválido: ", url_g1))
    return(NA)
  }
  
  x <- url_g1 %>% read_html() 
  # extrair sessao da noticia
  css_nome_caderno <- ".header-editoria--link"
  caderno <- x %>% html_nodes(css_nome_caderno) %>% html_text()
  if (length(caderno) == 0) caderno <- NA
  # extrair corpo da noticia
  css_corpo_a <- ".content-text__container"
  css_corpo_b <- "#materia-letra p"
  css_corpo_c <- ".post-content p"
  
  corpo_noticia <- x %>% 
    html_nodes(css_corpo_a) %>% 
    html_text()
  # se o css selector nao funcionou, use outro:
  if (length(corpo_noticia) == 0) {
    corpo_noticia <- x %>% 
      html_nodes(css_corpo_b) %>% 
      html_text()
  } 
  
  if (length(corpo_noticia) == 0) {
    corpo_noticia <- x %>% 
      html_nodes(css_corpo_c) %>% 
      html_text()
  } 
  # colapsar corpo da noticia em um vetor de elemento unico
  corpo_noticia <- paste0(corpo_noticia, collapse = ". ")
  
  
  tibble(url = url_g1, caderno = caderno, corpo_noticia = corpo_noticia)
}

# agora sim extrair dados do g1:
df_g1 <- g1_links %>% map_df(extrair_g1)

# extrair caderno da url da noticia
df_g1$documento  <- df_g1$url %>% 
  str_replace_all("https", "http") %>% 
  str_replace_all("http://g1.globo.com/", "") %>% 
  str_replace_all("/.*", "")

Uma amostra mínima dos dados coletados:

str(df_g1[1,])

## Classes 'tbl_df', 'tbl' and 'data.frame':    1 obs. of  4 variables:
##  $ url          : chr "https://g1.globo.com/politica/operacao-lava-jato/noticia/occhi-tinha-meta-mensal-de-propina-para-distribuir-a-p"| __truncated__
##  $ caderno      : chr "Operação Lava Jato"
##  $ corpo_noticia: chr " O doleiro Lúcio Funaro afirmou em seu acordo de delação premiada com a Procuradoria Geral da República (PGR) q"| __truncated__
##  $ documento    : chr "politica"

Agora podemos partir para a análise. Mas antes, um pouco de contexto teórico:

tf-idf

O Fator de Frequência Inversa no Documento ou term’s inverse document frequency (tf-idf) é uma técnica de mineração de texto que calcula a frequência de um determinado elemento textual (como uma palavra ou um n-gram) em um documento, diminuindo o peso de palavras comumente usadas em vários contextos diferentes (como “a”, “o” e “de”) e aumentando o peso de palavras que não são usadas em outros documentos da coleção.

No glossário de mineração de texto, documento nada mais é do que uma coleção que categoriza um conjunto de textos. Pode ser um livro (inteiro ou apenas um ou mais capítulos), a letra de uma música, um poema, uma notícia, um conjunto de notícias, etc. No nosso contexto, definimos como documento as notícias do G1 coletadas nessa amostra sobre um determinado tema, como Rio de Janeiro, São Paulo, Política ou Economia. Daí o nome da última coluna.

O livro online Text Mining with R é uma ótima referência para tf-idf, tanto teórica quanto prática.

Resultados

Quais são os documentos mais comuns?

df_g1$documento %>% table() %>% sort() %>% rev()

## .
##                   mundo               sao-paulo          rio-de-janeiro 
##                     205                     158                     118 
##                pop-arte              tecnologia                economia 
##                     110                     102                      99 
##                politica                      sp         ciencia-e-saude 
##                      95                      73                      60 
##         planeta-bizarro                bemestar                  musica 
##                      37                      30                      29 
##        distrito-federal                      mg                      pr 
##                      28                      27                      26 
##                  carros   vestibular-e-educacao                   goias 
##                      24                      21                      21 
##                  brasil                educacao             rock-in-rio 
##                      21                      18                      17 
##                natureza          espirito-santo                      sc 
##                      17                      15                      13 
##                      rs           resumo-do-dia            minas-gerais 
##                      13                      13                      13 
##             mato-grosso          11-de-setembro                   bahia 
##                      13                      13                      12 
##                vc-no-g1                  parana           agenda-do-dia 
##                      10                      10                       9 
##                      pi         bienal-do-livro                      rj 
##                       8                       8                       7 
##                     swu              pernambuco                      pb 
##                       6                       6                       6 
##      mato-grosso-do-sul                loterias                      rn 
##                       6                       6                       5 
##                      to                      rr                      ro 
##                       4                       4                       4 
##           revolta-arabe                 paraiba                      pa 
##                       4                       4                       4 
##              fantastico        dia-das-criancas                      ac 
##                       4                       4                       4 
##        turismo-e-viagem       rihanna-no-brasil                   platb 
##                       3                       3                       3 
## justin-bieber-no-brasil              e-ou-nao-e                   ceara 
##                       3                       3                       3 
##                  videos                      se                      ma 
##                       2                       2                       2 
##                 loteria                      ap                      am 
##                       2                       2                       2 
##                      al                    spfw          reveillon-2012 
##                       2                       1                       1 
##    monitor-da-violencia   especial-publicitario               especiais 
##                       1                       1                       1 
##            dia-dos-pais       dia-dos-namorados     concursos-e-emprego 
##                       1                       1                       1 
##                amazonas 
##                       1

As sessões do G1 que mais marcam presença na homepage são, sem muita surpresa, Mundo, São Paulo e Rio de Janeiro. Você pode ter percebido que existe tanto um documento chamado “sao-paulo” como “sp”, assim como “rio-de-janeiro” e “rj”. Isso acontece porque o G1, para os maiores estados, tem sessões separadas para a capital e para o resto das cidades.

Os dois primeiros objetos de estudo são as cidades mais famosas do Brasil: Rio de Janeiro e São Paulo. O passo-a-passo da aplicação do tf-idf para essas duas cidades é descrito abaixo:

docs <- c("rio-de-janeiro", "sao-paulo")

df_filtro  <- df_g1 %>%
  #mutate(caderno_url = if_else(caderno %in% vetor_cadernos, "Selecionado", "Outros"))
  filter(documento %in% docs)

temp <- df_filtro %>% 
  # separar cada palavra do corpo da notícia em uma linha diferente, sem converter para minusculo
  unnest_tokens(palavra, corpo_noticia, token = "ngrams", n = 1, to_lower = FALSE) %>% 
  # remover as duplicatas, isto é, as palavras que aparecem mais de uma vez em uma mesma noticia
  distinct(url, palavra, .keep_all = TRUE) %>% 
  # contar a ocorrencia de cada palavra em cada doc
  count(documento, palavra) %>% 
  tidytext::bind_tf_idf(term = palavra, document = documento, n = n) %>%  
  # ordenar as palavras com menor tf_idf por documento
  group_by(documento) %>% 
  arrange(desc(tf_idf)) %>% 
  mutate(palavra = factor(palavra, levels = rev(unique(palavra)))) %>% 
  #filtrar as 20 de maior destaque
  filter(row_number() <= 20) %>% 
  ungroup() %>% 
  arrange(desc(tf_idf)) %>% 
  mutate(palavra = factor(palavra, levels = rev(unique(palavra))))
    

# construir grafico
temp %>% 
  ggplot(aes(palavra, tf_idf, fill = documento)) +
      geom_col(show.legend = FALSE) +
      geom_text(aes(label = n), hjust = 1.3) +
      labs(x = NULL, y = "tf-idf",
           title = "Termos mais frequentes associados a apenas uma das cidades",
           caption = "Fonte: Mineração de texto aplicada em notícias do G1.") +
      facet_wrap(~documento, ncol = 2, scales = "free") +
      coord_flip()

Algumas observações sobre os resultados precisam ser feitas:
* No Rio de Janeiro, aparecem alguns termos meio estranhos como Envie e VC. Isso acontece porque, durante um período, no final das reportagens, o G1 escrevia algo como “Envie VC também uma reportagem para o G1RJ pelo Whatsapp ou pelo Viber”.
* Alguns nomes próprios se destacam, o que é natural, visto que Dória é prefeito de SP e Cabral um ex-governador do RJ. Em mineração de texto, esse tipo de dado é chamado de Entidade.

Para limpar os resultados no segundo caso, são removidos os substantitos próprios. A maneira que eu bolei para isso talvez não seja a mais científica ou linguisticamente correta possível, mas aparenta ter funcionado. Ela se baseia em remover toda palavra que não é igual se escrita toda em minúsculo ou se escrita toda em maiúsculo. Por exemplo:

eh_substantivo_comum <- function(x) {x == str_to_lower(x) | x == str_to_upper(x)}
c(eh_substantivo_comum("tiroteio"), eh_substantivo_comum("RJTV"), eh_substantivo_comum("Doria"))

## [1]  TRUE  TRUE FALSE

Aproveitando o embalo da limpeza de dados, os termos mencionados acima como “Envie” e “VC” também serão removidos. Aplicando esta metodologia:

temp <- df_filtro %>% 
  unnest_tokens(palavra, corpo_noticia, token = "ngrams", n = 1, to_lower = FALSE) %>% 
  # aplicar regra do substantivo comum
  filter(eh_substantivo_comum(palavra)) %>% 
  # remover termos estranhos
  filter(!palavra %in% c("VC", "RJTV")) %>% 
  distinct(url, palavra, .keep_all = TRUE) %>% 
  count(documento, palavra) %>% 
  tidytext::bind_tf_idf(term = palavra, document = documento, n = n) %>%  
  group_by(documento) %>% 
  arrange(desc(tf_idf)) %>% 
  mutate(palavra = factor(palavra, levels = rev(unique(palavra)))) %>% 
  filter(row_number() <= 20) %>% 
  ungroup() %>% 
  arrange(desc(tf_idf)) %>% 
  mutate(palavra = factor(palavra, levels = rev(unique(palavra))))
    

# construir grafico
temp %>% 
  ggplot(aes(palavra, tf_idf, fill = documento)) +
      geom_col(show.legend = FALSE) +
      geom_text(aes(label = n), hjust = 1.3) +
      labs(x = NULL, y = "tf-idf",
           title = "Termos mais frequentes associados a apenas uma das cidades",
           caption = "Fonte: Mineração de texto aplicada em notícias do G1.") +
      facet_wrap(~documento, ncol = 2, scales = "free") +
      coord_flip()

Agora é possível notar resultados mais interessantes: termos relacionados ao tráfico de drogas como tiroteio, rival, UPP e propinas possui uma frequência relativa muito maior em notícias sobre a cidade do Rio de Janeiro que na capital paulista. Por outro lado, notícias sobre estupro e abuso parecem ser mais comuns na terra onde biscoito é chamado de bolacha.

Também é possível realizar essa mesma análise por expressões compostas por mais de uma palavra, que são os chamados n-grams, onde n é a quantidade de termos. Analisando os 2-grams:

temp <- df_filtro %>% 
  unnest_tokens(palavra, corpo_noticia, token = "ngrams", n = 2, to_lower = FALSE) %>% 
  # aplicar regra do substantivo comum
  filter(eh_substantivo_comum(palavra)) %>% 
  distinct(url, palavra, .keep_all = TRUE) %>% 
  count(documento, palavra) %>% 
  tidytext::bind_tf_idf(term = palavra, document = documento, n = n) %>%  
  group_by(documento) %>% 
  arrange(desc(tf_idf)) %>% 
  mutate(palavra = factor(palavra, levels = rev(unique(palavra)))) %>% 
  filter(row_number() <= 20) %>% 
  ungroup() %>% 
  arrange(desc(tf_idf)) %>% 
  mutate(palavra = factor(palavra, levels = rev(unique(palavra))))
    

# construir grafico
temp %>% 
  ggplot(aes(palavra, tf_idf, fill = documento)) +
      geom_col(show.legend = FALSE) +
      geom_text(aes(label = n), hjust = 1.3) +
      labs(x = NULL, y = "tf-idf") +
      facet_wrap(~documento, ncol = 2, scales = "free") +
      coord_flip()

E Sergipe?

Conforme foi mostrado um pouco acima, existem apenas 2 notícias de Sergipe na amostra coletada. O Sudeste é o grande monopolizador da primeira página do G1. Mesmo se aplicássemos o tf-idf comparando o Rio de Janeiro com Sergipe, os resultados seriam enviesados devido à baixíssima quantidade de dados do último. Por isso, Norte e Nordeste são agregadas como uma:

Vamos então criar mais uma coluna para identificar a região do Brasil a qual a notícia se refere:

df_g1 %<>% 
  mutate(regiao = case_when(
    documento %in% c("ac", "am", "amazonas", "ap", "pa", "ro", "rr") ~ "Norte",
    documento %in% c ("al", "bahia", "ceara", "ma", "paraiba", "pb", "pernambuco", "pi", "rn", "se", "to") ~ "Nordeste",
    documento %in% c("distrito-federal", "goias", "mato-grosso", "mato-grosso-do-sul") ~ "Centro-Oeste",
    documento %in% c("espirito", "mg", "minas-gerais", "rio-de-janeiro", "rj", "sao-paulo", "sp") ~ "Sudeste",
    documento %in% c("parana", "rs", "sc") ~ "Sul",
    #caderno_url %in% "mundo" ~ "Mundo",
    TRUE ~ NA_character_
  ))

df_g1$regiao[df_g1$regiao %in% c("Norte", "Nordeste")] <- "Norte-Nordeste"

# regioes mais comuns:
df_g1$regiao %>% table() %>% sort() %>% rev()

## .
##        Sudeste Norte-Nordeste   Centro-Oeste            Sul 
##            396             75             68             36

Para não ter de repetir o código que constrói os gráficos acima, salvei a função neste Gist, com direito a algumas parametrizações, como a opção de remover ou não substantivos próprios:

id_gist <- "2d626f33ee1b635a0aa3beeda31ae720"
devtools::source_gist(id_gist, filename = "grafico_g1.R")

df_g1 %>% 
  mutate(documento = regiao) %>% 
  filter(!is.na(documento)) %>% 
  grafico_tfidf(n_grams = 1, remover_nomes_proprios = TRUE, agregar_por_noticia = TRUE)

Mesmo agregando os dados por região, o desbalanceamento da quantidade de notícias por região prejudicou os resultados. Seria necessário coletar muito mais notícias para que os resultados fossem mais interessantes.

Bônus

A análise não precisa se restringir a regiões demográficas. Podemos, por exemplo, comparar notícias dos cadernos de Política e Ciência:

df_g1 %>% 
  filter(documento %in% c("politica", "ciencia-e-saude")) %>% 
  grafico_tfidf(n_grams = 1, remover_nomes_proprios = TRUE, agregar_por_noticia = TRUE)

O Sensacionalista e Text Mining: Análise de sentimento usando o lexiconPT

Sat, 23 Sep 2017 00:00:00 +0000

De volta à ativa no blog!

Recentemente, quando precisei fazer pela primeira vez algum tipo de análise em cima de textos (o chamado Text Mining ou Mineração de Texto) em Português, senti falta de ter um acesso fácil a um léxico na linguagem. O R já tem a sua disposição vários recursos para quem quer fazer Text Mining em inglês, como os pacotes tokenizer, tidytext, tm e lexicon, além de vários blog posts sobre Sentiment Analysis que você encontra no R-bloggers. Contudo, existe uma séria escassez de material de referência na língua portuguesa.

O pacote lexiconPT, que eu lancei em 20/09/2017 no Github (e em breve no CRAN também) nasceu para resolver parte desse problema. Até o momento, o lexiconPT possui três datasets de léxicos: o OpLexicon (versões 2.1 e 3.0) e o SentiLex-PT02. Não pretendo (nem tenho competência para tal, pois sou iniciante em Text Mining - sem falsa modéstia) destrinchar como cada um deles funciona e em quê eles diferem. Para isso, sugiro ler as referências citadas na documentação dos próprios datasets (ex.: help("oplexicon_v2.1")).

Mas ter o léxico em mãos só resolve parte dos problemas: ainda faltam os textos em si para serem analisados. Algumas ideias de datasets poderiam ser notícias, letras de músicas, livros (tem vários em Domínio Público), tweets, etc. Para demonstrar um simples uso do pacote, eu decidi por analisar comentários feitos por usuários na página do Sensacionalista, uma das mais populares do Facebook. A coleta dos dados foi relativamente fácil graças ao pacote Rfacebook.

Com o pacote lexiconPT, podemos responder a perguntas como:
* Os comentários no Sensacionalista são mais negativos ou positivos?
* Qual termo está mais associado a comentários negativos? PT ou PSDB? Temer ou Dilma? Bolsonaro ou Lula?
* Qual o comentário feito por um usuário mais negativo da história do Sensacionalista (dentro da amostra coletada)? E qual o mais positivo?

Vamos ao código.

Coleta dos dados

library(Rfacebook) # usado para extrair dados do facebook
library(tidyverse) # pq nao da pra viver sem
library(ggExtra)
library(magrittr) # <3
library(lubridate)
library(stringr) # essencial para trabalhar com textos
library(tidytext) # um dos melhores pacotes para text mining
library(lexiconPT)

Este post só foi possível graças ao Rfacebook. Para aprender como ele funciona, leia a documentação presente em seu repo no Github. Para este primeiro, primeiro usei a função getPage() para extrair as últimas 5000 publicações do Sensacionalista.

# token que eu gerei com minha API key.
# Essa parte vc obviamente nao vai conseguir reproduzir.
# leia o README do Rfacebook para saber como obter seu token
fb_token <- readRDS("/home/sillas/R/data/facebook_token.Rds") 

# demora cerca de 10 min pra rodar:
pg <- getPage("sensacionalista", fb_token, n = 5000)

É necessário corrigir o encoding do corpo da publicação para o R parar de reclamar sobre isso:

# corrigir encoding do texto do post
pg$message %<>% iconv(to = "ASCII//TRANSLIT")
# remover emojis
pg$message %<>% iconv(sub="", 'UTF-8', 'ASCII')
# visualizar dataframe
glimpse(pg)

## Observations: 4,666
## Variables: 11
## $ from_id        <chr> "108175739225302", "108175739225302", "10817573...
## $ from_name      <chr> "Sensacionalista", "Sensacionalista", "Sensacio...
## $ message        <chr> "Apos liminar da Justica do DF permitir o trata...
## $ created_time   <chr> "2017-09-18T18:58:53+0000", "2017-09-18T17:25:0...
## $ type           <chr> "link", "link", "link", "link", "video", "link"...
## $ link           <chr> "http://www.sensacionalista.com.br/2017/09/18/l...
## $ id             <chr> "108175739225302_1638598099516384", "1081757392...
## $ story          <chr> NA, NA, NA, NA, "Sensacionalista shared Gshow -...
## $ likes_count    <dbl> 10172, 2162, 2503, 5793, 4676, 2585, 821, 766, ...
## $ comments_count <dbl> 230, 164, 285, 221, 329, 104, 32, 58, 493, 586,...
## $ shares_count   <dbl> 2290, 453, 410, 2751, 0, 930, 26, 36, 900, 92, ...

Só esse dataset por si só já renderia (e renderá) análises interessantes, mas vou as deixar para um futuro post para não deixar este aqui grande demais.

A coluna id é a que usaremos como referência como input na função getPost() para extrair os comentários dos usuários na publicação. Infelizmente, a API do Facebook apresenta uma certa instabilidade para requests de dados muito grandes. Em várias tentativas que fiz, o máximo de dados que consegui extrair foram 200 comentários de 500 publicações da página. Portanto, vou usar esses parâmetros:

# roda em cerca de 8 minutos:
df_posts <- pg$id[1:500] %>% map(getPost, fb_token, n = 200, comments = TRUE, likes = FALSE,
                            reactions = FALSE)

A função getPost() fornece o seguinte output:

str(df_posts)

## List of 500
##  $ :List of 2
##   ..$ post    :'data.frame': 1 obs. of  10 variables:
##   .. ..$ from_id       : chr "108175739225302"
##   .. ..$ from_name     : chr "Sensacionalista"
##   .. ..$ message       : chr "Após liminar da Justiça do DF permitir o tratamento da homossexualidade como doença"
##   .. ..$ created_time  : chr "2017-09-18T18:58:53+0000"
##   .. ..$ type          : chr "link"
##   .. ..$ link          : chr "http://www.sensacionalista.com.br/2017/09/18/liminar-que-chancela-cura-gay-permite-tratar-justica-brasileira-como-doenca/"
##   .. ..$ id            : chr "108175739225302_1638598099516384"
##   .. ..$ likes_count   : num 11340
##   .. ..$ comments_count: num 248
##   .. ..$ shares_count  : num 2590
##   ..$ comments:'data.frame': 200 obs. of  7 variables:
##   .. ..$ from_id       : chr [1:200] "1437254732976789" "1445900342154501" "10209941046899919" "173469923210786" ...
##   .. ..$ from_name     : chr [1:200] "Sérgio Henrique Reis" "Renata Gil" "Lucas Ferreira" "Leonardo Wesley" ...
##   .. ..$ message       :

## Error in strtrim(encodeString(object, quote = "\"", na.encode = FALSE), : string multibyte inválida em '<a0><be>\xed<b4>\u0094  Ahh do Distrito Federal.... Quando Juscelino Kubitschek fundou Brasília, será que ele tinha a mínima ideia do que sairia de lá?"'

Para extrair os dataframes relativos aos comentários e aos metadados das publicações, o purrr é uma mão na roda:

df_comments <- df_posts %>% map_df("comments")
df_posts <- df_posts %>% map_df("post")
# repetir procedimento de consertar o encoding
df_comments$message %<>% iconv(to = "ASCII//TRANSLIT") %>% iconv(sub="", 'UTF-8', 'ASCII')
df_posts$message %<>% iconv(to = "ASCII//TRANSLIT") %>% iconv(sub="", 'UTF-8', 'ASCII')
# por questoes de anonimizacao, vou remover os dados pessoais referentes aos usuarios
df_comments %<>% select(-from_id, -from_name)

# olhar estrutura dos dataframes
str(df_comments)

## 'data.frame':    72100 obs. of  5 variables:
##  $ message       : chr  "Entao pode faltar no servico, ligar pro chefe(a), levar atestado e dizer que acordou com vontade de chupar rola?" "Nunca o sensacionalista foi tao verdadeiro. Pq a justica brasileira se demonstrou uma verdadeira praga na socie"| __truncated__ "O unico que precisa de tratamento e o sr juiz que autorizou." "Isso viola todas os acordos internacionais e uma aberracao contra qqr liberdade individual e humana. Logo essa liminar cai." ...
##  $ created_time  : chr  "2017-09-18T19:01:21+0000" "2017-09-18T19:03:57+0000" "2017-09-18T19:01:26+0000" "2017-09-18T19:00:54+0000" ...
##  $ likes_count   : num  575 392 270 227 310 145 113 73 38 50 ...
##  $ comments_count: num  58 5 4 3 12 16 10 0 0 8 ...
##  $ id            : chr  "1638598099516384_1638600206182840" "1638598099516384_1638602159515978" "1638598099516384_1638600266182834" "1638598099516384_1638599869516207" ...

str(df_posts)

## 'data.frame':    500 obs. of  10 variables:
##  $ from_id       : chr  "108175739225302" "108175739225302" "108175739225302" "108175739225302" ...
##  $ from_name     : chr  "Sensacionalista" "Sensacionalista" "Sensacionalista" "Sensacionalista" ...
##  $ message       : chr  "Apos liminar da Justica do DF permitir o tratamento da homossexualidade como doenca" "Ja recebeu encomendas de quarteis" "Aparelho esta sendo oferecido por importadores por ate 6 mil reais" "Temer desembarcou nos Estados Unidos para jantar com Trump e participacao na Assembleia Geral da ONU" ...
##  $ created_time  : chr  "2017-09-18T18:58:53+0000" "2017-09-18T17:25:00+0000" "2017-09-18T17:05:41+0000" "2017-09-18T17:00:02+0000" ...
##  $ type          : chr  "link" "link" "link" "link" ...
##  $ link          : chr  "http://www.sensacionalista.com.br/2017/09/18/liminar-que-chancela-cura-gay-permite-tratar-justica-brasileira-como-doenca/" "http://www.sensacionalista.com.br/2017/09/18/fabricante-de-pau-de-arara-comemora-falta-de-resposta-a-general-qu"| __truncated__ "http://www.sensacionalista.com.br/2017/09/18/empresa-lanca-servico-de-escolta-armada-para-quem-comprar-o-iphone-x/" "http://www.sensacionalista.com.br/2017/09/18/coreia-do-norte-nega-ter-lancado-temer-nos-eua/" ...
##  $ id            : chr  "108175739225302_1638598099516384" "108175739225302_1638510679525126" "108175739225302_1638503796192481" "108175739225302_1638456466197214" ...
##  $ likes_count   : num  11340 2271 2826 6361 4990 ...
##  $ comments_count: num  248 167 315 242 347 106 32 58 494 590 ...
##  $ shares_count  : num  2590 478 441 3008 0 ...

Só pode ser trollagem da API do Facebook retornar aquela mensagem logo no topo do dataframe, mas enfim.

O dataframe df_comments, o objeto da nossa análise, não possui alguns dados que serão valiosos para a análise, como o link para o artigo no site do Sensacionalista. Por isso, vamos um left_join com o df_posts.

Percebeu que nas colunas df_comments$id e df_posts$id existe um traço separando dois conjuntos numéricos? Por alguma razão que beira a imbecilidade, não é possível combinar imediatamente essas duas colunas para formatar um dataframe só com o left_join. A sintaxe de identificação do Facebook funciona assim: O post é identificado IDPAGINA_IDPUBLICAÇÃO e o comentário na publicação é identificado como IDPUBLICAÇÃO_IDCOMENTÁRIO. Ou seja, para poder juntar os dois dataframes, vamos ter que combinar a sequência númerica à esquerda do underline (acho que esse traço tem algum outro nome, mas não me lembro no momento) em df_comments$id e à direita em df_posts$id.

# consertar colunas de id: no df_comments, deixar à esquerda do underline. no df_posts, deixar à direita.
df_comments$id_post_real <- df_comments$id
df_comments$id %<>% str_replace_all("_.*", "")
df_posts$id %<>% str_replace_all(".*_", "")

# juntar as duas tabelas
df_posts %<>% dplyr::select(id, post_message = message, horario_post = created_time,
                     type, post_comments_count = comments_count, post_link = link,
                     post_type = type, post_likes_count = likes_count)
df_comments %<>% rename(horario_comentario = created_time)

df_comments %<>% left_join(df_posts, by = "id")
# remover NAs (nao sao muitos casos)
df_comments %<>% filter(!is.na(horario_post))
# converter colunas de horario
df_comments$horario_comentario %<>% str_sub(1, 19) %>% str_replace_all("T", "") %>% ymd_hms()
df_comments$horario_post %<>% str_sub(1, 19) %>% str_replace_all("T", "") %>% ymd_hms()
# Como ficou:
glimpse(df_comments)

## Observations: 71,891
## Variables: 12
## $ message             <chr> "Entao pode faltar no servico, ligar pro c...
## $ horario_comentario  <dttm> 2017-09-18 19:01:21, 2017-09-18 19:03:57,...
## $ likes_count         <dbl> 575, 392, 270, 227, 310, 145, 113, 73, 38,...
## $ comments_count      <dbl> 58, 5, 4, 3, 12, 16, 10, 0, 0, 8, 69, 3, 0...
## $ id                  <chr> "1638598099516384", "1638598099516384", "1...
## $ id_post_real        <chr> "1638598099516384_1638600206182840", "1638...
## $ post_message        <chr> "Apos liminar da Justica do DF permitir o ...
## $ horario_post        <dttm> 2017-09-18 18:58:53, 2017-09-18 18:58:53,...
## $ post_type           <chr> "link", "link", "link", "link", "link", "l...
## $ post_comments_count <dbl> 248, 248, 248, 248, 248, 248, 248, 248, 24...
## $ post_link           <chr> "http://www.sensacionalista.com.br/2017/09...
## $ post_likes_count    <dbl> 11340, 11340, 11340, 11340, 11340, 11340, ...

Uso do lexiconPT

Agora temos o dataset em mãos para usar o lexiconPT. Acho muito importante ressaltar que Text Mining é uma atividade razoavelmente complexa que envolve uma extensa etapa de limpeza e tratamento de dados, como remover (ou não) acentos e corrigir palavras com letras duplicadas (tristee) ou erros gramaticais (infelismente). Para fins de simplicidade, não vou me ater muito a esses detalhes e pular direto para a utilização dos léxicos portugueses e apresentação dos resultados.

# carregar datasets
data("oplexicon_v3.0")
data("sentiLex_lem_PT02")

op30 <- oplexicon_v3.0
sent <- sentiLex_lem_PT02

glimpse(op30)

## Observations: 32,191
## Variables: 4
## $ term              <chr> "=[", "=@", "=p", "=P", "=x", "=d", "=D", ";...
## $ type              <chr> "emot", "emot", "emot", "emot", "emot", "emo...
## $ polarity          <int> -1, -1, -1, -1, -1, 1, 1, 1, 1, -1, -1, -1, ...
## $ polarity_revision <chr> "A", "A", "A", "A", "A", "A", "A", "A", "A",...

glimpse(sent)

## Observations: 7,014
## Variables: 5
## $ term                    <chr> "a-vontade", "abafado", "abafante", "a...
## $ grammar_category        <chr> "N", "Adj", "Adj", "Adj", "Adj", "Adj"...
## $ polarity                <dbl> 1, -1, -1, -1, -1, 1, -1, 1, 1, -1, -1...
## $ polarity_target         <chr> "N0", "N0", "N0", "N0", "N0", "N0", "N...
## $ polarity_classification <chr> "MAN", "JALC", "MAN", "JALC", "JALC", ...

Ambos os datasets possuem colunas de polaridade de sentimento, que é a que usaremos para quantificar o quão negativo ou positivo é um comentário.

# criar ID unica para cada comentario
df_comments %<>% mutate(comment_id = row_number())
# usar funçao do tidytext para criar uma linha para cada palavra de um comentario
df_comments_unnested <- df_comments %>% unnest_tokens(term, message)

df_comments_unnested %>%
  select(comment_id, term) %>%
  head(20)

##      comment_id     term
## 1             1    entao
## 1.1           1     pode
## 1.2           1   faltar
## 1.3           1       no
## 1.4           1  servico
## 1.5           1    ligar
## 1.6           1      pro
## 1.7           1    chefe
## 1.8           1        a
## 1.9           1    levar
## 1.10          1 atestado
## 1.11          1        e
## 1.12          1    dizer
## 1.13          1      que
## 1.14          1  acordou
## 1.15          1      com
## 1.16          1  vontade
## 1.17          1       de
## 1.18          1   chupar
## 1.19          1     rola

De novo esse comentário…

Enfim, veja que foi criada uma linha para cada palavra presetnte no comentário. Será essa nova coluna term que usaremos como referência para quantificar o sentimento de um comentário.

df_comments_unnested %>% 
  left_join(op30, by = "term") %>% 
  left_join(sent %>% select(term, lex_polarity = polarity), by = "term") %>% 
  select(comment_id, term, polarity, lex_polarity) %>% 
  head(10)

##    comment_id    term polarity lex_polarity
## 1           1   entao       NA           NA
## 2           1    pode       NA           NA
## 3           1  faltar        1           NA
## 4           1      no       NA           NA
## 5           1 servico       NA           NA
## 6           1   ligar       -1           NA
## 7           1     pro       NA           NA
## 8           1   chefe       NA           NA
## 9           1       a       NA           NA
## 10          1   levar       -1           NA

A amostra acima mostra que nem toads as palavras possuem uma polaridade registrada nos léxicos. Não só isso, mas algumas palavras (como faltar, ligar e levar) estão presentes no OpLexicon mas não no SentiLex. A polaridade 1 em faltar significa que, de acordo com esse léxico, a palavra está associada a comentários positivos. Saber essa diferença é fundamental, pois a escolha do léxico pode ter uma grande influência nos resultados da análise.

Vamos então manter no dataframe apenas as palavras que possuem polaridade tanto no OpLexicon como no SentiLex:

df_comments_unnested <- df_comments_unnested %>% 
  inner_join(op30, by = "term") %>% 
  inner_join(sent %>% select(term, lex_polarity = polarity), by = "term") %>% 
  group_by(comment_id) %>% 
  summarise(
    comment_sentiment_op = sum(polarity),
    comment_sentiment_lex = sum(lex_polarity),
    n_words = n()
    ) %>% 
  ungroup() %>% 
  rowwise() %>% 
  mutate(
    most_neg = min(comment_sentiment_lex, comment_sentiment_op),
    most_pos = max(comment_sentiment_lex, comment_sentiment_op)
  )

head(df_comments_unnested)

## # A tibble: 6 x 6
##   comment_id comment_sentiment_op comment_sentiment_lex n_words most_neg
##        <int>                <int>                 <dbl>   <int>    <dbl>
## 1          2                    0                     0       2        0
## 2          7                   -2                    -3       3       -3
## 3          8                    1                     1       2        1
## 4          9                    0                     0       3        0
## 5         11                   -1                    -1       3       -1
## 6         12                   -3                    -3       3       -3
## # ... with 1 more variables: most_pos <dbl>

Apresentação dos resultados

O gráfico de pontos abaixo mostra a distribuição de polaridade para cada léxico:

df_comments_unnested %>% 
  ggplot(aes(x = comment_sentiment_op, y = comment_sentiment_lex)) +
    geom_point(aes(color = n_words)) + 
    scale_color_continuous(low = "green", high = "red") +
    labs(x = "Polaridade no OpLexicon", y = "Polaridade no SentiLex") +
    #geom_smooth(method = "lm") +
    geom_vline(xintercept = 0, linetype = "dashed") +
    geom_hline(yintercept = 0, linetype = "dashed")

Existem pelo menos três outliers nos dados, todos causados pela grande quantidade de palavras do comentário, o que pode ser um indício de que simplesmente somar a polaridade de cada palavra do comentário pode não ser um bom método. Outra informação revelada pelo gráfico é que existem palavras que possuem sentimentos diferentes de acordo com o léxico usado. Ter isso em mente é fundamental para a análise.

Após remover os outliers, já é possível descobrir quais os comentários mais positivos e mais negativos da amostra coletada:

df_comments_unnested %<>% filter(between(comment_sentiment_op, -10, 10))

# comentario mais positivo da historia do sensacionalista
most_pos <- which.max(df_comments_unnested$most_pos)
most_neg <- which.min(df_comments_unnested$most_neg)

# mais positivo
cat(df_comments$message[df_comments$comment_id == df_comments_unnested$comment_id[most_pos]])

## O mundo a esquerda e sempre melhor. A musica, o pincel, a pena e a talha. Sempre esteve para a esquerda. As grandes mentes criativas, os grandes pensadores, os humanistas, os geniais. Tudo que e original e belo e oriundo da esquerda.
## E tendencia natural do ser humano, ao passo q alcanca um minimo de consciencia critica do mundo sempre tender a esquerda.
## Todavia o mundo tambem precisa de mentes computacionais, a esse papel a direita tem seu valor. A direita funciona bem quando o objetivo e produzir o fisico, o tangivel e operacional. Embora isso tambem pudesse ser feito por maquinas, robos, ou mesmo por animais adestrados.
## A exemplo, os EUA, onde o cidadao comum e um ser vegetativo, destinado a operar, produzir e consumir. Sao seres incapazes de formular um pensamento critico e original. Uma nacao que por forca do capital tem seu vies ideologico voltado pra direita. Ainda q por vezes elejam um presidente com vies de esquerda, nunca irao evoluir sua consciencia. Sera sempre uma nacao de dementes e ignorantes.
## Nao por acaso que o capital, na sua forma economica ou politica sempre se poe sobre a direita quando tem por objetivo o ganho, financeiro ou de poder. E sobre a direita q se faz os movimentos de massa imbecilizada, pois como seres roboticos sao facilmente levados aonde se quer levar.
## A esquerda liga-se ao mundo das ideias, ao pensamento critico, a modelagem do ser humano como ser consciente. A esquerda e a construcao do pensamento, e o
## individuo pensante e critico, tudo que evolui e eleva o ser humano a um patamar de consciencia superior, provem da esquerda.
## Nacoes capitalistas, ainda q direitista, mas q sua massa possui em sua construcao um vies ideologico de esquerda serao sempre nacoes ricas financeiramente e ricas de estado de consciencia critica. Observa se isto em paises europeus, onde o
## capital existe por forca do consumo, mas coexiste com o estado de bem estar social, com a beleza das artes e com tudo aquilo e natural da esquerda, enquanto consciencia e beleza.
## A direita tem por tendencia natural, o simples, o computacional e robotizado. O argumento da direita e sempre algoritmo, linear e raso. A direita sera sempre um universo de seres ocos, massivos e imbecilizados.
## A.L.C.

# mais negativo
cat(df_comments$message[df_comments$comment_id == df_comments_unnested$comment_id[most_neg]])

## No ultimo domingo foi ao ar o programa do Silvio Santos, onde Maisa foi ridiculamente feita de idiota por duas pessoas na frente do Brasil todo. Onde mesmo ela pedindo pra parar, nao pararam. Mas eu to aqui apenas pra falar a verdade sobre uma dessas pessoas: DUDU CAMARGO. 
## Muitos o conhecem como o cara chato que apresenta o jornal da manha, mas eu o conheco como o EX ABUSIVO QUE FEZ COISAS IMPERDOAVEIS. 
## Tudo comecou quando nos conhecemos na escola, quando ele fez de tudo pra me conquistar, e eu era bobo. Cai. Comecamos a namorar e era tudo incrivel e flores, mesmo com o preconceito, era bom ter alguem com quem contar e gostar. 
## As coisas foram andando, e mesmo com todas as pessoas dizendo pra eu nao continuar esse relacionamento, eu continuei. Meus professores, meus amigos, e ate gente desconhecida tentaram abrir meus olhos. Mas ja era tarde. Eu estava apaixonado! Ia fazer de tudo pra ficar com ele!
## O terror comeca. 
## Estava tudo bem, ate ele comecar a ser agressivo e babaca. Gritava, ficava de cara feia, falava merda, e eu tambem, mas ele foi ao extremo. Ele estava vidrado em ser um astro da tv que esqueceu que tinha um relacionamento e comecou a me tratar como lixo, ate que ele me machucou feio, arranhou meu braco e deixou uma cicatriz em uma de nossas brigas. Nao sou santo, claro que tentei revidar para me defender. Mas apenas UMA vez.
## As brigas e abusos tornaram-se serios, ele cada dia era mais estourado, e nao so comigo, com todos, ate com a familia, que por sinal sempre o apoiou. Mas ele sempre queria ser mais que todos.
## Nao contente em 1, ele bateu 2, 3, 4... Varias vezes. Ja cheguei em casa com o rosto machucado e tive que mentir pra minha mae, mas ela nao era e nem e burra, sabia o que tinha acontecido. 
## Na escola, todos perguntavam e eu mentia, achando que estava tudo bem, mas nao estava. Eu estava tao apaixonado que nao conseguia sair daquele pesadelo.
## Outro ponto: ABUSO SEXUAL. Isso e bem serio, e se fosse brincadeira, eu nao estaria me expondo assim. Em um relacionamento voce consequentemente transa com a pessoa, e no comeco era bom, era normal. Mas depois das agressoes, eu fiquei tao em choque que inventava que estava doente para nao ter que fazer nada com ele. E ele reclamava, e bla bla bla, e dizia que sexo nao era nada, mas era. Ate que ele comecou a falar coisas horriveis para mim, comecou ficar tao frustrado que comecou a forcar coisas dizendo que se eu nao fizesse, era pra eu ir embora e nunca mais voltar, e que se eu voltasse, ele me trataria pior do que ja estava tratando. Mas eu fiquei, nao sei o porque, mas fiquei, com todo o medo e receio. 
## Toda vez que eu queria conversar com ele sobre algo, ele ia direto me mandando ficar quieto e me chamava pra fazer coisas... Quando ele nao estava no instagram ou implorando para alguma aparicao na tv. 
## Eu estava louco e assustado, a escola chamou minha mae pra conversar pois estavam com medo de que eu fizesse algo comigo mesmo, meu psicologico estava destruido e eu fiquei com depressao. 
## Algumas pessoas vao dizer que eu quem quis, ja que nao fui embora, mas nao e bem assim. 
## Nao tenho tudo registrado, - e acho que nem preciso - mas eu vivi, as pessoas viram e tentaram me ajudar, mas eu recusei, com medo. 
## Passei muitas coisas boas no comeco, mas depois eu vi o monstro que ele era/e. Ele pode se fazer de santo na tv, mas muita gente sabe quem ele realmente e. E eu sei o que eu sofri. 
## Vao dizer que e tudo mentira, e que eu quero fama. Talvez que sou louco, mas felizmente tenho testemunhas e nao tenho mais medo de me esconder. Depois de domingo, ele provou ser a pessoa mais falsa e artificial que existe. Engessado, segundo a Maisa. 
## Nao e porque ele e uma pessoa publica que pode fazer o que quer sem pagar. Sei das consequencias que posso ter, mas nada tira a paz que sinto sabendo que tenho pessoas incriveis que me apoiaram e apoiam ate hoje. 
## Espero que entendam e ajudem as pessoas que precisam. Se voce sabe alguem que esteja nessa vida, ajude-a a sair... Nao importa quem seja. Chega de abuso!

Por incrível que pareça, tanto o comentário mais positivo quanto o mais negativo falam sobre a esquerda.

Para prosseguir com a análise, usaremos o léxico OpLexicon para a análise de sentimento:

df_comments %<>% inner_join(
  df_comments_unnested %>% select(comment_id, sentiment = comment_sentiment_op),
  by = "comment_id"
  )
# criar coluna de data (variavel da classe Date)
df_comments$data <- as.Date(df_comments$horario_post)

Agora sim podemos demonstrar uma visualização de uma análise básica de sentimento: Como tem sido o sentimento geral dos comentários no Sensacionalista ao longo do tempo?

df_comments_wide <- df_comments %>% 
  # filtrar fora palavras neutras
  filter(sentiment != 0) %>% 
  # converter numerico para categorico
  mutate(sentiment = ifelse(sentiment < 0, "negativo", "positivo")) %>% 
  # agrupar os dados
  count(data, post_link, post_type, sentiment) %>% 
  # converter para formato wide
  spread(sentiment, n, fill = 0) %>% 
  mutate(sentimento = positivo - negativo) %>% 
  ungroup() %>% 
  arrange(data)

head(df_comments_wide) %>% knitr::kable()

data	post_link	post_type	negativo	positivo	sentimento
2017-04-13	https://www.facebook.com/sensacionalista/photos/a.187587037950838.39557.108175739225302/1460990897277106/?type=3	photo	7	17	10
2017-04-13	http://www.sensacionalista.com.br/2017/04/13/temer-lula-e-fhc-articulam-pacto-de-nao-rir-de-brasileiro-que-desfez-amizade-no-facebook-por-politica/	link	32	34	2
2017-04-14	https://www.facebook.com/sensacionalista/photos/a.187587037950838.39557.108175739225302/1462221330487396/?type=3	photo	42	22	-20
2017-04-15	https://www.facebook.com/sensacionalista/photos/a.187587037950838.39557.108175739225302/1463589740350555/?type=3	photo	7	27	20
2017-04-16	https://www.sensacionalista.com.br/2016/03/25/laja-jato-diz-que-lula-comprou-ovo-da-kopenhagen-em-nome-de-amigo/	link	23	35	12
2017-04-16	http://www.sensacionalista.com.br/2017/04/10/as-18-melhores-coisas-com-sentimentos-a-nova-obsessao-da-internet/	link	17	16	-1

Por exemplo, o primeiro link coletado na amostra, uma foto, teve 9 palavras contadas como negativas e 13 como positivas. O score geral dos comentários nessa publicação foi 13 - 9 = 4.

Qual a publicação do Sensacionalista com maior nível de “positividade”? E o de “negatividade”?

df_comments_wide %>% 
  arrange(sentimento) %>% 
  filter(row_number() == 1 | row_number() == nrow(df_comments_wide)) %>% 
   knitr::kable()

data	post_link	post_type	negativo	positivo	sentimento
2017-09-11	http://www.sensacionalista.com.br/2017/09/11/projeto-do-mbl-pretende-vestir-obras-de-arte-em-museus-ao-redor-do-mundo/	link	95	39	-56
2017-06-05	http://www.sensacionalista.com.br/2017/06/05/festa-se-nada-der-certo-em-colegio-debocha-de-garis-e-faxineiras-e-mostra-que-ja-deu-tudo-errado/	link	29	86	57

A publicação que mais recebeu comentários negativos (não tenho certeza se é essa a interpretação mais correta dos resultados, mas enfim) é um link sobre o MBL, enquanto o mais positivo é sobre o famoso caso do “E se der errado”.

O gráfico abaixo mostra a evolução do sentimento dos comentários nas publicações do Sensacionalista ao longo do tempo:

df_comments_wide %>% 
  mutate(index = row_number()) %>% 
  ggplot(aes(x = index, y = sentimento)) +
    geom_col(aes(fill = post_type)) +
    scale_y_continuous(breaks = seq(-60, 60, 20), limits = c(-60, 60)) +
    labs(x = "Índice da publicação", y = "Sentimento",
         fill = NULL, title = "Evolução do sentimento em publicações do Sensacionalista")

Uma possível interpretação do gráfico é que a série temporal não possui uma clara tendência, apesar de os picos de negatividade serem bem mais frequentes que os de positividade.

Outra análise que dá para fazer é investigar o nível de sentimento de comentários associados a determinadas palavras. Por exemplo, o quão negativo costuma ser um comentário quando ele menciona a palavra bolsonaro?

# qual o sentimento mais associado a palavras em especifico
df_comments %>% 
  mutate(
    temer = str_detect(str_to_lower(message), "temer"),
    lula = str_detect(str_to_lower(message), "lula"),
    pmdb = str_detect(str_to_lower(message), "pmdb"),
    psdb = str_detect(str_to_lower(message), "psdb"),
    pt = str_detect(str_to_lower(message), "pt"),
    dilma = str_detect(str_to_lower(message), "dilma"),
    doria = str_detect(str_to_lower(message), "doria"),
    governo = str_detect(str_to_lower(message), "governo"),
    bolsonaro = str_detect(str_to_lower(message), "bolsonaro")
  ) %>% 
  gather(termo, eh_presente, temer:bolsonaro) %>% 
  filter(eh_presente) %>% 
  group_by(termo) %>% 
  summarise(sentiment = mean(sentiment)) %>% 
  ggplot(aes(x = termo, y = sentiment)) + 
    geom_col(fill = "#C10534")

Temer e Dilma, os dois presidentes com os piores níveis de popularidade de República, estarem associados a comentários positivos é bem surpreendente. Na verdade, isso ocorre porque a própria palavra temer possui polaridade positiva. Para consultar a polaridade de uma palavra nos datasets presentes no lexiconPT, use a função lexiconPT::get_word_sentiment().

get_word_sentiment("temer")

## $oplexicon_v2.1
##        term type polarity
## 28711 temer   vb        1
## 
## $oplexicon_v3.0
##        term type polarity polarity_revision
## 30160 temer   vb        1                 A
## 
## $sentilex
##       term grammar_category polarity polarity_target
## 6546 temer                V       -1           N0:N1
##      polarity_classification
## 6546                     MAN

Conclusão e chamada para futuros trabalhos

O pacote lexiconPT, apesar de simples, tem um enorme potencial para enriquecer o conteúdo de Text Mining em Português na comunidade brasileira de R. O exemplo dado nesse post pode ser considerado deveras simplório. Muitas etapas foram puladas ou desconsideradas com o intuito de fornecer a você uma rápida introdução às possibilidades criadas pelo pacote. Espero que o leitor deste post tenha se sentido motivado a fazer suas próprias análises de sentimento. As possibilidade são incontáveis.

Referências

Text Mining with R - A Tidy Approach: Livro online gratuito sobre Text Mining feito pela autora do pacote tidytext;
Single Word Analysis of Early 19th Century Poetry Using tidytext;
Texto no R;
A Fixação de Colbert;
Mineração de Texto - Prof. Walmes M. Zeviani;
Pacote tidytext;
Text Mining of Stack Overflow Questions;
Women in film

Slides da minha apresentação no SER 2017

Tue, 23 May 2017 00:00:00 +0000

Hoje (23/05), o Paixão por Dados esteve presente no II Seminário Internacional de Estatística com R, realizado na UFF, em Niterói. Com muito orgulho, pude falar de parte dos projetos que realizei com R, conquistas pessoais e profissionais que obtive como resultado pela minha dedicação à linguagem e ainda dicas para quem quer se aprofundar no R.

Os slides da minha apresentação, entitulada Como o R pode despertar sua paixão por dados se encontram aqui.

Blog Paixão por Dados estará no meetup 1º #AnalyticsEmTudo - Dados Abertos

Thu, 16 Feb 2017 00:00:00 +0000

Com muito orgulho, anuncio que o blog Paixão por Dados estará representado no primeiro meetup do grupo #AnalyticsEmTudo, no Rio de Janeiro, onde moro atualmente. Serei um dos três palestrantes do encontro. Falarei um pouco sobre os principais projetos que realizei usando o R, dando maior ênfase aos relacionados a Dados Abertos, que é o tema dessa edição.

mafs: Analisando a eficácia dos modelos preditivos usados no pacote

Sun, 29 Jan 2017 00:00:00 +0000

Lancei recentemente a versão 0.0.2 do pacote mafs tanto no CRAN como no Github. Adicionei dois novos recursos:
* No data frame df_models criado, foi acrescentada uma variável referente ao tempo de execução (runtime) do modelo para a série temporal de input. Isso foi uma necessidade devido ao fato de alguns modelos levarem muito tempo para rodar. Esse dado será importante para ser levado em consideração no segundo recurso adicionado:
* A função select_forecast() agora tem um argumento chamado dont_apply, no qual o usuário poderá inserir os modelos (em forma de vetor de caracteres) que não deverão ser usados na função para criar modelos preditivos. Esse recurso é muito útil para excluir da função os pacotes que demoram muito e que não costumam entregar bons resultados.

Neste post, farei uma demonstração da aplicação do pacote mafs em diversas séries temporais diferentes.

# carregar pacotes importantes
library(fpp)
library(dplyr)
library(ggplot2)
library(mafs)
library(magrittr)
library(ggrepel)

Os dados

As séries temporais usadas pertencem ao pacote fpp, que disponibiliza as séries temporais usadas no livro do Hyndman.

Vamos armazenar essas diversas séries em uma lista:

data_fpp <- list(a10 = a10, ausair = ausair, ausbeer = ausbeer,
                 austa = austa, austourists = austourists,
                 cafe = cafe, debitcards = debitcards,
                 elecequip = elecequip, elecsales = elecsales,
                 euretail = euretail, guinearice = guinearice,
                 h02 = h02, livestock = livestock,
                 oil = oil, sunspotarea = sunspotarea,
                 usmelec = usmelec, wmurders = wmurders
                 )
# confirmando que todas as séries são objetos do tipo 'ts', que é a classe
# usada como input para a funcão select_forecast()
lapply(data_fpp, class) %>% unlist

##         a10      ausair     ausbeer       austa austourists        cafe 
##        "ts"        "ts"        "ts"        "ts"        "ts"        "ts" 
##  debitcards   elecequip   elecsales    euretail  guinearice         h02 
##        "ts"        "ts"        "ts"        "ts"        "ts"        "ts" 
##   livestock         oil sunspotarea     usmelec    wmurders 
##        "ts"        "ts"        "ts"        "ts"        "ts"

Será que todas essas séries são mensais? Podemos confirmar essa informação com a função frequency().

lapply(data_fpp, frequency) %>% unlist

##         a10      ausair     ausbeer       austa austourists        cafe 
##          12           1           4           1           4           4 
##  debitcards   elecequip   elecsales    euretail  guinearice         h02 
##          12          12           1           4           1          12 
##   livestock         oil sunspotarea     usmelec    wmurders 
##           1           1           1          12           1

# fazer um gráfico
lapply(data_fpp, frequency) %>% unlist %>% table %>% barplot()

Temos então 8 séries anuais (frequência 1), 4 trimestrais e 5 mensais. Esse será um bom teste para o pacote mafs.

Modelagem

Para aplicar a função select_forecast() em todas as séries, é necessário um for loop:

# criar lista vazia para salvar os resultados
df_results <- vector("list", length = length(data_fpp))

# iniciar loop
for (i in 1:length(data_fpp)){
  print(i)
  # salvar serie do loop
  data <- data_fpp[[i]]
  # usar tamanho da serie de teste de 6. o horizonte de previsão não importa
  # nao usar modelo híbrido apenas como demonstração do novo arg dont_apply
  mafs_result <- select_forecast(data, test_size = 6, horizon = 3,
                                 error = "MAPE", dont_apply = "hybrid")
  
  mafs_result <- mafs_result$df_models
  # acrescentar nome da série no dataframe dos resultados
  mafs_result$serie <- names(data_fpp)[i]
  df_results[[i]] <- mafs_result
}

# converter para data frame
df_results <- bind_rows(df_results)
saveRDS(df_results, "/home/sillas/R/data/2017-01-29-mafs02.Rds")

Análise dos dados

Uma rápida visualização tabular dos resultados:

head(df_results)

##        model         ME      RMSE       MAE        MPE      MAPE     MASE
## 1 auto.arima -0.5266278  2.726579  2.317648  -3.404950 11.368897 1.867733
## 2       bats -0.6987866  2.543283  2.302901  -3.848498 11.063269 1.855849
## 3    croston  0.9954976  3.783578  2.770328   2.119148 11.608482 2.232536
## 4        ets -0.1664123  2.315405  2.059765  -1.141468  9.653898 1.659911
## 5      meanf 12.1695849 12.705245 12.169585  52.965233 52.965233 9.807155
## 6      naive -3.3000045  4.920821  4.586426 -17.426919 21.763365 3.696083
##          ACF1 best_model runtime_model serie
## 1 -0.48291837        ets         1.508   a10
## 2 -0.50875972        ets         4.643   a10
## 3 -0.07557645        ets         1.717   a10
## 4 -0.49674756        ets         1.501   a10
## 5 -0.07557645        ets         0.001   a10
## 6 -0.07557645        ets         0.004   a10

Vamos ver então quais modelos despontam como os mais rápidos e os mais eficientes.

Primeiro, um gráfico do tempo de execução por pacote

ggplot(df_results, aes(x = reorder(model, runtime_model, FUN = median),
                       y = runtime_model)) +
  geom_boxplot() +
  labs(x = NULL, y = "Tempo de execução (s)") +
  coord_flip()

Percebe-se que os modelos tbats() e bats() são os mais computacionalmente custosos. Os mais rápidos são, sem surpresas, os modelos de previsão simples, como o da média simples e o modelo ingênuo.

Agora, um gráfico da acurácia dos modelos de acordo com a métrica MAPE:

ggplot(df_results, aes(x = reorder(model, -MAPE, FUN = median),
                       y = MAPE)) +
  geom_boxplot() +
  labs(x = NULL, y = "MAPE (%)") +
  coord_flip()

Alguns modelos apresentaram outliers, o que distorceu o boxplot. Visto que esse gráfico não serviu para muita coisa, é melhor resumir a acurácia por meio da mediana simples do MAPE:

# calcular a mediana do MAPE para cada modelo
df_results %>%
  group_by(model) %>%
  summarise(MAPE_mediano = median(MAPE)) %>%
  ggplot(aes(x = reorder(model, -MAPE_mediano), y = MAPE_mediano)) +
    geom_bar(stat = "identity") +
    labs(x = NULL, y = "MAPE mediano") +
    coord_flip() +
    theme_bw()

Vê-se que os modelos que obtiveram os melhores resultados foram os modelos stlm(), seja por arima ou por ets. Não vou entrar em detalhes estatísticos sobre o porquê desse resultado para não fugir do escopo do post.

Vamos então analisar a relação entre tempo de execução e eficácia dos modelos por meio de um gráfico de pontos.

ggplot(df_results, aes(x = runtime_model, y = MAPE)) + 
  geom_point() +
  theme_bw()

É difícil visualizar alguma relação muito clara nesse gráfico. Ao invés de plotar todos os data points, vamos resumir os dados pela mediana do MAPE e do runtime para cada modelo.

df_results %>%
  group_by(model) %>%
  summarise(MAPE_mediano = median(MAPE),
            runtime_mediano = median(runtime_model)) %>%
  ggplot(aes(y = runtime_mediano,  x = MAPE_mediano)) +
    geom_point() +
    labs(y =  "Tempo de execução mediano (s)",
         x = "MAPE mediano (%)") +
    geom_text_repel(aes(label = model)) +
    theme_bw()

Novamente, não é possível determinar que a acurácia do modelo influencia o seu tempo de execução.

Análise da influência da frequência da série

Influência no tempo de execução

Já que estamos trabalhando ao mesmo tempo com séries trimestrais, mensais e anuais, por que não analisar a influência da variável da frequência da série nos resultados obtidos com o pacote?

Primeiro, vamos criar um data frame com características sobre as séries analisadas

df_series <- data.frame(
  serie = names(data_fpp),
  frequencia = lapply(data_fpp, frequency) %>% unlist,
  tamanho_serie = lapply(data_fpp, length) %>% unlist
)

# juntar ao dataframe de resultados
df_results %<>% left_join(df_series, by = "serie")

names(data_fpp)

##  [1] "a10"         "ausair"      "ausbeer"     "austa"       "austourists"
##  [6] "cafe"        "debitcards"  "elecequip"   "elecsales"   "euretail"   
## [11] "guinearice"  "h02"         "livestock"   "oil"         "sunspotarea"
## [16] "usmelec"     "wmurders"

Para demosntrar a influência da frequência da série no tempo de execução dos modelos, uma boa opção de visualização é o gráfico de densidade:

df_results$frequencia %<>% as.factor

df_results %>%
  filter(runtime_model <= quantile(runtime_model, 0.90)) %>%
  ggplot(aes(x = runtime_model, color = frequencia)) + geom_density()

É difícil tirar qualquer tipo de conclusão a partir do gráfico acima. Dá para afirmar que a probabilidade de um modelo ter um runtime muito curto (de até 0,25 segundos) é menor para séries mensais e trimestrais do que para mensais.

Um teste estatístico que pode ser usado para mensura essa relação é o ANOVA e o teste de Tukey:

anova.fit <- aov(runtime_model ~ frequencia, data = df_results)
summary(anova.fit)

##              Df Sum Sq Mean Sq F value Pr(>F)  
## frequencia    2    221  110.36   3.599 0.0287 *
## Residuals   262   8035   30.67                 
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

# Teste de Tukey
anova.fit %>% TukeyHSD()

##   Tukey multiple comparisons of means
##     95% family-wise confidence level
## 
## Fit: aov(formula = runtime_model ~ frequencia, data = df_results)
## 
## $frequencia
##           diff        lwr      upr     p adj
## 4-1  0.4026234 -1.6041101 2.409357 0.8840947
## 12-1 2.0767411  0.1990179 3.954464 0.0260572
## 12-4 1.6741176 -0.4496095 3.797845 0.1530838

O resultado do teste ANOVA aponta um valor significante (valor p menor que 0,05), o que indica que a hipótese nula de que a frequência da série não influencia o tempo de execução do ajuste pode ser rejeitado.

Já o teste de Tukey indica que apenas a hipótese nula só pode ser rejeitada para a comparação entre séries mensais e anuais. Para as outras duas comparações, o valor p é maior que 0,05.

Influência na acurácia

df_results %>%
  filter(MAPE <= quantile(MAPE, 0.90)) %>%
  ggplot(aes(x = MAPE, color = frequencia)) + geom_density()

anova.fit <- aov(MAPE ~ frequencia, data = df_results)
summary(anova.fit)

##              Df   Sum Sq Mean Sq F value   Pr(>F)    
## frequencia    2   900822  450411   10.14 5.71e-05 ***
## Residuals   262 11633340   44402                     
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

# Teste de Tukey
anova.fit %>% TukeyHSD()

##   Tukey multiple comparisons of means
##     95% family-wise confidence level
## 
## Fit: aov(formula = MAPE ~ frequencia, data = df_results)
## 
## $frequencia
##             diff        lwr       upr     p adj
## 4-1  -120.929333 -197.28734 -44.57133 0.0006774
## 12-1 -115.580724 -187.02977 -44.13168 0.0005011
## 12-4    5.348609  -75.46111  86.15832 0.9866718

Conclusão

Uma próxima análise poderia incluir um número maior de séries e de frequências diferentes, como diárias e semanais.

Anunciando a criação do rbloggers-BR: Seu novo feed de artigos sobre o R

Sat, 24 Dec 2016 00:00:00 +0000

É com grande orgulho que eu anuncio a concretização de um antigo projeto meu: a criação de um agregador de blogs brasileiros sobre o R, no estilo do R-Bloggers: O rbloggers-BR, um bot do twitter que a cada período de tempo posta as mais recentes publicações de blogs relacionados a linguagem R.

Atualmente, o bot não consegue funcionar em tempo real e sim a cada x horas por meio de um agendador de tarefas (como o Task Scheduler do Windows). Sugestões de como fazer a atualização do bot ser instantânea são bem-vindas.

Usei apenas três blogs para testar o funcionamento do bot: o meu, o do Neylson e o Symposio. Sugestões de outros blogs são muitíssimo bem-vindas, porém só serão aceitas se feitas por meio de issues no repositório do bot.

Esse é um projeto que tem potencial para ser de grande valor para a comunidade R brasileira. Por isso, sinta-se a vontade para contribuir, seja por meio de pull requests ou apenas com ideias e sugestões de melhorias.

Paixão por Dados

Anunciando um "novo" dataset no Kaggle: Pesquisa Origem Destino do Metrô SP

Motivação

Como usar os dados

E Python?

Qual o melhor serviço de streaming de filmes e séries no Brasil? O R responde.

Introdução

Primeiro passo: Coletando nomes de filmes e seriados

Usar o módulo Python para coletar dados da API do JustWatch

Juntando os dados

Resultados

Quais sites possuem mais filmes e seriados?

Quais sites possuem os filmes mais recentes?

Qualidade dos filmes

Exclusividade de conteúdo

Bônus: Diagrama de Venn

Conclusão

A equação mais perigosa do mundo e o efeito do tamanho da amostra nos resultados

Introdução

Geração dos dados por simulação

Geração das amostras

Análise dos resultados

Análise e simulação de investimentos com o pacote calcCidadao

Calculadora do Cidadão

Funções básicas do pacote

Estudo de caso para o pacote: Análise de um Título Pré-Fixado

Conclusão

Mapeando a abertura de escolas municipais em São Paulo ao longo dos anos com um GIF

Coleta e limpeza dos dados

Apresentação dos dados

Criando o mapa

Acrescentando o elemento tempo no mapa

Publicidade

Topic Modeling: Um algoritmo consegue entender sobre o que fala a youtuber Nathalia Arcuri?

Coleta dos dados

Limpeza dos dados

Topic Modeling

Pré-processamento

Criação do modelo de tópicos e interpretação dos resultados

Atribuição de tópicos a vídeos

Análise de Sentimento

Conclusão

Referências

BBB no R: Estudando as interações entre membros por análise de redes

Coleta dos dados

Visualização dos dados

Análise da Rede

Conclusão

Sobre gráficos e a mensagem que eles querem transmitir

Anunciando o lançamento de literaturaBR

Paixão por Dados de cara nova!

literaturaBR, o mais novo pacote da comunidade R Brasil

Introdução

Análise básica

Análise comparativa entre os livros

Análise de Sentimento

Complexidade léxica e ocorrência de palavras

Conclusão

Mineração de textos em notícias de G1: O que diferencia notícias sobre Rio de Janeiro e São Paulo?

Motivação para o post

Coleta dos dados

tf-idf

Resultados

E Sergipe?

Bônus

O Sensacionalista e Text Mining: Análise de sentimento usando o lexiconPT

Coleta dos dados

Uso do lexiconPT

Apresentação dos resultados

Conclusão e chamada para futuros trabalhos

Referências

Slides da minha apresentação no SER 2017

Blog Paixão por Dados estará no meetup 1º #AnalyticsEmTudo - Dados Abertos

mafs: Analisando a eficácia dos modelos preditivos usados no pacote

Os dados

Modelagem

Análise dos dados

Análise da influência da frequência da série

Influência no tempo de execução

Influência na acurácia