Coverage report: /home/ellis/comp/core/lib/nlp/textrank.lisp

KindCoveredAll%
expression148162 91.4
branch68 75.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; textrank.lisp --- TextRank
2
 
3
 ;; based on https://web.eecs.umich.edu/~mihalcea/papers/mihalcea.emnlp04.pdf
4
 
5
 ;;; Code:
6
 (in-package :nlp/textrank)
7
 
8
 (defclass document-vertex (document ast:node)
9
   ((edges :accessor edges :initform (make-hash-table)
10
           :documentation "The keys of the hash table represent the
11
           edges, the values of the hash table represent the edge
12
           weights."))
13
   (:documentation "The document vertex class represents a document
14
 that is part of a graph. The edges slot of the document vertex class
15
 is used to store edges of that particular vertex. The keys in the
16
 edges slot hash table are the actual vertexes, and the values are the
17
 edge weights."))
18
 
19
 (defmethod cosine-similarity ((document-a document) (document-b document))
20
   "Calculate the cosine similarity between two vectors."
21
   (flet ((vector-product (document-a document-b)
22
            (loop for a across (vector-data document-a)
23
                  for b across (vector-data document-b)
24
                  sum (* a b)))
25
          (vector-sum-root (document)
26
            (sqrt (loop for i across (vector-data document)
27
                        sum (* i i))))
28
          (vector-zero-p (document)
29
            (every #'zerop (vector-data document))))
30
     (if (or (vector-zero-p document-a) (vector-zero-p document-b))
31
         0 ; if either vector is completely zero, they are dissimilar
32
         (/ (vector-product document-a document-b)
33
            (* (vector-sum-root document-a) (vector-sum-root document-b))))))
34
 
35
 (defmethod generate-document-similarity-vectors ((collection document-collection))
36
   "Set the edge weights for all document neighbors (graph is fully connected)."
37
   (with-accessors ((documents documents)) collection
38
     (loop for document-a in documents
39
           do (loop for document-b in documents
40
                    do (setf (gethash document-b (edges document-a))
41
                             (cosine-similarity document-a document-b))))))
42
 
43
 (defmethod textrank ((collection document-collection) &key (epsilon 0.001)
44
                                                             (damping 0.85)
45
                                                             (initial-rank)
46
                                                             (iteration-limit 100))
47
   "This method is used to calculate the text rankings for a document
48
    collection. The `epsilon' is the maximum delta for a given node
49
    rank change during an iteration to be considered convergent. The
50
    `damping' is a factor utilized to normalize the data. The
51
    `initial-rank' is the rank given to nodes before any
52
    iterations. The `iteration-limit' is the amount of times the
53
    algorithm may traverse the graph before giving up (if the algorithm
54
    does not converge)."
55
   (with-accessors ((documents documents)) collection
56
     (unless (zerop (length documents))
57
       (labels ((set-initial-rank ()
58
                  "Set the initial rank of all documents to a supplied
59
                 value OR 1/length of the documents."
60
                  (let ((initial-rank (or initial-rank (/ 1 (length documents)))))
61
                    (mapcar (lambda (document) (setf (rank document) initial-rank)) documents)))
62
                (graph-neighbors (document)
63
                  "Return a list of neighbors. In a fully connected graph,
64
                 all nodes are a neighbor except for the node itself."
65
                  (remove document documents))
66
                (graph-neighbor-edge-sum (document)
67
                  "Add up the edges of all neighbors of a given node."
68
                  (let ((sum (- (reduce #'+ (hash-table-values (edges document))) 1)))
69
                    (if (> sum 0) sum 1)))
70
                (document-similarity (document-a document-b)
71
                  (gethash document-b (edges document-a) 0))
72
                (convergedp (previous-score current-score)
73
                  "Check if a delta qualifies for convergence."
74
                  (<=  (abs (- previous-score current-score)) epsilon))
75
                (calculate-rank (document)
76
                  "Calculate the rank of a document."
77
                  (loop for neighbor in (graph-neighbors document)
78
                        sum (/ (* damping (rank neighbor) (document-similarity document neighbor))
79
                               (graph-neighbor-edge-sum neighbor)))))
80
         (set-initial-rank)
81
         (loop with converged = nil
82
               for iteration from 0 to iteration-limit until converged
83
               do (setf converged t)
84
                  (loop for document in documents
85
                        for old-rank = (rank document)
86
                        for new-rank = (calculate-rank document)
87
                        do (setf (rank document) new-rank)
88
                        unless (convergedp old-rank new-rank)
89
                        do (setf converged nil)))))))
90
 
91
 (defun summarize-text (text &key (summary-length 3) (show-rank-p nil))
92
   (let ((collection (make-instance 'document-collection)))
93
     (loop for sentence in (sentence-tokenize text)
94
           do (add-document collection
95
                            (make-instance 'document-vertex
96
                                           :string-contents sentence)))
97
     (tf-idf-vectorize-documents collection)
98
     (generate-document-similarity-vectors collection)
99
     (textrank collection :iteration-limit 100)
100
     (take summary-length
101
                    (mapcar (if show-rank-p
102
                                (lambda (i) (cons (rank i) (string-contents i)))
103
                                #'string-contents)
104
                            (sort (documents collection) #'> :key #'rank)))))