第九組_讀書會討論3
2020-05-27 09:15:48
組員:
B054020042 郭宗翰 B064020014 鄭子婷
M084020023 陳靖中 M084020046 葉君良
N074220002 陳柏翔 N074220022 黃姿榕
M084810010 吳曼瑄
主題：封神演義
應用社群網絡分析
require(readr)## Loading required package: readrrequire(dplyr)## Loading required package: dplyr## Warning: package 'dplyr' was built under R version 3.5.3##
## Attaching package: 'dplyr'## The following objects are masked from 'package:stats':
##
## filter, lag## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, unionrequire(jiebaR)## Loading required package: jiebaR## Warning: package 'jiebaR' was built under R version 3.5.3## Loading required package: jiebaRD## Warning: package 'jiebaRD' was built under R version 3.5.3require(tidyr)## Loading required package: tidyr## Warning: package 'tidyr' was built under R version 3.5.3require(tidytext)## Loading required package: tidytext## Warning: package 'tidytext' was built under R version 3.5.3require(igraph)## Loading required package: igraph## Warning: package 'igraph' was built under R version 3.5.3##
## Attaching package: 'igraph'## The following object is masked from 'package:tidyr':
##
## crossing## The following objects are masked from 'package:dplyr':
##
## as_data_frame, groups, union## The following objects are masked from 'package:stats':
##
## decompose, spectrum## The following object is masked from 'package:base':
##
## unionrequire(topicmodels)## Loading required package: topicmodels## Warning: package 'topicmodels' was built under R version 3.5.3require(stringr)## Loading required package: stringrrequire(ggplot2)## Loading required package: ggplot2require(RColorBrewer)## Loading required package: RColorBrewerrequire(tm)## Loading required package: tm## Warning: package 'tm' was built under R version 3.5.3## Loading required package: NLP## Warning: package 'NLP' was built under R version 3.5.2##
## Attaching package: 'NLP'## The following object is masked from 'package:ggplot2':
##
## annotate# 設定讀取資料路徑
ROOT.DIR<- 'C:/Users/Sean/Documents/20200519_bookclub_3/'
mycolors <- colorRampPalette(brewer.pal(8, "Set3"))(20)古騰堡網站下載《封神演義》繁體文集
library(gutenbergr)## Warning: package 'gutenbergr' was built under R version 3.5.3Fengshen <- gutenberg_download(23910) %>% filter(text!="") %>% distinct(gutenberg_id, text)## Determining mirror for Project Gutenberg from http://www.gutenberg.org/robot/harvest## Using mirror http://aleph.gutenberg.orgFengshen## # A tibble: 3,011 x 2
## gutenberg_id text
## <int> <chr>
## 1 23910 第一回<U+00A0><U+00A0><U+00A0><U+00A0>紂王女媧宮進香
## 2 23910 古風一首：
## 3 23910 混沌初分盤古先，太極兩儀四象懸。子天丑地人寅出，避除獸患有巢賢。~
## 4 23910 燧人取火免鮮食，伏羲畫卦陰陽前。神農治世嚐百草，軒轅禮樂婚姻聯。~
## 5 23910 少昊五帝民物阜，禹王治水洪波蠲。承平享國至四百，桀王無道乾坤顛，~
## 6 23910 日縱妹喜荒酒色，成湯造亳洗腥羶，放桀南巢拯暴虐，雲霓如願後蘇全。~
## 7 23910 三十一世傳殷紂，商家脈絡如斷弦：紊亂朝綱絕倫紀，殺妻誅子信讒言，~
## 8 23910 穢污宮闈寵妲己，蠆盆炮烙忠貞冤，鹿臺聚斂萬姓苦，愁聲怨氣應障天，~
## 9 23910 直諫剖心盡焚炙，孕婦刳剔朝涉殲，崇信姦回棄朝政，屏逐師保性何偏，~
## 10 23910 郊社不修宗廟廢，奇技淫巧盡心研，昵此罪人乃罔畏，沉酗肆虐如鸇鳶。~
## # ... with 3,001 more rows使用正規表示式，將句子區分章節並斷出共1~100章回
Fengshen <- Fengshen %>% mutate(chapter = cumsum(str_detect(Fengshen$text, regex("第.*回(\u00a0|$)"))))
# 文集已經完成斷句了
head(Fengshen, 20)## # A tibble: 20 x 3
## gutenberg_id text chapter
## <int> <chr> <int>
## 1 23910 第一回<U+00A0><U+00A0><U+00A0><U+00A0>紂王女媧宮進香 1
## 2 23910 古風一首： 1
## 3 23910 混沌初分盤古先，太極兩儀四象懸。子天丑地人寅出，避除獸患有巢賢。~ 1
## 4 23910 燧人取火免鮮食，伏羲畫卦陰陽前。神農治世嚐百草，軒轅禮樂婚姻聯。~ 1
## 5 23910 少昊五帝民物阜，禹王治水洪波蠲。承平享國至四百，桀王無道乾坤顛，~ 1
## 6 23910 日縱妹喜荒酒色，成湯造亳洗腥羶，放桀南巢拯暴虐，雲霓如願後蘇全。~ 1
## 7 23910 三十一世傳殷紂，商家脈絡如斷弦：紊亂朝綱絕倫紀，殺妻誅子信讒言，~ 1
## 8 23910 穢污宮闈寵妲己，蠆盆炮烙忠貞冤，鹿臺聚斂萬姓苦，愁聲怨氣應障天，~ 1
## 9 23910 直諫剖心盡焚炙，孕婦刳剔朝涉殲，崇信姦回棄朝政，屏逐師保性何偏，~ 1
## 10 23910 郊社不修宗廟廢，奇技淫巧盡心研，昵此罪人乃罔畏，沉酗肆虐如鸇鳶。~ 1
## 11 23910 西伯朝商囚羑里，微子抱器走風湮。皇天震怒降災毒，若涉大海無淵邊。~ 1
## 12 23910 天下荒荒萬民怨，子牙出世人中仙，終日垂絲釣人主，飛熊入夢獵岐田，~ 1
## 13 23910 共載歸周輔朝政，三分有二日相沿。文考末集大勳沒，武王善述日乾乾。~ 1
## 14 23910 孟津大會八百國，取彼凶殘伐罪愆。甲子昧爽會牧野，前徒倒戈反回旋。~ 1
## 15 23910 若崩厥角齊稽首，血流漂杵脂如泉。戒衣甫著天下定，更於成湯增光妍。~ 1
## 16 23910 牧馬華山示偃武，開我周家八百年。太白旗懸獨夫死，戰亡將士幽魂潛。~ 1
## 17 23910 天挺人賢號尚父，封神壇上列花箋，大小英靈尊位次，商周演義古今傳。~ 1
## 18 23910 成湯乃黃帝之後也，姓子氏。初，帝嚳次妃簡狄祈於高禖，有玄鳥之祥， 遂生契。契事唐虞~ 1
## 19 23910 太戊 仲丁 外壬 河亶甲 祖乙 祖辛 1
## 20 23910 沃甲 祖丁 南庚 陽甲 盤庚 小辛 1文集斷詞
設定斷詞function與停用字stop_word
jieba_tokenizer <- worker(user = file.path(ROOT.DIR,"3_Dict/Fengshen.traditional.txt"),stop_word = file.path(ROOT.DIR , "3_Dict/stop_words.txt"))
Fengshen_tokenizer <- function(t) {
lapply(t, function(x) {
tokens <- segment(x, jieba_tokenizer)
# 去掉字串長度為1的詞彙
tokens <- tokens[nchar(tokens) > 1]
return(tokens)
})
}
tokens <- Fengshen %>% unnest_tokens(word, text, token=Fengshen_tokenizer) %>% filter(!str_detect(word, regex("[0-9a-zA-Z]"))) %>% count(chapter, word) %>% rename(count=n)
fengshen_same = c("子牙","姜子牙")
tokens$word[which(tokens$word %in% fengshen_same)] = "姜子牙"
tokens$gutenberg_id<-NULL # 去除gutenberg_id
head(tokens, 20) # 全文斷詞結果## # A tibble: 20 x 3
## chapter word count
## <int> <chr> <int>
## 1 1 一人 1
## 2 1 一日 2
## 3 1 一回 2
## 4 1 一見 1
## 5 1 一指 1
## 6 1 一面 1
## 7 1 一首 4
## 8 1 一時 2
## 9 1 一陣 2
## 10 1 一梁 1
## 11 1 一道 1
## 12 1 乙未 1
## 13 1 乙游 1
## 14 1 七十二路 1
## 15 1 七年 2
## 16 1 乃立 1
## 17 1 乃罔畏 1
## 18 1 乃帝 1
## 19 1 乃採 1
## 20 1 九頭 1將資料轉換為Document terms Matrix (DTM)
fengshen_dtm <- tokens %>% cast_dtm(chapter, word, count)
fengshen_dtm## <<DocumentTermMatrix (documents: 100, terms: 38286)>>
## Non-/sparse entries: 108114/3720486
## Sparsity : 97%
## Maximal term length: 8
## Weighting : term frequency (tf)fengshen_dtm <- removeSparseTerms(fengshen_dtm, 0.95) #刪除稀疏度大於 0.95 的詞彙
fengshen_dtm## <<DocumentTermMatrix (documents: 100, terms: 3968)>>
## Non-/sparse entries: 55673/341127
## Sparsity : 86%
## Maximal term length: 6
## Weighting : term frequency (tf)繪製封神演義章節分群圖
# graphics.off()
fengshen_dtm_mat <- as.matrix(fengshen_dtm)
## 文本間以 cosine similarity 為度量方式
fengshen_dtm_dist <- proxy::dist(fengshen_dtm_mat, method ="cosine")
## 分為六類
k <- 6
fengshen_clust <- hclust(d = fengshen_dtm_dist, method = "average") #Hierarchical Clustering
fengshen_clust$labels <- c(1:100)
## 可視化
par(cex = 0.6)
plot(fengshen_clust,
main = 'fengshen chpater cluster',
xlab = '', ylab = '', sub = '')
groups <- cutree(fengshen_clust, k=k) # "k=" defines the number of clusters you are using
rect.hclust(fengshen_clust, k=k, border="red") # draw dendogra
# graphics.off()
## 分為五類
k <- 5
fengshen_clust <- hclust(d = fengshen_dtm_dist, method = "average") #Hierarchical Clustering
fengshen_clust$labels <- c(1:100)
## 可視化
par(cex = 0.6)
plot(fengshen_clust,
main = 'fengshen chpater cluster',
xlab = '', ylab = '', sub = '')
groups <- cutree(fengshen_clust, k=k) # "k=" defines the number of clusters you are using
rect.hclust(fengshen_clust, k=k, border="red") # draw dendogra
繪製封神演義章節關係圖
threshoud <- 0.7
fengshen_dtm_dist_cut <- as.matrix(fengshen_dtm_dist)
for ( row_num in 1:dim(fengshen_dtm_dist_cut)[1]) { # 1 to 100
for (col_num in 1:dim(fengshen_dtm_dist_cut)[2]) { # 1 to 100
## 此處將原本 dist 轉換為權重，距離大於閾值則最後權重為 0，反之距離越近（小）者最後權重越大。
dist <- fengshen_dtm_dist_cut[row_num, col_num]
weight <- ifelse(dist >=threshoud, 0, dist)
weight <- abs(weight - threshoud)
weight <- ifelse(weight < threshoud, weight + threshoud,0)
fengshen_dtm_dist_cut[row_num, col_num] <- weight
}
}
#給每個 row 序號，即章節編號第一回至一百回，以 1 到 100 表示。
row.names(fengshen_dtm_dist_cut) <- c(1:100)# graphics.off()
# build a graph from the above matrix
g <- graph.adjacency(fengshen_dtm_dist_cut, weighted =T, mode = "undirected")
# remove loops
g <- simplify(g)
# set labels and degrees of vertices
V(g)$label <- row.names(fengshen_dtm_dist_cut)
V(g)$degree <- degree(g)
## 繪製章節關係圖
set.seed(2020)
par(cex = 1)
layout1 <- layout.kamada.kawai(g)
# plot(g, layout=layout1)
## 美化圖形
V(g)$label.cex <- 2.0 * V(g)$degree / max(V(g)$degree) + 0.5 # max is 2.5
V(g)$label.color <- rgb(0, 0, .2, .8)
V(g)$frame.color <- NA
egam <- (log(E(g)$weight)+.4) / max(log(E(g)$weight)+.4) # edge size
E(g)$color <- rgb(.5, .9, 0, egam)
E(g)$width <- egam *4
# plot the graph in layout1
plot(g, layout = layout1, main = "《封神演義》章節關係圖")
# graphics.off()
par(cex = 1)
layout2 <- layout.sphere(g)
plot(g, layout = layout2, main = "《封神演義》章節關係圖")
文字越大，說明與該章相關的章節數越多,連接的線越粗，說明聯繫越大
建立LDA模型
lda <- LDA(fengshen_dtm, k=5, control = list(seed=1234)) # 創建主題模型
lda## A LDA_VEM topic model with 5 topics.topics <- tidy(lda, matrix = "beta") # 查看每個主題的詞彙機率值
topics## # A tibble: 19,840 x 3
## topic term beta
## <int> <chr> <dbl>
## 1 1 一人 0.000539
## 2 2 一人 0.000851
## 3 3 一人 0.000966
## 4 4 一人 0.000636
## 5 5 一人 0.000336
## 6 1 一日 0.000603
## 7 2 一日 0.000697
## 8 3 一日 0.00212
## 9 4 一日 0.00220
## 10 5 一日 0.00108
## # ... with 19,830 more rows尋找Topic的代表字
top_terms <- topics %>%
group_by(topic) %>%
top_n(10, beta) %>%
ungroup() %>%
arrange(topic, -beta)
top_terms %>%
mutate(term = reorder(term, beta)) %>%
ggplot(aes(term, beta, fill = factor(topic))) +
geom_col(show.legend = FALSE) +
facet_wrap(~ topic, scales = "free") +
coord_flip()
載入每個主題的LDA結果
load(file.path(ROOT.DIR, "4_Result/ldas_result"))LDA後續分析
選定主題數5的結果來作後續的分析
fengshen_lda = ldas[[1]]
ftopics <- tidy(fengshen_lda, matrix = "beta") # 使用"beta"來取出Phi矩陣
ftopics## # A tibble: 191,435 x 3
## topic term beta
## <int> <chr> <dbl>
## 1 1 一人 0.000527
## 2 2 一人 0.000134
## 3 3 一人 0.000267
## 4 4 一人 0.000513
## 5 5 一人 0.000528
## 6 1 一日 0.00126
## 7 2 一日 0.000607
## 8 3 一日 0.000468
## 9 4 一日 0.00128
## 10 5 一日 0.000633
## # ... with 191,425 more rows尋找Topic的代表字
- 整理出每一個Topic中生成概率最高的10個詞彙。
top_terms <- ftopics %>%
filter(!term %in% c("紂王","哪吒")) %>%
group_by(topic) %>%
top_n(10, beta) %>%
ungroup() %>%
arrange(topic, -beta)
top_terms %>%
mutate(term = reorder(term, beta)) %>%
ggplot(aes(term, beta, fill = factor(topic))) +
geom_col(show.legend = FALSE) +
scale_fill_manual(values=mycolors)+
facet_wrap(~ topic, scales = "free") +
coord_flip()
可以歸納出 topic 1 = “聞太師怒兵黃飛虎” topic 2 = “楊戩制服土行孫” topic 3 = “張奎戰楊戩” topic 4 = “妲己媚紂王” topic 5 = “殷郊與殷洪” 以主題二與主題三做比較
# 使用LDA預測每個Document(章回)的主題
ftopics2 <- tidy(lda, matrix="gamma") %>% # 使用"gamma"來取出Theta矩陣
group_by(document) %>% top_n(1, wt=gamma)
ftopics2## # A tibble: 100 x 3
## # Groups: document [100]
## document topic gamma
## <chr> <int> <dbl>
## 1 41 1 0.347
## 2 42 1 0.499
## 3 43 1 0.824
## 4 44 1 0.830
## 5 45 1 1.00
## 6 46 1 0.800
## 7 47 1 0.982
## 8 48 1 0.930
## 9 49 1 0.996
## 10 50 1 1.00
## # ... with 90 more rowsLDA主題進行視覺化
# 把文章資訊和主題join起來
topic_document <- merge(x = ftopics, y = ftopics2, by="topic")
head(topic_document, 20)## topic term beta document gamma
## 1 1 一人 5.273366e-04 41 0.3468158
## 2 1 一人 5.273366e-04 42 0.4988725
## 3 1 一人 5.273366e-04 43 0.8238456
## 4 1 一人 5.273366e-04 44 0.8304069
## 5 1 一人 5.273366e-04 45 0.9996498
## 6 1 一人 5.273366e-04 46 0.8000817
## 7 1 一人 5.273366e-04 47 0.9817902
## 8 1 一人 5.273366e-04 48 0.9295196
## 9 1 一人 5.273366e-04 49 0.9961329
## 10 1 一人 5.273366e-04 50 0.9997166
## 11 1 一人 5.273366e-04 51 0.7222157
## 12 1 一人 5.273366e-04 52 0.7496463
## 13 1 一人 5.273366e-04 61 0.3767758
## 14 1 一人 5.273366e-04 77 0.9996690
## 15 1 一人 5.273366e-04 78 0.6972466
## 16 1 一人 5.273366e-04 82 0.9376980
## 17 1 一人 5.273366e-04 83 0.9997861
## 18 1 一人 5.273366e-04 84 0.7942465
## 19 1 一人 5.273366e-04 99 0.8629175
## 20 1 子不道 1.299290e-271 41 0.3468158篩選主題為2與3者
link <- topic_document %>% filter(topic == 2 | topic == 3) %>% unique()
head(link, 20)## topic term beta document gamma
## 1 2 此德 1.796462e-263 12 0.9997014
## 2 2 此德 1.796462e-263 13 0.9997196
## 3 2 此德 1.796462e-263 14 0.9997681
## 4 2 此德 1.796462e-263 34 0.5400579
## 5 2 此德 1.796462e-263 37 0.8730754
## 6 2 此德 1.796462e-263 38 0.4990336
## 7 2 此德 1.796462e-263 55 0.8849453
## 8 2 此德 1.796462e-263 58 0.5547957
## 9 2 此德 1.796462e-263 63 0.5536748
## 10 2 此德 1.796462e-263 64 0.6091706
## 11 2 此德 1.796462e-263 65 0.5600576
## 12 2 此德 1.796462e-263 72 0.5139829
## 13 2 此德 1.796462e-263 75 0.8688200
## 14 2 此德 1.796462e-263 76 0.7546960
## 15 2 此德 1.796462e-263 80 0.5847372
## 16 2 此德 1.796462e-263 81 0.5477349
## 17 2 此德 1.796462e-263 90 0.8986929
## 18 2 此德 1.796462e-263 91 0.8291499
## 19 2 此德 1.796462e-263 92 0.5650312
## 20 2 此德 1.796462e-263 93 0.3995605讀取文本人物
people <- scan(file.path(ROOT.DIR, "3_Dict/people.traditional.txt"),
what=character(),sep='\n',
encoding='utf-8',fileEncoding='utf-8')
people## [1] "鴻鈞老祖" "太上老君" "元始天尊" "通天教主"
## [5] "接引道人" "準提道人" "陸壓道人" "燃燈道人"
## [9] "南極仙翁" "廣成子" "赤精子" "玉鼎真人"
## [13] "懼留孫" "雲中子" "道行天尊" "慈航道人"
## [17] "黃龍真人" "靈寶大法師" "清虛道德真君" "普賢真人"
## [21] "太乙真人" "文殊廣法天尊" "姜子牙" "申公豹"
## [25] "多寶道人" "無當聖母" "金靈聖母" "龜靈聖母"
## [29] "烏雲仙" "餘元" "雲霄" "火靈聖母"
## [33] "菡芝仙" "石磯娘娘" "瓊宵碧霄" "趙公明"
## [37] "靈牙仙" "羅宣" "呂嶽" "金光仙"
## [41] "羽翼仙" "魔禮壽" "魔禮海" "禮紅"
## [45] "魔禮青" "楊森" "高友乾" "李興霸"
## [49] "王魔" "楊戩" "殷郊" "殷洪"
## [53] "韋護" "楊任" "雷震子" "鄧嬋玉"
## [57] "黃天化" "洪錦金吒" "龍吉公主" "木吒"
## [61] "哪吒" "土行孫" "龍鬚虎" "楊顯"
## [65] "袁洪" "朱子真" "常昊" "戴禮"
## [69] "金大升" "吳龍" "高覺" "高明"
## [73] "丘引" "餘化龍" "孔宣" "張桂芳"
## [77] "張奎" "畢環" "陶榮" "鄧忠"
## [81] "姚賓" "辛環張節" "荀章" "聞仲"
## [85] "聞聘" "黃飛虎" "崔英" "蘇護"
## [89] "崇黑虎" "鄧九公" "李靖" "孫焰紅"
## [93] "曹寶" "蕭升" "溫良" "馬善"
## [97] "高繼能" "鄔文化" "餘化" "紂王"
## [101] "伯邑考" "姜王" "武王姬發" "蘇全忠"
## [105] "竇榮" "鄂順" "郭宸" "徐蓋"
## [109] "鄂崇禹" "周寶" "候太乙" "王蛟"
## [113] "吳坤" "楊真" "方吉清" "沈庚"
## [117] "孫祥" "方貴" "高震" "薛定"
## [121] "妲己" "廣成子" "飛虎" "太師"
## [125] "聞太師" "子牙" "文王" "武王"
## [129] "武吉"length(people) # 129個人物## [1] 129將人物文本轉成dataframe格式
people_list <- data.frame(person=people)
head(people_list, 20)## person
## 1 鴻鈞老祖
## 2 太上老君
## 3 元始天尊
## 4 通天教主
## 5 接引道人
## 6 準提道人
## 7 陸壓道人
## 8 燃燈道人
## 9 南極仙翁
## 10 廣成子
## 11 赤精子
## 12 玉鼎真人
## 13 懼留孫
## 14 雲中子
## 15 道行天尊
## 16 慈航道人
## 17 黃龍真人
## 18 靈寶大法師
## 19 清虛道德真君
## 20 普賢真人篩選link(主題2,3)中有出現的人物
filtered_people <- people_list %>% filter(person%in%link$term)
head(filtered_people, 20) # 有出現在主題2,3中的人物共103個## person
## 1 太上老君
## 2 元始天尊
## 3 通天教主
## 4 準提道人
## 5 燃燈道人
## 6 南極仙翁
## 7 廣成子
## 8 赤精子
## 9 玉鼎真人
## 10 懼留孫
## 11 雲中子
## 12 道行天尊
## 13 慈航道人
## 14 黃龍真人
## 15 靈寶大法師
## 16 清虛道德真君
## 17 普賢真人
## 18 太乙真人
## 19 文殊廣法天尊
## 20 姜子牙topic_2_3_all <- link %>% filter(term%in%people_list$person) %>%
arrange(document)
head(topic_2_3_all, 20) # 顯示出現人物、主題、章回、beta、gamma等資料## topic term beta document gamma
## 1 2 元始天尊 3.321719e-05 12 0.9997014
## 2 2 廣成子 1.935781e-17 12 0.9997014
## 3 2 赤精子 4.598358e-264 12 0.9997014
## 4 2 伯邑考 9.632984e-04 12 0.9997014
## 5 2 雷震子 1.187951e-03 12 0.9997014
## 6 2 鄂順 1.328687e-04 12 0.9997014
## 7 2 太乙真人 3.312973e-04 12 0.9997014
## 8 2 文殊廣法天尊 3.321719e-05 12 0.9997014
## 9 2 木吒 4.645546e-04 12 0.9997014
## 10 2 李靖 2.441577e-03 12 0.9997014
## 11 2 哪吒 7.302111e-03 12 0.9997014
## 12 2 普賢真人 3.321719e-05 12 0.9997014
## 13 2 崇黑虎 3.791065e-168 12 0.9997014
## 14 2 竇榮 1.494773e-03 12 0.9997014
## 15 2 金靈聖母 1.606998e-04 12 0.9997014
## 16 2 石磯娘娘 1.732322e-262 12 0.9997014
## 17 2 丘引 1.312887e-03 12 0.9997014
## 18 2 飛虎 8.226285e-04 12 0.9997014
## 19 2 申公豹 9.237682e-04 12 0.9997014
## 20 2 王魔 2.721383e-263 12 0.9997014主題為2和3文本中參與各章回內容的人物網絡圖
# 建立網路關係
reviewNetwork <- graph_from_data_frame(d=topic_2_3_all, directed=T)
reviewNetwork## IGRAPH 3d0845b DN-- 104 3162 --
## + attr: name (v/c), beta (e/n), document (e/c), gamma (e/n)
## + edges from 3d0845b (vertex names):
## [1] 2->元始天尊 2->廣成子 2->赤精子 2->伯邑考
## [5] 2->雷震子 2->鄂順 2->太乙真人 2->文殊廣法天尊
## [9] 2->木吒 2->李靖 2->哪吒 2->普賢真人
## [13] 2->崇黑虎 2->竇榮 2->金靈聖母 2->石磯娘娘
## [17] 2->丘引 2->飛虎 2->申公豹 2->王魔
## [21] 2->李興霸 2->菡芝仙 2->燃燈道人 2->高友乾
## [25] 2->子牙 2->文王 2->楊森 2->雲中子
## [29] 2->雲霄 2->龍鬚虎 2->南極仙翁 2->高明
## + ... omitted several edges# 畫出網路圖
plot(reviewNetwork)
再行調整參數如下
調整參數
# 把點點的大小和線的粗細調小
plot(reviewNetwork, vertex.size=2, edge.arrow.size=.2)
嗯~~看不出來什麼…
每個章節出現的角色
chapter_person <- tokens %>% filter(tokens$word %in% people_list$person)%>% unique()
names(chapter_person)<-c("chapter","person","count")
chapter_person <- chapter_person %>% select(chapter,person)
chapter_person## # A tibble: 1,435 x 2
## chapter person
## <int> <chr>
## 1 1 太師
## 2 1 妲己
## 3 1 武王
## 4 1 紂王
## 5 1 殷洪
## 6 1 殷郊
## 7 1 鄂崇禹
## 8 1 黃飛虎
## 9 1 聞太師
## 10 1 聞仲
## # ... with 1,425 more rows每個章節出現的兩個角色
因為要節點是人物，edge是有共同出現在同一章
person_person <- inner_join(x = chapter_person, y = chapter_person, by = "chapter") %>% filter(person.x != person.y)
person_person## # A tibble: 23,784 x 3
## chapter person.x person.y
## <int> <chr> <chr>
## 1 1 太師 妲己
## 2 1 太師 武王
## 3 1 太師 紂王
## 4 1 太師 殷洪
## 5 1 太師 殷郊
## 6 1 太師 鄂崇禹
## 7 1 太師 黃飛虎
## 8 1 太師 聞太師
## 9 1 太師 聞仲
## 10 1 妲己 太師
## # ... with 23,774 more rowsperson_person_link <- person_person %>% group_by(person.x,person.y) %>% summarise(count = n())
person_person_link## # A tibble: 5,182 x 3
## # Groups: person.x [101]
## person.x person.y count
## <chr> <chr> <int>
## 1 土行孫 元始天尊 1
## 2 土行孫 太乙真人 2
## 3 土行孫 太師 1
## 4 土行孫 孔宣 4
## 5 土行孫 文王 2
## 6 土行孫 文殊廣法天尊 2
## 7 土行孫 木吒 7
## 8 土行孫 火靈聖母 1
## 9 土行孫 丘引 1
## 10 土行孫 玉鼎真人 5
## # ... with 5,172 more rows人物與人物的網路圖
Network <- graph_from_data_frame(d=person_person_link, directed=T)
Network## IGRAPH 648ad58 DN-- 101 5182 --
## + attr: name (v/c), count (e/n)
## + edges from 648ad58 (vertex names):
## [1] 土行孫->元始天尊 土行孫->太乙真人 土行孫->太師
## [4] 土行孫->孔宣 土行孫->文王 土行孫->文殊廣法天尊
## [7] 土行孫->木吒 土行孫->火靈聖母 土行孫->丘引
## [10] 土行孫->玉鼎真人 土行孫->申公豹 土行孫->羽翼仙
## [13] 土行孫->吳龍 土行孫->李靖 土行孫->赤精子
## [16] 土行孫->妲己 土行孫->武王 土行孫->武吉
## [19] 土行孫->金靈聖母 土行孫->南極仙翁 土行孫->姜子牙
## [22] 土行孫->紂王 土行孫->韋護 土行孫->飛虎
## + ... omitted several edges# 畫出網路圖
plot(Network,vertex.size = 2,vertex.label.cex = .7,vertex.label.dist = 1,edge.arrow.size = 0.4)
設為無向圖
Network<-as.undirected(Network, mode = "collapse")
plot(Network,vertex.size = 2,vertex.label.cex = .7,vertex.label.dist = 1)
太多角色和連結了，只能看出有部分角色屬於中心角色與大部分人物都有連結，而在外圍的角色則與較靠近的節點為較常一起出現的。
找出中心角色
找出一起出現超過20章的人物
link_main <- person_person %>% group_by(person.x,person.y) %>% summarise(count = n())
link_main <- link_main %>% filter(count >=20)人物與人物的網路圖
Network_main <- graph_from_data_frame(d=link_main, directed=T)
Network_main## IGRAPH 66760ae DN-- 40 160 --
## + attr: name (v/c), count (e/n)
## + edges from 66760ae (vertex names):
## [1] 土行孫 ->武王 土行孫 ->姜子牙 土行孫 ->哪吒
## [4] 元始天尊 ->姜子牙 太乙真人 ->姜子牙 太師 ->姜子牙
## [7] 太師 ->聞太師 文王 ->姜子牙 文殊廣法天尊->姜子牙
## [10] 木吒 ->姜子牙 木吒 ->哪吒 木吒 ->楊戩
## [13] 玉鼎真人 ->姜子牙 申公豹 ->武王 申公豹 ->姜子牙
## [16] 申公豹 ->哪吒 李靖 ->姜子牙 李靖 ->哪吒
## [19] 赤精子 ->姜子牙 妲己 ->姜子牙 妲己 ->紂王
## [22] 妲己 ->黃飛虎 武王 ->土行孫 武王 ->申公豹
## + ... omitted several edges# 畫出網路圖
Network_main<-as.undirected(Network_main, mode = "collapse")
plot(Network_main,vertex.size = 2,vertex.label.cex = .7,vertex.label.dist = 1,edge.arrow.size = 0.4)
可以發現姜子牙為封神演義的中心角色，許多人物都與他會共同出現。而哪吒、武王也能算另外的中心人物。