2000 - 2019 传播学硕博论文探索性分析
Qiushi Yan
2020-03-11
读取及预处理
# load packages
library(jiebaR)
library(tidyverse)
library(glue)
library(lubridate)
library(ggwordcloud)
library(pins)
library(showtext)
library(tidytext)
library(tidylo)
library(topicmodels)
font_add_google("Noto Serif SC")
showtext_auto()# 数据预处理
raw <- read_csv("传播学专业-摘要更新(最终)0307.csv") %>%
select(-链接) %>%
mutate(下载 = str_extract(下载, "\\d+") %>% as.integer(),
被引 = str_extract(被引, "\\d+") %>% as.integer(),
year = year(时间))
raw_long <- raw %>%
pivot_longer(c("关键词1", "关键词2", "关键词3", "关键词4"),
names_to = "keyword_id", values_to = "keyword",
names_prefix = "关键词", names_ptypes = list(id = integer()))
raw_decade <- raw %>%
mutate(decade = if_else(2000 <= year & year <= 2009,
"2000 - 2009",
"2010 - 2019")) %>%
select(-year)raw#> # A tibble: 10,731 x 14
#> 标题 摘要 作者 导师 学校 时间 等级 关键词1 关键词2 关键词3
#> <chr> <chr> <chr> <chr> <chr> <date> <chr> <chr> <chr> <chr>
#> 1 传播学视~ 随着土豆~ 江含雪~ 周晓明~ 华中师范~ 2014-05-01 硕士论文~ 弹幕视频~ 特点 传播模式~
#> 2 传播学视~ 弹幕视频~ 周舟 虞吉 西南大学~ 2015-04-20 硕士论文~ 弹幕 弹幕文化~ 青年亚文化~
#> 3 微信的传~ 微信,从~ 李阳 刘丹凌~ 西南大学~ 2014-04-21 硕士论文~ 微信 传播机制~ 封闭式传播~
#> 4 移动互联~ 随着互联~ 戴慧祺~ 孙平 江西师范~ 2014-06-01 硕士论文~ 移动互联网~ 微信营销~ SWOT分析~
#> 5 大数据时~ 大数据时~ 王国鹏~ 冯炜 山东大学~ 2014-05-30 硕士论文~ 大数据时代~ 媒介生产方式~ 传播机制~
#> 6 健康健美~ 自201~ 龚琼 金定海~ 华东师范~ 2014-03-17 硕士论文~ App 健康健美~ 传播
#> 7 媒介作为~ 媒介与记~ 邵鹏 吴飞 浙江大学~ 2014-03-01 博士论文~ 媒介记忆~ 记忆研究~ 传播研究~
#> 8 媒介融合~ 以数字化~ 王勇 罗以澄~ 武汉大学~ 2013-11-01 博士论文~ 媒介融合~ 广电全媒体~ 转型
#> 9 移动互联~ 从199~ 周菲乔~ 刘翼 成都理工~ 2016-05-01 硕士论文~ 移动互联网~ 短视频APP~ 传播模式~
#> 10 微信广告~ 科学技术~ 李勇 王战 湖南师范~ 2014-05-01 硕士论文~ 微信 移动互联网~ 盈利模式~
#> # ... with 10,721 more rows, and 4 more variables: 关键词4 <chr>, 下载 <int>,
#> # 被引 <int>, year <dbl># 定义分词器
wk <- worker(bylines = TRUE, user = "user.dict.utf8", stop_word = "哈工大停用词表.txt")
# 字典已根据传播学常用名词调整
read_lines("user.dict.utf8", n_max = 100)#> [1] "场域" "传播学" "第三人效果"
#> [4] "第一人效果" "涵化理论" "教养理论"
#> [7] "培养理论" "霍夫兰" "框架理论"
#> [10] "李普曼" "罗杰斯" "麦奎尔"
#> [13] "拉斯韦尔" "5W" "7W"
#> [16] "申农-韦弗模式" "过程研究" "传统线性模式"
#> [19] "控制论模式" "反馈" "编码和解码"
#> [22] "传播过程" "参照群体" "基本群体"
#> [25] "初级群体" "首属群体" "马莱茨克"
#> [28] "归纳" "演绎" "抽样调查"
#> [31] "随机抽样" "非随机抽样" "皮亚杰"
#> [34] "托尔曼" "斯蒂芬森" "个人功能"
#> [37] "授予地位" "社会准者" "麻醉功能"
#> [40] "双重行动" "潜网" "权力的媒介"
#> [43] "报刊的四种理论" "集权主义" "自由主义"
#> [46] "社会责任" "共产主义" "控制体系"
#> [49] "政治控制" "经济控制" "受众控制"
#> [52] "自我控制" "戈夫曼" "情境决定论"
#> [55] "前台行为" "后台行为" "可读性"
#> [58] "媒介理论个人差异论" "梅罗维茨" "连贯论"
#> [61] "认识不和谐理论" "可获得性" "易得性"
#> [64] "常识理论" "现场理论" "社会科学理论"
#> [67] "戈尔丁" "短期的预期效果" "短期的非预期效果"
#> [70] "长期的预期效果" "长期的非预期效果" "环境认知"
#> [73] "价值形成与维护" "行为示范" "意见领袖"
#> [76] "说服性效果" "魔弹论" "施拉姆"
#> [79] "数字鸿沟" "议程互设" "议程设置"
#> [82] "舆论" "知沟" "知识沟"
#> [85] "沉默的螺旋" "大数据" "人工智能"
#> [88] "虚拟显示" "机器学习" "深度学习"
#> [91] "强化学习" "算法" "既有倾向"
#> [94] "人民的选择" "休眠效果" "一面提示"
#> [97] "两面提示" "免疫" "明示结论"
#> [100] "诉诸理性"发文量及学校
# 年发文量
p <- raw %>%
group_by(year, 等级) %>%
count() %>%
ggplot() +
geom_line(aes(year, n, color = 等级))
plotly::ggplotly(p)# 前后十年学校频次对比
raw_decade %>%
group_by(decade) %>%
count(学校) %>%
ggplot() +
geom_text_wordcloud_area(aes(label = 学校, size = n)) +
theme_light() +
facet_wrap(~ decade)
标题, 关键词分析
# 标题常用词
# raw %>%
# select(-c(作者, 摘要, 导师, 学校, 时间), -contains("关键")) %>%
# mutate(words = segment(标题, wk)) %>%
# unnest_longer(words) %>%
# pin(name = "disseration_title_words")
title_words <- pin_get("disseration_title_words")
title_counts <- title_words %>%
group_by(year) %>%
filter(min_rank(desc(下载 + 被引)) <= 10) %>%
count(words, sort = TRUE)
title_counts#> # A tibble: 223 x 3
#> # Groups: year [20]
#> year words n
#> <dbl> <chr> <int>
#> 1 2005 传播 2
#> 2 2012 营销 2
#> 3 2014 背景 2
#> 4 2014 探究 2
#> 5 2000 报纸 1
#> 6 2000 初探 1
#> 7 2000 沟通 1
#> 8 2000 平衡 1
#> 9 2000 社会群体 1
#> 10 2000 探析 1
#> # ... with 213 more rows# 关键词常用词
# raw_long %>%
# select(-c(标题, 摘要, 作者, 导师, 学校, 时间, keyword_id)) %>%
# pin(name = "disseration_keyword_words")
keyword_words <- pin_get("disseration_keyword_words")
keyword_counts <- keyword_words %>%
filter(!is.na(keyword)) %>%
group_by(year) %>%
filter(min_rank(desc(下载 + 被引)) <= 10) %>%
count(keyword, sort = TRUE)
keyword_counts#> # A tibble: 208 x 3
#> # Groups: year [20]
#> year keyword n
#> <dbl> <chr> <int>
#> 1 2011 传播机制 2
#> 2 2011 微博 2
#> 3 2012 微博 2
#> 4 2014 移动互联网 2
#> 5 2000 报纸产业化 1
#> 6 2000 沟通 1
#> 7 2000 平衡 1
#> 8 2000 社会群体 1
#> 9 2000 物流配送网络 1
#> 10 2000 自办发行 1
#> # ... with 198 more rows# join 两个数据框
# title_counts %>%
# full_join(keyword_counts,
# by = c("year" = "year", "words" = "keyword"),
# suffix = c("_title", "_keyword")) %>%
# replace_na(list(n_keyword = 0)) %>%
# mutate(n_total = n_title + n_keyword) %>%
# pin("disseration_total_counts")
total_counts <- pin_get("disseration_total_counts")
total_counts#> # A tibble: 352 x 5
#> year words n_title n_keyword n_total
#> <dbl> <chr> <int> <dbl> <dbl>
#> 1 2005 传播 2 1 3
#> 2 2012 营销 2 0 2
#> 3 2014 背景 2 0 2
#> 4 2014 探究 2 0 2
#> 5 2000 报纸 1 0 1
#> 6 2000 初探 1 0 1
#> 7 2000 沟通 1 1 2
#> 8 2000 平衡 1 1 2
#> 9 2000 社会群体 1 1 2
#> 10 2000 探析 1 0 1
#> # ... with 342 more rows# 每年下载 + 引用量前十的论文中，标题和关键词的常用词
total_counts %>%
group_by(year) %>%
top_n(10) %>%
ggplot() +
geom_col(aes(n_total, reorder_within(words, n_total, year))) +
scale_y_reordered() +
facet_wrap(~ year, scales = "free_y", nrow = 5) +
labs(title = "2000 - 2019 年下载 + 引用量前十论文标题及关键词常用词",
x = "",
y = "") +
theme_light() +
theme(text = element_text(family = "Noto Serif SC", size = 50),
plot.title.position = "plot")# 前后十年对比，全部标题和关键词中的常用词
total_counts %>%
mutate(decade = if_else(2000 <= year & year <= 2009,
"2000 - 2009",
"2010 - 2019")) %>%
select(-year) %>%
ggplot() +
geom_text_wordcloud_area(aes(label = words, size = n_total)) +
facet_wrap(~ decade, scales = "free") +
labs(title = "二十年对比: 全部论文标题及关键词常用词",
x = "",
y = "") +
theme_light() +
theme(text = element_text(family = "Noto Serif SC", size = 20),
plot.title.position = "plot")
摘要分析
下面摘要分析中的文档均只选取了每年中下载 + 被引前50名的论文文章
# raw %>%
# select(-c(作者, 导师, 时间), -contains("关键")) %>%
# group_by(year) %>%
# filter(min_rank(desc(下载 + 被引)) <= 50) %>%
# mutate(words = segment(摘要, wk)) %>%
# unnest_longer(words) %>%
# select(-摘要) %>%
# pin(name = "dissertation_abstract_words")
abstract_words <- pin_get("dissertation_abstract_words")
abstract_words#> # A tibble: 218,256 x 7
#> 标题 学校 等级 下载 被引 year words
#> <chr> <chr> <chr> <int> <int> <dbl> <chr>
#> 1 传播学视域中的弹幕视频研究 华中师范大学 硕士论文 7463 177 2014 土豆网
#> 2 传播学视域中的弹幕视频研究 华中师范大学 硕士论文 7463 177 2014 豆
#> 3 传播学视域中的弹幕视频研究 华中师范大学 硕士论文 7463 177 2014 泡
#> 4 传播学视域中的弹幕视频研究 华中师范大学 硕士论文 7463 177 2014 产品
#> 5 传播学视域中的弹幕视频研究 华中师范大学 硕士论文 7463 177 2014 问世
#> 6 传播学视域中的弹幕视频研究 华中师范大学 硕士论文 7463 177 2014 弹幕视频
#> 7 传播学视域中的弹幕视频研究 华中师范大学 硕士论文 7463 177 2014 这一
#> 8 传播学视域中的弹幕视频研究 华中师范大学 硕士论文 7463 177 2014 非主流
#> 9 传播学视域中的弹幕视频研究 华中师范大学 硕士论文 7463 177 2014 视频
#> 10 传播学视域中的弹幕视频研究 华中师范大学 硕士论文 7463 177 2014 形式
#> # ... with 218,246 more rows关键词提取
比较两种算法在摘要中提取关键词的效果：tf-idf 和 weighted log odds
# tf idf
abstract_tf_idf <- abstract_words %>%
group_by(标题) %>%
count(words) %>%
bind_tf_idf(words, 标题, n)
# log odds
abstract_log_odds <- abstract_words %>%
group_by(标题) %>%
count(words) %>%
bind_log_odds(words, 标题, n)
abstract_joined <- abstract_log_odds %>%
left_join(abstract_tf_idf, by = c("标题", "words"))
abstract_joined#> # A tibble: 141,947 x 8
#> # Groups: 标题 [856]
#> 标题 words n.x log_odds n.y tf idf tf_idf
#> <chr> <chr> <int> <dbl> <int> <dbl> <dbl> <dbl>
#> 1 "\"烂片高票房\"现象与中国电影营销策略研究"~ 《小时代》~ 1 0.0815 1 0.00448 6.06 0.0272
#> 2 "\"烂片高票房\"现象与中国电影营销策略研究"~ 2013 1 0.0802 1 0.00448 3.76 0.0168
#> 3 "\"烂片高票房\"现象与中国电影营销策略研究"~ 217.69 1 0.0820 1 0.00448 6.75 0.0303
#> 4 "\"烂片高票房\"现象与中国电影营销策略研究"~ 包括 1 0.0571 1 0.00448 1.52 0.00680
#> 5 "\"烂片高票房\"现象与中国电影营销策略研究"~ 变得 1 0.0792 1 0.00448 3.29 0.0147
#> 6 "\"烂片高票房\"现象与中国电影营销策略研究"~ 变迁 1 0.0777 1 0.00448 3.23 0.0145
#> 7 "\"烂片高票房\"现象与中国电影营销策略研究"~ 便 1 0.0784 1 0.00448 3.09 0.0139
#> 8 "\"烂片高票房\"现象与中国电影营销策略研究"~ 层面 2 0.135 2 0.00897 1.59 0.0143
#> 9 "\"烂片高票房\"现象与中国电影营销策略研究"~ 产品 1 0.0512 1 0.00448 1.54 0.00689
#> 10 "\"烂片高票房\"现象与中国电影营销策略研究"~ 产业 1 0.0687 1 0.00448 2.26 0.0102
#> # ... with 141,937 more rows主题模型
abstract_2000 <- abstract_words %>%
mutate(decade = if_else(2000 <= year & year <= 2009,
"2000 - 2009",
"2010 - 2019")) %>%
select(-year) %>%
filter(decade == "2000 - 2009") %>%
group_by(标题) %>%
count(words)
abstract_2000 #> # A tibble: 54,393 x 3
#> # Groups: 标题 [356]
#> 标题 words n
#> <chr> <chr> <int>
#> 1 “博客”与博客传播新探 Blog 3
#> 2 “博客”与博客传播新探 ger 1
#> 3 “博客”与博客传播新探 log 1
#> 4 “博客”与博客传播新探 sphere 1
#> 5 “博客”与博客传播新探 Web 1
#> 6 “博客”与博客传播新探 背景 1
#> 7 “博客”与博客传播新探 本文 1
#> 8 “博客”与博客传播新探 必将 1
#> 9 “博客”与博客传播新探 壁垒 1
#> 10 “博客”与博客传播新探 标志 1
#> # ... with 54,383 more rowsabstract_2010 <- abstract_words %>%
mutate(decade = if_else(2000 <= year & year <= 2009,
"2000 - 2009",
"2010 - 2019")) %>%
select(-year) %>%
filter(decade == "2010 - 2019") %>%
group_by(标题) %>%
count(words)
abstract_2010#> # A tibble: 87,554 x 3
#> # Groups: 标题 [500]
#> 标题 words n
#> <chr> <chr> <int>
#> 1 "\"烂片高票房\"现象与中国电影营销策略研究" 《小时代》 1
#> 2 "\"烂片高票房\"现象与中国电影营销策略研究" 2013 1
#> 3 "\"烂片高票房\"现象与中国电影营销策略研究" 217.69 1
#> 4 "\"烂片高票房\"现象与中国电影营销策略研究" 包括 1
#> 5 "\"烂片高票房\"现象与中国电影营销策略研究" 变得 1
#> 6 "\"烂片高票房\"现象与中国电影营销策略研究" 变迁 1
#> 7 "\"烂片高票房\"现象与中国电影营销策略研究" 便 1
#> 8 "\"烂片高票房\"现象与中国电影营销策略研究" 层面 2
#> 9 "\"烂片高票房\"现象与中国电影营销策略研究" 产品 1
#> 10 "\"烂片高票房\"现象与中国电影营销策略研究" 产业 1
#> # ... with 87,544 more rows分别对两个十年的数据拟合 LDA 主题模型 (k = 5)
topics_2000 <- abstract_2000 %>%
cast_dtm(标题, words, n) %>%
LDA(k = 5, control = list(seed = 1234))topics_2010 <- abstract_2010 %>%
cast_dtm(标题, words, n) %>%
LDA(k = 5, control = list(seed = 1234))2000 - 2009 年的 \(\beta\) 矩阵
topics_2000 %>%
tidy(matrix = "beta") #> # A tibble: 54,765 x 3
#> topic term beta
#> <int> <chr> <dbl>
#> 1 1 Blog 3.50e-131
#> 2 2 Blog 7.87e-154
#> 3 3 Blog 3.61e-153
#> 4 4 Blog 1.77e- 4
#> 5 5 Blog 1.12e-153
#> 6 1 ger 1.56e-131
#> 7 2 ger 2.05e-154
#> 8 3 ger 4.28e-153
#> 9 4 ger 5.89e- 5
#> 10 5 ger 2.67e-153
#> # ... with 54,755 more rowstopics_2000 %>%
tidy(matrix = "beta") %>%
group_by(topic) %>%
top_n(10, beta) %>%
ungroup() %>%
arrange(topic, -beta) %>%
mutate(term = reorder_within(term, beta, topic)) %>%
ggplot(aes(term, beta, fill = factor(topic))) +
geom_col(show.legend = FALSE) +
facet_wrap(~ topic, scales = "free") +
coord_flip() +
scale_x_reordered() +
theme_light() +
labs("2000 - 2009 年主题分类")
2010 - 2019 年的 \(\beta\) 矩阵
topics_2010 %>%
tidy(matrix = "beta") #> # A tibble: 69,920 x 3
#> topic term beta
#> <int> <chr> <dbl>
#> 1 1 《小时代》 3.56e- 9
#> 2 2 《小时代》 3.86e- 8
#> 3 3 《小时代》 2.25e-136
#> 4 4 《小时代》 2.82e- 5
#> 5 5 《小时代》 1.95e- 4
#> 6 1 2013 9.75e- 5
#> 7 2 2013 1.14e- 4
#> 8 3 2013 1.73e- 4
#> 9 4 2013 4.02e- 4
#> 10 5 2013 7.84e- 10
#> # ... with 69,910 more rowstopics_2010 %>%
tidy(matrix = "beta") %>%
group_by(topic) %>%
top_n(10, beta) %>%
ungroup() %>%
arrange(topic, -beta) %>%
mutate(term = reorder_within(term, beta, topic)) %>%
ggplot(aes(term, beta, fill = factor(topic))) +
geom_col(show.legend = FALSE) +
facet_wrap(~ topic, scales = "free") +
coord_flip() +
scale_x_reordered() +
theme_light() +
labs("2000 - 2009 年主题分类")