;;############################################################################
;; tableobj.lsp
;; Copyright (c) 1991-98 by Forrest W. Young
;; This file contains code to implement table data objects.
;;############################################################################

(require "vista")

;;###########################################################################
;;define prototype table data object and it's methods
;;prototype inherits from multivariate data-object prototype
;;###########################################################################

#|The following function appears at the end of dataobj3.lsp
(defproto table-data-object-proto 
  '(classes nways nclasses ncells cellfreqs source-names level-names 
            indicator-matrices obs-labels) 
  () mv-data-object-proto)|#

(defun table-data (data variables title labels types name ways classes)
  (let* ((num-cells-observed (length data))
         (num-cells-implied (apply #'* (mapcar #'length classes)))
         (ok (= num-cells-observed num-cells-implied))
         (object nil)
         )
    (when (not ok) 
          (send *workmap* :data-in-construction nil)
          (fatal-message 
           (format nil "These data cannot be used:~%Some cells are empty.")))
    (setf object (send table-data-object-proto :new
                       data variables title labels types name ways classes)) 
    (when (not (send object :data)) (setf object nil))
    object))

(defmeth table-data-object-proto :isnew 
  (data variables title labels types name ways classes)
  (let ((result (call-next-method data variables title labels types name)))
    (when result
          (send self :data data)
          (send self :ways ways)
          (send self :nobs (length (combine data)))
          (send self :classes classes)
          (send self :nways (length ways))
          (send self :ncells (length data))
          (send self :nclasses (mapcar #'length classes))
          (send self :cellfreqs (mapcar #'length data))
          (send self :labels ways classes)
          (send self :make-obs-labels)
          (send self :make-source-names)
          (send self :make-level-names)
          (send self :make-indicator-matrix-list))
    result))

(defmeth table-data-object-proto :nways
  (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the number of table cells." 
  (if set (setf (slot-value 'nways) number))
  (slot-value 'nways))

(defmeth table-data-object-proto :nclasses
  (&optional (number-list nil set))
"Message args: (&optional number-list)
 Sets or retrieves a list of the number of classes in each way of the table." 
  (if set (setf (slot-value 'nclasses) number-list))
  (slot-value 'nclasses))

(defmeth table-data-object-proto :ncells
  (&optional (number nil set))
"Message args: (&optional number)
 Sets or retrieves the number of table ways." 
  (if set (setf (slot-value 'ncells) number))
  (slot-value 'ncells))

(defmeth table-data-object-proto :cellfreqs
  (&optional (number-list nil set))
"Message args: (&optional number-list)
 Sets or retrieves a list of the number of observations in each cell of the table." 
  (if set (setf (slot-value 'cellfreqs) number-list))
  (slot-value 'cellfreqs))

(defmeth table-data-object-proto :classes (&optional (string-list nil set))
"Message args: (&optional string-list)
 Sets or retrieves the names of the classes of each way of the table data. This is a list for one-way data and a list of lists for multi-way data.  In the latter case there is a list for each way of the data.  The number of ways and the number of levels of each way are determined from this information."
  (if set (setf (slot-value 'classes) string-list))
  (slot-value 'classes))

(defmeth table-data-object-proto :source-names
  (&optional (name-list nil set))
"Message args: (&optional name-list)
 Sets or retrieves a list of the main and two-way source names of the table." 
  (if set (setf (slot-value 'source-names) name-list))
  (slot-value 'source-names))

(defmeth table-data-object-proto :level-names
  (&optional (name-list nil set))
"Message args: (&optional name-list)
 Sets or retrieves a list of lists the table's main and two-way level names." 
  (if set (setf (slot-value 'level-names) name-list))
  (slot-value 'level-names))

(defmeth table-data-object-proto :obs-labels
  (&optional (string-list nil set))
"Message args: (&optional string-list)
 Sets or retrieves a list of the observation labels." 
  (if set (setf (slot-value 'obs-labels) string-list))
  (slot-value 'obs-labels))

(defmeth table-data-object-proto :indicator-matrices
  (&optional (matrix-list nil set))
"Message args: (&optional matrix-list)
 Sets or retrieves a list of the main and two-way indicator matrices." 
  (if set (setf (slot-value 'indicator-matrices) matrix-list))
  (slot-value 'indicator-matrices))

(defmeth table-data-object-proto :make-source-names ()
"Method args: none
Creates and concatenates two-way table names to way names and stores as source names."
  (let* ((source-names (send self :ways))
         (nways (send self :nways))
         (knt nways))
    (when (> nways 1)
          (setf source-names 
                (combine source-names 
                         (repeat " " (/ (* nways (- nways 1)) 2))))
          (dotimes (i (- nways 1))
                   (dolist (j (iseq (+ i 1) (- nways 1)))
                           (setf (select source-names knt)
                                 (strcat (select source-names i) "*"
                                         (select source-names j)))
                           (setf knt (+ knt 1)))))
    (send self :source-names source-names)))

(defmeth table-data-object-proto :make-level-names ()
"Method args: none
Makes the table's main and two-way level names."
  (let ((names nil)
        (inter-names nil)
        (nclasseslist (send self :nclasses))
        (classes (send self :classes))
        (ways (send self :ways))
        (nways (send self :nways))
        (nclasses nil))
;make main effects level names
    (dotimes (i (send self :nways))
             (setf nclasses (nth i nclasseslist))
             (dotimes (j nclasses)
                      (when (numberp (select (select classes i) j))
                            (setf (select (select classes i) j)
                                  (format nil "~s" 
                                          (select (select classes i) j)))))
             (setf names (add-element-to-list names (mapcar #'strcat 
                   (repeat (nth i ways) nclasses)
                   (repeat "[" nclasses)
                   (nth i classes)
                   (repeat "]" nclasses)))))
;make two-way interaction level names
    (dotimes (m (- nways 1))
       (dolist  (n (iseq (+ m 1) (- nways 1)))
          (setf inter-names nil)
          (dotimes (i (select nclasseslist m))
             (dotimes (j (select nclasseslist n))
                (setf inter-names 
                      (add-element-to-list 
                       inter-names 
                       (strcat (select (select names m) i)
                               "*"
                               (select (select names n) j))))))
                (setf names (add-element-to-list names inter-names))))
    (send self :level-names names)))

(defmeth table-data-object-proto :make-obs-labels ()
  (send self :obs-labels 
        (repeat (send self :labels) (send self :cellfreqs))))

(defmeth table-data-object-proto :set-labels (labels)
  (setf (slot-value 'onames) labels))

(defmeth table-data-object-proto :labels (&optional way-names  class-names)
"Message args: (&optional way-names class-names)
Reports or creates labels for the cells of table data.  When both optional argument are used the method creates labels from the way-names and class-names.  Either both or neither optional argument must be used."
  (when (and way-names class-names)
        (let* ((nways (send self :nways))
               (ncells (send self :ncells))
               (class-num (repeat 0 nways))
               (nclasses (send self :nclasses))
               (cell-names (repeat "" ncells))
               (value nil)
               (string ""))
          (dotimes (i ncells)
              (dotimes (j nways)
                       (setf value 
                             (select (select class-names j) 
                                     (select class-num j)))
                       (when (numberp value)
                             (setf value (format nil "~s" value)))
                  (setf string 
                        (strcat string " " value )
;                       (strcat string (select way-names j) "[" value "] ")
                        ) )
              (dolist (j (iseq (- nways 1) 0))
                      (setf (select class-num j) (+ (select class-num j) 1))
                      (if (= (select class-num j)  (select nclasses j))
                          (setf (select class-num j) 0)
                          (return)))
              (setf (select cell-names i) string)
              (setf string ""))
          (setf (slot-value 'onames) cell-names)))
  (slot-value 'onames))

(defmeth table-data-object-proto :make-indicator-matrix-list ()
"Makes a list of indicator matrices for the main effects and (when appropriate) two-way interactions for a data table."
 (send self :make-main-effects-matrices)
 (when (> (send self :nways) 1) (send self :make-interaction-matrices)))
 
(defmeth table-data-object-proto :make-main-effects-matrices ()
"Computes a list of indicator matrices for the main effects of balanced or unbalanced tabular data having any number of ways. Each indicator matrix has one row for each observation and a column for each level. Their elements are 1's and 0's, with a 1 indicating which level the observation belongs in."
  (let* ((nways (send self :nways))
         (cellfreqs (send self :cellfreqs))
         (nobs  (sum cellfreqs))
         (freqs nobs)
         (nlevels (send self :nclasses))
         (nthislevel nil)
         (nproduct 1)
         (nrepeats 1)
         (thisobs 0)
         (thiscell 0)
         (thisfreq 0)
         (design nil))
    (dotimes (i nways)
             (setf nproduct (* nproduct (select nlevels i))))
    (dotimes (i nways)
;determine cell frequencies for way i of the design
             (setf nthislevel (select nlevels i))
             (setf nproduct (/ nproduct nthislevel))
             (setf freqs (repeat 0 (* nthislevel nrepeats)))
             (dotimes (ii (* nthislevel nrepeats))
                      (dotimes (jj nproduct)
                               (setf (select freqs ii) 
                                     (+ (select freqs ii)
                                        (select cellfreqs thiscell)))
                               (setf thiscell (+ thiscell 1))))
             (setf thiscell 0)
;create reduced-rank indicator matrix for way i of the design
             
             (setf design 
                   (make-array (list nobs nthislevel) :initial-element 0))
             (dotimes (k nrepeats)
                      (dotimes (j nthislevel)
                               (dotimes (l (select freqs thisfreq))
                                        (setf (aref design thisobs j) 1)
                                        (setf thisobs (+ thisobs 1)))
                               (setf thisfreq (+ thisfreq 1))))
             (setf nrepeats (* nrepeats nthislevel))
             (send self :indicator-matrices 
                   (make-matrix-list (send self :indicator-matrices) design))
             (setf thisobs 0)
             (setf thisfreq 0)
             )))

(defmeth table-data-object-proto :make-interaction-matrices ()
"Args: none
Computes and saves in a slot all two-way interaction indicator matrices."
  (let ((n (send self :nways))
        (interaction-matrices nil))
    (when (> n 1)
          (dolist (i (iseq (- n 1)))
             (dolist (j (iseq (+ i 1) (- n 1)))
                (setf interaction-matrices
                      (make-matrix-list 
                       interaction-matrices
                       (send self :twoway-interaction-matrix j i)))))
          (send self :indicator-matrices
                (append (send self :indicator-matrices)
                        interaction-matrices))
          )))

(defmeth table-data-object-proto :twoway-interaction-matrix (wayi wayj)
"Args: WAYI WAYJ
WAYI and WAYJ are integers specifying a way of the design.  
Returns the WAYI WAYJ two-way interaction indicator matrix."
  (let ((indicatori  (select (send self :indicator-matrices) wayi))
        (indicatorj  (select (send self :indicator-matrices) wayj))
        (classesi (select (send self :nclasses) wayi))
        (classesj (select (send self :nclasses) wayj))
        (interact nil)
        (nobs     (send self :nobs))
        (interaction nil))
    (dotimes (i classesj)
             (setf interaction (make-matrix-list interaction (transpose 
                   (matrix (list classesi nobs)
                           (map-elements #'* 
                                   (repeat (col indicatorj i) classesi) 
                                         (transpose indicatori)))))))
    (apply #'bind-columns interaction)))

(defmeth table-data-object-proto :grouped-data (source)
  (let* ((data (combine (send self :data)))
         (indicator (nth source (send self :indicator-matrices)))
         (nclasses (second (size indicator)))
         (members nil)
         (grouped-data nil))
    (dotimes (i nclasses)
             (setf members (select data (which (= 1 (col indicator i)))))
             (setf grouped-data (append grouped-data (list members))))
    grouped-data))

(defmeth table-data-object-proto :grouped-labels (source)
  (let* (
         (labels (send self :obs-labels))
         (indicator (nth source (send self :indicator-matrices)))
         (nclasses (second (size indicator)))
         (members nil)
         (grouped-labels nil))
    (dotimes (i nclasses)
             (setf members (select labels (which (= 1 (col indicator i)))))
             (setf grouped-labels (append grouped-labels (list members))))
    grouped-labels))

(defmeth table-data-object-proto :report (&optional ok-types)
"Method Args:  (&optional ok-types)
Presents a listing of the data that includes the data object name, 
variable names and types and observation labels.  Reports only the active
ok-types data when the optional argument is used. Ok-types must be one of 
the following strings: all, numeric, ordinal, category, label. 
On Macintoshes the listing is presented in a separate window whose object 
identification is returned.  On other machines the listing is in the listener
window, T is returned."
  (if (not (eq current-object self)) (setcd self))
  (let* ((data (send self :data))
         (cellnames (send self :labels))
         (cellfreqs (send self :cellfreqs))
         (ncells (send self :ncells))
         (nobs (send self :nobs))
         (ways (send self :ways))
         (nways (send self :nways))
         (classes (send self :classes))
         (nclasses (send self :nclasses))
         (balanced (= 1 (length (remove-duplicates cellfreqs))))
         (w nil))
    (setf w (report-header (strcat (send self :name) " Data Listing")))
    (display-string (format nil "Title: ~a~%" (send self :title)) w)
    (display-string (format nil "Data:  ~a~2%" (send self :name)) w)
    (display-string (format nil "Variable:           ~a~%" 
                            (first (send self :variables))) w)
    (display-string (format nil "Number of Ways:     ~d~%" nways) w)
    (display-string (format nil "Way Names:         ~a~%" ways) w)
    (display-string (format nil "Number of Classes: ~f~%" nclasses) w)
    (display-string (format nil "Class Names:       ~a~%" (first classes)) w)
    (when (> nways 1)
          (dotimes (i (- nways 1))
                   (display-string (format nil "                   ~a~%" 
                                     (select classes (+ i 1))) w)))
    (display-string (format nil "~%Number of Observations: ~d~%" nobs) w)
    (display-string (format nil   "Number of Cells:        ~d~%" ncells) w)
    (display-string (format nil   "Cell Frequencies:       ~f~%" cellfreqs) w)
    (display-string (format nil   "Data Type:              ") w)
    (if balanced (display-string (format nil "Balanced~%") w)
        (display-string (format nil "Unbalanced~%") w))
    (display-string
          (format nil "~%Labeled Data Cell Values~%") w)
    (dotimes (i ncells)
             (display-string (format nil "~a  ~10,2f~%"(select cellnames i)
                                     (select data i)) w))
    w))

(defmeth table-data-object-proto :summary 
  (&key moments quartiles ranges dialog)
"Method Args: (&key moments quartiles ranges dialog)
Prints summary statistics for each cell of the data table.  If dialog is t a dialog box is presented to determine which statistics are to be printed, otherwise the other keywords determine which are printed."
  (if (not (eq current-object self)) (setcd self))
  (let ((summary-options nil))
    (if dialog
        (setf summary-options 
              (choose-subset-dialog 
               "Choose Summary Statistics:"
               '("Moments (Mean, StDv, etc.)" 
                 "Quartiles (5 Number Summary)" 
                 "Range, Interquartile Range")
               :initial (select (send self :summary-option-states) 0)))
        (setf summary-options (list (delete 'nil (list
             (when moments '0) (when quartiles '1)
             (when ranges  '2))))))
    (when summary-options
          (when (not (select summary-options 0))
                (setf summary-options (send self :summary-option-states)))
          (when summary-options 
                (when (select summary-options 0)
                      (send self :summary-option-states summary-options)
                      (send self :describe-data 
                            (send self :data) (send self :labels)
                            summary-options))))))

(defmeth table-data-object-proto :save-data-template (f)
  (unwind-protect
   (print 
    `(data       ,(send self :name)
                 :title      ,(send self :title)
                 :variables ',(send self :variables)
                 :ways      ',(send self :ways)
                 :classes   ',(send self :classes)
                 :data      ',(send self :data))
    f)))