lib/cart_aux.scm

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;                                                                       ;;
   3 ;;;                Centre for Speech Technology Research                  ;;
   4 ;;;                     University of Edinburgh, UK                       ;;
   5 ;;;                       Copyright (c) 1996,1997                         ;;
   6 ;;;                        All Rights Reserved.                           ;;
   7 ;;;                                                                       ;;
   8 ;;;  Permission is hereby granted, free of charge, to use and distribute  ;;
   9 ;;;  this software and its documentation without restriction, including   ;;
  10 ;;;  without limitation the rights to use, copy, modify, merge, publish,  ;;
  11 ;;;  distribute, sublicense, and/or sell copies of this work, and to      ;;
  12 ;;;  permit persons to whom this work is furnished to do so, subject to   ;;
  13 ;;;  the following conditions:                                            ;;
  14 ;;;   1. The code must retain the above copyright notice, this list of    ;;
  15 ;;;      conditions and the following disclaimer.                         ;;
  16 ;;;   2. Any modifications must be clearly marked as such.                ;;
  17 ;;;   3. Original authors' names are not deleted.                         ;;
  18 ;;;   4. The authors' names are not used to endorse or promote products   ;;
  19 ;;;      derived from this software without specific prior written        ;;
  20 ;;;      permission.                                                      ;;
  21 ;;;                                                                       ;;
  22 ;;;  THE UNIVERSITY OF EDINBURGH AND THE CONTRIBUTORS TO THIS WORK        ;;
  23 ;;;  DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING      ;;
  24 ;;;  ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT   ;;
  25 ;;;  SHALL THE UNIVERSITY OF EDINBURGH NOR THE CONTRIBUTORS BE LIABLE     ;;
  26 ;;;  FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES    ;;
  27 ;;;  WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN   ;;
  28 ;;;  AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,          ;;
  29 ;;;  ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF       ;;
  30 ;;;  THIS SOFTWARE.                                                       ;;
  31 ;;;                                                                       ;;
  32 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  33 ;;;
  34 ;;;  Some functions for manipulating decision trees
  35 ;;;
  36 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37
  38 (define (cart_prune_tree_thresh tree threshold default)
  39 "(prune_cart_tree_thresh TREE THRESHOLD DEFAULT)
  40 Prune the classification tree TREE so that all tail nodes with
  41 a prediction probabality less than THRESHOLD and changed to return
  42 DEFAULT instead.  This may be used when different mistakes have actually
  43 different penalites hence some control of the defaults need to be
  44 controlled."
  45   (cond
  46    ((cdr tree) ;; a question
  47     (list
  48      (car tree)
  49      (cart_prune_tree_thresh (car (cdr tree)) threshold default)
  50      (cart_prune_tree_thresh (car (cdr (cdr tree))) threshold default)))
  51    ((< (cart_class_probability (car tree)) threshold)
  52     (list (list (list threshold default) default)))
  53    (t   ;; leave asis
  54     tree)))
  55
  56 (define (cart_class_probability class)
  57   "(cart_class_probability CLASS)
  58 Returns the probability of the best class in the cart leaf node CLASS.
  59 If CLASS simple has a value and now probabilities the probabilities
  60 it assume to be 1.0."
  61   (let ((val 0.0))
  62     (set! val (assoc (car (last class)) class))
  63     (if val
  64         (car (cdr val))
  65         1.0)))
  66
  67 (define (cart_class_prune_merge tree)
  68   "(cart_class_prune_merge tree)
  69 Prune all sub trees which are pure.  That is they all predict the
  70 same class.  This can happen when some other pruning technique
  71 as modified a sub-tree now making it pure."
  72   (let ((pure (cart_tree_pure tree)))
  73     (cond
  74      (pure pure)
  75      ((cdr tree);; a question
  76       (list
  77        (car tree)
  78        (cart_class_prune_merge (car (cdr tree)))
  79        (cart_class_prune_merge (car (cdr (cdr tree))))))
  80      (t;; a leaf leave asis
  81       tree))))
  82
  83 (define (cart_tree_pure tree)
  84   "(cart_tree_pure tree)
  85 Returns a probability density function if all nodes in this tree
  86 predict the same class and nil otherwise"
  87   (cond
  88    ((cdr tree)
  89     (let ((left (cart_tree_pure (car (cdr tree))))
  90           (right (cart_tree_pure (car (cdr (cdr tree))))))
  91       (cond
  92        ((not left) nil)
  93        ((not right) nil)
  94        ((equal? (car (last left)) (car (last right)))
  95         left)
  96        (t
  97         nil))))
  98    (t   ;; its a leaf, so of couse its pure
  99     tree)))
 100
 101 (define (cart_simplify_tree tree map)
 102   "(cart_simplify_tree TREE)
 103 Simplify a CART tree by reducing probability density functions to
 104 simple single clasifications (no probabilities).  This removes valuable
 105 information from the tree but makes them smaller easier to read by humans
 106 and faster to read by machines.  Also the classes may be mapped by the assoc
 107 list in map.  The bright ones amongst you will note this could be
 108 better and merge 'is' operators into 'in' operators in some situations
 109 especially if you are ignoring actual probability distributions."
 110   (cond
 111    ((cdr tree)
 112     (list
 113      (car tree)
 114      (cart_simplify_tree (car (cdr tree)) map)
 115      (cart_simplify_tree (car (cdr (cdr tree))) map)))
 116    (t
 117     (let ((class (car (last (car tree)))))
 118       (if (assoc class map)
 119           (list (cdr (assoc class map)))
 120           (list (last (car tree))))))))
 121
 122 (define (cart_simplify_tree2 tree)
 123   "(cart_simplify_tree2 TREE)
 124 Simplify a CART tree by reducing probability density functions to
 125 only non-zero probabilities."
 126   (cond
 127    ((cdr tree)
 128     (list
 129      (car tree)
 130      (cart_simplify_tree2 (car (cdr tree)))
 131      (cart_simplify_tree2 (car (cdr (cdr tree))))))
 132    (t
 133     (list
 134      (cart_remove_zero_probs (car tree))))))
 135
 136 (define (cart_remove_zero_probs pdf)
 137   "(cart_remove_zero_probs pdf)
 138 Removes zero probability classes in pdf, last in list
 139 is best in class (as from cart leaf node)."
 140   (cond
 141    ((null (cdr pdf)) pdf)
 142    ((equal? 0 (car (cdr (car pdf))))
 143     (cart_remove_zero_probs (cdr pdf)))
 144    (t
 145     (cons
 146      (car pdf)
 147      (cart_remove_zero_probs (cdr pdf))))))
 148
 149 (define (cart_interpret_debug i tree)
 150   "(cart_interpret_debug i tree)
 151 In comparing output between different implementations (flite vs festival)
 152 This prints out the details as it interprets the tree."
 153   (cond
 154    ((cdr tree) ;; question
 155     (format t "%s %s %s\n" (car (car tree)) (upcase (cadr (car tree)))
 156             (car (cddr (car tree))))
 157     (set! a (item.feat i (car (car tree))))
 158     (format t "%s\n" a)
 159     (cond
 160      ((string-equal "is" (cadr (car tree)))
 161       (if (string-equal a (car (cddr (car tree))))
 162           (begin
 163             (format t "   YES\n")
 164             (cart_interpret_debug i (car (cdr tree))))
 165           (begin
 166             (format t "   NO\n")
 167             (cart_interpret_debug i (car (cddr tree))))))
 168      ((string-equal "<" (cadr (car tree)))
 169       (if (< (parse-number a) (parse-number (car (cddr (car tree)))))
 170           (begin
 171             (format t "   YES\n")
 172             (cart_interpret_debug i (car (cdr tree))))
 173           (begin
 174             (format t "   NO\n")
 175             (cart_interpret_debug i (car (cddr tree))))))
 176      (t
 177       (format t "unknown q type %l\n" (car tree)))))
 178    (t ;; leaf
 179     (car tree)
 180     )))
 181
 182 (provide 'cart_aux)
 183