|
Mineração de Texto
|
Agrupamento de documentos
Prof. Walmes M. Zeviani
2019-12-06
1 Definições da sessão
library(jsonlite)
library(tm)
library(slam)
library(text2vec)
library(proxy)
library(RWeka)
library(Matrix)
library(dendextend)
library(networkD3)
library(DT)2 Agrupamento de avaliações de veículos
2.1 Importação das avaliações
Os dados usados neste exemplo são de avaliações de donos de veículos extraídos do Carros na Web, guia Opinião do Dono.
A documentação sobre o arquivo está dispoível em LEG-UFPR Hackathon.
# Importação do arquivo JSON.
url <- "https://github.com/leg-ufpr/hackathon/blob/master/opinioes.json?raw=true"
json <- fromJSON(txt = url)
str(json)## chr [1:5329, 1:10] "e2b9dc08" "3b9dcf63" "9f62a709" "0e6c8d29" ...head(json[, 3], n = 3) # Modelo.## [1] "Chevrolet Celta LT 1.0 2011/2012"
## [2] "Chevrolet Celta LT 1.0 2015/2015"
## [3] "Chevrolet Celta Life 1.0 2004/2005"head(json[, 9], n = 3) # Opinião geral.## [1] "Opinião Geral:O CARRO É 10 ESTOU COM ELE A 7 ANOS E RODEI 35000 KM,[RODO POUCO MORO PRÓXIMO DO TRABALHO] NUNCA ME DEIXOU NA MÃO, É MUITO ECONÔMICO, PRA QUEM QUER UM CARRINHO PRA ANDAR NA CIDADE E ATÉ UMAS VIAGENS CURTAS NÃO DECEPCIONA, MOTORZINHO MUITO VALENTE FIQUEI IMPRESSIONADO.... SÓ TROCO ÓLEO NO TEMPO CERTO COMO RECOMENDADO NO MANUAL..."
## [2] "Opinião Geral:Este é o segundo celta que compro 0km e não me arrependo. Faço as manutenções preventivas sempre, que por sinal são muito baratas, mas sempre usando peças originais. Em comparativos já se mostrou mais seguro que o ônix, e não deixa a desejar pra nenhum de seus concorrentes."
## [3] "Opinião Geral:Recomendo: carro valente, relativamente confortável, econômico e prático. Já fiz várias viagens com ele e nunca me deixou na mão.Outro dia fui de Salvador a Maceió e o carro foi bem. Pesquisei muito e achei o carro certo. Muito indicado para pessoas de baixa renda que só quer o carro como meio de transporte, não para mostrar aos vizinhos kkkk. Estou feliz com o Celta. E este é todo original, até a pintura. Não vendo e não empresto. Vai ficar comigo."2.2 Criação do corpus e pré-processamento
A criação do corpus será seguida do pré-processamento usual para coleções de texto. Ou seja, eliminação de caracteres não alfabéticos, stop words, aplicação de stemming, etc.
Por questões didáticas, o exemplo será feito apenas com as avaliações do Volkswagen Fox.
# Cria vetor de avaliações gerais para um particular modelo.
i <- grep(x = json[, 3], "Volkswagen Fox")
x <- json[i, 9]
names(x) <- json[i, 1]
# TIP: para indicar o idioma tanto serve `portuguese` quanto `pt`.
# Cria o corpus a partir de um vetor.
cps <- Corpus(VectorSource(x),
readerControl = list(language = "portuguese"))
cps## <<SimpleCorpus>>
## Metadata: corpus specific: 1, document level (indexed): 0
## Content: documents: 613# Função que troca pontuação por espaço.
replacePunctuation <- content_transformer(FUN = function(x) {
return(gsub(pattern = "[[:punct:]]+", replacement = " ", x = x))
})
# ATTENTION: O stemming é linguagem dependente?
stemDocument(cps[[1]])[[1]]## [1] "Opinião Geral:no geral é um carro muito bom, quando se faz um mai e menos, com certeza os prós vencem, vou partir pra um sedã mai se foss ficar com um hatch, com certeza seria outro fox 1.6"stemDocument(cps[[1]], language = "english")[[1]]## [1] "Opinião Geral:no geral é um carro muito bom, quando se faz um mai e menos, com certeza os prós vencem, vou partir pra um sedã mai se foss ficar com um hatch, com certeza seria outro fox 1.6"stemDocument(cps[[1]], language = "spanish")[[1]]## [1] "Opinião Geral:no geral é um carro muito bom, quando se faz um mai e menos, com certeza os prós vencem, vou partir pra um sedã mai se foss ficar com um hatch, com certeza seria outro fox 1.6"# Fazendo as operações usuais de limpeza.
cps <- tm_map(cps, FUN = content_transformer(tolower))
cps <- tm_map(cps, FUN = replacePunctuation)
cps <- tm_map(cps, FUN = removeWords,
words = stopwords("portuguese"))
cps <- tm_map(cps, FUN = removeWords,
words = c("opinião", "geral", "carro", "fox", "veículo"))
cps <- tm_map(cps, FUN = stemDocument, language = "portuguese")
cps <- tm_map(cps, FUN = removeNumbers)
cps <- tm_map(cps, FUN = stripWhitespace)
cps <- tm_map(cps, FUN = content_transformer(trimws))
content(cps[[1]])## [1] "é bom faz men certez prós venc vou part pra sedã fic hatch certez outr"content(cps[[2]])## [1] "apes ter apresent baix óle aparent motiv má qualidad construt alguns defeit pontu é bom dia dia prátic pequen econôm funçõ úte desempenh bom motor"# Filtra documentos pelo número de caracteres. Elimina avaliações curtas
# que tem pouca informação.
cps <- tm_filter(cps, FUN = function(x) sum(nchar(x)) >= 120)
# Filtra pela ocorrência de algum termo.
u <- tm_filter(cps, FUN = function(x) any(grep("defeit", x)))
lapply(u[1:3], FUN = strwrap, width = 56)## $`5ff3eee9`
## [1] "apes ter apresent baix óle aparent motiv má qualidad"
## [2] "construt alguns defeit pontu é bom dia dia prátic"
## [3] "pequen econôm funçõ úte desempenh bom motor"
##
## $f454b602
## [1] "recom sim é bom apes pouquíss defeit pegu mil km rod"
## [2] "estil lind atend bem necess dia dia espos sobr espac"
## [3] "cois acontec pali celt"
##
## $`6132796c`
## [1] "ser compact pararec carrã uno gol prefir pont ceg menor"
## [2] "fiat motor dar defeit mt confiável vectr baix rotaçã é"
## [3] "melhor apost corr é elent agor gost muit veloc compr"
## [4] "golf"2.3 Criação da matriz de documentos e termos
A matriz de documentos e termos é criada usando os textos pré-processados. A escolha do tipo de ponderação é muito importante para as taferas que serão realizadas. Faça uma busca para definir qual o tipo de ponderação mais adequada para a análise subsequente. Para a análise de agrupamento, será usada a ponderação binária.
# Matriz de documentos (linhas) e termos (colunas).
dtm <- DocumentTermMatrix(cps,
control = list(weighting = weightBin))
dtm## <<DocumentTermMatrix (documents: 188, terms: 1802)>>
## Non-/sparse entries: 6396/332380
## Sparsity : 98%
## Maximal term length: 37
## Weighting : binary (bin)c(nTerms(dtm), nDocs(dtm))## [1] 1802 188sample(Terms(dtm), size = 10)## [1] "astras" "manual" "confirm" "nao" "qualidad" "maaaasss"
## [7] "recei" "honest" "achar" "mã"class(dtm)## [1] "DocumentTermMatrix" "simple_triplet_matrix"cbind(methods(class = "simple_triplet_matrix"))## [,1]
## [1,] "aperm.simple_triplet_matrix"
## [2,] "as.array.simple_triplet_matrix"
## [3,] "as.matrix.simple_triplet_matrix"
## [4,] "as.simple_sparse_array.simple_triplet_matrix"
## [5,] "as.simple_triplet_matrix.simple_triplet_matrix"
## [6,] "as.vector.simple_triplet_matrix"
## [7,] "cbind.simple_triplet_matrix"
## [8,] "col_means.simple_triplet_matrix"
## [9,] "col_sums.simple_triplet_matrix"
## [10,] "c.simple_triplet_matrix"
## [11,] "dimnames<-.simple_triplet_matrix"
## [12,] "dimnames.simple_triplet_matrix"
## [13,] "dim<-.simple_triplet_matrix"
## [14,] "dim.simple_triplet_matrix"
## [15,] "duplicated.simple_triplet_matrix"
## [16,] "is.numeric.simple_triplet_matrix"
## [17,] "Math.simple_triplet_matrix"
## [18,] "mean.simple_triplet_matrix"
## [19,] "Ops.simple_triplet_matrix"
## [20,] "print.simple_triplet_matrix"
## [21,] "rbind.simple_triplet_matrix"
## [22,] "rollup.simple_triplet_matrix"
## [23,] "row_means.simple_triplet_matrix"
## [24,] "row_sums.simple_triplet_matrix"
## [25,] "[<-.simple_triplet_matrix"
## [26,] "[.simple_triplet_matrix"
## [27,] "split.simple_triplet_matrix"
## [28,] "Summary.simple_triplet_matrix"
## [29,] "t.simple_triplet_matrix"
## [30,] "unique.simple_triplet_matrix"# Com ponderação binária, essa soma é inversamente proporcional a
# esparsidade de cada coluna.
col_tot <- slam::col_sums(dtm)
col_spar <- (nDocs(dtm) - col_tot)/nDocs(dtm)
# Termos mais esparsos.
ord <- order(col_tot, decreasing = FALSE)
col_tot <- col_tot[ord]
col_spar <- col_spar[ord]
head(col_spar, n = 10) # Mais esparsas.## funçõ má pontu úte contrari cans choqu
## 0.9946809 0.9946809 0.9946809 0.9946809 0.9946809 0.9946809 0.9946809
## embal ergonom folg
## 0.9946809 0.9946809 0.9946809tail(col_spar, n = 10) # Menos esparsas.## pra recom problem consum pois bem outr
## 0.7978723 0.7978723 0.7925532 0.7765957 0.7659574 0.7234043 0.7234043
## motor bom compr
## 0.6914894 0.6223404 0.5372340# Os n termos menos esparsos.
lattice::barchart(tail(col_tot, n = 50))
# A espasidade de cada termo.
plot((col_spar))
abline(h = 0.95)
2.4 Remoção de esparsidade
A eliminação da esparsidade se dá pelo descarte de termos com colunas esparsas. Estes termos ocorrem em poucos documentos.
summary(col_spar)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.5372 0.9840 0.9947 0.9811 0.9947 0.9947par(mfrow = c(2, 1))
plot(ecdf(col_spar))
plot(ecdf(col_spar^10))
layout(1)
# Qual a esparsidade para manter até 10% dos termos?
0.1 * nTerms(dtm)## [1] 180.2k <- quantile(col_spar, probs = 0.1)
k## 10%
## 0.9574468# Matriz menos esparsa.
rst <- removeSparseTerms(dtm, sparse = k)
rst## <<DocumentTermMatrix (documents: 188, terms: 201)>>
## Non-/sparse entries: 3255/34533
## Sparsity : 91%
## Maximal term length: 12
## Weighting : binary (bin)2.5 Agrupamento hierárquico
O agrupamento será feito a partir da matriz de documentos e termos. Isso é baseado em medidas de similaridade/distância entre documentos no espaço vetorial.
# Número de distâncias a serem calculadas.
nDocs(dtm) * (nDocs(dtm) - 1)/2## [1] 17578# Retorna uma distância e não uma similaridade, então dissimilaridade.
m <- rbind(c(1, 1, 0),
c(0, 0, 1),
c(0, 0, 1),
c(1, 0, 1))
dist2(m, method = "cosine")## [,1] [,2] [,3] [,4]
## [1,] 2.220446e-16 1.0000000 1.0000000 5.000000e-01
## [2,] 1.000000e+00 0.0000000 0.0000000 2.928932e-01
## [3,] 1.000000e+00 0.0000000 0.0000000 2.928932e-01
## [4,] 5.000000e-01 0.2928932 0.2928932 2.220446e-16# Distância é caro. Estude bem como obter de forma rápida.
# microbenchmark::microbenchmark(times = 10,
# text2vec::dist2(m, method = "cosine"),
# proxy::dist(m, method = "cosine"))
# Transforma em matriz ordinária. `rst` é uma matriz esparsa.
m <- as.matrix(rst)
# Distância coseno entre documentos.
d_mat <- text2vec::dist2(m, method = "cosine")
str(d_mat)## num [1:188, 1:188] 1.11e-16 9.40e-01 7.33e-01 9.45e-01 8.39e-01 ...
## - attr(*, "dimnames")=List of 2
## ..$ Docs: chr [1:188] "5ff3eee9" "6c956410" "29056ebb" "f0abda9b" ...
## ..$ Docs: chr [1:188] "5ff3eee9" "6c956410" "29056ebb" "f0abda9b" ...# De matriz cheia para triangular inferior.
d_mat <- stats::as.dist(d_mat)
str(d_mat)## 'dist' Named num [1:17578] 0.94 0.733 0.945 0.839 0.931 ...
## - attr(*, "Labels")= chr [1:188] "5ff3eee9" "6c956410" "29056ebb" "f0abda9b" ...
## - attr(*, "Size")= int 188
## - attr(*, "call")= language as.dist.default(m = d_mat)
## - attr(*, "Diag")= logi FALSE
## - attr(*, "Upper")= logi FALSE# Vetor com as distâncias.
d_vec <- c(d_mat)
length(d_vec)## [1] 17578# Grau de dissimilaridade.
plot(ecdf(d_vec))
abline(h = 0.1, col = "red", lty = "dashed")
quantile(d_vec, probs = 0.1)## 10%
## 0.7735446# Faz o dendrograma.
mtd <- "average"
mtd <- "ward.D2"
mtd <- "single"
mtd <- "complete"
mtd <- "centroid"
mtd <- "median"
mtd <- "ward.D"
# hc <- hclust(d_mat, method = mtd)
# plot(hc, hang = -1)
hc <- as.dendrogram(hclust(d_mat, method = mtd))
plot(set(hc, "branches_k_color", k = 10))
# Grupos criados pelo dendograma.
grp <- cutree(hc, k = 10)
# Tamanho dos grupos.
sort(sapply(split(names(grp), grp), FUN = length))## 8 10 9 1 6 5 3 7 2 4
## 7 9 16 18 18 19 20 20 26 352.5.1 Avaliações do mesmo grupo
tb_u <- data.frame(id = meta(cps, tag = "id"),
grupo_hc = grp,
# avaliação = content(cps)
avaliação = x[is.element(names(x),
meta(cps, tag = "id"))])
rownames(tb_u) <- NULL
# head(tb_u)
html_table <-
datatable(tb_u,
colnames = c("Avaliação", "Grupo", "Opinião"))
html_table2.5.2 Rede de relacionamento
library(networkD3)
# Para cortar nos k documentos menos dissimilares.
dis <- sort(d_vec)[50]
dis## [1] 0.6307255links <- which(proxy::as.matrix(d_mat, diag = NA) < dis, arr.ind = TRUE)
str(links)## int [1:96, 1:2] 24 87 119 121 101 11 119 68 118 48 ...
## - attr(*, "dimnames")=List of 2
## ..$ : chr [1:96] "5526b980" "2ebd40ff" "427c0acb" "97ee3789" ...
## ..$ : chr [1:2] "row" "col"linkage <- data.frame(links, row.names = NULL)
simpleNetwork(Data = linkage)## Warning: It looks like Source/Target is not zero-indexed. This is required
## in JavaScript and so your plot may not render.# Documento com mais ligações.
u <- sort(table(c(links))/2, decreasing = TRUE)
doc <- as.integer(names(u[1]))
# Relações do documento com mais relações.
i <- apply(links, MARGIN = 2, FUN = "==", doc)
i <- rowSums(i) >= 1
links[i, ]## row col
## c94df60d 118 27
## c94df60d 118 41
## c94df60d 118 57
## c94df60d 118 68
## c94df60d 118 71
## f454b602 27 118
## 09ce3cc8 41 118
## b16c1775 57 118
## be0f7368 68 118
## 201dfbb3 71 118
## 427c0acb 119 118
## c94df60d 118 119# Avaliações conectadas.
u <- unique(c(links[i, ]))
u## [1] 118 27 41 57 68 71 119# sapply(x[Docs(rst)[u]], strwrap, width = 60)
# Docs(rst)[u]
html_table <-
datatable(tb_u[tb_u$id %in% Docs(rst)[u], ],
colnames = c("Avaliação", "Grupo", "Opinião"))
html_table2.5.3 Agrupamento não hierárquico com K-means
X <- as.matrix(rst)
km <- kmeans(X, centers = 10)
str(km)## List of 9
## $ cluster : Named int [1:188] 8 5 3 2 1 6 5 6 4 1 ...
## ..- attr(*, "names")= chr [1:188] "5ff3eee9" "6c956410" "29056ebb" "f0abda9b" ...
## $ centers : num [1:10, 1:201] 0 0.333 0.333 0 0 ...
## ..- attr(*, "dimnames")=List of 2
## .. ..$ : chr [1:10] "1" "2" "3" "4" ...
## .. ..$ : chr [1:201] "alguns" "apes" "apresent" "baix" ...
## $ totss : num 2848
## $ withinss : num [1:10] 509 171 195 242 240 ...
## $ tot.withinss: num 2483
## $ betweenss : num 365
## $ size : int [1:10] 50 9 9 16 18 19 6 36 18 7
## $ iter : int 6
## $ ifault : int 0
## - attr(*, "class")= chr "kmeans"tb_u$grupo_km <- km$cluster
html_table <-
datatable(tb_u,
colnames = c("Avaliação", "Grupo HC", "Opinião", "Grupo KM"))
html_tabletable(km$cluster)##
## 1 2 3 4 5 6 7 8 9 10
## 50 9 9 16 18 19 6 36 18 7table(tb_u$grupo_km, tb_u$grupo_hc)##
## 1 2 3 4 5 6 7 8 9 10
## 1 2 4 11 2 3 9 7 0 8 4
## 2 0 1 1 5 0 0 1 0 0 1
## 3 0 0 1 5 2 0 0 0 1 0
## 4 2 2 0 3 4 1 4 0 0 0
## 5 4 3 1 0 2 1 0 7 0 0
## 6 0 0 0 2 0 7 4 0 5 1
## 7 0 5 0 0 1 0 0 0 0 0
## 8 3 8 0 17 3 0 0 0 2 3
## 9 1 3 6 0 4 0 4 0 0 0
## 10 6 0 0 1 0 0 0 0 0 0k_seq <- 2:40
w_seq <- sapply(k_seq,
FUN = function(ki) {
kmeans(X,
centers = ki)$tot.withinss
})## Warning: did not converge in 10 iterationsplot(w_seq ~ k_seq, type = "o")
2.5.4 Agrupamento não hierárquico com DB-SCAN
set.seed(456)
db <- fpc::dbscan(X, eps = 3.9, MinPts = 5)
str(db)## List of 4
## $ cluster: num [1:188] 0 0 0 0 1 0 0 0 0 1 ...
## $ eps : num 3.9
## $ MinPts : num 5
## $ isseed : logi [1:188] FALSE FALSE FALSE FALSE TRUE FALSE ...
## - attr(*, "class")= chr "dbscan"table(db$cluster)##
## 0 1
## 144 44grid <- expand.grid(eps = seq(2, 8, length.out = 20),
MinPts = 4:14)
grid$n <- mapply(
FUN = function(i, j) {
length(table(fpc::dbscan(X, eps = i, MinPts = j)$cluster))
},
i = grid$eps,
j = grid$MinPts)
lattice::levelplot(n ~ eps + MinPts, data = grid)
opts_chunk$set(eval = FALSE)3 Similaridade entre os signos do zodíaco
- Descrição da personalidade dos 12 signos do zodíaco.
- Matriz de documentos e termos ponderada com TF-IDF.
#-----------------------------------------------------------------------
# Fonte: www.planetaesoterico.com.br.
url <- paste0("http://www.planetaesoterico.com.br/perfil-dos-signos",
"/perfil-dos-signos.php")
# browseURL(url)
h <- htmlParse(url, encoding = "utf-8")
# summary(h)
txt <- xpathSApply(doc = h,
path = "//div[@class = 'text-signos']",
fun = xmlValue,
trim = TRUE)
length(txt)#-----------------------------------------------------------------------
# Criando o Corpus.
# Atribui nomes aos elementos do vetor.
signos <- c("ÁRIES", "TOURO", "GÊMEOS", "CÂNCER", "LEÃO", "VIRGEM",
"LIBRA", "ESCORPIÃO", "SAGITÁRIO", "CAPRICÓRNIO", "AQUÁRIO",
"PEIXES")
names(txt) <- signos
cps <- Corpus(VectorSource(txt),
readerControl = list(language = "portuguese"))
cps
# Fazendo as operações de limpeza.
cps <- tm_map(cps, FUN = content_transformer(tolower))
cps <- tm_map(cps, FUN = replacePunctuation)
cps <- tm_map(cps, FUN = removeNumbers)
cps <- tm_map(cps, FUN = removeWords, words = stopwords("portuguese"))
cps <- tm_map(cps, FUN = stripWhitespace)
cps <- tm_map(cps, FUN = content_transformer(trimws))
# Matriz de documentos e termos.
dtm <- DocumentTermMatrix(cps,
control = list(weighting = weightBin,
stemming = TRUE))
dtm
# Matriz menos esparsa.
rst <- removeSparseTerms(dtm, sparse = 0.75)
rst
# Transforma em matriz ordinária.
m <- as.matrix(rst)
# Distância coseno entre documentos.
d_mat <- text2vec::dist2(m, method = "cosine")
str(d_mat)
# De matriz cheia para triangular inferior.
d_mat <- stats::as.dist(d_mat)
str(d_mat)
# Vetor com as distâncias.
d_vec <- c(d_mat)
length(d_vec)
# Grau de dissimilaridade.
plot(ecdf(d_vec))
abline(h = 0.1, col = "red", lty = "dashed")
quantile(d_vec, probs = 0.1)
# Faz o dendrograma.
hc <- hclust(d_mat, method = "average")
plot(hc, hang = -1)
# Grupos criados pelo dendograma.
grp <- cutree(hc, k = 4)
split(names(grp), grp)4 Agrupamento de respostas a questões discursivas
Essa abordagem irá verificar se existem respostas muito semelhates.
# ATTENTION: deve-se usar o contrutor `VCorpus()` para fazer uso de
# funções de tokenização.
cps <- VCorpus(DirSource(directory = "../data/agrupamento/"),
readerControl = list(language = "portuguese"))
class(cps)
# Fazendo as operações de limpeza.
cps <- tm_map(cps, FUN = content_transformer(tolower))
cps <- tm_map(cps, FUN = replacePunctuation)
cps <- tm_map(cps, FUN = removeNumbers)
cps <- tm_map(cps, FUN = removeWords, words = stopwords("portuguese"))
cps <- tm_map(cps, FUN = stripWhitespace)
cps <- tm_map(cps, FUN = stemDocument, language = "portuguese")
cps <- tm_map(cps, FUN = content_transformer(trimws))
# Um tokenizador de bi-gramas.
my_tokenizer <- function(x) {
NGramTokenizer(x, control = Weka_control(min = 2, max = 2))
}
tt <- Token_Tokenizer(my_tokenizer)
tt(s)
dtm <- DocumentTermMatrix(cps, control = list(tokenize = tt))
dtm
sample(Terms(dtm), size = 10)
# content(cps[[1]])
# Matriz menos esparsa.
rst <- removeSparseTerms(dtm, sparse = 0.75)
rst
# Transforma em matriz ordinária.
m <- as.matrix(rst)
# Distância coseno entre documentos.
d_mat <- text2vec::dist2(m, method = "cosine")
str(d_mat)
# De matriz cheia para triangular inferior.
d_mat <- stats::as.dist(d_mat)
str(d_mat)
# Vetor com as distâncias.
d_vec <- c(d_mat)
length(d_vec)
# Grau de dissimilaridade.
plot(ecdf(d_vec))
abline(h = 0.1, col = "red", lty = "dashed")
quantile(d_vec, probs = 0.1)
# Faz o dendrograma.
hc <- hclust(d_mat, method = "average")
plot(hc, hang = -1)
# ATTENTION: cuidado em fazer isso com dimensões proibitivas.
u <- which(as.matrix(d_mat) == min(d_mat), arr.ind = TRUE)
i <- names(cps) %in% rownames(u)
lapply(cps[i], strwrap, width = 60)#-----------------------------------------------------------------------
# Versões dos pacotes e data do documento.
devtools::session_info()
Sys.time()
Mineração de Texto |
leg.ufpr.br/~walmes/ensino/mintex/ |