;;; -*- Mode: LISP; Package: COMMON-LISP-USER; Base: 10; Syntax: Common-lisp -*-
;
;******************************************************************************
;
;  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 : >taylor>autoclass-x>nograph-ui>data-mods.lisp
;
;    Functions: GENERATE-REPORTS-FOR-BEST-CLASSIFICATION
;		XREF-BY-CLASS
;		XREF-BY-CASE
;		FIRST-PAGE-HEADER
;		PAGINATE
;		OUTPUT-PAGE-HEADERS
;		GET-CLASSES 
;
;   Revision History : For no graph UI => adapted from data-mods.lisp,
;		       GENERATE-REPORTS-FOR-BEST-CLASSIFICATION added
;;;
;;;**********************************
;;; 


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

(defun GENERATE-REPORTS-FOR-BEST-CLASSIFICATION (&key (base-file nil) results-file N-classes metrics-report-file 
						 xref-by-class-file xref-by-case-file)
  "generate reports of best classification for non graphical user interface"
  (if (not (null base-file))
      (read-*base-data* base-file))
  (setf *current-results* results-file)
  (get-best-of-weightings results-file)			; load best classification
  (setf *partition* (make-part&classes N-classes))
  (collect-weights *partition*)
  (update-partition-mmls *partition*)
  (get-autoclass-data)					; compute influence values
  (generate-metrics-report metrics-report-file)
  (xref-by-class xref-by-class-file)
  (xref-by-case xref-by-case-file))
;;;
;;;********************************** 
;;;  

(defmacro DATUM-AREF (datum-array &optional
			 (header-field '(case-number
					  ; var0 var1 var2 ...
					  )))
  "accessor macro for datum array - element of *base-data* array"
  (let* ((field-assoc-list '((case-number . 0)
			     ; (var0 . n0) (var1 . n1) (var2 . n2) ...
			     ))
	 (index (rest (assoc header-field field-assoc-list))))
    `(aref ,datum-array ,index)))

; (datum-aref (elt *base-data* 0) case-number)
;;;
;;;********************************** 
;;;  

(defun XREF-BY-CLASS (file &optional (data *base-data*) (weights *curr-wts*))
  " Sorts the elements of getclasses
   by AutoClass max-class and 0th element of datum array"
  (with-open-file (out-str file :direction :output)
;;  (let ((out-str t))		; debug
   (first-page-header out-str *n-data* *current-db* (part-total-mml *partition*) *current-results*)
    (format out-str "~%~18@T  SORTED BY AUTOCLASS CLASSIFICATION.")
    (let ((classes nil) (key-element-p t))
      (setf classes (get-classes data weights))
      (setf classes			; compute sort key & insert at front
	    (map 'list #'(lambda (elt)
			   (let ((key (+ (* 250000000
					     (first (second elt)))	; AutoClass class
					  (* (first (first elt)) 10000))))
			     (cons key elt)))
		 classes))
      (paginate out-str (stable-sort classes #'< :key #'first) key-element-p))))
;;;
;;;********************************** 
;;;  

(defun XREF-BY-CASE (file &optional (data *base-data*) (weights *curr-wts*))
  " Writes the elements of getclasses
   sorted by observation-num (*base-data* is already in this order)"
  (let ((key-element-p t))
    (with-open-file (out-str file :direction :output)
;;    (let ((out-str t))	; debug
      (first-page-header out-str *n-data* *current-db* (part-total-mml *partition*) *current-results*)
      (format out-str "~%~18@TSORTED BY CASE NUMBER.")
      (paginate out-str (get-classes data weights) (not key-element-p)))))
;;;
;;;********************************** 
;;;  

(defun FIRST-PAGE-HEADER (out-str n-data current-db part-total-mml current-results)
  "output header on first page"
  (format out-str
	    "~%~12@TAutoClass classifications for the ~A Cases~%~12@Tin ~A, ~%~12@Tusing the ~A MML classification ~%~12@Tin ~A."
	    n-data current-db part-total-mml current-results))
;;;
;;;********************************** 
;;;  

(defun PAGINATE (out-str list-of-lines key-element-p)
  "write output with headers at top of each page"
  (outputpage-headers out-str t)
  (let ((cnt 0) (line-cnt 62)
	(format-string
	  "~&~15@T~{~7D~} ~5@T~{~{(~@2A ~4,2F)~}~}"))
    (dolist (elt list-of-lines)
      (let ((arg1 (first elt)) (arg2 (rest elt)))
	(if key-element-p
	    (setf arg1 (second elt) arg2 (rest (rest elt))))
	(setf cnt (+ cnt (length arg2)))
	(format out-str format-string arg1 arg2))
      (when (>= cnt line-cnt)
	(setf cnt 0)
	(setf line-cnt 70)
	(format out-str "~|")
	(outputpage-headers out-str nil)))))
;;; 
;;;********************************** 
;;;  

(defun OUTPUTPAGE-HEADERS (out-str page-1-p)
  "write out page headers for sort listings"
  (let ((new-line "~%"))
    (if page-1-p
	(setf new-line "~2&"))
    (format out-str (concatenate
		      'string new-line
		      "~15@T  Case      AutoClass"))
    (format out-str "~%~15@T Number       Class")))
;;;
;;;********************************** 
;;;  

(defun GET-CLASSES (&optional (data *base-data*) (weights *curr-wts*))
  "collects data from *base-data* along with
   with the ordered set of (class wt)
   pairs for which wt > .1 as: ((h1 h2 ... h-N) (c1 w1) (c2 w2) ...)."
  (let* ((N-classes (length (elt weights 0)))
	 (temp (make-array N-classes))
	 (out-list ()))
    (do* ((index 0 (1+ index)))
	 ((= index *n-data*))
;;	 ((= index 150))	; debug
      (let ((collector ()) (wt ())
	    (datum (aref data index))
	    (wts (aref weights index)))
	(setq temp (sort (replace temp wts) '>))
	(dotimes (n N-classes)
	  (setq wt (elt temp n))
	  (if (> wt .1)
	      (push (list (position (position wt wts) *class-wt-ordering*)	; class
			  wt)
		    collector)
	      (return)  )  )
	(setf out-list (cons (cons (list (datum-aref datum case-number)
					 ; (datum-aref datum var0)
					 ; (datum-aref datum var1) ...
					 )
				   (nreverse collector)) out-list))))
    (nreverse out-list)))
;;;
;;;**********************************
;;;