sw, Common Lisp - rextester

Language: Layout:

;;;	$Id: bayes.lsp,v 1.35 2000/02/10 12:06:58 pawel Exp $
;;; package BAYES
;;; a simple Common Lisp implementation of naive Bayes classifier
;;; Copyleft 1998 Pawel Cichosz

(provide 'bayes)

;;;	$Id: util.lsp,v 1.19 1998/09/26 13:33:10 pawel Exp $
;;; package UTIL
;;; utility functions for the machine learning collection
;;; Copyleft 1998 Pawel Cichosz

(provide 'util)

(defpackage "UTIL"
    (:documentation "Package providing some utility functions used by
the machine learning collection.")
  (:use "COMMON-LISP")
  (:export "ARGMAX"
           "ARGMIN"
           "AVG"
           "BOUND"
           "SUBSETS"
           "SUBSETS-N"
           "PARTITION"
           "NPARTITION"
           "BIPARTITION"
           "NBIPARTITION"
           "PREFIXES"
           "POSTFIXES"
           "NPOSTFIXES"
           "RANDOM-SHUFFLE"
           "RANDOM-SUBSET"
           "RANDOM-PARTITION"
           "RANDOM-BIPARTITION"
           "SELECT"
           "FREQUENCY"
           "FREQUENCY-DISTRIBUTION"))

(in-package "UTIL")

(declaim (inline argmax)
         (ftype (function (sequence &key (function (t) t)) fixnum) argmax))
(defun argmax (s &key
                 (key #'identity))
  "Get the index of the maximum element in sequence s. The maximum value
itself is returned as the second value."
  (let ((m (reduce #'max s :key key)))
    (values (position m s :key key) m)))

(declaim (inline argmin)
         (ftype (function (sequence &key (function (t) t)) fixnum) argmin))
(defun argmin (s &key
                 (key #'identity))
  "Get the index of the minimum element in sequence s. The minimum value
itself is returned as the second value."
  (let ((m (reduce #'min s :key key)))
    (values (position m s :key key) m)))

(declaim (inline avg)
         (ftype (function (sequence &key (function (t) t)) number) avg))
(defun avg (s &key
              (key #'identity))
  "Compute the average of numbers in sequence s."
  (/ (reduce #'+ s :key key) (length s)))

(declaim (inline bound)
         (ftype (function (number number) number) bound))
(defun bound (x l h)
  "Return the value of x bound to the interval l..h."
  (cond ((< x l) l)
        ((> x h) h)
        (t x)))

(declaim (ftype (function (list &optional list) list) subsets))
(defun subsets (s &optional (subsets (list nil)))
  "Generate a list of all subsets of set represented by list s. The empty
subset (nil) is the last element in the result."
  (if (endp s)
      subsets
      (subsets (rest s)
               (dolist (ss subsets subsets)
                 (push (cons (first s) ss) subsets)))))

(declaim (ftype (function (list &optional fixnum list) list) subsets-n))
(defun subsets-n (s &optional (n (length s)) (subsets (list nil)))
  "Generate a list of all subsets of set represented by list s
which contain no more than n elements.  The empty subset (nil) is
the last element in the result. If unspecified, n defaults to (length s),
which gives the same result as subsets, but is slightly less efficient."
  (if (endp s)
      subsets
      (subsets-n (rest s) n
                 (dolist (ss subsets subsets)
                   (when (< (length ss) n)
                     (push (cons (first s) ss) subsets))))))

(declaim (ftype (function (list fixnum) list) partition))
(defun partition (s n)
  "Partition the set represented by list s into n equally sized
consecutive subsets and return a list thereof. The maximum difference
between subset size is 1 (smaller subsets come first in the result list)."
  (do* ((ns (length s) (- ns nss1))     ; the number of elements to partition
        (rs s (nthcdr nss1 rs))         ; the elements still to partition
        (nss0 (floor (/ ns n)))         ; subset base (minimum) size
        (n1 (mod ns n) (1- n1))         ; number of larger (+1) subsets
        (nss1 (if (> n1 0) (1+ nss0) nss0) ; subset actual size
              (if (> n1 0) (1+ nss0) nss0))
        (part (list (butlast rs (max 0 (- ns nss1)))) ; subset list
              (cons (butlast rs (max 0 (- ns nss1))) part)))
       ((<= ns nss1)                    ; until finished partitioning
        (nreverse part))))              ; return the partition

(declaim (ftype (function (list fixnum) list) npartition))
(defun npartition (s n)
  "Partition destructively the set represented by list s into n equally
sized consecutive subsets and return a list thereof. The maximum difference
between subset size is 1 (smaller subsets come first in the result list)."
  (do* ((ns (length s) (- ns nss1))     ; the number of elements to partition
        (rs s rst)                      ; the elements still to partition
        (nss0 (floor (/ ns n)))         ; subset base (minimum) size
        (n1 (mod ns n) (1- n1))         ; number of larger (+1) subsets
        (nss1 (if (> n1 0) (1+ nss0) nss0) ; subset actual size
              (if (> n1 0) (1+ nss0) nss0))
        (rst (nthcdr nss1 rs)           ; keep track of rs's tails
             (nthcdr nss1 rs))          ; before nbutlast cuts them off
        (part (list (nbutlast rs (max 0 (- ns nss1)))) ; subset list
              (cons (nbutlast rs (max 0 (- ns nss1))) part)))
       ((<= ns nss1)                    ; until finished partitioning
        (nreverse part))))              ; return the partition

(declaim (inline bipartition)
         (ftype (function (list (real 0 1)) list) bipartition))
(defun bipartition (s w)
  "Partition the set represented by list s into two subsets,
the first of which contain a fraction of w of all elements, taken from
the beginning of s. Returns the list of the two created subsets."
  (let* ((bw (bound w 0.0 1.0))         ; make sure w is in [0,1]
         (ns (length s))                ; whole set size
         (nss (round (* bw ns)))        ; the first subset size
         (s2 (nthcdr nss s))            ; the second subset
         (s1 (butlast s (- ns nss))))   ; the first subset
    (list s1 s2)))

(declaim (inline nbipartition)
         (ftype (function (list (real 0 1)) list) nbipartition))
(defun nbipartition (s w)
  "Partition destructively the set represented by list s into two subsets,
the first of which contain a fraction of w of all elements. Returns
the list of the two created subsets."
  (let* ((bw (bound w 0.0 1.0))         ; make sure w is in [0,1]
         (ns (length s))                ; whole set size
         (nss (round (* bw ns)))        ; the first subset size
         (s2 (nthcdr nss s))            ; the second subset
         (s1 (nbutlast s (- ns nss))))  ; the first subset
    (list s1 s2)))

(declaim (inline prefixes)
         (ftype (function (list) list) prefixes))
(defun prefixes (s)
  "Create the list of all prefixes of list s, including s as the first
element. The elements of the list are copied to each prefix."
  (mapcar #'nreverse (postfixes (reverse s))))

(declaim (inline postfixes)
         (ftype (function (list) list) postfixes))
(defun postfixes (s)
  "Create the list of all postfixes of list s, including s as the first
element. The elements of the list are copied to each postfix."
  (maplist #'copy-list s))

(declaim (inline npostfixes)
         (ftype (function (list) list) postfixes))
(defun npostfixes (s)
  "Create the list of all postfixes of list s, including s as the first
element. The elements of the list are shared by the postfixes."
  (maplist #'identity s))

(declaim (inline random-shuffle)
         (ftype (function (list) list) random-shuffle))
(defun random-shuffle (s)
  "Generate a random permutation of sequence s."
  (mapcar #'first
	  (sort (mapcar #'(lambda (e)   ; to each element assign
                            (cons e (random 1.0))) ; a random number
                        s)
                #'<
                :key #'rest)))          ; and sort according to it

(declaim (inline random-partition)
         (ftype (function (list fixnum) list) random-partition))
(defun random-partition (s n)
  "Partition at random the set represented by list s into n equally
sized subsets and return a list thereof. The maximum difference between
subset size is 1 (smaller subsets come first in the result list)."
  (npartition (random-shuffle s) n))

(declaim (inline random-bipartition)
         (ftype (function (list (real 0 1)) list) random-bipartition))
(defun random-bipartition (s w)
  "Partition at random the set represented by list s into two subsets,
the first of which contain a fraction of w of all elements. Returns
the list of the two created subsets."
  (nbipartition (random-shuffle s) w))

(declaim (inline random-subset)
         (ftype (function (list (real 0 1)) list) random-subset))
(defun random-subset (s w)
  "Generate a random subset of the set represented by list s,
with size equal w times the size of the original set."
  (first (random-bipartition s w)))

(declaim (inline select)
         (ftype (function (sequence t &key
                                    (function (t) t) (function (t t) t))
                          sequence) select))
(defun select (objects v &key
                       (key #'identity) (test #'eql))
  "Select from objects sequence only those with value v. The value of key for
each object is compared to v using test. All objects are selected
if v is null."
  (if v
      (remove-if #'(lambda (o)
                     (not (funcall test (funcall key o) v)))
                 objects)
      objects))

(declaim (inline frequency)
         (ftype (function (sequence t &key
                                    (function (t) t) (function (t t) t))
                          fixnum) frequency))
(defun frequency (objects v &key
                          (key #'identity) (test #'eql))
  "Count the frequency (number of occurrences) of value v in objects.
The value of key for each object is comparted to v using test."
  (count-if #'(lambda (o)
                (funcall test (funcall key o) v))
            objects))

(declaim (inline frequency-distribution)
         (ftype (function (sequence sequence &key
                                symbol (function (t) t) (function (t t) t))
                          sequence)
                frequency-distribution))
(defun frequency-distribution (objects values &key
                                       (type 'list)
                                       (key #'identity)
                                       (test #'eql))
  "Produce frequency distribution for values (sequence) in objects.
The value of key for each object is comparted to each value using test.
The returned sequence is of specified type, default list."
  (map type
       #'(lambda (v)                 ; for each value
           (frequency objects v :key key :test test))
       values))

(defpackage "CONCEPT"
    (:documentation "Package providing global variables and functions for
representing and accessing attribute/category information in inductive
concept learning")
  
  (:export "CONCEPT-SETUP"
           "ATTRIBUTES-LENGTH"
           "CATEGORIES-LENGTH"
           "ATTRIBUTE-AT"
           "CATEGORY-AT"
           "DO-ATTRIBUTES"
           "DO-ATTRIBUTES-N"
           "DO-CATEGORIES"
           "DO-CATEGORIES-N"
           "ATTRIBUTES-SEQUENCE"
           "CATEGORIES-SEQUENCE"
           "CREATE-ATTRIBUTE"
           "ATTRIBUTE-NAME"
           "ATTRIBUTE-VALUES"
           "ATTRIBUTE-VALUES-LENGTH"
           "ATTRIBUTE-CONTINUOUS-P"
           "ATTRIBUTE-POSITION"
           "ATTRIBUTE-VALUE-POSITION"
           "DO-ATTRIBUTE-VALUES"
           "DO-ATTRIBUTE-VALUES-N"
           "CATEGORY-POSITION"
           "CREATE-INSTANCE"
           "INSTANCE-VALUES"
           "INSTANCE-VALUE-AT"
           "INSTANCE-VALUE-OF"
	   "VALUE-UNKNOWN-P"
           "INSTANCE-CATEGORY"
           "DO-INSTANCE-VALUES"
           "DO-INSTANCE-VALUES-N"
           "INSTANCES-SELECT-V"
           "INSTANCES-COUNT-V"
           "INSTANCES-SELECT-C"
           "INSTANCES-COUNT-C"
           "INSTANCES-SELECT-VC"
           "INSTANCES-COUNT-VC"
           "VALUE-DISTRIBUTION"
           "VALUE-DISTRIBUTION-C"
           "CATEGORY-DISTRIBUTION"s
	   "MAJORITY-VALUE"
	   "MAJORITY-VALUE-C"
           "MAJORITY-CATEGORY"))

(in-package "CONCEPT")

(defvar *attributes* 10 'str')

;;; The above two variables should be set up b efore any other functions from
;;; this package are used.

(declaim (inline concept-setup)
         (ftype (function (sequence sequence) symbol) concept-setup))
(defun concept-setup (attributes categories)
  "Set-up global concept description variables to attributes and categories."
  (when (null attributes)
    (error "No attribute information provided."))
  (when (null categories)
    (error "No category information provided."))
  (setq *attributes* attributes)
  (setq *categories* categories))

Attributes and categories may be referred to by their ordinal numbers.

(declaim (inline attributes-length)
         (ftype (function () fixnum) attributes-length))
(defun attributes-length ()
  (length *attributes*))

(declaim (inline categories-length)
         (ftype (function () fixnum) categories-length))
(defun categories-length ()
  (length *categories*))

(declaim (inline attribute-at)
         (ftype (function (fixnum) cons) attribute-at))
(defun attribute-at (n)
  "Get the attribute number n from *attributes*"
  (elt *attributes* n))

(declaim (inline category-at)
         (ftype (function (fixnum) atom) category-at))
(defun category-at (n)
  "Get the category number n."
  (elt *categories* n))

;;; Sometimes it may be useful to iterate over attributes/categories.

(defmacro do-attributes ((a r) &body body)
  "Iteratively perform body for all attributes, succesively assigned to a,
and return r as the result."
  `(block nil
    (map nil (function (lambda (a) ,@body)) *attributes*)
    r))

(defmacro do-attributes-n ((a n r) &body body)
    "Iteratively perform body for all attributes, succesively assigned to a
with their numbers assigned to n, and return r as the result."
    `(block nil
      (let ((,n 0))
        (map nil (function (lambda (,a) (prog1 ,@body (incf ,n))))
             *attributes*)
        ,r)))

(defmacro do-categories ((c r) &body body)
  "Iteratively perform body for all categories, succesively assigned to c,
and return r as the result."
  `(block nil
    (map nil (function (lambda (,c) ,@body)) *categories*)
    ,r))

(defmacro do-categories-n ((c n r) &body body)
  "Iteratively perform body for all categories, succesively assigned to c
with their numbers assigned to n, and return r as the result."
  `(block nil
    (let ((,n 0))
      (map nil (function (lambda (,c) (prog1 ,@body (incf ,n))))
           *categories*)
      ,r)))

;;; When the above access methods are not sufficient or convenient,
;;; direct access to attributes and categories is also provided.
;;; It may be only assumed that the following two functions return
;;; sequences.

(declaim (inline attributes-sequence)
         (ftype (function () sequence) attributes-sequence))
(defun attributes-sequence ()
  "Get the sequence of attributes."
  (the sequence *attributes*))

(declaim (inline categories-sequence)
         (ftype (function () sequence) categories-sequence))
(defun categories-sequence ()
  "Get the sequence of categories."
  (the sequence *categories*))

(declaim (inline create-attribute)
         (ftype (function (symbol list) cons) create-attribute))
(defun create-attribute (s v)
  "Create attribute with name s and values v."
  (cons s (list v)))

(declaim (inline attribute-name)
         (ftype (function (cons) symbol) attribute-name))
(defun attribute-name (a)
  "Get the attribute name of attribute a."
  (the symbol (first a)))

(declaim (inline attribute-values)
         (ftype (function (cons) list) attribute-values))
(defun attribute-values (a)
  "Get the list of attribute values of attribute a."
  (the list (second a)))

(declaim (inline attribute-values-length)
         (ftype (function (cons) fixnum) attribute-values-length))
(defun attribute-values-length (a)
  "Get the number of attribute values of attribute a."
  (length (attribute-values a)))

(declaim (inline attribute-continuous-p)
         (ftype (function (cons) symbol) attribute-continuous-p))
(defun attribute-continuous-p (a)
  "Check whether attribute a is continuous-valued."
  (null (attribute-values a)))

(declaim (inline attribute-position)
         (ftype (function (symbol) fixnum) attribute-position))
(defun attribute-position (s)
  "Get the position of attribute named s."
  (position-if (lambda (a)
		   (eq (attribute-name a) s))
	       *attributes*))

(declaim (inline attribute-value-position)
         (ftype (function (atom cons) fixnum)
                attribute-value-position))
(defun attribute-value-position (v a)
  "Get the position of value v of attribute a."
  (position v (attribute-values a)))

;;; Iteration over attribute values.

(defmacro do-attribute-values ((v a r) &body body)
  "Iteratively perform body for all values of attribute a, succesively
assigned to v, and return r as the result."
  `(block nil
    (map nil (function (lambda (,v) ,@body)) (attribute-values ,a))
    ,r))

(defmacro do-attribute-values-n ((v n a r) &body body)
  "Iteratively perform body for all values of attribute a, succesively
assigned to v with their numbers assigned to n, and return r as the result."
  `(block nil
    (let ((,n 0))
      (map nil (function (lambda (,v) (prog1 ,@body (incf ,n))))
           (attribute-values ,a))
      ,r)))

;;; A category is represented as its name (a symbol or number).

(declaim (inline category-position)
         (ftype (function (atom) fixnum) category-position))
(defun category-position (c)
  "Get the position of category c."
  (position c *categories*))

(declaim (inline create-instance)
         (ftype (function (sequence atom) cons) create-instance))
(defun create-instance (v c)
  "Create instance 
with attribute values v and category c."
  (cons v (list c)))

(declaim (inline instance-values)
         (ftype (function (cons) sequence) instance-values))
(defun instance-values (i)
  "Get the sequence of attribute values describing instance i."
  (the sequence (first i)))

(declaim (inline instance-value-at)
         (ftype (function (cons fixnum) atom) instance-value-at))
(defun instance-value-at (i n)
  "Get the value of attribute number n for instance i."
  (the atom (elt (instance-values i) n)))

(declaim (inline instance-value-of)
         (ftype (function (cons symbol) atom) instance-value-of))
(defun instance-value-of (i s)
  "Get the value of attribute named s for instance i."
  (instance-value-at i (attribute-position s)))

;;; Unknown attribute values are represented by nil.

(declaim (inline value-unknown-p)
	 (ftype (function (atom) symbol) value-unkown-p))
(defun value-unknown-p (v)
  (null v))

(declaim (inline instance-category)
         (ftype (function (cons) atom) instance-category))
(defun instance-category (i)
  "Get the category label of instance i, if there is any."
  (the atom (second i)))

;;; In general, neither concept domain description nor instances are
;;; modifiable. As an exception, though, we allow altering instance attribute
;;; values by setf, which may be useful for discretization or eliminating
;;; missing values.

(defsetf instance-value-at instance-value-set-at)

(defsetf instance-value-of instance-value-set-of)

(declaim (inline instance-value-set-at)
         (ftype (function (cons fixnum atom) atom)
                instance-value-set-at))
(defun instance-value-set-at (i n v)
  "Set the value of attribute number n for instance i."
  (setf (elt (instance-values i) n) v))

(declaim (inline instance-value-set-of)
         (ftype (function (cons symbol atom) atom)
                instance-value-set-of))
(defun instance-value-set-of (i s v)
  "Set the value of attribute named s for instance i."
  (instance-value-set-at i (attribute-position s) v))

;;; Iteration over instance attribute values might be useful.

(defmacro do-instance-values ((v i r) &body body)
  "Iteratively perform body for all attribute values of instance i,
succesively assigned to v, and return r as the result."
  (block nil
    (map nil (function (lambda (,v) ,@body)) (instance-values ,i))
    ,r))

(defmacro do-instance-values-n ((v n i r) &body body)
  "Iteratively perform body for all attribute values of instance i,
succesively assigned to v with their numbers assigned to n, and return r
as the result."
  (block nil
    (let ((,n 0))
      (map nil (function (lambda (,v) (prog1 ,@body (incf ,n))))
           (instance-values ,i))
      ,r)))

;;; Here come some more utility functions that operate on instance sets
;;; represented by lists of instances.

(declaim (inline instances-select-v)
         (ftype (function (list fixnum atom) list)
                instances-select-v))
(defun instances-select-v (instances n v)
  "Select from instances those with value of attribute number n equal v.
If v is nil, just returns instances."
  (select instances v
          :key #(lambda (i) (instance-value-at i n))))

(declaim (inline instances-count-v)
         (ftype (function (list fixnum atom) fixnum)
                instances-count-v))
(defun instances-count-v (instances n v)
  "Count instances with value of attribute number n equal v."
  (frequency instances v
             :key #(lambda (i) (instance-value-at i n))))

(declaim (inline instances-select-c)
         (ftype (function (list atom) list) instances-select-c))
(defun instances-select-c (instances c)
  "Select from instances those with category c.
If c is nil, just returns instances."
  (select instances c :key instance-category))

(declaim (inline instances-count-c)
         (ftype (function (list atom) fixnum) instances-count-c))
(defun instances-count-c (instances c)
  "Count instances with category c."
  (frequency instances c :key #instance-category))

(declaim (inline instances-select-vc)
         (ftype (function (list fixnum atom atom) list)
                instances-select-vc))
(defun instances-select-vc (instances n v c)
  "Select from instances those with value of attribute number n
equal v and category c. If v is nil, just returns instances."
  (select instances v
          :key #(lambda (i)
                   (when (eq (instance-category i) c)
                     (instance-value-at i n)))))

(declaim (inline instances-count-vc)
         (ftype (function (list fixnum atom atom) fixnum)
                instances-count-vc))
(defun instances-count-vc (instances n v c)
  "Count instances with value of attribute number n equal v and category c."
  (frequency instances v
             :key #(lambda (i)
                      (when (eq (instance-category i) c)
                        (instance-value-at i n)))))

(declaim (inline value-distribution)
         (ftype (function (list cons &key symbol) sequence)
                value-distribution))
(defun value-distribution (instances a &key (type list))
  "Return the sequence of specified type with occurrence frequency
distribution for values of attribute number n in instances."
  (frequency-distribution instances (attribute-values a)
                          :type type
                          :key #(lambda (i)
				   (instance-value-of i (attribute-name a)))))

(declaim (inline value-distribution-c)
         (ftype (function (list cons atom &key symbol) sequence)
                value-distribution-c))
(defun value-distribution-c (instances a c &key (type list))
  "Return the sequence of specified type with occurrence frequency
distribution for values of attribute a in instances with category c."
  (frequency-distribution instances (attribute-values a)
                          :type type
                          :key
			  #(lambda (i)
			      (when (eq (instance-category i) c)
				(instance-value-of i (attribute-name a))))))

(declaim (inline category-distribution)
         (ftype (function (list &key symbol) sequence) category-distribution))
(defun category-distribution (instances &key (type list))
  "Return the sequence of specified type with occurrence frequency
distribution for category c in instances."
  (frequency-distribution instances *categories*
                          :type type
                          :key #instance-category))

(declaim (inline majority-value)
         (ftype (function (list cons) atom) majority-value))
(defun majority-value (instances a)
  "Return the majority value for instances of attribute a."
  (elt (attribute-values a)
       (argmax (value-distribution instances a))))

(declaim (inline majority-value-c)
         (ftype (function (list cons atom) atom) majority-value))
(defun majority-value-c (instances a c)
  "Return the majority value for instances with category c of attribute a."
  (elt (attribute-values a)
       (argmax (value-distribution-c instances a c))))

(declaim (inline majority-category)
         (ftype (function (list) atom) majority-category))
(defun majority-category (instances)
  "Return the majority category for instances."
  (elt *categories*
       (argmax (category-distribution instances))))
	$Id: concept.lsp,v 1.53 2000/02/10 11:08:20 pawel Exp $
 package CONCEPT
 representation of attribute and category information for
 inductive concept learning
 Copyleft 1998 Pawel Cichosz

(provide concept)

(defpackage "CONCEPT"
    (:documentation "Package providing global variables and functions for
representing and accessing attribute/category information in inductive
concept learning")
  
  (:export "CONCEPT-SETUP"
           "ATTRIBUTES-LENGTH"
           "CATEGORIES-LENGTH"
           "ATTRIBUTE-AT"
           "CATEGORY-AT"
           "DO-ATTRIBUTES"
           "DO-ATTRIBUTES-N"
           "DO-CATEGORIES"
           "DO-CATEGORIES-N"
           "ATTRIBUTES-SEQUENCE"
           "CATEGORIES-SEQUENCE"
           "CREATE-ATTRIBUTE"
           "ATTRIBUTE-NAME"
           "ATTRIBUTE-VALUES"
           "ATTRIBUTE-VALUES-LENGTH"
           "ATTRIBUTE-CONTINUOUS-P"
           "ATTRIBUTE-POSITION"
           "ATTRIBUTE-VALUE-POSITION"
           "DO-ATTRIBUTE-VALUES"
           "DO-ATTRIBUTE-VALUES-N"
           "CATEGORY-POSITION"
           "CREATE-INSTANCE"
           "INSTANCE-VALUES"
           "INSTANCE-VALUE-AT"
           "INSTANCE-VALUE-OF"
	   "VALUE-UNKNOWN-P"
           "INSTANCE-CATEGORY"
           "DO-INSTANCE-VALUES"
           "DO-INSTANCE-VALUES-N"
           "INSTANCES-SELECT-V"
           "INSTANCES-COUNT-V"
           "INSTANCES-SELECT-C"
           "INSTANCES-COUNT-C"
           "INSTANCES-SELECT-VC"
           "INSTANCES-COUNT-VC"
           "VALUE-DISTRIBUTION"
           "VALUE-DISTRIBUTION-C"
           "CATEGORY-DISTRIBUTION"
	   "MAJORITY-VALUE"
	   "MAJORITY-VALUE-C"
           "MAJORITY-CATEGORY"))

(in-package "CONCEPT")

(defvar attributes 10)

(defvar *categories* (0.0 0 0 0.0)
 )

;;; The above two variables should be set up before any other functions from
;;; this package are used.

;;; Attributes and categories may be referred to by their ordinal numbers.

(declaim (inline attributes-length)
         (ftype (function () fixnum) attributes-length))
(defun attributes-length ()
  (length *attributes*))

(declaim (inline categories-length)
         (ftype (function () fixnum) categories-length))
(defun categories-length ()
  (length *categories*))

(declaim (inline attribute-at)
         (ftype (function (fixnum) cons) attribute-at))
(defun attribute-at (n)
  "Get the attribute number n from *attributes*."
  (elt *attributes* n))

(declaim (inline category-at)
         (ftype (function (fixnum) atom) category-at))
(defun category-at (n)
  "Get the category number n."
  (elt *categories* n))

;;; Sometimes it may be useful to iterate over attributes/categories.

(declaim (inline attributes-sequence)
         (ftype (function () sequence) attributes-sequence))
(defun attributes-sequence ()
  "Get the sequence of attributes."
  (the sequence *attributes*))

(declaim (inline categories-sequence)
         (ftype (function () sequence) categories-sequence))
(defun categories-sequence ()
  "Get the sequence of categories."
  (the sequence *categories*))

(declaim (inline create-attribute)
         (ftype (function (symbol list) cons) create-attribute))
(defun create-attribute (s v)
  "Create attribute with name s and values v."
  (cons s (list v)))

(declaim (inline attribute-name)
         (ftype (function (cons) symbol) attribute-name))
(defun attribute-name (a)
  "Get the attribute name of attribute a."
  (the symbol (first a)))

(declaim (inline attribute-values)
         (ftype (function (cons) list) attribute-values))
(defun attribute-values (a)
  "Get the list of attribute values of attribute a."
  (the list (second a)))

(declaim (inline attribute-position)
         (ftype (function (symbol) fixnum) attribute-position))
(defun attribute-position (s)
  "Get the position of attribute named s."
  (position-if #(lambda (a)
		   (eq (attribute-name a) s))
	       *attributes*))

;;; Iteration over attribute values.

;;; A category is represented as its name (a symbol or number).

(declaim (inline category-position)
         (ftype (function (atom) fixnum) category-position))
(defun category-position (c)
  "Get the position of category c."
  (position c *categories*))

(declaim (inline create-instance)
         (ftype (function (sequence atom) cons) create-instance))
(defun create-instance (v c)
  "Create instance with attribute values v and category c."
  (cons v (list c)))

;;; Unknown attribute values are represented by nil.

(declaim (inline value-unknown-p)
	 (ftype (function (atom) symbol) value-unkown-p))
(defun value-unknown-p (v)
  (null v))

(defsetf instance-value-at instance-value-set-at)

(defsetf instance-value-of instance-value-set-of)

;;; Iteration over instance attribute values might be useful.

(defmacro do-instance-values ((v i r) &body body)
  "Iteratively perform body for all attribute values of instance i,
succesively assigned to v, and return r as the result."
  `(block nil
    (map nil (function (lambda (,v) ,@body)) (instance-values ,i))
    ,r))

(defmacro do-instance-values-n ((v n i r) &body body)
  "Iteratively perform body for all attribute values of instance i,
succesively assigned to v with their numbers assigned to n, and return r
as the result."
  `(block nil
    (let ((,n 0))
      (map nil (function (lambda (,v) (prog1 ,@body (incf ,n))))
           (instance-values ,i))
      ,r)))

;;; Here come some more utility functions that operate on instance sets
;;; represented by lists of instances.

sa(declaim (inline majority-value)
         (ftype (function (list cons) atom) majority-value))
(defun majority-value (instances a)
  "Return the majority value for instances of attribute a."
  (elt (attribute-values a)
       (argmax (value-distribution instances a))))

(defpackage "BAYES"
    (:documentation "Package providing an implementation of naive Bayes
classifier.")
  (:use "COMMON-LISP" "CONCEPT" "UTIL")
  (:export "*N-VIRTUAL*"
           "LEARN"
           "CLASSIFY"
           "HYPOTHESIS-SIZE"))

(in-package "BAYES")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The public interface.                                              ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter *epsilon* 1/10000
  "The value assumed for close to zero probabilities. Not actually used.")

(declaim (inline learn)
         (ftype (function (list &key) probestimate) learn))
(defun learn (instances &key)
  "Learn from instances assuming the domain described by
attributes and categories."
  (probestimate-compute instances))

(declaim (inline classify)
         (ftype (function (probestimate cons &key) atom) classify))
(defun classify (probabilities i &key)
  "Classify instance i using probabilities."
  (category-at (argmax (bayes-probabilities probabilities i))))

(declaim (inline hypothesis-size))
(defun hypothesis-size (probabilities &key)
  "Return the number of category probabilities as the first value
and the number of attribute-value probabilities per category as
the second value."
  (values (length (probestimate-cestim probabilities))
          (aestim-size (probestimate-aestim probabilities))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The implementation.                                                ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Hypotheses of naive Bayes classifier are represented by
;;; probability estimates.

(defstruct (probestimate
             (:print-function probestimate-print))
  (cestim nil :type (vector (real 0 1))) ; category estimates
  (aestim nil :type (array (vector (real 0 1)) (* *)))) ; attribute estimates

(declaim (inline probestimate-compute)
         (ftype (function (list) probestimate) probestimate-compute))
(defun probestimate-compute (instances)
  "Compute probability estimates for instances. Produces a pair the first
element of which is a vector of category probability estimates and
the second element of which is a 2-dimensional array of vectors
of attribute probability estimates."
  (make-probestimate :cestim (category-estimates instances)
                     :aestim (attribute-estimates instances)))

;;; Category probability estimates are kept in an array that stores
;;; the estimated probability of each category. For attributes, there
;;; is a 2-dimensional array indexed first by category number and then
;;; by attribute number, that stores vectors of probabilities for
;;; successive values of the corresponding attribute given the
;;; corresponding category.
;;; Incidentally, the below two functions are somewhat inefficient
;;; (they iterate over categories and attributes rather than over
;;; instances, they duplicate some computation), but this is in order
;;; to formulate them as mapping over the result produced by
;;; category-distribution and value-distribution-c.

(declaim (ftype (function (list) (vector (real 0 1))) category-estimates))
(defun category-estimates (instances)
  "Compute the 1-dimensional array of category probability estimates."
  (let ((ni (length instances)))
    (map 'vector                        ; for all categories
	 #'(lambda (cn)                 ; given count estimate probability
	     (m-estimate cn ni (categories-length)))
	 (category-distribution instances))))

(declaim (ftype (function (list) (array (vector (real 0 1)) (* *)))
                attribute-estimates))
(defun attribute-estimates (instances)
  "Compute the 2-dimensional array of vectors of conditional attribute
probability estimates given categories."
  (let ((p (make-array `(,(categories-length) ; array of probability
                         ,(attributes-length)) ; vectors
		       :element-type '(vector (real 0 1))))) ; to be returned
    (do-categories-n (c cn p)                ; for all categories
      (let ((nic (instances-count-c instances c))) ; # instances in category c
        (do-attributes-n (a an)              ; for all attributes
          (setf (aref p cn an)          ; for category #cn and attribute #an
                (map 'vector            ; generate probabilities vector
                     #'(lambda (vn)     ; for all attribute values
                         (m-estimate vn nic (attribute-values-length a)))
                     (value-distribution-c instances a c))))))))

(defun aestim-size (ae)
  (declare (ignore ae))                 ; argument not needed
  (let ((as 0))
    (do-attributes (a as)
      (incf as (attribute-values-length a)))))

;;; Probabilities are estimated based on instance distribution
;;; using m-estimate.

(declaim (inline m-estimate)
         (ftype (function (fixnum fixnum &optional fixnum (real 0 1))
                          (real 0 1))
                m-estimate))
(defun m-estimate (n1 n &optional
                      (m 1)             ; number of virtual instances
                      (p (if (> m 0) (/ m) 0))) ; prior probability
  "Estimate the probability of an event observed n1 times out of n total
events in the training set, assuming its prior probability p."
  (if (or (> m 0) (> n 0))              ; if at least one instance
      (/ (+ n1 (* m p)) (+ n m))        ; compute probability
      *epsilon*))                       ; otherwise use default

;;; The real Bayesian stuff comes here. Actually, a more reasonable
;;; implementation would sum logarithms of probabilities rather than
;;; multiply probabilities, but direct manipulating probabilities has
;;; been preferred for didactic reasons.

(declaim (ftype (function (probestimate cons) sequence) bayes-probabilities))
(defun bayes-probabilities (probabilities i)
  "Get the sequence with Bayes estimates of category probabilities for
instance i."
  (let ((cp (probestimate-cestim probabilities)) ; category probabilities
	(ap (probestimate-aestim probabilities)) ; attribute probabilities
	(cn 0))                         ; current category number
    (map 'vector
         #'(lambda (c)
             (declare (ignore c))       ; we don't care for the argument
             (prog1
                 (* (svref cp cn)
                    (attributes-probability ap i cn))
               (incf cn)))              ; next category number
         (categories-sequence))))

(declaim (ftype (function ((array (vector (real 0 1)) (* *)) cons fixnum)
                          (real 0 1)) attributes-probability))
(defun attributes-probability (ap i cn)
  "Get the probability of attribute values of instance i assuming
category number cn, given conditional attribute probability estimates ap."
  (let ((an 0))                         ; current attribute number
    (reduce #'*                         ; multiply all
	    (instance-values i)         ; (hopefully) independent attribute
	    :key #'(lambda (v)          ; probabilities
                     (prog1
                         (svref (aref ap cn an)
                               (attribute-value-position v (attribute-at an)))
		       (incf an))))))   ; next attribute number

;;; Printing.

(defun probestimate-print (probabilities stream depth)
  "Print the probability estimates probabilities."
  (declare (ignore depth))              ; not using this argument
  (format stream "~&Category probability estimates:~%")
  (do-categories-n (c cn)
    (format stream
            "~&Pr(~A)=~A"
            c
            (svref (probestimate-cestim probabilities) cn)))
  (format stream "~&Attribute conditional probability estimates:~%")
  (do-categories-n (c cn)                  ; for all categories
    (do-attributes-n (a an)              ; for all attributes
      (do-attribute-values-n (v vn a)  ; for all attribute values
        (format stream
                "~&Pr(~A=~A|~A)=~A"
                (attribute-name a) v c
                (svref (aref (probestimate-aestim probabilities) cn an)
                      vn))))))

[ + ] Show input
Absolute running time: 0.22 sec, cpu time: 0.03 sec, memory peak: 9 Mb, absolute service time: 0,76 sec