word-classes.scm

;
; grammatical class explorer
; Display stats and stuff, about the various word classes.
;
; -------------------------------------------------------
(use-modules (srfi srfi-1))
;
; Load all grammatical classes from storage
; XXX Don't use this; use ((make-gram-class-api) 'fetch-pairs) instead.
(define (fetch-all-gram-classes)
	(load-atoms-of-type 'WordClassNode)
	(for-each
		(lambda (CLS) (fetch-incoming-by-type CLS 'MemberLink))
		(cog-get-atoms 'WordClassNode)))

; How many grammatical classes are there?
(cog-count-atoms 'WordClassNode)

; Show them all
(cog-get-atoms 'WordClassNode)

; How many words have been classified? Note that this will double-count
; (triple-count, ...) all words that belong to two (three, ...)
; word-classes.
(define (num-classified-words)
	(define (nmemb CLS) (length (cog-incoming-by-type CLS 'MemberLink)))
	(fold (lambda (CLS cnt) (+ cnt (nmemb CLS))) 0
		(cog-get-atoms 'WordClassNode)))

; Print membership summary.
(define (prt-class-summary)
	(define (nmemb CLS) (length (cog-incoming-by-type CLS 'MemberLink)))
	(define all-classes (cog-get-atoms 'WordClassNode))
	(define by-size
		(sort! all-classes
			(lambda (CLS-A CLS-B) (> (nmemb CLS-A) (nmemb CLS-B)))))
	(define multi-cnt 0)
	(define single-cnt 0)
	(define hi-cnt 10000000000)
	(format #t "There are ~A words placed into ~A classes\n"
		(num-classified-words) (cog-count-atoms 'WordClassNode))
	
	(for-each
		(lambda (CLS)
			(if (< 1 (nmemb CLS))
				(set! multi-cnt (+ multi-cnt 1))
				(set! single-cnt (+ single-cnt 1))))
		by-size)
	(format #t "There are ~A classes with multiple members, and ~A singltons\n"
		multi-cnt single-cnt)
	(for-each
		(lambda (CLS)
			(define n (nmemb CLS))
			(if (< 1 n)
				(if (< n hi-cnt)
					(begin
						(set! hi-cnt n)
						(format #t "\nClasses with ~A members: <~A>"
							n (cog-name CLS)))
					(format #t " <~A>" (cog-name CLS)))))
		by-size)
	(newline)
)

; Print the members of one class.
; Print most frequent words first.
; (Roughly. The get-count is not really acccurate; it includes totals
; from pair counting, not MST counting.  And the MST counts get trashed
; during classification, so we don't have any good counts left...)
(define (prt-members-of-class CLS)
	(define membs (cog-incoming-by-type CLS 'MemberLink))
	(define words (map gar membs))
	(define words-by-freq
		(sort! words
			(lambda (WRD-A WRD-B) (> (get-count WRD-A) (get-count WRD-B)))))
	(format #t "Class <~A> has ~A members:\n   "
		(cog-name CLS) (length words-by-freq))
	(for-each
		(lambda (wrd)
			(format #t "~A " (cog-name wrd)))
		words-by-freq)
	(newline))

; Print all classes and members.
(define (prt-all-classes)
	(define (nmemb CLS) (length (cog-incoming-by-type CLS 'MemberLink)))
	(define all-classes (cog-get-atoms 'WordClassNode))
	(define by-size
		(sort! all-classes
			(lambda (CLS-A CLS-B) (> (nmemb CLS-A) (nmemb CLS-B)))))
	(format #t "There are ~A words placed into ~A classes\n"
		(num-classified-words) (cog-count-atoms 'WordClassNode))
	(for-each prt-members-of-class by-size))

; Print all of the classes that a word belongs to.
(define (prt-class-mebership WRD)
	(define membs (cog-incoming-by-type WRD 'MemberLink))
	(define classes (map gdr membs))
	(format #t "Word '~A' belongs to ~A classes:\n   "
		(cog-name WRD) (length classes))
	(for-each
		(lambda (cls) (format #t "<~A> " (cog-name cls)))
		classes)
	(newline))

; Print words that belong to more than one class
(define (prt-multi-members)
	(define nwrds 0)
	(define ducls '())
	(define (summer WRD)
		(define membs (cog-incoming-by-type WRD 'MemberLink))
		(if (< 1 (length membs))
			(begin
				(prt-class-mebership WRD)
				(set! nwrds (+ nwrds 1))
				(set! ducls (append ducls membs))))
	)
	(for-each summer (cog-get-atoms 'WordNode))
	(format #t "total words=~A total classes=~A unique classes=~A\n"
		nwrds (length ducls)
		(length (remove-duplicate-atoms (map gdr ducls))))
)

; -----------------------------------------------------------------
; -----------------------------------------------------------------
; -----------------------------------------------------------------
; Print a distribution of some statistic, vs. the class.
; First printed column: numerical ID for the class.
; Second printed column: The statistic.
; The FUNC  should be a function taking the class, returning a number.
(define (prt-distribution FUNC)
	(define all-classes (cog-get-atoms 'WordClassNode))
	(define by-size
		(sort! all-classes
			(lambda (CLS-A CLS-B) (> (FUNC CLS-A) (FUNC CLS-B)))))
	(define cnt 1)
	(for-each
		(lambda (CLS)
			(format #t "~A	~A\n" cnt (FUNC CLS))
			(set! cnt (+ cnt 1)))
		by-size))

; Print size distribution, viz, number of member-words.
; First column: numerical ID for the class.
; Second column: number of words in that class.
(define (prt-word-distribution)
	(define (nmemb CLS) (length (cog-incoming-by-type CLS 'MemberLink)))
	(prt-distribution nmemb))

(define (get-count atom)
	(if (cog-atom? atom) (cog-count atom) 0))

; Print disjunct support distribution, viz, number of distinct different
; disjuncts on each class
; Viz, this is the "support" or l_0 size.
; First column: numerical ID for the class.
; Second column: number of disjuncts in that class.
(define (prt-disjunct-support-distribution)
	(define (nmemb CLS) (length (cog-incoming-by-type CLS 'Section)))
	(prt-distribution nmemb))

; Print disjunct-count distribution, viz, total number of observations
; of disjuncts on each class
; Viz, this is the "count" or l_1 size.
; First column: numerical ID for the class.
; Second column: sum of observations of disjuncts in that class.
(define (prt-disjunct-count-distribution)
	(define (nmemb CLS)
		(fold (lambda (SECT cnt) (+ cnt (get-count SECT))) 0
 			(cog-incoming-by-type CLS 'Section)))
	(prt-distribution nmemb))

; Print disjunct-length distribution, viz, mean-square number of
; observations of disjuncts on each class
; Viz, this is the "length" or l_2 size.
; First column: numerical ID for the class.
; Second column: mean-square number of observations of disjuncts in that class.
(define (prt-disjunct-length-distribution)
	(define (nmemb CLS) (sqrt
		(fold (lambda (SECT cnt) (+ cnt
			(* (get-count SECT) (get-count SECT)))) 0
 			(cog-incoming-by-type CLS 'Section))))
	(prt-distribution nmemb))
;
; -----------------------------------------------------------------
;
; Print the distribution of disjuncts by disjunct-size.
; The disjunct-size is the number of connectors in a disjunct.
; Every section has exactly one disjunct in it.
; Loop over all sections on all word-classes, and count how many
; of these sections have the indicated size.
(define (prt-dj-size-distribution)
	(define (num-sections SIZ)
		(fold (lambda (CLS SUM)
				(+ SUM (length (get-sections-by-size CLS SIZ))))
			0
			(cog-get-atoms 'WordClassNode)))

	(define (prt-dist SIZ)
		(format #t "~A	~A\n" SIZ (num-sections SIZ)))

	(format #t "disjunct-size vs num-disjuncts\n")
	(list-tabulate 15 prt-dist)
)
;
; Print the distribution of disjuncts by disjunct-size.
; The disjunct-size is the number of connectors in a disjunct.
; Every section has exactly one disjunct in it.
; Loop over all sections on all word-classes, and count how many
; of these sections have the indicated size.
(define (prt-dj-weighted-size-distribution)
	(define (sum-section-weights SEC-LST)
		(fold (lambda (SEC SUM) (+ SUM (get-count SEC))) 0 SEC-LST))

	(define (weighted-num-sections SIZ)
		(fold (lambda (CLS SUM)
				(+ SUM (sum-section-weights (get-sections-by-size CLS SIZ))))
			0
			(cog-get-atoms 'WordClassNode)))

	(define (prt-dist SIZ)
		(format #t "~A	~A\n" SIZ (weighted-num-sections SIZ)))

	(format #t "disjunct-size vs weighted-num-disjuncts\n")
	(list-tabulate 15 prt-dist)
)
;
; -----------------------------------------------------------------