孤独にそっくり

開いている窓の前で立ち止まるな

実践Common Lispを読む　第23章

プログラミング

IMGP3678
Bayes' theoremのネオン？

こんにちは。今回から実践の章に入りました。
写経することはないので、どちらかというと読み物としてサクサク進むかなと思ったのですが、全然そうなりませんでした。

第23章　実践：スパムフィルタ

ポール・グレアムが2002年に書いた"A Plan for Spam"でスパムフィルタ技術のちょっとした革命が起きた。彼は従来型のルールベースのフィルタではなく、統計的手法を用いたフィルタ（ベイジアンフィルタ）を提唱した。

＊スパムフィルタの心臓部

新規メッセージの分類とフィルタの学習機能に主眼を置く。
ひとまずパッケージを定義する。

;;15章で定義したパッケージ
(defpackage :com.gigamonkeys.pathnames
  (:use :common-lisp)
  (:export
   :list-directory
   :file-exists-p
   :directory-pathname-p
   :file-pathname-p
   :pathname-as-directory
   :pathname-as-file
   :walk-directory
   :directory-p
   :file-p))

(defpackage :com.gigamonkeys.spam
  (:use :common-lisp :com.gigamonkeys.pathnames))
;;lispファイルの最初で宣言する
;;または、REPLでパッケージを移動する
(in-package :com.gigamonkeys.spam)

メッセージのテキストを受け取ってスパム、ハム（スパムでないもの）、不明に分類する。

;;特徴を抽出(extract)してscore関数に渡す。
;;socre関数で値を計算する
;;その値をclassificationで3つに分類
(defun classify (text)
  "Classify the text of a message as SPAM, HAM, or UNSURE."
  (classification (score (extract-features text))))
;;socreが返す値は、スパムが1に近い値、ハムなら0に近い値、不明は0.5に近い値
(defparameter *max-ham-score* .4)
(defparameter *min-spam-score* .6)
;;0.4以下はハム、0.6以上はスパム、それ以外は不明
(defun classification (score)
  (values
   (cond
     ((<= score *max-ham-score*) 'ham)
     ((>= score *min-spam-score*) 'spam)
     (t 'unsure))
   score))
;;各単語について、それがスパム中に現れる回数とハム中に現れる回数を保持したい
;;そのため、クラスを定義する
(defclass word-feature ()
  ((word
    :initarg :word
    :accessor word
    :initform (error "Must supply :word")
    :documentation "The word this feature represents.")
   (spam-count
    :initarg :spam-count
    :accessor spam-count
    :initform 0
    :documentation "Number of spams we have seen this feature in.")
   (ham-count
    :initarg :ham-count
    :accessor ham-count
    :initform 0
    :documentation "Number of hams we have seen this feature in.")))
;;特徴データベースはハッシュテーブルにする
;;ハッシュへの参照を格納
(defvar *feature-database* (make-hash-table :test #'equal))
;;DEFVARなので誤ってリロードしても値を保持する
;;特徴データベースをクリアするための関数が必要
(defun clear-database ()
  (setf
   *feature-database* (make-hash-table :test #'equal)
   *total-spams* 0
   *total-hams* 0))

与えれたメッセージの特徴を探るには、単語を抽出して対応するword-featureオブジェクトを*feature-database*から探す必要がある
もし、探した特徴がなかった場合に新しいword-featureを作りたい

;;単語を受け取って適切な特徴を返し、必要があれば対応する特徴を作る
;;ORは最初にTになった値を返す
(defun intern-feature (word)
  (or (gethash word *feature-database*)
      (setf (gethash word *feature-database*)
            (make-instance 'word-feature :word word))))

正規表現を使って文字をメッセージから抽出
CL-PPCREライブラリを使う

;;
(defun extract-words (text)
  (delete-duplicates
   (cl-ppcre:all-matches-as-strings "[a-zA-Z]{3,}" text)
   :test #'string=))

extract-wordsとintern-featureを組み合わせる

(defun extract-features (text)
  (mapcar #'intern-feature (extract-words text)))

サンプルコード動かそうとしてみたらよくわからなかったからググった。
http://d.hatena.ne.jp/patterson/20081207/1228641808

~/cl/practicals-1.0.3/libraries/cl-ppcre-1.2.3/cl-ppcre.asd
~/cl/practicals-1.0.3/Chapter15/chapter-15.asd
~/cl/practicals-1.0.3/Chapter23/chapter-23.asd
(setf asdf:*central-registry*
             '(*default-pathname-defaults*
	        #p"/home/cl/systems/"
	        #p"/usr/share/common-lisp/systems/"))
;;すぐ上手くいった？（STYLE-WARNING:出るけど…）
(asdf:operate 'asdf:load-op 'cl-ppcre) 

;;エラー吐いた
(asdf:operate 'asdf:load-op 'chapter-15)
;;エラー
Component "pathnames" not found, required by                                   
#<SYSTEM "chapter-15">
   [Condition of type ASDF/FIND-COMPONENT:MISSING-DEPENDENCY]
;;なんでやねん

https://common-lisp.net/project/asdf/asdf/The-defsystem-grammar.html
http://pcl-review.blogspot.jp/2008/01/chapter-23-practical-spam-filter.html
（Practical Common Lisp を読むって僕とまったく同じタイトルで、しかもこの方のほうが前ですが、パクったわけではないです。今回初めて発見したので、今後参考にさせていただきます。）

でも公式のREADME.TXT読んでたら、直接pathnames.asdとspam.asdにリンク貼ってやればいいんじゃねと思って、ちょっと書き方変えてみた。

Thus to load the test framework code from Chapter 9, you'd type:
(asdf:oos 'asdf:load-op :test-framework)

~/cl/practicals-1.0.3/Chapter15/pathnames.asd
~/cl/practicals-1.0.3/Chapter23/spam.asd
(asdf:operate 'asdf:load-op :pathnames)
(asdf:operate 'asdf:load-op :spam)

動いた！！！

;;パッケージを変更
CL-USER> (in-package :com.gigamonkeys.spam)
#<PACKAGE "COM.GIGAMONKEYS.SPAM">
;;テスト       
SPAM> (extract-words "foo bar baz foo bar")
("baz" "foo" "bar")  
;;テスト2
;;PRINT-UNREADABLE-OBJECTで読み込んだ特徴量を成形して表示
SPAM> (extract-features "foo bar baz foo bar")
(#<WORD-FEATURE "baz" :hams 0 :spams 0> #<WORD-FEATURE "foo" :hams 0 :spams 0> 
 #<WORD-FEATURE "bar" :hams 0 :spams 0>)
＊フィルタを学習させる
;;テキストとタイプ(ham or spam)を引数にとって、テキストに表れるすべての特徴について、加算する。
(defun train (text type)
  (dolist (feature (extract-features text))
    (increment-count feature type))
  (increment-total-count type))
;;特徴のスロットに加算
(defun increment-count (feature type)
  (ecase type
    (ham (incf (ham-count feature)))
    (spam (incf (spam-count feature)))))
;;ハムとスパムの総数をカウント
(defun increment-total-count (type)
  (ecase type
    (ham (incf *total-hams*))
    (spam (incf *total-spams*))))
＊単語ごとの統計

与えられたメッセージに含まれる特徴を抽出して分別、個々の特徴についてそれを含むメッセージがスパムである確率を計算して、その全確率を組み合わせて合計スコアを出す。
知りたいのは特徴がスパムである確率ではなく、スパムに現れる確率

;;スパムに現れる確率
;;スパム、ハムの出現回数の比（全体数で除算しているため）で考える
;;全体のメッセージ数は考えられてない
(defun spam-probability (feature)
  (with-slots (spam-count ham-count) feature
    (let ((spam-frequency (/ spam-count (max 1 *total-spams*)))
          (ham-frequency (/ ham-count (max 1 *total-hams*))))
      (/ spam-frequency (+ spam-frequency ham-frequency)))))

;;事前確率:assumed-probabilityとウェイトを用いた手法
(defun bayesian-spam-probability (feature &optional
                                  (assumed-probability 1/2)
                                  (weight 1))
  (let ((basic-probability (spam-probability feature))
        (data-points (+ (spam-count feature) (ham-count feature))))
    (/ (+ (* weight assumed-probability)
          (* data-points basic-probability))
       (+ weight data-points))))

上の設定だと、１つのスパムにあらわれて、どのハムにも現れない特徴は0.75
10のスパムにあらわれてどのハムにも現れないのは0.955、100のスパムにあらわれて、どのハムにも現れなければ0.995の確率でスパムの特徴となる
あとでウェイトとか動かして遊んでみよう

＊確率を合成する

フィッシャー流でやる

  1. すべての確率の積を求める
  2. この値の自然対数に-2をかけた値は、ランダムな数字であれば、カイ二乗分布に従う
  3. これと確率の個数に２倍した値を逆カイ二乗分布関数に渡せば、「ランダムに選んだ同じ個数の確率を合成して、同じかそれ以上に極端な値が得られる可能性がどれくらいあるか」を示す値が得られる
  4. これを使って、帰無仮説「分類されたメッセージは、実は特徴をランダムに集めたもの」を棄却する。言い換えると、「関与している特徴は、バイアスのかかったサンプルから取り出されたもの」だと分かる

スパム確率を合成して、帰無仮説が棄却されたら、「ハムらしさ」がわかることと同じ意味になる
逆にハム確率を合成すれば「スパムらしさ」がわかる
最終的には、２つの「らしさ」を合成して0〜１にする。
この時、ロビンソンの方法に従うので、「ハムらしさ」と「スパムらしさ」の差を半分にしたものに1/2を加える。「らしさ」がどちらも低い時に1/2に近づくため、不明の判定ができるようになる。

;;spam-probs:スパムである確率のリスト
;;ham-probs:ハムである確率のリスト
;;fisher:ランダムなテキストにしては小さい確率の特徴を多く含む場合に小さくなる
(defun score (features)
  (let ((spam-probs ()) (ham-probs ()) (number-of-probs 0))
    (dolist (feature features)
      (unless (untrained-p feature)
        (let ((spam-prob (float (bayesian-spam-probability feature) 0.0d0)))
          (push spam-prob spam-probs)
          (push (- 1.0d0 spam-prob) ham-probs)
          (incf number-of-probs))))
    (let ((h (- 1 (fisher spam-probs number-of-probs)))
          (s (- 1 (fisher ham-probs number-of-probs))))
      (/ (+ (- 1 h) s) 2.0d0))))
;;学習したことのない特徴をスキップ
(defun untrained-p (feature)
  (with-slots (spam-count ham-count) feature
    (and (zerop spam-count) (zerop ham-count))))
;;数値のリストを積算したいが、値が浮動小数点数でとても小さくなってエラーを吐かないように、計算順序を入れ替える
(defun fisher (probs number-of-probs)
  "The Fisher computation described by Robinson."
  (inverse-chi-square
   (* -2 (reduce #'+ probs :key #'log));;もとは(log (reduce #'* probs))
   (* 2 number-of-probs)))
＊逆カイ二乗関数

よくわからないけど、確率の個数の割に、フィッシャー流に合成した値が以上に大きくなった場合、それに渡されたinverse-chi-squareは小さい確率を返す
積算やべき乗のエラーを丸めるときに1を超えないようにMINでくくっている

(defun inverse-chi-square (value degrees-of-freedom)
  "Probability that chi-square >= value with given degrees-of-freedom.         
Based on Gary Robinson's Python implementation."
  (assert (evenp degrees-of-freedom))
  ;; Due to rounding errors in the multiplication and exponentiation           
  ;; the sum computed in the loop may end up a shade above 1.0 which           
  ;; we can't have since it's supposed to represent a probability.             
  (min
   (loop with m = (/ value 2)
      for i below (/ degrees-of-freedom 2)
      for prob = (exp (- m)) then (* prob (/ m i))
      summing prob)
   1.0))
＊フィルタをさらに学習させる

SPAMかUNSUREかHAMかだけでなく、未加工のスコアを表示したいから多値を使う

(defun classification (score)
  (values
   (cond
     ((<= score *max-ham-score*) 'ham)
     ((>= score *min-spam-score*) 'spam)
     (t 'unsure))
   score))

実際にやってみる

SPAM> (clear-database)
0
SPAM> (train "Make money fast" 'spam)
1                                                                              
SPAM> (classify "Make money fast")
SPAM                                                                           
0.8636771013604718d0                                                           
SPAM> (classify "Want to go to the movies?")
UNSURE                                                                         
0.5d0
;;さらに学習させる
SPAM> (train "Do you have any money for the movies?" 'ham)
1                                                                              
SPAM> (classify "Make money fast")
SPAM
0.7685351214863382d0                                                           
SPAM> (classify "Want to go to the movies?")
HAM                                                                            
0.17482223181586642d0

やったぜ

＊フィルタをテストする

ディレクトリから読み込んでコーパスに追加する

(defun add-file-to-corpus (filename type corpus)
  (vector-push-extend (list filename type) corpus))

(defun add-directory-to-corpus (dir type corpus)
  (dolist (filename (list-directory dir))
    (add-file-to-corpus filename type corpus)))
;;(defparameter *corpus* (make-array 1000 :adjustable t :fill-pointer 0)
;;SPAM (add-directory-to-corpus "mail/spam/" 'spam *corpus*)のように使う

分類器をテストする関数が必要
分類の精度を測るには、学習に使うコーパスの塊をランダムに選び、残りのコーパスに対する結果を予めわかっている分類と比較する必要がある

(defun test-classifier (corpus testing-fraction)
  (clear-database)
  (let* ((shuffled (shuffle-vector corpus))
         (size (length corpus))
         (train-on (floor (* size (- 1 testing-fraction)))))
    (train-from-corpus shuffled :start 0 :end train-on)
    (test-from-corpus shuffled :start train-on)))
;;文字数制限とかちょっと処理してdestructuring-bindに渡す
(defun train-from-corpus (corpus &key (start 0) end)
  (loop for idx from start below (or end (length corpus)) do
        (destructuring-bind (file type) (aref corpus idx)
          (train (start-of-file file *max-chars*) type))))
;;分析用にいろいろ情報を入れたリストを返す
(defun test-from-corpus (corpus &key (start 0) end)
  (loop for idx from start below (or end (length corpus)) collect
        (destructuring-bind (file type) (aref corpus idx)
          (multiple-value-bind (classification score)
              (classify (start-of-file file *max-chars*))
            (list
             :file file
             :type type
             :classification classification
             :score score)))))
＊ユーティリティ関数
(defun nshuffle-vector (vector)
  "Shuffle a vector in place using Fisher-Yates algorithm."
  (loop for idx downfrom (1- (length vector)) to 1
        for other = (random (1+ idx))
        do (unless (= idx other)
             (rotatef (aref vector idx) (aref vector other))))
  vector)

(defun shuffle-vector (vector)
  "Return a shuffled copy of vector."
  (nshuffle-vector (copy-seq vector)))

(defun start-of-file (file max-chars)
  (with-open-file (in file)
    (let* ((length (min (file-length in) max-chars))
           (text (make-string length))
           (read (read-sequence text in)))
      (if (< read length)
	  (subseq text 0 read)
        text))))
＊結果の分析

correct（正しい）、false-positive（誤判定）、false-negative（判定漏れ）、missed-ham（ハムと判定し損ねた）、missed-spam（スパムと判定し損ねた）
に分ける

(defun result-type (result)
  (destructuring-bind (&key type classification &allow-other-keys) result
    (ecase type
      (ham
       (ecase classification
         (ham 'correct)
         (spam 'false-positive)
	  (unsure 'missed-ham)))
      (spam
       (ecase classification
         (ham 'false-negative)
         (spam 'correct)
         (unsure 'missed-spam))))))

その後、本だとかっこいい感じに表示してるけど割愛
本当はデータセット使って実際に動かしてみたほうがいいんだろうけど…

＊まとめ

今回は、遂に実践！って思うような内容でした。
それにしてもナイーブベイズは勉強したはずなのに単語しか覚えてないのが悲しくて統計の勉強し直したくなりました（きっとしない）。
サンプルコードを動かそうとしてハマったりして、読むのが大変でしたけど、とりあえず読み下しました。最後のテストや分析に関しては実際にこういう研究をしている人たちが日常的にやっていることなのかなとおもったりしましたが、こんなに１から全部書いているひとはどれくらいいるんでしょうね。ともかく、おもしろかったです。