|
Mineração de Texto
|
Modelagem de tópicos
Prof. Walmes M. Zeviani
2019-12-06
1 Definições da sessão
#-----------------------------------------------------------------------
# Pacotes.
library(jsonlite) # Leitura e escrita JSON.
library(tidyverse) # Recursos de manipulação e visualização.
library(tidytext) # Manipulação de texto a la tidyverse.
library(tm) # Mineração de texto.
library(topicmodels) # Modelagem de tópicos.
library(wordcloud) # Núvem de palavras.
library(ggtern) # Gráfico ternário.
# library(lda)
# library(LDAvis)2 Modelagem de tópicos das notícias da UFPR
Notícias sobre a UFPR na Gazeta do Povo entre Setembro/16 e Março/17.
2.1 Criação do corpus e matriz de documentos e termos
#-----------------------------------------------------------------------
# Carrega notícias sobre a UFPR.
# Dados armazenados na forma de lista em binário `RData`.
load("../data/ufpr-news.RData")
length(ufpr)## [1] 8305str(ufpr[[1]])## List of 11
## $ id_noticia : chr "3224492166"
## $ str_midia : chr "Online"
## $ str_veiculo : chr "Gazeta do Povo - Economia"
## $ str_tipo_veiculo: chr "GRANDES REGIONAIS"
## $ str_cidade : chr "Curitiba"
## $ str_estado : chr "PARANÁ"
## $ str_pais : chr "Brasil"
## $ str_secao : chr "AUTOMÓVEIS"
## $ ts_publicacao : chr "2016-09-05 00:14:18"
## $ str_titulo : chr "MST ergue acampamento em frente ao Incra de Curitiba para exigir reforma agrária"
## $ conteudo_texto : chr "Cerca de 1,5 mil integrantes do Movimento dos Trabalhadores Rurais Sem Terra (MST) ocupam desde a manhã desta s"| __truncated__#-----------------------------------------------------------------------
# Título das notícias.
# Extrai os títulos.
tit <- sapply(ufpr, "[[", "str_titulo")
# tit <- sapply(ufpr, "[[", "conteudo_texto")
dul <- duplicated(tolower(tit))
sum(dul)## [1] 3454# Removendo as duplicações com base nos títulos.
ufpr <- ufpr[!dul]
tit <- tit[!dul]
#-----------------------------------------------------------------------
# Período das publicações.
dts <- strptime(sapply(ufpr, "[[", "ts_publicacao"),
format = "%Y-%m-%d %H:%M:%S")
range(dts)## [1] "2016-09-05 00:14:18 -03" "2017-03-31 23:23:00 -03"#-----------------------------------------------------------------------
# Veículos de divulgação.
vei <- sapply(ufpr, "[[", "str_veiculo")
tb <- sort(table(vei), decreasing = TRUE)
ggplot(enframe(head(tb, n = 30)),
aes(x = reorder(name, value), y = value)) +
geom_col() +
labs(x = "Veículo", y = "Frequência") +
coord_flip()## Don't know how to automatically pick scale for object of type table. Defaulting to continuous.
#-----------------------------------------------------------------------
# Extraindo o conteúdo das notícias.
L <- sapply(ufpr, FUN = "[", "conteudo_texto")
L <- unlist(L)
L[1:3] %>%
map(str_sub, start = 1, end = 500) %>%
map(str_wrap, width = 60) %>%
walk(cat, "... <continua> ... \n\n")## Cerca de 1,5 mil integrantes do Movimento dos Trabalhadores
## Rurais Sem Terra (MST) ocupam desde a manhã desta segunda-
## feira (5) espaços em frente à sede do Instituto Nacional de
## Colonização e Reforma Agrária (Incra) em Curitiba, que fica
## na rua Dr. Faivre, no Centro. Por causa do protesto, a via
## foi bloqueada entre as avenidas Sete de Setembro e Visconde
## de Guarapuava. Equipes do BPTran e Setran já estão no local.
## A linha Circular Centro, que passa na região, registra um
## pouco de atraso nos horá ... <continua> ...
##
## A Prefeitura de Ponta Grossa lamenta o falecimento da
## arquiteta e urbanista Silvia Magali Contin, aos 61 anos,
## ocorrido nesta segunda-feira (5). Silvia foi a primeira
## presidente do Instituto de Pesquisa e Planejamento Urbano de
## Ponta Grossa (Iplan), permanecendo no cargo nos anos de 1999
## a 2000. Formada em Arquitetura pela Universidade Federal do
## Paraná (UFPR), vinha participando ativamente das reuniões
## públicas do Iplan para a elaboração do Plano Diretor
## Municipal 2016, e foi membro integrante ... <continua> ...
##
## Inscrições para o vestibular da Universidade Federal
## do Paraná seguem abertas até o dia 11 de setembro. A
## Universidade Federal do Paraná está com inscrições abertas
## para o vestibular . As inscrições podem ser realizadas
## pela internet até o dia 11 de setembro por meio deste
## link: www.nc.ufpr.br /concursos_institucionais/ufpr/ps2016/
## index.htm. O valor da taxa é de R$ 120,00 e as provas estão
## previstas para serem aplicadas no dia 8 de novembro . A
## segunda ... <continua> ...#-----------------------------------------------------------------------
# Cria o corpus a partir da lista.
# is.vector(L)
cps <- VCorpus(VectorSource(x = L),
readerControl = list(language = "pt"))
cps## <<VCorpus>>
## Metadata: corpus specific: 0, document level (indexed): 0
## Content: documents: 4851# Confere os tamanhos.
length(cps) == length(vei)## [1] TRUE#-----------------------------------------------------------------------
# Adiciona os metadados aos documentos do corpus. Eles podem ser úteis
# para aplicar filtros e tarefas por estrato.
# `type = "local"` para usar na `tm_filter()` e `tm_index()`.
meta(cps, type = "local", tag = "veiculo") <- vei
meta(cps, type = "local", tag = "titulo") <- tit
meta(cps, type = "local", tag = "ts") <- as.character(dts)
# Consulta os metadados apenas para verificação.
# meta(cps[[5]])
# meta(cps[[5]], tag = "veiculo")
# meta(cps[[5]], tag = "ts")
# Filtra os documentos usando os metadados.
cps2 <- tm_filter(cps,
FUN = function(x) {
meta(x)[["veiculo"]] == "Gazeta do Povo"
})
length(cps2)## [1] 516- Processo de filtragem poderia ser feito antes de criar um corpus, apenas com os vetores do
veiculoe dos conteúdos das notíciasL. - Isso ilustra como usar a
tm_filter(), que pode ser usada para filtrar textos com base no conteúdo: e.g. contém a palavra “vestibular”?
#-----------------------------------------------------------------------
# Processamento.
cps2 <- cps2 %>%
tm_map(FUN = content_transformer(tolower)) %>%
tm_map(FUN = content_transformer(
function(x) gsub(" *-+ *", "-", x))) %>%
# tm_map(FUN = replacePunctuation) %>%
tm_map(FUN = content_transformer(
function(x) gsub("[[:punct:]]", " ", x))) %>%
tm_map(FUN = removeNumbers) %>%
tm_map(FUN = removeWords,
words = stopwords("portuguese")) %>%
tm_map(FUN = stemDocument,
language = "portuguese") %>%
tm_map(FUN = stripWhitespace)
# Para ver os fragmentos dos documentos após o pré-processamento.
sapply(cps2[1:2], content) %>%
map(str_sub, start = 1, end = 500) %>%
map(str_wrap, width = 60) %>%
walk(cat, "... <continua> ... \n\n")## advogado renato almeida freita junior costuma dar orientaçõ
## comunidad carent curitiba região sobr comportar abordagen
## polícia próprio seguindo regra ensina obtev sucesso acabou
## sendo detido sob acusação perturbação ordem pública desacato
## freita é candidato vereador capit preso agosto doi guarda
## municipai porqu estaria ouvindo música volum alto região
## central curitiba formado direito universidad feder paraná
## ufpr desd mestrando programa pós graduação mesma instituição
## ond pesquisa sistema carcerá ... <continua> ...
##
## advogado renato almeida freita junior costuma dar orientaçõ
## comunidad carent curitiba região sobr comportar abordagen
## polícia próprio seguindo regra ensina obtev sucesso acabou
## sendo detido sob acusação perturbação ordem pública desacato
## freita é candidato vereador capit preso agosto doi guarda
## municipai porqu estaria ouvindo música volum alto região
## central curitiba formado direito universidad feder paraná
## ufpr desd mestrando programa pós graduação mesma instituição
## ond pesquisa sistema carcerá ... <continua> ...#-----------------------------------------------------------------------
# Criar a matriz de documentos e termos.
# Para fazer modelagem de tópicos, requer ponderação `term-frequency`.
# Ela é a opção default.
dtm <- DocumentTermMatrix(cps2)
dtm## <<DocumentTermMatrix (documents: 516, terms: 20740)>>
## Non-/sparse entries: 129285/10572555
## Sparsity : 99%
## Maximal term length: 24
## Weighting : term frequency (tf)# Número de documentos x tamanho do vocabulário.
dim(dtm)## [1] 516 20740# Remoção de esparsidade para reduzir dimensão.
rst <- removeSparseTerms(x = dtm, sparse = 0.99)
rst## <<DocumentTermMatrix (documents: 516, terms: 4167)>>
## Non-/sparse entries: 100282/2049890
## Sparsity : 95%
## Maximal term length: 20
## Weighting : term frequency (tf)# Número de documentos x tamanho do vocabulário.
dim(rst)## [1] 516 4167dtm <- rst2.2 Ajuste do modelo LDA
- LDA é Latent Dirichlet Allocation.
- http://conteudo.icmc.usp.br/CMS/Arquivos/arquivos_enviados/BIBLIOTECA_158_RT_409.pdf.
- https://towardsdatascience.com/light-on-math-machine-learning-intuitive-guide-to-latent-dirichlet-allocation-437c81220158.
- http://www.jmlr.org/papers/volume3/blei03a/blei03a.pdf.
- https://www.tidytextmining.com/topicmodeling.html.
# Essa função requer ponderação padrão: term frequency.
# k: número de assuntos ou temas.
fit <- LDA(x = dtm, k = 3)
fit## A LDA_VEM topic model with 3 topics.# Classe, métodos e conteúdo (é programação orientada a objetos em
# arquitetura S4).
class(fit)## [1] "LDA_VEM"
## attr(,"package")
## [1] "topicmodels"methods(class = "LDA_VEM")## [1] logLik perplexity posterior show terms topics
## see '?methods' for accessing help and source codeslotNames(fit)## [1] "alpha" "call" "Dim"
## [4] "control" "k" "terms"
## [7] "documents" "beta" "gamma"
## [10] "wordassignments" "loglikelihood" "iter"
## [13] "logLiks" "n"isS4(fit)## [1] TRUE# Termos principais (maior frequência) que são, por default, usados para
# rotular tópicos.
terms(fit)## Topic 1 Topic 2 Topic 3
## "ufpr" "ano" "ser"# get_terms(fit)
# Índice que separa os documentos pelo tópico com maior fração. Esse
# seria o resultado da análise de agrupamento fornecida por essa
# abordagem.
classif <- topics(fit)
head(classif) # Classificação dos primeiros documentos.## 5 6 14 22 30 31
## 3 3 3 2 3 1table(classif) # Distribuição dos documentos nas classes.## classif
## 1 2 3
## 165 144 207# Fração de cada tópico por documento (a soma é 1).
# rowSums(fit@gamma[1:6, ])
head(fit@gamma) %>%
`colnames<-`(paste0("Tópico", 1:fit@k))## Tópico1 Tópico2 Tópico3
## [1,] 0.12351372 0.0268899516 0.8495963254
## [2,] 0.12351372 0.0268899516 0.8495963254
## [3,] 0.22794374 0.0002424328 0.7718138269
## [4,] 0.27367775 0.7258137464 0.0005085078
## [5,] 0.00096074 0.4673123352 0.5317269248
## [6,] 0.47695199 0.3938593569 0.1291886567# Fração de cada termo em cada documento (a soma é 1).
round(head(t(exp(fit@beta))), digits = 8) %>%
`colnames<-`(paste0("Tópico", 1:fit@k)) %>%
`rownames<-`(paste0("Termo", 1:nrow(.)))## Tópico1 Tópico2 Tópico3
## Termo1 0.00055368 0.00000000 0.00000000
## Termo2 0.00010716 0.00038498 0.00017293
## Termo3 0.00002572 0.00001500 0.00007398
## Termo4 0.00000000 0.00006800 0.00007181
## Termo5 0.00007151 0.00000152 0.00012511
## Termo6 0.00005186 0.00023462 0.000000002.3 Exibição dos resultados
- Note que a palavra “professor” aparece nos 3 tópicos.
- “universidad” e “ufpr” aparece em dois tópicos.
#-----------------------------------------------------------------------
# Distribuição dos tópicos.
# Proporção dos tópicos nos documentos.
topic_coef <- tidy(fit, matrix = "gamma")
head(topic_coef)## # A tibble: 6 x 3
## document topic gamma
## <chr> <int> <dbl>
## 1 5 1 0.124
## 2 6 1 0.124
## 3 14 1 0.228
## 4 22 1 0.274
## 5 30 1 0.000961
## 6 31 1 0.477# Gráfico da mistura a partir de uma amostra.
aux <- sample_n(topic_coef, size = 150) %>%
arrange(topic, gamma) %>%
mutate(document = fct_reorder(document, row_number()))
ggplot(data = aux) +
aes(x = document,
y = gamma,
fill = factor(topic)) +
geom_col(position = "fill") +
labs(fill = "Tópico predominante") +
coord_flip()
# Os mesmos dados mas na forma wide.
topicProbs <- as.data.frame(fit@gamma)
names(topicProbs) <- paste0("T", seq_along(names(topicProbs)))
topicProbs$class <- topics(fit)
names(topicProbs)## [1] "T1" "T2" "T3" "class"# Gráfico composicional para k = 3.
if (fit@k == 3) {
ggtern(data = topicProbs,
mapping = aes(x = T1,
y = T2,
z = T3,
color = factor(class))) +
geom_point(alpha = 0.5) +
labs(color = "Tópico\npredominante") +
theme_showarrows()
}
#-----------------------------------------------------------------------
# Distribuição dos tópicos.
# Proporção dos termos nos tópicos.
terms_coef <- tidy(fit, matrix = "beta")
head(terms_coef)## # A tibble: 6 x 3
## topic term beta
## <int> <chr> <dbl>
## 1 1 abadia 5.54e- 4
## 2 2 abadia 4.02e-17
## 3 3 abadia 1.14e-31
## 4 1 abaixo 1.07e- 4
## 5 2 abaixo 3.85e- 4
## 6 3 abaixo 1.73e- 4# Os termos mais frequentes pro tópico.
topn_terms <- terms_coef %>%
group_by(topic) %>%
top_n(n = 50, wt = beta) %>%
ungroup()
topn_terms## # A tibble: 150 x 3
## topic term beta
## <int> <chr> <dbl>
## 1 1 acompanh 0.00344
## 2 2 acompanh 0.00338
## 3 1 acordo 0.00364
## 4 3 advogado 0.00221
## 5 1 ainda 0.00323
## 6 2 ainda 0.00323
## 7 3 ainda 0.00381
## 8 2 além 0.00253
## 9 3 além 0.00236
## 10 1 aluno 0.00961
## # … with 140 more rows# ggplot(topn_terms) +
# aes(x = reorder(term, beta), y = beta) +
# facet_wrap(facets = ~topic, scales = "free_y", drop = FALSE) +
# geom_col() +
# coord_flip()
# Faz os gráficos em separado e retorna em lista.
pp <- topn_terms %>%
group_by(topic) %>%
do(plot = {
ggplot(.) +
aes(x = reorder(term, beta), y = beta) +
geom_col() +
labs(x = "Termos", y = "Frequência") +
coord_flip()
})
length(pp$plot)## [1] 3# Invoca a `grid.arrange()` do pacote `gridExtra`.
do.call(what = gridExtra::grid.arrange,
args = c(pp$plot, nrow = 1))
#-----------------------------------------------------------------------
# Núvem de palavras por tópico.
# Termos mais salientes.
topn_terms <- terms_coef %>%
group_by(topic) %>%
top_n(300, beta) %>%
ungroup()
i <- 0
pal <- c("Reds", "Blues", "Greens", "Purples")[1:fit@k]
oldpar <- par()
par(mfrow = c(2, 2), mar = c(0, 0, 0, 0))
topn_terms %>%
group_by(topic) %>%
do(plot = {
i <<- i + 1
wordcloud(words = .$term,
freq = .$beta,
min.freq = 1,
max.words = 300,
random.order = FALSE,
colors = tail(brewer.pal(9, pal[i]), n = 5))
})## Source: local data frame [3 x 2]
## Groups: <by row>
##
## # A tibble: 3 x 2
## topic plot
## * <int> <list>
## 1 1 <NULL>
## 2 2 <NULL>
## 3 3 <NULL>layout(1)
par(oldpar)2.4 Distribuição cronológica dos tópicos
# Pega estampa de tempo.
ts <- sapply(cps2, meta, tag = "ts")
ts <- as.POSIXct(ts)
# Documentos e data de publicação.
doc_ts <- tibble(document = unlist(meta(cps2, "id")),
ts = parse_datetime(unlist(meta(cps2, "ts"))))
# Junção.
topic_ts <- inner_join(topic_coef, doc_ts)## Joining, by = "document"topic_ts## # A tibble: 1,548 x 4
## document topic gamma ts
## <chr> <int> <dbl> <dttm>
## 1 5 1 0.124 2016-09-05 18:20:00
## 2 6 1 0.124 2016-09-05 18:20:00
## 3 14 1 0.228 2016-09-05 22:00:00
## 4 22 1 0.274 2016-09-06 12:29:00
## 5 30 1 0.000961 2016-09-06 16:21:00
## 6 31 1 0.477 2016-09-06 16:25:00
## 7 46 1 0.000515 2016-09-08 00:01:00
## 8 47 1 0.000968 2016-09-08 00:01:00
## 9 71 1 0.000379 2016-09-09 09:50:00
## 10 76 1 0.239 2016-09-09 15:50:00
## # … with 1,538 more rowsgg1 <-
ggplot(topic_ts) +
aes(x = ts, y = gamma, color = factor(topic)) +
geom_point() +
geom_smooth(se = FALSE, span = 0.45) +
theme(legend.direction = "horizontal",
legend.position = "top") +
labs(x = "Data",
y = "Fração de cada tópico",
color = "Tópico")
gg2 <-
ggplot(topic_ts) +
aes(x = ts) +
geom_density(fill = "gray30", alpha = 0.5) +
labs(y = "Densidade de\ndocumentos",
x = "Data")
gridExtra::grid.arrange(gg1, gg2, ncol = 1, heights = c(4,1))## `geom_smooth()` using method = 'loess' and formula 'y ~ x'
3 Modelagem de tópicos das avaliações de veículos
3.1 Importação do texto
#-----------------------------------------------------------------------
# Importação do arquivo JSON.
# Endereço de arquivo JSON com avaliação de veículos.
url <- paste0("https://github.com/leg-ufpr/hackathon/blob/master",
"/opinioes.json?raw=true")
# Importa reviews de veículos.
txt <- fromJSON(url)
str(txt)## chr [1:5329, 1:10] "e2b9dc08" "3b9dcf63" "9f62a709" "0e6c8d29" ...# Conteúdo está na forma de matriz.
# txt[1, ]
# Passando para tabela.
colnames(txt) <- c("id", "title", "model", "owner", "condition", "good",
"bad", "defect", "general", "ts")
tt <- as_tibble(txt)
glimpse(tt)## Observations: 5,329
## Variables: 10
## $ id <chr> "e2b9dc08", "3b9dcf63", "9f62a709", "0e6c8d29", "3c958…
## $ title <chr> "\"MELHOR POPULAR DO MERCADO ATÉ 2012\"", "\"Ótimo car…
## $ model <chr> "Chevrolet Celta LT 1.0 2011/2012", "Chevrolet Celta L…
## $ owner <chr> "João - Brasília DF", "Hugo - São Pedro SP", "Ivan - S…
## $ condition <chr> "Dono há 6 anos - 35.200 kmCarro anterior: Fiat Uno", …
## $ good <chr> "Prós:ECONOMIA DE COMBUSTÍVEL, PEÇAS BARATAS, RESISTEN…
## $ bad <chr> "Contras:UM POUCO BAIXO.. AS VEZES QUANDO ESTÁ CARREGA…
## $ defect <chr> "Defeitos apresentados:NENHUM", "Defeitos apresentados…
## $ general <chr> "Opinião Geral:O CARRO É 10 ESTOU COM ELE A 7 ANOS E R…
## $ ts <chr> "09/03/2018 17:40:00", "02/03/2018 21:27:00", "27/02/2…# Modelos de veículos contidos nas avaliações.
tt$product <- tt$model %>%
str_extract("^([[:alpha:]]+ +[[:alpha:]]+)") %>%
str_to_upper()
# Tipos únicos.
# tt$product %>% unique() %>% dput()
tt %>%
count(product, sort = TRUE)## # A tibble: 8 x 2
## product n
## <chr> <int>
## 1 VOLKSWAGEN GOL 1486
## 2 FIAT PALIO 758
## 3 RENAULT SANDERO 712
## 4 VOLKSWAGEN FOX 613
## 5 FIAT UNO 591
## 6 CHEVROLET CELTA 496
## 7 HYUNDAI HB 452
## 8 CHEVROLET ONIX 221# Aplica filtro para reter apenas um modelo de carro.
mod <- c("CHEVROLET CELTA",
"CHEVROLET ONIX",
"FIAT PALIO",
"FIAT UNO",
"HYUNDAI HB",
"RENAULT SANDERO",
"VOLKSWAGEN FOX",
"VOLKSWAGEN GOL")[7]
texto <- tt %>%
filter(str_detect(product, mod)) %>%
select(id, general)
texto## # A tibble: 613 x 2
## id general
## <chr> <chr>
## 1 704827a6 Opinião Geral:no geral é um carro muito bom, quando se faz um …
## 2 5ff3eee9 Opinião Geral:Apesar de ter apresentado a baixa de óleo aparen…
## 3 6c956410 Opinião Geral:Um carro bem equipado, com custo de manutenção b…
## 4 29056ebb Opinião Geral:O carro é bem bonito e o acabamento é muito bom,…
## 5 f0abda9b Opinião Geral:Carro razoável, caro pelo o preço, cheio de mimo…
## 6 7f1a8990 Opinião Geral:Recomendo muito. Ótimo custo beneficio. A versão…
## 7 68aaaffe Opinião Geral:Carro bom para quem pretende ficar uns 3 a 4 ano…
## 8 5721c9e2 Opinião Geral:Já é meu segundo FOX 0km.... Teria um terceiro. …
## 9 2d50b489 Opinião Geral:Carro é bom, bem econômico, dependendo de onde u…
## 10 39b5955c Opinião Geral:Carro muito bom! Mas com o tempo aparece alguns …
## # … with 603 more rows3.2 Criação do corpus e matriz de documentos e termos
#-----------------------------------------------------------------------
# Cria o corpus a partir de um vetor.
cps <- VCorpus(VectorSource(texto$general),
readerControl = list(language = "portuguese"))
cps## <<VCorpus>>
## Metadata: corpus specific: 0, document level (indexed): 0
## Content: documents: 613# Para ver os fragmentos dos documentos após o pré-processamento.
sapply(cps[1:3], content) %>%
map(str_wrap, width = 60) %>%
walk(cat, "\n\n")## Opinião Geral:no geral é um carro muito bom, quando se faz
## um mais e menos, com certeza os prós vencem, vou partir pra
## um sedã mais se fosse ficar com um hatch, com certeza seria
## outro fox 1.6
##
## Opinião Geral:Apesar de ter apresentado a baixa de óleo
## aparentemente sem motivo, a má qualidade construtiva e
## alguns defeitos pontuais, é um bom carro para o dia-a-dia,
## prático, pequeno, econômico, com funções úteis e desempenho
## bom para um motor 1.0
##
## Opinião Geral:Um carro bem equipado, com custo de manutenção
## barato. Vale muito a pena pelo custo/benefício. Muito bom
## de dirigir, estável, com boa aceleração. Vou trocar por
## um jetta agora pois a família aumentou e preciso de mais
## espaço, do contrario poderia ficar vários anos com ele e
## estar bem de carro.# Função que troca pontuação por espaço.
replacePunctuation <-
content_transformer(FUN = function(x) {
return(gsub(pattern = "[[:punct:]]+",
replacement = " ",
x = x))
})
# Minhas stop words.
my_sw <- c("opinião", "geral", "carro", "veículo")
# Fazendo as operações usuais de limpeza.
cps2 <- cps %>%
tm_map(FUN = content_transformer(tolower)) %>%
tm_map(FUN = replacePunctuation) %>%
tm_map(FUN = removeWords, words = stopwords("portuguese")) %>%
tm_map(FUN = removeWords, words = my_sw) %>%
tm_map(FUN = stemDocument, language = "portuguese") %>%
tm_map(FUN = removeNumbers) %>%
tm_map(FUN = stripWhitespace) %>%
tm_map(FUN = content_transformer(trimws))
# Filtra documentos pelo número de caracteres. Elimina avaliações curtas
# que tem pouca informação.
cps2 <- tm_filter(cps2,
FUN = function(x) {
sum(nchar(content(x))) >= 80
})
cps2## <<VCorpus>>
## Metadata: corpus specific: 0, document level (indexed): 0
## Content: documents: 351# Para ver os fragmentos dos documentos após o pré-processamento.
sapply(cps2[1:3], content) %>%
map(str_wrap, width = 60) %>%
walk(cat, "\n\n")## é bom faz meno certeza prós vencem vou partir pra sedã ficar
## hatch certeza outro fox
##
## apesar ter apresentado baixa óleo aparentement motivo má
## qualidad construtiva algun defeito pontuai é bom dia dia
## prático pequeno econômico funçõ útei desempenho bom motor
##
## bem equipado custo manutenção barato vale pena custo
## benefício bom dirigir estável boa aceleração vou trocar
## jetta agora poi família aumentou preciso espaço contrario
## poderia ficar vário ano estar bem#-----------------------------------------------------------------------
# Matriz de documentos (linhas) e termos (colunas).
# IMPORTANT: a ponderação tem que ser a de frequência absoluta. É a
# poderação default da `DocumentTermMatrix()`.
dtm <- DocumentTermMatrix(cps2)
dtm## <<DocumentTermMatrix (documents: 351, terms: 2685)>>
## Non-/sparse entries: 8869/933566
## Sparsity : 99%
## Maximal term length: 38
## Weighting : term frequency (tf)# Doumentos e vocabulário.
dim(dtm)## [1] 351 2685# Matriz menos esparsa.
rst <- removeSparseTerms(dtm, sparse = 0.975)
rst## <<DocumentTermMatrix (documents: 351, terms: 209)>>
## Non-/sparse entries: 4144/69215
## Sparsity : 94%
## Maximal term length: 14
## Weighting : term frequency (tf)# Doumentos e vocabulário.
dim(rst)## [1] 351 2093.3 Ajuste do modelo LDA
# fit <- LDA(rst, k = 3, control = list(seed = 1234))
fit <- LDA(dtm, k = 3, control = list(seed = 1234))
# topics(fit) # O tópico mais frequente de cada documento.
table(topics(fit))##
## 1 2 3
## 118 115 118terms(fit) # Os termos mais frequentes dos tópicos.## Topic 1 Topic 2 Topic 3
## "fox" "fox" "fox"# Os resultados mais interessantes.
fit_coefs <- posterior(fit)
str(fit_coefs)## List of 2
## $ terms : num [1:3, 1:2685] 6.07e-04 9.50e-20 9.83e-04 1.53e-17 3.06e-04 ...
## ..- attr(*, "dimnames")=List of 2
## .. ..$ : chr [1:3] "1" "2" "3"
## .. ..$ : chr [1:2685] "abaixo" "abastec" "abastecendo" "abastecido" ...
## $ topics: num [1:351, 1:3] 0.00317 0.99586 0.00159 0.99897 0.00123 ...
## ..- attr(*, "dimnames")=List of 2
## .. ..$ : chr [1:351] "1" "2" "3" "4" ...
## .. ..$ : chr [1:3] "1" "2" "3"3.4 Exibição dos resultados
#-----------------------------------------------------------------------
# Distribuição dos tópicos.
# Proporção dos tópicos nos documentos.
topic_coef <- tidy(fit, matrix = "gamma")
head(topic_coef)## # A tibble: 6 x 3
## document topic gamma
## <chr> <int> <dbl>
## 1 1 1 0.00317
## 2 2 1 0.996
## 3 3 1 0.00159
## 4 4 1 0.999
## 5 5 1 0.00123
## 6 6 1 0.00395# Gráfico da mistura a partir de uma amostra.
aux <- sample_n(topic_coef, size = 150) %>%
arrange(topic, gamma) %>%
mutate(document = fct_reorder(document, row_number()))
ggplot(data = aux) +
aes(x = document,
y = gamma,
fill = factor(topic)) +
geom_col(position = "fill") +
labs(fill = "Tópico predominante") +
coord_flip()
# Os mesmos dados mas na forma wide.
topicProbs <- as.data.frame(fit@gamma)
names(topicProbs) <- paste0("T", seq_along(names(topicProbs)))
topicProbs$class <- topics(fit)
names(topicProbs)## [1] "T1" "T2" "T3" "class"# Gráfico composicional para k = 3.
if (fit@k == 3) {
ggtern(data = topicProbs,
mapping = aes(x = T1,
y = T2,
z = T3,
color = factor(class))) +
geom_point(alpha = 0.5) +
labs(color = "Tópico\npredominante") +
theme_showarrows()
}
#-----------------------------------------------------------------------
# Distribuição dos tópicos.
# Proporção dos termos nos tópicos.
terms_coef <- tidy(fit, matrix = "beta")
head(terms_coef)## # A tibble: 6 x 3
## topic term beta
## <int> <chr> <dbl>
## 1 1 abaixo 6.07e- 4
## 2 2 abaixo 9.50e-20
## 3 3 abaixo 9.83e- 4
## 4 1 abastec 1.53e-17
## 5 2 abastec 3.06e- 4
## 6 3 abastec 3.28e- 4# Os termos mais frequentes pro tópico.
topn_terms <- terms_coef %>%
group_by(topic) %>%
top_n(n = 50, wt = beta) %>%
ungroup()
topn_terms## # A tibble: 150 x 3
## topic term beta
## <int> <chr> <dbl>
## 1 3 acabamento 0.00324
## 2 1 acho 0.00317
## 3 3 acho 0.00288
## 4 1 agora 0.00288
## 5 2 agora 0.00335
## 6 1 ainda 0.00417
## 7 3 algun 0.00290
## 8 1 alto 0.00287
## 9 1 ano 0.00434
## 10 3 ano 0.00738
## # … with 140 more rows# ggplot(topn_terms) +
# aes(x = reorder(term, beta), y = beta) +
# facet_wrap(facets = ~topic, scales = "free_y", drop = FALSE) +
# geom_col() +
# coord_flip()
# Faz os gráficos em separado e retorna em lista.
pp <- topn_terms %>%
group_by(topic) %>%
do(plot = {
ggplot(.) +
aes(x = reorder(term, beta), y = beta) +
geom_col() +
labs(x = "Termos", y = "Frequência") +
coord_flip()
})
length(pp$plot)## [1] 3# Invoca a `grid.arrange()` do pacote `gridExtra`.
do.call(what = gridExtra::grid.arrange,
args = c(pp$plot, nrow = 1))
#-----------------------------------------------------------------------
# Núvem de palavras por tópico.
# Termos mais salientes.
topn_terms <- terms_coef %>%
group_by(topic) %>%
top_n(300, beta) %>%
ungroup()
i <- 0
pal <- c("Reds", "Blues", "Greens", "Purples")[1:fit@k]
oldpar <- par()
par(mfrow = c(2, 2), mar = c(0, 0, 0, 0))
topn_terms %>%
group_by(topic) %>%
do(plot = {
i <<- i + 1
wordcloud(words = .$term,
freq = .$beta,
min.freq = 1,
max.words = 300,
random.order = FALSE,
colors = tail(brewer.pal(9, pal[i]), n = 5))
})## Source: local data frame [3 x 2]
## Groups: <by row>
##
## # A tibble: 3 x 2
## topic plot
## * <int> <list>
## 1 1 <NULL>
## 2 2 <NULL>
## 3 3 <NULL>layout(1)
par(oldpar)3.5 Usando o lda
# Extrai o vetor de palavras.
v <- content(cps)
lex <- lexicalize(v)
str(lex, list.len = 4)
nTerms(dtm) # Palavras de menos de 2 digitos são excluídas.
# Frequência das palavras do vocabulário no corpus.
wc <- word.counts(lex$documents, lex$vocab)
# Para o ajuste do LDA.
set.seed(1234)
k <- 5
niter <- 40
alpha <- 0.02
eta <- 0.02
fit <- lda.collapsed.gibbs.sampler(documents = lex$documents,
K = k,
vocab = lex$vocab,
num.iterations = niter,
alpha = alpha,
eta = eta,
initial = NULL,
burnin = 0,
compute.log.likelihood = TRUE)
# Para verificar se houve convergência.
plot(fit$log.likelihoods[1, ])
# As palavras mais típicas de cada tópico.
top.topic.words(fit$topics, num.words = 10, by.score = TRUE)
# Os documentos com maior proporção em cada tópico.
top.topic.documents(fit$document_sums, num.documents = 3)
# OBS: o valor de 0.01 somado é para evitar 0 porque isso pode dar
# problema quando for chamada a função `createJSON` que internamente usa
# a *Jensen Shannon distance*. Veja a discussão:
# https://github.com/cpsievert/LDAvis/issues/56.
# Proporção de cada tópico em cada documento.
theta <- t(apply(fit$document_sums + 0.01,
MARGIN = 2,
FUN = function(x) x/sum(x)))
head(theta)
# Proporção de cada termo em cada tópico.
phi <- t(apply(fit$topics + 0.01,
MARGIN = 1,
FUN = function(x) x/sum(x)))
head(phi[, 1:4])
json_data <- createJSON(phi = phi,
theta = theta,
doc.length = document.lengths(lex$documents),
vocab = lex$vocab,
term.frequency = as.vector(wc))
serVis(json = json_data)A documentação disponível em https://cran.r-project.org/web/packages/textmineR/vignettes/c_topic_modeling.html é bastante interessante. São definidas métricas que podem ser usadas para orientar a escolha do \(k\) que são a coerência e a prevalência.
#-----------------------------------------------------------------------
# Versões dos pacotes e data do documento.
devtools::session_info()## ─ Session info ──────────────────────────────────────────────────────────
## setting value
## version R version 3.6.1 (2019-07-05)
## os Ubuntu 16.04.6 LTS
## system x86_64, linux-gnu
## ui X11
## language en_US
## collate en_US.UTF-8
## ctype pt_BR.UTF-8
## tz America/Sao_Paulo
## date 2019-12-06
##
## ─ Packages ──────────────────────────────────────────────────────────────
## package * version date lib source
## assertthat 0.2.1 2019-03-21 [3] CRAN (R 3.6.1)
## backports 1.1.4 2019-04-10 [3] CRAN (R 3.6.1)
## bayesm 3.1-4 2019-10-15 [3] CRAN (R 3.6.1)
## broom 0.5.2 2019-04-07 [3] CRAN (R 3.6.1)
## callr 3.3.1 2019-07-18 [3] CRAN (R 3.6.1)
## cellranger 1.1.0 2016-07-27 [3] CRAN (R 3.6.1)
## cli 1.1.0 2019-03-19 [3] CRAN (R 3.6.1)
## colorspace 1.4-1 2019-03-18 [3] CRAN (R 3.6.1)
## compositions 1.40-3 2019-10-25 [3] CRAN (R 3.6.1)
## crayon 1.3.4 2017-09-16 [3] CRAN (R 3.6.1)
## curl 4.0 2019-07-22 [3] CRAN (R 3.6.1)
## DEoptimR 1.0-8 2016-11-19 [3] CRAN (R 3.6.1)
## desc 1.2.0 2018-05-01 [3] CRAN (R 3.6.1)
## devtools 2.1.0 2019-07-06 [3] CRAN (R 3.6.1)
## digest 0.6.21 2019-09-20 [3] CRAN (R 3.6.1)
## dplyr * 0.8.3 2019-07-04 [3] CRAN (R 3.6.1)
## ellipsis 0.2.0.1 2019-07-02 [3] CRAN (R 3.6.1)
## evaluate 0.14 2019-05-28 [3] CRAN (R 3.6.1)
## fansi 0.4.0 2018-10-05 [3] CRAN (R 3.6.1)
## forcats * 0.4.0 2019-02-17 [3] CRAN (R 3.6.1)
## fs 1.3.1 2019-05-06 [3] CRAN (R 3.6.1)
## generics 0.0.2 2018-11-29 [3] CRAN (R 3.6.1)
## ggplot2 * 3.2.0 2019-06-16 [3] CRAN (R 3.6.1)
## ggtern * 3.1.0 2018-12-19 [3] CRAN (R 3.6.1)
## glue 1.3.1 2019-03-12 [3] CRAN (R 3.6.1)
## gridExtra 2.3 2017-09-09 [3] CRAN (R 3.6.1)
## gtable 0.3.0 2019-03-25 [3] CRAN (R 3.6.1)
## haven 2.1.1 2019-07-04 [3] CRAN (R 3.6.1)
## hms 0.5.0 2019-07-09 [3] CRAN (R 3.6.1)
## htmltools 0.4.0 2019-10-04 [3] CRAN (R 3.6.1)
## httr 1.4.0 2018-12-11 [3] CRAN (R 3.6.1)
## janeaustenr 0.1.5 2017-06-10 [3] CRAN (R 3.6.1)
## jsonlite * 1.6 2018-12-07 [3] CRAN (R 3.6.1)
## knitr * 1.23 2019-05-18 [3] CRAN (R 3.6.1)
## labeling 0.3 2014-08-23 [3] CRAN (R 3.6.1)
## latex2exp 0.4.0 2015-11-30 [3] CRAN (R 3.6.1)
## lattice 0.20-38 2018-11-04 [4] CRAN (R 3.5.1)
## lazyeval 0.2.2 2019-03-15 [3] CRAN (R 3.6.1)
## lubridate 1.7.4 2018-04-11 [3] CRAN (R 3.6.1)
## magrittr 1.5 2014-11-22 [3] CRAN (R 3.6.1)
## MASS 7.3-51.4 2019-04-26 [4] CRAN (R 3.6.1)
## Matrix 1.2-17 2019-03-22 [4] CRAN (R 3.6.1)
## memoise 1.1.0 2017-04-21 [3] CRAN (R 3.6.1)
## modelr 0.1.4 2019-02-18 [3] CRAN (R 3.6.1)
## modeltools 0.2-22 2018-07-16 [3] CRAN (R 3.6.1)
## munsell 0.5.0 2018-06-12 [3] CRAN (R 3.6.1)
## nlme 3.1-140 2019-05-12 [3] CRAN (R 3.6.1)
## NLP * 0.2-0 2018-10-18 [3] CRAN (R 3.6.1)
## pillar 1.4.2 2019-06-29 [3] CRAN (R 3.6.1)
## pkgbuild 1.0.3 2019-03-20 [3] CRAN (R 3.6.1)
## pkgconfig 2.0.2 2018-08-16 [3] CRAN (R 3.6.1)
## pkgload 1.0.2 2018-10-29 [3] CRAN (R 3.6.1)
## plyr 1.8.4 2016-06-08 [3] CRAN (R 3.6.1)
## prettyunits 1.0.2 2015-07-13 [3] CRAN (R 3.6.1)
## processx 3.4.1 2019-07-18 [3] CRAN (R 3.6.1)
## proto 1.0.0 2016-10-29 [3] CRAN (R 3.6.1)
## ps 1.3.0 2018-12-21 [3] CRAN (R 3.6.1)
## purrr * 0.3.2 2019-03-15 [3] CRAN (R 3.6.1)
## R6 2.4.0 2019-02-14 [3] CRAN (R 3.6.1)
## RColorBrewer * 1.1-2 2014-12-07 [3] CRAN (R 3.6.1)
## Rcpp 1.0.3 2019-11-08 [3] CRAN (R 3.6.1)
## readr * 1.3.1 2018-12-21 [3] CRAN (R 3.6.1)
## readxl 1.3.1 2019-03-13 [3] CRAN (R 3.6.1)
## remotes 2.1.0 2019-06-24 [3] CRAN (R 3.6.1)
## reshape2 1.4.3 2017-12-11 [3] CRAN (R 3.6.1)
## rlang 0.4.0 2019-06-25 [3] CRAN (R 3.6.1)
## rmarkdown * 1.14 2019-07-12 [3] CRAN (R 3.6.1)
## robustbase 0.93-5 2019-05-12 [3] CRAN (R 3.6.1)
## rprojroot 1.3-2 2018-01-03 [3] CRAN (R 3.6.1)
## rstudioapi 0.10 2019-03-19 [3] CRAN (R 3.6.1)
## rvest 0.3.4 2019-05-15 [3] CRAN (R 3.6.1)
## scales 1.0.0 2018-08-09 [3] CRAN (R 3.6.1)
## sessioninfo 1.1.1 2018-11-05 [3] CRAN (R 3.6.1)
## slam 0.1-45 2019-02-26 [3] CRAN (R 3.6.1)
## SnowballC 0.6.0 2019-01-15 [3] CRAN (R 3.6.1)
## stringi 1.4.3 2019-03-12 [3] CRAN (R 3.6.1)
## stringr * 1.4.0 2019-02-10 [3] CRAN (R 3.6.1)
## tensorA 0.36.1 2018-07-29 [3] CRAN (R 3.6.1)
## testthat 2.2.0 2019-07-22 [3] CRAN (R 3.6.1)
## tibble * 2.1.3 2019-06-06 [3] CRAN (R 3.6.1)
## tidyr * 0.8.3 2019-03-01 [3] CRAN (R 3.6.1)
## tidyselect 0.2.5 2018-10-11 [3] CRAN (R 3.6.1)
## tidytext * 0.2.2 2019-07-29 [3] CRAN (R 3.6.1)
## tidyverse * 1.2.1 2017-11-14 [3] CRAN (R 3.6.1)
## tm * 0.7-6 2018-12-21 [3] CRAN (R 3.6.1)
## tokenizers 0.2.1 2018-03-29 [3] CRAN (R 3.6.1)
## topicmodels * 0.2-8 2018-12-21 [3] CRAN (R 3.6.1)
## usethis 1.5.1 2019-07-04 [3] CRAN (R 3.6.1)
## utf8 1.1.4 2018-05-24 [3] CRAN (R 3.6.1)
## vctrs 0.2.0 2019-07-05 [3] CRAN (R 3.6.1)
## withr 2.1.2 2018-03-15 [3] CRAN (R 3.6.1)
## wordcloud * 2.6 2018-08-24 [3] CRAN (R 3.6.1)
## xfun 0.8 2019-06-25 [3] CRAN (R 3.6.1)
## xml2 1.2.0 2018-01-24 [3] CRAN (R 3.6.1)
## yaml 2.2.0 2018-07-25 [3] CRAN (R 3.6.1)
## zeallot 0.1.0 2018-01-28 [3] CRAN (R 3.6.1)
##
## [1] /home/walmes/R/x86_64-pc-linux-gnu-library/3.6
## [2] /usr/local/lib/R/site-library
## [3] /usr/lib/R/site-library
## [4] /usr/lib/R/librarySys.time()## [1] "2019-12-06 18:02:34 -03"
Mineração de Texto |
leg.ufpr.br/~walmes/ensino/mintex/ |