Week14: 토픽 모델링 I
Shin Lee
6/2/2021
R을 이용한 토픽모델링
코로나 백신 관련 기사의 토픽 분석
빅카인즈 중앙지 기사 중 “코로나”와 “백신” 키워드 포함 기사 16000여건 분석
- 코퍼스 준비 및 기본적인 전처리
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()library(readxl)
library(lubridate) ##
## Attaching package: 'lubridate'## The following objects are masked from 'package:base':
##
## date, intersect, setdiff, unioncv <- read_excel("bigkinds_cv.xlsx", sheet = 1)
cv_keywords <- cv %>%
select(DATE, COMPANY, HEADLINE, KEYWORD) %>%
filter(!duplicated(KEYWORD)) %>%
mutate(DATE = ymd(DATE)) %>%
rowid_to_column()
cv_keywords## # A tibble: 16,075 x 5
## rowid DATE COMPANY HEADLINE KEYWORD
## <int> <date> <chr> <chr> <chr>
## 1 1 2021-03-22 중부일보 "[사설] 고령층에도 본격화된 AZ 백신 접~ 고령층,본격화,접종,AZ,백신,고령층,접종,~
## 2 2 2021-03-22 중앙일보 "AZ \"코로나백신, 美 임상서 효과 79~ AZ,코로나,백신,임상서,효과,79%,혈전,~
## 3 3 2021-03-22 YTN "[생생경제] SK바사. 공모주라고 무조건 ~ SK,성공,투자,유의,투자,방송,15:10~~
## 4 4 2021-03-22 YTN "[생생경제] 코로나의무검사보다 근로환경개선~ 코로나의무검사,근로환경개선,우다야,라이,민주~
## 5 5 2021-03-22 중앙일보 "\"AZ 접종 후 희귀 혈전 발생 20대 ~ AZ,접종,혈전,발생,구급,대원,증상,호전,~
## 6 6 2021-03-22 전남일보 "이용빈, \"미얀마 군부 폭력의 희생자에 ~ 이용빈,폭력,미얀마,군부,희생자,인도,지원,~
## 7 7 2021-03-22 동아일보 "“선택적 분노 김제동 선생” 신간 리뷰 삭~ 선택,분노,김제동,선생,신간,리뷰,삭제,논란~
## 8 8 2021-03-22 중앙일보 "김제동 책 비판 리뷰 삭제 논란 \"욕설도~ 김제동,욕설,검열,방송인,김제동,2년,신간,~
## 9 9 2021-03-22 중앙일보 "LH 두고 \"부동산 적폐\"→\"누적된 ~ LH,부동산,적폐,누적,관행,일주일만,문재인~
## 10 10 2021-03-22 YTN "[더뉴스] [리얼미터] 문 대통령 지지율 ~ 대통령,지지율,최저,LH,사태,여파,진행,강~
## # ... with 16,065 more rows- 데이터 파악하기
cv_keywords %>%
count(DATE) %>%
arrange(DATE) %>%
ggplot(aes(DATE, n)) +
geom_col() +
scale_x_date(name="날짜", date_labels = "%Y-%m-%d") +
ylab("")+
ggtitle("코로나 백신 관련 보도량 추이")
- 토큰화하기
library(tidytext)
cv_tidy <- cv_keywords %>%
unnest_tokens(input = KEYWORD,
output = word,
token = "regex",
pattern = ",") %>%
select(rowid, word)
cv_tidy## # A tibble: 3,745,707 x 2
## rowid word
## <int> <chr>
## 1 1 고령층
## 2 1 본격화
## 3 1 접종
## 4 1 az
## 5 1 백신
## 6 1 고령층
## 7 1 접종
## 8 1 유보
## 9 1 아스트라제네카
## 10 1 az
## # ... with 3,745,697 more rows- Document-Term Matrix(DTM) 만들기
4-1. 문서별 단어 빈도 구하기
count_word_doc <- cv_tidy %>%
count(rowid, word, sort = T)
count_word_doc## # A tibble: 2,244,762 x 3
## rowid word n
## <int> <chr> <int>
## 1 5735 미국 127
## 2 6643 대통령 105
## 3 12740 백신 105
## 4 7658 백신 102
## 5 11146 사업 102
## 6 6728 생각 92
## 7 11492 백신 91
## 8 1887 백신 90
## 9 2237 백신 90
## 10 10857 백신 89
## # ... with 2,244,752 more rows4-2. 너무 많은 기사에서 혹은 너무 적은 기사에서 출현하는 단어 지우기
코로나 백신 보도와 관련한 세부 토픽을 파악하기 위해서 기사들에서 공통적으로 출현하는 특정 단어들의 (공기어) 패턴을 파악해 토픽의 특징을 파악하고자 함인데, 이때 대부분의 기사에서 등장하는 “코로나”나 “백신”과 같은 고빈도 출현 단어들이나 주요 주제와는 상관없이 특이하게 소수 기사에서만 등장하는 저빈도 출현 단어들은 토픽 분석에 장애가 됨. 따라서 제거함. 이 작업을 trimming이라고 함.
count_word_doc %>%
count(word, sort=T)## # A tibble: 125,146 x 2
## word n
## <chr> <int>
## 1 코로나 15909
## 2 백신 15876
## 3 코로나19 12201
## 4 접종 10042
## 5 정부 8546
## 6 상황 7512
## 7 시작 7346
## 8 미국 6155
## 9 방역 5741
## 10 국민 5567
## # ... with 125,136 more rowstoo_frequent_terms <- count_word_doc %>%
count(word, sort=T) %>%
filter(n > max(cv_tidy$rowid) * 0.95) # 95% 이상의 문서에서 등장
too_rare_terms <- count_word_doc %>%
count(word, sort=T) %>%
filter(n < max(cv_tidy$rowid) * 0.005) # 0.5% 이하의 문서에서 등장4-3. DTM 만들기: cast_dtm()
#install.packages("tm")
library(tm)## Loading required package: NLP##
## Attaching package: 'NLP'## The following object is masked from 'package:ggplot2':
##
## annotatecv_dtm <- count_word_doc %>%
filter(!word %in% too_frequent_terms$word,
!word %in% too_rare_terms$word) %>%
cast_dtm(document = rowid,
term = word,
value = n)
cv_dtm## <<DocumentTermMatrix (documents: 16074, terms: 3868)>>
## Non-/sparse entries: 1660401/60513831
## Sparsity : 97%
## Maximal term length: 10
## Weighting : term frequency (tf)- LDA 모델 만들기:
LDA()DTM을topicmodels패키지의LDA()에 적용해 LDA 모델 만들기.LDA()에는 다음과 같은 파라미터 입력.
k: 토픽 수. 토픽 수는 정답이 없기 때문에k값을 바꾸어 가며 여러 모델을 만든 다음, 결과를 비교해 결정.method: 샘플링 방법. 토픽 모델은 샘플링을 반복하여 토픽과 단어의 분포를 추정하는 과정을 거쳐 만들어짐. 일반적으로는 깁스"Gibbs"샘플링이 사용됨control = list(seed = 210621): 반복 실행해도 동일한 결과를 만들도록 난수 고정
#install.packages("topicmodels")
library(topicmodels)
lda_model <- LDA(cv_dtm,
k = 10,
method = "Gibbs",
control = list(seed = 210621))
glimpse(lda_model)
save(lda_model, file="lda_model.RData")- 토픽별 주요 단어 살펴보기:
beta값을 기준으로
load("lda_model.RData")
term_topic <- tidy(lda_model, matrix = "beta")## Loading required package: topicmodelsterm_topic## # A tibble: 38,680 x 3
## topic term beta
## <int> <chr> <dbl>
## 1 1 미국 0.000000355
## 2 2 미국 0.0000105
## 3 3 미국 0.000000343
## 4 4 미국 0.0666
## 5 5 미국 0.000000397
## 6 6 미국 0.00637
## 7 7 미국 0.000000343
## 8 8 미국 0.000876
## 9 9 미국 0.000000305
## 10 10 미국 0.000000308
## # ... with 38,670 more rowsterm_topic %>% count(topic)## # A tibble: 10 x 2
## topic n
## * <int> <int>
## 1 1 3868
## 2 2 3868
## 3 3 3868
## 4 4 3868
## 5 5 3868
## 6 6 3868
## 7 7 3868
## 8 8 3868
## 9 9 3868
## 10 10 3868term_topic %>%
filter(topic == 1) %>%
summarise(sum_beta = sum(beta))## # A tibble: 1 x 1
## sum_beta
## <dbl>
## 1 1term_topic %>%
filter(term == "아스트라제네카")## # A tibble: 10 x 3
## topic term beta
## <int> <chr> <dbl>
## 1 1 아스트라제네카 0.000000355
## 2 2 아스트라제네카 0.0110
## 3 3 아스트라제네카 0.000000343
## 4 4 아스트라제네카 0.00000412
## 5 5 아스트라제네카 0.00000437
## 6 6 아스트라제네카 0.0170
## 7 7 아스트라제네카 0.000000343
## 8 8 아스트라제네카 0.000000356
## 9 9 아스트라제네카 0.000000305
## 10 10 아스트라제네카 0.000000308term_topic %>%
filter(term == "화이자")## # A tibble: 10 x 3
## topic term beta
## <int> <chr> <dbl>
## 1 1 화이자 0.000000355
## 2 2 화이자 0.000000340
## 3 3 화이자 0.000000343
## 4 4 화이자 0.0000154
## 5 5 화이자 0.000000397
## 6 6 화이자 0.0169
## 7 7 화이자 0.000000343
## 8 8 화이자 0.000000356
## 9 9 화이자 0.000000305
## 10 10 화이자 0.000000308term_topic %>%
filter(topic == 1) %>%
arrange(-beta)## # A tibble: 3,868 x 3
## topic term beta
## <int> <chr> <dbl>
## 1 1 대통령 0.0423
## 2 1 정부 0.0209
## 3 1 경제 0.0182
## 4 1 국민 0.0166
## 5 1 한국 0.0156
## 6 1 국가 0.0152
## 7 1 협력 0.0144
## 8 1 강조 0.0143
## 9 1 위기 0.0139
## 10 1 방역 0.0139
## # ... with 3,858 more rows# 토픽별로 beta가 가장 높은 10개씩 추출해 시각화해 각 토픽 내용 파악하기
top_term_topic <- term_topic %>%
group_by(topic) %>%
slice_max(beta, n = 10)
library(scales)##
## Attaching package: 'scales'## The following object is masked from 'package:purrr':
##
## discard## The following object is masked from 'package:readr':
##
## col_factorlibrary(ggplot2)
top_term_topic %>%
ggplot(aes(x = reorder_within(term, beta, topic),
y = beta,
fill = factor(topic))) +
geom_col(show.legend = F) +
facet_wrap(~ topic, scales = "free", ncol = 5) +
coord_flip() +
scale_x_reordered() +
scale_y_continuous(n.breaks = 4,
labels = number_format(accuracy = .01)) +
labs(x = NULL) +
theme_minimal()
- 문서를 토픽별로 분류하기:
gamma값을 기준으로
doc_topic <- tidy(lda_model, matrix = "gamma")
doc_topic## # A tibble: 160,740 x 3
## document topic gamma
## <chr> <int> <dbl>
## 1 5735 1 0.201
## 2 6643 1 0.0455
## 3 11146 1 0.0249
## 4 6728 1 0.308
## 5 14480 1 0.286
## 6 1979 1 0.00683
## 7 6301 1 0.243
## 8 2166 1 0.0196
## 9 5597 1 0.0363
## 10 9454 1 0.0535
## # ... with 160,730 more rowsdoc_topic %>% count(topic)## # A tibble: 10 x 2
## topic n
## * <int> <int>
## 1 1 16074
## 2 2 16074
## 3 3 16074
## 4 4 16074
## 5 5 16074
## 6 6 16074
## 7 7 16074
## 8 8 16074
## 9 9 16074
## 10 10 16074# 문서 1의 gamma 합계
doc_topic %>%
filter(document == 1) %>%
summarise(sum_gamma = sum(gamma))## # A tibble: 1 x 1
## sum_gamma
## <dbl>
## 1 1# 문서별로 확률이 가장 높은 토픽 추출
doc_class <- doc_topic %>%
group_by(document) %>%
slice_max(gamma, n = 1)
doc_class## # A tibble: 16,294 x 3
## # Groups: document [16,074]
## document topic gamma
## <chr> <int> <dbl>
## 1 1 2 0.384
## 2 10 10 0.502
## 3 100 4 0.459
## 4 1000 2 0.333
## 5 10000 10 0.252
## 6 10001 10 0.473
## 7 10002 6 0.434
## 8 10003 10 0.305
## 9 10004 6 0.320
## 10 10005 6 0.431
## # ... with 16,284 more rows# integer로 변환
doc_class$document <- as.integer(doc_class$document)
# 원문에 토픽 번호 부여
cv_news_topic <- cv_keywords %>%
left_join(doc_class, by = c("rowid" = "document"))
cv_news_topic## # A tibble: 16,295 x 7
## rowid DATE COMPANY HEADLINE KEYWORD topic gamma
## <int> <date> <chr> <chr> <chr> <int> <dbl>
## 1 1 2021-03-22 중부일보 "[사설] 고령층에도 본격화된 A~ 고령층,본격화,접종,AZ,백신,고~ 2 0.384
## 2 2 2021-03-22 중앙일보 "AZ \"코로나백신, 美 임상서~ AZ,코로나,백신,임상서,효과,7~ 6 0.255
## 3 3 2021-03-22 YTN "[생생경제] SK바사. 공모주라~ SK,성공,투자,유의,투자,방송,~ 8 0.404
## 4 4 2021-03-22 YTN "[생생경제] 코로나의무검사보다 ~ 코로나의무검사,근로환경개선,우다야~ 9 0.322
## 5 5 2021-03-22 중앙일보 "\"AZ 접종 후 희귀 혈전 발~ AZ,접종,혈전,발생,구급,대원,~ 5 0.486
## 6 6 2021-03-22 전남일보 "이용빈, \"미얀마 군부 폭력의~ 이용빈,폭력,미얀마,군부,희생자,~ 1 0.212
## 7 7 2021-03-22 동아일보 "“선택적 분노 김제동 선생” 신~ 선택,분노,김제동,선생,신간,리뷰~ 10 0.260
## 8 8 2021-03-22 중앙일보 "김제동 책 비판 리뷰 삭제 논란~ 김제동,욕설,검열,방송인,김제동,~ 10 0.28
## 9 9 2021-03-22 중앙일보 "LH 두고 \"부동산 적폐\"→~ LH,부동산,적폐,누적,관행,일주~ 10 0.220
## 10 10 2021-03-22 YTN "[더뉴스] [리얼미터] 문 대통~ 대통령,지지율,최저,LH,사태,여~ 10 0.502
## # ... with 16,285 more rows# 결합 확인
cv_news_topic %>%
select(rowid, topic)## # A tibble: 16,295 x 2
## rowid topic
## <int> <int>
## 1 1 2
## 2 2 6
## 3 3 8
## 4 4 9
## 5 5 5
## 6 6 1
## 7 7 10
## 8 8 10
## 9 9 10
## 10 10 10
## # ... with 16,285 more rows# 토픽별 문서 수 확인
cv_news_topic %>%
count(topic)## # A tibble: 11 x 2
## topic n
## * <int> <int>
## 1 1 1333
## 2 2 1950
## 3 3 1851
## 4 4 2201
## 5 5 1402
## 6 6 1950
## 7 7 1690
## 8 8 309
## 9 9 1847
## 10 10 1761
## 11 NA 1# NA 토픽은 trimming 과정에서 제거된 단어들로 이뤄진 문서- 토픽 이름 짓기
beta값을 기준으로 각 토픽에 높은 확률로 할당된 단어들을 살피고,gamma값을 기준으로 각 토픽에 높은 확률로 할당된 문서의 내용을 바탕으로 각 토픽의 이름 짓기
term_topic %>%
filter(topic == 1) %>%
arrange(-beta)## # A tibble: 3,868 x 3
## topic term beta
## <int> <chr> <dbl>
## 1 1 대통령 0.0423
## 2 1 정부 0.0209
## 3 1 경제 0.0182
## 4 1 국민 0.0166
## 5 1 한국 0.0156
## 6 1 국가 0.0152
## 7 1 협력 0.0144
## 8 1 강조 0.0143
## 9 1 위기 0.0139
## 10 1 방역 0.0139
## # ... with 3,858 more rowscv_news_topic %>%
filter(topic == 1) %>%
arrange(-gamma) %>%
slice_max(gamma, n = 10) %>%
pull(HEADLINE)## [1] "[전문]문 대통령, 유엔총회 연설 “포용적 국제협력으로 모두를 위한 자유를”"
## [2] "[현장영상] 문 대통령 \"북한 포함한 동북아시아 방역 보건 협력체 제안\""
## [3] "[문재인 대통령, 제75차 유엔총회 기조연설 전문]"
## [4] "문대통령, ‘한반도 종전선언’ 유엔 및 국제사회의 지지 호소"
## [5] "문재인 대통령 유엔총회 기조연설 전문"
## [6] "[전문] 다시 꺼내든 종전선언 문 대통령 “한반도 비극 끝낼 때”"
## [7] "\u6587대통령 “한미, 책임동맹으로 발전 한반도 평화는 반드시 가야할 길”"
## [8] "\u6587 \"한반도 평화 반드시 필요, 비핵화 노력 멈추지 않을 것\" [전문]"
## [9] "문 대통령 \"한반도 평화 반드시 필요하다는 것 다시 한번 강조\""
## [10] "\u9751 \"\u6587-바이든 한미 정상 통화에서 '포괄적 전략 동맹 발전' 합의\""name_topic <- tibble(topic = 1:10,
name = c("1. 대통령의 외교 성과 및 방역 협력",
"2. 가나다",
"3. 라마바",
"4. 사아자",
"5. 차카타",
"6. 파하",
"7. ABC",
"8. DEF",
"9. GHI",
"10. JKL"))
# 시각화
count_topic <- cv_news_topic %>%
count(topic)
top_terms <- term_topic %>%
group_by(topic) %>%
slice_max(beta, n = 5, with_ties = F) %>%
summarise(term = paste(term, collapse = ", "))
count_topic_word <- count_topic %>%
left_join(top_terms) %>%
left_join(name_topic, by ="topic")## Joining, by = "topic"count_topic_word %>%
filter(!is.na(topic)) %>%
ggplot(aes(x = reorder(name, n),
y = n,
fill = name)) +
geom_col(show.legend = F) +
coord_flip() +
geom_text(aes(label = term) , # 토픽 이름 표시
hjust = -0.05) + # 막대 밖에 표시
# geom_text(aes(label = term), # 주요 단어 표시
# hjust = 1.03, # 막대 안에 표시
# col = "white", # 색깔
# fontface = "bold", # 두껍게
# family = "nanumgothic") + # 폰트
scale_y_continuous(expand = c(0, 0), # y축-막대 간격 줄이기
limits = c(0, 4500)) + # y축 범위
labs(x = NULL)