home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: Multimed / Multimed.zip / fest-141.zip / festival / lib / cart_aux.scm next >
Text File  |  1999-05-30  |  6KB  |  151 lines
  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. (provide 'cart_aux)
  150.     
  151.