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
|
;;; decision list learning algorithm (Rivest)
;;; returns a decision list, each element of which is
;;; a test of the form (x .term), where each term is
;;; of the form ((a1 . v1) (a2 . v2) ... (an . vn)).
;;; The last element is the test (0).
;;; only works for purely boolean attributes.
(defun decision-list-learning (k problem)
(dll k (learning-problem-examples problem)
(learning-problem-attributes problem)
(first (learning-problem-goals problem))))
(defun dll (k examples attributes goal)
(if (null examples)
(list (list 0))
(multiple-value-bind (test subset)
(select-test k examples attributes goal)
(if test
(cons test
(dll k (set-difference examples subset :test #'eq) attributes goal))
(error "Cannot find a consistent decision list")))))
;;; select-test finds a test of size at most k that picks out a set of
;;; examples with uniform classification. Returns test and subset.
(defun select-test (k examples attributes goal)
(dotimes (i (1+ k) (values nil nil))
(let ((test (select-k-test i examples attributes goal nil)))
(when test
(return (values test
(remove-if-not #'(lambda (e) (passes e test))
examples)))))))
(defun select-k-test (k examples attributes goal test-attributes)
(cond ((= 0 k)
(dolist (term (generate-terms test-attributes) nil)
(let ((subset (remove-if-not
#'(lambda (e) (passes e (cons 0 term)))
examples)))
(when (and subset (uniform-classification subset goal))
(return (cons (attribute-value goal (first subset)) term))))))
(t
(dolist (f attributes nil)
(let ((test (select-k-test (- k 1)
examples
(remove f attributes :test #'eq)
goal
(cons f test-attributes))))
(when test (return test)))))))
(defun generate-terms (attributes) ;;; generate all labellings
(if (null attributes)
(list nil)
(let ((rest (generate-terms (cdr attributes))))
(nconc (mapcar #'(lambda (test)
(cons (cons (car attributes) 0) test))
rest)
(mapcar #'(lambda (test)
(cons (cons (car attributes) 1) test))
rest)))))
(defun uniform-classification (examples goal)
(every #'(lambda (e) (eq (attribute-value goal e)
(attribute-value goal (first examples))))
(rest examples)))
(defun passes (example test)
(every #'(lambda (av)
(eq (attribute-value (car av) example) (cdr av)))
(cdr test)))
;;; dlpredict is the standard "performance element" that
;;; interfaces with the example-generation and learning-curve functions
(defun dlpredict (dl example)
(if (every #'(lambda (av) (eq (attribute-value (car av) example) (cdr av)))
(cdar dl))
(list (caar dl))
(dlpredict (cdr dl) example)))
|
