Word Vector & Word embedding 初探 - with n-Gram & GLOVE Model
終於又有新題材可以分享了，每天在公司歷練（？），下班時常想著要爬起來自我學習，但現實總有點動力骨感，打開的不是筆電，是switch.....不過人生嘛...努力就是想到的時候再做，也是一種進步。
不胡說八道了，進入主題Word Embedding吧，繼上次分享詞頻分析之後，心中對於text mining真的是想著總有一天我還要在更加深入的學習，所以今天要努力分享嚕~
1. 什麼是Word Embedding?
當你打開手機，輸入"一瓶"，螢幕上自動跳出 "啤酒" "汽水" 等名詞；或者郭台銘之於鴻海就像張忠謀之於台積電。
諸如此類讓文字彼此之間有所連結跟類似的邏輯，就是Word Embedding的應用。
透過分析一份完整的語料 (Corpus) 建立詞向量(Word Vector) 進而推論出詞語之間的邏輯語關係，就是Word Embedding的功能。
2. 和詞頻分析不同之處?
詞頻分析主要透過斷詞進而找出詞頻，並抓出相似的文件或者分析出文件的主題。
而詞向量主要在語料中的字詞間找出特定的邏輯和關係。
3. 貝式機率 & 馬可夫練
貝式機率一直是推論關係很好的辦法，
P(w1,w2,w3,w4......,wn) = P(w1) * P(w2|w1) * P(w3|w1,w2) * .........P(wn|w1,w2,w3......,wn-1)
P(w1,w2,w3,w4......,wn) <-- w1~wn 共同出現的機率
P(w1) <-- w1 出現之機率
P(w2|w1) <-- 給了w1後，w2出現的機率；P(w3|w1,w2) 給定w1,w2後，w3出現的機率
P(wn|w1,w2,w3......,wn-1) <-- 同理類推，給定w1~wn-1後，wn出現的機率。
如此一來便能推斷字詞之間的關係，但這時發現，如果字數太多，便會很耗費計算效能。
這時便可參考馬可夫鍊的假設，目前出現的詞，僅和前幾個出現的詞語有關係。
其實很好推論，馬可夫鍊也被應用於棒球投手的配球，假設一場球賽先發投手投了120球，我們要推論投手在最後10球的配球，並不會回溯到第一球或者回溯到他生涯的第一場先發，我們會根據他在前幾球的配球做後續推論，就是這樣的道理。
於是可以改寫成:
P(w1~wn) = P(wi | Wi-n+1,......,Wi-1)
4. N-gram model
N就是代表，考慮前N個詞的影響，例如: 麥可就是丹尼爾，
P(x| 麥克) , 若 n=2,我們就可以知道麥克出現在"就"前面的機率最高，依循這樣的循環下去，下一個我們就會開始尋找 P(x|可就)的x為哪個字詞最高?
我們可以藉由這樣的方式推明白字詞的關係，不過缺點是當字數一多，耗能也大。
n = 2，20000的語料來看，便會有400000000個字節。
4. Glove Model
N-gram表示考慮前N個詞的影響，但生活中總會有碰到需要透過上下文才有辦法了解到意義的字詞，例如: "麥可真的很聰明，連算術都不會" ，我們單看聰明會以為是稱讚，但其實看到下文才會知道，這裡的聰明是種反諷。
因此GloVe的全名即稱為: Global Vectors for Word Representation，Global vector即是上下文的意思，透過上下文了解Word的Presentation。非常簡單明瞭。
在這裡也交待一下數學原理：
1.透過完整的Corpus建立Co-ocurrence Matrix，
矩陣中每一個元素稱為Xij, i代表單詞，j代表對應單詞在特定大小的窗口共同出現的次數，和一般計算頻率的方式不同，這裡將以1/d取代頻率，d就是代表distance距離，也就是說該理論重視上下文推斷意義，不過一樣也認為距離近的字詞對彼此之間的影響較大。
"In all cases we use a decreasing weighting function, so that word pairs that are d words apart contribute 1/d to the total count."
原文如是說哩~~~~
2. 找出符合目標的loss function
3. 得到詞向量
4. 了解詞與詞之間的關係
目標函數:
重中之重在於最後一列，我們給了固定的詞之後，可以透過比例去檢查該詞與哪一個詞更為相近，例如Solid和Ice的關係更為接近，故最後比率高於1，而Gas相對跟Steam較為接近，故比率低於1，而和兩個字詞差不多關係或者兩者皆無特別關係的話，比率接近1。從理論可以得知透過比率去了解詞向量的關係可能會是更洽當的想法。
最終目標函數
考慮貢獻高低的狀態
5. Apply in R
library(text2vec)
library(tidyverse)
library(jiebaR)
library(knitr)
library(magrittr)
library(widyr)
library(tidytext)
library(tm)
library(igraph)
library(ggnetwork)
library(textrank)
#讀檔
Video <- read_csv("C:/Users/michael/Desktop/NLP/Text rank_RAKE_TFIDF/201909_video_info.csv")
Video <- Video[,c(2,5)]
head(Video)
> head(Video)
# A tibble: 6 x 2
items.snippet.channelT~ items.snippet.description
<chr> <chr>
1 蔡阿嘎 "【下方有完整25間台南美食店家資訊喔】挖出台南人的口袋美食，台南人都吃這個啦！哈哈哈\n► 訂閱蔡阿嘎Life頻道：http://p~
2 蔡阿嘎 "訂閱頻道+留言，就抽出20位，可以獲得從澳門帶回來的名產「豬肉乾」喔!!!!! (咦? 哪裡怪怪的? 哈哈哈哈)\n► 訂閱蔡阿嘎L~
3 蔡阿嘎 "搶先搶先！訂閱+留言，日本環球影城2019 Universal Cool Japan，破萬元的10樣限定商品要送大家!!!!!\n►~
4 蔡阿嘎 "(影片中的新竹24家最推美食，在下方有完整清單喔)\n► 訂閱蔡阿嘎Life頻道：http://pics.ee/AGaLife\n►~
5 蔡阿嘎 "10元20元就能吃一餐，超便宜美食天堂！(美食景點地址，在下方有列出來喔！)\n► 訂閱蔡阿嘎Youtube：http://pics~
6 蔡阿嘎 "► 訂閱蔡阿嘎Youtube：http://pics.ee/AGaU2\n► 馬叔叔FaceBook：https://ppt.cc/~
#Regex part
url_pattern <- "http[s]?://(?:[a-zA-Z]|[0-9]|[$-_@.&+]|[!*\\(\\),]|(?:%[0-9a-fA-F][0-9a-fA-F]))+"
Video$items.snippet.description <- Video$items.snippet.description %>% str_replace_all(url_pattern,"")
#Regex 消除Email
email <- "\\S*@\\S*"
Video$items.snippet.description <- Video$items.snippet.description %>% str_replace_all(email,"")
symbols <- c("《", "》", "【", "】", "｜", "(",")",
"®", "\n", "？", "@", "#", "?", "！", "!","►","↓","：","➔","-","＊","▷","◅",":","~","●","▻")
Video$items.snippet.description <- gsub(
paste(symbols, collapse = "|"),
"",
Video$items.snippet.description
)
Video$items.snippet.description <- removeNumbers(
as.character(Video$items.snippet.description))
#消除表情符號
emoji <- "[\U{1F300}-\U{1F6FF}]"
Video$items.snippet.description <- Video$items.snippet.description %>% str_replace_all(emoji,"")
#Setting special word , stop words and my dictionary
seg <- worker(stop_word = 'C:/Users/michael/Desktop/NLP/Word_Embedding/hwstop.txt',
user = 'C:/Users/michael/Desktop/NLP/Word_Embedding/hwmydict.txt')
result <- tibble(
text = sapply(
as.character(Video$items.snippet.description),
function(char) segment(char, seg) %>% paste(collapse = " ")
)
)
result$text <- sapply(result$text,
function(x){
return(str_replace_all(x,"Mao|MaoMao|maomao","毛毛"))}
)
result$text <- sapply(result$text,
function(x){
return(str_replace_all(x,"Joeman","九麵"))}
)
result$text <- sapply(result$text,
function(x){
return(str_replace_all(x,"劉沛|thePierre|遊沛","劉沛"))}
)
result$text <- sapply(result$text,
function(x){
return(str_replace_all(x,"阿倫頻道|阿倫|Alan|alan","阿倫"))}
)
result$text <- sapply(result$text,
function(x){
return(str_replace_all(x,"阿倫頻道|阿倫|Alan|alan","阿倫"))}
)
result$text <- sapply(result$text,
function(x){
return(str_replace_all(x,"展榮展瑞|展榮|展瑞","展榮展瑞"))}
)
result$text <- sapply(result$text,
function(x){
return(str_replace_all(x,"Facebook|facebook|FB|fb|FaceBook","臉書"))}
)
result$text <- sapply(result$text,
function(x){
return(str_replace_all(x,"IG|instragram","哀居"))}
)
result$text <- sapply(result$text,
function(x){
return(str_replace_all(x,"twitter|Twitter","推特"))}
)
result$text <- sapply(result$text,
function(x){
return(str_replace_all(x,"VLOG|Vlog","生活影片"))}
)
result$text <- sapply(result$text,
function(x){
return(str_replace_all(x,"Subscribe","訂閱"))}
)
result$text <- sapply(result$text,
function(x){
return(str_replace_all(x,"[A-z[:punct:][:digit:]]",""))}
)#Modeling
tokens <- space_tokenizer(result$text)
it <- itoken(tokens, progressbar = FALSE)
vocab <- create_vocabulary(it)
vocab <- prune_vocabulary(vocab, term_count_min = 5L)
vectorizer <- vocab_vectorizer(vocab)
tcm <- create_tcm(it, vectorizer, skip_grams_window = 10L)
set.seed(500)
glove = GlobalVectors$new(rank = 50, x_max = 10)
wv_main = glove$fit_transform(tcm, n_iter = 20, convergence_tol = 0.01, n_threads = 8)
INFO [14:39:55.782] epoch 1, loss 0.3443
INFO [14:39:55.825] epoch 2, loss 0.1460
INFO [14:39:55.847] epoch 3, loss 0.1018
INFO [14:39:55.861] epoch 4, loss 0.0817
INFO [14:39:55.876] epoch 5, loss 0.0686
INFO [14:39:55.892] epoch 6, loss 0.0593
INFO [14:39:55.907] epoch 7, loss 0.0523
INFO [14:39:55.922] epoch 8, loss 0.0467
INFO [14:39:55.937] epoch 9, loss 0.0423
INFO [14:39:55.953] epoch 10, loss 0.0386
INFO [14:39:55.968] epoch 11, loss 0.0355
INFO [14:39:55.984] epoch 12, loss 0.0328
INFO [14:39:55.999] epoch 13, loss 0.0305
INFO [14:39:56.013] epoch 14, loss 0.0285
INFO [14:39:56.028] epoch 15, loss 0.0268
INFO [14:39:56.043] epoch 16, loss 0.0252
INFO [14:39:56.058] epoch 17, loss 0.0238
INFO [14:39:56.073] epoch 18, loss 0.0226
INFO [14:39:56.088] epoch 19, loss 0.0215
INFO [14:39:56.102] epoch 20, loss 0.0205
wv_context = glove$components word_vectors = wv_main + t(wv_context) get_similar_word <- function(x){ cos_sim = sim2(x = word_vectors, y = word_vectors[x,,drop=FALSE], method = "cosine", norm = "l2") cat('---',x,'---\n') return(head(sort(cos_sim[,1], decreasing = TRUE), 20)) } get_similar_word('毛毛') --- 毛毛 --- 毛毛 叫 你好 每週 一個 女生 新片 愛看 點我 1.0000000 0.7367908 0.5972205 0.5950850 0.5791051 0.5751691 0.5619604 0.5230970 0.5170412 住 推特毛毛 下面 世界 高中畢業 相關 日本 得看 台灣女生 0.4846525 0.4800262 0.4557407 0.4420519 0.4253715 0.4179618 0.4097638 0.4046754 0.4041196 미 愛 0.4039344 0.4016076 get_similar_word('九麵') --- 九麵 --- 九麵 貴賓室 飛機 夾娃娃 九件 體驗 專頁 筆電 全世界 1.0000000 0.6026659 0.5983328 0.5711459 0.5593035 0.5578135 0.5486513 0.5298209 0.5231434 販賣機 訂閱 系列 與 全職 打槍 餐廳 推特毛毛 餐 0.5209183 0.5198733 0.4816135 0.4772236 0.4606588 0.4599972 0.4404813 0.4293975 0.4247202 第二季 百元 0.4212950 0.4209033
get_correlation <- function(w1, w2, w3){
result <- word_vectors[w1, , drop = FALSE] -
word_vectors[w2, , drop = FALSE] +
word_vectors[w3, , drop = FALSE]
cos_sim = sim2(x = word_vectors, y = result, method = "cosine", norm = "l2")
cat(w1,'-->', w2, ' = ', w3, '-->\n')
return(head(sort(cos_sim[,1], decreasing = TRUE), 20))
}
get_correlation("蔡阿嘎", "食尚玩嘎", "阿倫")
蔡阿嘎 --> 食尚玩嘎 = 阿倫 -->
阿倫 頻道 臉書 折 事 租借 影片 專頁 號碼
0.8684918 0.5185187 0.5135866 0.5110766 0.5044175 0.4967886 0.4904883 0.4828033 0.4800988
件 遊戲 想租 實際 貼圖 愛 這 阿格 優惠
0.4736211 0.4626157 0.4526334 0.4490765 0.4427615 0.4362950 0.4331490 0.4326934 0.4279728
搜尋 好友
0.4100710 0.4022639
plot_correlation <- function(w1, w2, w3, w4, dim, num){
w_1 <- word_vectors[w1,,drop=FALSE]
w_2 <- word_vectors[w2,,drop=FALSE]
w_3 <- word_vectors[w3,,drop=FALSE]
w_4 <- word_vectors[w4,,drop=FALSE]
set.seed(500)
TrainP <- rbind(w_1,w_2,w_3,w_4)
PCA <- prcomp(TrainP)
d <- cbind(PCA$x[,c(1,2)]) %>% as.data.frame()
d$group <- ifelse(d[,dim]<num, '1','0')
d$name <- rownames(d)
ggplot(aes(PC1, PC2), data = d) +
geom_point(aes(colour = group)) +
geom_line(aes(group = group), linetype = 'dashed') +
geom_text(aes(label = name), position = position_stack(vjust = 0.5),
family="LiHei Pro" ) +
labs(title = paste(w1, w2, w3, w4)) +
theme(text=element_text(family="LiHei Pro"))
}plot_correlation('劉沛', '歐洲', '毛毛' ,'日本', 'PC1', 0)
plot_correlation("劉沛","歐洲","九麵","販賣機", 'PC1', 1)
plot_correlation("九麵","筆電","蔡阿嘎","食尚玩嘎", 'PC1', 0)
留言
張貼留言