knitr::opts_chunk$set(echo = TRUE)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:
require(caret)
require(tidyverse)
dados <- load("data_041218_1138.RData")
dados <- features_atual %>%
filter(categoria %in% c("Torneira Interna", "Torneira Externa")) %>%
filter(casa == "A") %>%
sample_n(1000)
dados$categoria <- fct_drop(dados$categoria)
x <- dados[,c(2:9)]Realizaremos, primeiro, o PCA através do passo-a-passo a seguir:
- Escalonando os dados:
x <- scale(x)- Cálculo da covariância:
covariancia <- cov(x)- Autovetores e valores:
auto <- eigen(covariancia)
auto$vectors # Autovetores## [,1] [,2] [,3] [,4] [,5]
## [1,] -0.2874158 0.5177313 0.289541796 0.28822099 -0.11157488
## [2,] -0.1836519 0.6237807 0.160700025 -0.59299595 0.30674104
## [3,] -0.4151302 0.1640234 0.118296188 0.37892024 -0.41937080
## [4,] -0.1819549 0.3046597 -0.907534267 0.15285423 0.02909467
## [5,] -0.3918615 -0.2380082 -0.084915386 -0.55746341 -0.63810544
## [6,] -0.4214431 -0.2646106 0.006626759 -0.07049019 0.35265005
## [7,] -0.4141117 -0.1958094 0.186385659 0.28014688 0.21927746
## [8,] -0.4190052 -0.2410866 -0.103607267 -0.06420994 0.37029637
## [,6] [,7] [,8]
## [1,] 0.31111741 0.60367440 -0.093674419
## [2,] -0.08184488 -0.30666828 0.069762801
## [3,] -0.58710956 -0.35013532 0.004942601
## [4,] 0.14482094 -0.06098780 -0.039407223
## [5,] 0.23701390 0.08834334 0.025727120
## [6,] -0.11435745 0.06005052 -0.778658120
## [7,] 0.58571918 -0.47593444 0.243485516
## [8,] -0.34426220 0.42106214 0.564380499auto$values # Autovalores## [1] 4.754869942 1.794947478 0.809040933 0.280322316 0.165782718 0.129812026
## [7] 0.055586277 0.009638309- Predizendo os valores no PCA:
pred <- as.matrix(x) %*% as.matrix(auto$vectors)
head(pred)## [,1] [,2] [,3] [,4] [,5]
## 1442 0.90160802 0.56445830 -1.03244203 0.43822913 -0.44928247
## 2263 2.36393222 0.05878983 -0.24405902 0.08573885 -0.21686342
## 4631 0.28354187 -0.62282949 -0.03892431 -0.15689228 -0.33821503
## 141 0.09813593 -0.24644071 0.18476249 0.45072958 0.02042007
## 3853 1.18560000 -0.56825413 -0.24942334 -0.17194166 -0.01693470
## 1969 0.97643148 0.56956641 1.08122014 0.28491345 0.26805281
## [,6] [,7] [,8]
## 1442 0.39561157 0.24152164 -0.06399957
## 2263 -0.22567180 -0.14991912 0.02318916
## 4631 0.24621661 0.04275761 0.04041907
## 141 -0.02593098 0.26756345 -0.07145361
## 3853 -0.15866571 -0.05155676 -0.01815174
## 1969 0.41234910 -0.55691159 -0.14811048Exploraremos agora, brevemente, alguns opções de projeção do PCA:
Usaremos para isto o pacote factoextra:
library(factoextra)Criando nosso objeto PCA:
x_pca <- prcomp(x)
summary(x_pca)## Importance of components:
## PC1 PC2 PC3 PC4 PC5 PC6
## Standard deviation 2.1806 1.3398 0.8995 0.52945 0.40716 0.36029
## Proportion of Variance 0.5944 0.2244 0.1011 0.03504 0.02072 0.01623
## Cumulative Proportion 0.5944 0.8187 0.9199 0.95490 0.97562 0.99185
## PC7 PC8
## Standard deviation 0.23577 0.09817
## Proportion of Variance 0.00695 0.00120
## Cumulative Proportion 0.99880 1.00000x_pca$rotation## PC1 PC2 PC3 PC4 PC5
## duracao -0.2874158 -0.5177313 0.289541796 0.28822099 -0.11157488
## nmoda -0.1836519 -0.6237807 0.160700025 -0.59299595 0.30674104
## volume -0.4151302 -0.1640234 0.118296188 0.37892024 -0.41937080
## inercia -0.1819549 -0.3046597 -0.907534267 0.15285423 0.02909467
## moda -0.3918615 0.2380082 -0.084915386 -0.55746341 -0.63810544
## media -0.4214431 0.2646106 0.006626759 -0.07049019 0.35265005
## pico -0.4141117 0.1958094 0.186385659 0.28014688 0.21927746
## mediana -0.4190052 0.2410866 -0.103607267 -0.06420994 0.37029637
## PC6 PC7 PC8
## duracao 0.31111741 -0.60367440 0.093674419
## nmoda -0.08184488 0.30666828 -0.069762801
## volume -0.58710956 0.35013532 -0.004942601
## inercia 0.14482094 0.06098780 0.039407223
## moda 0.23701390 -0.08834334 -0.025727120
## media -0.11435745 -0.06005052 0.778658120
## pico 0.58571918 0.47593444 -0.243485516
## mediana -0.34426220 -0.42106214 -0.564380499É 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 duas componentes principais podemos explicar cerca de 85% 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.
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:
fviz_pca_ind(x_pca,
label = "none", # hide individual labels
habillage = dados$categoria, # color by groups
addEllipses = TRUE # Concentration ellipses
)
Os resultados não apontam um agrupamento conclusivo, testemos, de forma expedita, o ganho de acurácia utilizando o PCA no processamento dos dados:
Definindo grupo de teste e treino:
# Definindo Split
split=0.80
trainIndex <- createDataPartition(dados$categoria, p=split, list=FALSE)
# Separando
data_train <- dados[ trainIndex,c(1:8)]
data_test <- dados[-trainIndex,c(1:8)]Modelo 1 : Sem pca
model <- train(categoria ~ ., data = data_train,
method = "knn", preProcess = c("center", "scale"),
tuneLength = 10,
trControl = trainControl(method="cv", number=10))
pred <- predict(model, data_test)
confusionMatrix(pred, data_test$categoria) ## Confusion Matrix and Statistics
##
## Reference
## Prediction Torneira Interna Torneira Externa
## Torneira Interna 98 21
## Torneira Externa 11 69
##
## Accuracy : 0.8392
## 95% CI : (0.7806, 0.8873)
## No Information Rate : 0.5477
## P-Value [Acc > NIR] : <2e-16
##
## Kappa : 0.6723
##
## Mcnemar's Test P-Value : 0.1116
##
## Sensitivity : 0.8991
## Specificity : 0.7667
## Pos Pred Value : 0.8235
## Neg Pred Value : 0.8625
## Prevalence : 0.5477
## Detection Rate : 0.4925
## Detection Prevalence : 0.5980
## Balanced Accuracy : 0.8329
##
## 'Positive' Class : Torneira Interna
## acc_sem <- 0.763Modelo 2 : Com pca
model2 <- train(categoria ~ ., data = data_train,
method = "knn", preProcess = c("center", "scale", "pca"),
tuneLength = 10,
trControl = trainControl(method="cv", number=10))
pred <- predict(model2, data_test)
confusionMatrix(pred, data_test$categoria) ## Confusion Matrix and Statistics
##
## Reference
## Prediction Torneira Interna Torneira Externa
## Torneira Interna 87 19
## Torneira Externa 22 71
##
## Accuracy : 0.794
## 95% CI : (0.7311, 0.8479)
## No Information Rate : 0.5477
## P-Value [Acc > NIR] : 3.381e-13
##
## Kappa : 0.5854
##
## Mcnemar's Test P-Value : 0.7548
##
## Sensitivity : 0.7982
## Specificity : 0.7889
## Pos Pred Value : 0.8208
## Neg Pred Value : 0.7634
## Prevalence : 0.5477
## Detection Rate : 0.4372
## Detection Prevalence : 0.5327
## Balanced Accuracy : 0.7935
##
## 'Positive' Class : Torneira Interna
## acc_sem <- 0.768Existe um pequeno ganho no PCA, o que pode ser visto é que é preciso uma técnica mais robusta de redução de dimensionalidade para que encontremos uma melhor separação dos dados e consequentemente um resultado melhor. Mais a frente será debatido o t-SNE e seus resultados para este banco de dados.
PCA para textos
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
library(epubr)
library(tm)
library(lexiconPT)
library(broom)
library(tidytext)
x <- epub("O Estrangeiro - Albert Camus.epub")
estrangeiro <- x$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 %>%
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.0221Vamos 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.
library(widyr)
colnames(stop_words) <- c("word")
tidy_skipgrams <- estrangeiro %>%
unnest_tokens(ngram, text, token = "ngrams", n = 15) %>%
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 morreuCalculando as probabilidades:
skipgram_probs <- tidy_skipgrams %>%
pairwise_count(word, skipgramID, diag = TRUE, sort = TRUE) %>%
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 %>%
filter(n > 20) %>%
rename(word1 = item1, word2 = item2) %>%
left_join(unigram_probs %>%
select(word1 = word, p1 = p),
by = "word1") %>%
left_join(unigram_probs %>%
select(word2 = word, p2 = p),
by = "word2") %>%
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 2844 0.00157 0.00642 0.00642 38.2
## 2 mim mim 1514 0.000838 0.00343 0.00343 71.4
## 3 é é 1448 0.000801 0.00349 0.00349 65.7
## 4 pouco pouco 1307 0.000723 0.00323 0.00323 69.5
## 5 raimundo raimundo 1303 0.000721 0.00306 0.00306 77.0
## 6 então então 1227 0.000679 0.00279 0.00279 87.0Vamos observar quais palavras estão associadas a “praia”:
normalized_prob %>%
filter(word1 == "praia") %>%
arrange(-p_together)## # A tibble: 23 x 7
## word1 word2 n p p1 p2 p_together
## <chr> <chr> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 praia praia 443 0.000245 0.00103 0.00103 231.
## 2 praia saco 39 0.0000216 0.00103 0.0000998 210.
## 3 praia brilho 22 0.0000122 0.00103 0.000233 50.7
## 4 praia autocarro 33 0.0000183 0.00103 0.000366 48.4
## 5 praia banho 22 0.0000122 0.00103 0.000266 44.4
## 6 praia longe 44 0.0000243 0.00103 0.000565 41.8
## 7 praia voltei 57 0.0000315 0.00103 0.000765 40.0
## 8 praia longo 24 0.0000133 0.00103 0.000333 38.7
## 9 praia mar 57 0.0000315 0.00103 0.000831 36.8
## 10 praia pequena 24 0.0000133 0.00103 0.000466 27.7
## # ... with 13 more rowsVamos observar quais palavras estão associadas a “raimundo”:
normalized_prob %>%
filter(word1 == "raimundo") %>%
arrange(-p_together)## # A tibble: 108 x 7
## word1 word2 n p p1 p2 p_together
## <chr> <chr> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 raimundo raimundo 1303 0.000721 0.00306 0.00306 77.0
## 2 raimundo copo 23 0.0000127 0.00306 0.0000665 62.5
## 3 raimundo bêbedo 22 0.0000122 0.00306 0.0000665 59.8
## 4 raimundo vítima 21 0.0000116 0.00306 0.0000665 57.1
## 5 raimundo ouviu 26 0.0000144 0.00306 0.0000998 47.1
## 6 raimundo ouvimos 22 0.0000122 0.00306 0.0000998 39.9
## 7 raimundo revólver 36 0.0000199 0.00306 0.000200 32.6
## 8 raimundo insultá 24 0.0000133 0.00306 0.000133 32.6
## 9 raimundo navalha 35 0.0000194 0.00306 0.000200 31.7
## 10 raimundo bateu 23 0.0000127 0.00306 0.000133 31.3
## # ... with 98 more rowsVamos transformar estes dados em uma matriz esparsa:
pmi_matrix <- normalized_prob %>%
mutate(pmi = log10(p_together)) %>%
cast_sparse(word1, word2, pmi)
head(pmi_matrix@x)## [1] 1.5821239 0.6537674 0.7127086 0.4269799 0.8530843 0.8116916A transformação de dados textuais em matriz, possuem muitos zeros, esta estrutura utilizada economiza tempo e memória.
PCA para textos:
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 :
library(irlba)
pmi_pca <- irlba::prcomp_irlba(pmi_matrix, n = 256)
word_vectors <- pmi_pca$x
rownames(word_vectors) <- rownames(pmi_matrix)
dim(word_vectors)## [1] 1884 256Encontrando 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:
search_synonyms(word_vectors, word_vectors["praia",])## # A tibble: 1,884 x 2
## token similarity
## <chr> <dbl>
## 1 praia 36.9
## 2 mar 21.1
## 3 longe 16.3
## 4 raimundo 14.7
## 5 voltei 14.2
## 6 maria 14.1
## 7 banho 13.6
## 8 alguns 13.2
## 9 brilho 13.1
## 10 pequena 12.7
## # ... with 1,874 more rows