Brasil x Argentina, tidytext e Machine Learning

Aplicando técnincas de Text Mining como pacote tidy text para explorar a rivalidade entre Brasil e Argentina! Veja também como a análise de sentimentos pode ser divertida além de possíveis aplicações de machine learning

Fellipe Gomes

30 minute read

Brasil vs Argentina e Text Mining

A copa do mundo esta ai novamente e como não poderia ser diferente, com ela surgem novos quintilhões de bytes todos os dias, saber analisar esses dados é um grande desafio pois a maioria dessa informação se encontra de forma não estruturada e além do desafio de captar esses dados ainda existem mais desafios que podem ser ainda maiores, como o de processá-los e obter respostas deles.

Dada a rivalidade histórica entre Brasil e Argentina achei que seria interessante avaliar como anda o comportamento das pessoas do Brasil nas mídias sociais em relação a esses dois países. Para o post não ficar muito longo, escolhi que iria recolher informações apenas do Twitter devido a praticidade, foram coletados os últimos 4.000 tweets com o termo “brasil” e os últimos “4.000” tweets com o termo “argentina” no Twitter através da sua API com o pacote os twitteR e ROAuth. O código pode ser conferido neste link.

Análise de textos sempre foi um tema que me interessou muito, no final do ano de 2017 quando era estagiário me pediram para ajudar em uma pesquisa que envolvia a análise de palavras criando algumas nuvens de palavras. Pesquisando sobre técnicas de textmining descobri tantas abordagens diferentes que resolvi juntar tudo que tinha encontrado em uma única função (que será apresentada a seguir) para a confecção dessas nuvens, utilizarei esta função para ter uma primeira impressão dos dados.

Além disso, como seria um problema a tarefa de criar as nuvens de palavras só poderia ser realizada por alguém com conhecimento em R, na época estava começando meus estudo sobre shiny e como treinamento desenvolvi um app que esta hospedado no link: https://gomesfellipe.shinyapps.io/appwordcloud/ e o código esta aberto e disponível para quem se interessar no meu github neste link

Porém, após ler e estudar o livro Text Mining with R - A Tidy Approach por Silge; Robinson (2018) hoje em dia eu olho para trás e vejo que poderia ter feito tanto a função quanto o aplicativo de maneira muito mais eficiente portanto esse post trás alguns dos meus estudos sobre esse livro maravilhoso e também algum estudo sobre Machine Learning com o pacote caret

Importando a dados

Como já foi dito, a base de dados foi obtida através da API do twitter e o código pode ser obtido neste link.

suppressMessages(library(dplyr))
suppressMessages(library(kableExtra))
suppressMessages(library(magrittr))

base <- read.csv("original_books.csv") %>% as_tibble()

Nuvem de palavras rápida com função customizada

Para uma primeira impressão dos dados, vejamos o que retorna uma nuvem de palavras criada com a função wordcloud_sentiment() que desenvolvi antes de conhecer a “A Tidy Approach” para Text Mining:

devtools::source_url("https://raw.githubusercontent.com/gomesfellipe/functions/master/wordcloud_sentiment.R")
## SHA-1 hash of file is 10ac998534c5f9ea4c06b79183ab676a6bb5e1e2
# Obtendo nuvem e salvando tabela num objeto com nome teste:
df <- wordcloud_sentiment(base$text,
                      type = "text",
                      sentiment = F,
                      excludeWords = c("nao",letters,LETTERS),
                      ngrams = 2,
                      tf_idf = F,
                      max = 100,
                      freq = 10,
                      horizontal = 0.9,
                      textStemming = F,
                      print=T)

Não poderia esquecer, além da nuvem, a função também retorna um dataframe com a frequência das palavras:

df %>% as_tibble()
## # A tibble: 13,667 x 2
##    words          freq  
##  * <fct>          <fct> 
##  1 brasil copa    2065  
##  2 copa mundo     1959  
##  3 hat trick      1327  
##  4 hoje brasil    1215  
##  5 messi          " 929"
##  6 mundo          " 914"
##  7 estreia brasil " 874"
##  8 copa           " 827"
##  9 pra copa       " 813"
## 10 hoje           " 740"
## # ... with 13,657 more rows

E outra função interessante é a de criar uma nuvem a partir de um webscraping muito (muito mesmo) introdutório, para isso foi pegar todo o texto da página sobre a copa do mundo no Wikipédia, veja:

# Obtendo nuvem e salvando tabela num objeto com nome teste:
df_html <- wordcloud_sentiment("https://pt.wikipedia.org/wiki/Copa_do_Mundo_FIFA",
                      type = "url",
                      sentiment = F,
                      excludeWords = c("nao",letters,LETTERS),
                      ngrams = 2,
                      tf_idf = F,
                      max = 100,
                      freq = 6,
                      horizontal = 0.9,
                      textStemming = F,
                      print=T)
## Carregando pacotes exigidos: bitops

Essa função é bem “prematura”, existem infinitas maneiras de melhorar ela e não alterei ela ainda por falta de tempo.

A Tidy Approach

O formato tidy, em que cada linha corresponde a uma observação e cada coluna à uma variável, veja:

Agora a tarefa será simplificada com a abordagem tidy, além das funções do livro Text Mining with R utilizarei a função clean_tweets que adaptei inspirado nesse post dessa pagina: Quick guide to mining twitter with R quando estudava sobre textmining.

Arrumando e transformando a base de dados

Utilizando as funções do pacote tidytext em conjunto com os pacotes stringr e abjutils, será possível limpar e arrumar a base de dados.

Além disso serão removidas as stop words de nossa base, com a função stopwords::stopwords("pt") podemos obter as stopwords da nossa língua

suppressMessages(library(stringr))
suppressMessages(library(tidytext))
suppressMessages(library(abjutils))

devtools::source_url("https://raw.githubusercontent.com/gomesfellipe/functions/master/clean_tweets.R")
## SHA-1 hash of file is 1bc5c5a1e83e36c5535545a73c4f61cd49327e20
original_books = base %>% 
  mutate(text = clean_tweets(text) %>% enc2native() %>% rm_accent())

#Removendo stopwords:
excludewords=c("[:alpha:]","[:alnum:]","[:digit:]","[:xdigit:]","[:space:]","[:word:]",
               LETTERS,letters,1:10,
               "hat","trick","bc","de","tem","twitte","fez",
               'pra',"vai","ta","so","ja","rt")

stop_words = data_frame(word = c(stopwords::stopwords("pt"), excludewords))

tidy_books <- original_books %>%
  unnest_tokens(word, text) %>% 
  anti_join(stop_words)
## Joining, by = "word"

Portando a base de dados após a limpeza e a remoção das stop words:

#Palavras mais faladas:
tidy_books %>%
  count(word, sort = TRUE) 
## # A tibble: 3,943 x 2
##    word          n
##    <chr>     <int>
##  1 copa       6993
##  2 brasil     4164
##  3 argentina  3487
##  4 mundo      2030
##  5 hoje       1825
##  6 letras     1562
##  7 nao        1517
##  8 messi      1493
##  9 estreia    1268
## 10 penalti     933
## # ... with 3,933 more rows
#Apos a limpeza, caso precise voltar as frases:
original_books = tidy_books%>%
  group_by(book,line)%>%
  summarise(text=paste(word,collapse = " "))

Palavras mais frequentes

Vejamos as palavras mais faladas nessa pesquisa:

suppressMessages(library(ggplot2))

tidy_books %>%
  count(word, sort = TRUE) %>%
  filter(n > 400) %>%
  mutate(word = reorder(word, n)) %>%
  
  ggplot(aes(word, n, fill = I("yellow"), colour = I("green"))) +
  geom_col(position="dodge") +
  xlab(NULL) +
  labs(title = "Frequencia total das palavras pesquisadas")+
  coord_flip()+ theme(
  panel.background = element_rect(fill = "#74acdf",
                                colour = "lightblue",
                                size = 0.5, linetype = "solid"),
  panel.grid.major = element_line(size = 0.5, linetype = 'solid',
                                colour = "white"), 
  panel.grid.minor = element_line(size = 0.25, linetype = 'solid',
                                colour = "white")
  )

Palavras mais frequentes para cada termo

Vejamos as nuvens de palavras mais frequentes de acordo com cada um dos termos pesquisados:

#Criando nuvem de palavra:
library(wordcloud)

par(mfrow=c(1,2))
tidy_books %>%
  filter(book=="br")%>%
  count(word) %>%
  with(wordcloud(word, n, max.words = 100,random.order = F,min.freq = 15,random.color = F,colors = c("#009b3a", "#fedf00","#002776"),scale = c(2,1),rot.per = 0.05))

tidy_books %>%
  filter(book=="arg")%>%
  count(word) %>%
  with(wordcloud(word, n, max.words = 100,min.freq = 15,random.order = F,random.color = F,colors = c("#75ade0", "#ffffff","#f6b506"),scale = c(2,1),rot.per = 0.05))

par(mfrow=c(1,1))

Análise de sentimentos

A análise de sentimentos utilizando a abordagem tidy foi possível graças ao pacote lexiconPT, que esta disponível no CRAN e que conheci ao ler o post: “O Sensacionalista e Text Mining: Análise de sentimento usando o lexiconPT” do blog Paixão por dados que gosto tanto de acompanhar.

# Analise de sentimentos:
library(lexiconPT)

sentiment = data.frame(word = sentiLex_lem_PT02$term ,
                       polarity = sentiLex_lem_PT02$polarity) %>% 
  mutate(sentiment = if_else(polarity>0,"positive",if_else(polarity<0,"negative","neutro")),
         word = as.character(word)) %>% 
  as_tibble()


suppressMessages(library(tidyr))

book_sentiment <- tidy_books %>%
  inner_join(sentiment) %>%
  count(book,word, index = line , sentiment) %>%
  spread(sentiment, n, fill = 0) %>%
  mutate(sentiment = positive - negative) %T>%
  print
## Joining, by = "word"
## # A tibble: 3,212 x 7
##    book  word       index negative neutro positive sentiment
##    <fct> <chr>      <int>    <dbl>  <dbl>    <dbl>     <dbl>
##  1 arg   abandonar    857     1.00   0        0        -1.00
##  2 arg   absurdo      849     1.00   0        0        -1.00
##  3 arg   absurdo     1863     1.00   0        0        -1.00
##  4 arg   acougueiro  1413     1.00   0        0        -1.00
##  5 arg   afogado     2275     1.00   0        0        -1.00
##  6 arg   afogado     3659     1.00   0        0        -1.00
##  7 arg   alegria     1134     0      0        1.00      1.00
##  8 arg   alto        3055     0      1.00     0         0   
##  9 arg   amador      1592     0      1.00     0         0   
## 10 arg   amar        1811     0      1.00     0         0   
## # ... with 3,202 more rows

Cada palavra possui um valor associado a sua polaridade , vejamos como ficou distribuído o número de palavras de cada sentimento de acordo com cada termo escolhido para a pesquisa:

book_sentiment%>%
  count(sentiment,book)%>%
  arrange(book) %>%
  
  ggplot(aes(x = factor(sentiment),y = n,fill=book))+
  geom_bar(stat="identity",position="dodge")+
  facet_wrap(~book) +
  theme_bw()+ 
    scale_fill_manual(values=c("#75ade0", "#009b3a"))

Comparando sentimentos dos termos de pesquisa

Para termos associados a palavra “Brasil” no twitter:

# Nuvem de comparação:
suppressMessages(library(reshape2)) 

tidy_books %>%
  filter(book=="br")%>%
  inner_join(sentiment) %>%
  count(word, sentiment, sort = TRUE) %>%
  acast(word ~ sentiment, value.var = "n", fill = 0) %>%
  comparison.cloud(colors = c("red", "gray80","green"),
                   max.words = 200)
## Joining, by = "word"

Para termos associados a palavra “Argentina” no twitter:

tidy_books %>%
  filter(book=="arg")%>%
  inner_join(sentiment) %>%
  count(word, sentiment, sort = TRUE) %>%
  acast(word ~ sentiment, value.var = "n", fill = 0) %>%
  comparison.cloud(colors = c("red", "gray80","green"),
                   max.words = 200)
## Joining, by = "word"

Proporção de palavras positivas e negativas por texto

# Proporção de palavras negativas:
bingnegative <- sentiment %>% 
  filter(sentiment == "negative")

bingpositive <- sentiment %>% 
  filter(sentiment == "positive")

wordcounts <- tidy_books %>%
  group_by(book, line) %>%
  summarize(words = n())
Para negativas;
tidy_books %>%
  semi_join(bingnegative) %>%
  group_by(book, line) %>%
  summarize(negativewords = n()) %>%
  left_join(wordcounts, by = c("book", "line")) %>%
  mutate(ratio = negativewords/words) %>%
  top_n(5) %>%
  ungroup() %>% arrange(desc(ratio)) %>% filter(book=="br")
## Joining, by = "word"
## Selecting by ratio
## # A tibble: 683 x 5
##    book   line negativewords words ratio
##    <fct> <int>         <int> <int> <dbl>
##  1 br     2580             2     7 0.286
##  2 br        2             1     4 0.250
##  3 br        7             1     4 0.250
##  4 br       10             1     4 0.250
##  5 br       20             1     4 0.250
##  6 br       25             1     4 0.250
##  7 br       34             1     4 0.250
##  8 br       58             1     4 0.250
##  9 br       65             1     4 0.250
## 10 br       70             1     4 0.250
## # ... with 673 more rows

A frase mais negativa do brasil e da argentina::

base %>%
  filter(book=="br",line==2580) %>% mutate(text = as.character(text))%>% select(text) %>% c() 
## $text
## [1] "um medo? — de nois criar expectativa e o Brasil perder a copa https://t.co/0chcNWHh0m"
base %>%
  filter(book=="arg",line==572) %>% mutate(text = as.character(text))%>% select(text) %>% c()  
## $text
## [1] "RT @DavidmeMelo: @SantiiSanchez16 @Flamengo Perder a copa para o time mais sujo e mais corrupto da argentina é assim mesmo https://t.co/zIC…"
Para positivas:
tidy_books %>%
  semi_join(bingpositive) %>%
  group_by(book, line) %>%
  summarize(positivewords = n()) %>%
  left_join(wordcounts, by = c("book", "line")) %>%
  mutate(ratio = positivewords/words) %>%
  top_n(5) %>%
  ungroup() %>% arrange(desc(ratio))
## Joining, by = "word"
## Selecting by ratio
## # A tibble: 18 x 5
##    book   line positivewords words ratio
##    <fct> <int>         <int> <int> <dbl>
##  1 arg    2120             3     9 0.333
##  2 br     2374             1     3 0.333
##  3 arg    3272             2     7 0.286
##  4 arg    1751             2     8 0.250
##  5 arg    2301             1     4 0.250
##  6 arg    2806             2     8 0.250
##  7 br      553             2     8 0.250
##  8 br     1499             2     9 0.222
##  9 br     2054             2     9 0.222
## 10 br       16             1     5 0.200
## 11 br      126             1     5 0.200
## 12 br      212             1     5 0.200
## 13 br      232             1     5 0.200
## 14 br     1591             1     5 0.200
## 15 br     1923             1     5 0.200
## 16 br     2095             2    10 0.200
## 17 br     2591             1     5 0.200
## 18 br     3281             1     5 0.200

A frase mais positiva do brasil e da argentina:

base %>%
  filter(book=="br",line==2374) %>% mutate(text = as.character(text))%>% select(text) %>% c() 
## $text
## [1] "Tirei Brasil, é uma honra https://t.co/OgNCot4Wu0"
base %>%
  filter(book=="arg",line==2120) %>% mutate(text = as.character(text))%>% select(text) %>% c()  
## $text
## [1] "@_LeoFerreiraH Quero que a Argentina passe para possivelmente enfrentar o Brasil, ganhar da Argentina já é bom, na… https://t.co/bxHJUeGVpc"

TF-IDF

Segundo Silge; Robinson (2018) no livro tidytextminig:

The statistic tf-idf is intended to measure how important a word is to a document in a collection (or corpus) of documents, for example, to one novel in a collection of novels or to one website in a collection of websites.

Traduzido pelo Google tradutor:

A estatística tf-idf destina-se a medir a importância de uma palavra para um documento em uma coleção (ou corpus) de documentos, por exemplo, para um romance em uma coleção de romances ou para um site em uma coleção de sites.

Matematicamente:

\[ idf(\text{term}) = \ln{\left(\frac{n_{\text{documents}}}{n_{\text{documents containing term}}}\right)} \]

E que com o pacote tidytext podemos obter usando o comando bind_tf_idf(), veja:

# Obtendo numero de palavras
book_words <- original_books %>%
  unnest_tokens(word, text) %>%
  count(book, word, sort = TRUE) %>%
  ungroup()%>%
  anti_join(stop_words)
## Joining, by = "word"
total_words <- book_words %>% 
  group_by(book) %>% 
  summarize(total = sum(n))

book_words <- left_join(book_words, total_words)
## Joining, by = "book"
# tf-idf:
book_words <- book_words %>%
  bind_tf_idf(word, book, n)

book_words %>%
  arrange(desc(tf_idf))
## # A tibble: 4,802 x 7
##    book  word              n total      tf   idf  tf_idf
##    <fct> <chr>         <int> <int>   <dbl> <dbl>   <dbl>
##  1 br    letras         1562 30006 0.0521  0.693 0.0361 
##  2 arg   penalti         933 40244 0.0232  0.693 0.0161 
##  3 br    ansioso         688 30006 0.0229  0.693 0.0159 
##  4 arg   classificou     666 40244 0.0165  0.693 0.0115 
##  5 arg   segundo         654 40244 0.0163  0.693 0.0113 
##  6 arg   especialistas   649 40244 0.0161  0.693 0.0112 
##  7 arg   repito          649 40244 0.0161  0.693 0.0112 
##  8 br    icon            248 30006 0.00827 0.693 0.00573
##  9 arg   silencio        290 40244 0.00721 0.693 0.00499
## 10 arg   colocou         270 40244 0.00671 0.693 0.00465
## # ... with 4,792 more rows

O que nos trás algo como: “termos mais relevantes”.

Visualmente:

book_words %>%
  arrange(desc(tf_idf)) %>%
  mutate(word = factor(word, levels = rev(unique(word)))) %>% 
  group_by(book) %>% 
  top_n(15) %>% 
  ungroup %>%
  
  ggplot(aes(word, tf_idf, fill = book)) +
  geom_col(show.legend = FALSE) +
  labs(x = NULL, y = "tf-idf") +
  facet_wrap(~book, ncol = 2, scales = "free") +
  coord_flip()+
  theme_bw()+ 
    scale_fill_manual(values=c("#75ade0", "#009b3a"))
## Selecting by tf_idf

bi grams

OS bi grams são sequencias de palavras, a seguir será procurada as sequencias de duas palavras, o que nos permite estudar um pouco melhor o contexto do seu uso.

# Bi grams
book_bigrams <- original_books %>%
  unnest_tokens(bigram, text, token = "ngrams", n = 2)

book_bigrams %>%
  count(bigram, sort = TRUE)
## # A tibble: 12,027 x 3
## # Groups:   book [2]
##    book  bigram                    n
##    <fct> <chr>                 <int>
##  1 br    brasil copa            2030
##  2 br    copa mundo             1459
##  3 br    hoje brasil            1215
##  4 arg   argentina copa         1119
##  5 br    estreia brasil          856
##  6 br    ansioso estreia         685
##  7 arg   classificou argentina   660
##  8 arg   copa segundo            649
##  9 arg   messi repito            649
## 10 arg   repito classificou      649
## # ... with 12,017 more rows

Separando as coluna de bi grams:

bigrams_separated <- book_bigrams %>%
  separate(bigram, c("word1", "word2"), sep = " ")

bigrams_filtered <- bigrams_separated %>%
  filter(!word1 %in% stop_words$word) %>%
  filter(!word2 %in% stop_words$word)

# new bigram counts:
bigram_counts <- bigrams_filtered %>% 
  count(word1, word2, sort = TRUE)

bigram_counts
## # A tibble: 12,027 x 4
## # Groups:   book [2]
##    book  word1       word2           n
##    <fct> <chr>       <chr>       <int>
##  1 br    brasil      copa         2030
##  2 br    copa        mundo        1459
##  3 br    hoje        brasil       1215
##  4 arg   argentina   copa         1119
##  5 br    estreia     brasil        856
##  6 br    ansioso     estreia       685
##  7 arg   classificou argentina     660
##  8 arg   copa        segundo       649
##  9 arg   messi       repito        649
## 10 arg   repito      classificou   649
## # ... with 12,017 more rows

Caso seja preciso juntar novamente:

bigrams_united <- bigrams_filtered %>%
  unite(bigram, word1, word2, sep = " ")

bigrams_united
## # A tibble: 62,255 x 3
## # Groups:   book [2]
##    book   line bigram             
##    <fct> <int> <chr>              
##  1 arg       1 islandia pouco     
##  2 arg       1 pouco mil          
##  3 arg       1 mil habitantes     
##  4 arg       1 habitantes montaram
##  5 arg       1 montaram selecao   
##  6 arg       1 selecao estao      
##  7 arg       1 estao copa         
##  8 arg       1 copa fizeram       
##  9 arg       1 fizeram gol        
## 10 arg       1 gol argentina      
## # ... with 62,245 more rows

Analisando bi grams com tf-idf

Também é possível aplicar a transformação tf-idf em bigrams, veja:

#bi grams com tf idf
bigram_tf_idf <- bigrams_united %>%
  count(book, bigram) %>%
  bind_tf_idf(bigram, book, n) %>%
  arrange(desc(tf_idf))

bigram_tf_idf
## # A tibble: 12,027 x 6
## # Groups:   book [2]
##    book  bigram                    n     tf   idf  tf_idf
##    <fct> <chr>                 <int>  <dbl> <dbl>   <dbl>
##  1 br    hoje brasil            1215 0.0467 0.693 0.0324 
##  2 br    ansioso estreia         685 0.0263 0.693 0.0183 
##  3 br    letras letras           620 0.0238 0.693 0.0165 
##  4 arg   classificou argentina   660 0.0182 0.693 0.0126 
##  5 arg   copa segundo            649 0.0179 0.693 0.0124 
##  6 arg   messi repito            649 0.0179 0.693 0.0124 
##  7 arg   repito classificou      649 0.0179 0.693 0.0124 
##  8 arg   segundo especialistas   649 0.0179 0.693 0.0124 
##  9 br    brasil letras           313 0.0120 0.693 0.00834
## 10 br    letras brasil           313 0.0120 0.693 0.00834
## # ... with 12,017 more rows

Analisando contexto de palavras negativas:

Uma das abordagens interessantes ao estudar as bi-grams é a de avaliar o contexto das palavras negativas, veja:

bigrams_separated %>%
  filter(word1 == "nao") %>%
  count(word1, word2, sort = TRUE)
## # A tibble: 280 x 4
## # Groups:   book [2]
##    book  word1 word2         n
##    <fct> <chr> <chr>     <int>
##  1 arg   nao   bom         259
##  2 arg   nao   pq          259
##  3 br    nao   blusa        97
##  4 br    nao   pode         73
##  5 arg   nao   podem        54
##  6 arg   nao   desleal      39
##  7 arg   nao   reclamou     39
##  8 br    nao   alg          34
##  9 arg   nao   passariam    31
## 10 br    nao   to           20
## # ... with 270 more rows
not_words <- bigrams_separated %>%
  filter(word1 == "nao") %>%
  inner_join(sentiment, by = c(word2 = "word")) %>%
  count(word2, sentiment, sort = TRUE) %>%
  ungroup()

not_words
## # A tibble: 17 x 4
##    book  word2     sentiment     n
##    <fct> <chr>     <chr>     <int>
##  1 arg   bom       positive    259
##  2 arg   desleal   negative     39
##  3 br    ganhar    positive      8
##  4 arg   ganhar    positive      5
##  5 arg   pior      negative      3
##  6 arg   ruim      negative      3
##  7 arg   gostar    neutro        2
##  8 arg   vencer    positive      2
##  9 arg   amigo     positive      1
## 10 arg   melhor    neutro        1
## 11 arg   sao       positive      1
## 12 arg   verdade   positive      1
## 13 br    amistoso  positive      1
## 14 br    educacao  positive      1
## 15 br    perder    negative      1
## 16 br    preparado positive      1
## 17 br    vao       negative      1

A palavra não antes de uma palavra “positiva”, como por exemplo “não gosto” pode ser anulada ao somar-se suas polaridades (“não” = - 1, “gosto” = +1 e “não gosto” = -1 + 1) o leva a necessidade de ser tomar um cuidado especial com essas palavras em uma análise de texto mais detalhada, veja de forma visual:

not_words %>%
  mutate(sentiment=ifelse(sentiment=="positive",1,ifelse(sentiment=="negative",-1,0)))%>%
  mutate(contribution = n * sentiment) %>%
  arrange(desc(abs(contribution))) %>%
  head(20) %>%
  mutate(word2 = reorder(word2, contribution)) %>%
  
  ggplot(aes(word2, n * sentiment, fill = n * sentiment > 0)) +
  geom_col() +
  xlab("Words preceded by \"not\"") +
  ylab("Sentiment score * number of occurrences") +
  coord_flip()+
  theme_bw()

Machine Learning

Estava pesquisando sobre algorítimos recomendados para a análise de texto quando encontrei um artigo da data camp chamado: Lyric Analysis with NLP & Machine Learning with R, do qual a autora expõe a seguinte tabela:

Portanto resolvi fazer uma brincadeira e ajustar 4 dos modelos propostos para a tarefa supervisionada de classificação: K-NN, Tress (tentarei o ajuste do algorítimo Random Forest), Logistic Regression (Modelo estatístico) e Naive-Bayes (por meio do cálculo de probabilidades condicionais) para ver se conseguia recuperar a classificação de quais os termos de pesquisa que eu utilizei para obter esses dados

Além de técnicas apresentadas no livro do pacote caret, por Kuhn (2018), muito do que apliquei aqui foi baseado no livro “Introdução a mineração de dados” por Silva; Peres; Boscarioli (2016), que foi bastante útil na minha introdução sobre o tema Machine Learning.

Vou utilizar uma função chamada plot_pred_type_distribution(),apresentada neste post de titulo: Illustrated Guide to ROC and AUC e fiz uma pequena alteração para que ela funcionasse para o dataset deste post . A função adaptada pode ser encontrada neste link no meu github e a função original neste link do github do autor.

Pacote caret

Basicamente o ajuste de todos os modelos envolveram o uso do pacote caret e muitos dos passos aqui foram baseados nas instruções fornecidas no livro do pacote. O pacote facilita bastante o ajuste dos parâmetros no ajuste de modelos.

Transformar e arrumar

Uma solução do kaggle para o desafio Toxic Comment Classification Challenge me chamou atenção, do qual o participante da competição criou colunas que sinalizassem os caracteres especiais de cada frase, utilizarei esta técnica para o ajuste e novamente utilizarei o pacote de léxicos do apresentado no post do blog Paixão por dados

Veja a base transformada e arrumada:

# Ref: https://cfss.uchicago.edu/text_classification.html 
# https://www.r-bloggers.com/illustrated-guide-to-roc-and-auc/
devtools::source_url("https://raw.githubusercontent.com/gomesfellipe/functions/master/plot_pred_type_distribution.R")
## SHA-1 hash of file is 28a80d11778ba40d627731ab0c78bf2d783da269
base <- base %>% 
  mutate(length = str_length(text),
         ncap = str_count(text, "[A-Z]"),
         ncap_len = ncap / length,
         nexcl = str_count(text, fixed("!")),
         nquest = str_count(text, fixed("?")),
         npunct = str_count(text, "[[:punct:]]"),
         nword = str_count(text, "\\w+"),
         nsymb = str_count(text, "&|@|#|\\$|%|\\*|\\^"),
         nsmile = str_count(text, "((?::|;|=)(?:-)?(?:\\)|D|P))"),
         text = clean_tweets(text) %>% enc2native() %>% rm_accent())%>%
  unnest_tokens(word, text) %>% 
  anti_join(stop_words)%>%
  group_by(book,line,length, ncap, ncap_len, nexcl, nquest, npunct, nword, nsymb, nsmile)%>%
  summarise(text=paste(word,collapse = " ")) %>% 
  select(text,everything())%T>% 
  print()
## Joining, by = "word"
## # A tibble: 7,995 x 12
## # Groups:   book, line, length, ncap, ncap_len, nexcl, nquest, npunct,
## #   nword, nsymb [7,995]
##    text  book   line length  ncap ncap_len nexcl nquest npunct nword nsymb
##    <chr> <fct> <int>  <int> <int>    <dbl> <int>  <int>  <int> <int> <int>
##  1 isla~ arg       1    139     7   0.0504     0      0      7    21     1
##  2 pau ~ arg       2    108     6   0.0556     0      0      2    20     1
##  3 mess~ arg       3    140    10   0.0714     0      0      4    24     1
##  4 minu~ arg       4    140     2   0.0143     0      0      3    22     1
##  5 requ~ arg       5    129    23   0.178      0      0     15    21     1
##  6 bras~ arg       6    139    11   0.0791     0      0     13    20     1
##  7 dupl~ arg       7    123    84   0.683      0      0      8    21     1
##  8 mess~ arg       8    140    10   0.0714     0      0      4    24     1
##  9 mess~ arg       9    140    10   0.0714     0      0      4    24     1
## 10 mess~ arg      10    140    10   0.0714     0      0      4    24     1
## # ... with 7,985 more rows, and 1 more variable: nsmile <int>

Após arrumar e transformar as informações que serão utilizadas na classificação, será criado um corpus sem a abordagem tidy para obter a matriz de documentos e termos, e depois utilizar a coluna de classificação, veja:

suppressMessages(library(tm))       #Pacote de para text mining
corpus <- Corpus(VectorSource(base$text))

#Criando a matrix de termos:
book_dtm = DocumentTermMatrix(corpus, control = list(minWordLength=2,minDocFreq=3)) %>% 
  weightTfIdf(normalize = T) %>%    # Transformação tf-idf com pacote tm
  removeSparseTerms( sparse = .95)  # obtendo matriz esparsa com pacote tm

#Transformando em matrix, permitindo a manipulacao:
matrix = as.matrix(book_dtm)
dim(matrix)
## [1] 7995   18

Pronto, agora já podemos juntar tudo em um data frame e separa em treino e teste para a classificação dos textos obtidos do twitter:

#Criando a base de dados:
full=data.frame(cbind(
  base[,"book"],
  matrix,
  base[,-c(1:3)]
  )) 

Treino e teste

Será utilizado tanto o método de hold-out e de cross-validation

set.seed(825)
particao = sample(1:2,nrow(full), replace = T,prob = c(0.7,0.3))

train = full[particao==1,] 
test = full[particao==2,] 

suppressMessages(library(caret))

Ajustando modelos

KNN

É uma técnica de aprendizado baseado em instância, isto quer dizer que a classificação de uma observação com a classe desconhecida é realizada a partir da comparação com outras observações cada vez que uma observação é apresentado ao modelo e também é conhecido como “lazy evaluation”, já que um modelo não é induzido previamente.

Diversas medidas de distância podem ser utilizadas, utilizarei aqui a euclideana e além disso a escolha do parâmetro \(k\) (de k vizinhos mais próximos) deve ser feita com cuidado pois um \(k\) pequeno pode expor o algorítimo a uma alta sensibilidade a um ruído.

Utilizarei aqui o pacote caret como ferramenta para o ajuste deste modelo pois ela permite que eu configure que seja feita a validação cruzada em conjunto com a padronização, pois esses complementos beneficiam no ajuste de modelos que calculam distâncias.

# knn -------
set.seed(825)
antes = Sys.time()
book_knn <- train(book ~.,
                  data=train,
                 method = "knn",
                 trControl = trainControl(method = "cv",number = 10), # validacao cruzada
                 preProc = c("center", "scale"))                      
time_knn <- Sys.time() - antes 
Sys.time() - antes
## Time difference of 6.492635 secs
plot(book_knn)

previsao  = predict(book_knn, test)
confusionMatrix(previsao, test$book)
## Confusion Matrix and Statistics
## 
##           Reference
## Prediction  arg   br
##        arg 1200   35
##        br    33 1145
##                                           
##                Accuracy : 0.9718          
##                  95% CI : (0.9644, 0.9781)
##     No Information Rate : 0.511           
##     P-Value [Acc > NIR] : <2e-16          
##                                           
##                   Kappa : 0.9436          
##  Mcnemar's Test P-Value : 0.9035          
##                                           
##             Sensitivity : 0.9732          
##             Specificity : 0.9703          
##          Pos Pred Value : 0.9717          
##          Neg Pred Value : 0.9720          
##              Prevalence : 0.5110          
##          Detection Rate : 0.4973          
##    Detection Prevalence : 0.5118          
##       Balanced Accuracy : 0.9718          
##                                           
##        'Positive' Class : arg             
## 
df = cbind(fit = if_else(previsao=="br",1,0), class = if_else(test$book=="br",1,0)) %>% as.data.frame()
plot_pred_type_distribution(df,0.5)

Como podemos ver, segundo a validação cruzada realizada com o pacote caret, o número 5 de vizinhos mais próximos foi o que apresentou o melhor resultado. Além disso o modelo apresentou uma acurácia de 97,18% e isto parece bom dado que a sensibilidade (taxa de verdadeiros positivos) e a especificidade (taxa de verdadeiros negativos) foram altas também, o que foi reforçado com o gráfico ilustrado da matriz de confusão.

O tempo computacional para o ajuste do modelo foi de:6.491642 segundos

Random Forest

O modelo de Random Forest tem se tornado muito popular devido ao seu bom desempenho e pela sua alta capacidade de se adaptar aos dados. O modelo funciona através da combinação de várias árvores de decisões e no seu ajuste alguns parâmetros precisam ser levados em conta.

O parâmetro que sera levado em conta para o ajuste será apenas o ntree, que representa o número de árvores ajustadas. Este parâmetro deve ser escolhido com cuidado pois pode ser tão grande quanto você quiser e continua aumentando a precisão até certo ponto porém pode ser mais limitado pelo tempo computacional disponível.

set.seed(824)
# Random Forest
antes = Sys.time()
book_rf <- train(book ~.,
                  data=train,
                     method = "rf",trace=F,
                     ntree = 200,
                     trControl = trainControl(method = "cv",number = 10))
time_rf <- Sys.time() - antes 
Sys.time() - antes
## Time difference of 50.14381 secs
suppressMessages(library(randomForest))
varImpPlot(book_rf$finalModel)

previsao  = predict(book_rf, test)
confusionMatrix(previsao, test$book)
## Confusion Matrix and Statistics
## 
##           Reference
## Prediction  arg   br
##        arg 1222   15
##        br    11 1165
##                                           
##                Accuracy : 0.9892          
##                  95% CI : (0.9843, 0.9929)
##     No Information Rate : 0.511           
##     P-Value [Acc > NIR] : <2e-16          
##                                           
##                   Kappa : 0.9784          
##  Mcnemar's Test P-Value : 0.5563          
##                                           
##             Sensitivity : 0.9911          
##             Specificity : 0.9873          
##          Pos Pred Value : 0.9879          
##          Neg Pred Value : 0.9906          
##              Prevalence : 0.5110          
##          Detection Rate : 0.5064          
##    Detection Prevalence : 0.5126          
##       Balanced Accuracy : 0.9892          
##                                           
##        'Positive' Class : arg             
## 
# https://www.r-bloggers.com/illustrated-guide-to-roc-and-auc/
df = cbind(fit = if_else(previsao=="br",1,0), class = if_else(test$book=="br",1,0)) %>% as.data.frame()
plot_pred_type_distribution(df,0.5)

Segundo o gráfico de importância, parece que as palavras “brasil”, “argentina”, “copa” e “messi” foram as que apresentaram maior impacto do preditor (lembrando que essa medida não é um efeito específico), o que mostra que a presença das palavras que estamos utilizando para classificar tiveram um impacto na classificação bastante superior aos demais.

Quanto a acurácia, o random forest apresentou valor um pouco maior do que o do algorítimo K-NN e além disso apresentou altos valores para a sensibilidade (taxa de verdadeiros positivos) e a especificidade (taxa de verdadeiros negativos), o que foi reforçado com o gráfico ilustrado da matriz de confusão, porém o tempo computacional utilizado para ajustar este modelo foi muito maior, o que leva a questionar se esse pequeno aumento na taxa de acerto vale a pena aumentando tanto no tempo de processamento (outra alternativa seria diminuir o tamanho do número de árvores para ver se melhoraria na qualidade do ajuste).

O tempo computacional para o ajuste do modelo foi de: 50.142808 segundos

Naive Bayes

Este é um algorítimo que trata-se de um classificador estatístico baseado no Teorema de Bayes e recebe o nome de ingênuo (naive) porque pressupõe que o valor de um atributo que exerce algum efeito sobre a distribuição da variável resposta é independente do efeito que outros atributos.

O cálculo para a classificação é feito por meio do cálculo de probabilidades condicionais, ou seja, probabilidade de uma observação pertencer a cada classe dado os exemplares existentes no conjunto de dados usado para o treinamento.

# Naive Bayes ----
set.seed(825)
antes = Sys.time()
book_nb <- train(book ~.,
                  data=train,
                 method= "nb",
                 laplace =1,       
                 trControl = trainControl(method = "cv",number = 10))
time_nb <- Sys.time() - antes 
Sys.time() - antes
## Time difference of 15.91544 secs
previsao  = predict(book_nb, test)
confusionMatrix(previsao, test$book)
## Confusion Matrix and Statistics
## 
##           Reference
## Prediction  arg   br
##        arg 1232  395
##        br     1  785
##                                           
##                Accuracy : 0.8359          
##                  95% CI : (0.8205, 0.8505)
##     No Information Rate : 0.511           
##     P-Value [Acc > NIR] : < 2.2e-16       
##                                           
##                   Kappa : 0.6692          
##  Mcnemar's Test P-Value : < 2.2e-16       
##                                           
##             Sensitivity : 0.9992          
##             Specificity : 0.6653          
##          Pos Pred Value : 0.7572          
##          Neg Pred Value : 0.9987          
##              Prevalence : 0.5110          
##          Detection Rate : 0.5106          
##    Detection Prevalence : 0.6743          
##       Balanced Accuracy : 0.8322          
##                                           
##        'Positive' Class : arg             
## 
# https://www.r-bloggers.com/illustrated-guide-to-roc-and-auc/
df = cbind(fit = if_else(previsao=="br",1,0), class = if_else(test$book=="br",1,0)) %>% as.data.frame()
plot_pred_type_distribution(df,0.5)

Apesar a aparente acurácia alta, o valor calculado para a especificidade (verdadeiros negativos) foi elevado o que aponta que o ajuste do modelo não se apresentou de forma eficiente

O tempo computacional foi de 15.9144468 segundos

GLM - Logit

Este é um modelo estatístico que já abordei aqui no blog no post sobre AED de forma rápida e um pouco de machine learning e seguindo a recomendação do artigo da datacamp vejamos quais resultados obtemos com o ajuste deste modelo:

# Modelo logístico ----
set.seed(825)
antes = Sys.time()
book_glm <- train(book ~.,
                  data=train,
                  method = "glm",                                         # modelo generalizado
                  family = binomial(link = 'logit'),                      # Familia Binomial ligacao logit
                  trControl = trainControl(method = "cv", number = 10))   # validacao cruzada
time_glm <- Sys.time() - antes 
Sys.time() - antes
## Time difference of 2.935504 secs
suppressMessages(library(ggfortify))

autoplot(book_glm$finalModel, which = 1:6, data = train,
         colour = 'book', label.size = 3,
         ncol = 3) + theme_classic()

previsao  = predict(book_glm, test)
confusionMatrix(previsao, test$book)
## Confusion Matrix and Statistics
## 
##           Reference
## Prediction  arg   br
##        arg 1201   38
##        br    32 1142
##                                           
##                Accuracy : 0.971           
##                  95% CI : (0.9635, 0.9773)
##     No Information Rate : 0.511           
##     P-Value [Acc > NIR] : <2e-16          
##                                           
##                   Kappa : 0.9419          
##  Mcnemar's Test P-Value : 0.5501          
##                                           
##             Sensitivity : 0.9740          
##             Specificity : 0.9678          
##          Pos Pred Value : 0.9693          
##          Neg Pred Value : 0.9727          
##              Prevalence : 0.5110          
##          Detection Rate : 0.4977          
##    Detection Prevalence : 0.5135          
##       Balanced Accuracy : 0.9709          
##                                           
##        'Positive' Class : arg             
## 
df = cbind(fit = if_else(previsao=="br",1,0), class = if_else(test$book=="br",1,0)) %>% as.data.frame()
plot_pred_type_distribution(df,0.5)

Comparando modelos

Agora que temos 4 modelos ajustados e cada um apresentando resultados diferentes, vejamos qual deles seria o mais interessante para caso fosse necessário recuperar a classificação dos termos pesquisados através da API, veja a seguir um resumo das medidas obtidas:

# "Dados esses modelos, podemos fazer declarações estatísticas sobre suas diferenças de desempenho? Para fazer isso, primeiro coletamos os resultados de reamostragem usando resamples." - caret
resamps <- resamples(list(knn = book_knn,
                          rf = book_rf,
                          nb = book_nb,
                          glm = book_glm)) 
summary(resamps)
## 
## Call:
## summary.resamples(object = resamps)
## 
## Models: knn, rf, nb, glm 
## Number of resamples: 10 
## 
## Accuracy 
##          Min.   1st Qu.    Median      Mean   3rd Qu.      Max. NA's
## knn 0.9570662 0.9663978 0.9722463 0.9713387 0.9749104 0.9874552    0
## rf  0.9802867 0.9825509 0.9847670 0.9851322 0.9870072 0.9910394    0
## nb  0.8118280 0.8284050 0.8387097 0.8358971 0.8456369 0.8512545    0
## glm 0.9623656 0.9668459 0.9695341 0.9690064 0.9708918 0.9749553    0
## 
## Kappa 
##          Min.   1st Qu.    Median      Mean   3rd Qu.      Max. NA's
## knn 0.9141090 0.9327833 0.9444845 0.9426705 0.9498189 0.9749123    0
## rf  0.9605674 0.9651031 0.9695291 0.9702611 0.9740095 0.9820747    0
## nb  0.6251296 0.6580331 0.6784979 0.6728768 0.6921197 0.7034234    0
## glm 0.9247138 0.9337036 0.9390775 0.9380110 0.9417835 0.9499033    0

Como podemos ver, o modelo que apresentou a menor acurácia e o menor coeficiente kappa foi o Naive Bayes enquanto que o que apresentou as maiores medidas de qualidade do ajuste foi o modelo ajustado com o algorítimo Random Forest e tanto o modelo ajustado pelo algorítimo knn quanto o modelo linear generalizado com função de ligação “logit” também apresentaram acurácia e coeficiente kappa próximos do apresentado no ajuste do Random Forest.

Portanto, apesar dos ajustes, caso dois modelos não apresentem diferença estatisticamente significante e o tempo computacional gasto para o ajuste de ambos for muito diferente pode ser que ser que tenhamos um modelo candidato para:

c( knn= time_knn,rf = time_rf,nb = time_nb,glm = time_glm)
## Time differences in secs
##       knn        rf        nb       glm 
##  6.491642 50.142808 15.914447  2.934740

O modelo linear generalizado foi o que apresentou o menor tempo computacional e foi o que apresentou o terceiro maior registro para os as medidas de qualidade do ajuste dos modelos, portanto esse modelo será avaliado com mais cuidado em seguida para saber se ele será o modelo selecionado

Obs.: Sou suspeito para falar mas dentre esses modelos eu teria preferência por este modelo de qualquer maneira por não se tratar de uma “caixa preta”, da qual todos os efeitos de cada parâmetro ajustado podem ser interpretado, além de obter medidas como razões de chance que ajudam bastante na compreensão dos dados.

Comparando de forma visual:

splom(resamps)

Assim fica mais claro o como o ajuste dos modelos Random Forest, K-NN e GLM se destacaram quando avaliados em relação a acurácia apresentada.

Vejamos a seguir como foi a distribuição dessas medidas de acordo com cada modelo através de boxplots:

bwplot(resamps)

Note que além de apresentar os ajustes com menor acurácia (e elevada taxa de falsos negativos) o algorítimo Naive Bayes foi o que apresentou a maior variação interquartil das medidas de qualidade do ajuste do modelo.

Para finalizar a análise visual vamos obter as diferenças entre os modelos com a função diff() e em seguida conferir de maneira visual o comportamento dessas informações:

difValues <- diff(resamps)

# plot:
bwplot(difValues)

Observe que tanto o modelo logístico quando o ajuste com o algorítimo K-NN apresentaram valores muito próximos dos valores do ajuste do Random Forest e como já vimos o Random Forest foi o modelo que levou maior tempo computacional para ser ajustado, portanto vamos conferir a seguir se existe diferença estatisticamente significante entre os valores obtidos através de cada um dos ajustes e decidir qual dos modelos se apresentou de maneira mais adequada para nosso caso:

tidy_resamps <- 
  resamps %>% 
  broom::tidy() %>% 
  select(glm,knn,rf)

tidy_resamps %>% 
  purrr::map_dbl(function(x) shapiro.test(x)$p.value)
##       glm       knn        rf 
## 0.6122197 0.9047978 0.3582990

Como a hipótese de normalidade não foi rejeitada para nenhuma das amostras de acurácias registradas, vejamos se existe diferença estatisticamente significante entre as médias dessas medidas de qualidade para cada modelo:

t.test(tidy_resamps$rf,tidy_resamps$knn, paired = T)  
## 
##  Paired t-test
## 
## data:  tidy_resamps$rf and tidy_resamps$knn
## t = 7.4601, df = 9, p-value = 3.851e-05
## alternative hypothesis: true difference in means is not equal to 0
## 95 percent confidence interval:
##  0.00961085 0.01797617
## sample estimates:
## mean of the differences 
##              0.01379351

Rejeita a hipótese de que as médias das acurácias calculadas para o ajuste do algorítimo Random Forest e K-NN foram iguais

t.test(tidy_resamps$rf,tidy_resamps$glm, paired = T)  
## 
##  Paired t-test
## 
## data:  tidy_resamps$rf and tidy_resamps$glm
## t = 9.9056, df = 9, p-value = 3.872e-06
## alternative hypothesis: true difference in means is not equal to 0
## 95 percent confidence interval:
##  0.01244314 0.01980852
## sample estimates:
## mean of the differences 
##              0.01612583

Novamente, rejeita-se a hipótese de que as médias das acurácias calculadas para o ajuste do algorítimo Random Forest e do modelo de logístico foram iguais

t.test(tidy_resamps$knn,tidy_resamps$glm, paired = T)
## 
##  Paired t-test
## 
## data:  tidy_resamps$knn and tidy_resamps$glm
## t = 0.85631, df = 9, p-value = 0.414
## alternative hypothesis: true difference in means is not equal to 0
## 95 percent confidence interval:
##  -0.003829065  0.008493692
## sample estimates:
## mean of the differences 
##             0.002332314

Já para a comparação entre as médias das acurácias calculadas para o algorítimo K-NN e para o modelo logístico não houve evidências estatísticas para se rejeitas a hipótese de que ambas as médias são iguais, o que nos sugere o modelo logístico como o segundo melhor candidato como modelo de classificação para este problema com estes dados.

Então a escolha ficará a critério do que é mais importante. Caso o tempo computacional fosse uma medida que tivesse mais importância do que a pequena superioridade de acurácia apresentada pelo algorítimo Random Forest, escolheria o modelo logístico, porém como neste caso os 47.2080679 segundos a mais para ajustar o modelo não fazem diferença para mim, fico com o modelo Random Forest.

Este post trás alguns dos conceitos que venho estudado e existem muitos tópicos apresentados aqui que podem (e devem) ser estudados com mais profundidade, espero que tenha gostado!

Referências

obs.: links mensionados no corpo do texto

Kuhn, Max. 2018. The Caret Package.

Silge; Robinson, Julia; David. 2018. Text Mining with R. A Tidy Approach.

Silva; Peres; Boscarioli, Leandro Augusto; Sarajane Marques; Clodis. 2016. Introdução à Mineração de Dados. Com Aplicações Em R. Vol. 3. Elsevier Editora Ltda.

comments powered by Disqus