library(NLP)
s <- '那我們酸民婉君也可以報名嗎'
s_split <- strsplit(s, '')
bigram <- ngrams(unlist(s_split), 2)
vapply(bigram, paste, '' ,collapse= '')
## [1] "那我" "我們" "們酸" "酸民" "民婉" "婉君" "君也" "也可" "可以" "以報"
## [11] "報名" "名嗎"
trigram <- ngrams(unlist(s_split), 3)
vapply(trigram, paste, '' ,collapse= '')
## [1] "那我們" "我們酸" "們酸民" "酸民婉" "民婉君" "婉君也" "君也可"
## [8] "也可以" "可以報" "以報名" "報名嗎"
article <- "身兼中華職棒聯盟會長的國民黨立委吳志揚今天透露，台灣積極爭取的2017世界棒球經典賽分區預賽主辦權，因為大巨蛋遲遲無法孵出來，確定被競爭對手韓國拿走。吳志揚批評，當初中央政府拿台北市的精華地跟北市府交換，就是希望在大巨蛋現址成立體育園區，就如果北市府要改變使用目的，教育部都漠不關心，部長跟體育署長乾脆下台。"
w <- strsplit(x=article, split ='')
bigram <-ngrams(unlist(w), 2)
bigram.str <- vapply(bigram, paste, "", collapse = "")
tb <- table(bigram.str)
tb[tb>=2]
## bigram.str
## ，就 大巨 北市 巨蛋 市府 吳志 志揚 體育
## 2 2 3 2 2 2 2 2
strsplit(article, '，|。|、')
## [[1]]
## [1] "身兼中華職棒聯盟會長的國民黨立委吳志揚今天透露"
## [2] "台灣積極爭取的2017世界棒球經典賽分區預賽主辦權"
## [3] "因為大巨蛋遲遲無法孵出來"
## [4] "確定被競爭對手韓國拿走"
## [5] "吳志揚批評"
## [6] "當初中央政府拿台北市的精華地跟北市府交換"
## [7] "就是希望在大巨蛋現址成立體育園區"
## [8] "就如果北市府要改變使用目的"
## [9] "教育部都漠不關心"
## [10] "部長跟體育署長乾脆下台"
a.split <- strsplit(article, "、|，|。")
w.split <- strsplit(x=unlist(a.split), split ='')
bigram <- function(w){
bigram <-ngrams(unlist(w), 2)
bigram.str <- vapply(bigram, paste, "", collapse = "")
bigram.str
}
bigram.all <- sapply(w.split, bigram)
tb <- table(unlist(bigram.all))
tb[tb>=2]
##
## 大巨 北市 巨蛋 市府 吳志 志揚 體育
## 2 3 2 2 2 2 2
s <- "當初中央政府拿台北市的精華地跟北市府交換"
s.split <- strsplit(s, '台北市')
paste(unlist(s.split), collapse = "", sep="")
## [1] "當初中央政府拿的精華地跟北市府交換"
removekey <- function(s, keys){
for (key in keys){
s.split = strsplit(s, key)
s = paste(unlist(s.split), collapse = "", sep="")
}
s
}
removekey("當初中央政府拿台北市的精華地跟北市府交換" , c('台北市', '北市府'))
## [1] "當初中央政府拿的精華地跟交換"
ngram.func <- function(w, n){
n.gram <-ngrams(unlist(w), n)
n.gram.str <- vapply(n.gram, paste, "", collapse = "")
n.gram.str
}
ngram.func(strsplit('當初中央政府拿台北市', ''), 2)
## [1] "當初" "初中" "中央" "央政" "政府" "府拿" "拿台" "台北" "北市"
Long Term First
longTermFirst <- function(article, keywords){
for(i in seq(4,2,-1)){
article = removekey(article, keywords)
a.split <- strsplit(article, "、|，|。")
w.split <- strsplit(x=unlist(a.split), split ='')
n.gram.all <- sapply(w.split, function(e) ngram.func(e,i))
tb <- table(unlist(n.gram.all))
candidate <- names(tb[tb>=2])
keywords = c(keywords, candidate)
}
keywords
}
keywords = c()
article <- "身兼中華職棒聯盟會長的國民黨立委吳志揚今天透露，台灣積極爭取的2017世界棒球經典賽分區預賽主辦權，因為大巨蛋遲遲無法孵出來，確定被競爭對手韓國拿走。吳志揚批評，當初中央政府拿台北市的精華地跟北市府交換，就是希望在大巨蛋現址成立體育園區，就如果北市府要改變使用目的，教育部都漠不關心，部長跟體育署長乾脆下台。"
longTermFirst(article, keywords)
## [1] "大巨蛋" "北市府" "吳志揚" "體育"
JiebaR
library(jiebaR)
## Warning: package 'jiebaR' was built under R version 3.3.3
## Loading required package: jiebaRD
## Warning: package 'jiebaRD' was built under R version 3.3.3
s <- ' 那我們酸民婉君也可以報名嗎'
#?worker
mixseg <- worker()
segment(s, jiebar = mixseg)
## [1] "那" "我們" "酸民" "婉君" "也" "可以" "報名" "嗎"
#edit_dict()
#USERPATH
s <- ' 那我們酸民婉君也可以報名嗎'
tagseg <- worker('tag')
segment(s, jiebar = tagseg)
## r r n n d c v y
## "那" "我們" "酸民" "婉君" "也" "可以" "報名" "嗎"
抓取Wiki 同義字詞
library(rvest)
read_html('https://zh.wikipedia.org/wiki/%E5%9C%8B%E7%AB%8B%E6%88%90%E5%8A%9F%E5%A4%A7%E5%AD%B8') %>% html_nodes('b')
抓取Keyword
s <- ' 那我們酸民婉君也可以報名嗎'
keyseg <- worker('keywords', topn = 3)
keyseg <= s
## 11.7392 11.7392 11.7392
## "報名" "婉君" "我們"
新聞辭典擴充
library(rvest)
newsurl <- read_html('http://news.ltn.com.tw/list/breakingnews') %>% html_nodes('a.tit') %>% html_attr('href')
con <- file('C:\\Program Files\\R\\R-3.3.2\\library\\jiebaRD\\dict\\user.dict.utf8', 'a', encoding = "UTF-8")
for (news in newsurl){
keywords <- read_html(news) %>% html_nodes('.keyword a') %>% html_text()
for (w in keywords){
cat(paste(w,'\n'), file= con)
}
}
close(con)
計算TFIDF
a <- c("a")
abb <- c("a", "b", "b")
abc <- c("a", "b", "c")
D <- list(a, abb, abc)
## tfidf('a', a, D) => 0
# tf('a', a) <- 1/1
1/1
## [1] 1
# idf('a', D) <- log(3 / 3)
log(3/3)
## [1] 0
tfidf <- (1/1) * log(3/3)
## tfidf('a', abb, D)
tf <- 1/3
idf <- 0
tfidf <- tf * idf
tfidf
## [1] 0
## tfidf('b', abb, D)
tf <- 2/3
idf <- log(3/2)
tfidf <- tf * idf
tfidf
## [1] 0.2703101
## tfidf('a', abc, D)
tf <- 1/3
idf <- 0
tfidf <- tf * idf
tfidf
## [1] 0
## tfidf('b', abc, D)
tf <- 1/3
idf <- log(3/2)
tfidf <- tf * idf
tfidf
## [1] 0.135155
## tfidf('c', abc, D)
tf <- 1/3
idf <- log(3/1)
tfidf <- tf * idf
tfidf
## [1] 0.3662041
#names(table(abc)) == 'a'
tfidf <- function(t, d, D){
tf <- table(d)[names(table(d)) == t]/ sum(table(d))
idf <- log(length(D) /sum(sapply(D, function(e) t %in% e)))
tf*idf
}
tfidf('a',a,D)
## a
## 0
tfidf('b',abb,D)
## b
## 0.2703101
tfidf('b',abc,D)
## b
## 0.135155
tfidf('c',abc,D)
## c
## 0.3662041
tfidf('b',abc,D)
## b
## 0.135155
Word Frequency Analysis
nuclear <- '核三廠二號機今晨冷卻設備異常跳脫，機組雖自動安全停機，無輻射外洩，但用電恐怕吃緊，台電說今天因為假日，雖然少了核三廠二號機，備轉率還有6.82%，但是明天恢復上班，加上近日高溫用電情況持續攀升，的確會很吃緊，除調度大林電廠三、四號機等全台可用機組積極因應，並協調汽電共生業者在用電尖峰時段增加發電，並呼籲民眾共同協助節約用電。
台電說，核三廠二號機設備異常原因目前正查修中，由於完成檢修還要經原能會審查同意後，機組後續起動也要一段時間，最快要達到發電滿載可能也要幾天時間。
由於氣象局預估，本周受太平洋高壓影響下，天氣持續高溫悶熱，這幾天供電將成一大問題，台電說，在啟動大林三、四號機及需量競價措施情況下，目前預估明日最高用電量仍可達到約3570萬瓩，作為用電餘裕的備轉容量，但少了核三二號機的95.1萬瓩，評估備轉用電約只有125萬瓩、備轉率約3.5%。
台電發言人林德福說，會盡一切努力，儘速完成核三廠二號機設備檢修，並從電力供應及需求端雙管齊下，除確保既有機組正常運轉，也將積極聯繫汽電共生業者協助緊急增購電力，並努力執行需量競價等需求管理措施，也請民眾共同協助節約用電，一起度過今夏用電尖峰挑戰。'
library(jiebaR)
mixseg <- worker()
seg <- segment(nuclear, mixseg)
sort(table(seg), decreasing = TRUE)
## seg
## 用電 二號機 核三廠 機組 三 也 台電說 瓩
## 6 5 4 4 3 3 3 3
## 並 協助 約 要 設備 萬 了 下
## 3 3 3 3 3 3 2 2
## 大林 四號 由於 目前 共生 共同 吃緊 在
## 2 2 2 2 2 2 2 2
## 尖峰 努力 完成 汽電 的 持續 除 高溫
## 2 2 2 2 2 2 2 2
## 情況 措施 異常 備轉 幾天 發電 會 業者
## 2 2 2 2 2 2 2 2
## 節約用電 達到 預估 需求 需量 積極 檢修 競價
## 2 2 2 2 2 2 2 2
## 125 3.5 3570 6.82 95.1 一大 一切 一段時間
## 1 1 1 1 1 1 1 1
## 一起 上班 也將 今天 今夏 今晨 仍 及
## 1 1 1 1 1 1 1 1
## 天氣 太平洋 少 加上 只有 可 可用 可能
## 1 1 1 1 1 1 1 1
## 台電 外洩 本周 正查 正常 民眾 用電量 全台
## 1 1 1 1 1 1 1 1
## 同意 因為 因應 安全 自動 但 但少 但是
## 1 1 1 1 1 1 1 1
## 作為 冷卻 並從 供電 協調 受 呼籲 明天
## 1 1 1 1 1 1 1 1
## 明日 林 的確 近日 度過 很 後 後續
## 1 1 1 1 1 1 1 1
## 恢復 挑戰 既有 修中 原因 容量 恐怕 時段
## 1 1 1 1 1 1 1 1
## 時間 核 氣象局 能會 起動 高壓 假日 停機
## 1 1 1 1 1 1 1 1
## 問題 啟動 執行 將成 率 這 備 備轉率
## 1 1 1 1 1 1 1 1
## 悶熱 最快 最高 無輻射 發言人 等 評估 經原
## 1 1 1 1 1 1 1 1
## 跳脫 運轉 電力 電力供應 電廠 滿載 盡 端
## 1 1 1 1 1 1 1 1
## 管理 緊急 說 增加 增購 審查 影響 德福
## 1 1 1 1 1 1 1 1
## 確保 調度 請民眾 餘裕 儘速 機及 機等 聯繫
## 1 1 1 1 1 1 1 1
## 還有 還要 雖 雖然 轉 雙管齊下 攀升
## 1 1 1 1 1 1 1
tb <- table(seg)
library(wordcloud2)
## Warning: package 'wordcloud2' was built under R version 3.3.3
tb2 <- tb[tb >= 3 & nchar(names(tb)) >= 2]
wordcloud2(tb2, shape='star')
#tb2
?wordcloud2
## starting httpd help server ...
## done
Bag of words
s <- "大巨蛋案對市府同仁下封口令？柯P否認"
mixseg <- worker()
segment(code= s , jiebar = mixseg)
## [1] "大巨蛋" "案" "對" "市府" "同仁" "下" "封口令" "柯P"
## [9] "否認"
English Term Document Matrix
library(tm)
## Warning: package 'tm' was built under R version 3.3.3
e3 <- 'Hello, I am David. I have taken over 100 courses ~~~'
e3.list = strsplit(e3, ' ')
e3.corpus <- Corpus(VectorSource(e3.list))
e3.dtm <- DocumentTermMatrix(e3.corpus)
inspect(e3.dtm)
## <<DocumentTermMatrix (documents: 1, terms: 7)>>
## Non-/sparse entries: 7/0
## Sparsity : 0%
## Maximal term length: 7
## Weighting : term frequency (tf)
## Sample :
## Terms
## Docs 100 courses david have hello over taken
## 1 1 1 1 1 1 1 1
dtm <- DocumentTermMatrix(e3.corpus, control=list(wordLengths=c(1, 20)))
inspect(dtm)
## <<DocumentTermMatrix (documents: 1, terms: 10)>>
## Non-/sparse entries: 10/0
## Sparsity : 0%
## Maximal term length: 7
## Weighting : term frequency (tf)
## Sample :
## Terms
## Docs 100 am c courses david have hello i over taken
## 1 1 1 1 1 1 1 1 2 1 1
doc <- tm_map(e3.corpus, removeNumbers)
doc <- tm_map(doc, removePunctuation)
dtm <- DocumentTermMatrix(doc)
inspect(dtm)
## <<DocumentTermMatrix (documents: 1, terms: 6)>>
## Non-/sparse entries: 6/0
## Sparsity : 0%
## Maximal term length: 7
## Weighting : term frequency (tf)
## Sample :
## Terms
## Docs chello courses david have over taken
## 1 1 1 1 1 1 1
e1 <- 'this is a book'
e2 <- 'this is my car'
e.list <- strsplit(c(e1,e2), ' ')
e.corpus <- Corpus(VectorSource(e.list))
e.dtm <- DocumentTermMatrix(e.corpus)
inspect(e.dtm)
## <<DocumentTermMatrix (documents: 2, terms: 3)>>
## Non-/sparse entries: 4/2
## Sparsity : 33%
## Maximal term length: 4
## Weighting : term frequency (tf)
## Sample :
## Terms
## Docs book car this
## 1 1 0 1
## 2 0 1 1
中文詞頻矩陣
library(jiebaR)
mixseg = worker()
s <- "大巨蛋案對市府同仁下封口令？柯P否認"
s1 <- "柯P市府近來飽受大巨蛋爭議"
s.vec <- segment(code= s , jiebar = mixseg)
s1.vec <- segment(code= s1 , jiebar = mixseg)
s.corpus = Corpus(VectorSource(list(s.vec, s1.vec)))
s.dtm <- DocumentTermMatrix(s.corpus)
inspect(s.dtm)
## <<DocumentTermMatrix (documents: 2, terms: 7)>>
## Non-/sparse entries: 9/5
## Sparsity : 36%
## Maximal term length: 3
## Weighting : term frequency (tf)
## Sample :
## Terms
## Docs 大巨蛋 市府 同仁 爭議 近來 封口令 飽受
## 1 1 1 1 0 0 1 0
## 2 1 1 0 1 1 0 1
詞頻矩陣的應用
# https://github.com/ywchiu/rtibame/blob/master/data/applenews.RData
load('applenews.RData')
dim(applenews)
## [1] 1500 5
library(jiebaR)
mixseg <- worker()
#segment(applenews$article[1], mixseg)
article.list <- lapply(applenews$content, function(e) segment(e, mixseg))
doc <- Corpus(VectorSource(article.list))
dtm <- DocumentTermMatrix(doc, control = list(WordLengths=c(2,Inf)))
dim(dtm)
## [1] 1500 39069
#applenews$title
#dtm$dimnames$Terms
findFreqTerms(dtm , 200, 300)
## [1] "已經" "男子" "要求" "調查" "相關" "人員" "其中"
## [8] "照片" "今\xa6" "未來" "政府" "第\xa4" "這些" "媒體"
## [15] "影響" "民眾" "國家" "希望" "最後" "工\xa7" "如果"
## [22] "是\xa7" "經濟" "kobe" "不是" "不過" "這個" "這樣"
## [29] "不\xb7" "市府" "還是" "萬元" "大巨蛋"
findAssocs(dtm, "大巨蛋", 0.5)
## $大巨蛋
## 遠雄 解約 市府 展延 工期 collapse 口稱 已朝
## 0.86 0.78 0.74 0.72 0.70 0.69 0.69 0.69
## 已無太多 心叵測 王貞治 他怕 若不\xc4 核子彈 問及此事 理還亂
## 0.69 0.69 0.69 0.69 0.69 0.69 0.69 0.69
## 連通 期議約 菸廠 進度條 聘書 運棄 孵出 蔡宗易
## 0.69 0.69 0.69 0.69 0.69 0.69 0.69 0.69
## 談盤 應\xa5 遽增 歸責 難解 觸礁 議約 無解
## 0.69 0.69 0.69 0.69 0.69 0.69 0.69 0.68
## 停工 方向 五大 溫室 拋出 南線 貿然 和\xa5
## 0.64 0.62 0.62 0.61 0.61 0.60 0.60 0.60
## 量體 逾期 逃生 違約 實地 懶人 370 容納
## 0.59 0.56 0.55 0.54 0.53 0.52 0.51 0.51
dtm.remove <- removeSparseTerms(dtm, 0.99)
dim(dtm.remove)
## [1] 1500 1750
head(dtm.remove$dimnames$Terms)
## [1] "2000" "500" "已經" "之際" "友人" "方式"
Article Similarity
a <- c(1,0,0,0,0,1)
b <- c(1,0,0,1,0,0)
# dist 1
sum(a - b)
## [1] 0
# dist 2 => Euclidean Distance
sqrt(sum((a - b) ^ 2 ))
## [1] 1.414214
# dist 3
a <- c(1,0,0,0,0,0,0,0,0,0,0,0,0)
b <- c(1,1,1,1,1,1,1,1,1,1,1,1,1)
sqrt(sum((a - b) ^ 2 ))
## [1] 3.464102
library(proxy)
## Warning: package 'proxy' was built under R version 3.3.3
##
## 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)
d <- proxy::dist(rbind(a,b), method = 'cosine')
as.matrix(d)
## a b
## a 0.00000000 0.06180581
## b 0.06180581 0.00000000
dim(dtm.remove)
## [1] 1500 1750
dtm_dist <- proxy::dist(as.matrix(dtm.remove), method='cosine')
dist_mat <- as.matrix(dtm_dist)
applenews$title[1:24]
## [1] "【更新】搶2.2萬彩券刮中1.4萬 沒發財還得入獄"
## [2] "拿到澳洲護照後 他放火燒中國護照"
## [3] "【特企】房市大追擊- 租屋這些事情要小心"
## [4] "【央廣RTI】美菲軍演 美防長南海登艦"
## [5] "全球最閃牽手夫妻 絕美禮服出自台灣…"
## [6] "公司遭搜索 浩鼎籲檢調勿公開商業機密"
## [7] "【央廣RTI】每318秒就有1人罹癌 大腸癌名列第一"
## [8] "垃圾掉滿地 村民請神明幫忙"
## [9] "【熊本強震】取消去九州 華航5月8日前退改票免手續費"
## [10] "麵龜摻非工業色素 千顆不良品早下肚"
## [11] "同居人女兒熟睡 淫男伸狼爪"
## [12] "岡山星巴克明開張 前100人咖啡免費"
## [13] "揚智攜手DishTV 搶攻印度衛星電視市場"
## [14] "又要下雨了 中南部6縣市大雨特報"
## [15] "韓留學生超羨慕 「台灣人失業可以賣雞排」 "
## [16] "澎恰恰收女弟子 拱當台灣第一名伶"
## [17] "手機截圖的極限在哪？ 鄉民接力完成"
## [18] "陸委會跨部會議確認 下周登陸展開肯亞案協商"
## [19] "【驚險有片】BMW撞翻撞公車 後方機車神穿越"
## [20] "熊本強震驚呆了 返台旅客：整晚不敢睡"
## [21] "【唱新聞】詐騙嗎？R.O.C.有CHINA但不是CHINA"
## [22] "封口費不足還找小四 富翁遭小三爆不舉"
## [23] "LINE更綠了 貓熊新角色曝光"
## [24] "【更新】翁啟惠進府報告浩鼎案 堅辭與否受矚目"
#head(order(dist_mat[6,]))
# Find article similiar to article 20
applenews$title[head(order(dist_mat[20,]))]
## [1] "熊本強震驚呆了 返台旅客：整晚不敢睡"
## [2] "【法廣RFI】日本熊本地震 已知9死餘震不斷"
## [3] "【更新】熊本強震9死逾1千傷 威力日史上第4"
## [4] "熊本再震規模6.4 無海嘯危險 "
## [5] "日本預警系統多強大 正妹記者超有感"
## [6] "熊本強震 台灣氣象局也測到震波"