Week15: 토픽 모델링 II
Shin Lee
2021/6/9
R을 이용한 토픽모델링
여성에 대한 미디어 담론 분석
1990년부터 현재까지 여성 담론 주제 변화 추적
빅카인즈 중앙지 기사 중 헤드라인에 “여성” 혹은 “여자” 키워드 포함 기사 131534여건 분석
1. 코퍼스 준비
library(tidyverse)## -- Attaching packages --------------------------------------- tidyverse 1.3.0 --## v ggplot2 3.3.3 v purrr 0.3.4
## v tibble 3.1.0 v dplyr 1.0.4
## v tidyr 1.1.2 v stringr 1.4.0
## v readr 1.3.1 v forcats 0.5.1## -- Conflicts ------------------------------------------ tidyverse_conflicts() --
## x dplyr::filter() masks stats::filter()
## x dplyr::lag() masks stats::lag()load("female_news.RData")
female_news## # A tibble: 18,083 x 5
## date company headline keyword text
## <date> <chr> <chr> <chr> <chr>
## 1 2021-05-07 YTN "집행 유예 기간에 9차례 절도..~ 기간,집행,유예,9차례,교도소행,~ "보호관찰 기간에 절도 등의 ~
## 2 2021-05-07 YTN "경찰, 마취 덜 풀린 여성 환자 ~ 경찰,마취,추행,여성,환자,병원,~ "경기 의정부시의 한 대형 병~
## 3 2021-05-07 YTN "서울 학교와 전국 여성 아동 노인~ 서울,학교,전국,여성,아동,노인시~ "서울지역 학교와 전국 여성과~
## 4 2021-05-07 YTN "'1호가' 이휘재 \"탈모약 부작~ 1호,부작용,이휘재,탈모약,아내,~ "'1호가 될 순 없어'에서 ~
## 5 2021-05-07 YTN "학교 행사서 '여왕' 되려 투표 ~ 학교,행사,여왕,투표,조작,여성,~ "미국의 고등학교 홈커밍 행사~
## 6 2021-05-07 SBS "벽돌로, 흉기로 또 아시아계 여성~ 벽돌,흉기,피습,아시아,여성,앵커~ "<앵커> \n\n \n\n미~
## 7 2021-05-06 KBS "[빅뉴스] “코로나 일자리 충격 ~ 코로나,일자리,충격,남성,자녀,여~ "키워드로 뉴스를 살펴보는 빅~
## 8 2021-05-06 KBS "샌프란시스코서 아시아계 여성 흉기~ 샌프란시스코,아시아,여성,흉기,피~ "[앵커]\n\n지난 3월 애~
## 9 2021-05-06 SBS "벽돌로 치고 흉기로 찌르고 또 아~ 벽돌,흉기,피습,아시아,여성,앵커~ "<앵커> \n\n \n\n미~
## 10 2021-05-06 OBS "코로나19 고용 충격, 여성이 남~ 충격,코로나19,고용,여성,남성,~ "코로나19 사태로 여성이 남~
## # ... with 18,073 more rowsView(female_news)female_news %>%
count(date) %>%
arrange(date) %>%
ggplot(aes(date, n)) +
geom_col() +
scale_x_date(name="날짜", date_labels = "%Y-%m-%d") +
ylab("")+
ggtitle("여성 관련 보도량 추이",
subtitle="국내 방송사")
WHY STM?
“The goal of the structural topic model (STM) is to allow researchers to discover topics and estimate their relationship to document metadata. Outputs of the model can be used to conduct hypothesis testing about these relationships. This of course mirrors the type of analysis that social scientists perform with other types of data, where the goal is to discover relationships between variables and test hypotheses” (Roberts, Stewart, & Tingley, 2019, p. 2 “stm: An R Package for Structural Topic Models”).
“The document generative process highlights the case where topical prevalence and topical content can be a function of document metadata. Topical prevalence refers to how much of a document is associated with a topic and topic content refers to the words used within a topic” (Roberts et al., 2019, p. 2)
Estimating the structural topic model
“The key innovation of the STM is that it incorporates metadata into the topic modeling framework. In STM, metadata can be entered into the topic model in two ways: topical prevalence and topical content. Metadata covariates for topical prevalence allow the observed metadata to affect the frequency with which a topic is discussed. Covariates in topical content allow the observed metadata to affect the word rate use within a given topic - that is, how a particular topic is discussed” (Roberts et al., 2019, p. 8)
2. 텍스트 전처리 및 메타데이터 결합
library(stm)## stm v1.3.6 successfully loaded. See ?stm for help.
## Papers, resources, and other materials at structuraltopicmodel.comlibrary(furrr)## Loading required package: futurelibrary(future.apply)
plan(multicore)
female_news$keyword[1]## [1] "기간,집행,유예,9차례,교도소행,여성,교도,소행,보호,관찰,기간,절도,범죄,여성,법원,집행,유예,취소,법무부,의정부,보호,관찰소,보험사기,절도,혐의,47살,집행,유예,취소,신청,대법원,2018년,법원,징역형,집행유예,선고,집행,유예,기간,9차례,절도,이사,지역,보호,관찰소,신고,확인,취소,집행,유예,원래,선고,8개월,징역,수감생활,동시,보호,관찰,기간,범죄,처벌"female_news <- female_news %>%
mutate(keyword= future_sapply(keyword, function(x){
str_replace_all(x, ",", " ")
}))
female_news$keyword[1]## 기간,집행,유예,9차례,교도소행,여성,교도,소행,보호,관찰,기간,절도,범죄,여성,법원,집행,유예,취소,법무부,의정부,보호,관찰소,보험사기,절도,혐의,47살,집행,유예,취소,신청,대법원,2018년,법원,징역형,집행유예,선고,집행,유예,기간,9차례,절도,이사,지역,보호,관찰소,신고,확인,취소,집행,유예,원래,선고,8개월,징역,수감생활,동시,보호,관찰,기간,범죄,처벌
## "기간 집행 유예 9차례 교도소행 여성 교도 소행 보호 관찰 기간 절도 범죄 여성 법원 집행 유예 취소 법무부 의정부 보호 관찰소 보험사기 절도 혐의 47살 집행 유예 취소 신청 대법원 2018년 법원 징역형 집행유예 선고 집행 유예 기간 9차례 절도 이사 지역 보호 관찰소 신고 확인 취소 집행 유예 원래 선고 8개월 징역 수감생활 동시 보호 관찰 기간 범죄 처벌"library(lubridate)##
## Attaching package: 'lubridate'## The following objects are masked from 'package:base':
##
## date, intersect, setdiff, unionfemale_news <- female_news %>%
mutate(year = floor_date(date, unit="years"))
year_df <- female_news %>%
count(year) %>%
arrange(year) %>%
rowid_to_column() %>%
select(-n)
female_news <- female_news %>%
left_join(year_df, by="year") %>%
select(-year) %>%
rename(yid = rowid)
processed <- textProcessor(female_news$keyword,
metadata = female_news,
wordLengths = c(1, Inf),
lowercase = FALSE,
removestopwords = FALSE,
stem = FALSE,
removepunctuation = TRUE,
ucp= TRUE,
custompunctuation = c("’","“","『"),
removenumbers = FALSE,
language = "na")## Building corpus...
## Removing punctuation...
## Removing custom punctuation...
## Creating Output...length(processed$vocab)## [1] 86769out <- prepDocuments(processed$documents,
processed$vocab,
processed$meta,
lower.thresh = length(female_news$keyword)*0.001,
upper.thresh = length(female_news$keyword)*0.99)## Removing 79875 of 86769 terms (211861 of 1008177 tokens) due to frequency
## Your corpus now has 18083 documents, 6894 terms and 796316 tokens.length(out$vocab)## [1] 6894save(out, file="out.RData")
load("out.RData")
docs <- out$documents
vocab <- out$vocab
meta <- out$meta3. 구조화
library(tidytext)
female_tidy <- female_news %>%
rowid_to_column() %>%
unnest_tokens(word, keyword)## Warning: Outer names are only allowed for unnamed scalar atomic inputsfemale_word_doc <- female_tidy %>%
filter(word %in% vocab) %>%
count(rowid, word, sort=T)
female_dtm <- female_word_doc %>%
cast_dtm(document=rowid, term=word, value=n)
female_dtm## <<DocumentTermMatrix (documents: 18083, terms: 6365)>>
## Non-/sparse entries: 795413/114302882
## Sparsity : 99%
## Maximal term length: 11
## Weighting : term frequency (tf)save(female_dtm, file="female_dtm.RData")
load("female_dtm.RData")4. 모델링
library(ldatuning)
models <- FindTopicsNumber(dtm = female_dtm,
topics = seq(5,50,5),
return_models = T,
control = list(seed = 210507))
save(models, file="models.RData")library(ldatuning)## Warning: package 'ldatuning' was built under R version 4.0.5load("models.RData")
FindTopicsNumber_plot(models)
4-1. Estimation with topical prevalence parameter We will use the ‘yid’ variable (year id) as a covariate in the topic prevalence portion of the model. “Each document is a mixture of multiple topics. Topical prevalence captures how much each topic contributes to a document. Because different documents come from different sources, it is natural to want to allow this prevalence to vary with metadata that we have about document sources” (Roberts et al., 2019, p. 8).
femalePrevFit <- stm(documents = out$documents, vocab = out$vocab,
K = 40, prevalence =~ s(yid), max.em.its = 75,
data = out$meta, init.type = "Spectral")
save(femalePrevFit, file="femalePrevFit.RData")load("femalePrevFit.RData")
femalePrevFit## A topic model with 40 topics, 18083 documents and a 6894 word dictionary.4. 해석하기
td_beta <- tidy(femalePrevFit)
td_beta## # A tibble: 275,760 x 3
## topic term beta
## <int> <chr> <dbl>
## 1 1 000만 1.10e-102
## 2 2 000만 3.58e- 48
## 3 3 000만 1.43e-103
## 4 4 000만 8.15e- 4
## 5 5 000만 3.71e- 27
## 6 6 000만 1.18e- 68
## 7 7 000만 3.91e- 5
## 8 8 000만 7.91e-101
## 9 9 000만 1.15e- 65
## 10 10 000만 1.18e- 94
## # ... with 275,750 more rowstd_beta %>% arrange(desc(beta)) %>% group_by(topic)## # A tibble: 275,760 x 3
## # Groups: topic [40]
## topic term beta
## <int> <chr> <dbl>
## 1 2 여자 0.551
## 2 2 남자 0.274
## 3 40 앵커 0.273
## 4 15 여성 0.202
## 5 13 한국 0.186
## 6 29 미국 0.171
## 7 40 인터뷰 0.160
## 8 8 출산 0.147
## 9 13 일본 0.134
## 10 12 여성 0.134
## # ... with 275,750 more rowstd_beta %>% group_by(topic) %>% slice_max(beta, n=5)## # A tibble: 200 x 3
## # Groups: topic [40]
## topic term beta
## <int> <chr> <dbl>
## 1 1 운전 0.108
## 2 1 사우디 0.104
## 3 1 허용 0.0500
## 4 1 이슬람 0.0461
## 5 1 사우디아라비아 0.0369
## 6 2 여자 0.551
## 7 2 남자 0.274
## 8 2 남자들 0.0168
## 9 2 만화 0.00990
## 10 2 박은혜 0.00973
## # ... with 190 more rowstd_gamma <- tidy(femalePrevFit, matrix = "gamma",
document_names = rownames(female_dtm))
td_gamma %>% arrange(desc(gamma))## # A tibble: 723,320 x 3
## document topic gamma
## <chr> <int> <dbl>
## 1 6434 39 0.983
## 2 6439 39 0.983
## 3 9795 3 0.982
## 4 16064 17 0.982
## 5 7583 14 0.981
## 6 7858 14 0.981
## 7 17141 17 0.980
## 8 6141 4 0.980
## 9 7484 14 0.980
## 10 10479 26 0.979
## # ... with 723,310 more rowsgamma_df <- td_gamma %>% group_by(topic) %>% arrange(desc(gamma)) %>% mutate(document=as.integer(document))
gamma_df## # A tibble: 723,320 x 3
## # Groups: topic [40]
## document topic gamma
## <int> <int> <dbl>
## 1 6434 39 0.983
## 2 6439 39 0.983
## 3 9795 3 0.982
## 4 16064 17 0.982
## 5 7583 14 0.981
## 6 7858 14 0.981
## 7 17141 17 0.980
## 8 6141 4 0.980
## 9 7484 14 0.980
## 10 10479 26 0.979
## # ... with 723,310 more rowsVisualization of beta
Interpretation of topics
td_beta %>%
group_by(topic) %>%
slice_max(beta, n=7) %>%
ungroup %>%
arrange(topic, -beta) %>%
mutate(term = reorder_within(term, beta, topic)) %>%
filter(topic %in% 1:4) %>%
ggplot(aes(beta, term, fill = factor(topic))) +
geom_col(show.legend = FALSE) +
facet_wrap(~ topic, scales = "free") +
scale_y_reordered()
female_news %>%
select(date, company, headline) %>%
rowid_to_column(var="document") %>%
left_join(gamma_df, by="document") %>%
group_by(topic) %>%
slice_max(gamma, n=1, with_ties = FALSE) %>%
ungroup %>%
arrange(desc(gamma)) %>%
select(-c(document))## # A tibble: 40 x 5
## date company headline topic gamma
## <date> <chr> <chr> <int> <dbl>
## 1 2017-09-21 YTN "사우디, 스포츠 경기장에 여성 입장 첫 허용" 39 0.983
## 2 2015-10-28 MBC "'여성 몰카 사진 찍어 공유' 인터넷 카페 회원 56명 입건"~ 3 0.982
## 3 2008-10-23 MBC "2008 세계여성포럼 폐막" 17 0.982
## 4 2017-01-16 YTN "피해 여성이 대만 택시가 권한 음료수를 마신 이유"~ 14 0.981
## 5 2017-12-06 YTN "나문희, 트로피 하나 더 추가.. 올해의 여성영화인상 수상"~ 4 0.980
## 6 2015-06-11 YTN "[*메르스] 삼성서울병원 응급실 감염 50대 여성 사망"~ 26 0.979
## 7 2017-08-06 YTN "\"여성혐오 범죄 그만\" 강남역에서 집회 열려" 25 0.972
## 8 2019-05-16 YTN "서천에서 여성 살해 후 분신...경찰 2명도 화상" 35 0.966
## 9 2007-12-21 MBC "고급승용차 탄 여성 납치, 강도 일당 검거" 22 0.962
## 10 2013-10-05 MBC "마포대교서 20대 여성 투신했다 구조...평소 우울증 앓아"~ 31 0.961
## # ... with 30 more rowstd_beta## # A tibble: 275,760 x 3
## topic term beta
## <int> <chr> <dbl>
## 1 1 000만 1.10e-102
## 2 2 000만 3.58e- 48
## 3 3 000만 1.43e-103
## 4 4 000만 8.15e- 4
## 5 5 000만 3.71e- 27
## 6 6 000만 1.18e- 68
## 7 7 000만 3.91e- 5
## 8 8 000만 7.91e-101
## 9 9 000만 1.15e- 65
## 10 10 000만 1.18e- 94
## # ... with 275,750 more rowstop_terms <- td_beta %>%
arrange(beta) %>%
group_by(topic) %>%
slice_max(beta, n=7) %>%
arrange(-beta) %>%
select(topic, term) %>%
summarise(terms = list(term)) %>%
mutate(terms = map(terms, paste, collapse = ", ")) %>%
unnest()## Warning: `cols` is now required when using unnest().
## Please use `cols = c(terms)`top_terms## # A tibble: 40 x 2
## topic terms
## <int> <chr>
## 1 1 운전, 사우디, 허용, 이슬람, 사우디아라비아, 자동차, 복장
## 2 2 여자, 남자, 남자들, 만화, 박은혜, 구두, 남녀
## 3 3 여성, 검찰, 성폭행, 수사, 조사, 주장, 경찰
## 4 4 여자친구, 여자, 아이들, 친구, 공개, 가수, 그룹
## 5 5 여성, 기업, 일자리, 취업, 정부, 임원, 고용
## 6 6 대통령, 장관, 여성, 정부, 청와대, 임명, 인사
## 7 7 촬영, 화장실, 여성, 사진, 인터넷, 카메라, 신체
## 8 8 출산, 육아, 경력, 단절, 임신, 합격자, 시험
## 9 9 혐의, 성폭행, 여성, 선고, 기소, 징역, 재판
## 10 10 아들, 어머니, 아버지, 학대, argWidth, 여성, 입양
## # ... with 30 more rowslibrary(scales)##
## Attaching package: 'scales'## The following object is masked from 'package:purrr':
##
## discard## The following object is masked from 'package:readr':
##
## col_factorgamma_terms <- td_gamma %>%
group_by(topic) %>%
summarise(gamma = mean(gamma)) %>%
arrange(desc(gamma)) %>%
left_join(top_terms, by = "topic") %>%
mutate(topic = paste0("Topic ", topic),
topic = reorder(topic, gamma))
gamma_terms## # A tibble: 40 x 3
## topic gamma terms
## <fct> <dbl> <chr>
## 1 Topic 21 0.0663 경찰, 여성, 살해, 혐의, 범행, 조사, 흉기
## 2 Topic 31 0.0613 여성, 사고, 경찰, 택시, 병원, 구조, 조사
## 3 Topic 26 0.0523 여성, 환자, 건강, 위험, 결과, 남성, 치료
## 4 Topic 12 0.0467 여성, 남성, 조사, 비율, 결과, 증가, 평균
## 5 Topic 19 0.0435 여성, 경찰, 남성, 폭행, 신고, 사건, 피해
## 6 Topic 9 0.0429 혐의, 성폭행, 여성, 선고, 기소, 징역, 재판
## 7 Topic 25 0.0398 발견, 시신, 여성, 실종, 경찰, 확인, 추정
## 8 Topic 20 0.0310 여성, 성매매, 경찰, 혐의, 감금, 중국, 구속
## 9 Topic 34 0.0306 여성, 납치, 서울, 범행, 강도, 주차장, 혼자
## 10 Topic 17 0.0303 여성, 환자, 코로나19, 감염, 병원, 판정, 확진
## # ... with 30 more rows# 21, 31, 26, 12, 19, 25, 9, 34, 17, 20, 5, 23, 3, 38, 15, 39, 33, 30, 18, 11, 6, 7, 16, 22, 24, 4, 27, 29, 35, 14, 36, 10, 13, 8, 1 Surveying prevalent topics
names(femalePrevFit)## [1] "mu" "sigma" "beta" "settings" "vocab"
## [6] "convergence" "theta" "eta" "invsigma" "time"
## [11] "version"td_gamma %>%
group_by(topic) %>%
summarise(mean = mean(gamma)) %>%
ungroup %>%
arrange(desc(mean)) %>%
filter(mean >= 0.015)## # A tibble: 29 x 2
## topic mean
## <int> <dbl>
## 1 21 0.0663
## 2 31 0.0613
## 3 26 0.0523
## 4 12 0.0467
## 5 19 0.0435
## 6 9 0.0429
## 7 25 0.0398
## 8 20 0.0310
## 9 34 0.0306
## 10 17 0.0303
## # ... with 19 more rowstop_topics <- td_gamma %>%
group_by(topic) %>%
summarise(mean = mean(gamma)) %>%
ungroup %>%
arrange(desc(mean)) %>%
pull(topic)
length(top_topics)## [1] 40plot(femalePrevFit, type="summary", xlim=c(0,.3))
Visualizing the estimates
#install.packages("remotes")
#remotes::install_github("mikaelpoul/tidystm")
library(stm)
library(tidystm)
top_topics## [1] 21 31 26 12 19 9 25 20 34 17 37 5 30 23 15 28 3 39 38 33 18 11 7 6 16
## [26] 27 22 24 4 29 35 32 14 36 40 13 2 8 10 1prep <- estimateEffect(1:40 ~ s(yid), femalePrevFit, meta=out$meta,
uncertainty="Global")
summary(prep, topics=5)##
## Call:
## estimateEffect(formula = 1:40 ~ s(yid), stmobj = femalePrevFit,
## metadata = out$meta, uncertainty = "Global")
##
##
## Topic 5:
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 0.051260 0.009643 5.316 1.07e-07 ***
## s(yid)1 -0.005942 0.020256 -0.293 0.769262
## s(yid)2 -0.019140 0.011653 -1.643 0.100501
## s(yid)3 -0.032679 0.010890 -3.001 0.002695 **
## s(yid)4 -0.020116 0.010785 -1.865 0.062172 .
## s(yid)5 -0.041365 0.011054 -3.742 0.000183 ***
## s(yid)6 -0.018246 0.010959 -1.665 0.095951 .
## s(yid)7 -0.021612 0.012176 -1.775 0.075918 .
## s(yid)8 -0.035449 0.014101 -2.514 0.011950 *
## s(yid)9 -0.025726 0.016151 -1.593 0.111209
## s(yid)10 0.004509 0.011274 0.400 0.689200
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1# 2, 3, 4, 5, 6, 7, 9, 11, 14, 15, 17, 18, 19, 20, 21, 22, 23, 24, 25
# 26, 27, 29, 32, 33, 34, 37, 39, 40
# 21, 31, 26, 12, 19, 25, 9, 34, 17, 20, 5, 23, 3, 38, 15, 39, 33, 30, 18, 11, 6, 7, 16, 22, 24, 4, 27, 29, 35, 14, 36, 10, 13, 8, 1
# increase: 3, 4, 7, 9, 11, 14, 17, 18, 19, 21, 23, 25, 39
# 21, 31, 26, 12, 19, 25, 9, 34, 17, 20, 5, 23, 3, 38, 15, 39, 33, 30, 18, 11, 6 (gamma > 0.2)
# increase: 9, 11, 17, 18, 19, 21, 25, 39
# decrease: 26, 34, 20, 5, 23, 15, 33labelTopics(femalePrevFit, sort(c(26, 34, 20, 15, 33)))## Topic 15 Top Words:
## Highest Prob: 여성, 세계, 여성들, 행사, 인권, 할머니, 운동
## FREX: 운동가, 세계, 독립, 이란, 수상자, 행사, 할머니
## Lift: 노벨, 독립운동, 평화상, 종군, 각국, 기념행사, 유네스코
## Score: 세계, 종군, 운동가, 여성, 인권, 유엔, 이란
## Topic 20 Top Words:
## Highest Prob: 여성, 성매매, 경찰, 혐의, 감금, 중국, 구속
## FREX: 성매매, 업소, 감금, 업주, 알선, 사기, 단속
## Lift: 브로커, 업주들, 윤락, 18년, 미끼, 성매매, 성매매업소
## Score: 성매매, 감금, 업소, 혐의, 알선, 경찰, 업주
## Topic 26 Top Words:
## Highest Prob: 여성, 환자, 건강, 위험, 결과, 남성, 치료
## FREX: 흡연, 호르몬, 연구팀, 통증, 골다공증, 폐경, 섭취
## Lift: 갑상선암, 고관절, 골밀도, 나윤숙, 분비, 섭취량, 식생활
## Score: 환자, 유방암, 골다공증, 호르몬, 폐경, 연구팀, 폐경기
## Topic 33 Top Words:
## Highest Prob: 여성, 여성들, 사회, 생각, 남성, 시대, 대학
## FREX: 시대, 편견, 농촌, 공부, 미래, 박사, 능력
## Lift: 김현경, 김지영, 공학, 지휘자, 노벨상, 잠재력, 페미니즘
## Score: 여성들, 시대, 사회, 여성, 김현경, 교수, 지휘자
## Topic 34 Top Words:
## Highest Prob: 여성, 납치, 서울, 범행, 강도, 주차장, 혼자
## FREX: 주차장, 오토바이, 강도, 가방, 금품, 현금, 납치
## Lift: 강도짓, 날치기, 강도행각, 소매치기, 유괴, 인출기, 주차장
## Score: 납치, 주차장, 범행, 금품, 가방, 유괴, 강도decrease_topics <- estimateEffect(sort(c(26, 34, 20, 15, 33)) ~ s(yid), femalePrevFit, meta=out$meta,
uncertainty="Global")
decrease_fit <- extract.estimateEffect(x= decrease_topics, covariate = "yid",
method = "continuous",
model = femalePrevFit,
labeltype = "prob",
n = 10, ci.level = 0.95)
library(ggthemes)
female_years <- female_news %>% mutate(year=floor_date(date, "years")) %>% filter(!duplicated(yid))
decrease_fit %>%
ggplot(aes(x = covariate.value, y = estimate,
color = as.factor(topic), group = as.factor(topic),
ymin = ci.lower, ymax = ci.upper)) +
geom_line() +
geom_ribbon(aes(fill=as.factor(topic)),linetype=0, alpha = 0.1, show.legend = FALSE) +
scale_color_discrete(name = "FREX: 각 토픽에서 빈번하지만 독점적으로 등장하는 단어들",
labels=c("여성운동: 운동가, 세계, 독립, 이란, 수상자, 행사, 할머니",
"성매매: 성매매, 업소, 감금, 업주, 알선, 사기, 단속",
"건강: 흡연, 호르몬, 연구팀, 통증, 골다공증, 폐경, 섭취",
"계몽: 시대, 편견, 농촌, 공부, 미래, 박사, 능력",
"범죄: 주차장, 오토바이, 강도, 가방, 금품, 현금, 납치")) +
scale_x_continuous("Year", breaks=seq(5,25,5),
labels = sort(year(female_years$year))[seq(5,25,5)]) +
scale_y_continuous(limits=c(-0.35,0.35)) +
ggtitle("여성 관련 토픽 중 비중이 점차 감소해온 5개 토픽",
subtitle = "95% 신뢰구간") +
theme_gdocs()
labelTopics(femalePrevFit, c(9, 11, 17, 18, 19, 21, 25, 39))## Topic 9 Top Words:
## Highest Prob: 혐의, 성폭행, 여성, 선고, 기소, 징역, 재판
## FREX: 선고, 재판부, 징역, 기소, 유예, 재판, 추행
## Lift: 40시간, 원심, 유예, 피고인들, 2심, 재판부, 항소심
## Score: 혐의, 선고, 성폭행, 징역, 기소, 재판부, 재판
## Topic 11 Top Words:
## Highest Prob: 범죄, 여성, 피해자, 피해, 사건, 폭력, 성폭력
## FREX: 시위, 집회, 가해자, 미투, 폭력, 규탄, 성폭력
## Lift: 규탄, 최루탄, 텔레그램, 편파, 혜화역, 강남역, 근절
## Score: 범죄, 성폭력, 시위, 피해자, 집회, 폭력, 가해자
## Topic 17 Top Words:
## Highest Prob: 여성, 환자, 코로나19, 감염, 병원, 판정, 확진
## FREX: 감염, 판정, 확진, 확진자, 메르스, 바이러스, 코로나19
## Lift: 감염자, 검체, 오한, 인플루엔자, 감염, 고열, 뇌염
## Score: 확진, 감염, 환자, 확진자, 코로나19, 판정, 바이러스
## Topic 18 Top Words:
## Highest Prob: 논란, 발언, 사과, 성추행, 여성, 학교, 비하
## FREX: 사과, 성희롱, 비하, 발언, 징계, 해명, 폭로
## Lift: 트랙, 중징계, 징계, 탁현민, 성희롱, 언행, STAR
## Score: 발언, 비하, 성희롱, 성추행, 사과, 논란, 트랙
## Topic 19 Top Words:
## Highest Prob: 여성, 경찰, 남성, 폭행, 신고, 사건, 피해
## FREX: 폭행, 경찰관, 난동, 엘리베이터, 주먹, 머리채, 출동
## Lift: 여성혐오, 이수역, 신림동, 머리채, 난동, 폭행, 현행범
## Score: 경찰, 폭행, 남성, 신고, 여성혐오, 사건, 경찰관
## Topic 21 Top Words:
## Highest Prob: 경찰, 여성, 살해, 혐의, 범행, 조사, 흉기
## FREX: 경사, 자수, 살해, 야산, 흉기, 구속영장, 암매장
## Lift: 사패산, 안동, 파주경찰서, 군산경찰서, 의정부경찰서, 군포, 혈흔
## Score: 경찰, 범행, 살해, 흉기, 혐의, 용의자, 구속영장
## Topic 25 Top Words:
## Highest Prob: 발견, 시신, 여성, 실종, 경찰, 확인, 추정
## FREX: 실종, 발견, 실종자, 타살, 해경, 제주, 수색
## Lift: 가파도, 변사체, 선체, 실족, 실종자, 인양, 타살
## Score: 발견, 시신, 실종, 경찰, 부검, 수색, 제주
## Topic 39 Top Words:
## Highest Prob: 후보, 의원, 여성, 선거, 대표, 정치, 민주당
## FREX: 새누리당, 공천, 총통, 지역구, 총선, 한나라당, 선거
## Lift: 더민주, 민진당, 안철수, 차이잉원, 홍준표, 새누리, 의석
## Score: 후보, 의원, 선거, 새누리당, 민주당, 공천, 당선increase_topics <- estimateEffect(c(9, 11, 17, 18, 19, 21, 25, 39) ~ s(yid), femalePrevFit, meta=out$meta,
uncertainty="Global")
increase_fit <- extract.estimateEffect(x= increase_topics, covariate = "yid",
method = "continuous",
model = femalePrevFit,
labeltype = "prob",
n = 10, ci.level = 0.95)
library(ggthemes)
female_years <- female_news %>% mutate(year=floor_date(date, "years")) %>% filter(!duplicated(yid))
top_terms## # A tibble: 40 x 2
## topic terms
## <int> <chr>
## 1 1 운전, 사우디, 허용, 이슬람, 사우디아라비아, 자동차, 복장
## 2 2 여자, 남자, 남자들, 만화, 박은혜, 구두, 남녀
## 3 3 여성, 검찰, 성폭행, 수사, 조사, 주장, 경찰
## 4 4 여자친구, 여자, 아이들, 친구, 공개, 가수, 그룹
## 5 5 여성, 기업, 일자리, 취업, 정부, 임원, 고용
## 6 6 대통령, 장관, 여성, 정부, 청와대, 임명, 인사
## 7 7 촬영, 화장실, 여성, 사진, 인터넷, 카메라, 신체
## 8 8 출산, 육아, 경력, 단절, 임신, 합격자, 시험
## 9 9 혐의, 성폭행, 여성, 선고, 기소, 징역, 재판
## 10 10 아들, 어머니, 아버지, 학대, argWidth, 여성, 입양
## # ... with 30 more rowsincrease_fit %>%
ggplot(aes(x = covariate.value, y = estimate,
color = as.factor(topic), group = as.factor(topic),
ymin = ci.lower, ymax = ci.upper)) +
geom_line() +
geom_ribbon(aes(fill=as.factor(topic)),linetype=0, alpha = 0.1, show.legend = FALSE) +
scale_color_discrete(name = "FREX: 각 토픽에서 빈번하지만 독점적으로 등장하는 단어들",
labels=c("성범죄: 선고, 재판부, 징역, 기소, 유예, 재판, 추행",
"성범죄: 시위, 집회, 가해자, 미투, 폭력, 규탄, 성폭력",
"감염증: 감염, 판정, 확진, 확진자, 메르스, 바이러스, 코로나19",
"성범죄: 사과, 성희롱, 비하, 발언, 징계, 해명, 폭로",
"범죄: 폭행, 경찰관, 난동, 엘리베이터, 주먹, 머리채, 출동",
"범죄: 경사, 자수, 살해, 야산, 흉기, 구속영장, 암매장",
"범죄: 실종, 발견, 실종자, 타살, 해경, 제주, 수색",
"정치: 새누리당, 공천, 총통, 지역구, 총선, 한나라당, 선거")) +
scale_x_continuous("Year", breaks=seq(5,25,5),
labels = sort(year(female_years$year))[seq(5,25,5)]) +
scale_y_continuous(limits=c(-0.35,0.35)) +
ggtitle("여성 관련 40개 토픽 중 비중이 점차 증가해온 8개 토픽",
subtitle = "95% 신뢰구간") +
theme_gdocs()
Topic correlations
plot(topicCorr(femalePrevFit, cutoff = 0.1))
cor_matrix <- topicCorr(femalePrevFit)$cor
cor_matrix[1:5,1:5]## [,1] [,2] [,3] [,4] [,5]
## [1,] 1.00000000 -0.02486294 -0.03201587 -0.01830289 0.00000000
## [2,] -0.02486294 1.00000000 -0.05390984 0.05947546 -0.06519753
## [3,] -0.03201587 -0.05390984 1.00000000 -0.02351338 -0.05482920
## [4,] -0.01830289 0.05947546 -0.02351338 1.00000000 -0.04610141
## [5,] 0.00000000 -0.06519753 -0.05482920 -0.04610141 1.00000000hc <- hclust(dist(cor_matrix))
plot(hc, hang=0)
Visualization of topic correlations by a network
library(textshape)##
## Attaching package: 'textshape'## The following object is masked from 'package:lubridate':
##
## duration## The following object is masked from 'package:dplyr':
##
## combine## The following object is masked from 'package:purrr':
##
## flatten## The following object is masked from 'package:tibble':
##
## column_to_rownamesrownames(cor_matrix) <- top_terms$topic
colnames(cor_matrix) <- top_terms$topic
cor_tidy <- tibble(tidy_matrix(cor_matrix))
library(igraph)##
## Attaching package: 'igraph'## The following object is masked from 'package:textshape':
##
## ends## The following objects are masked from 'package:lubridate':
##
## %--%, union## The following objects are masked from 'package:future':
##
## %->%, %<-%## The following objects are masked from 'package:dplyr':
##
## as_data_frame, groups, union## The following objects are masked from 'package:purrr':
##
## compose, simplify## The following object is masked from 'package:tidyr':
##
## crossing## The following object is masked from 'package:tibble':
##
## as_data_frame## The following objects are masked from 'package:stats':
##
## decompose, spectrum## The following object is masked from 'package:base':
##
## unionlibrary(ggraph)
library(tidygraph)##
## Attaching package: 'tidygraph'## The following object is masked from 'package:igraph':
##
## groups## The following object is masked from 'package:stats':
##
## filterset.seed(210609)
cor_tidy %>%
filter(value > 0.1) %>%
as_tbl_graph(directed = FALSE) %>%
activate(nodes) %>%
mutate(eigen = centrality_eigen(),
betweenness = centrality_betweenness(),
group = group_louvain()) %>%
ggraph(layout="nicely") +
geom_edge_link(aes(edge_alpha = value), show.legend = FALSE) +
geom_node_point(aes(size = betweenness, color=factor(group))) +
scale_size(range = c(2,6)) +
geom_node_text(aes(label = name, size = betweenness),
repel = TRUE) +
theme(legend.position = "none")