読者です 読者をやめる 読者になる 読者になる

形態素解析器(4)

common lisp algorithm

形態素解析器の4。
今回は未知語処理+αを扱う。


前回までで作成した形態素解析器では、下の例のように未知語が"_"と表示されてしまうが、これをちゃんと"ocaml"と表示されるようにするのが今回の主たる目的。

;; 未知語=単語辞書に登録されていない語は、"_"と表示される。
>(wakati "関数型言語ocamlを勉強する")
--> ("BOS" "関数" "型" "言語" "_" "_" "_" "_" "_" "を" "勉強" "する" "EOS")

概要

今までの形態素解析では、基本的に単語辞書(word.csv)に登録されている単語しか使用していなかった*1
これだと、最初の例のように、単語辞書に登録されていない単語を適切に扱うことができない。
MeCabが採用している未知語処理では、こういった単語(未知語)を、ルールベースで処理することで対応している。
例えば、最初の例の'ocaml'の場合、この文字列は全て英字から構成されているので英字カテゴリに属する一つの単語(未知語)として、処理されることになる。
同様に、'ブログ'は全てカタカナからなるので...(以下同)、'12345'は全て数字からなるので...(以下同)
つまり、未知語処理では、まず入力テキストの各文字を(英字,数字,漢字,カタカナ,ひらがな,その他任意の)対応するカテゴリに割り振り、次に隣接する同じカテゴリの文字をまとめて、一つの単語(未知語)として取り出すということを行う。そして、いったん未知語として取り出された後は、辞書に登録されているそれと同様に一つの単語として扱われる。(ただし各カテゴリには、単語辞書内の単語と同様に、品詞IDやコストなどを与えておく必要があり、各カテゴリの品詞IDやコストが、それに属する未知語の品詞ID、コストとなる)
MeCabの場合、英字やカタカナといった特定のカテゴリ以外に、デフォルトカテゴリ(どのカテゴリにも属さない文字が属するカテゴリ)が用意されているので、どの文字も必ず何らかのカテゴリに属することになる。

未知語定義ファイル

上に書いたような文字とカテゴリのマッピング${IPADIC}/char.def*2に、各カテゴリの品詞IDなどは${IPADIC}/unk.defに定義されている。
各ファイルの詳細は、MeCabのサイトで詳細に説明されているので、そちらを参照のこと。
ここでは以降の処理のための必要な準備を行っておく。

# char.defのコピー&文字コード変換
# char.defでは、以下の二つが定義されている
# 1] 文字カテゴリ  ※ カテゴリ名やカテゴリの処理ルールなど
# 2] 文字(UCS2コード値)とカテゴリのマッピング
> nkf -w ${IPADIC}/char.def > ${DATA}/char.def

# unk.defのコピー&文字コード変換
# unk.defでは、各カテゴリの品詞などが定義されている
# 例] NUMERIC,1295,1295,27386,名詞,数,*,*,*,*,*
> nkf -w ${IPADIC}/unk.def > ${DATA}/unk.def

実装

前回までと同様に、実装の大半は、構造体の定義やデータ読込み、基本的なアクセサが占めている。
まずは、それらをまとめて載せる。※ これも前回までと同様に、データのバリデーション等は行っていない

;;;;;;;;;;;;;;
;;; パッケージ
(require :iterate)
(require :cl-ppcre)
(use-package :cl-ppcre)

;;;;;;;;;;
;;; 構造体
;; 文字カテゴリ用の構造体
;; 各フィールドは、char.def内の定義行のそれと一対一で対応
(defstruct category name invoke? group? length)

;;;;;;;;;;;;;;;;
;;; char.def関連
;; 文字カテゴリ定義行読込み
(defun read-category-definition-line (line)
  (destructuring-bind (nm ivk? gp? len) (split "\\s+" line :limit 4)
    (make-category :name    (intern  nm)
                   :invoke? (string= ivk? "1")
                   :group?  (string= gp?  "1")
                   :length  (parse-integer len))))

;; 文字(UCS2コード値)とカテゴリのマッピングの読込み、設定
;; 定義例1] 0x0020 SPACE             # " "はカテゴリSPACEに属する
;; 定義例2] 0x0030..0x0039 NUMERIC   # "1"から"9"はカテゴリNUMERICに属する
;; 定義例3] x4E00 KANJINUMERIC KANJI # "一"はデフォルトカテゴリKANJINUMERICと互換カテゴリKANJIに属する
(defun set-char=>category-map (map definition-line)
  (destructuring-bind (code . category-names) (split "\\s+" definition-line)
    (setf category-names (mapcar #'intern category-names))
    (destructuring-bind (beg &optional (end beg)) (split "\\.\\." code)
      (let ((beg (parse-integer beg :radix 16 :start 2))
            (end (parse-integer end :radix 16 :start 2)))
        (loop FOR cd FROM beg TO end DO
          (setf (gethash (code-char cd) map) category-names)))))
  map)

;; コメントを除去した文字列を返す
(defun remove-comment (line)
  (regex-replace "#.*$" line ""))

;; char.defを読み込む
(defun read-char.def (filepath)
  (let ((char-category-map (make-hash-table))
        (categorys '()))
    (iterate:iter (iterate:for line in-file filepath using #'read-line)
      (setf line (remove-comment line))
      (unless (zerop (length line))
        (if (string= "0x" line :end2 2)
            ;; "0x"で始まる行は、文字とカテゴリのマッピング定義行
            (set-char=>category-map char-category-map line)
          ;; それ以外はカテゴリ定義行
          (push (read-category-definition-line line)
                categorys))))
    (values char-category-map categorys)))

;; char.def読込み内容を、スペシャル変数に保存する
(multiple-value-bind (map categorys) (read-char.def "data/char.def")
  (defparameter *char-category-map* map)
  (defparameter *categorys* categorys))

;;;;;;;;;;;;;;;
;;; unk.def関連
;; 文字カテゴリの品詞(など)定義行を読み込む
;; 内容的には、単語辞書の読込みとほぼ同様だが、読込み時にはsurfaceが未設定な点が異なる
(defun read-unk.def (filepath)
  (let ((map (make-hash-table :test #'eq)))
    (iterate:iter (iterate:for line in-file filepath using #'read-line)
      (destructuring-bind (category-name lid rid cost info) (split "," line :limit 5)
        (push (make-word :left-id  (parse-integer lid)
                         :right-id (parse-integer rid)
                         :cost     (parse-integer cost)
                         :info     info)
              (gethash (intern category-name) map))))
    map))
;; 読み込む
(defparameter *unk-word-map* (read-unk.def "data/unk.def"))

;;;;;;;;;;;;;;;;
;;; 各種補助関数
;; カテゴリ用のwordインスタンスにはsurface(具体的な単語名)が欠如しているので、それを設定する
(defun embody-unknown-word (surface template-unknown-word)
  (let ((w (copy-word template-unknown-word)))
    (setf (word-surface w) surface)
    w))

;; カテゴリ名に対応するwordのリストを生成する
(defun gen-unknown-words (category-name surface)
  (mapcar (lambda (unk-word)
            (embody-unknown-word surface unk-word))
          (gethash category-name *unk-word-map*)))

;; 例
> (gen-unknown-words 'KATAKANA "インスタンス")
--> (["インスタンス":感動詞,*,*,*,*,*,*] ["インスタンス":名詞,固有名詞,一般,*,*,*,*]
 ["インスタンス":名詞,固有名詞,人名,一般,*,*,*] ["インスタンス":名詞,固有名詞,組織,*,*,*,*]
 ["インスタンス":名詞,固有名詞,地域,一般,*,*,*] ["インスタンス":名詞,一般,*,*,*,*,*])

> (gen-unknown-words 'NUMERIC "123")
(["123":名詞,数,*,*,*,*,*])


;; 引数の文字が属するカテゴリのリストを取得する
;; リストの一番目が正式な(?)カテゴリで、二番目以降はサブカテゴリ
(defun get-char-categorys (char)
  (mapcar (lambda (category-name)
            (find category-name *categorys* :key #'category-name))
          (gethash char *char-category-map* '(default))))

;; 例
> (get-char-categorys #\a)
--> (#S(CATEGORY :NAME ALPHA :INVOKE? T :GROUP? T :LENGTH 0))

> (get-char-categorys #\三)
--> (#S(CATEGORY :NAME KANJINUMERIC :INVOKE? T :GROUP? T :LENGTH 0) 
     #S(CATEGORY :NAME KANJI :INVOKE? NIL :GROUP? NIL :LENGTH 2))


次は、入力テキストから未知語を取り出す関数の定義。

;; dicword-matched?は、単語辞書内にマッチする単語があったかどうか
(defun extract-unknown-words (text dicword-matched? &key (start 0))
         ;; text[start]の文字のカテゴリ取得
  (let ((category (first (get-char-categorys (char text start))))
        (text-len (length text)))
    (with-slots (name invoke? group? length) category
          ;; 既に単語辞書内にマッチする単語がある場合は、
          ;; invoke?フラグがtrueの場合だけ未知語処理を行う
      (if (and dicword-matched? (not invoke?))
          nil
        (let (ends)
          ;; lengthまでの長さの全ての同じカテゴリの文字を未知語として追加する
          ;; ex] len=3で、text="1234個"の場合、"1"と"12"と"123"が未知語となる
          (loop FOR i FROM (1+ start) TO (min (+ start length) (1- text-len))
                WHILE (member category (get-char-categorys (char text i)))
                DO (push i ends))

          ;; group?フラグがtrueの場合は、連接する同じカテゴリの文字全てを一つの単語として扱う
          ;; ex] text="1234個"の場合、"1234"が未知語となる
          (if group?
              (pushnew (1+ (position-if (lambda (categorys)
                                          (member category categorys))
                                        text :from-end t :key #'get-char-categorys))
                       ends)
            (pushnew (1+ start) ends))

          ;; 未知語を生成する
          (mapcan (lambda (end)
                    (gen-unknown-words name (subseq text start end)))
                  (or ends `(,(1+ start)))))))))

;; 例
> (extract-unknown-words "ocamlを勉強する" nil)
--> (["ocaml":感動詞,*,*,*,*,*,*] ["ocaml":名詞,固有名詞,一般,*,*,*,*]
     ["ocaml":名詞,固有名詞,人名,一般,*,*,*] ["ocaml":名詞,固有名詞,組織,*,*,*,*]
     ["ocaml":名詞,固有名詞,地域,一般,*,*,*] ["ocaml":名詞,一般,*,*,*,*,*])


これで、未知語も抽出できるようになったので、後は入力テキストから形態素を取り出す箇所を、この関数も使うように修正する。

;; 形態素解析器(2)で定義したmatched-word-list関数を修正
;; 前半部分は以前のものと基本的に同様
(defun matched-word-list (text &optional (*da* *da*))
  (let ((list '()))
    (dotimes (beg-pos (length text))
      (let ((pairs (doar:common-prefix-search text *da* :start beg-pos)))
        (dolist (pair pairs)
          (destructuring-bind (end-pos . word-id) pair
            (dolist (word (get-words word-id))
              (push (make-node :word word
                               :beg beg-pos
                               :end end-pos)
                    list))))
        ;; 未知語を取り出すコードを追加
        (dolist (unk-word (extract-unknown-words text pairs :start beg-pos))
          (push (make-node :word unk-word
                           :beg beg-pos
                           :end (+ beg-pos (length (word-surface unk-word))))
                list))))
    (nreverse list)))

;; 以前のlattice関数にあったアドホックな未知語処理を除去
(defun lattice (text &optional (*da* *da*) &aux (size (length text)))
  `(,(make-node :word *bos* :beg -1 :end 0 :cost 0)
    ,@(sort (matched-word-list text)
            (lambda (a b)
              (or (< (node-beg a) (node-beg b))
                  (< (node-end a) (node-end b)))))
    ,(make-node :word *eos* :beg size :end (1+ size))))

;; viterbi関数も若干修正
(defun viterbi (text &optional (*wdic* *wdic*) (*matrix* *matrix*) (*da* *da*))
  (let ((nodes (lattice text)))
    (dolist (cur (cdr nodes))
      (multiple-value-bind (prev-node min-cost)
          (select-min (nodes-end-at nodes (node-beg cur))
                      (lambda (prev)
                        (+ (node-cost prev)
                           (word-cost (node-word cur))
                           (link-cost (node-word prev) (node-word cur)))))
          (when prev-node  ; この条件判定を追加  ※1
            (setf (node-cost cur) min-cost
                  (node-prev cur) prev-node))))
    (car (last nodes))))

;; ※1 matched-word-list及びlattice関数を修正したことにより、
;;     BOSノードを始点としないノードが生じるようになってしまったので、この判定が必要。
;;     後でこの判定が不要なコードを掲載する。


以上の修正で、未知語も適切に扱えるようになった。

> (wakati "関数型言語ocamlを勉強する")
--> ("BOS" "関数" "型" "言語" "ocaml" "を" "勉強" "する" "EOS")

これまでのコードでは全て、以下の二つ段階を別々に扱っていた。

  1. 入力テキストにマッチする単語(形態素)を取り出す(lattice関数)
  2. その中から最適な形態素分割を求める(viterbi関数)

開発や説明のためには、これらを分けて扱った方が都合が良いのだが、実際には平行して処理することが可能だし、その方が効率も良い。
参考までに、両者を統合した版のコードも載せておく。

;; 入力テキストのstart位置にマッチする単語/形態素を取り出す。
(defun matched-node-list (text &key (*da* *da*) (start 0))
  (let ((matches (doar:common-prefix-search text *da* :start start)))
    (nconc 
     ;; 単語辞書内の単語
     (mapcan (lambda (cps-rlt)
               (destructuring-bind (end . word-id) cps-rlt
                 (mapcar (lambda (word)
                           (make-node :word word :beg start :end end))
                         (get-words word-id))))
             matches)

     ;; 未知語
     (mapcar (lambda (unk-word)
               (let ((end (+ start (length (word-surface unk-word)))))
                 (make-node :word unk-word :beg start :end end)))
             (extract-unknown-words text matches :start start)))))


;; 入力テキストからの形態素取り出しと、最適パスの計算を平行して行うviterbi関数
(defun viterbi (text &optional (*da* *da*) &aux (len (length text)))
  (let ((nodes (make-array (+ len 1) :initial-element nil))
        (eos (make-node :word *eos* :beg len :end len :cost 0)))
    ;; BOSを設定
    (setf (aref nodes 0)   (list (make-node :word *bos* :beg -1  :end 0 :cost 0)))
    (dotimes (beg-pos (1+ len))
      ;; マッチ終了位置がbeg-posのノードがあれば以降の処理を行う
      (when (aref nodes beg-pos)
        ;; textのbeg-posにマッチするノード(形態素)を取得する  ※ beg-pos==lenの場合は例外
        (dolist (node (if (= beg-pos len) 
                          (list eos)
                        (matched-node-list text :start beg-pos)))
          
          (unless (eq node eos) 
            ;; マッチ終了位置をインデックスとして、nodes配列に格納する
            (push node (aref nodes (node-end node))))

          ;; 以前のviteribi関数と同様に、コストが最小のノードを求めて、設定する
          (multiple-value-bind (prev-node min-cost)
            (select-min (aref nodes beg-pos)
                        (lambda (prev)
                          (+ (node-cost prev)
                             (word-cost (node-word node))
                             (link-cost (node-word prev) (node-word node)))))
            (setf (node-cost node) min-cost
                  (node-prev node) prev-node)))))
    eos))

;; 結果は同じ
> (wakati "関数型言語ocamlを勉強する")
--> ("BOS" "関数" "型" "言語" "ocaml" "を" "勉強" "する" "EOS")

一応、ここまででcommon lispを使ったとした形態素解析器の実装は終了。
速度的にはまだまだかなり改善の余地はあるし、全然使いやすいような構成にもなっていないが、アルゴリズム的にはだいたいベストな形になっているのではないかと思う。

*1:ただし、解析が文の途中で終了してしまうのを防ぐために、便宜的に入力テキスト中の全ての文字が'_'という未知語でもあるものとして処理していた

*2:IPADICなどの環境変数に関しては、形態素解析(1)を参照