Modelagem de tópicos
Prof. Walmes Marques Zeviani
30 Maio 2017
Aplicação
- Notícias sobre a UFPR na Gazeta do Povo entre Setembro/16 e Março/17.
# Carrega notícias sobre a UFPR.
load("scripts/ufpr-news.RData")
length(ufpr)
## [1] 8305
## 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__
Carregando os recursos
library(tm)
library(SnowballC)
library(topicmodels)
library(wordcloud)
library(plyr)
library(lattice)
prepanel.pareto <- function(x, y, ...) {
yy <- y[, drop = TRUE]
list(ylim = as.character(yy),
yat = 1:nlevels(yy))
}
panel.pareto <- function(x, y, ...) {
yy <- y[, drop = TRUE]
panel.barchart(x, yy[order(yy)], ...)
}
Processamento e criação da DTM
#-----------------------------------------------------------------------
# Título das notícias.
tit <- sapply(ufpr, "[[", "str_titulo")
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 BRT" "2017-03-31 23:23:00 BRT"
#-----------------------------------------------------------------------
# Veículos.
vei <- sapply(ufpr, "[[", "str_veiculo")
tb <- sort(table(vei), decreasing = TRUE)
# head(tb)
barchart(head(tb, n = 30))
#-----------------------------------------------------------------------
# Extraindo o conteúdo das notícias.
L <- sapply(ufpr, FUN = "[", "conteudo_texto")
L <- unlist(L)
# L[1:2]
#-----------------------------------------------------------------------
# Cria o corpus.
cps <- VCorpus(VectorSource(x = L),
readerControl = list(language = "pt"))
# Confere os tamanhos.
length(cps) == length(vei)
## [1] TRUE
#-----------------------------------------------------------------------
# Adiciona os metadados.
# É necessário que seja "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.
# meta(cps[[5]])
# meta(cps[[5]], tag = "veiculo")
# meta(cps[[5]], tag = "ts")
# Filtra para os documentos pelo valor de 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
veiculo e dos conteúdos das notícias L.
- 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 <- tm_map(cps2, FUN = content_transformer(tolower))
cps2 <- tm_map(cps2, FUN = removePunctuation)
cps2 <- tm_map(cps2, FUN = removeNumbers)
cps2 <- tm_map(cps2, FUN = removeWords, words = stopwords("portuguese"))
cps2 <- tm_map(cps2, FUN = stemDocument, language = "portuguese")
cps2 <- tm_map(cps2, FUN = stripWhitespace)
# sapply(cps2[1:2], content)
# Para fazer modelagem de tópicos, requer podenração term-frequency.
dtm <- DocumentTermMatrix(cps2)
dtm
## <<DocumentTermMatrix (documents: 516, terms: 21421)>>
## Non-/sparse entries: 128969/10924267
## Sparsity : 99%
## Maximal term length: 30
## Weighting : term frequency (tf)
# Termos de maior intensidade.
frq <- slam::colapply_simple_triplet_matrix(dtm, FUN = sum)
frq <- sort(frq, decreasing = TRUE)
# Gráfico de pareto.
barchart(head(frq, n = 60), xlim = c(0, NA))
# Remoção de esparsidade.
rst <- removeSparseTerms(x = dtm, sparse = 0.95)
rst
## <<DocumentTermMatrix (documents: 516, terms: 995)>>
## Non-/sparse entries: 63848/449572
## Sparsity : 88%
## Maximal term length: 15
## Weighting : term frequency (tf)
Modelagem de tópicos
# Documentação da principal função.
# help(LDA, help_type = "html")
# Essa função requer ponderação padrão: term frequency.
lda <- LDA(x = dtm, k = 3)
lda
## A LDA_VEM topic model with 3 topics.
# Classe, métodos e estrutura.
class(lda)
## [1] "LDA_VEM"
## attr(,"package")
## [1] "topicmodels"
methods(class = class(lda))
## [1] logLik perplexity posterior show terms
## [6] topics
## see '?methods' for accessing help and source code
# str(lda)
# Termos principais que são por default usados para rotular tópicos.
terms(lda)
## Topic 1 Topic 2 Topic 3
## "ufpr" "ser" "ano"
# get_terms(lda)
# Índice que separa os documento no tópico predominante.
table(topics(lda))
##
## 1 2 3
## 138 216 162
# table(get_topics(lda))
# Valor da log-verossimilhança.
logLik(lda)
## 'log Lik.' -671440.1 (df=2986)
# Os termos (em ordem alfabética).
c(head(lda@terms), tail(lda@terms))
## [1] "abaixo" "aberta" "aberto" "abrir" "acaba" "acabar"
## [7] "volta" "voltar" "vontad" "votação" "voto" "zaki"
# Fração de cada tópico por documento (a soma é 1).
head(rowSums(lda@gamma))
## [1] 1 1 1 1 1 1
# Log da fração de cada termo em cada documento (a soma é 1).
rowSums(exp(lda@beta))
## [1] 1 1 1
Distribuição de termos por tópico
# Os termos e suas log-probs em cada tópico.
words <- as.data.frame(t(lda@beta))
names(words) <- terms(lda)
words <- cbind(term = lda@terms, words, stringsAsFactors = FALSE)
str(words)
## 'data.frame': 995 obs. of 4 variables:
## $ term: chr "abaixo" "aberta" "aberto" "abrir" ...
## $ ufpr: num -12.11 -11.26 -12.29 -8.11 -17.52 ...
## $ ser : num -9.92 -8.6 -8.11 -8.28 -7.37 ...
## $ ano : num -7.03 -6.98 -7.05 -8.14 -8.85 ...
# Filtrando para as que ocorrem mais em cada tópico.
k <- 30
tops <- lapply(words[, terms(lda)],
FUN = function(x) {
o <- head(order(x, decreasing = TRUE), n = k)
data.frame(term = words$term[o],
lprob = x[o])
})
tops <- ldply(tops, .id = "topic")
str(tops)
## 'data.frame': 90 obs. of 3 variables:
## $ topic: Factor w/ 3 levels "ufpr","ser","ano": 1 1 1 1 1 1 1 1 1 1 ...
## $ term : chr "ufpr" "estudant" "universidad" "prédio" ...
## $ lprob: num -3.65 -3.94 -4.09 -4.25 -4.27 ...
# Gráfico de pareto.
barchart(term ~ lprob | topic,
data = tops,
ylab = "Termos mais frequentes em cada tópico",
xlab = "log da probabilidade de cada termo no tópico",
scales = "free",
layout = c(NA, 1),
prepanel = prepanel.pareto,
panel = panel.pareto)
- Note que a palavra “professor” aparece nos 3 tópicos.
- “universidad” e “ufpr” aparece em dois tópicos.
Núvem de palavras
# display.brewer.all()
par(mfrow = c(1, length(terms(lda))))
sapply(terms(lda),
FUN = function(t) {
wordcloud(words = words$term,
freq = 100 * exp(words[, t]),
max.words = 100,
random.order = FALSE,
family = "Lato",
colors = tail(brewer.pal(7, "Purples"), 5))
title(main = t, line = -4)
})
## $`Topic 1`
## NULL
##
## $`Topic 2`
## NULL
##
## $`Topic 3`
## NULL
Distribuição cronológica dos tópicos
ts <- sapply(cps2, meta, tag = "ts")
ts <- as.POSIXct(ts)
ser <- as.data.frame(lda@gamma)
names(ser) <- terms(lda)
ser <- cbind(ts = ts, ser)
str(ser)
## 'data.frame': 516 obs. of 4 variables:
## $ ts : POSIXct, format: "2016-09-05 18:20:00" ...
## $ ufpr: num 0.0454 0.0454 0.29158 0.10426 0.00294 ...
## $ ser : num 0.73888 0.73888 0.70782 0.00124 0.37501 ...
## $ ano : num 0.215713 0.215713 0.000597 0.894495 0.622057 ...
xyplot(as.formula(paste(paste(terms(lda), collapse = " + "), "~ ts")),
data = ser,
lwd = 2,
auto.key = list(title = "Tópico",
cex.title = 1),
type = c("p", "smooth"),
ylab = "Proporção de cada tópico",
xlab = "Data",
span = 1/4,
evaluation = 512)
Títulos das notícias
tit <- sapply(cps2, meta, tag = "titulo")
tit <- split(tit, topics(lda))
# Uma amostra aleatória de títulos em cada tópico.
lapply(tit, FUN = function(x) {
cat("--------------------------------------------------\n")
cat(sample(x, size = 20), sep = "\n")
})
## --------------------------------------------------
## Por causa das ocupações, ano letivo de 2016 da UFPR se estende até fevereiro do ano que vem
## Ocupação na UFPR chega ao Politécnico; paralisação de alunos e servidores segue
## Grupo de mascarados ocupa Santos Andrade com quebra-quebra e violência
## Nove prédios estão ocupados na UFPR; no Centro Politécnico, são três
## Vice-reitora é uma das investigadas pela PF no desvio de bolsas na UFPR
## Greve de servidores do HC afeta banco de sangue e agendamento de consultas
## Em reunião fechada, UFPR estuda medidas para garantir 2.ª fase do vestibular
## Manifestantes dizem que só saem com a polícia e invasão na UTFPR continua
## Servidores da UFPR e do Hospital de Clínicas aprovam paralisação de três dias
## UFPR divulga ensalamento do vestibular 2016/2017 nesta terça (18)
## Estudantes ignoram a Justiça e invasão da UTFPR vai para o segundo dia
## Centro tem dia de comércio cheio e protestos esvaziados
## Em reunião com estudantes, UFPR pede desocupação imediata e negociação pacífica
## Manifestantes decidem manter invasão na UTFPR e aulas são suspensas
## Resolução sobre jubilamento é uma das pautas dos estudantes que ocupam prédios da UFPR; entenda
## Ocupações perdem força na região de colégio onde menino foi encontrado morto
## Após manhã tensa, reitoria ameaça pedir reintegração do prédio histórico
## UFPR divulga locais de prova da 2ª fase do vestibular
## PF cumpre reintegração de posse e retira manifestantes do prédio da UTFPR
## Após negociação, invasores deixam prédio histórico da UFPR
## --------------------------------------------------
## América Latina dá uma guinada à direita
## Como o “monopólio” dos sindicatos pode travar a educação no Brasil
## Governo Temer
## Exército inicia ação no RJ na 67ª Operação de Garantia da Ordem em 10 anos no país
## “A realização de concurso para servidores de 1.º grau é medida que se impõe”
## Melhora da educação não depende só de mais dinheiro, diz economista
## A perigosa atualidade da pergunta de Garrett
## Deputados empacam em projeto que nem proíbe nem libera Uber
## Desmonte programado
## O gás do Paraná
## Os mistérios da roda fixa
## Cabeleireiro recebia ‘bolsa’ maior do que de professor no esquema de desvio da UFPR
## Ministro da Justiça de Temer é apontado como favorito para a vaga de Teori
## Especialistas veem risco em negociar registro de ponto na reforma trabalhista
## TCU acusa pedalada do governo para esconder dívida de R$ 3,1 bilhões no Fies
## Ex-reitor da UFPR?é intimado a prestar depoimento à PF?sobre desvios de recursos
## Tentativas de fraudes no sistema de cotas vão além do vestibular
## Temer 1
## “A violência não faz parte do nosso movimento”, diz líder do MBL
## Sigilo da fonte e garantia constitucional
## --------------------------------------------------
## Com contratação de novos funcionários, Hospital de Clínicas irá reabrir 20 leitos de UTI
## Curitiba precisa de “SUS animal” e educação, não de hospital veterinário
## Alunos de escola pública do PR levam 1.º lugar em feira por projeto de rede de pesca sustentável
## Pesquisa da UFPR recruta idosas com fraqueza, cansaço e lentidão ao caminhar
## Em carta, Greca se compromete a criar “ecossistema de inovação” em Curitiba
## Uma chance para que jovens desenvolvam seus talentos
## Sexta é dia de maldade? Não! É dia de cinema, teatro e boa música. Veja os horários
## Ney Regattieri do Nascimento: o médico que sempre honrou o juramento
## Veja os destaques da programação cultural desta segunda
## Do Boqueirão à disputa do Nobel: a trajetória do físico curitibano Celso Grebogi
## Quão respirável está o ar de Curitiba
## Cientista curitibano está entre os cotados para o Nobel de Física
## Universidade privada dos EUA é gratuita para renda de até R$ 400 mil por ano
## Principal rua de Madri será fechada para os carros
## Redação do vestibular da UFPR exige boa gestão do tempo
## Fim de semana de calorão no litoral. Mas fique atento aos bloqueios nas estradas do PR e SC
## Ameaça ao patrimônio espeleológico do Paraná
## A?educação a distância não é mais o patinho feio do ensino superior
## Curitiba quer criar Rua da Cerveja, mas por que não uma Rua da Literatura?
## Não basta saber ler, é preciso entender
## $`1`
## NULL
##
## $`2`
## NULL
##
## $`3`
## NULL
