;;########################################################################
;; mmrmob.lsp
;; multivariate multiple regression ViSta model object
;; Copyright (c) 1991-96 by Forrest W. Young
;;########################################################################

(require "vista")

;;---------------------------------------------------------------------------
;;constructor function for multivariate multiple regression model object
;;----------------------------------------------------------------------------

(defun multivariate-regression 
  (&key 
   (data current-data)  
   (title "Multivariate Regression")
   (name nil)
   (dialog nil)
   (responses nil)
   (predictors nil)
   (weight nil)
   (intercept t)
   (redundancy nil) )
"ViSta function to perform Multivariate Regression analysis.  
With no arguments the current data are analyzed, with the first active numeric variable as the response, and the remaining active numeric variables as the predictors. Keyword arguments are
:RESPONSES followed by a list of the response variables 
      (if there is more than one response variable then several separate
       multiple regressions are performed, each with the same predictors);
:PREDICTORS followed by a list of the predictor variables;
:WEIGHT followed by a variable name (nil by default);
:INTERCEPT followed by t if an intercept is to be computed (default) or nil;
:REDUNDANCY followed by a value specifying the number of redundancy variables  to be computed or nil if they are not to be computed (default);
:DATA followed by the name of the data to be analyzed (default: current-data);
:TITLE followed by a character string (default: Multivariate Regression);
:DIALOG followed by t (to display parameters dialog box) or nil (default)."
  (if (not (eq current-object data)) (setcd data))
  (if (not name) (setf name (strcat "MRG-" (send current-data :name))))
  (when (= 1 (send current-data :active-nvar '(numeric)))
        (error (format nil "Cannot do Regression with data that has only one active numeric variable."))) 
  (send mmr-model-object-proto 
        :new responses predictors weight intercept redundancy 
        4 data title name dialog))

;;---------------------------------------------------------------------------
;;define multivariate multiple regression model object
;;----------------------------------------------------------------------------

(defproto mmr-model-object-proto 
  '(reg-models num-iv num-dv iv dv y-stdv x-stdv intercept predictors 
    responses weights scores coefs beta redundancy redun-index redun-evals 
    redun-evecs redun-scores redun-coefs redun-bmat cor cov) () 
  mv-model-object-proto)

(defmeth mmr-model-object-proto :isnew 
  (responses predictors weight intercept redundancy 
             number data title name dialog)
  (when (not dialog) 
        (when (not responses)
              (setf responses (list (first 
                      (send current-data :active-variables '(numeric))))))
        (when (not predictors)
              (setf predictors 
                    (rest (send current-data :active-variables '(numeric)))))
        (send self :responses responses)
        (send self :predictors predictors)
        (send self :intercept intercept)
        (send self :weights weight)
        (when (not redundancy) (setf redundancy 0))
        (send self :redundancy redundancy))
  (send self :model-abbrev "MRG")
  (call-next-method number data title name dialog)
  (send self :check-vars (send self :responses) (send self :predictors)))

(defmeth mmr-model-object-proto :reg-models (&optional (names nil set))
    (if set (setf (slot-value 'reg-models) names))
    (slot-value 'reg-models))

(defmeth mmr-model-object-proto :num-iv (&optional (names nil set))
    (if set (setf (slot-value 'num-iv) names))
    (slot-value 'num-iv))

(defmeth mmr-model-object-proto :num-dv (&optional (names nil set))
    (if set (setf (slot-value 'num-dv) names))
    (slot-value 'num-dv))

(defmeth mmr-model-object-proto :iv (&optional (numbers nil set))
    (if set (setf (slot-value 'iv) numbers))
    (slot-value 'iv))

(defmeth mmr-model-object-proto :dv (&optional (numbers nil set))
    (if set (setf (slot-value 'dv) numbers))
    (slot-value 'dv))

(defmeth mmr-model-object-proto :x-stdv (&optional (numbers nil set))
    (if set (setf (slot-value 'x-stdv) numbers))
    (slot-value 'x-stdv))

(defmeth mmr-model-object-proto :y-stdv (&optional (numbers nil set))
    (if set (setf (slot-value 'y-stdv) numbers))
    (slot-value 'y-stdv))

(defmeth mmr-model-object-proto :predictors (&optional (names nil set))
    (if set (setf (slot-value 'predictors) names))
    (slot-value 'predictors))

(defmeth mmr-model-object-proto :responses (&optional (names nil set))
    (if set (setf (slot-value 'responses) names))
    (slot-value 'responses))

(defmeth mmr-model-object-proto :intercept (&optional (val nil set))
    (if set (setf (slot-value 'intercept) val))
    (slot-value 'intercept))

(defmeth mmr-model-object-proto :beta (&optional (numbers nil set))
    (if set (setf (slot-value 'beta) numbers))
    (slot-value 'beta))

(defmeth mmr-model-object-proto :redundancy (&optional (val nil set))
    (if set (setf (slot-value 'redundancy) val))
    (slot-value 'redundancy))

(defmeth mmr-model-object-proto :weights (&optional (val nil set))
    (if set (setf (slot-value 'weights) val))
    (slot-value 'weights))

(defmeth mmr-model-object-proto :scores (&optional (names nil set))
  (if set (setf (slot-value 'scores) names))
  (slot-value 'scores))

(defmeth mmr-model-object-proto :coefs (&optional (names nil set))
    (if set (setf (slot-value 'coefs) names))
    (slot-value 'coefs))

(defmeth mmr-model-object-proto :redun-index (&optional (value nil set))
    (if set (setf (slot-value 'redun-index) value))
    (slot-value 'redun-index))

(defmeth mmr-model-object-proto :redun-evals (&optional (vector nil set))
    (if set (setf (slot-value 'redun-evals) vector))
    (slot-value 'redun-evals))

(defmeth mmr-model-object-proto :redun-evecs (&optional (matrix nil set))
    (if set (setf (slot-value 'redun-evecs) matrix))
    (slot-value 'redun-evecs))

(defmeth mmr-model-object-proto :redun-scores (&optional (matrix nil set))
  (if set (setf (slot-value 'redun-scores) matrix))
  (slot-value 'redun-scores))

(defmeth mmr-model-object-proto :redun-coefs (&optional (matrix nil set))
    (if set (setf (slot-value 'redun-coefs) matrix))
    (slot-value 'redun-coefs))

(defmeth mmr-model-object-proto :redun-bmat (&optional (matrix nil set))
    (if set (setf (slot-value 'redun-bmat) matrix))
    (slot-value 'redun-bmat))

(defmeth mmr-model-object-proto :cor (&optional (matrix nil set))
    (if set (setf (slot-value 'cor) matrix))
    (slot-value 'cor))

(defmeth mmr-model-object-proto :cov (&optional (matrix nil set))
    (if set (setf (slot-value 'cov) matrix))
    (slot-value 'cov))

(defmeth mmr-model-object-proto :check-vars (responses predictors)
  (let ((vars (send current-data :variables))
        )
    (dotimes (i (length responses))
             (when (not (member (select responses i) vars :test #'equal))
                   (error "Bad Response Variable List.")))
    (dotimes (i (length predictors))
             (when (not (member (select predictors i) vars :test #'equal))
                   (error "Bad Predictor Variable List.")))))

(defmeth mmr-model-object-proto :create-data 
  (&key (dialog nil)
        (scores t)
        (coefs  t)
        (input  nil))
  (if (not (eq current-object self)) (setcm self)) 
  (let ((creator (send *desktop* :selected-icon))
        (desires (list (list (if input 0) (if scores 1) (if coefs 2) )))
        )
    (if dialog
        (setf desires
              (if (send self :redundancy) 
                  (choose-subset-dialog "Choose Desired Data Objects"
                               '("Analyzed Input Data"
                                 "Predicted Values (Scores)" 
                                 "Regression Coefficients"
                                 "Redundancy Coefficients"
                                 "Redundancy Variates"       
                                           )
                                       :initial (select desires 0))
                  (choose-subset-dialog "Choose Desired Data Objects"
                               '("Analyzed Input Data"
                                 "Predicted Values (Scores)" 
                                 "Regression Coefficients"      
                                           )
                                       :initial (select desires 0)))))
    (when desires
          (when (member '0 (select desires 0))
                (send self :create-input-data-object "MRG" creator))
          (when (member '1 (select desires 0))
                (send self :mmr-scores-data-object creator))
          (when (member '2 (select desires 0))
                (send self :mmr-coefs-data-object creator))
          (when (member '3 (select desires 0))
                (send self :red-reg-coefs-data-object creator))
          (when (member '4 (select desires 0))
                (send self :red-var-coefs-data-object creator))
          )
    t))
 

(defmeth mmr-model-object-proto :mmr-scores-data-object (creator)
  (let ((n (send self :num-dv)))
  (data (concatenate 'string "RegScores-" (send self :name))
   :created creator
   :creator-object self
   :title (concatenate 'string "MulReg Scores for " 
                       (send self :title))
   :data (combine (send self :scores))
   :variables (mapcar #'concatenate (repeat 'string n) (select (send self :variables) (send self :dv)) (repeat "-hat" n))
   :labels (send self :labels)
   :types (select (send self :types) (send self :dv)))
  ))

(defmeth mmr-model-object-proto :mmr-coefs-data-object (creator)
  (data (concatenate 'string "RegCoefs-" (send self :name))
   :created creator
   :creator-object self
   :title (concatenate 'string "Regression Coefficients for " 
                       (send self :title))
   :data (combine (transpose (send self :coefs)))
   :labels (select (send self :variables) (send self :iv))
   :variables (select (send self :variables) (send self :dv))
  ))

(defmeth mmr-model-object-proto :red-reg-coefs-data-object (creator)
  (data (concatenate 'string "RedRegCoefs-" (send self :name))
   :created creator
   :creator-object self
   :title (concatenate 'string "Redundancy Coefficients for " 
                       (send self :title))
   :data (combine (send self :redun-bmat))
   :labels (select (send self :variables) (send self :iv))
   :variables (select (send self :variables) (send self :dv))
  ))

(defmeth mmr-model-object-proto :red-var-coefs-data-object (creator)
  (let* ((nredun (send self :redundancy))
         (redvars (mapcar #'(lambda (x) (format nil "Red~d" x))
                            (iseq nredun))))
    (data (concatenate 'string "RedVarCoefs-" (send self :name))
          :created creator
          :creator-object self
          :title (concatenate 'string "Redundancy Variable Coefficients for " 
                              (send self :title))
          :data (combine (select (send self :redun-coefs)
                                 (iseq (send self :num-iv)) (iseq nredun))) 
          :variables redvars
          :labels (select (send self :variables) (send self :iv))
          )))

(defmeth mmr-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."
  `(multivariate-regression    
    :title       ,(send self :title)
    :name        ,(send self :name) 
    :dialog       nil
    :responses  ',(send self :responses)
    :predictors ',(send self :predictors)
    :intercept    t
    :data (data  ,(send data-object :name)
                 :title      ,(send data-object :title)
                 :variables ',(send self :variables)
                 :types     ',(send self :types)
                 :labels    ',(send self :labels)
                 :data      ',(send self :data))))

(defmeth mmr-model-object-proto :report (&key (dialog nil)) 
  (if (not (eq current-object self)) (setcm self))
  (let* ((labels (send self :labels))
         (dvars  (select (send self :variables) 
                         (send self :dv)))
         (ivars  (select (send self :variables) 
                         (send self :iv)))
         
         (scores (send self :scores))
         (coefs  (send self :coefs ))
         (lc-names (mapcar #'(lambda (x) (format nil "MulReg~a" x)) ;?????
                      (iseq (send self :nvar))))
         (mtest  (if (and (> (send self :num-dv) 1)
                          (> (send self :nobs) 
                             (sum (send self :num-dv) (send self :num-iv)))) 
                     (send self :multivariate-test)
                     nil))
         (redun  (send self :redundancy))
         (y-stdv (send self :y-stdv))
         (x-stdv (send self :x-stdv))
         (beta   (send self :beta))
         (w nil)
         (desires (list nil))
         )
    (when dialog 
          (setf desires
                (choose-subset-dialog "Choose Optional Reports:"
                               '("Univariate Analyses"
                                 "Correlation Matrix" 
                                 "Covariance Matrix")
                                      :initial '(0))))
    (when (not (equalp desires nil))
    (setf w (report-header (send self :title)))
    (display-string (format nil "Multivariate Multiple Regression Analysis~%") w)
    (display-string (format nil "~%Model: ~a~%" 
                            (send self :name )) w)
    (display-string (format nil "Response  Variables:   ~a~%" dvars)   w)
    (display-string (format nil "Predictor Variables:   ~a~%" ivars)   w)
    (display-string (format nil "Number of Observatios: ~d~%"
                            (send self :nobs)) w)
    (display-string (format nil "Redundancy analysis~a requested.~2%"
                            (if redun "" " not")) w)
    (when (member '0 (select desires 0))
    (dotimes (i (length dvars))
             (let ((w (report-header "Univariate Regression Report")))
               (display-string (format nil "Univariate Regression Report~%") w)
               (display-string 
                (format nil "~%Model: ~a~%" 
                        (send self :name )) w)
               (display-string 
                (format nil "Response  Variable:    ~a~%" 
                        (select dvars i))   w)
               (display-string 
                (format nil "Predictor Variables:  ~a~%" ivars)   w)
               (display-string 
                (format nil "Number of Observatios: ~d~%"
                        (send self :nobs)) w)
               (send (select (send self :reg-models) i) :display w)
               )))
          (when w (send w :show-window))
    (when (= (send self :num-dv) 1)
          (display-string (format nil "You have used the Multivariate Multiple Regression procedure for Univariate Multiple Regression.  More complete univariate results are provided by Regres, the Univariate Multiple Regression procedure.") w))
    (when (> (send self :num-dv) 1)
          (display-string (format nil "------------------------------~%") w)
          (display-string (format nil "~%MULTIVARIATE REGRESSION ANALYSIS") w)
          (when (member '1 (select desires 0))     
                (display-string (format nil "~2%Correlation Matrix~%") w)
                (print-matrix-to-window (send self :cor) w 
                                        :labels (combine dvars ivars)))
          (when (member '2 (select desires 0))           
                (display-string (format nil "~%Covariance Matrix~%") w)
                (print-matrix-to-window (send self :cov) w
                                        :labels (combine dvars ivars)))
    (when mtest
     (when (select mtest 6)
      (display-string
        (format nil "~%Multivariate Test: ~%Ho: No relationship between responses and predictors") w)
      (display-string
        (format nil "~%Wilks' Lambda = ~1,7f  F(~3,2f, ~3,2f) = ~3,2f  p = ~1,4f" (first mtest) (third mtest) (fourth mtest) (second mtest) (fifth mtest)) w)
      (if (select mtest 5)
        (display-string (format nil "~%F-statistic is exact.~%") w)
        (display-string (format nil "~%F-statistic is approximate.~%") w)))
     (when (not (select mtest 6))
      (display-string
       (format nil "Multivariate test not reported. Matrix of response variables is too close to singularity.~%") w)))
    (when (not mtest)
          (display-string (format nil "~%Multivariate test not calculated.") w)
          (when (> (sum (send self :num-dv) (send self :num-iv)) 
                   (send self :nobs))
                (display-string (format nil " (There are more variables than observations.)") w)) )
    (display-string (format nil "~%Response  Variable Standard Deviations~%~a" 
                            (fuzz y-stdv 4)) w)
    (display-string (format nil "~%Predictor Variable Standard Deviations~%~a" 
                            (fuzz x-stdv 4)) w)
    
    (display-string 
     (format nil "~2%Raw Regression (B) Coefficients~%") w)
    (print-matrix-to-window (transpose coefs) w :labels ivars)
    (display-string
     (format nil "~%Standardized Regression (Beta) Coefficients~%") w)  
    (print-matrix-to-window beta w :labels ivars)
    (display-string 
     (format nil "~%Regression Scores (Predicted/Fitted Values):~%") w)
    (print-matrix-to-window scores w :labels labels)
    (when redun
     (display-string (format nil "~%------------------------------~%") w)
     (display-string (format nil "~%REDUNDANCY ANALYSIS") w)
     (display-string (format nil "~%Using ~d Redundancy Variates" redun) w)     
     (display-string (format nil "~%Eigenvectors~%") w)
     (print-matrix-to-window (send self :redun-evecs) w :labels dvars)
     (display-string (format nil "~%Eigenvalues  = ~a" 
                     (combine (fuzz (send current-model :redun-evals) 4))) w)
     (display-string (format nil "~%Proportions  = ~a"
                  (combine (fuzz (/ (send current-model :redun-evals)
                                    (sum (send current-model :redun-evals)))
                                 4))) w)
     (display-string (format nil "~%Redundancies = ~a"
                     (combine (fuzz
                     (/ (send self :redun-evals) (send self :num-iv)) 4))) w)
     (display-string (format nil "~%Redundancy   = ~7,4f (total)" 
                             (send self :redun-index)) w)
     (display-string (format nil "~%Redundancy   = ~7,4f (for ~d variates)"
              (sum (select (/ (send self :redun-evals) (send self :num-dv))
                           (iseq (send self :redundancy))))
         (send self :redundancy)) w)                                                               
     (display-string (format nil "~2%Redundancy Variate Coefficients~%") w)
     (print-matrix-to-window (send self :redun-coefs) w :labels ivars)
     (display-string (format nil "~%Raw Redundancy Regression Coefficients~%(Using the first ~d Redundancy Variates)~%"redun) w)
     (print-matrix-to-window (send self :redun-bmat) w :labels ivars)
     (display-string (format nil "~%Standardized Redundancy Regression Coefficients~%(Using the first ~d Redundancy Variates)~%"redun) w)
     (print-matrix-to-window 
      (matmult (diagonal x-stdv) 
               (send self :redun-bmat) 
               (inverse (diagonal y-stdv))) w :labels ivars)
     (display-string 
     (format nil "~%Redundancy Scores (Predicted/Fitted Values)~%(Using the first ~d Redundancy Variates)~%"redun) w)
    (print-matrix-to-window (send self :redun-scores) w :labels labels)
    (when w (send w :show-window))
    w)))))

(defmeth mmr-model-object-proto :options ()
"Args: none
Constructs and displays the options dialog window for regression models.
Returns nil or a four element list.  Returns nil when dialog canceled or when no response or predictor variables selected, returns four element list otherwise.  The first element of the list is a list of response variable indices.  The second element is a list of predictor variable indices. The third element is the index of the weight variable, or nil for unweighted analysis.  The fourth element is T for intercept models, nil for non-intercept models."
  (when (not (send self :dialog))
        (send self :iv ($position (send self :predictors)
                                  (send self :variables)))
        (send self :dv ($position (send self :responses)
                                  (send self :variables))))
  (when (send self :dialog)
  (let* ((mob self)
         (box-text-item (send text-item-proto :new 
                              "Multivariate Multiple Regression Options"))
         (select-toggle (send choice-item-proto :new (list
                              "Select Response  Variables"
                              "Select Predictor Variables"
                              "Select Weighting Variable") 
                              :value 0))
         (intercept     (send toggle-item-proto :new "Include the Intercept Term" 
                              :value t))
         (use-text  (send text-item-proto :new "Use"))
         (redun (send edit-text-item-proto :new "0"))
         (redun-text (send text-item-proto :new "Redundancy Variates"))
         (weight-var-text (send text-item-proto :new "Weight Var:"))
         (weight-var    (send list-item-proto :new (list "")))
         (var-text-item (send text-item-proto :new "Selectable Variables"))
         (rsp-text-item (send text-item-proto :new "Selected Responses"))
         (prd-text-item (send text-item-proto :new "Selected Predictors"))
         (var-list (send self :variables))
         (rsp-list (repeat " " (length var-list)))
         (prd-list (repeat " " (length var-list)))
         (rsp-nums nil)
         (prd-nums nil)
         (weight-num nil)
         (var-list-item (send list-item-proto :new var-list
                              :action #'(lambda () (move-vars &optional dc))))
         (rsp-list-item (send list-item-proto :new rsp-list))
         (prd-list-item (send list-item-proto :new prd-list))
         (ok        (send modal-button-proto :new "OK"))
         (cancel    (send modal-button-proto :new "Cancel"))
         (reg-dialog (send modal-dialog-proto :new
                     (list box-text-item
                           (list select-toggle
                                 (list
                                  (list use-text redun redun-text)
                                  (list weight-var-text weight-var)
                                  intercept))
                           (list (list var-text-item var-list-item)
                                 (list rsp-text-item rsp-list-item)
                                 (list prd-text-item prd-list-item))
                           (list ok cancel))
                           :default-button ok)))

    (defmeth ok :do-action ()
      (let ((dialog (send ok :dialog))
            )
        (send mob :intercept (send intercept :value))
        (send mob :weights weight-num)
        (send mob :iv prd-nums)
        (send mob :dv rsp-nums)
        (send mob :redundancy (number-from-string (send redun :text)))
        (cond 
          ((or (> 1 (length prd-nums))
               (> 1 (length rsp-nums)))
           (error-message "You must select at least one response and one predictor variable.")
           (send dialog :modal-dialog-return nil))
          (t (send dialog :modal-dialog-return t)))
        ))

    (defmeth cancel :do-action ()
      (let ((dialog (send cancel :dialog)))
        (send dialog :modal-dialog-return nil)))

    (defmeth var-list-item :do-action (&optional dbl-clk)
      (let* ((n (send self :selection))
             (s (select (send self :slot-value 'list-data) n))
             (m nil))
        (when (and n (not (equal s " ")))
              (send self :set-text n " ") ;OK
              (when (= 0 (send select-toggle :value))
                    (setf m (position " " 
                               (send rsp-list-item :slot-value  'list-data)
                                      :test 'equal))
                    (send rsp-list-item :set-text m s)
                    (setf rsp-nums (concatenate 'list rsp-nums (list n))))
              (when (= 1 (send select-toggle :value))
                    (setf m (position " " 
                               (send prd-list-item :slot-value  'list-data)
                                      :test 'equal))
                    (send prd-list-item :set-text m s)
                    (setf prd-nums (concatenate 'list prd-nums (list n))))
              (when (and (not weight-num) (= 2 (send select-toggle :value)))
                    (send weight-var :set-text 0 s)
                    (setf weight-num n))
              (send self :selection nil))))

    (defmeth rsp-list-item :do-action (&optional dbl-clk)
      (let* ((n (send self :selection))
             (L (length rsp-nums))
             (s nil)
             (m nil))
        (when n
              (setf s (select (send self :slot-value 'list-data) n))
              (when (> L n) 
                    (setf m (select rsp-nums n))
                    (when (< n (1- L))
                          (dolist (i (iseq n (- L 2)))
                                  (send self :set-text i 
                                        (select (send self :slot-value 
                                                      'list-data) (1+ i)))))
                    (send self :set-text (1- L) " ")
                    (send var-list-item :set-text m s)
                    (send self :selection nil)
                    (setf rsp-nums (remove m rsp-nums))))))

    (defmeth prd-list-item :do-action (&optional dbl-clk)
      (let* ((n (send self :selection))
             (L (length prd-nums))
             (s nil)
             (m nil))
        (when n
              (setf s (select (send self :slot-value 'list-data) n))
              (when (> L n)
                    (setf m (select prd-nums n))
                    (when (< n (1- L))
                          (dolist (i (iseq n (- L 2)))
                                  (send self :set-text i 
                                        (select (send self :slot-value
                                                      'list-data) (1+ i)))))
                    (send self :set-text (1- L) " ")
                    (send var-list-item :set-text m s)
                    (send self :selection nil)
                    (setf prd-nums (remove m prd-nums))))))

    (defmeth weight-var :do-action (&optional dbl-clk) 
      (let* ((s (select (send self :slot-value 'list-data) 0))
             )
        (when (not (equal s ""))
              (send self :set-text 0 "")
              (send var-list-item :set-text weight-num s)
              (send self :selection nil)
              (setf weight-num nil))))

    (if (send reg-dialog :modal-dialog)
        (list rsp-nums prd-nums weight-num (send intercept :value) 
              (send redun :text));:value
        nil))))
  
  
(provide "mmrmob1")
(require "mmrmob2")