;;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Base: 10 -*-
;
;******************************************************************************
;
;  AUTOCLASS II - Automatic Classification of Data
;
;  Authors : Peter Cheeseman - RIACS - Research Institute for Advanced
;					Computer Science
;	     Matthew Self    - Sterling Software
;
;	     John Stutz      - RIA - Artificial Intelligence Research Branch
;
;	     William Taylor  - Sterling Software
;
;  Address : MS 244-17, NASA Ames Research Center, Moffett Field, CA 94035
;
;  Phone : (415) 694-4946   -   FTS 464-4946
;
;  Arpanet : taylor%plu@io.arc.nasa.gov
;  
;  Environment : Common Lisp
;
;  Revision History : 11 Jan 88 - original released version - 
;
;******************************************************************************
;

;******************************************************************************
;
;  FILE : cha:>taylor>autoclass-x>nograph-ui>display-partition.lisp
;
;  Description : Compute global partition & compute influence values
;
;  Functions defined : GET-AUTOCLASS-DATA
;		       COMPUTE-GLOBAL-PARTITION
;		       COMPUTE-INFLUENCE-VALUES
;		       COMPUTE-DISCRETE-INFLUENCE-VALUE 
;		       COMPUTE-REAL-PT-INFLUENCE-VALUE 
;
;  Environment : Symbolics 3640 - Genera 7.0 - Common Lisp
;
;  Author : Will Taylor - Sterling Software
;
;  Revision History : 14 Dec 87 - original version - split from display-window.lisp
;		      05 Jan 88 - For no graph UI => delete SET-ITEMS-FOR-PANES;
;				  delete refernces to *plot-pane*, *lrs-type*,
;				  create-classes-attributes-menus & set-items-for-panes
;				  in GET-AUTOCLASS-DATA 
;
;******************************************************************************
;
;;;
;;;******************************************************* (nth 5 *class-wt-ordering*)
;;;

(defun GET-AUTOCLASS-DATA ()
  "process autoclass data for display"
  (setq *autoclass-run-descriptor-1* (format nil " DATA: ~A items of ~A" *n-data* *current-db*))
  (setq *autoclass-run-descriptor-2* (format nil " RESULTS: ~A with total MML ~A"
					     *current-results* (part-total-mml *partition*)))
  (setq *display-data-class-assignments* (get-max-weight-classes *curr-wts*))
  ;; order classes by weight
  (let* ((classes-array (part-classes *partition*))
	 (sort-array ()))
    (dotimes (N-class (length classes-array))
      (setf sort-array (cons (list (class-wt (aref classes-array N-class)) N-class)
			     sort-array)))
    (setf *class-wt-ordering* (mapcar #'second (sort sort-array #'> :key #'first))))
  (setf *global-partition* (compute-global-partition))
  (compute-influence-values))
;;;
;;;*******************************************************
;;;

(defun COMPUTE-GLOBAL-PARTITION ()
  "compute globalized partition of *display-partition* for attribute influence values"
  (let ((saved-*partition*-ptr *partition*)
	(global-partition (make-part&classes 1))
	(saved-*curr-wts* (get-class-wts 'vector)))
    ;; re-disribute *curr-wts* over 1 class
    (block-distribute-data *n-data* 1)	
    (collect-weights global-partition)
    (update-partition-mmls global-partition)
    ;; restore multi-class partition
    (reset-class-wts saved-*curr-wts*)
    (setf *partition* saved-*partition*-ptr)
    global-partition))
;;;
;;;*******************************************************  (compute-influence-values)
;;;   

(defun COMPUTE-INFLUENCE-VALUES ()
  "create & fill arrays of partition influence values"
  (let ((influence-array (make-array (part-class-range *partition*) :initial-element nil))
	(influence-sums (make-array *n-variables* :initial-element 0.0))
	(curr-influence-value 0.0)
	(influence-value-max 0.0)
	(global-mmls (class-unit-mmls (aref (part-classes *global-partition*) 0)))
	(global-value-wts (class-value-wts (aref (part-classes *global-partition*) 0))))
    (dotimes (N-class (length (part-classes *partition*)))
      (when (>= (class-wt (aref (part-classes *partition*) N-class)) 1.0)
	(let ((attribute-array (make-array  *n-variables* :initial-element nil))
	      (class-mmls (class-unit-mmls (aref (part-classes *partition*) N-class)))
	      (class-value-wts (class-value-wts (aref (part-classes *partition*) N-class))))
	  (dotimes (N-var *n-variables*)
	    (case (nth N-var *variable-types*)
	      (discrete
		(multiple-value-bind (influence-value class/global-att-probability-list)
		    (compute-discrete-influence-value N-var (aref class-mmls N-var) (aref global-mmls N-var))
		  (setf curr-influence-value influence-value)
		  (setf (aref attribute-array N-var)
			(make-i-discrete :value influence-value :p-p*-list class/global-att-probability-list))))
	      (real-pt
		(multiple-value-bind (influence-value class/global-att-mean-sigma-list)
		    (compute-real-pt-influence-value N-var class-value-wts global-value-wts
						     class-mmls global-mmls)
		  (setf curr-influence-value influence-value)
		  (setf (aref attribute-array N-var)
			(make-i-real-pt :value influence-value :mean-sigma-list class/global-att-mean-sigma-list))))
	      (ignore
		(setf curr-influence-value 0.0)))
	    (setf (aref influence-sums N-var) (+ (aref influence-sums N-var) curr-influence-value))
	    (if (> curr-influence-value influence-value-max)
		(setf influence-value-max curr-influence-value)))
	  (setf (aref influence-array N-class) attribute-array))))
    (setf *influence-values* influence-array)
    (setf *influence-value-max* influence-value-max)
    (setf *influence-sums* influence-sums)
    (setf *influence-sum-max* (max+! *influence-sums*))))

;;;
;;;*******************************************************  
;;; 

(defun COMPUTE-DISCRETE-INFLUENCE-VALUE (N-var local-att-mmls global-att-mmls)
  "compute influence value for discrete attribute"
  (let ((influence-value 0.0)
	(class/global-att-probability-list ()))
    (dotimes (N-value (nth N-var  *disc-var-ranges*))
      (let ((class-att-probability (exp (- (aref local-att-mmls N-value))))
	    (global-att-probability (exp (- (aref global-att-mmls N-value)))))
	(setf class/global-att-probability-list (cons (list N-value class-att-probability global-att-probability)
						      class/global-att-probability-list))
	(setf influence-value (+ influence-value
				 (* class-att-probability (log (/ class-att-probability global-att-probability)))))))
    (values influence-value (reverse class/global-att-probability-list))))
;;;
;;;******************************************************* (compute-influence-values)
;;; 

(defun COMPUTE-REAL-PT-INFLUENCE-VALUE (N-var class-value-wts global-value-wts class-mmls global-mmls)
  "compute influence value for real-pt attribute"
  (let* ((influence-value 0.0)
	 (local-mean (/ (acc-real-sum class-value-wts N-var) (acc-real-wt class-value-wts N-var)))
	 (local-sigma (sqrt (- (/ (acc-real-sum-sq class-value-wts N-var)
				  (acc-real-wt class-value-wts N-var))
			       (* local-mean local-mean))))
	 (global-mean (/ (acc-real-sum global-value-wts N-var) (acc-real-wt global-value-wts N-var)))
	 (global-sigma (sqrt (- (/ (acc-real-sum-sq global-value-wts N-var)
				   (acc-real-wt global-value-wts N-var))
				(* global-mean global-mean))))
	 (global-sigma-sqr (* global-sigma global-sigma))
	 (local-unknown (exp (- (acc-null-mml class-mmls N-var))))
	 (local-known (exp (- (acc-known-mml class-mmls N-var))))
	 (global-unknown (exp (- (acc-null-mml global-mmls N-var))))
	 (global-known (exp (- (acc-known-mml global-mmls N-var)))))
    (setf influence-value (+ (log (/ global-sigma local-sigma))
			     (/ (+ (- (* local-sigma local-sigma) global-sigma-sqr)
				   (* (- local-mean global-mean) (- local-mean global-mean)))
				(* 2.0 global-sigma-sqr))
			     (* local-unknown (log (/ local-unknown global-unknown))) 
			     (* local-known (log (/ local-known global-known)))))
    (values (abs influence-value) (list (list local-mean global-mean)
					(list local-sigma global-sigma)
					(list local-unknown global-unknown)
					(list local-known global-known)))))
;;;
;;;*******************************************************
;;;