-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathpos.lisp
227 lines (211 loc) · 11.3 KB
/
pos.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
;; -*- mode: Lisp; coding: utf-8-unix; -*-
;; Copyright (c) 2024, April & May
;; SPDX-License-Identifier: 0BSD
(in-package aprnlp)
(defclass pos-tagger (perceptron-processor)
((name :initform "unnamed-pos-tagger")
(unique-tag-words :initform (make-hash-table :test #'eq))))
(export 'pos-tagger)
(defparameter *loaded-pos-tagger* nil)
(export '*loaded-pos-tagger*)
;; Features
(defun prev-word (i words)
(declare (inline prev-word))
(if (< i 1) :start (word-form (aref words (1- i)))))
(defun prev-prev-word (i words)
(declare (inline prev-prev-word))
(if (< i 2) :start (word-form (aref words (- i 2)))))
(defun next-word (i words)
(declare (inline next-word))
(if (> i (- (length words) 2)) :end (word-form (aref words (1+ i)))))
(defun next-next-word (i words)
(declare (inline next-next-word))
(if (> i (- (length words) 3)) :end (word-form (aref words (+ i 2)))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *backward-features*
'((:word form t)
(:prev-word form prev-word)
(:prev-prev-word form prev-prev-word)
(:next-word form next-word)
(:next-next-word form next-next-word)
(:word t t)
(:prev-word t prev-word)
;(:prev-prev-word t (prev-prev-word i words))
(:next-word t next-word)
;(:next-next-word t (next-next-word i words))
;(:suffix form (suffix form))
;(:prefix form (prefix form))
(:suffix t (word-suffix word))
(:prefix t (word-prefix word))
;(:prev-suffix form (suffix (prev-word i words)))
;(:next-suffix form (suffix (next-word i words)))
(:prev-suffix t (if (< i 1) 'start (word-suffix (aref words (1- i)))))
(:next-suffix t (if (> i (- (length words) 2)) 'end (word-suffix (aref words (1+ i)))))
(:prev-tag form prev-tag)
;(:prev-prev-tag form prev-prev-tag)
(:prev-tag t prev-tag)
;(:prev-prev-tag t prev-prev-tag)
(:prev-tags prev-tag prev-prev-tag))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *forward-features*
'((:next-tag form next-tag)
;(:next-next-tag form next-next-tag)
(:next-tag t next-tag)
;(:next-next-tag t next-next-tag)
(:next-tags next-tag next-next-tag))))
(macrolet ((expand (features)
(let ((features (eval features)))
`(let* ((i (1- (word-id word)))
(form (general-form word))
(prev-word (prev-word i words))
(prev-prev-word (prev-prev-word i words))
(next-word (next-word i words))
(next-next-word (next-next-word i words))
(prev-tag (awhen prev-word (word-upos it)))
(prev-prev-tag (awhen prev-prev-word (word-upos it)))
(next-tag (awhen next-word (word-upos it)))
(next-next-tag (awhen next-next-word (word-upos it))))
(declare (ignorable i prev-word prev-prev-word next-word next-next-word
prev-tag prev-prev-tag next-tag next-next-tag))
(vector ,@(iter (for feature :in features)
(collect `(list ,@feature))))))))
(defun pos-backward-features (word words)
(declare (optimize (speed 3) (safety 0)))
(expand *backward-features*))
(defun pos-forward-features (word words)
(declare (optimize (speed 3) (safety 0)))
(expand *forward-features*))
(defun pos-all-features (word words)
(declare (optimize (speed 3) (safety 0)))
(expand (append *backward-features* *forward-features*))))
;; Methods
(defmethod process ((tagger pos-tagger) sentence)
(declare (optimize (speed 3) (space 0) (safety 0)))
(with-slots (weights unique-tag-words) tagger
(let ((scores (make-array (length sentence) :element-type 'hash-table)))
(iter (for word :in-vector sentence :with-index i)
(for form :next (word-form word))
(for unique-tag :next (gethash form unique-tag-words))
(setf (svref scores i) (make-hash-table :test #'eq))
(if unique-tag
(setf (gethash unique-tag (svref scores i)) most-positive-fixnum)
(iter (for feature :in-vector (pos-backward-features word sentence))
(awhen (apply #'href-default nil weights feature)
(iter (for (class weight) :in-hashtable it)
(incf (gethash class (svref scores i) 0.0) weight))))))
(iter (for word :in-vector sentence :with-index i :downto 0)
(for form :next (word-form word))
(for unique-tag :next (gethash form unique-tag-words))
(unless unique-tag
(iter (for feature :in-vector (pos-forward-features word sentence))
(awhen (apply #'href-default nil weights feature)
(iter (for (class weight) :in-hashtable it)
(incf (gethash class (svref scores i) 0.0) weight))))))
(iter (for table :in-vector scores :with-index i)
(setf (word-upos (aref sentence i))
(iter (for (class weight) :in-hashtable table)
(finding class :maximizing weight))))
sentence)))
(defmethod load-processor ((class (eql 'pos-tagger)) file)
#+lispworks (hcl:load-data-file file)
#-lispworks (load file)
*loaded-pos-tagger*)
(defmethod save-processor ((tagger pos-tagger) directory)
(with-slots (name weights unique-tag-words) tagger
(let ((filename (make-pathname :name name :type "fasl" :defaults directory)))
#+lispworks
(hcl:with-output-to-fasl-file (out filename :overwrite t)
(hcl:dump-form '(setf *loaded-pos-tagger* (make-instance 'pos-tagger)) out)
(hcl:dump-form `(setf (slot-value *loaded-pos-tagger* 'name) ,name) out)
(hcl:dump-form `(setf (slot-value *loaded-pos-tagger* 'weights)
(plist-to-table ',(table-to-plist weights)))
out)
(hcl:dump-form `(setf (slot-value *loaded-pos-tagger* 'unique-tag-words)
(plist-to-table ',(table-to-plist unique-tag-words)))
out))
#-lispworks
(let ((src (make-pathname :name name :type "lisp" :defaults directory)))
(with-open-file (out src
:direction :output
:if-exists :supersede
:if-does-not-exist :create)
(prin1 '(setf *loaded-pos-tagger* (make-instance 'pos-tagger)) out)
(prin1 `(setf (slot-value *loaded-pos-tagger* 'name) ,name) out)
(prin1 `(setf (slot-value *loaded-pos-tagger* 'weights)
(plist-to-table ',(table-to-plist weights)))
out)
(prin1 `(setf (slot-value *loaded-pos-tagger* 'unique-tag-words)
(plist-to-table ',(table-to-plist unique-tag-words)))
out))
(compile-file src :output-file filename)
(delete-file src))
(log-info "Tagger saved to ~A, size: ~A" (namestring filename) (print-size (file-size-in-octets filename)))
*loaded-pos-tagger*)))
(defmethod train ((tagger pos-tagger) sentences &key (cycles 5) (save-dir (asdf:system-source-directory :aprnlp)))
(declare (optimize (speed 3) (space 0) (safety 0)))
(with-slots (unique-tag-words) tagger
(log-info "Start training with ~D sentences, ~D cycles. ~A"
(length sentences) cycles
#+lispworks (lw:string-append "Heap size: " (print-size (getf (sys:room-values) :total-size)))
#-lispworks "")
(let ((table (make-hash-table :test #'eq)))
(iter (for sentence :in-vector sentences)
(iter (for word :in-vector sentence)
(incf (getf (gethash (word-form word) table) (word-upos word) 0))))
(iter (for (form plist) :in-hashtable table)
(if (> (length plist) 2)
(remhash form table)
(setf (gethash form table) (first plist))))
(setf unique-tag-words table)
(log-info "Found ~A words has unique tag." (hash-table-count table)))
(iter (for cycle :range cycles)
(let ((correct-count 0)
(total-count 0)
(cycle-start-time (get-internal-real-time)))
(iter (for sentence :in-vector sentences)
(for guess-sentence :next (process tagger (copy-sentence sentence)))
(iter (for truth-word :in-vector sentence :with-index i)
(for guess-word :in-vector guess-sentence)
(for truth :next (word-upos truth-word))
(for guess :next (word-upos guess-word))
(for features :next (pos-all-features truth-word sentence))
(update tagger truth guess features)
(when (eq guess truth) (incf correct-count))
(incf total-count)))
(shuffle sentences)
(log-info "Cycle ~D/~D completed using ~,2Fs with ~D/~D (~,2F%) correct. ~A"
(1+ cycle) cycles
#+lispworks (/ (- (get-internal-real-time) cycle-start-time) 1000)
#-lispworks (/ (- (get-internal-real-time) cycle-start-time) 1000000)
correct-count total-count (* 100.0 (/ correct-count total-count))
#+lispworks (lw:string-append "Heap size: " (print-size (getf (sys:room-values) :total-size)))
#-lispworks "")))
(average-weights tagger)
(save-processor tagger save-dir)))
(defmethod test ((tagger pos-tagger) sentences)
(let ((correct-count 0)
(total-count 0)
(start-time (get-internal-real-time)))
(iter (for sentence :in-vector sentences)
(iter (for truth-word :in-vector sentence)
(for guess-word :in-vector (process tagger (copy-sentence sentence)))
(if (eq (word-upos guess-word) (word-upos truth-word))
(incf correct-count))
(incf total-count)))
(log-info "Test ~D sentences using ~,2Fs, result: ~D/~D (~,2F%)"
(length sentences)
#+lispworks (/ (- (get-internal-real-time) start-time) 1000)
#-lispworks (/ (- (get-internal-real-time) start-time) 1000000)
correct-count total-count (* 100 (/ correct-count total-count)))
(float (* 100 (/ correct-count total-count)))))
(defmethod test-training ((class (eql 'pos-tagger)))
(download-ud-treebanks)
(let ((tagger (make-instance 'pos-tagger)))
(train tagger (read-conllu-files (treebank-file :english "GUM" :train)
(treebank-file :english "EWT" :train)
(treebank-file :english "Atis" :train))
:cycles 5)
(test tagger (read-conllu-files (treebank-file :english "GUM" :test)))
(setq *loaded-pos-tagger* tagger)
nil))
;(test-training 'pos-tagger)