中文斷詞
library(jiebaR)
## Loading required package: jiebaRD
mixseg <- worker()
segment(code='今天天氣真好', jiebar = mixseg)
## [1] "今天" "天氣" "真好"
#edit_dict()
詞頻矩陣
library(jiebaR)
#edit_dict()
#USERPATH
mixseg <- worker()
s <- "大巨蛋案對市府同仁下封口令？柯P否認"
s1 <- "柯P市府近來飽受大巨蛋爭議"
s.vec <- lapply( list(s, s1), function(e) segment(e, jiebar = mixseg))
library(tm)
## Loading required package: NLP
s.corpus <- Corpus(VectorSource(s.vec))
s.dtm <- DocumentTermMatrix(s.corpus)
inspect(s.dtm)
## <<DocumentTermMatrix (documents: 2, terms: 11)>>
## Non-/sparse entries: 14/8
## Sparsity : 36%
## Maximal term length: 3
## Weighting : term frequency (tf)
## Sample :
## Terms
## Docs 下 同仁 否認 大巨蛋 封口令 市府 柯p 案對 爭議 近來
## 1 1 1 1 1 1 1 1 1 0 0
## 2 0 0 0 1 0 1 1 0 1 1
s.tdm <- TermDocumentMatrix(s.corpus)
inspect(s.tdm)
## <<TermDocumentMatrix (terms: 11, documents: 2)>>
## Non-/sparse entries: 14/8
## Sparsity : 36%
## Maximal term length: 3
## Weighting : term frequency (tf)
## Sample :
## Docs
## Terms 1 2
## 下 1 0
## 同仁 1 0
## 否認 1 0
## 大巨蛋 1 1
## 封口令 1 0
## 市府 1 1
## 柯p 1 1
## 案對 1 0
## 爭議 0 1
## 近來 0 1
利用新聞資料建立詞頻矩陣
library(readxl)
url <- "https://raw.githubusercontent.com/ywchiu/phalanxrtm/master/data/news.xlsx"
destfile <- "news.xlsx"
curl::curl_download(url, destfile)
news <- read_excel(destfile)
#View(news)
library(jiebaR)
mixseg <- worker()
apple.seg <- lapply(news$content, function(e) segment(e, jiebar = mixseg))
s.corpus <- Corpus(VectorSource(apple.seg))
control.list <- list(wordLengths=c(2,Inf) )
dtm <- DocumentTermMatrix(s.corpus, control=control.list)
dim(dtm)
## [1] 899 34233
findFreqTerms(dtm, 200,300)
## [1] "一定" "今天" "問題" "因" "政府" "更新" "目前"
## [8] "知道" "開始" "之" "仍" "你" "可能" "大"
## [15] "或" "所" "指出" "新聞" "曾" "能" "他們"
## [22] "向" "媒體" "男" "約" "蘋果" "11" "其"
## [29] "包括" "名" "因為" "於" "至" "進行" "第"
## [36] "公司" "把" "認為" "個" "從" "跟" "並"
## [43] "又" "就是" "看" "下" "發現" "可以" "很"
## [50] "再" "新" "何守正" "網友" "警方" "可"
findAssocs(dtm, '何守正', 0.7)
## $何守正
## 小嫻 妙禪 健身房 密友
## 0.96 0.76 0.74 0.73
dtm.remove <- removeSparseTerms(dtm, 0.99)
dim(dtm.remove)
## [1] 899 3260
#dtm.remove$dimnames$Terms
文章距離計算
library(jiebaR)
mixseg <- worker()
s <- "大巨蛋案對市府同仁下封口令？柯P否認"
s1 <- "柯P市府近來飽受大巨蛋爭議"
s.vec <- lapply( list(s, s1), function(e) segment(e, jiebar = mixseg))
library(tm)
s.corpus <- Corpus(VectorSource(s.vec))
s.dtm <- DocumentTermMatrix(s.corpus)
inspect(s.dtm)
## <<DocumentTermMatrix (documents: 2, terms: 11)>>
## Non-/sparse entries: 14/8
## Sparsity : 36%
## Maximal term length: 3
## Weighting : term frequency (tf)
## Sample :
## Terms
## Docs 下 同仁 否認 大巨蛋 封口令 市府 柯p 案對 爭議 近來
## 1 1 1 1 1 1 1 1 1 0 0
## 2 0 0 0 1 0 1 1 0 1 1
v1 <- c(1,1,1 ,1,1,1,1,1,0,0)
v2 <- c(0,0,0 ,1,0,1,1,0,1,1)
sum(abs(v1 - v2))
## [1] 7
sum((v1 - v2) ^ 2)
## [1] 7
sqrt(sum((v1 - v2) ^ 2))
## [1] 2.645751
#東北季風影響 北部、東北部濕涼有雨
#國慶日東北季風增強，北部及東北部氣溫稍下降，高溫表現上，北部及東半部約26至29度，其他地區約31、32度，由於各地清晨溫度偏涼，中南部應留意日夜溫差較大，早出晚歸的朋友請添加衣物以免受涼；降雨方面，迎風面水氣增加，其中基隆北海岸、宜蘭及大臺北山區為整天有雨的天氣，並有局部大雨發生的機率，北部地區及花、東也有局部短暫雨，建議參加國慶日活動及前往花蓮欣賞國慶煙火的朋友攜帶雨具備用；至於中南部地區仍維持多雲到晴，午後在山區及屏東地區有局部雷陣雨。
# 東北季風 北部 東北部 濕涼 有雨
# 東北季風 北部 東北部 濕涼 有雨 宜蘭 大臺北 中南部 花蓮 國慶煙火
# 東北季風 北部 東北部 濕涼 有雨 宜蘭 大臺北 中南部 花蓮 國慶煙火
# title 1 1 1 1 1 0 0 0 0 0
# article 1 1 1 1 1 1 1 1 1 1
library(proxy)
##
## Attaching package: 'proxy'
## The following objects are masked from 'package:stats':
##
## as.dist, dist
## The following object is masked from 'package:base':
##
## as.matrix
a <- c(1, 2, 2, 1, 1, 1, 0)
b <- c(1, 2, 2, 1, 1, 2, 1)
proxy::dist(rbind(a, b), method = 'cosine')
## a
## b 0.06180581
library(jiebaR)
mixseg <- worker()
apple.seg <- lapply(news$content, function(e) segment(e, jiebar = mixseg))
s.corpus <- Corpus(VectorSource(apple.seg))
s.corpus <- tm_map(s.corpus, removeNumbers)
## Warning in tm_map.SimpleCorpus(s.corpus, removeNumbers): transformation
## drops documents
s.corpus <- tm_map(s.corpus, removePunctuation)
## Warning in tm_map.SimpleCorpus(s.corpus, removePunctuation): transformation
## drops documents
control.list <- list(wordLengths=c(2,Inf) )
dtm <- DocumentTermMatrix(s.corpus, control=control.list)
dim(dtm)
## [1] 899 33905
dtm.remove <- removeSparseTerms(dtm, 0.99)
dim(dtm.remove)
## [1] 899 3164
library(proxy)
dtm.dist <- proxy::dist(as.matrix(dtm.remove), method = "cosine")
dtm.mat <- as.matrix(dtm.dist)
dtm.mat[1:3, 1:3]
## 1 2 3
## 1 0.0000000 0.7025869 0.7880713
## 2 0.7025869 0.0000000 0.6464768
## 3 0.7880713 0.6464768 0.0000000
news$title[6]
## [1] "Fed升息美元走軟 台幣今再升破30元大關"
order(dtm.mat[6,])[1:10]
## [1] 6 627 805 20 132 753 118 587 666 721
news$title[order(dtm.mat[6,])[1:10]]
## [1] "Fed升息美元走軟 台幣今再升破30元大關"
## [2] "靜候FOMC結論 台幣平盤整理午盤小貶0.5分"
## [3] "耶誕購物旺季 遠百寶慶店推滿5千送5百優惠"
## [4] "Fed宣布升息1碼 台股早盤大漲逾百點"
## [5] "【Fed有鴿味】美元軟了黃金硬了 美股道指創新高"
## [6] "哀鳳SLP訂單有風險 外資降評景碩目標價對半砍"
## [7] "Fed升息符合預期 經濟學家：大家可過個平安聖誕節"
## [8] "傳產撐盤 台股漲27點收10470點"
## [9] "巨騰發出獲利預警 將年減75~85%"
## [10] "做辛酸？薪水被扣1萬 還要繳水電瓦斯費"
news$title[order(dtm.mat[17,])[1:10]]
## [1] "小嫻婚變冒毒菇 勾于美人「奉茶」夢魘"
## [2] "遭粉絲頁冒名捲「正嫻」口水戰 于美人：跟我真的無關！"
## [3] "【獨家內幕】太傷！小嫻被分手 何守正當小三面前攤牌"
## [4] "小嫻信奉妙禪 關鍵原因與何守正有關！"
## [5] "「小嫻不快樂！」 許聖梅：何守正虧欠她"
## [6] "小嫻別傻傻被欺負！女律師說「姐寶」就要這樣對付"
## [7] "國小女童寫作文 內容竟是「我的變態爸比」"
## [8] "心理師：情傷背後，看不見的需要與脆弱"
## [9] "遭霸凌男童被起底疑歧視黑人 母喊冤：我們不是那種人"
## [10] "砲轟小嫻被酸民攻陷 「何三姑」粉絲頁關了"
idx <- dtm.mat[17, order(dtm.mat[17,]) ] < 0.5
news$title[as.integer(names(which(idx ==TRUE )))]
## [1] "小嫻婚變冒毒菇 勾于美人「奉茶」夢魘"
## [2] "遭粉絲頁冒名捲「正嫻」口水戰 于美人：跟我真的無關！"
## [3] "【獨家內幕】太傷！小嫻被分手 何守正當小三面前攤牌"
## [4] "小嫻信奉妙禪 關鍵原因與何守正有關！"
getSimilarArticle <- function(pos, threshold){
idx <- dtm.mat[pos, order(dtm.mat[pos,]) ] < threshold
news$title[as.integer(names(which(idx ==TRUE )))]
}
getSimilarArticle(20, 0.6)
## [1] "Fed宣布升息1碼 台股早盤大漲逾百點"
## [2] "【Fed有鴿味】美元軟了黃金硬了 美股道指創新高"
## [3] "【Fed告別秀】葉倫談比特幣 以7個字總結"
## [4] "Fed升息符合預期 經濟學家：大家可過個平安聖誕節"
聚合式分群
dtm.cluster <- hclust(dtm.dist)
plot(dtm.cluster, hang = -0.1)
fit <- cutree(dtm.cluster, k = 30)
#fit
plot(dtm.cluster, hang = -0.1)
rect.hclust(dtm.cluster, k = 30)
news$title[fit == 5]
## [1] "Fed升息美元走軟 台幣今再升破30元大關"
## [2] "桃園夫妻貪20元購物金天天假交易 物流士怒嗆：有那麼窮？"
## [3] "靜候FOMC結論 台幣平盤整理午盤小貶0.5分"
## [4] "做辛酸？薪水被扣1萬 還要繳水電瓦斯費"
## [5] "耶誕購物旺季 遠百寶慶店推滿5千送5百優惠"
KMeans 分群
fit <- kmeans(dtm.dist, centers = 30)
news$title[fit$cluster == 15]
## [1] "天使換來金斯勒 解決二壘漏洞"
## [2] "大眾臉女子買2支iPhone X 都被同事輕鬆解鎖"
## [3] "【有片】生死一瞬間 他被雪崩追著跑險遭活埋"
## [4] "努涅茲搶手 美東3強都想要"
## [5] "湖人要「球爸」閉嘴 結果又被譙了"
## [6] "性愛片沒拍到臉 他爽快認「就是我沒錯」"
## [7] "【咩姊台語】做直銷開公司建人脈 張誌家與前妻吸千萬捲款"
## [8] "【暖流】罹癌翁「人老了該走就走」 但「腦麻兒怎麼辦」"
## [9] "【舌功片】法拉利姊餐車到台中 舌舔美乃滋喊冤醬髒"
## [10] "「今天南京大屠殺80年公祭日」邱毅：可悲又可恨啊"
## [11] "浩鼎案開庭 翁啟惠：美事一樁被誤會"
## [12] "小嫻中分手魔咒！ 同公司4女星全都婚變"
## [13] "謝金晶誇謝金燕容貌變時尚 桃園跨年無緣同台"
## [14] "【獨家】母餐廳被控少報勞保 林佑星「前員工就是要錢」"
## [15] "感情冒粉紅泡泡！張棟樑認身邊「有一些人」"
## [16] "何守正兩個姊姊護航扯婆媳 「他」戳破媽寶特色"
## [17] "拿假鈔買檳榔 男辯：檳榔西施當時沒說啊！"
## [18] "【話當年】被拍和她上賓館 何守正掰了阿妹"
## [19] "小嫻婚變無徵兆 男星嘆：兩人向來出雙入對"
## [20] "禮讓前車被警拍照驅趕 駕駛怒批結果挨告了"
## [21] "賣家自寄自收「洗評價」 物流士超商店員崩潰"
## [22] "政府勸企業加薪 張忠謀：有違自由人力市場規矩"
library(fpc)
nk <- 2:30
set.seed(123)
SW <- sapply(nk, function(k) {
fit <- kmeans(dtm.dist,centers = k)
cluster.stats(dtm.dist, fit$cluster)$avg.silwidth
})
plot(nk, SW, type="l", xlab="number of clusers", ylab="average silhouette width")
使用Louvain
library(igraph)
##
## Attaching package: 'igraph'
## The following objects are masked from 'package:stats':
##
## decompose, spectrum
## The following object is masked from 'package:base':
##
## union
m <- as.matrix(dtm.dist)
m[1:3,1:3]
## 1 2 3
## 1 0.0000000 0.7025869 0.7880713
## 2 0.7025869 0.0000000 0.6464768
## 3 0.7880713 0.6464768 0.0000000
m2 <- ifelse(m < 0.4, 1, 0)
m2[1:3,1:3]
## 1 2 3
## 1 1 0 0
## 2 0 1 0
## 3 0 0 1
G <- graph_from_adjacency_matrix(m2)
wc <- cluster_walktrap(G)
modularity(wc)
## [1] 0.3680795
max(membership(wc))
## [1] 565
#table(membership(wc))
news$title[membership(wc)== 2]
## [1] "【狗仔偷拍】小嫻搬離何守正家租66坪房 月租6萬元"
## [2] "許聖梅心疼小嫻被當空氣 爆何守正「有兩個女學員」"
## [3] "【動畫解盤】毒菇跳火線譙seafood 小嫻難瘦香菇"
## [4] "不捨善良小嫻慘遭婚變 乃哥「命運捉弄人」"
## [5] "【獨家】小嫻賣房求子 婆婆竟拒入籍何家"
## [6] "小心！在美結婚台灣沒登記 偷腥照樣能捉姦"
## [7] "小嫻離婚導火線 拉何守正信妙禪"
## [8] "小嫻別傻傻被欺負！女律師說「姐寶」就要這樣對付"
## [9] "教友小嫻婚姻觸礁 曾之喬談情避不開Seafood"
## [10] "小嫻守正結婚在台沒登記 想離婚只有兩條路"
## [11] "胡瓜2個月前耳聞小嫻婚變 震驚之餘好心疼"
## [12] "大姑出面護弟！轟小嫻不能生「媽媽是全台最沒有尊嚴的婆婆」"
## [13] "小嫻信奉妙禪 關鍵原因與何守正有關！"
## [14] "小嫻何守正想離婚 必須先做這件事！"
## [15] "「小嫻不快樂！」 許聖梅：何守正虧欠她"
## [16] "【內幕動畫】小嫻婚變何守正姊反擊 不滿媽煮飯侍奉星媳婦"
## [17] "小嫻多信妙禪？ 曾見證「師父帶我跳舞」"
## [18] "【話當年】被拍和她上賓館 何守正掰了阿妹"
## [19] "小嫻婚變無徵兆 男星嘆：兩人向來出雙入對"
## [20] "【獨家內幕】太傷！小嫻被分手 何守正當小三面前攤牌"
## [21] "【小嫻離婚】何守正稱沒有遺憾 人妻女星超火「一嘴屁話」"
## [22] "【小嫻離婚】3大退讓人財兩失 求子花光430萬積蓄"
m3 <- as.matrix(dtm[membership(wc)== 2,])
n <- sort(apply(m3, 2, sum), decreasing = TRUE)[1:20]
n[nchar(names(n)) >= 2 ]
## 小嫻 何守正 離婚 美國 結婚 妙禪
## 264 180 82 41 40 38
文章分類
apple.subset <- news[news$category %in% c('財經地產', '娛樂', '社會'), ]
dim(apple.subset)
## [1] 357 5
head(apple.subset)
## # A tibble: 6 x 5
## X__1 category content link title
## <dbl> <chr> <chr> <chr> <chr>
## 1 2 社會 被控來台涉發展情報組織的中國學生周泓旭，因接觸我方外交部官員而露餡落網，今年9月被台北… https… 陸生共諜…
## 2 5 財經地產 受到Fed升息，及明年升息步伐均符合市場預期影響，國際美元在利多實現後走軟，帶動台幣兌… https… Fed升…
## 3 6 娛樂 韓國女星「喬妹」宋慧喬10月嫁給宋仲基，隨即飛往西班牙度蜜月，上周六甜蜜現身IU演唱會… https… 喬妹升格…
## 4 7 財經地產 更新：新增葉倫談美股、調整標題美國聯邦準備理事會（Fed）在台北時間今凌晨3時公布利率… https… 【Fed…
## 5 10 財經地產 時代力量立委黃國昌今日在財委會上表示，臉書（Facebook；FB)在台營業，每年繳稅… https… 臉書在台…
## 6 13 財經地產 財信傳媒董事長謝金河在臉書發文表示，去年川普當選，跌破全世界的眼鏡。同樣地，菲律賓人選… https… 老謝：美…
library(jiebaR)
mixseg <- worker()
apple.seg <- lapply(apple.subset$content, function(e)segment(code = e, jiebar = mixseg))
#apple.seg[1]
library(tm)
apple.corpus <- Corpus(VectorSource(apple.seg))
doc <- tm_map(apple.corpus, removeNumbers)
## Warning in tm_map.SimpleCorpus(apple.corpus, removeNumbers): transformation
## drops documents
doc <- tm_map(doc, removePunctuation)
## Warning in tm_map.SimpleCorpus(doc, removePunctuation): transformation
## drops documents
dtm <- DocumentTermMatrix(doc)
dtm
## <<DocumentTermMatrix (documents: 357, terms: 18058)>>
## Non-/sparse entries: 62528/6384178
## Sparsity : 99%
## Maximal term length: 18
## Weighting : term frequency (tf)
ft <- findFreqTerms(dtm, 5)
control.list <- list(wordLengths=c(2,Inf),dictionary = ft)
new.dtm <- DocumentTermMatrix(doc,control=control.list)
dim(new.dtm)
## [1] 357 3425
as.matrix(new.dtm[1:3,1:3])
## Terms
## Docs 一名 一審 上午
## 1 1 2 1
## 2 0 0 1
## 3 0 0 0
convert_counts <- function(x) {
x <- ifelse(x > 0, 1, 0)
x <- factor(x, levels = c(0, 1), labels = c("No", "Yes"))
return(x)
}
dtm.count <- apply(new.dtm, MARGIN = 2, convert_counts)
#as.matrix(dtm.count[1:3,1:3])
dtm.count[1:3,1:3]
## Terms
## Docs 一名 一審 上午
## 1 "Yes" "Yes" "Yes"
## 2 "No" "No" "Yes"
## 3 "No" "No" "No"
m <- as.data.frame(dtm.count)
sample.int(42,6)
## [1] 34 16 14 8 22 33
idx <- sample.int(2, nrow(m), replace=TRUE, prob=c(0.7,0.3))
trainset <- m[idx==1,]
testset <- m[idx==2,]
traintitle <- apple.subset$title[idx == 1]
testtitle <- apple.subset$title[idx == 2]
traintag <- apple.subset[idx==1,]$category
testtag <-apple.subset[idx==2,]$category
library(e1071)
model <- naiveBayes(trainset,as.factor(traintag) )
pred <- predict(model, testset)
tb <- table(testtag, pred)
sum(pred == testtag) / length(testtag)
## [1] 0.9363636
#pred
df2 <- as.data.frame(cbind(testtag, as.character(pred),testtitle))
head(df2)
## testtag V2
## 1 社會 社會
## 2 財經地產 財經地產
## 3 社會 娛樂
## 4 娛樂 娛樂
## 5 財經地產 財經地產
## 6 娛樂 娛樂
## testtitle
## 1 【不斷更新】桃園工廠惡火撲滅 6人仍失聯宿舍內發現一堆白骨
## 2 Fed宣布升息1碼 台股早盤大漲逾百點
## 3 醉女盧小小 女警帥爆！突然霸氣送她側摔
## 4 遭粉絲頁冒名捲「正嫻」口水戰 于美人：跟我真的無關！
## 5 鴻準砸45億入股IDG能源 布局天然氣石油商機
## 6 蕭邦羊絨錶帶裝年輕 超薄錶速配西裝
colnames(df2) <- c('testtag', 'pred', 'title')
df2[df2$testtag != df2$pred,]
## testtag pred title
## 3 社會 娛樂 醉女盧小小 女警帥爆！突然霸氣送她側摔
## 23 財經地產 娛樂 【投資動畫】月薪27K每月存股15K 他問這樣能致富嗎？
## 34 娛樂 社會 《殺人回憶》懸案上銀幕 領宋康昊登影帝寶座
## 35 財經地產 娛樂 土銀藝文展 龍笛創辦人蔡孟夏獻寶
## 68 社會 娛樂 小嫻守正結婚在台沒登記 想離婚只有兩條路
## 93 娛樂 財經地產 Kelys & Chirp龜殼藏悅耳鳥鳴 168萬覓品味客
## 94 社會 娛樂 一下車有人墜樓掉在車頂 網友：車牌有密碼
#pred != testtag
正負情緒判斷
library(readxl)
url <- "https://raw.githubusercontent.com/ywchiu/phalanxrtm/master/data/movies.xlsx"
destfile <- "movies.xlsx"
curl::curl_download(url, destfile)
movies <- read_excel(destfile)
View(movies)
movies <- movies[(nchar(movies$content) >=10)& (movies$stars %in% c('1', '5')),]
dim(movies)
## [1] 618 5
movies$status <- as.factor(movies$status )
library(jiebaR)
mixseg <- worker()
yahoo.seg <- lapply(movies$content, function(e)segment(code=e,jiebar=mixseg))
library(tm)
doc <- Corpus(VectorSource(yahoo.seg))
dtm <- DocumentTermMatrix(doc)
dim(dtm)
## [1] 618 4757
ft <- findFreqTerms(dtm, 5)
dtm <- DocumentTermMatrix(doc, control = list(dictionary = ft))
dim(dtm)
## [1] 618 721
convert_counts <- function(x) {
x <- ifelse(x > 0, 1, 0)
x <- factor(x, levels = c(0, 1), labels = c("No", "Yes"))
return(x)
}
dtm.count <- apply(dtm, MARGIN = 2, convert_counts)
dtm.count[1:3,1:3]
## Terms
## Docs 不會 了 動作片
## 1 "Yes" "Yes" "Yes"
## 2 "No" "Yes" "No"
## 3 "No" "No" "No"
m <- as.data.frame(dtm.count)
idx <- sample.int(2, nrow(m), replace=TRUE, prob=c(0.7,0.3))
trainset <- m[idx==1,]
testset <- m[idx==2,]
traintag <- movies[idx==1,]$status
testtag <- movies[idx==2,]$status
traincontent <- movies[idx==1,]$content
testcontent <- movies[idx==2,]$content
library(e1071)
model <- naiveBayes(trainset,traintag )
pred <- predict(model, testset)
sum(testtag == pred, na.rm = TRUE) / length(testtag)
## [1] 0.7554348
table(testtag, pred)
## pred
## testtag bad good
## bad 63 15
## good 30 76
#testcontent[testtag != pred]