Indo além do PCA, v2

Pacotes que serão utilizados:

#install.packages("pacman")
library(pacman)


p_load(caret, tidyverse, factoextra, epubr, tm, lexiconPT, broom, tidytext, widyr, irlba, 
       Rtsne,plotly)

# require(caret)
# require(tidyverse)
# library(factoextra)
# library(epubr)
# library(tm)
# library(lexiconPT)
# library(broom)
# library(tidytext)
# library(widyr)
# library(irlba)
# library(Rtsne)
# library(plotly)

Utilizando um pouco do PCA da forma mais clássica:

Objetivo

Vamos utilizar o PCA com o intuíto de realizar a redução de dimensionalidade e posteriormente comparar os resultados obtidos para classificação, através do algoritmo de KNN, para os usos de água domésticos.

Realizando o PCA e analisando os resultados

Carregando os dados:

dados <- load("data_041218_1138.RData")

dados <- features_atual %>% 
  group_by(categoria) %>% 
  dplyr::filter(categoria %in% c("Torneira Interna", "Bacia")) %>% 
  dplyr::sample_n(1000)

dados$categoria <- forcats::fct_drop(dados$categoria)


x <- dados[,c(2:9)]

Realizaremos, primeiro, o PCA através do passo-a-passo a seguir:

Escalonando os dados:

x1 <- scale(x)

Cálculo da covariância:

covariancia <- cov(x1)

covariancia

##           duracao      nmoda    volume   inercia       moda      media
## duracao 1.0000000 0.91695943 0.7806709 0.1963526 0.14801370 0.12642921
## nmoda   0.9169594 1.00000000 0.6644585 0.3031549 0.06387387 0.03907877
## volume  0.7806709 0.66445847 1.0000000 0.2844428 0.51111595 0.52629646
## inercia 0.1963526 0.30315487 0.2844428 1.0000000 0.26748496 0.24853437
## moda    0.1480137 0.06387387 0.5111160 0.2674850 1.00000000 0.88023884
## media   0.1264292 0.03907877 0.5262965 0.2485344 0.88023884 1.00000000
## pico    0.2083276 0.07043902 0.5354330 0.1484250 0.75141204 0.89824706
## mediana 0.1286985 0.04465841 0.5292554 0.2809531 0.89753029 0.97055864
##               pico    mediana
## duracao 0.20832760 0.12869851
## nmoda   0.07043902 0.04465841
## volume  0.53543301 0.52925541
## inercia 0.14842498 0.28095307
## moda    0.75141204 0.89753029
## media   0.89824706 0.97055864
## pico    1.00000000 0.85818012
## mediana 0.85818012 1.00000000

Autovetores e valores:

auto <- eigen(covariancia)

auto$vectors # Autovetores

##            [,1]       [,2]        [,3]        [,4]        [,5]        [,6]
## [1,] -0.2310453  0.5632435  0.19229566 -0.02801841 -0.12043491  0.26494624
## [2,] -0.1855689  0.5933754  0.01331170  0.07495371 -0.51858486 -0.25545942
## [3,] -0.3799819  0.3244277  0.14875429  0.02646461  0.81076600 -0.10012595
## [4,] -0.1861937  0.1353942 -0.95204290 -0.15147971  0.06777708  0.09763952
## [5,] -0.4182136 -0.2156115 -0.02290288  0.69486003 -0.10814106  0.51227360
## [6,] -0.4387141 -0.2495565  0.03121013 -0.07604606 -0.12191760 -0.39156017
## [7,] -0.4164563 -0.1980184  0.18075640 -0.68778987 -0.14272351  0.43162598
## [8,] -0.4385424 -0.2431038 -0.01265553  0.09100582 -0.08775848 -0.49289015
##             [,7]         [,8]
## [1,]  0.69849278  0.137909284
## [2,] -0.51222987 -0.105382075
## [3,] -0.24336242 -0.030662979
## [4,]  0.05584913  0.020547723
## [5,] -0.14508361  0.009277505
## [6,]  0.02294322  0.754840886
## [7,] -0.20879571 -0.177083237
## [8,]  0.34958935 -0.606039530

auto$values # Autovalores

## [1] 4.30639229 2.22141303 0.88549979 0.23952540 0.18395396 0.09251282
## [7] 0.04681361 0.02388910

Predizendo os valores no PCA:

pred <- as.matrix(x) %*% as.matrix(auto$vectors)

head(pred)

##           [,1]      [,2]     [,3]      [,4]       [,5]     [,6]      [,7]
## [1,] -48.92063 106.38567 35.28283 -4.794310 -21.847135 45.41168 120.12825
## [2,] -27.60923  40.15480 12.75673 -1.695787  -8.806737 17.41199  45.28915
## [3,] -51.52599 111.95428 37.28973 -4.638067 -22.954011 48.35786 126.97243
## [4,] -27.30683  40.11059 12.68653 -1.680300  -9.089243 17.58629  45.37863
## [5,] -27.11220  38.71631 13.85484 -1.663683  -7.969440 18.04135  46.20005
## [6,] -72.25968 165.03076 50.81712 -6.255202 -37.819282 66.20711 176.83245
##           [,8]
## [1,] 23.823585
## [2,]  8.668638
## [3,] 25.168835
## [4,]  8.422100
## [5,]  8.760234
## [6,] 34.753208

Exploraremos agora, brevemente, alguns opções de projeção do PCA:

Usaremos para isto o pacote factoextra. Primeiramente, vamos construir nosso objeto pca

x_pca <- prcomp(x, scale = TRUE)

summary(x_pca)

## Importance of components:
##                           PC1    PC2    PC3     PC4     PC5     PC6
## Standard deviation     2.0752 1.4904 0.9410 0.48941 0.42890 0.30416
## Proportion of Variance 0.5383 0.2777 0.1107 0.02994 0.02299 0.01156
## Cumulative Proportion  0.5383 0.8160 0.9267 0.95660 0.97960 0.99116
##                            PC7     PC8
## Standard deviation     0.21636 0.15456
## Proportion of Variance 0.00585 0.00299
## Cumulative Proportion  0.99701 1.00000

x_pca$rotation

##                PC1        PC2         PC3         PC4         PC5
## duracao -0.2310453 -0.5632435  0.19229566 -0.02801841 -0.12043491
## nmoda   -0.1855689 -0.5933754  0.01331170  0.07495371 -0.51858486
## volume  -0.3799819 -0.3244277  0.14875429  0.02646461  0.81076600
## inercia -0.1861937 -0.1353942 -0.95204290 -0.15147971  0.06777708
## moda    -0.4182136  0.2156115 -0.02290288  0.69486003 -0.10814106
## media   -0.4387141  0.2495565  0.03121013 -0.07604606 -0.12191760
## pico    -0.4164563  0.1980184  0.18075640 -0.68778987 -0.14272351
## mediana -0.4385424  0.2431038 -0.01265553  0.09100582 -0.08775848
##                 PC6         PC7          PC8
## duracao  0.26494624 -0.69849278 -0.137909284
## nmoda   -0.25545942  0.51222987  0.105382075
## volume  -0.10012595  0.24336242  0.030662979
## inercia  0.09763952 -0.05584913 -0.020547723
## moda     0.51227360  0.14508361 -0.009277505
## media   -0.39156017 -0.02294322 -0.754840886
## pico     0.43162598  0.20879571  0.177083237
## mediana -0.49289015 -0.34958935  0.606039530

É interessante, em momento de exercicio, comparar o obtido através do algoritmo e o resultado da função prcomp.

É possível perceber, também, que com as três componentes principais podemos explicar cerca de 90% da variância dos dados, reduzindo de forma significativa o numéro de dimensões do nosso problema. Vamos, enfim, explorar a projeção das nossas componentes principais.

factoextra::fviz_pca_biplot(x_pca, repel = FALSE)

Com o gráfico acima verificamos a direção de alguma das variáveis e como os dados se comportam após em função dos dois primeiros componentes gerados pela PCA.

Podemos, ver também como acontece a projeção, tendo em vista as classificações dos usos domésticos de água:

factoextra::fviz_pca_ind(x_pca,
             label = "none", # hide individual labels
             habillage = dados$categoria, # color by groups
             addEllipses = TRUE # Concentration ellipses
             )

PCA para dados textuais:

Objetivo:

Um dos claros objetivos desta apresentação é ir além do PCA, porém, pede-se um pouco de paciência para que vejamos de forma breve (sem entrar nas questões de NLP) como esta técnica pode ser utilizada em análise textual.

Utilizaremos os seguintes pacotes para determinar a similaridade entre as palavras utilizados por Albert Camus no seu clássico: “O Estrangeiro”.

knitr::include_graphics("7248407GG.jpg")

“Hoje, a mãe morreu. Ou talvez ontem, não sei bem. Recebi um telegrama do asilo: “Sua mãe falecida: Enterro amanhã. Sentidos pêsames”. Isto não quer dizer nada. Talvez tenha sido ontem.”

Carregando o livro

x0 <- epubr::epub("O Estrangeiro - Albert Camus.epub")

estrangeiro <- x0$data[[1]]

Alguns ajustes

Neste momento, vamos separar as palavras utilizadas e remover as “stopwords” em português:

Analisando os “unigrams”:

stop_words <- stopwords(kind = "pt") %>% 
  as.tibble()

unigram_probs <- estrangeiro %>%
  tidytext::unnest_tokens(word, text) %>%
  count(word, sort = TRUE) %>%
  mutate(p = n / sum(n)) 

head(unigram_probs)

## # A tibble: 6 x 3
##   word      n      p
##   <chr> <int>  <dbl>
## 1 que    1227 0.0408
## 2 a      1112 0.0370
## 3 o      1053 0.0350
## 4 e       990 0.0329
## 5 de      905 0.0301
## 6 me      664 0.0221

Vamos escolher uma janela móvel de 15 palavras, pode-se aplicar maiores ou menores, é interessante testar algumas afim de entender qual é o valor que propociona os melhores resultados.

colnames(stop_words) <- c("word")

tidy_skipgrams <- estrangeiro %>%
  tidytext::unnest_tokens(ngram, text, token = "ngrams", n = 40) %>%
  mutate(ngramID = row_number()) %>% 
  unite(skipgramID, ngramID) %>%
  unnest_tokens(word, ngram) %>% 
  anti_join(stop_words, by = "word")

head(tidy_skipgrams)

## # A tibble: 6 x 5
##   section           nword nchar skipgramID word    
##   <chr>             <int> <int> <chr>      <chr>   
## 1 content0002.xhtml     2    14 1          <NA>    
## 2 content0003.xhtml  4167 24617 2          capítulo
## 3 content0003.xhtml  4167 24617 2          i       
## 4 content0003.xhtml  4167 24617 2          hoje    
## 5 content0003.xhtml  4167 24617 2          mãe     
## 6 content0003.xhtml  4167 24617 2          morreu

Calculando as probabilidades:

skipgram_probs <- tidy_skipgrams %>%
  widyr::pairwise_count(word, skipgramID, diag = TRUE, sort = TRUE) %>%
  dplyr::mutate(p = n / sum(n))

Normalizando a probabilidade

Vamos utilizar um indicador para visualizar quais palavras ocorreram juntas com mais frequência do que o esperado, tendo em base a frequência com que elas ocorreram sozinhas.

O quanto maior o resultado, mais estas palavras estão associadas e possuem boa probabilidade de ocorrem juntas, em relação a probabilidade de serem encontradas individualmente.

normalized_prob <- skipgram_probs %>%
  dplyr::filter(n > 20) %>%
  dplyr::rename(word1 = item1, word2 = item2) %>%
  dplyr::left_join(unigram_probs %>%
              select(word1 = word, p1 = p),
            by = "word1") %>%
  dplyr::left_join(unigram_probs %>%
              select(word2 = word, p2 = p),
            by = "word2") %>%
  dplyr::mutate(p_together = p / p1 / p2)


head(normalized_prob)

## # A tibble: 6 x 7
##   word1 word2     n        p      p1      p2 p_together
##   <chr> <chr> <dbl>    <dbl>   <dbl>   <dbl>      <dbl>
## 1 disse disse  6897 0.000577 0.00642 0.00642       14.0
## 2 mim   mim    3830 0.000321 0.00343 0.00343       27.3
## 3 é     é      3377 0.000283 0.00349 0.00349       23.2
## 4 pouco pouco  3343 0.000280 0.00323 0.00323       26.9
## 5 então então  3097 0.000259 0.00279 0.00279       33.2
## 6 tempo tempo  2970 0.000249 0.00266 0.00266       35.1

Vamos observar quais palavras estão associadas a “praia”:

normalized_prob %>% 
  dplyr::filter(word1 == "mae") %>%
  dplyr::arrange(-p_together)

## # A tibble: 0 x 7
## # ... with 7 variables: word1 <chr>, word2 <chr>, n <dbl>, p <dbl>,
## #   p1 <dbl>, p2 <dbl>, p_together <dbl>

Vamos observar quais palavras estão associadas a “raimundo”:

normalized_prob %>% 
  dplyr::filter(word1 == "raimundo") %>%
  dplyr::arrange(-p_together)

## # A tibble: 862 x 7
##    word1    word2           n          p      p1        p2 p_together
##    <chr>    <chr>       <dbl>      <dbl>   <dbl>     <dbl>      <dbl>
##  1 raimundo esbofeteara    80 0.00000670 0.00306 0.0000665       32.9
##  2 raimundo elétricos      40 0.00000335 0.00306 0.0000333       32.9
##  3 raimundo levando        40 0.00000335 0.00306 0.0000333       32.9
##  4 raimundo longínquos     40 0.00000335 0.00306 0.0000333       32.9
##  5 raimundo estridente     40 0.00000335 0.00306 0.0000333       32.9
##  6 raimundo chorou         40 0.00000335 0.00306 0.0000333       32.9
##  7 raimundo melífluo       40 0.00000335 0.00306 0.0000333       32.9
##  8 raimundo precipitou     40 0.00000335 0.00306 0.0000333       32.9
##  9 raimundo batido         40 0.00000335 0.00306 0.0000333       32.9
## 10 raimundo tira           40 0.00000335 0.00306 0.0000333       32.9
## # ... with 852 more rows

Vamos transformar estes dados em uma matriz esparsa:

pmi_matrix <- normalized_prob %>%
    dplyr::mutate(pmi = log10(p_together)) %>%
    tidytext::cast_sparse(word1, word2, pmi)

A transformação de dados textuais em matriz, possuem muitos zeros, esta estrutura utilizada economiza tempo e memória.

Aplicando o PCA:

Neste caso, usaremos a abordagem do PCA afim de reduzir a dimensionalidade dos dados e buscar uma forma mais interessante de representar a similaridade entre as palavras :

pmi_pca <- irlba::prcomp_irlba(pmi_matrix, n = 256)

word_vectors <- pmi_pca$x

rownames(word_vectors) <- rownames(pmi_matrix)

dim(word_vectors)

## [1] 4373  256

Encontrando similaridades:

Vamos utilizar uma função publicada pela Julia Silge para para varrer o vetor de word_vectors atrás das palavras de maiores similaridades:

search_synonyms <- function(word_vectors, selected_vector) {
  
  similarities <- word_vectors %*% selected_vector %>%
    tidy() %>%
    as_tibble() %>%
    rename(token = .rownames,
           similarity = unrowname.x.)
  
  similarities %>%
    arrange(-similarity)    
}

Testando a função:

praia <- search_synonyms(word_vectors, word_vectors["sol",])

praia

## # A tibble: 4,373 x 2
##    token similarity
##    <chr>      <dbl>
##  1 sol         688.
##  2 mim         201.
##  3 praia       190.
##  4 cara        182.
##  5 tudo        179.
##  6 água        176.
##  7 maria       175.
##  8 céu         173.
##  9 pouco       169.
## 10 tempo       165.
## # ... with 4,363 more rows

Adicionando sentimentos:

lex <- lexiconPT::oplexicon_v3.0

colnames(lex)[1] <- "word"

unnested_words <- praia %>%
  inner_join(lex, by = c("token" = "word"))

Analisando os sentimentos referentes a palavra praia:

unnested_words %>% 
  top_n(40, abs(similarity)) %>% 
  ggplot(aes(x = reorder(token, similarity), y = similarity, fill = as.factor(polarity))) +
  geom_col() +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 90, hjust = 1, vjust = 0.5),
        axis.ticks.x = element_blank())

Podemos também realizar de outra forma o PCA:

Recuperemos nosso livro e ajustemos ele para análise:

stop_words <- stopwords(kind = "pt") %>% 
  as.tibble()

colnames(stop_words) <- c("word")

words <- map_df(1,
                ~ unnest_tokens(estrangeiro, word, text, 
                                token = "ngrams", n = .x)) %>%
  anti_join(stop_words, by = "word")

unnested_words <- words %>%
  count(word, sort = TRUE) %>% 
  filter(n > 5)

Filtremos apenas com as palavras encontradas no lexcon:

Criando matriz de tag e transformando em matriz esparsa

sparse_tag_matrix <- unnested_words %>%
  tidytext::cast_sparse(word,word,n)

#PCA -> PCA para matriz esparsa

word_scaled <- scale(sparse_tag_matrix)

set.seed(42)

tags_pca <- irlba::prcomp_irlba(word_scaled, n = 64)

Visualizando

tidied_pca <- bind_cols(Tag = colnames(sparse_tag_matrix),
                        tidy(tags_pca$rotation))

text_pca <- reshape2::melt(tidied_pca)

Melhorando a visualizacao

text_pca %>%
  filter(variable == "PC1") %>%
  top_n(40, abs(value)) %>%  
  mutate(Tag = reorder(Tag, value)) %>%
  ggplot(aes(Tag, value, fill = Tag)) +
  geom_col(show.legend = FALSE, alpha = 0.8) +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 90, hjust = 1, vjust = 0.5),
        axis.ticks.x = element_blank()) +
  labs(x = "Words",
       y = "Relative importance in principle component",
       title = "PC1")

Olhando outros PCS

text_pca %>%
  filter(variable == "PC2") %>%
  top_n(40, abs(value)) %>%  
  mutate(Tag = reorder(Tag, value)) %>%
  ggplot(aes(Tag, value, fill = Tag)) +
  geom_col(show.legend = FALSE, alpha = 0.8) +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 90, hjust = 1, vjust = 0.5),
        axis.ticks.x = element_blank()) +
  labs(x = "Words",
       y = "Relative importance in principle component",
       title = "PC2")

Olhando outros PCS

text_pca %>%
  filter(variable == "PC3") %>%
  top_n(40, abs(value)) %>%
  mutate(Tag = reorder(Tag, value)) %>%
  ggplot(aes(Tag, value, fill = Tag)) +
  geom_col(show.legend = FALSE, alpha = 0.8) +
  theme_minimal() +
  theme(axis.text.x = element_text(angle = 90, hjust = 1, vjust = 0.5),
        axis.ticks.x = element_blank()) +
  labs(x = "Words",
       y = "Relative importance in principle component",
       title = "PC3")

Está difícil né? O livro não é muito linear e as situações muitas vezes se repetem e o autor tem sentimentos, por vezes, contraditórios. Vamos continuar nossa expedição por métodos de redução de dimensionalidade utilizando, agora, o t-SNE.

t-SNE

rm(list=ls())

Adicionaremos, também, o livro Crime e Castigo (Fiódor Dostoiévsk). Existe uma comparação entre os dois livros, principalmente no que tange aos seus personagens principais: Raskolnikov e Mersault.

knitr::include_graphics("super_imgcrime_e_castigo_dostoievski_0.jpg")

Só é dado o poder a quem ousa abaixar-se para apanha-lo.

Remontando os datasets com os livros em questão:

# Stopwords

stop_words <- stopwords(kind = "pt") %>% 
  as.tibble()

stop_words <- rbind(stop_words, c("é"))


colnames(stop_words)[1] <- "word"

# Carregando 

x0 <- epubr::epub("O Estrangeiro - Albert Camus.epub")

x1 <- epubr::epub("Crime e Castigo - Fiódor Dostoiévski.epub")

Começaremos, dividindo o texto em paragráfos, neste momento, queremos saber se há similaridade entre os paragráfos escritos por ambos autores em livros que possuem uma certa similaridade.

O Estrangeiro

estrangeiro <- x0$data[[1]]

estrangeiro_ <- estrangeiro %>%
  tidytext::unnest_tokens(paragraphs, text, token = "paragraphs") %>% 
  mutate(paragrafo = row_number()) %>% 
  tidytext::unnest_tokens(word, paragraphs) %>% 
  anti_join(stop_words, by = "word")  %>% 
  count(paragrafo, word, sort = TRUE) %>% 
  mutate(book = "estrangeiro")

id <- max(estrangeiro_$paragrafo)

# Criando um filtro

estrangeiro_filtro <- estrangeiro_ %>%  
  group_by(word) %>% 
  summarise(soma = sum(n)) %>% 
  arrange(desc(soma)) %>% 
  filter(soma > 5) %>% 
  select(word)

estrangeiro <- estrangeiro_ %>% 
  filter(word %in% estrangeiro_filtro$word)

Crime e Castigo

crime <- x1$data[[1]]

crime_ <- crime %>%  
  tidytext::unnest_tokens(paragraphs, text, token = "paragraphs") %>% 
  mutate(paragrafo = row_number() + id) %>% 
  tidytext::unnest_tokens(word, paragraphs) %>% 
  anti_join(stop_words, by = "word")  %>% 
  count(paragrafo, word, sort = TRUE) %>% 
  mutate(book = "crime") 

# Criando um filtro

crime_filtro <- crime_ %>%  
  group_by(word) %>% 
  summarise(soma = sum(n)) %>% 
  arrange(desc(soma)) %>% 
  filter(soma > 50) %>% 
  select(word)

crime2 <- crime_ %>% 
  filter(word %in% crime_filtro$word)

A princípio, criaremos um banco de dados que é a acumulação dos dois textos no sentido das linhas. Neste será aplicado o TSNE e veremos se é possível visualizar a diferença entre o conteúdo dos parágrafos dos dois textos (É possível fazer com as palavras também, basta restringir um pouco mais o filtro ou ter mais capacidade de processamento).

### Similares

similar <- rbind(estrangeiro_, crime_) 

range(similar$paragrafo)

## [1]    1 4356

Ao se tratar de textos temos alguma medidas clássicas que podem auxiliar nesta separação de conteúdo, podem usar a simples contagem de palavras por parágrafo ou o tf-idf que representa o quanto uma palavra é mais exclusiva de um ou outro livro, neste caso.

Utilizaremos o tf-idf, para isto, é aconselhável que retiremos os nomes de pessoas, uma vez que estas palavras são muito exclusivas dos livros a que dizem respeito. Também, removo mais algumas stop_words que se mostraram relevante ao aplicar o tf-idf.

nomes <- c("raskólnikov", "sônia", "razumíkhin", "ivánova", "pietróvitch", "n", 
           "catierina", "dúnia", "svidrigáilov", "porfiri", "piotr", "pulkhéria", 
           "t", "avdótia", "ródia", "románovna", "rodíon", "lújin", "atieksándrovna",
           "dúnietchka", "zóssimov", "zamiótov", "marfa", "sófia", "semeónovna", "nastácia",
           "pietróvna", "raskólnikovnn", "amália", "liebeziátnikov", "raimundo", "masson", "u", 
           "perez", "manuel", "meursault", "ivánovna", "alieksándrovna", "lisavieta", "ei", "capítulo",
           "19", "si", "alguma", "agora", "jeito", "instalamo", "ora", "algum", "há", "ainda", "descemos", 
           "respondi","instante", "bocadinho", "soubera", "ah", "vou")


aux <- similar %>%
  filter(!word %in% nomes)

Criamos, enfim, um objeto um pouco mais coerente para a realização da nossa análise.

Criando nossa matriz esparsa

Antes de criarmos, vamos aplicar mais um filtro. Utilizaremos o lexicon-PT para filtrar apenas as palavras que tem cadastradas algum valor de sentimento ou polaridade. Desta forma, podemos ver se o agrupamento formado entre os livros diz respeito também ao sentimento expresso nos paragráfos pela palavra de maior tf-idf.

sentimentos <- oplexicon_v3.0

colnames(sentimentos)[1] <- "word"

Enfim…

aux1 <- aux %>% 
  ungroup() %>% 
  inner_join(sentimentos) %>% 
  bind_tf_idf(word, book, n) %>% 
  group_by(book) %>% 
  top_n(100,tf_idf) %>% 
  distinct(word,paragrafo, tf_idf, .keep_all = TRUE) 
  

sparse_words <- aux1 %>%
  cast_sparse(paragrafo, word, tf_idf)

sparse_words1 <- aux1 %>%
  cast_sparse(paragrafo, word, tf_idf) %>%
  as.matrix() %>% 
  as.tibble() %>% 
  distinct()

RTSNE:

O pacote para criação do t-SNE no R é o RTSNE. Neste, devemos escolher o número de dimensões desejadas e a perplexidade final. É interessante que se teste alguns valores, aqui será apresentado aquele que julguei mais pertinente por separar bem as palavras.

tsne <- Rtsne(sparse_words1, dims = 2, perplexity= 10 , verbose=TRUE, max_iter = 500)

## Performing PCA
## Read the 931 x 50 data matrix successfully!
## OpenMP is working. 1 threads.
## Using no_dims = 2, perplexity = 10.000000, and theta = 0.500000
## Computing input similarities...
## Building tree...
## Done in 0.26 seconds (sparsity = 0.047653)!
## Learning embedding...
## Iteration 50: error is 74.996748 (50 iterations in 0.19 seconds)
## Iteration 100: error is 63.659614 (50 iterations in 0.11 seconds)
## Iteration 150: error is 61.847161 (50 iterations in 0.11 seconds)
## Iteration 200: error is 61.123288 (50 iterations in 0.10 seconds)
## Iteration 250: error is 60.704210 (50 iterations in 0.11 seconds)
## Iteration 300: error is 1.309755 (50 iterations in 0.13 seconds)
## Iteration 350: error is 1.044950 (50 iterations in 0.10 seconds)
## Iteration 400: error is 0.973582 (50 iterations in 0.10 seconds)
## Iteration 450: error is 0.942681 (50 iterations in 0.11 seconds)
## Iteration 500: error is 0.926490 (50 iterations in 0.10 seconds)
## Fitting performed in 1.15 seconds.

Criemos um objeto que absorva estas novas coordenadas e as associe ao banco auxiliar: aux1. Queremos com isto verificar de forma gráfica, usando o plotly, o resultado final.

word_vectors <- tsne$Y %>% 
  as.tibble() %>% 
  mutate(paragrafo = as.numeric(rownames(sparse_words))) %>% 
  left_join(aux1) %>% 
  mutate(book = as.factor(book)) %>% 
  mutate(polarity = as.factor(polarity)) %>% 
  mutate(book_s = fct_cross(book, polarity))

Criando nosso gráfico:

pal <- c("darkred", "red","firebrick1","darkblue", "blue", "lightblue")

plot_ly(word_vectors, type = 'scatter', mode = 'markers',
        text = ~word, color = ~book_s, colors = pal) %>% 
  add_trace(
    x = word_vectors$V1,
    y = word_vectors$V2,
    opacity = 0.9)

Interessante como fica bem divido, apesar de haver uma área, que será explorada, de intersecção entre os dois livros. Esta área está associada, possivelmente, aos, respectivos, capítulos que abordam os assassinatos, já que na lietratura muito se discute sobre as suas semelhanças e diferenças.

Comparando o incomparável:

Vamos atualizar nossas stopword com o verbo “é” :

stop_words <- rbind(stop_words, c("é"))

Atualizaremos, também, os bancos de dados referentes aos dois livros:

estrangeiro <- x0$data[[1]]

estrangeiro_ <- estrangeiro %>%
  filter(section == "content0008.xhtml") %>% 
  tidytext::unnest_tokens(paragraphs, text, token = "paragraphs") %>% 
  mutate(paragrafo = row_number()) %>% 
  tidytext::unnest_tokens(word, paragraphs) %>% 
  anti_join(stop_words, by = "word")  %>% 
  count(paragrafo, word, sort = TRUE) %>% 
  mutate(book = "estrangeiro")

id <- max(estrangeiro_$paragrafo)


crime <- x1$data[[1]]

crime_ <- crime %>%    
  filter(section == "Section0008.xhtml") %>% 
  tidytext::unnest_tokens(paragraphs, text, token = "paragraphs") %>% 
  mutate(paragrafo = row_number() + id) %>% 
  tidytext::unnest_tokens(word, paragraphs) %>% 
  anti_join(stop_words, by = "word")  %>% 
  count(paragrafo, word, sort = TRUE) %>% 
  mutate(book = "crime")

Coincidentemente, os assassinatos ocorrem na mesma sessão, no capítulo 7. Será uma questão numerológica? Ou apenas a aleatoridade se manisfestando?

cap7 <- rbind(estrangeiro_, crime_) 

range(cap7$paragrafo)

## [1]   1 147

Criemos, novamente, nosso objeto auxilar e nossa matriz esparsa:

aux <- cap7 %>%
  filter(!word %in% nomes) %>% 
  bind_tf_idf(word, book, n) %>% 
  group_by(book) %>% 
  distinct(word,paragrafo, n, .keep_all = TRUE) 

table(aux$book)

## 
##       crime estrangeiro 
##        2176        1584

sparse_words1 <- aux %>%
  cast_sparse(word, paragrafo, n) %>%
  as.matrix() %>% 
  data.frame() %>% 
  unique()

Será possível através da redução da dimensão dos dados observar algum agrupamento?

tsne <- Rtsne(sparse_words1, dims = 2, perplexity= 200 , verbose=TRUE, max_iter = 500)

## Performing PCA
## Read the 755 x 50 data matrix successfully!
## OpenMP is working. 1 threads.
## Using no_dims = 2, perplexity = 200.000000, and theta = 0.500000
## Computing input similarities...
## Building tree...
## Done in 1.10 seconds (sparsity = 0.952537)!
## Learning embedding...
## Iteration 50: error is 41.172216 (50 iterations in 0.21 seconds)
## Iteration 100: error is 41.172216 (50 iterations in 0.22 seconds)
## Iteration 150: error is 41.172258 (50 iterations in 0.42 seconds)
## Iteration 200: error is 41.172279 (50 iterations in 0.33 seconds)
## Iteration 250: error is 41.172258 (50 iterations in 0.51 seconds)
## Iteration 300: error is 0.932424 (50 iterations in 0.31 seconds)
## Iteration 350: error is 0.551552 (50 iterations in 0.19 seconds)
## Iteration 400: error is 0.543667 (50 iterations in 0.17 seconds)
## Iteration 450: error is 0.540331 (50 iterations in 0.19 seconds)
## Iteration 500: error is 0.538069 (50 iterations in 0.19 seconds)
## Fitting performed in 2.76 seconds.

word_vectors <- tsne$Y %>% 
  as.tibble() %>% 
  mutate(word = rownames(sparse_words1)) %>% 
  left_join(aux) %>% 
  mutate(book = as.factor(book))
  
word2 <- word_vectors %>% 
  filter(word %in% c("laço", "machado", "cômodo", "crânio", "gritou", "praia", "sol", "silêncio", "árabes", "navalha"))

Visualizando os resultados:

pal <- c("red", "blue")

plot_ly(word_vectors, type = 'scatter', mode = 'markers', 
        color = ~book, colors = pal) %>% 
  add_trace(
    x = word_vectors$V1,
    y = word_vectors$V2,
    text = ~word) %>% 
  add_annotations(x = word2$V1,
                  y = word2$V2,
                  text = word2$word,
                  xref = "x",
                  yref = "y",
                  showarrow = TRUE,
                  arrowhead = 7,
                  ax = 20,
                  ay = -40
                  )

Indo além do PCA, v2

Tarssio Barreto

21 de abril de 2019

Pacotes que serão utilizados:

Utilizando um pouco do PCA da forma mais clássica:

Objetivo

Realizando o PCA e analisando os resultados

Carregando os dados:

Realizaremos, primeiro, o PCA através do passo-a-passo a seguir:

Exploraremos agora, brevemente, alguns opções de projeção do PCA:

PCA para dados textuais:

Objetivo:

Carregando o livro

Alguns ajustes

Calculando as probabilidades:

Normalizando a probabilidade

Vamos observar quais palavras estão associadas a “praia”:

Vamos observar quais palavras estão associadas a “raimundo”:

Vamos transformar estes dados em uma matriz esparsa:

Aplicando o PCA:

Encontrando similaridades:

Analisando os sentimentos referentes a palavra praia:

Podemos também realizar de outra forma o PCA:

Filtremos apenas com as palavras encontradas no lexcon:

Criando matriz de tag e transformando em matriz esparsa

Visualizando

Melhorando a visualizacao

Olhando outros PCS

Olhando outros PCS

t-SNE

Remontando os datasets com os livros em questão:

O Estrangeiro

Crime e Castigo

Criando nossa matriz esparsa

RTSNE:

Criando nosso gráfico:

Comparando o incomparável:

Será possível através da redução da dimensão dos dados observar algum agrupamento?

Visualizando os resultados: