;;########################################################################
;; anovamob.lsp
;; Copyright (c) 1993-97 by Forrest W. Young
;; Nway ViSta Analysis of Variance object. Can fit main effects or two-way 
;; interaction models to n-way balanced or unbalanced univariate data.
;; Data must be complete (no empty cells)
;;########################################################################

(require "vista")
(load (strcat *vista-dir-name* "nway"))

;;########################################################################
;; uses nway lispstat model object
;;########################################################################

(defun analysis-of-variance 
  (&key
   (data        current-data)
   (title       "Analysis of Variance")
   (name        nil)
   (dialog      nil)
   (interaction nil))
"ViSta function to perform Analysis of Variance of balanced or unbalanced, complete data. 
With no arguments the current data are analyzed. Keyword arguments are
:INTERACTION followed by t (calculate interaction) or nil (do not calculate, the default);
:DATA followed by the name of the data to be analyzed (default: current-data);
:TITLE followed by a character string (default: Analysis of Variance);
:DIALOG followed by t (to display parameters dialog box) or nil (default)."
  (if (not (eq current-object data)) (setcd data))
  (if (not name) (strcat "ANV-" (send current-data :name)))
  (when (not (send *current-data* :ways))
        (when (not (and (send current-data :active-types '(category))
                        (send current-data :active-types '(numeric))))
              (send *toolbox* :reset-button 1)
              (fatal-message "ANOVA requires at least one Numeric and at least one Category variable.")))
  (let ((ok-types '(all)));fwy4.29
    (send anova-model-object-proto 
          :new interaction 1 data title name dialog ok-types)));fwy4.29

(defproto anova-model-object-proto 
  '(nway-model data-object interaction response ways classes 
               profile-labels line-labels line-xs line-ys
               f-obs f-crit leverages nclasses cellfreqs ncells
               class-matrix indicator-matrices nways 
               level-names source-names)
  () mv-model-object-proto)

(defmeth anova-model-object-proto :isnew (interaction &rest args)
  (send self :data-object current-data)
  (send self :model-abbrev "ANV")
  (send self :interaction interaction)
  (send self :ways (send current-data :ways))
  (when (send self :ways) 
        (send self :response (first (send self :variables)))
        (send self :classes  (send current-data :classes)))
  (apply #'call-next-method args))

(defmeth anova-model-object-proto :nway-model (&optional (object-id nil set))
"Message args: (&optional object-id)
Sets or retrieves the object identification information of the underlying nway-model that does the analysis and stores the results."
  (if set (setf (slot-value 'nway-model) object-id))
  (slot-value 'nway-model))

(defmeth anova-model-object-proto :data-object (&optional (object-id nil set))
"Message args: (&optional object-id)
Sets or retrieves the object identification of the analyzed data."
  (if set (setf (slot-value 'data-object) object-id))
  (slot-value 'data-object))

(defmeth anova-model-object-proto :interaction (&optional (logical nil set))
"Method args: (&optional logical)
Sets or returns t or nil indicating whether two-way interaction terms used."
  (if set (setf (slot-value 'interaction) logical))
  (slot-value 'interaction))

(defmeth anova-model-object-proto :response (&optional (string nil set))
"Method args: (&optional string)
Sets or returns response variable name."
  (if set (setf (slot-value 'response) string))
  (slot-value 'response))

(defmeth anova-model-object-proto :class-matrix (&optional (matrix nil set))
"Method args: (&optional matrix)
Sets or returns the matrix of classification data."
  (if set (setf (slot-value 'class-matrix) matrix))
  (slot-value 'class-matrix))

(defmeth anova-model-object-proto :indicator-matrices 
  (&optional (matrix nil set))
"Method args: (&optional matrix)
Sets or returns the matrix of indicator data."
  (if set (setf (slot-value 'indicator-matrices) matrix))
  (slot-value 'indicator-matrices))

(defmeth anova-model-object-proto :ways (&optional (string-list nil set))
"Method args: (&optional string-list)
Sets or returns way names."
  (if set (setf (slot-value 'ways) string-list))
  (slot-value 'ways))

(defmeth anova-model-object-proto :level-names 
  (&optional (string-list nil set))
"Method args: (&optional string-list)
Sets or returns level names."
  (if set (setf (slot-value 'level-names) string-list))
  (slot-value 'level-names))

(defmeth anova-model-object-proto :source-names 
  (&optional (string-list nil set))
"Method args: (&optional string-list)
Sets or returns source names."
  (if set (setf (slot-value 'source-names) string-list))
  (slot-value 'source-names))

(defmeth anova-model-object-proto :ncells (&optional (number nil set))
"Method args: (&optional number)
Sets or returns number of cells."
  (if set (setf (slot-value 'ncells) number))
  (slot-value 'ncells))

(defmeth anova-model-object-proto :nclasses (&optional (number nil set))
"Method args: (&optional number)
Sets or returns number of class variables."
  (if set (setf (slot-value 'nclasses) number))
  (slot-value 'nclasses))

(defmeth anova-model-object-proto :nways (&optional (number nil set))
"Method args: (&optional number)
Sets or returns number of ways."
  (if set (setf (slot-value 'nways) number))
  (slot-value 'nways))

(defmeth anova-model-object-proto :cellfreqs (&optional (number-list nil set))
"Method args: (&optional number-list)
Sets or returns cell frequencies."
  (if set (setf (slot-value 'cellfreqs) number-list))
  (slot-value 'cellfreqs))

(defmeth anova-model-object-proto :classes (&optional (string-list nil set))
"Method args: (&optional string-list)
Sets or returns class names."
  (if set (setf (slot-value 'classes) string-list))
  (slot-value 'classes))

(defmeth anova-model-object-proto :profile-labels
  (&optional (string-list nil set))
"Method args: (&optional string-list)
Sets or returns profile plot x-axis labels."
  (if set (setf (slot-value 'profile-labels) string-list))
  (slot-value 'profile-labels))

(defmeth anova-model-object-proto :line-labels 
  (&optional (string-list nil set))
"Method args: (&optional string-list)
Sets or returns profile plot line labels."
  (if set (setf (slot-value 'line-labels) string-list))
  (slot-value 'line-labels))

(defmeth anova-model-object-proto :line-xs (&optional (number-list nil set))
"Method args: (&optional number-list)
Sets or returns profile plot line label x locations."
  (if set (setf (slot-value 'line-xs) number-list))
  (slot-value 'line-xs))

(defmeth anova-model-object-proto :line-ys (&optional (number-list nil set))
"Method args: (&optional number-list)
Sets or returns profile plot line label y locations."
  (if set (setf (slot-value 'line-ys) number-list))
  (slot-value 'line-ys))

(defmeth anova-model-object-proto :leverages (&optional (matrix nil set))
"Method args: (&optional matrix)
Sets or returns Sall's predictor source variable leverage values."
  (if set (setf (slot-value 'leverages) matrix))
  (slot-value 'leverages))

(defmeth anova-model-object-proto :f-obs (&optional (list nil set))
  (if set (setf (slot-value 'f-obs) list))
  (slot-value 'f-obs))

(defmeth anova-model-object-proto :f-crit (&optional (list nil set))
  (if set (setf (slot-value 'f-crit) list))
  (slot-value 'f-crit))

(defmeth anova-model-object-proto :options ()
"Args: none
Constructs and displays the options dialog window for ANOVA. Returns nil if dialog canceled or when no response and/or classification variables selected from multivariate data. Otherwise: (1) when table data, returns 0 for no interaction, 1 for two-way interactions; (2) when mv data, returns a three element list consisting of the name of the response variable, a list of the names of the classifier variables, and a 0 for no interaction or 1 for two-way interactions."
  (cond 
    ((send self :ways)
     (send self :options-table)
     )
    (t
     (let* ((result (send self :options-mv))
            (response-variable-name (first result))
            (cat-variables (second result))
            (interaction (third result))
            (nobs (send self :nobs))
            (cat-matrix nil)
            (cell-labels nil)
            (data-matrix nil)
            (sorted-labels-and-grouped-data nil)
            )
       (when result
             (cond
              ((or (< (length response-variable-name) 1)
                   (< (length cat-variables) 1))
               (setf result nil)
               (error-message "You must select one response variable and at least one classification variable."))
               (t
                (if (= 0 interaction)
                    (send self :interaction nil)
                    (send self :interaction t))
                (send self :ways cat-variables)
                (setf cat-matrix
                      (bind-columns 
                       (send self :variable (select cat-variables 0))))
                (when (> (length cat-variables) 1)
                  (dotimes (i (1- (length cat-variables)))
                     (setf cat-matrix (bind-columns 
                           cat-matrix
                          (send self :variable 
                                (select cat-variables (1+ i)))))))
                (send self :classes
                      (mapcar #'(lambda (x)
                                  (coerce (remove-duplicates
                                           (send self :variable x) 
                                           :test #'equal) 'list)) 
                              cat-variables))
                (send self :nclasses
                      (mapcar #'length (send self :classes)))
                (setf cell-labels (make-cell-labels cat-matrix cat-variables))
                (setf data-matrix (bind-columns
                          (send self :variable response-variable-name)
                          cat-matrix))
                (setf sorted-labels-and-grouped-data 
                      (sort-labels-and-group-data cell-labels data-matrix))
                (send self :labels (first sorted-labels-and-grouped-data))
                (send self :data (second sorted-labels-and-grouped-data))
                (send self :classes (third sorted-labels-and-grouped-data))
                (send self :class-matrix 
                      (select (fourth sorted-labels-and-grouped-data)
                              (iseq nobs) (iseq 1 (length cat-variables))))
                (send self :cellfreqs (mapcar #'length (send self :data)))
                (send self :ncells (length (send self :cellfreqs)))
                (send self :response response-variable-name)
                (send self :nways (length (send self :ways))) 
                (send self :make-level-names)
                )))
       result))))

(defmeth anova-model-object-proto :options-table () 
  (let ((choice t))
    (when (send self :dialog)
          (when (or (> (send current-data :nways) 2)
                    (and (= (send current-data :nways) 2)
                         (> (send current-data :nobs) 
                            (send current-data :ncells))))
                (setf choice (choose-item-dialog 
                        "Analysis of Variance:
Include Two-Way Interaction Terms?"
                              '("Main Effects Only (No Interactions)"
                                "Main Effects and Two-Way Interactions")))
                (when choice
                      (if (= 0 choice)
                          (send self :interaction nil)
                          (send self :interaction t))))
          choice)))

(defmeth anova-model-object-proto :options-mv ()
"Args: none
Constructs and displays the options dialog window for ANOVA models of MV data.
Returns nil when dialog canceled. Returns three element list otherwise.  The first element of the list is the name of the response variable.  The second element is a list of the names of the classifier variables. The third element is 0 if no interactions are to be computed, 1 if interactions are to be computed. If dialog=nil, then the response variable is the first numeric variable in the dataset, the classifier variables are all of the nominal variables in the dataset, and interactions are computed."
          
  (let* ((no-dialog-response-variable 
          (first (send self :active-variables '(numeric))))
         (no-dialog-class-variables 
          (send self :active-variables '(category)))
         (box-text-item (send text-item-proto :new 
                              "Analysis of Variance:"))
         (method-toggle (send choice-item-proto :new (list 
                 "Main Effects Only (No Interactions)"
                 "Main Effects and Two-Way Interactions")))
         (rsp-text-item1 (send text-item-proto :new 
                 (format nil "Selectable~%Numeric Variables")))
         (rsp-text-item2 (send text-item-proto :new 
                 (format nil "Selected~%Response Variable")))
         (cls-text-item1 (send text-item-proto :new 
                 (format nil "Selectable~%Class Variables")))
         (cls-text-item2 (send text-item-proto :new 
                 (format nil "Selected~%Class Variables")))
         (var-list (send self :active-variables '(numeric)))
         (cls-list (send self :active-variables '(category)))
         (var-list-item (send list-item-proto :new var-list))
         (rsp-var (send list-item-proto :new (list " ") ))
         (cls-list-item (send list-item-proto :new cls-list))
         (method nil)
         (selected-class-variables nil)
         (selected-response-variable nil)
         (cls-var (send list-item-proto :new (repeat " " (length cls-list))))
         (ok        (send modal-button-proto :new "OK"
                      :action #'(lambda ()
                          (let ((dialog (send ok :dialog)))
                            (if (> (length cls-list) 1) 
                                (setf method (send method-toggle :value))
                                (setf method 0))
                            (setf selected-class-variables
                                  (concatenate 'list
                                   (send cls-var :slot-value 'list-data)))
                            (setf selected-response-variable
                                  (first (concatenate 'list
                                   (send rsp-var :slot-value 'list-data))))
                            (send dialog :modal-dialog-return t)))))   
         (cancel    (send modal-button-proto :new "Cancel"
                          :action #'(lambda ()
                            (let ((dialog (send cancel :dialog)))
                              (send dialog :modal-dialog-return nil)))))
         
         (reg-dialog 
          (when (send self :dialog)
                (if (> (length cls-list) 1) 
                    (send modal-dialog-proto :new
                          (list box-text-item
                                (list (list rsp-text-item1 var-list-item) 
                                      (list rsp-text-item2 rsp-var))
                                (list (list cls-text-item1 cls-list-item) 
                                      (list cls-text-item2 cls-var))
                                method-toggle
                                (list ok cancel))
                          :default-button ok)
                    (send modal-dialog-proto :new
                          (list box-text-item
                                (list (list rsp-text-item1 var-list-item) 
                                      (list rsp-text-item2 rsp-var))
                                (list (list cls-text-item1 cls-list-item) 
                                      (list cls-text-item2 cls-var))
                                (list ok cancel))
                          :default-button ok))))
          
         )
    
    (when reg-dialog
          ;following required for reg-dialog to work
          (send rsp-var :slot-value 'list-data #())
          (send cls-var :slot-value 'list-data #())
          (defmeth reg-dialog :switch-element 
            (me you your-max-L)
            (let* ((n (send me :selection))
                   (my-list   (send me  :slot-value 'list-data))
                   (your-list (send you :slot-value 'list-data))
                   (L-me  (length my-list))
                   (L-you (length your-list))
                   (s nil))
              (when n
                    (send me :selection nil)
                    (when (and (< n L-me) (< L-you your-max-L))
                          (setf s (select my-list n))
                          (when (< n (1- L-me))
                                (dolist (i (iseq n (- L-me 2)))
                                        (send me :set-text i 
                                              (select my-list (1+ i)))))
                          (send me :set-text (1- L-me) " ")
                          (send me :slot-value 'list-data
                                (select (send me :slot-value 'list-data) 
                                        (iseq (1- L-me))))
                          (send you :slot-value 'list-data
                                (concatenate 'vector your-list (vector s)))
                          (send you :set-text L-you s)))))

          (defmeth var-list-item :do-action (&optional dbl-clk)
            (send  reg-dialog :switch-element 
                   var-list-item rsp-var 1))
          (defmeth rsp-var :do-action (&optional dbl-clk)
            (send  reg-dialog :switch-element 
                   rsp-var var-list-item (length var-list)))
          (defmeth cls-list-item :do-action (&optional dbl-clk)
            (send  reg-dialog :switch-element 
                   cls-list-item cls-var (length cls-list)))
          (defmeth cls-var :do-action (&optional dbl-clk)
            (send  reg-dialog :switch-element 
                   cls-var cls-list-item (length cls-list))))
    (cond 
      (reg-dialog
       (if (send reg-dialog :modal-dialog);t if OK, nil if Cancel
           (list selected-response-variable 
                 selected-class-variables
                 method)))
      (t
       (list no-dialog-response-variable
             no-dialog-class-variables
             1)))
    ))

(defmeth anova-model-object-proto :analysis ()
  (when (/= (length (send self :data))
            (apply #'* (mapcar #'length (send self :classes))))
        (fatal-message "This analysis cannot be performed because one or more of the data cells contains no data."))
  (let* ((interaction (send self :interaction))
         (dob (send self :data-object))
         (object nil)
         (testval nil))
    (when (send dob :ways) 
          (send self :nways (send dob :nways))
          (send self :cellfreqs (send dob :cellfreqs)))
    (setf testval (remove-duplicates (send self :cellfreqs)))
    (when (and (= (length testval) 1) 
               (= (first testval) 1) 
               (< (send self :nways) 3)) 
          (fatal-message "Analysis not possible for one-way or two-way data when there is only one observation for every cell."))
    (when (and (= 1 (length (send self :ways))) interaction) 
          (error-message "Interactions not possible with one classification variable. Analysis continues without interactions.") 
          (send self :interaction nil) 
          (setf interaction nil))
    (setf object (nway-model (send self :data) 
                             :class-names (send self :classes)
                             :way-names (send self :ways)
                             :print nil
                             :interaction interaction))
    (send self :nway-model object)
    (send self :indicator-matrices (send object :indicator-matrices))
    (when (send dob :ways)
          (send self :response (first (send dob :variables)))
          (send self :class-matrix)
          (send self :nobs (send dob :nobs))
          (send self :nclasses (send dob :nclasses))
          (send self :classes (send dob :classes))
          (send self :level-names (send dob :level-names))
          (send self :ncells (send dob :ncells)))
    (when interaction
          (send self :indicator-matrices 
                (send self :make-interaction-indicator-matrices)))
    (send self :make-source-names)
    (send self :leverages (send self :make-leverages))
    object))

(defmeth anova-model-object-proto :report (&key (dialog nil))
  (if (not (eq current-object self)) (setcm self))
  (let* ((object (send self :nway-model))
         (w nil)
         (details nil)
         (dob (send self :data-object))
         (nclasses (send self :nclasses))
         (cellfreqs (send self :cellfreqs))
         (ncells (send self :ncells))
         (nobs (send self :nobs))
         (balanced (= 1 (length (remove-duplicates cellfreqs))))
         )
    (when dialog 
          (setf details (yes-or-no-dialog "ANOVA Report Option" 
                                          "Show report details?" nil)))
    (setf w (report-header (send self :title)))
    (display-string (format nil "Analysis of Variance~2%") w)
    (display-string (format nil "Model:               ~a~%" 
                            (send self :name )) w)
    (display-string (format nil "Response  Variable:  ~a~%" 
                            (send self :response))   w)
    (display-string (format nil "Way Names:           ~a~%"
                            (send self :ways)) w)
    (display-string (format nil "Number of Classes:   ~f~%" nclasses) w)
    (display-string (format nil "Class Names:         ~a~%"
                            (send self :classes)) 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))
    (send object :display w details)))
    

(defmeth anova-model-object-proto :save-model-template (data-object)
"Args: (data-object)
DATA-OBJECT is the object-identification information of a data object. 
The method contains a template for saving the model-object." 
  `(analysis-of-variance    
    :title      ,(send self :title)
    :name       ,(send self :name) 
    :dialog      nil
    :interaction ,(send current-model :interaction)
    :data (data  ,(send data-object :name)
                 :title      ,(send data-object :title)
                 :variables ',(send self :variables)
                 :types     ',(send self :types)
                 :labels    ',(send self :labels)
                 :ways      ',(send self :ways)
                 :classes   ',(send self :classes)
                 :data      ',(send self :data)))
  )

(defmeth anova-model-object-proto :create-data (&key (dialog nil))
  (if (not (eq current-object self)) (setcm self)) 
  (let* ((creator (send *desktop* :selected-icon))
         (data-obj (send self :data-object))
         (nway (send self :nway-model))
         (nways (send self :nways))
         (data-ways (send data-obj :ways))
         (model-ways (send self :ways))
         (response-var (first (send self :variables)))
         (y (send nway :y))
         (x (if data-ways (send nway :x) (send self :class-matrix)))
         (nx (second (size x)))
         (x-var-names (if data-ways (send nway :predictor-names) model-ways))
         (fit-values (send nway :fit-values))
         (raw-residuals (send nway :raw-residuals))
         (residuals (send nway :residuals))
         (studentized-residuals (send nway :studentized-residuals))
         (externally-studentized-residuals 
                               (send nway :externally-studentized-residuals))
         (cooks-distances (send nway :cooks-distances))
         (data (bind-columns y x fit-values residuals raw-residuals 
                    studentized-residuals externally-studentized-residuals 
                    cooks-distances))
         (types (repeat "Numeric" (second (size data))))
         )
    (if (not data-ways)
        (setf (select types (iseq 1 nways)) (repeat "Category" nways)))
    (data (concatenate 'string "Results-" (send self :name))
          :created creator
          :creator-object self
          :title (concatenate 'string "ANOVA Results From " 
                              (send self :title))
          :data (combine data)
          :types types
          :variables (combine response-var x-var-names "FitValues" 
                              "Residuals" "RawResids"  
                              "StudResids" "ExtStudResids" 
                              "CooksDists")
          :labels 
          (if (not data-ways)
              (send self :labels)
              (repeat (send data-obj :labels) (send data-obj :cellfreqs)))
          )))

(defmeth anova-model-object-proto :lev (sel)
  (let* ((nway (send self :nway-model))
         (ncols (select (array-dimensions (send nway :x)) 1))
         (ident-mat (identity-matrix ncols))
         (nrows nil)
         (mats (mapcar #'array-dimensions (send nway :design-matrices)))
         (x nil)
         (g nil)
         (i 0)
         (j 0)
         (levmat nil)
         (mat nil)
         )
    (dotimes (i (length mats))
             (setf x (remove nil (combine x 
                     (list (select (select mats i) 1))))))
    (when (not (= sel 0))
          (setf nrows (select x (1- sel)))
          (setf g (if (not (= sel 1))
                      (apply #'+ (select x (iseq (1- sel))))))
          (if (= sel 1) (setf g 0))
          (setf levmat (select ident-mat (iseq g (+ g (1- nrows))) (iseq ncols)))
          (setf mat (send self :sall-lev levmat)))
    (when (= sel 0)
          (setf mat (list (send nway :fit-values) (send nway :y))))
    mat))

(defmeth anova-model-object-proto :sall-lev (L)
"Args: L
L is an indicator matrix for a source in the anova design. L has a column for every term in the design. L has one row for each level of a source, a row has a single 1 indicating the factors position in the design."
  (let* ((nway    (send self :nway-model))
         (x       (send nway :x))
         (xpxiLp  (matmult (inverse (matmult (transpose x) x))(transpose L)))
         (xxpxiLp (matmult x xpxiLp))
         (b       (bind-columns (rest (send nway :coef-estimates))))
         (lambda  (matmult (inverse (matmult L xpxiLp)) L b))
         (vx      (+ (mean (send nway :y)) 
                     (combine (matmult xxpxiLp lambda))))
         (vy      (+ (send nway :residuals) vx))
         )
    (list vx vy)))

(defmeth anova-model-object-proto :make-leverages ()
"Args: none
Returns an nobs x nsources matrix of Sall's Leverage values for the predictor source variables."
  (let* ((levs nil)
         (nway-model (send self :nway-model))
         (n-sources 
          (- (length (send nway-model :source-degrees-of-freedom)) 2))
         (n-obs (send nway-model :nobs))
         )
    (dotimes (i n-sources)
             (setf levs (combine levs (first (send self :lev (1+ i))))))
    (transpose (matrix (list n-sources n-obs) (rest levs)))))

(defmeth anova-model-object-proto :grouped-values (values model sel)
  (let* ((indicator 
          (nth sel (send self :indicator-matrices)))
         (nclasses (second (size indicator)))
         (members nil)
         (grouped-values nil))
    (dotimes (i nclasses)
             (setf members (select values (which (= 1 (col indicator i)))))
             (setf grouped-values (append grouped-values (list members))))
    grouped-values))

(load (strcat *vista-dir-name* "anovavis"))