75-R对邮件进行排序实现智能收件箱
2020-06-02 本文已影响0人
wonphen
《机器学习-实用案例解析》学习笔记
1、数据准备
数据下载：https://spamassassin.apache.org/old/publiccorpus/
参考谷歌Gmail服务，他们将邮件特征分为社交特征、内容特征、线程特征和标签特征。我们的数据中没有详细的时间戳及无法得知用户何时做了何种响应。但我们可以测量接收量，因此可以假设这种单向度量能够较好地代表数据中的社交特征类型。
社交特征。用同一主题邮件的发送间隔时间来决定邮件的重要性，很自然的方法就是计算收件人在收到邮件后过了多久才处理这封邮件，在给定特征集下，这个平均时间越短，说明邮件在所属类型中的重要性越高。
线程特征。匹配线程特征词项，比如“RE:”，线程很活跃，那么就比不活跃的更重要。
内容特征。抽取邮件正文中的词项，新来一封邮件当它们包含更多的特征词项时，说明更重要。
标签特征。暂不考虑。
我们只需要正常的邮件数据，对所有邮件信息按时间排序，然后将数据拆分为训练集和测试集。第一部分用于训练排序算法，第二部分用来测试模型效果。
> library(pacman)
> p_load(chinese.misc,stringr,dplyr,ggplot2)
> easy.ham.files <- dir_or_file("./easy_ham")
> easy.ham2.files <- dir_or_file("./easy_ham_2")
> hard.ham.files <- dir_or_file("./hard_ham")
> hard.ham2.files <- dir_or_file("./hard_ham_2")
>
> emails <- c(easy.ham.files,easy.ham2.files,
+ hard.ham.files,hard.ham2.files) %>% unique()
邮件头信息：
From：这封邮件来自谁？使用来自该发件人的邮件量作为社交特征的表征量。
Date：何时收到这封邮件？作为时间度量。
Subj：这是一个活跃线程吗？如果来自一个已知线程，那么可以确定其活跃程度以作为线程特征。
正文：邮件内容是什么？找到最常出现的词项作为内容特征。
构造函数，在读取时从每一封邮件中抽取如上内容，将半结构化数据转换为高度结构化的训练数据集。
> pre_fun <- function(string) {
+ string <- str_replace_all(string,"\\s+"," ")
+ string <- tolower(string)
+ string <- str_replace_all(string,"[^a-z]"," ")
+ string <- str_replace_all(string,"\\s+"," ")
+ string <- str_trim(string,side = "both")
+ return(string)
+ }
>
> # 数据读取函数
> read_fun <- function(f) {
+ if (!str_detect(f,"cmds")) {
+ f.txt <- readr::read_file(f)
+ # 抽取From
+ from <- str_extract_all(f.txt,"From:(.*)") %>% unlist
+ from <- ifelse(length(from>1),from[str_detect(from,"@")],from)
+ # 如果检测到邮箱地址在<>中，提取
+ if(str_detect(from,"<")) {
+ from <- str_extract(from,"<+(.*?)+>") %>%
+ str_remove_all("<|>")
+ } else {
+ # 如果没有检测到尖括号，清除From和括号中的内容
+ from <- str_remove_all(from,"From: |\\(.*?\\)")}
+ # 抽取Date
+ date <- str_extract(f.txt,"Date:(.*)") %>%
+ str_remove("Date: ")
+ # 抽取Subject
+ subject <- str_extract(f.txt,"Subject:(.*)") %>%
+ str_remove("Subject: ")
+ # 按第一个空行切割，抽取邮件正文
+ message <- str_split_fixed(f.txt,"\n\n",2)
+ message <- message[1,2] %>% pre_fun
+ df <- tibble(from=from,date=date,subject=subject,message=message,id=f)
+ return(df)
+ }
+ }
> dt <- sapply(emails,read_fun) %>%
+ do.call(bind_rows,.) %>% distinct()
> head(dt)
## # A tibble: 6 x 5
## from date subject message id
## <chr> <chr> <chr> <chr> <chr>
## 1 kre@munna~ Thu, 22 A~ Re: New Sequen~ date wed aug from ~ D:/R/data_set/sp~
## 2 steve.bur~ Thu, 22 A~ [zzzzteana] RE~ martin a posted ta~ D:/R/data_set/sp~
## 3 timc@2ubh~ Thu, 22 A~ [zzzzteana] Mo~ man threatens expl~ D:/R/data_set/sp~
## 4 monty@ros~ Thu, 22 A~ [IRR] Klez: Th~ klez the virus tha~ D:/R/data_set/sp~
## 5 Stewart.S~ Thu, 22 A~ Re: [zzzzteana~ in adding cream to~ D:/R/data_set/sp~
## 6 martin@sr~ Thu, 22 A~ Re: [zzzzteana~ i just had to jump~ D:/R/data_set/sp~
> mice::md.pattern(dt)
检查缺失值
## from date message id subject
## 6944 1 1 1 1 1 0
## 7 1 1 1 1 0 1
## 0 0 0 0 7 7
subject变量存在7个缺失值。
另外，我们还需要针对具体变量做更详细的检查。
> # 检查from中是否都存在@符号
> table(str_detect(dt$from,"@"))
##
## TRUE
## 6951
说明邮箱中发件人信息从邮箱格式上看是没有问题的。
随机查看30个date列的值：
> dt$date[sample(nrow(dt),30)]
## [1] "Tue, 27 Aug 2002 21:36:22 -0400"
## [2] "Fri, 9 Aug 2002 20:09:02 -0700"
## [3] "Thu, 25 Jul 2002 04:56:39 -0400 (EDT)"
## [4] "Sat, 24 Aug 2002 10:57:13 -0400 (EDT)"
## [5] "Fri, 04 Oct 2002 10:03:14 +0300"
## [6] "Mon, 2 Sep 2002 09:33:47 -0400"
## [7] "Mon, 09 Sep 2002 12:29:51 -0400"
## [8] "Thu, 22 Aug 2002 12:39:47 -0300"
## [9] "Wed, 28 Aug 2002 07:45:18 -0700"
## [10] "Tue, 24 Sep 2002 08:00:11 -0000"
## [11] "Sat, 03 Aug 2002 22:31:23 -0700"
## [12] "Mon, 07 Oct 2002 08:00:59 -0000"
## [13] "20 Jul 2002 10:50:58 +1200"
## [14] "Wed, 10 Jul 2002 16:34:42 -0700 (PDT)"
## [15] "Tue, 08 Oct 2002 13:28:56 +0100"
## [16] "Tue, 20 Aug 2002 16:30:38 -0300"
## [17] "Thu, 26 Sep 2002 08:01:56 -0000"
## [18] "Tue, 1 Oct 2002 14:16:16 +0300 (EEST)"
## [19] "Mon, 30 Sep 2002 15:55:47 -0400"
## [20] "Thu, 18 Jul 2002 17:20:20 -0700 (PDT)"
## [21] "Tue, 20 Aug 2002 15:31:17 +0100"
## [22] "03 Oct 2002 21:58:55 -0400"
## [23] "Sun, 01 Dec 2002 18:03:10 -0700"
## [24] "Thu, 18 Jul 2002 13:46:12 -0700 (PDT)"
## [25] "Sun, 29 Sep 2002 08:00:02 -0000"
## [26] "Thu, 26 Sep 2002 15:32:19 -0000"
## [27] "Wed, 31 Jul 2002 16:37:42 +0100"
## [28] "Mon, 12 Aug 2002 09:29:38 +0100"
## [29] "Sat Sep 7 04:38:51 2002"
## [30] "Wed, 09 Oct 2002 08:00:35 -0000"
多抽样几次，可以发现date列的格式比较多，比如
"Sun, 15 Sep 2002 21:22:52 -0400"，
"01 Oct 2002 19:22:16 -0700"，
"Wed, 17 Jul 2002 20:58:30 -0700 (PDT)"，
"Tue, 24 Sep 2002 08:46:08 EDT"，
"Tue Sep 10 10:29:19 2002"，
需要重新整理成统一的格式。构建日期转换函数：
> trans_date <- function(string) {
+
+ string <- str_split(string," ") %>% unlist %>%
+
+ str_remove_all("Sun|Mon|Tue|Wed|Thu|Fri|Sat|,") %>%
+
+ str_remove_all("[+|-](.*)") %>% str_remove_all("\\(.*\\)") %>%
+
+ str_remove_all("[A-Z]{2,}")
+ year <- string[nchar(string)==4]
+ month <- string[nchar(string)==3]
+ day <- string[nchar(string)==1|nchar(string)==2]
+ time <- string[nchar(string)==8]
+ string.new <- paste(day,month,year,time) %>% lubridate::dmy_hms()
+ return(string.new)
+ }
>
> dt$date <- dt$date %>% trans_date
> dt$date[sample(nrow(dt),10)]
## [1] "2002-07-15 03:00:01 UTC" "2002-10-08 08:01:21 UTC"
## [3] "2002-08-29 08:32:08 UTC" "2002-09-25 08:00:22 UTC"
## [5] "2002-10-08 08:01:05 UTC" "2002-09-12 09:05:50 UTC"
## [7] "2002-09-30 22:00:02 UTC" "2002-08-06 16:50:07 UTC"
## [9] "2002-07-10 16:05:42 UTC" "2002-10-08 08:00:31 UTC"
转换后的结果很规整，完全符合我们的要求。
> head(dt)
## # A tibble: 6 x 5
## from date subject message id
## <chr> <dttm> <chr> <chr> <chr>
## 1 kre@munn~ 2002-08-22 18:26:25 Re: New Sequ~ date wed aug fr~ D:/R/data_set~
## 2 steve.bu~ 2002-08-22 12:46:18 [zzzzteana] ~ martin a posted~ D:/R/data_set~
## 3 timc@2ub~ 2002-08-22 13:52:38 [zzzzteana] ~ man threatens e~ D:/R/data_set~
## 4 monty@ro~ 2002-08-22 09:15:25 [IRR] Klez: ~ klez the virus ~ D:/R/data_set~
## 5 Stewart.~ 2002-08-22 14:38:22 Re: [zzzztea~ in adding cream~ D:/R/data_set~
## 6 martin@s~ 2002-08-22 14:50:31 Re: [zzzztea~ i just had to j~ D:/R/data_set~
现在数据基本转换成了我们需要的样子，下面继续做一些必要的转换。将from和subject全部转换为小写，并且将整个数据框按date列排序。最后将数据拆分为训练集和测试集。
> dt$from <- tolower(dt$from)
> dt$subject <- tolower(dt$subject)
> dt <- arrange(dt,date)
>
> set.seed(123)
> ind <- sample(1:nrow(dt),nrow(dt)*0.8,replace = T)
> train <- dt[ind,]
> test <- dt[-ind,]
2、邮件发送量权重计算策略
来自同一地址（from）的邮件越频繁，说明该邮件越重要。所以按邮件中的from计数来设计用于重要性排序的权重。
> p_load(ggplot2)
> from.weight <- train[,"from"] %>% group_by(from) %>%
+ summarise(freq=n()) %>% arrange(-freq)
> head(from.weight)
## # A tibble: 6 x 2
## from freq
## <chr> <int>
## 1 rssfeeds@example.com 498
## 2 rssfeeds@spamassassin.taint.org 468
## 3 tomwhore@slack.net 112
## 4 garym@canada.com 104
## 5 pudge@perl.org 102
## 6 matthias@egwn.net 86
> # 查看邮件数量最多的前30个账号
> from.weight %>% top_n(30) %>%
+ ggplot(aes(freq,reorder(from,freq))) +
+ geom_bar(stat = "identity") +
+ theme_bw() +
+ labs(x="接收邮件数量",y="")
最密切的发件人
对发送量做对数转换。
> from.weight %>%
+ ggplot(aes(x=freq)) +
+ geom_line(aes(y=log10(freq)),col="green") +
+ geom_text(aes(500,2.5,label="对数变换")) +
+ geom_line(aes(y=log(freq)),col="red") +
+ geom_text(aes(500,6,label="自然对数变换")) +
+ theme_bw() +
+ labs(x="",y="接收的邮件量")
对数变换效果
做对数变换后曲线会更平缓，同时，自然对数变换相对对数变换程度更小，更能保留原始数据的一些差异，所以最终我们选择自然对数变换后的值作为发送量特征的权重。
但是在做对数变换时需要注意的是，如果观测值为1，转换后就为0，计算权重时0乘以其他任何值都为0。为了避免这种情况，在转换前一般对观测值都加1。
> # log1p()函数计算log(p+1)
> from.weight$freq <- log1p(from.weight$freq)
> # 检查下变换为的数据
> summary(from.weight$freq)
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.6931 0.6931 1.3863 1.4869 1.7918 6.2126
3、邮件线程活跃度权重计算策略
从subject中查找“re:”，然后查找这个线程里面的其他邮件，并测量其活跃度。在短时间内有更多邮件发送的线程就更活跃，因此也更重要。
> # 提取包含“re:”的subject，并提取“re:”后面的内容作为主题
> threads.train <- train %>% filter(str_detect(subject,"re:"))
>
> extract_subject <- function(string){
+ string <- str_split(string,"re:") %>%
+ unlist %>% .[2] %>% str_trim()
+ return(string)
+ }
> threads.train$subject <- threads.train$subject %>%
+ lapply(extract_subject) %>% unlist
>
> # 分组统计数量
> threads.freq <- threads.train %>% group_by(subject) %>%
+ summarise(freq=n()) %>% arrange(freq)
数据中存在freq<2的情况，是因为数据集在采集的时候存在一部分主题邮件是在采集时间开始之前发起的，这时候主题中也存在“re:”标记，但是该线程发起时间并不在数据集中，所以需要去掉这部分数据。
> # 线程时间跨度，即第一封邮件和最后一封邮件之间的时间间隔
> time_span <- function(df){
+ max.time <- max(df$date)
+ min.time <- min(df$date)
+ threads.span <- difftime(max.time,min.time,units = "secs")
+ df.new <- tibble(subject=df$subject[1],threads.span=threads.span)
+ return(df.new)
+ }
>
> # 将数据框按subject拆分
> threads.train.split <- split.data.frame(threads.train,
+ threads.train$subject)
>
> threads.span <- lapply(threads.train.split,time_span) %>%
+ do.call(rbind.data.frame,.)
按主题合并两个数据框。
> subject.weight <- left_join(threads.freq,threads.span,by="subject") %>%
+ # 转换为数值型
+ transform(threads.span=as.numeric(threads.span)) %>%
+ filter(freq>=2 & threads.span!=0) %>%
+ mutate(weight=freq/threads.span) %>%
+ # 仿射变换
+ transform(weight=log10(weight)+10) %>%
+ arrange(weight)
> head(subject.weight)
## subject freq threads.span weight
## 1 activebuddy 17 820721053 2.316253
## 2 [zzzzteana] 6 8275106 3.860378
## 3 no matter where you go 4 2672629 4.175121
## 4 [sadev] 7 3325905 4.323188
## 5 [ilug-social] 4 1649403 4.384733
## 6 [razor-users] 16 5174599 4.490243
> summary(subject.weight)
## subject freq threads.span weight
## Length:287 Min. : 2.000 Min. : 16 Min. :2.316
## Class :character 1st Qu.: 3.000 1st Qu.: 15482 1st Qu.:5.675
## Mode :character Median : 5.000 Median : 49344 Median :6.126
## Mean : 7.784 Mean : 3094884 Mean :6.115
## 3rd Qu.: 9.000 3rd Qu.: 145816 3rd Qu.:6.512
## Max. :41.000 Max. :820721053 Max. :9.097
从摘要中可以看到freq平均为7.784，threads.span平均为3094884，这样计算的weight将会很小，平均为2.515118e-06，在做对数转换时，就会得到负值：log10(7.784/3094884)=-5.600825。计算时权重不能为负值，所以这里进行仿射变换，简单地给所有转换值加10，以保证所有权重值为正数。
4、邮件内容中高频词项的权重策略
假设出现在活跃线程邮件主题中的高频词比低频词和出现在不活跃线程中的词项更重要。
> p_load(text2vec)
>
> it <- itoken(threads.dt$message,ids = threads.dt$id,progressbar = F)
>
> # 创建训练集词汇表
> vocab <- create_vocabulary(it)
>
> # 去除停用词
> stopword <- readr::read_table("D:/R/dict/english_stopword.txt",
+ col_names = F)
>
> # 还是以对数转换计算高频词的权重
> term.weight <- anti_join(vocab,stopword,by=c("term"="X1")) %>%
+ mutate(term.weight=log10(term_count)) %>%
+ filter(term.weight>0)
5、训练和测试排序算法
一封邮件的整体权重（优先级）等于前面三种权重的乘积。当收到一封邮件的时候，我们需要先对其进行解析，计算其权重，然后对其进行优先级排序。
构造排序函数：
> get_weight <- function(newemail){
+
+ from.new.n <- left_join(newemail[,1],from.weight,by = "from")
+ from.new <- ifelse(is.na(from.new.n$freq),1,from.new.n$freq)
+
+
+ if (!is.na(newemail$subject) & str_detect(newemail$subject,"re:")) {
+ newemail$subject <- extract_subject(newemail$subject)
+ subject.new.n <- left_join(newemail,subject.weight,by="subject")
+
+ subject.new <- ifelse(is.na(subject.new.n$weight),1,
+ subject.new.n$weight)
+ } else {
+
+ subject.new <- 1
+ }
+
+
+ if (newemail$message!="") {
+
+ msg.weight <- str_split(newemail$message," ") %>% unlist %>%
+ jiebaR::freq() %>% anti_join(stopword,by=c("char"="X1")) %>%
+ filter(char!="")
+
+ if (nrow(msg.weight)!=0) {
+ msg.weight.n <- left_join(msg.weight,term.weight[,c(1,4)],
+ by=c("char"="term")) %>%
+ summarise(msg.new=sum(freq*term.weight,na.rm = T))
+ msg.new <- msg.weight.n$msg.new
+ }
+ } else {
+ msg.new <- 1
+ }
+
+
+ return(prod(from.new,subject.new,msg.new))
+ }
5.1 对训练集进行排序
> rank.train <- vector(length = nrow(train))
> for (i in 1:nrow(train)) {
+ rank.train[i] <- get_weight(train[i,])
+ }
>
> train.rank <- tibble(id=train$id,rank=rank.train)
>
> summary(train.rank$rank)
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 8.64 282.39 859.82 2300.37 2702.20 241506.57
> # 检查排序值的分布
> p1 <- ggplot(train.rank,aes(rank)) +
+ geom_histogram(bins = 1000, fill = "dodgerblue") +
+ geom_vline(xintercept = median(rank.train),size=1) +
+ xlim(c(0,25000)) +
+ theme_bw() +
+ labs(y="")
6、对测试集进行排序
> rank <- vector(length = nrow(test))
> for (i in 1:nrow(test)) {
+ rank[i] <- get_weight(test[i,])
+ }
>
> test.rank <- tibble(id=test$id,rank=rank)
>
> summary(test.rank$rank)
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 8.64 237.50 716.02 1913.47 2301.08 36852.14
> # 检查排序值的分布
> p2 <- ggplot(test.rank,aes(rank)) +
+ geom_histogram(bins = 1000, fill = "red") +
+ geom_vline(xintercept = median(rank),size=1) +
+ xlim(c(0,25000)) +
+ theme_bw() +
+ labs(y="")
对比训练集和测试的排序分布。
> p_load(patchwork)
> p1 + p2 + plot_layout(nrow = 2)
训练集和测试集排序值分布
可以看到训练集和测试集的排序分布几乎一模一样，都是长尾分布，意味着更多的邮件的优先级排序不高，这也符合常理。
然后检查一下测试集排序最靠前的20行。
> test[,3] %>% cbind(rank=rank) %>% arrange(-rank) %>% head(20)
## subject rank
## 1 re: apple sauced...again 36852.14
## 2 re: apple sauced...again 36852.14
## 3 sed /s/united states/roman empire/g 33739.40
## 4 re: selling wedded bliss (was re: ouch...) 25141.77
## 5 re: selling wedded bliss (was re: ouch...) 25141.77
## 6 re: new sequences window 22509.49
## 7 [lockergnome windows daily] fraud wipes 21055.61
## 8 [lockergnome windows daily] fraud wipes 21023.90
## 9 [lockergnome windows daily] brilliant mistakes 21004.60
## 10 [lockergnome penguin shell] recursive metaphor 20823.06
## 11 [lockergnome windows daily] cranky beats 20449.50
## 12 re: comrade communism (was re: crony capitalism (was re: sed 20073.10
## 13 [lockergnome windows daily] deeper uplink 20043.92
## 14 bush covers the waterfront 19548.67
## 15 [lockergnome digital media] clever ritual 19499.38
## 16 [lockergnome digital media] clever ritual 19467.67
## 17 [lockergnome windows daily] dignity shakedown 19325.42
## 18 [lockergnome penguin shell] good hearts 19295.45
## 19 [lockergnome windows daily] dignity shakedown 19293.71
## 20 [lockergnome windows daily] sticker courtesy 19132.87
主题中几乎有一大半是不活跃的邮件，因为subject中不包含“re:”，也表明排序算法可以将主题之外的其他权重应用到数据中。
尽管这种非监督的排序算法无法测算其准确度，但这结果仍然是很鼓舞人心的。
