Sg, Common Lisp - rextester

Language: Layout:

(provide 'concept)

;;;	$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")
  (:use "COMMON-LISP" "UTIL")
  (: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")

;;; Two global variables are used for keeping really global data:
;;; domain description. But they are encapsulated (not exported) and
;;; should be only accessed with proper funtions defined in this package.

(defvar *attributes* nil
  "The sequence of attributes.")

(defvar *categories* nil
  "The sequence of categories.")

;;; The above two variables should be set up before 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*))

;;; An attribute is represented by a list the first element of which is
;;; its name (symbol) and the second  element of which is a list
;;; (not vector!) of its values (symbols or numbers), e.g.:
;;;     '(attr (val1 val2 val3))
;;; For continuous attributes no values should be specified, e.g.:
;;;     '(attr)

(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*))

;;; An instance is represented by a list consisting of a sequence of its
;;; attribute values as the first element and its category as the second
;;; element (it may be missing for testing instances), e.g.:
;;;    '((vala valb valc) category)

(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))))