機械学習手習い: 重要度による電子メールの並び替え
「入門 機械学習」手習い、4日目。「4章 順位づけ:優先トレイ」です。
電子メールを重要度で順位づけするシステムを作ります
並び替えのアプローチ
以下の素性を使って、メールに優先度をつけます。
- 1) 送信者のメッセージ数
- やり取りが多い送信者からのメールは重要とみなす
- 2) スレッドの活性
- 活発にやり取りされているスレッドのメールは優先度を高くする
- 活性度は、1秒あたりのスレッドのメール数で算出。多いほど、活性が高い
- 3) サブジェクトと本文に含まれる単語
必要なモジュールとデータの読み込み
> setwd("04-Ranking/") > library('tm') > library('ggplot2') > library('plyr') > library('reshape') # メールデータは、3章で使った非スパムメール(易)を使う > data.path <- file.path("..", "03-Classification", "data") > easyham.path <- file.path(data.path, "easy_ham")
メールから素性を取り出す
ファイルを読み込んで、本文を返す関数を作成します。
# メールファイルから、全データを読み込んで返す > msg.full <- function(path) { con <- file(path, open = "rt", encoding = "latin1") msg <- readLines(con) close(con) return(msg) } # メールデータからFromアドレスを取り出す > get.from <- function(msg.vec) { from <- msg.vec[grepl("From: ", msg.vec)] from <- strsplit(from, '[":<> ]')[1] from <- from[which(from != "" & from != " ")] return(from[grepl("@", from)][1]) } # メールデータから、サブジェクトを取り出す > get.subject <- function(msg.vec) { subj <- msg.vec[grepl("Subject: ", msg.vec)] if(length(subj) > 0) { return(strsplit(subj, "Subject: ")[1][2]) } else { return("") } } # メールデータから、本文を取り出す > get.msg <- function(msg.vec) { msg <- msg.vec[seq(which(msg.vec == "")[1] + 1, length(msg.vec), 1)] return(paste(msg, collapse = "\n")) } # メールデータから、受信日時を取り出す > get.date <- function(msg.vec) { date.grep <- grepl("^Date: ", msg.vec) date.grep <- which(date.grep == TRUE) date <- msg.vec[date.grep[1]] date <- strsplit(date, "\\+|\\-|: ")[1][2] date <- gsub("^\\s+|\\s+$", "", date) return(strtrim(date, 25)) } # メールを読み込んで、必要な素性を返す。 > parse.email <- function(path) { full.msg <- msg.full(path) date <- get.date(full.msg) from <- get.from(full.msg) subj <- get.subject(full.msg) msg <- get.msg(full.msg) return(c(date, from, subj, msg, path)) }
動作テスト。
> parse.email("../03-Classification/data/easy_ham/00111.a478af0547f2fd548f7b412df2e71a92") [1] "Mon, 7 Oct 2002 10:37:26" [2] "niall@linux.ie" ...
メールデータを読み込んで素性をデータフレームにまとめる
# 全メールを解析 > easyham.docs <- dir(easyham.path) > easyham.docs <- easyham.docs[which(easyham.docs != "cmds")] > easyham.parse <- lapply(easyham.docs, function(p) parse.email(file.path(easyham.path, p))) # データフレームに変換 > ehparse.matrix <- do.call(rbind, easyham.parse) > allparse.df <- data.frame(ehparse.matrix, stringsAsFactors = FALSE) > names(allparse.df) <- c("Date", "From.EMail", "Subject", "Message", "Path")
できた。
> head(allparse.df) Date From.EMail 1 Thu, 22 Aug 2002 18:26:25 kre@munnari.OZ.AU 2 Thu, 22 Aug 2002 12:46:18 steve.burt@cursor-system.com 3 Thu, 22 Aug 2002 13:52:38 timc@2ubh.com 4 Thu, 22 Aug 2002 09:15:25 monty@roscom.com
データの調整
送信日時が文字列になっているので、POSIXオブジェクトに変換します。
# 日本語環境だと、%b が Aug などの月名にマッチしないため、変更しておく。 > Sys.setlocale(locale="C") > date.converter <- function(dates, pattern1, pattern2) { pattern1.convert <- strptime(dates, pattern1) pattern2.convert <- strptime(dates, pattern2) pattern1.convert[is.na(pattern1.convert)] <- pattern2.convert[is.na(pattern1.convert)] return(pattern1.convert) } > pattern1 <- "%a, %d %b %Y %H:%M:%S" > pattern2 <- "%d %b %Y %H:%M:%S" > allparse.df$Date <- date.converter(allparse.df$Date, pattern1, pattern2) > head(allparse.df) Date From.EMail 1 2002-08-22 18:26:25 kre@munnari.OZ.AU 2 2002-08-22 12:46:18 steve.burt@cursor-system.com 3 2002-08-22 13:52:38 timc@2ubh.com 4 2002-08-22 09:15:25 monty@roscom.com 5 2002-08-22 14:38:22 Stewart.Smith@ee.ed.ac.uk # ロケールを戻しておく。 > Sys.setlocale(local="ja_JP.UTF-8")
また、サブジェクトと送信者アドレスを小文字に変更します。
> allparse.df$Subject <- tolower(allparse.df$Subject) > allparse.df$From.EMail <- tolower(allparse.df$From.EMail)
最後に、送信日時でソート。
> priority.df <- allparse.df[with(allparse.df, order(Date)), ]
データの最初の半分を訓練データに使うので、別の変数に格納しておきます。
> priority.train <- priority.df[1:(round(nrow(priority.df) / 2)), ]
送信者別メール件数での重みづけ
送信者ごとのメール件数で重みづけを行うため、まずは、件数がどんな感じになっているか確認します。
送信者ごとのメール件数を集計。
> from.weight <- melt(with(priority.train, table(From.EMail))) > from.weight <- from.weight[with(from.weight, order(value)), ] > head(from.weight) From.EMail value 1 adam@homeport.org 1 2 admin@networksonline.com 1 4 albert.white@ireland.sun.com 1 5 andr@sandy.ru 1 6 andris@aernet.ru 1 9 antoin@eire.com 1 > summary(from.weight$value) Min. 1st Qu. Median Mean 3rd Qu. Max. 1.00 1.00 2.00 4.63 4.00 55.00
平均は4.63通。最大値は55通でばらつきが大きいかな? 7通以上送信しているアドレスをグラフに表示してみます。
> from.ex <- subset(from.weight, value >= 7) > from.scales <- ggplot(from.ex) + geom_rect(aes(xmin = 1:nrow(from.ex) - 0.5, xmax = 1:nrow(from.ex) + 0.5, ymin = 0, ymax = value, fill = "lightgrey", color = "darkblue")) + scale_x_continuous(breaks = 1:nrow(from.ex), labels = from.ex$From.EMail) + coord_flip() + scale_fill_manual(values = c("lightgrey" = "lightgrey"), guide = "none") + scale_color_manual(values = c("darkblue" = "darkblue"), guide = "none") + ylab("Number of Emails Received (truncated at 6)") + xlab("Sender Address") + theme_bw() + theme(axis.text.y = element_text(size = 5, hjust = 1)) > ggsave(plot = from.scales, filename = file.path("images", "0011_from_scales.png"), height = 4.8, width = 7)
一部の送信者が、平均的な送信者の10倍以上、メールを送信しています。送信数をそのまま重みにしてしまうと、これらの特殊な送信者の優先度が高くなりすぎてしまいます。グラフを見ると、指数関数的に増えている感じなので、自然対数を使って重みを調整します。
# 対数を取る。重みがゼロにならないように、値に1を足す。 > from.weight <- transform(from.weight, Weight = log(value + 1), log10Weight = log10(value + 1))
スレッド活性での重みづけ
まずは、スレッド別のメール件数を集計します。
メールがスレッドに属するかどうかは、メールのサブジェクトを見て判定します。
# re:を除いたサブジェクト(=スレッド名)と送信者を取り出す。 > find.threads <- function(email.df) { response.threads <- strsplit(email.df$Subject, "re: ") is.thread <- sapply(response.threads, function(subj) ifelse(subj[1] == "", TRUE, FALSE)) threads <- response.threads[is.thread] senders <- email.df$From.EMail[is.thread] threads <- sapply(threads, function(t) paste(t[2:length(t)], collapse = "re: ")) return(cbind(senders,threads)) } > threads.matrix <- find.threads(priority.train) > head(threads.matrix) senders threads [1,] "kre@munnari.oz.au" "new sequences window" [2,] "stewart.smith@ee.ed.ac.uk" "[zzzzteana] nothing like mama used to make" [3,] "martin@srv0.ems.ed.ac.uk" "[zzzzteana] nothing like mama used to make" [4,] "stewart.smith@ee.ed.ac.uk" "[zzzzteana] nothing like mama used to make" [5,] "marc@perkel.com" "[sadev] live rule updates after release ???" [6,] "cwg-exmh@deepeddy.com" "new sequences window"
次に、スレッドごとの活性度を集計します。
# スレッドごとの活性度一覧を返す > get.threads <- function(threads.matrix, email.df) { threads <- unique(threads.matrix[, 2]) thread.counts <- lapply(threads, function(t) thread.counts(t, email.df)) thread.matrix <- do.call(rbind, thread.counts) return(cbind(threads, thread.matrix)) } # スレッド名に属するメールの活性度を返す > thread.counts <- function(thread, email.df) { # メールから、スレッドに属するメールの送信日時を取り出す thread.times <- email.df$Date[which(email.df$Subject == thread | email.df$Subject == paste("re:", thread))] freq <- length(thread.times) # スレッドのメールの総数 min.time <- min(thread.times) # 送信日時の最小値 max.time <- max(thread.times) # 送信日時の最大値 time.span <- as.numeric(difftime(max.time, min.time, units = "secs")) if(freq < 2) { # メールが1通しかない場合(返信がなくスレッドになっていない場合)、NAを返す return(c(NA, NA, NA)) } else { trans.weight <- freq / time.span # 1秒当たりのメール送信数 log.trans.weight <- 10 + log(trans.weight, base = 10) # 対数を取る。負にならないよう、10を足す(アフィん変換) return(c(freq, time.span, log.trans.weight)) } } > thread.weights <- data.frame(thread.weights, stringsAsFactors = FALSE) > names(thread.weights) <- c("Thread", "Freq", "Response", "Weight") > thread.weights$Freq <- as.numeric(thread.weights$Freq) > thread.weights$Response <- as.numeric(thread.weights$Response) > thread.weights$Weight <- as.numeric(thread.weights$Weight) > thread.weights <- subset(thread.weights, is.na(thread.weights$Freq) == FALSE) > head(thread.weights) Thread Freq Response Weight 1 please help a newbie compile mplayer :-) 4 42309 5.975627 2 prob. w/ install/uninstall 4 23745 6.226488 3 http://apt.nixia.no/ 10 265303 5.576258 4 problems with 'apt-get -f install' 3 55960 5.729244 5 problems with apt update 2 6347 6.498461 6 about apt, kernel updates and dist-upgrade 5 240238 5.318328
また、送信者での重みづけの補完として、「送信者が何スレッドに参加しているか」を示す重みも計算しておきます。
> email.thread <- function(threads.matrix) { senders <- threads.matrix[, 1] senders.freq <- table(senders) senders.matrix <- cbind(names(senders.freq), senders.freq, log(senders.freq + 1)) senders.df <- data.frame(senders.matrix, stringsAsFactors=FALSE) row.names(senders.df) <- 1:nrow(senders.df) names(senders.df) <- c("From.EMail", "Freq", "Weight") senders.df$Freq <- as.numeric(senders.df$Freq) senders.df$Weight <- as.numeric(senders.df$Weight) return(senders.df) } > senders.df <- email.thread(threads.matrix) > head(senders.df) From.EMail Freq Weight 1 adam@homeport.org 1 0.6931472 2 aeriksson@fastmail.fm 5 1.7917595 3 albert.white@ireland.sun.com 1 0.6931472 4 alex@netwindows.org 1 0.6931472 5 andr@sandy.ru 1 0.6931472 6 andris@aernet.ru 1 0.6931472
サブジェクトと本文に含まれる単語による重みづけ
まずは、サブジェクト。
- スレッド名に含まれる単語一覧を抽出して、単語ごとに重みを計算します。
- 単語を含む全スレッドのweightを取り出して、その平均を重みとして使います。
# 単語と出現頻度の一覧を返す > term.counts <- function(term.vec, control) { vec.corpus <- Corpus(VectorSource(term.vec)) vec.tdm <- TermDocumentMatrix(vec.corpus, control = control) return(rowSums(as.matrix(vec.tdm))) } # スレッド名に含まれる単語一覧を抽出 > thread.terms <- term.counts(thread.weights$Thread, control = list(stopwords = TRUE)) > thread.terms <- names(thread.terms) # 出現頻度は使わないので捨てる > head(thread.terms) [1] "--with" ":-)" "..." ".doc" "'apt-get" "\"holiday" # 単語ごとに重みを算出 # 単語を含む全スレッドのweightを取り出して、その平均を重みとして使う > term.weights <- sapply(thread.terms, function(t) mean(thread.weights$Weight[grepl(t, thread.weights$Thread, fixed = TRUE)])) > head(term.weights) --with :-) ... .doc 'apt-get "holiday 7.109579 6.103883 6.050786 5.725911 5.729244 7.197911 # 整形 > term.weights <- data.frame(list(Term = names(term.weights), Weight = term.weights), stringsAsFactors = FALSE, row.names = 1:length(term.weights)) > head(term.weights) Term Weight 1 --with 7.109579 2 :-) 6.103883 3 ... 6.050786 4 .doc 5.725911 5 'apt-get 5.729244 6 "holiday 7.197911
次に本文。
# 本文に含まれる単語と頻度を集計 > msg.terms <- term.counts(priority.train$Message, control = list(stopwords = TRUE, removePunctuation = TRUE, removeNumbers = TRUE)) # 重みを算出。ここでも対数をとる > msg.weights <- data.frame(list(Term = names(msg.terms), Weight = log(msg.terms, base = 10)), stringsAsFactors = FALSE, row.names = 1:length(msg.terms)) # 重みがゼロのものは除外 > msg.weights <- subset(msg.weights, Weight > 0)
これで、すべての重みデータフレームがそろいました。
順位づけを行う
重要度を計算する関数を定義します。
# 単語の重みを返す # 単語、検索する重みデータフレーム、term.weightが検索対象かどうか、を引数で受け取り、重みを返す。 > get.weights <- function(search.term, weight.df, term = TRUE) { if(length(search.term) > 0) { # weight.dfがterm.weightかどうかで列名が異なるので、ここで調整 if(term) { term.match <- match(names(search.term), weight.df$Term) } else { term.match <- match(search.term, weight.df$Thread) } match.weights <- weight.df$Weight[which(!is.na(term.match))] if(length(match.weights) < 1) { # マッチする件数がゼロの場合、1を使う return(1) } else { # マッチする件数が1以上の場合、平均を使う return(mean(match.weights)) } } else { return(1) } } # メールの重要度を返す > rank.message <- function(path) { # メールを解析 msg <- parse.email(path) # 送信者が送信したメール数に基づく重みを取得 from <- ifelse(length(which(from.weight$From.EMail == msg[2])) > 0, from.weight$Weight[which(from.weight$From.EMail == msg[2])], 1) # 送信者が参加したスレッド数に基づく重みを取得 thread.from <- ifelse(length(which(senders.df$From.EMail == msg[2])) > 0, senders.df$Weight[which(senders.df$From.EMail == msg[2])], 1) # メールがスレッドへの投降かどうかを判定し、スレッドへの投稿であれば、スレッドの重みを取得 subj <- strsplit(tolower(msg[3]), "re: ") is.thread <- ifelse(subj[[1]][1] == "", TRUE, FALSE) if(is.thread){ activity <- get.weights(subj[[1]][2], thread.weights, term = FALSE) } else { # スレッドへの投稿でない場合、重みは1 activity <- 1 } # メールサブジェクトに基づく重みを取得 thread.terms <- term.counts(msg[3], control = list(stopwords = TRUE)) thread.terms.weights <- get.weights(thread.terms, term.weights) # メール本文に基づく重みを取得 msg.terms <- term.counts(msg[4], control = list(stopwords = TRUE, removePunctuation = TRUE, removeNumbers = TRUE)) msg.weights <- get.weights(msg.terms, msg.weights) # 重みをすべて掛け合わせて、重要度を算出する rank <- prod(from, thread.from, activity, thread.terms.weights, msg.weights) return(c(msg[1], msg[2], msg[3], rank)) }
動作テスト。
> rank.message("../03-Classification/data/easy_ham/00111.a478af0547f2fd548f7b412df2e71a92") [1] "Mon, 7 Oct 2002 10:37:26" [2] "niall@linux.ie" [3] "Re: [ILUG] Interesting article on free software licences" [4] "5.27542087468428"
優先メールとみなす閾値が妥当か確認する
今回は、優先度の中央値を閾値として使います。 データの半分を使って、閾値が妥当かチェックします。
train.paths <- priority.df$Path[1:(round(nrow(priority.df) / 2))] test.paths <- priority.df$Path[((round(nrow(priority.df) / 2)) + 1):nrow(priority.df)] # train.pathsに含まれるメールの重要度を算出 train.ranks <- suppressWarnings(lapply(train.paths, rank.message)) # データフレームに変換 > train.ranks.matrix <- do.call(rbind, train.ranks) > train.ranks.matrix <- cbind(train.paths, train.ranks.matrix, "TRAINING") > train.ranks.df <- data.frame(train.ranks.matrix, stringsAsFactors = FALSE) > names(train.ranks.df) <- c("Message", "Date", "From", "Subj", "Rank", "Type") > train.ranks.df$Rank <- as.numeric(train.ranks.df$Rank) > head(train.ranks.df) Message 1 ../03-Classification/data/easy_ham/01061.6610124afa2a5844d41951439d1c1068 2 ../03-Classification/data/easy_ham/01062.ef7955b391f9b161f3f2106c8cda5edb 3 ../03-Classification/data/easy_ham/01063.ad3449bd2890a29828ac3978ca8c02ab 4 ../03-Classification/data/easy_ham/01064.9f4fc60b4e27bba3561e322c82d5f7ff 5 ../03-Classification/data/easy_ham/01070.6e34c1053a1840779780a315fb083057 6 ../03-Classification/data/easy_ham/01072.81ed44b31e111f9c1e47e53f4dfbefe3 Date From 1 Thu, 31 Jan 2002 22:44:14 robinderbains@shaw.ca 2 01 Feb 2002 00:53:41 lance_tt@bellsouth.net 3 Fri, 01 Feb 2002 02:01:44 robinderbains@shaw.ca 4 Fri, 1 Feb 2002 10:29:23 matthias@egwn.net 5 Fri, 1 Feb 2002 12:42:02 bfrench@ematic.com 6 Fri, 1 Feb 2002 13:39:31 bfrench@ematic.com Subj Rank Type 1 Please help a newbie compile mplayer :-) 3.614003 TRAINING 2 Re: Please help a newbie compile mplayer :-) 120.742481 TRAINING 3 Re: Please help a newbie compile mplayer :-) 20.348502 TRAINING 4 Re: Please help a newbie compile mplayer :-) 307.809626 TRAINING 5 Prob. w/ install/uninstall 3.653047 TRAINING 6 RE: Prob. w/ install/uninstall 21.685750 TRAINING
閾値を中央値に設定して、訓練データの重要度と密度を図にします。
# 閾値を中央値に設定 > priority.threshold <- median(train.ranks.df$Rank) # 訓練データの重要度と密度を図示 > threshold.plot <- ggplot(train.ranks.df, aes(x = Rank)) + stat_density(aes(fill="darkred")) + geom_vline(xintercept = priority.threshold, linetype = 2) + scale_fill_manual(values = c("darkred" = "darkred"), guide = "none") + theme_bw() > ggsave(plot = threshold.plot, filename = file.path("images", "01_threshold_plot.png"), height = 4.7, width = 7)
図中の点線が中央値。 ここを閾値にすれば、ランクの高い裾部分と、密度の高い部分の電子メールもある程度含まれるので、これらを優先メールと判定したのでよさそう。
残りのデータも加えて、図にしてみます。
# test.ranksに含まれるメールの重要度を算出 > train.ranks.df$Priority <- ifelse(train.ranks.df$Rank >= priority.threshold, 1, 0) > test.ranks <- suppressWarnings(lapply(test.paths,rank.message)) > test.ranks.matrix <- do.call(rbind, test.ranks) > test.ranks.matrix <- cbind(test.paths, test.ranks.matrix, "TESTING") > test.ranks.df <- data.frame(test.ranks.matrix, stringsAsFactors = FALSE) > names(test.ranks.df) <- c("Message","Date","From","Subj","Rank","Type") > test.ranks.df$Rank <- as.numeric(test.ranks.df$Rank) > test.ranks.df$Priority <- ifelse(test.ranks.df$Rank >= priority.threshold, 1, 0) # 訓練用データとテスト用データをマージ > final.df <- rbind(train.ranks.df, test.ranks.df) > final.df$Date <- date.converter(final.df$Date, pattern1, pattern2) > final.df <- final.df[rev(with(final.df, order(Date))), ] > head(final.df) Message 2500 ../03-Classification/data/easy_ham/00883.c44a035e7589e83076b7f1fed8fa97d5 2499 ../03-Classification/data/easy_ham/02500.05b3496ce7bca306bed0805425ec8621 2498 ../03-Classification/data/easy_ham/02499.b4af165650f138b10f9941f6cc5bce3c 2497 ../03-Classification/data/easy_ham/02498.09835f512f156da210efb99fcc523e21 2496 ../03-Classification/data/easy_ham/02497.60497db0a06c2132ec2374b2898084d3 2495 ../03-Classification/data/easy_ham/02496.aae0c81581895acfe65323f344340856 Date From 2500 <NA> sdw@lig.net 2499 <NA> ilug_gmc@fiachra.ucd.ie 2498 <NA> mwh@python.net 2497 <NA> nickm@go2.ie 2496 <NA> phil@techworks.ie 2495 <NA> timc@2ubh.com Subj Rank Type 2500 Re: ActiveBuddy 6.219744 TESTING 2499 Re: [ILUG] Linux Install 2.278890 TESTING 2498 [Spambayes] Re: New Application of SpamBayesian tech? 4.265954 TESTING 2497 Re: [ILUG] Linux Install 4.576643 TESTING 2496 Re: [ILUG] Linux Install 3.652100 TESTING 2495 [zzzzteana] Surfing the tube 27.987331 TESTING Priority 2500 0 2499 0 2498 0 2497 0 2496 0 2495 1 # 図示 > testing.plot <- ggplot(subset(final.df, Type == "TRAINING"), aes(x = Rank)) + stat_density(aes(fill = Type, alpha = 0.65)) + stat_density(data = subset(final.df, Type == "TESTING"), aes(fill = Type, alpha = 0.65)) + geom_vline(xintercept = priority.threshold, linetype = 2) + scale_alpha(guide = "none") + scale_fill_manual(values = c("TRAINING" = "darkred", "TESTING" = "darkblue")) + theme_bw() > ggsave(plot = testing.plot, filename = file.path("images", "02_testing_plot.png"), height = 4.7, width = 7)
テストデータは、訓練データより優先度低のメールが多く含まれる結果になっています。 これは、テストデータの素性に、訓練データに含まれないデータが多く含まれ、これらが順序付け時に無視されているためであり、妥当らしい。ふむ。
最後に優先度一覧をcsvに出力しておしまい。
write.csv(final.df, file.path("data", "final_df.csv"), row.names = FALSE)
