;;; This is an implementation of the basic ID3 algorithm for learning from examples, January, 1988.

;;;; Copyright (c) 1988 by Raymond Joseph Mooney. This program may be freely copied, used, or
;;;; modified provided that this copyright notice is included in each copy of this code
;;;; and parts thereof.

;;;; This implementation of ID3 produces decision trees descriminating postive and negatives
;;;; instances which are represented by simple nominal feature vectors represented by ordered lists. 
;;;; WEATHER-DOMAIN is a sample datafile for the weather example used in Quinlan's ML journal article
;;;; It currently does not support the iterative windowing aspect of ID3, since it is fairly
;;;; efficient on large problems as is.

(defvar *domains*)               ; A list defining the domain of each feature in the vector
(defvar *feature-names*)
(defparameter *trace-id3* nil)   ; Produces a trace if set to T

(defmacro trace-print (test-var &rest format-form)
  ;;; When test-var (usually a *-trace variable) is set then use formated print
  `(if ,test-var
       (format t ,@format-form)))

;;; A decision tree is either a symbol representing a leaf (+ or -) or a structure
;;; where decision-tree-feature is the number (starting from 1) of the feature
;;; being tested and decision-tree-subtrees is an assoc list of the form
;;; ((value1 subtree1)(value2 subtree2)...) representing the branches and subtrees

(defstruct (decision-tree (:print-function print-decision-tree))
  feature subtrees)

(defun id3 (examples)
;;; This function takes a list of examples where an example is a list consisting of either + or -
;;; and an instance and produces a decision tree which classifies instances into + or -.

  (prog1 (build-decision-tree examples (let ((features nil)) 
                                        (dotimes (i (length *domains*) features)
                                          (setf features (nconc features (list (1+ i)))))))
         (trace-print *trace-id3* "~%")))


(defun build-decision-tree (examples features &optional most-common)
;;; This function produces a decision tree for the given set of examples
;;; by choosing one of the given features (features are indicated by a
;;; number giving its position in the vector) as the root of the tree and
;;; recursively making trees for each of the resulting categories.
;;; most-common passes the most common class of a parent to its children
  
  (let ((p 0)(n 0))
    (dolist (example examples) (cond ((eq (first example) '+)
                                      (incf p))
                                     ((eq (first example) '-)
                                      (incf n))))
    (cond ((null examples) 
           ;; if there are no examples, label leaf with most common class from the parent node
           (trace-print *trace-id3* "~%No examples, use most common class of parent: ~A" most-common)
           most-common)
          ((zerop p)
           ;; if there are no positive examples then they must all be
           ;; negative so make
           ;; a leaf indicating a negative outcome.
           (trace-print *trace-id3* "~%All examples -")
           '-)
          ((zerop n)
           ;; if there are no negative examples then they must all be
           ;; positive so make
           ;; a leaf indicating a positive outcome.
           (trace-print *trace-id3* "~%All examples +")
           '+)
          ((null features)
           ;; if there are no features left to descriminate on and all
           ;; examples are not in the same class, then example set must
           ;; have had same instance both positive and negative
           (error "Inconsistent data"))
          (t (let ((I (info p n)) (split-feature nil) (E 0) (min-E 1e10))
               ;; Otherwise find the feature which maximizes information
               ;; gain (minimizes E) and make it the root of the decision
               ;; tree (i.e. make it the "split feature")
               (dolist (feature features)
                 (setf E (expected-info feature examples))
                 (trace-print
                   *trace-id3*
                   "~%Info gain for feature ~A = ~5,3F" feature (- I E))
                 (if (< E min-E)
                     (progn (setf min-E E)(setf split-feature feature))))
               (trace-print *trace-id3*
                            "~%~%Splitting on feature ~A" split-feature)
               ;; separate instances based on their value for this feature
               ;; and process each subset of examples recursively
               ;; eliminating the splitting feature from the set of features
               ;; available for use in discriminating between examples
               (make-decision-tree :feature split-feature
                    :subtrees
                     (mapcar #'(lambda (value)
                                 (trace-print
                                   *trace-id3*
                                   "~%~%Considering value ~A of feature ~A"
                                              value split-feature)
                                 (list value
                                       (build-decision-tree
                                        (remove-if-not
                                          #'(lambda (ex)
                                              (eq (nth (1- split-feature)
                                                       (second ex))
                                                  value))
                                          examples)
                                        (remove split-feature features)
                                        (if (> p n)
                                            '+
                                            '-))))
                             (nth (1- split-feature) *domains*))))))))

(defun expected-info (feature examples)
;;; Compute the expected amount of information needed for the subtrees created by
;;; splitting on the given feature. This is simply a weighted sum of the information
;;; needed for each subtree.

  (let ((E 0) (num-examples (length examples)))
    (dolist (value (nth (1- feature) *domains*))
      (let ((p-i 0) (n-i 0))
        (dolist (example examples)
          (if (equal (nth (1- feature) (second example)) value)
              (cond ((eq (first example) '+) (incf p-i))
                    ((eq (first example) '-) (incf n-i)))))
        (incf E (* (/ (+ p-i n-i) num-examples)
                   (info p-i n-i)))))
    E))


(defun info (p n)
;;; Compute the amount of information needed to distinguish the two classes
;;; given p + instances and n - instances

  (let ((s (+ p n)))
    (- (- (if (zerop p)
              0
              (* (/ p s) (log (/ p s) 2))))
       (if (zerop n)
           0
           (* (/ n s) (log (/ n s) 2))))))


(defun decide (instance decision-tree)
;;; Determines the class of instance by using it to traverse the given decision
;;; tree till a leaf is reached.
  
  (if (symbolp decision-tree)
      decision-tree
      (let* ((value (nth (1- (decision-tree-feature decision-tree)) instance))
             (subtree (second (assoc value (decision-tree-subtrees decision-tree)))))
        (if (symbolp subtree)
            subtree
            (decide instance subtree)))))

(defun print-decision-tree (tree stream depth &optional (indent 0))
  ;;; Print decision tree in a nice indented form
  (if (= indent 0) (setf tree (format-decision-tree tree)))
  (cond ((atom tree)
         (format stream "~%~vTClass is: ~A" indent tree))
        (t (format stream "~%~vTFeature: ~A" indent (first tree))
           (dolist (value-form (rest tree))
             (format stream "~%~vT  ~A" indent (first value-form))
             (print-decision-tree (second value-form) stream depth (+ indent 5))))))

(defun format-decision-tree (decision-tree)
  ;;; Format tree with feature names
  (if (symbolp decision-tree)
      decision-tree
      (cons (nth (1- (decision-tree-feature decision-tree)) *feature-names*)
            (mapcar #'(lambda (choice)
                        (list (first choice) (format-decision-tree (second choice))))
                    (decision-tree-subtrees decision-tree)))))

(defun make-domains (levels-list)
  ;;; If features values are simply integers 0 to n then the number of values of a
  ;;; feature is sufficient for determining its domain.  This function creates a
  ;;; list suitable for *domains* given a list of the number of values for each feature.
  ;;; See the file SOYBEAN-RDATA for a sample use.

  (mapcar #'(lambda (levels) (let ((domain nil)) 
                               (dotimes (i levels domain)
                                 (setf domain (nconc domain (list i))))))
          levels-list))


;;;; ==========================================================================================
;;;; Functions for running and testing a single concept
;;;; ==========================================================================================


(defun id3-test (examples &optional train#)
  ;;; Run and test id3 on the examples by using the first train# examples
  ;;; to train and the remaining to test
  (if (null train#) (setf train# (length examples)))
  (let ((training-examples (subseq examples 0 train#))
        (testing-examples  (subseq examples train#))
        (start-time (get-internal-run-time)))
    (let ((decision-tree (id3 training-examples)))
      (format t "~%~%Run time: ~,2Fs" (seconds-since start-time))
      (format t "~%Decision tree: ~%~A" decision-tree)
      (test-examples testing-examples decision-tree))))


(defun test-examples (examples decision-tree)
  ;;; Test tree on the given set of examples and report results
  (if examples
      (let ((correct# 0))
        (dolist (example examples)
          (if (eq (first example) (decide (second example) decision-tree))
              (incf correct#)))
        (format t "~%~%Percentage correct: ~A" (round (* 100 (/ correct# (length examples))))))))


;;;; ==========================================================================================
;;;; The following functions are for multiple concept (category) problems like the soybean data
;;;; ==========================================================================================

(defun id3-categories (category-list)
  ;;; ID3 for multiple concept learning problems. The argument category-list
  ;;; should be a list of atoms which represent names of individual categories. A list of
  ;;; instances for learning should be stored on the LEARN-INSTANCES property of each
  ;;; category name. A single concept learning trial is run for each category in which the
  ;;; instances of that category are positive examples and instances of all other categories
  ;;; are negative examples. The resulting decision tree for each category is stored on the
  ;;; DECISION-TREE property of the category name
  
  (let ((start-time (get-internal-run-time)))
    (dolist (category-name category-list)
      (format t "~%~%Category: ~A" category-name)
      (setf (get category-name 'DECISION-TREE) 
            (id3 (make-examples (get category-name 'learn-instances)
                                (mapcan #'(lambda (a) (copy-list (get a 'learn-instances)))
                                        (remove category-name category-list)))))
     (format t "~%Decision tree: ~%~A"(get category-name 'DECISION-TREE)))
    (format t "~%~%Run time: ~,2Fs" (seconds-since start-time)))
  (id3-test-categories category-list))

(defun make-examples (pos-instances neg-instances)
  ;;; Converts lists of positive and negative instances into a list of examples
  ;;; suitable for ID3.

  (append (mapcar #'(lambda (instance) (list '+ instance)) pos-instances)
          (mapcar #'(lambda (instance) (list '- instance)) neg-instances)))

(defun separate-instances (categories num-learn-instances)
  ;;; Separates a list of instances for a set of categories into learning and testing
  ;;; instances to facilitate experimentation in preparation for using VS-CATEGORIES
  ;;; and TEST-CATEGORIES.  The variable categories should be bound to a list of
  ;;; category names whose values are a list of instances of that category. The first
  ;;; num-learn-instances of these instances are stored on the LEARN-INSTANCES property
  ;;; to be used for learning and the rest are stored on TEST-INSTANCES for testing.
  
  (dolist (category categories)
    (setf (get category 'learn-instances) 
          (subseq (eval category) 0 num-learn-instances))
    (setf (get category 'test-instances)
          (subseq (eval category) num-learn-instances (length (eval category))))))

(defun id3-test-categories (categories &optional use-learn-instances)
  ;;; To be used after ID3-CATEGORIES in order to test the generalizations learned on a 
  ;;; set of new instances stored under the TEST-INSTANCES property of each category name
  ;;; in categories.  Reports % correct for each category and overall % correct.

  (let ((percent-sum 0)(percent 0))
    (dolist (category categories)
      (format t "~%~%Testing ~A instances" category)
      (let ((answers (mapcar #'(lambda (instance) (test-instance instance categories))
                             (get category (if use-learn-instances
                                               'learn-instances 'test-instances))))
            (count 0))
        (format t "~%~A" answers)
        (dolist (answer answers) (if (and (eq (first answer) category)(null (rest answer)))
                                     (incf count)))
        (setf percent (* 100 (/ count (length answers))))
        (incf percent-sum percent)
        (format t "~%Percentage correct: ~A" (round percent))))
    (format t "~%~%Total percent correct: ~A" (round (/ percent-sum (length categories))))))


(defun test-instance (instance categories)
  ;;; Given an instance and a list of category names returns the subset of these categories
  ;;; which it is determined that the instance belongs to. Uses the decision tree for each
  ;;; category to determine whether or not an instance belongs to the category or not.

   (let ((member-categories nil))
     (dolist (category categories member-categories)
      (if (eq (decide instance (get category 'DECISION-TREE)) '+)
          (push category member-categories)))))

;;;; ==========================================================================================
;;;; General utility functions
;;;; ==========================================================================================

(defun seconds-since (time)
   ;;; Return seconds elapsed since given time (initially set by get-internal-run-time)
  (/ (- (get-internal-run-time) time)
     internal-time-units-per-second))