OverviewFilesCommitsIssuesDocsReleasesPeers

opencog-learn commits / 988f18f

LgParseMinimal no longer exists.
WordInstances are also gone. This is dead code.
988f18f90bf50ae6f32188e6f7d0baf30cf1b433
by Linas Vepstas <linasvepstas@gmail.com> · 2025-11-04T08:57:02.000Z

Changed files (3) +572 -575

scm/CMakeLists.txt +0 -3
……@@ -1,6 +1,5 @@
11ADD_GUILE_MODULE (FILES
22 learn.scm
3 common.scm
43 utils/utilities.scm
54 utils/waiter.scm
65
……@@ -29,8 +28,6 @@ ADD_GUILE_MODULE (FILES
2928 gram-class/similarity.scm
3029 gram-class/singletons.scm
3130
32 lg-compare.scm
33
3431 MODULE_DESTINATION "${GUILE_SITE_DIR}/opencog/learn"
3532)
3633
scm/attic/lg-compare.scm +572 -0
……@@ -0,0 +1,572 @@
1;
2; lg-compare.scm -- Compare parses from two different LG dictionaries.
3;
4; -----------------------------------------------------------------
5; Overview:
6; ---------
7; The general goal of the code here is to obtain the accuracy, recall
8; and other statistics of a test-dictionary, compared to a gold-standard
9; dictionary. This is done by creating a comparison function that can
10; parse sentences with both dictionaries, and then verify the presence
11; or absence of links between words.
12;
13(use-modules (srfi srfi-1))
14(use-modules (ice-9 optargs)) ; for define*-public
15
16(use-modules (opencog) (opencog exec) (opencog lg))
17
18
19(define*-public (make-lg-comparator gold-dict test-dict classes #:key
20 (INCLUDE-MISSING #f)
21 (VERBOSE #f)
22)
23"
24 make-lg-comparator GOLD-DICT OTHER-DICT CLASSES - Return a sentence
25 comparison function.
26
27 GOLD-DICT and OTHER-DICT should be the two LgDictNodes to compare.
28 The code assumes that GOLD-DICT is the reference or \"golden\" lexis
29 to compare to, so that any differences found in OTHER-DICT are blamed
30 on OTHER-DICT.
31
32 CLASSES is a list of lists of link types in the GOLD-DICT for which
33 statistics should be kept. The idea is that some link types in the
34 golden dict are more important to get right than others, and so stats
35 should be kept just for those. CLASSES may be an empty list, in which
36 case only overall stats are kept.
37
38 This returns a comparison function. To use it, pass one or more
39 sentence strings to it; it will compare the resulting parses.
40 When finished, pass it `#f`, and it will print a summary report.
41
42 Example usage:
43 (define compare (make-lg-comparator
44 (LgDictNode \"en\") (LgDictNode \"micro-fuzz\")
45 (list (list \"S\" \"O\" \"MV\") (list \"X\")) ))
46 (compare \"I saw her face\")
47 (compare \"I swooned to the floor\")
48 (compare #f)
49
50 By default, this does not test sentences that have words that are
51 not in the test dictionary. Over-ride this by supplying the optional
52 argument INCLUDE-MISSING.
53"
54 (let* ((verbose VERBOSE)
55
56 ; -------------------
57 ; Stats we are keeping
58 (total-sentences 0)
59 (total-compares 0)
60 (incomplete-dict 0)
61 (temp-cnt 0)
62 (bad-sentences 0)
63 (total-words 0)
64 (total-links 0)
65 (length-miscompares 0)
66 (word-miscompares 0)
67 (link-count-miscompares 0)
68 (link-correct 0)
69 (link-excess 0)
70 (link-deficit 0)
71
72 ; Counts of missing/present link types.
73 ; The last entry is for "none of the above".
74 (nclasses (length classes))
75 (present (make-vector (+ 1 nclasses) 0))
76 (missing (make-vector (+ 1 nclasses) 0))
77
78 (missing-link-types '())
79 (missing-words (make-atom-set))
80 (vocab-words (make-atom-set))
81 )
82
83 ; ----------------------------------------
84 ; Misc utilities
85
86 ; Get the word of the word instance, i.e. the WordNode.
87 (define (get-word-of-winst WRD)
88 (gdr (car (cog-incoming-by-type WRD 'ReferenceLink))))
89
90 ; Get the index of the word instance, i.e. the NumberNode.
91 (define (get-index-of-winst WRD)
92 (gdr (car (cog-incoming-by-type WRD 'WordSequenceLink))))
93
94 ; ------
95 ; Place the word-instance list into sequential order.
96 ; i.e. left-to-right order, as the word appear in a sentence.
97 (define (sort-word-inst-list LST)
98 (sort LST
99 (lambda (wa wb)
100 (define (get-num wi)
101 (string->number (cog-name (get-index-of-winst wi))))
102 (< (get-num wa) (get-num wb)))))
103
104 ; ------
105 ; Return a sorted list of the paired word-instances that this
106 ; word links to. To avoid double-counting, this returns only the
107 ; links connecting to the right. To avoid spurious RIGHT-WALL
108 ; miscompares, all instances of RIGHT-WALL are stripped out.
109 (define (get-linked-winst WIN)
110 (sort-word-inst-list
111 (map gdr
112 ; Accept only those ListLinks that are bonfide word-links
113 (filter
114 (lambda (lili)
115 (and
116 ; Is the first word (left word) ours?
117 (equal? (gar lili) WIN)
118
119 ; Is the second word (right word) the RIGHT-WALL?
120 (not (equal? (cog-name
121 (get-word-of-winst (gdr lili))) "###RIGHT-WALL###"))
122
123 ; Are any of the possible EvaluationLink's
124 ; an LG relation? If so, we are happy.
125 (any
126 (lambda (evlnk)
127 (equal? 'LgLinkNode
128 (cog-type (gar evlnk))))
129 (cog-incoming-by-type lili 'EvaluationLink))
130 ))
131 (cog-incoming-by-type WIN 'ListLink)))))
132
133 ; ------
134 ; Return the name of a link connecting lwin (left word
135 ; instance) and rwin (right word instance). There must actually
136 ; be a link connecting them, else bad things happen.
137 (define (get-link-name lwin rwin)
138 (gar (car (filter
139 (lambda (evl)
140 (equal? (cog-type (gar evl)) 'LgLinkNode))
141 (cog-incoming-by-type (ListLink lwin rwin)
142 'EvaluationLink)))))
143
144 ; Return the string-name of a link. Truncate link subtypes.
145 (define (get-link-str-name lwin rwin)
146 (string-trim-right
147 (cog-name (get-link-name lwin rwin))
148 (char-set-adjoin char-set:lower-case #\*)))
149
150 ; For each link-class, see if the link type is in that class.
151 ; If it is, then increment the count on that class. If it is
152 ; not in any class, then increment the n+1'th count.
153 (define (incr-class-counts COUNT-VEC LINK-NAME)
154 (define touched #f)
155 (for-each
156 (lambda (k)
157 (if (any (lambda (ltyp) (equal? ltyp LINK-NAME)) (list-ref classes k))
158 (begin
159 (vector-set! COUNT-VEC k (+ 1 (vector-ref COUNT-VEC k)))
160 (set! touched #t))))
161 (iota nclasses))
162
163 ; If the link-type was not in any class, thenm increment "other"
164 (if (not touched)
165 (vector-set! COUNT-VEC nclasses (+ 1 (vector-ref COUNT-VEC nclasses))))
166 )
167
168 ; ------
169 ; Increment count for a missing link type putting the count
170 ; in an association list, so that we can print all muffed
171 ; types at the end.
172 (define (incr-missing-link-type-count link-name)
173 (define cnt (assoc-ref missing-link-types link-name))
174 (if (not cnt) (set! cnt 0))
175 (set! missing-link-types
176 (assoc-set! missing-link-types link-name (+ 1 cnt))))
177
178 (define (incr-missing-link-count lwin rwin)
179 (define link-name (get-link-str-name lwin rwin))
180 (if VERBOSE
181 (format #t "Missing link: ~A <-- ~A --> ~A\n"
182 (cog-name (get-word-of-winst lwin))
183 link-name
184 (cog-name (get-word-of-winst rwin))))
185
186 ; Increment the count on specific link classes in the
187 ; golden dictionary.
188 (incr-class-counts missing link-name)
189
190 ; Increment the count on individual link types.
191 (incr-missing-link-type-count link-name)
192 )
193
194 (define (incr-present-link-count lwin rwin)
195 (define link-name (get-link-str-name lwin rwin))
196 (if VERBOSE
197 (format #t "Have link: ~A <-- ~A --> ~A\n"
198 (cog-name (get-word-of-winst lwin))
199 link-name
200 (cog-name (get-word-of-winst rwin))))
201
202 ; Increment the count on specific link classes in the
203 ; golden dictionary.
204 (incr-class-counts missing link-name)
205 )
206
207 ; ----------------------------------------
208 ; Comparison functions
209
210 ; Return the number of words in the sentence that are not in
211 ; the test dictionary. This also adds them to the mising-words
212 ; set.
213 (define (num-missing-words winli dict)
214 (fold
215 (lambda (win cnt)
216 (define wrd (get-word-of-winst win))
217 (if (< 0.5 (cog-tv-mean
218 (cog-evaluate! (LgHaveDictEntry wrd dict))))
219 cnt
220 (begin
221 (missing-words wrd)
222 (+ cnt 1))))
223 0 winli))
224
225 ; Return #t if the sentence contains missing words.
226 (define (has-missing-words winli dict)
227 (if (< 0 (num-missing-words winli dict))
228 (begin
229 (set! incomplete-dict (+ 1 incomplete-dict))
230 #t)
231 #f))
232
233 ; ---
234 ; The length of the sentences should match.
235 (define (compare-lengths gold-sorted test-sorted)
236 (define ewlilen (length gold-sorted))
237 (define owlilen (length test-sorted))
238
239 ; Both should usually have the same length. Note, however,
240 ; that LG English will split "I'm" -> "I 'm" i.e. one word
241 ; into two, and that many/most test dictionaries do NOT do
242 ; this. This leads to instant miscompares... Count total
243 ; words ONLY if lengh-compare passes.
244 (if (equal? ewlilen owlilen)
245 (set! total-words (+ total-words ewlilen))
246 (begin
247 (format #t "Length miscompare: ~A vs ~A\n" ewlilen owlilen)
248 (set! length-miscompares (+ 1 length-miscompares))))
249
250 ; Return #t is the lengths are good!
251 (equal? ewlilen owlilen))
252
253 ; ---
254 ; The words should compare. We are not currently comparing the
255 ; sequence; doing so would be complicated, and I don't see how
256 ; the sequences could ever mis-compare...
257 (define (compare-words ewinst owinst)
258 (define ewrd (get-word-of-winst ewinst))
259 (define owrd (get-word-of-winst owinst))
260 (vocab-words ewrd)
261 (if (not (equal? ewrd owrd))
262 (begin
263 (if verbose
264 (format #t "Word miscompare at ~A: ~A vs ~A\n"
265 (get-index-of-winst ewinst) ewrd owrd))
266 (set! word-miscompares (+ 1 word-miscompares)))))
267
268 ; ---
269 ; Compare links. For the given words, find the words that link to
270 ; the right. Verify that there are the same number of them, and
271 ; that they have the same targets.
272 ; ewin should be a word-instance from the EN side
273 ; owin should be the OTHER word instance.
274 (define (compare-links ewin owin)
275 (define ewrd (get-word-of-winst ewin))
276
277 ; elinked and olinked are lists of word instances
278 ; that are linked to the right of the current word.
279 (define elinked (get-linked-winst ewin))
280 (define olinked (get-linked-winst owin))
281
282 ; Obtain sets of the linked words (not the word-instances)
283 (define ewords (map get-word-of-winst elinked))
284 (define owords (map get-word-of-winst olinked))
285
286 ; A set of words in ewords that are not in owords
287 ; These correspond to missing links.
288 (define miss-w (lset-difference equal? ewords owords))
289
290 ; A set of words in ewords that are also in owords
291 ; These correspond to correct links.
292 (define have-w (lset-intersection equal? ewords owords))
293
294 ; A set of words in owords that are not in ewords
295 ; These correspond to extra, unexpected links.
296 (define extra-w (lset-difference equal? owords ewords))
297
298 ; Keep only word-instances that are in the word-set.
299 (define (trim-wili wili wrd-set)
300 (filter
301 (lambda (wi)
302 (any
303 (lambda (wrd) (equal? (get-word-of-winst wi) wrd))
304 wrd-set))
305 wili))
306
307 ; Missing linked word-instances...
308 (define missing-wi (trim-wili elinked miss-w))
309 (define present-wi (trim-wili elinked have-w))
310 (define extra-wi (trim-wili olinked extra-w))
311
312 (define n-missing (length missing-wi))
313 (define n-present (length present-wi))
314 (define n-extra (length extra-wi))
315
316 (set! link-deficit (+ link-deficit n-missing))
317 (set! link-correct (+ link-correct n-present))
318 (set! link-excess (+ link-excess n-extra))
319
320 ; A count of how many LG-English generated.
321 (set! total-links (+ total-links (length elinked)))
322
323 (if (or (< 0 n-missing) (< 0 n-extra))
324 (begin
325 (if verbose
326 (format #t "Miscompare right-links: ~A missing, ~A extra for ~A"
327 n-missing n-extra ewrd))
328 (set! link-count-miscompares (+ 1 link-count-miscompares))))
329
330 ; Create a histogram of missing link types.
331 (for-each
332 (lambda (misw) (incr-missing-link-count ewin misw))
333 missing-wi)
334
335 ; And also the ones that we have.
336 (for-each
337 (lambda (havw) (incr-present-link-count ewin havw))
338 present-wi)
339 )
340
341 ; -------------------
342 ; The main comparison function
343 (define (do-compare SENT)
344 ; Get a parse, one for each dictionary.
345 (define gold-sent (cog-execute!
346 (LgParseMinimal (PhraseNode SENT) gold-dict (NumberNode 1))))
347 (define test-sent (cog-execute!
348 (LgParseMinimal (PhraseNode SENT) test-dict (NumberNode 1))))
349
350 ; Since only one parse, we expect only one...
351 (define gold-parse (gar (car
352 (cog-incoming-by-type gold-sent 'ParseLink))))
353 (define test-parse (gar (car
354 (cog-incoming-by-type test-sent 'ParseLink))))
355
356 ; Get a list of the words in each parse.
357 (define test-word-inst-list
358 (map gar (cog-incoming-by-type test-parse 'WordInstanceLink)))
359
360 (define left-wall (WordNode "###LEFT-WALL###"))
361 (define right-wall (WordNode "###RIGHT-WALL###"))
362
363 ; Get the list of words in the standard dict.
364 ; XXX Temp hack. Currently, the test dicts are missing
365 ; RIGHT-WALL and so we filter it out manually. This
366 ; should be made more elegant. Argh. And the gold dict
367 ; is missing them too ...
368 ; hang on, this is broken, anyway, because the test dicts are
369 ; exported to LG without hash-marks. ...
370 (define gold-word-inst-list
371 (filter
372 (lambda (winst)
373 (define wrd (get-word-of-winst winst))
374 (and
375 (not (equal? wrd left-wall))
376 (not (equal? wrd right-wall))))
377 (map gar (cog-incoming-by-type gold-parse 'WordInstanceLink))))
378
379 ; Sort into sequential order. Pain-in-the-neck. Hardly worth it.
380 (define gold-sorted (sort-word-inst-list gold-word-inst-list))
381 (define test-sorted (sort-word-inst-list test-word-inst-list))
382
383 (define gold-has-missing-words (has-missing-words gold-sorted gold-dict))
384 (define test-has-missing-words (has-missing-words test-sorted test-dict))
385
386 (set! total-sentences (+ total-sentences 1))
387
388 (if gold-has-missing-words
389 (format #t "Gold dictionary is missing words in: \"~A\"\n" SENT))
390
391 (if test-has-missing-words
392 (format #t "Test dictionary is missing words in: \"~A\"\n" SENT))
393
394 ; Don't do anything more, if the dict is missing words in the
395 ; sentence. ... unless the INCLUDE-MISSING flag is set.
396 ; Don't do anything if there as a sentence-length miscompare.
397 ; Such miscompares pointlessly garbage up the stats.
398 (if (and
399 (or (not test-has-missing-words) INCLUDE-MISSING
400 (not gold-has-missing-words))
401 (compare-lengths gold-sorted test-sorted))
402 (begin
403 (set! total-compares (+ total-compares 1))
404 (set! temp-cnt link-count-miscompares)
405
406 ; Compare words and links
407 (for-each
408 (lambda (ewrd owrd)
409 (compare-words ewrd owrd)
410 (compare-links ewrd owrd)
411 )
412 gold-sorted test-sorted)
413
414 (if (not (equal? temp-cnt link-count-miscompares))
415 (set! bad-sentences (+ 1 bad-sentences)))
416 (format #t "Finish compare of sentence ~A/~A: \"~A\"\n"
417 total-compares total-sentences SENT)
418 ))
419 )
420
421 ; -------------------
422 ; The main comparison function
423 (define (do-compare-gc SENT)
424 (define (kill typ)
425 (for-each cog-extract-recursive (cog-get-atoms typ)))
426 (catch 'C++-EXCEPTION
427 (lambda () (do-compare SENT))
428 (lambda (key . args) #f))
429
430 ; Cleanup most stuff, but not WordNodes, because
431 ; they have to be saved in the "missing words" list.
432 ; Sadly, cannot use push-pop atomspace as a result.
433 ; This makes an almost unmeasureable difference in
434 ; performance and mem usage... so is not really needed.
435 (kill 'NumberNode)
436 (kill 'WordInstanceNode)
437 (kill 'SentenceNode)
438 (kill 'PhraseNode)
439 (kill 'ParseNode)
440 (kill 'LgLinkNode)
441 (kill 'LgHaveDictEntry)
442 )
443
444 ; -------------------
445 (define (report-stats)
446 ; Compute link precision and recall.
447 ; total-links is the number of links that LG English found.
448 (define link-expected-positives (exact->inexact total-links))
449
450 ; The links that were exactly right.
451 (define link-true-positives link-correct)
452
453 ; The links we should not have seen...
454 (define link-false-positives link-excess)
455
456 ; The links that were just-pain missing.
457 (define link-false-negatives link-deficit)
458
459 (define link-recall (/ link-true-positives link-expected-positives))
460 (define link-precision (/ link-true-positives
461 (+ link-true-positives link-false-positives)))
462 (define link-f1 (/ (* 2.0 link-recall link-precision)
463 (+ link-recall link-precision)))
464
465 ; Put missing link counts into sorted order.
466 (define sorted-missing-links
467 (sort missing-link-types
468 (lambda (ia ib) (> (cdr ia) (cdr ib)))))
469
470 ; Compute the recall of important link types.
471 (define class-recall (make-vector (+ 1 nclasses) 0))
472 (define class-total (make-vector (+ 1 nclasses) 0))
473 (for-each
474 (lambda (k)
475 (define tot (+ (vector-ref missing k) (vector-ref present k)))
476 (define rcl
477 (if (equal? 0 tot) (inf)
478 (/ (vector-ref present k) tot)))
479 (vector-set! class-total k tot)
480 (vector-set! class-recall k rcl))
481 (iota (+ 1 nclasses)))
482
483 (newline)
484 (newline)
485 (format #t
486 "Examined ~A sentences; ~A had words not in dictionary (~6F %).\n"
487 total-sentences incomplete-dict
488 (/ (* 100.0 incomplete-dict) total-sentences))
489 (format #t
490 "Finished comparing ~A parses; ~A parsed differently (~6F %).\n"
491 total-compares bad-sentences
492 (/ (* 100.0 bad-sentences) total-compares))
493 (format #t
494 "Found ~A word instances, vocab= ~A words; expect to find ~A links\n"
495 total-words (length (vocab-words #f)) total-links)
496 (format #t "Dictionary was missing ~A words\n"
497 (length (missing-words #f)))
498 (format #t "Found ~A length-miscompares\n" length-miscompares)
499 (format #t "Found ~A word-miscompares\n" word-miscompares)
500 (format #t
501 "Found ~A words w/diffs in #links: ~A fewer and ~A extra links\n"
502 link-count-miscompares
503 link-deficit link-excess)
504
505 (format #t "Link precision=~6F recall=~6F F1=~6F\n"
506 link-precision link-recall link-f1)
507 (newline)
508
509 (for-each
510 (lambda (k)
511 (format #t "Link-class recall=~6F tot=~A ~A\n"
512 (vector-ref class-recall k)
513 (vector-ref class-total k)
514 (list-ref classes k)))
515 (iota nclasses))
516 (format #t "Other link-classes recall=~6F tot=~A\n"
517 (vector-ref class-recall nclasses)
518 (vector-ref class-total nclasses))
519
520 (newline)
521 (format #t "Counts of missing link-types: ~A\n\n"
522 sorted-missing-links)
523 (format #t "Missing words: ~A\n\n"
524 (map cog-name (missing-words #f)))
525 )
526
527 ; -------------------
528 ; The main comparison function
529 (lambda (SENT)
530 (if (not SENT)
531 (report-stats)
532 (do-compare-gc SENT)))
533 )
534)
535
536(define*-public (make-lg-en-comparator DICT #:key
537 (INCLUDE-MISSING #f)
538 (VERBOSE #f)
539)
540"
541 make-lg-en-comparator DICT - Return an English sentence comparison function.
542
543 DICT should be an LgDictNode containing a dictionary that will be
544 compared to the Link Grammar English dictionary.
545
546 This returns a comparison function. To use it, pass one or more
547 sentence strings to it; it will compare the resulting parses.
548 When finished, pass it `#f`, and it will print a summary report.
549
550 Example usage:
551 (define compare (make-lg-comparator (LgDictNode \"micro-fuzz\")))
552 (compare \"I saw her face\")
553 (compare \"I swooned to the floor\")
554 (compare #f)
555
556 By default, this does not test sentences that have words that are
557 not in the test dictionary. Over-ride this by supplying the optional
558 argument INCLUDE-MISSING.
559"
560
561 ; ----------------------------------------
562 ; LG English link-type classes
563 (define primary-links (list "S" "O" "MV" "SI" "CV"))
564 (define secondary-links (list "A" "AN" "B" "C" "D" "E" "EA" "G" "J" "M" "MX" "R"))
565 (define punct-links (list "X"))
566
567 (define classes (list primary-links secondary-links punct-links))
568
569 (make-lg-comparator (LgDictNode "en") DICT classes
570 #:INCLUDE-MISSING INCLUDE-MISSING
571 #:VERBOSE VERBOSE)
572)
scm/lg-compare.scm +0 -572
……@@ -1,572 +0,0 @@
1;
2; lg-compare.scm -- Compare parses from two different LG dictionaries.
3;
4; -----------------------------------------------------------------
5; Overview:
6; ---------
7; The general goal of the code here is to obtain the accuracy, recall
8; and other statistics of a test-dictionary, compared to a gold-standard
9; dictionary. This is done by creating a comparison function that can
10; parse sentences with both dictionaries, and then verify the presence
11; or absence of links between words.
12;
13(use-modules (srfi srfi-1))
14(use-modules (ice-9 optargs)) ; for define*-public
15
16(use-modules (opencog) (opencog exec) (opencog lg))
17
18
19(define*-public (make-lg-comparator gold-dict test-dict classes #:key
20 (INCLUDE-MISSING #f)
21 (VERBOSE #f)
22)
23"
24 make-lg-comparator GOLD-DICT OTHER-DICT CLASSES - Return a sentence
25 comparison function.
26
27 GOLD-DICT and OTHER-DICT should be the two LgDictNodes to compare.
28 The code assumes that GOLD-DICT is the reference or \"golden\" lexis
29 to compare to, so that any differences found in OTHER-DICT are blamed
30 on OTHER-DICT.
31
32 CLASSES is a list of lists of link types in the GOLD-DICT for which
33 statistics should be kept. The idea is that some link types in the
34 golden dict are more important to get right than others, and so stats
35 should be kept just for those. CLASSES may be an empty list, in which
36 case only overall stats are kept.
37
38 This returns a comparison function. To use it, pass one or more
39 sentence strings to it; it will compare the resulting parses.
40 When finished, pass it `#f`, and it will print a summary report.
41
42 Example usage:
43 (define compare (make-lg-comparator
44 (LgDictNode \"en\") (LgDictNode \"micro-fuzz\")
45 (list (list \"S\" \"O\" \"MV\") (list \"X\")) ))
46 (compare \"I saw her face\")
47 (compare \"I swooned to the floor\")
48 (compare #f)
49
50 By default, this does not test sentences that have words that are
51 not in the test dictionary. Over-ride this by supplying the optional
52 argument INCLUDE-MISSING.
53"
54 (let* ((verbose VERBOSE)
55
56 ; -------------------
57 ; Stats we are keeping
58 (total-sentences 0)
59 (total-compares 0)
60 (incomplete-dict 0)
61 (temp-cnt 0)
62 (bad-sentences 0)
63 (total-words 0)
64 (total-links 0)
65 (length-miscompares 0)
66 (word-miscompares 0)
67 (link-count-miscompares 0)
68 (link-correct 0)
69 (link-excess 0)
70 (link-deficit 0)
71
72 ; Counts of missing/present link types.
73 ; The last entry is for "none of the above".
74 (nclasses (length classes))
75 (present (make-vector (+ 1 nclasses) 0))
76 (missing (make-vector (+ 1 nclasses) 0))
77
78 (missing-link-types '())
79 (missing-words (make-atom-set))
80 (vocab-words (make-atom-set))
81 )
82
83 ; ----------------------------------------
84 ; Misc utilities
85
86 ; Get the word of the word instance, i.e. the WordNode.
87 (define (get-word-of-winst WRD)
88 (gdr (car (cog-incoming-by-type WRD 'ReferenceLink))))
89
90 ; Get the index of the word instance, i.e. the NumberNode.
91 (define (get-index-of-winst WRD)
92 (gdr (car (cog-incoming-by-type WRD 'WordSequenceLink))))
93
94 ; ------
95 ; Place the word-instance list into sequential order.
96 ; i.e. left-to-right order, as the word appear in a sentence.
97 (define (sort-word-inst-list LST)
98 (sort LST
99 (lambda (wa wb)
100 (define (get-num wi)
101 (string->number (cog-name (get-index-of-winst wi))))
102 (< (get-num wa) (get-num wb)))))
103
104 ; ------
105 ; Return a sorted list of the paired word-instances that this
106 ; word links to. To avoid double-counting, this returns only the
107 ; links connecting to the right. To avoid spurious RIGHT-WALL
108 ; miscompares, all instances of RIGHT-WALL are stripped out.
109 (define (get-linked-winst WIN)
110 (sort-word-inst-list
111 (map gdr
112 ; Accept only those ListLinks that are bonfide word-links
113 (filter
114 (lambda (lili)
115 (and
116 ; Is the first word (left word) ours?
117 (equal? (gar lili) WIN)
118
119 ; Is the second word (right word) the RIGHT-WALL?
120 (not (equal? (cog-name
121 (get-word-of-winst (gdr lili))) "###RIGHT-WALL###"))
122
123 ; Are any of the possible EvaluationLink's
124 ; an LG relation? If so, we are happy.
125 (any
126 (lambda (evlnk)
127 (equal? 'LgLinkNode
128 (cog-type (gar evlnk))))
129 (cog-incoming-by-type lili 'EvaluationLink))
130 ))
131 (cog-incoming-by-type WIN 'ListLink)))))
132
133 ; ------
134 ; Return the name of a link connecting lwin (left word
135 ; instance) and rwin (right word instance). There must actually
136 ; be a link connecting them, else bad things happen.
137 (define (get-link-name lwin rwin)
138 (gar (car (filter
139 (lambda (evl)
140 (equal? (cog-type (gar evl)) 'LgLinkNode))
141 (cog-incoming-by-type (ListLink lwin rwin)
142 'EvaluationLink)))))
143
144 ; Return the string-name of a link. Truncate link subtypes.
145 (define (get-link-str-name lwin rwin)
146 (string-trim-right
147 (cog-name (get-link-name lwin rwin))
148 (char-set-adjoin char-set:lower-case #\*)))
149
150 ; For each link-class, see if the link type is in that class.
151 ; If it is, then increment the count on that class. If it is
152 ; not in any class, then increment the n+1'th count.
153 (define (incr-class-counts COUNT-VEC LINK-NAME)
154 (define touched #f)
155 (for-each
156 (lambda (k)
157 (if (any (lambda (ltyp) (equal? ltyp LINK-NAME)) (list-ref classes k))
158 (begin
159 (vector-set! COUNT-VEC k (+ 1 (vector-ref COUNT-VEC k)))
160 (set! touched #t))))
161 (iota nclasses))
162
163 ; If the link-type was not in any class, thenm increment "other"
164 (if (not touched)
165 (vector-set! COUNT-VEC nclasses (+ 1 (vector-ref COUNT-VEC nclasses))))
166 )
167
168 ; ------
169 ; Increment count for a missing link type putting the count
170 ; in an association list, so that we can print all muffed
171 ; types at the end.
172 (define (incr-missing-link-type-count link-name)
173 (define cnt (assoc-ref missing-link-types link-name))
174 (if (not cnt) (set! cnt 0))
175 (set! missing-link-types
176 (assoc-set! missing-link-types link-name (+ 1 cnt))))
177
178 (define (incr-missing-link-count lwin rwin)
179 (define link-name (get-link-str-name lwin rwin))
180 (if VERBOSE
181 (format #t "Missing link: ~A <-- ~A --> ~A\n"
182 (cog-name (get-word-of-winst lwin))
183 link-name
184 (cog-name (get-word-of-winst rwin))))
185
186 ; Increment the count on specific link classes in the
187 ; golden dictionary.
188 (incr-class-counts missing link-name)
189
190 ; Increment the count on individual link types.
191 (incr-missing-link-type-count link-name)
192 )
193
194 (define (incr-present-link-count lwin rwin)
195 (define link-name (get-link-str-name lwin rwin))
196 (if VERBOSE
197 (format #t "Have link: ~A <-- ~A --> ~A\n"
198 (cog-name (get-word-of-winst lwin))
199 link-name
200 (cog-name (get-word-of-winst rwin))))
201
202 ; Increment the count on specific link classes in the
203 ; golden dictionary.
204 (incr-class-counts missing link-name)
205 )
206
207 ; ----------------------------------------
208 ; Comparison functions
209
210 ; Return the number of words in the sentence that are not in
211 ; the test dictionary. This also adds them to the mising-words
212 ; set.
213 (define (num-missing-words winli dict)
214 (fold
215 (lambda (win cnt)
216 (define wrd (get-word-of-winst win))
217 (if (< 0.5 (cog-tv-mean
218 (cog-evaluate! (LgHaveDictEntry wrd dict))))
219 cnt
220 (begin
221 (missing-words wrd)
222 (+ cnt 1))))
223 0 winli))
224
225 ; Return #t if the sentence contains missing words.
226 (define (has-missing-words winli dict)
227 (if (< 0 (num-missing-words winli dict))
228 (begin
229 (set! incomplete-dict (+ 1 incomplete-dict))
230 #t)
231 #f))
232
233 ; ---
234 ; The length of the sentences should match.
235 (define (compare-lengths gold-sorted test-sorted)
236 (define ewlilen (length gold-sorted))
237 (define owlilen (length test-sorted))
238
239 ; Both should usually have the same length. Note, however,
240 ; that LG English will split "I'm" -> "I 'm" i.e. one word
241 ; into two, and that many/most test dictionaries do NOT do
242 ; this. This leads to instant miscompares... Count total
243 ; words ONLY if lengh-compare passes.
244 (if (equal? ewlilen owlilen)
245 (set! total-words (+ total-words ewlilen))
246 (begin
247 (format #t "Length miscompare: ~A vs ~A\n" ewlilen owlilen)
248 (set! length-miscompares (+ 1 length-miscompares))))
249
250 ; Return #t is the lengths are good!
251 (equal? ewlilen owlilen))
252
253 ; ---
254 ; The words should compare. We are not currently comparing the
255 ; sequence; doing so would be complicated, and I don't see how
256 ; the sequences could ever mis-compare...
257 (define (compare-words ewinst owinst)
258 (define ewrd (get-word-of-winst ewinst))
259 (define owrd (get-word-of-winst owinst))
260 (vocab-words ewrd)
261 (if (not (equal? ewrd owrd))
262 (begin
263 (if verbose
264 (format #t "Word miscompare at ~A: ~A vs ~A\n"
265 (get-index-of-winst ewinst) ewrd owrd))
266 (set! word-miscompares (+ 1 word-miscompares)))))
267
268 ; ---
269 ; Compare links. For the given words, find the words that link to
270 ; the right. Verify that there are the same number of them, and
271 ; that they have the same targets.
272 ; ewin should be a word-instance from the EN side
273 ; owin should be the OTHER word instance.
274 (define (compare-links ewin owin)
275 (define ewrd (get-word-of-winst ewin))
276
277 ; elinked and olinked are lists of word instances
278 ; that are linked to the right of the current word.
279 (define elinked (get-linked-winst ewin))
280 (define olinked (get-linked-winst owin))
281
282 ; Obtain sets of the linked words (not the word-instances)
283 (define ewords (map get-word-of-winst elinked))
284 (define owords (map get-word-of-winst olinked))
285
286 ; A set of words in ewords that are not in owords
287 ; These correspond to missing links.
288 (define miss-w (lset-difference equal? ewords owords))
289
290 ; A set of words in ewords that are also in owords
291 ; These correspond to correct links.
292 (define have-w (lset-intersection equal? ewords owords))
293
294 ; A set of words in owords that are not in ewords
295 ; These correspond to extra, unexpected links.
296 (define extra-w (lset-difference equal? owords ewords))
297
298 ; Keep only word-instances that are in the word-set.
299 (define (trim-wili wili wrd-set)
300 (filter
301 (lambda (wi)
302 (any
303 (lambda (wrd) (equal? (get-word-of-winst wi) wrd))
304 wrd-set))
305 wili))
306
307 ; Missing linked word-instances...
308 (define missing-wi (trim-wili elinked miss-w))
309 (define present-wi (trim-wili elinked have-w))
310 (define extra-wi (trim-wili olinked extra-w))
311
312 (define n-missing (length missing-wi))
313 (define n-present (length present-wi))
314 (define n-extra (length extra-wi))
315
316 (set! link-deficit (+ link-deficit n-missing))
317 (set! link-correct (+ link-correct n-present))
318 (set! link-excess (+ link-excess n-extra))
319
320 ; A count of how many LG-English generated.
321 (set! total-links (+ total-links (length elinked)))
322
323 (if (or (< 0 n-missing) (< 0 n-extra))
324 (begin
325 (if verbose
326 (format #t "Miscompare right-links: ~A missing, ~A extra for ~A"
327 n-missing n-extra ewrd))
328 (set! link-count-miscompares (+ 1 link-count-miscompares))))
329
330 ; Create a histogram of missing link types.
331 (for-each
332 (lambda (misw) (incr-missing-link-count ewin misw))
333 missing-wi)
334
335 ; And also the ones that we have.
336 (for-each
337 (lambda (havw) (incr-present-link-count ewin havw))
338 present-wi)
339 )
340
341 ; -------------------
342 ; The main comparison function
343 (define (do-compare SENT)
344 ; Get a parse, one for each dictionary.
345 (define gold-sent (cog-execute!
346 (LgParseMinimal (PhraseNode SENT) gold-dict (NumberNode 1))))
347 (define test-sent (cog-execute!
348 (LgParseMinimal (PhraseNode SENT) test-dict (NumberNode 1))))
349
350 ; Since only one parse, we expect only one...
351 (define gold-parse (gar (car
352 (cog-incoming-by-type gold-sent 'ParseLink))))
353 (define test-parse (gar (car
354 (cog-incoming-by-type test-sent 'ParseLink))))
355
356 ; Get a list of the words in each parse.
357 (define test-word-inst-list
358 (map gar (cog-incoming-by-type test-parse 'WordInstanceLink)))
359
360 (define left-wall (WordNode "###LEFT-WALL###"))
361 (define right-wall (WordNode "###RIGHT-WALL###"))
362
363 ; Get the list of words in the standard dict.
364 ; XXX Temp hack. Currently, the test dicts are missing
365 ; RIGHT-WALL and so we filter it out manually. This
366 ; should be made more elegant. Argh. And the gold dict
367 ; is missing them too ...
368 ; hang on, this is broken, anyway, because the test dicts are
369 ; exported to LG without hash-marks. ...
370 (define gold-word-inst-list
371 (filter
372 (lambda (winst)
373 (define wrd (get-word-of-winst winst))
374 (and
375 (not (equal? wrd left-wall))
376 (not (equal? wrd right-wall))))
377 (map gar (cog-incoming-by-type gold-parse 'WordInstanceLink))))
378
379 ; Sort into sequential order. Pain-in-the-neck. Hardly worth it.
380 (define gold-sorted (sort-word-inst-list gold-word-inst-list))
381 (define test-sorted (sort-word-inst-list test-word-inst-list))
382
383 (define gold-has-missing-words (has-missing-words gold-sorted gold-dict))
384 (define test-has-missing-words (has-missing-words test-sorted test-dict))
385
386 (set! total-sentences (+ total-sentences 1))
387
388 (if gold-has-missing-words
389 (format #t "Gold dictionary is missing words in: \"~A\"\n" SENT))
390
391 (if test-has-missing-words
392 (format #t "Test dictionary is missing words in: \"~A\"\n" SENT))
393
394 ; Don't do anything more, if the dict is missing words in the
395 ; sentence. ... unless the INCLUDE-MISSING flag is set.
396 ; Don't do anything if there as a sentence-length miscompare.
397 ; Such miscompares pointlessly garbage up the stats.
398 (if (and
399 (or (not test-has-missing-words) INCLUDE-MISSING
400 (not gold-has-missing-words))
401 (compare-lengths gold-sorted test-sorted))
402 (begin
403 (set! total-compares (+ total-compares 1))
404 (set! temp-cnt link-count-miscompares)
405
406 ; Compare words and links
407 (for-each
408 (lambda (ewrd owrd)
409 (compare-words ewrd owrd)
410 (compare-links ewrd owrd)
411 )
412 gold-sorted test-sorted)
413
414 (if (not (equal? temp-cnt link-count-miscompares))
415 (set! bad-sentences (+ 1 bad-sentences)))
416 (format #t "Finish compare of sentence ~A/~A: \"~A\"\n"
417 total-compares total-sentences SENT)
418 ))
419 )
420
421 ; -------------------
422 ; The main comparison function
423 (define (do-compare-gc SENT)
424 (define (kill typ)
425 (for-each cog-extract-recursive (cog-get-atoms typ)))
426 (catch 'C++-EXCEPTION
427 (lambda () (do-compare SENT))
428 (lambda (key . args) #f))
429
430 ; Cleanup most stuff, but not WordNodes, because
431 ; they have to be saved in the "missing words" list.
432 ; Sadly, cannot use push-pop atomspace as a result.
433 ; This makes an almost unmeasureable difference in
434 ; performance and mem usage... so is not really needed.
435 (kill 'NumberNode)
436 (kill 'WordInstanceNode)
437 (kill 'SentenceNode)
438 (kill 'PhraseNode)
439 (kill 'ParseNode)
440 (kill 'LgLinkNode)
441 (kill 'LgHaveDictEntry)
442 )
443
444 ; -------------------
445 (define (report-stats)
446 ; Compute link precision and recall.
447 ; total-links is the number of links that LG English found.
448 (define link-expected-positives (exact->inexact total-links))
449
450 ; The links that were exactly right.
451 (define link-true-positives link-correct)
452
453 ; The links we should not have seen...
454 (define link-false-positives link-excess)
455
456 ; The links that were just-pain missing.
457 (define link-false-negatives link-deficit)
458
459 (define link-recall (/ link-true-positives link-expected-positives))
460 (define link-precision (/ link-true-positives
461 (+ link-true-positives link-false-positives)))
462 (define link-f1 (/ (* 2.0 link-recall link-precision)
463 (+ link-recall link-precision)))
464
465 ; Put missing link counts into sorted order.
466 (define sorted-missing-links
467 (sort missing-link-types
468 (lambda (ia ib) (> (cdr ia) (cdr ib)))))
469
470 ; Compute the recall of important link types.
471 (define class-recall (make-vector (+ 1 nclasses) 0))
472 (define class-total (make-vector (+ 1 nclasses) 0))
473 (for-each
474 (lambda (k)
475 (define tot (+ (vector-ref missing k) (vector-ref present k)))
476 (define rcl
477 (if (equal? 0 tot) (inf)
478 (/ (vector-ref present k) tot)))
479 (vector-set! class-total k tot)
480 (vector-set! class-recall k rcl))
481 (iota (+ 1 nclasses)))
482
483 (newline)
484 (newline)
485 (format #t
486 "Examined ~A sentences; ~A had words not in dictionary (~6F %).\n"
487 total-sentences incomplete-dict
488 (/ (* 100.0 incomplete-dict) total-sentences))
489 (format #t
490 "Finished comparing ~A parses; ~A parsed differently (~6F %).\n"
491 total-compares bad-sentences
492 (/ (* 100.0 bad-sentences) total-compares))
493 (format #t
494 "Found ~A word instances, vocab= ~A words; expect to find ~A links\n"
495 total-words (length (vocab-words #f)) total-links)
496 (format #t "Dictionary was missing ~A words\n"
497 (length (missing-words #f)))
498 (format #t "Found ~A length-miscompares\n" length-miscompares)
499 (format #t "Found ~A word-miscompares\n" word-miscompares)
500 (format #t
501 "Found ~A words w/diffs in #links: ~A fewer and ~A extra links\n"
502 link-count-miscompares
503 link-deficit link-excess)
504
505 (format #t "Link precision=~6F recall=~6F F1=~6F\n"
506 link-precision link-recall link-f1)
507 (newline)
508
509 (for-each
510 (lambda (k)
511 (format #t "Link-class recall=~6F tot=~A ~A\n"
512 (vector-ref class-recall k)
513 (vector-ref class-total k)
514 (list-ref classes k)))
515 (iota nclasses))
516 (format #t "Other link-classes recall=~6F tot=~A\n"
517 (vector-ref class-recall nclasses)
518 (vector-ref class-total nclasses))
519
520 (newline)
521 (format #t "Counts of missing link-types: ~A\n\n"
522 sorted-missing-links)
523 (format #t "Missing words: ~A\n\n"
524 (map cog-name (missing-words #f)))
525 )
526
527 ; -------------------
528 ; The main comparison function
529 (lambda (SENT)
530 (if (not SENT)
531 (report-stats)
532 (do-compare-gc SENT)))
533 )
534)
535
536(define*-public (make-lg-en-comparator DICT #:key
537 (INCLUDE-MISSING #f)
538 (VERBOSE #f)
539)
540"
541 make-lg-en-comparator DICT - Return an English sentence comparison function.
542
543 DICT should be an LgDictNode containing a dictionary that will be
544 compared to the Link Grammar English dictionary.
545
546 This returns a comparison function. To use it, pass one or more
547 sentence strings to it; it will compare the resulting parses.
548 When finished, pass it `#f`, and it will print a summary report.
549
550 Example usage:
551 (define compare (make-lg-comparator (LgDictNode \"micro-fuzz\")))
552 (compare \"I saw her face\")
553 (compare \"I swooned to the floor\")
554 (compare #f)
555
556 By default, this does not test sentences that have words that are
557 not in the test dictionary. Over-ride this by supplying the optional
558 argument INCLUDE-MISSING.
559"
560
561 ; ----------------------------------------
562 ; LG English link-type classes
563 (define primary-links (list "S" "O" "MV" "SI" "CV"))
564 (define secondary-links (list "A" "AN" "B" "C" "D" "E" "EA" "G" "J" "M" "MX" "R"))
565 (define punct-links (list "X"))
566
567 (define classes (list primary-links secondary-links punct-links))
568
569 (make-lg-comparator (LgDictNode "en") DICT classes
570 #:INCLUDE-MISSING INCLUDE-MISSING
571 #:VERBOSE VERBOSE)
572)