;;########################################################################
;; mmrmob2.lsp
;; multivariate multiple regression ViSta model object
;; Copyright (c) 1991-95 by Forrest W. Young
;; Multivariate Test implemented by Mark G. Baxter
;; Redundancy Analysis implemented by Mark G. Baxter and Forrest W. Young 
;;########################################################################

(require "mmrmob1")

(defmeth mmr-model-object-proto :analysis ()
  (let* ((dv (send self :dv))
         (iv (send self :iv))
         (intercept (send self :intercept))
         (weights (send self :weights))
         (all-coefs nil)
         (all-coefs-mat nil)
         (all-scores nil)
         (all-scores-mat nil)
         (rm ())
         (num-dv (length dv))
         (num-iv (length iv))
         (numobs (send self :nobs)) 
         )
    (when (>= num-iv numobs) 
          (error (format nil "Cannot analyze data that does not have more observations (~d) than predictor variables (~d)." numobs num-iv)))
    (when (< (send self :redundancy) 0)
          (error-message "The minimum number of redundancy variates is zero. Redundancy analysis will not be performed."))
    (when (> (send self :redundancy) (min num-dv num-iv))
          (send self :redundancy (min num-dv num-iv))
          (error-message (format nil "The number of redundancy variates has been lowered to the maximum of ~d." (min num-dv num-iv))))
        
    (when (<= (send self :redundancy) 0) (send self :redundancy nil))
 
    (dolist (i dv)
            (setf rm (concatenate 'list rm (list  
               (regression-model 
                (col (send self :data-matrix) iv)
                (col (send self :data-matrix) i )
                :intercept intercept
                :predictor-names (select (send self :variables) iv)
                :response-name   (select (send self :variables) i )
                :weights (if weights 
                             (col (send self :data-matrix) weights)
                             nil)
                :print nil
                )))))
    (dotimes (i num-dv)
             (setf all-coefs (combine all-coefs 
                    (if intercept 
                       (rest (send (select rm i) :coef-estimates))
                    (send (select rm i) :coef-estimates))))
             (setf all-scores 
                 (combine all-scores 
                          (send (select rm i) :fit-values)))
             )
    (setf all-coefs  (rest all-coefs))
    (setf all-scores (rest all-scores))
    (setf all-coefs-mat (matrix (list num-dv num-iv) all-coefs))
    (setf all-scores-mat 
               (transpose (matrix (list num-dv numobs) all-scores)))
    (send self :num-iv num-iv)
    (send self :num-dv num-dv)
    (send self :coefs all-coefs-mat)
    (send self :scores all-scores-mat)
    (send self :reg-models rm)
    (send self :compute-cor-cov)
    (send self :y-stdv (sqrt (mapcar #'variance (column-list 
                       (send self :get-y-matrix)))))
    (send self :x-stdv (sqrt (mapcar #'variance (column-list 
                       (send (first (send self :reg-models)) :x)))))
    (send self :beta   (matmult (diagonal (send self :x-stdv)) 
                       (transpose (send self :coefs)) 
                       (inverse (diagonal (send self :y-stdv)))))
    (if (and (> (send self :num-dv) 1) (send self :redundancy))
        (send self :compute-redundancy-variables))
    ))

(defmeth mmr-model-object-proto :compute-cor-cov ()
  (let* ((x-mat   (send (first (send self :reg-models)) :x))
         (y-mat   (send self :get-y-matrix))
         (yx-mat  (bind-columns y-mat x-mat))) 
    (send self :cor (correlation-matrix yx-mat))
    (send self :cov (covariance-matrix  yx-mat))))

(defmeth mmr-model-object-proto :get-y-matrix ()
    (let* ((y-mat (send (first (send self :reg-models)) :y))
           (y-mat-2 nil))
      (dotimes (i (1- (send self :num-dv)))
               (setf y-mat-2 
                     (bind-rows y-mat (send (select (send self :reg-models) 
                                                  (1+ i)) :y)))
               (setf y-mat y-mat-2))
      (if (= 1 (send self :num-dv))
          (matrix (list (length y-mat) 1) y-mat)
          (transpose y-mat))))

(defmeth mmr-model-object-proto :get-intercept-vector ()
  (let* ((int-vec (first (send (first (send self :reg-models)) 
                               :coef-estimates)))
         (int-vec-2 nil))
    (dotimes (i (1- (send self :num-dv)))
             (setf int-vec-2 
                   (combine int-vec (first (send (select 
                            (send current-model :reg-models) (1+ i)) 
                                                 :coef-estimates))))
             (setf int-vec int-vec-2))
    int-vec))

(defmeth mmr-model-object-proto :multivariate-test ()
    (let* ((x-mat (send (first (send self :reg-models)) :x))
           (x-mat-1 (bind-columns (repeat 1 (first (array-dimensions x-mat))) 
                                  x-mat))
           (y-mat (send self :get-y-matrix))
           (beta (bind-rows (send self :get-intercept-vector) 
                            (transpose (send self :coefs))))
           (c (transpose (bind-columns 
                          (repeat 0 (second (array-dimensions x-mat)))
                          (diagonal 
                           (repeat 1 
                                   (second (array-dimensions x-mat)))))))
           (s-h (matmult (transpose (matmult (transpose c) beta)) 
                         (inverse (matmult (transpose c) 
                                           (inverse 
                                            (matmult (transpose x-mat-1)
                                                     x-mat-1)) c)) 
                         (transpose c) beta))
           (resid (- y-mat (matmult x-mat-1 beta)))
           (s-e (matmult (transpose resid) resid))
           (wl
            (cond
              ((> (determinant (+ s-h s-e)) 1E-9)
               (/ (determinant s-e) (determinant (+ s-h s-e))))
              (t 1)))
           (p (array-dimension (+ s-h s-e) 0))
           (q (array-dimension 
               (matmult (transpose c) 
                (inverse (matmult (transpose x-mat-1) x-mat-1))
                c) 0))
           (v (- (1- (array-dimension x-mat 0)) (array-dimension x-mat 1)))
           (s (min (list p q)))
           (m (* 0.5 (1- (abs (- p q)))))
           (n (* 0.5 (1- (- v p))))
           (r (- v (/ (+ (- p q) 1) 2)))
           (u (/ (- (* p q) 2) 4))
           (tee (cond
                ((> (- (+ (^ p 2) (^ q 2)) 5) 0)
                 (^ (/ (- (* p p q q) 4) (- (+ (^ p 2) (^ q 2)) 5)) 0.5))
                (t 1)))
           (wl-alt (^ wl (/ 1 tee)))
           (f-stat (/ (* (- 1 wl-alt) (- (* r tee) (* 2 u))) 
                   (* wl-alt (* p q))))
           (num-df (* p q))
           (den-df (- (* r tee) (* 2 u)))
           (p-level (- 1 (f-cdf f-stat num-df den-df)))
           (singflag t)
           (exact (cond
                    ((> (min (list p q)) 2) nil)
                    (t t))))
      (when
       (< (determinant (matmult (transpose x-mat) x-mat)) 1E-9)
       (setf singflag nil))
      (when
       (< (determinant (matmult (transpose y-mat) y-mat)) 1E-9)
       (setf singflag nil))       
       (list wl f-stat num-df den-df p-level exact singflag)))

(defmeth mmr-model-object-proto :compute-redundancy-variables () 
  (let* ((x-mat   (send (first (send self :reg-models)) :x))
         (y-mat   (send self :get-y-matrix))
         (x-stdv  (sqrt (mapcar #'variance (column-list x-mat))))
         (y-stdv  (sqrt (mapcar #'variance (column-list y-mat))))
         (x-means (mapcar (function mean) (column-list x-mat)))
         (y-means (mapcar (function mean) (column-list y-mat)))
         (nx      (array-dimension x-mat 1))
         (ny      (array-dimension y-mat 1))
         (nr      (send self :redundancy))
         (nvar    (array-dimension x-mat 0))
         (x-devia (- x-mat (matrix (list nvar nx) (repeat x-means nvar))))
         (r       (send self :cor))
         (results (send self :redundancy-solve r ny nx nr)))
    (send self :redun-index (first results))
    (send self :redun-evals (second results))
    (send self :redun-evecs (third results))
    (send self :redun-coefs (fourth results))
    (send self :redun-bmat  
          (transpose (matmult (diagonal y-stdv) 
                              (transpose (fifth results))
                              (inverse (diagonal x-stdv)))))
    (send self :redun-scores 
          (+ (matmult x-devia (send self :redun-bmat)) 
             (matrix (list nvar ny) (repeat y-means nvar))))
    ))

(defmeth mmr-model-object-proto :redundancy-solve (s ny nx nr) 
"Args: S NY NX
Computes the redundancy solution for S, a covariance matrix for NY responses (the first portion of S) and NX predictors (the last portion), using the first NR redundancy variates. Returns a list containing the redundancy index value, eigen-values, eigen-vectors, A-matrix (redundancy variate coefficients) and Beta-Matrix (standardized redundancy coefficients based on NR variates)."
  (let* ((nrank (min ny nx))
         (nall  (+ nx ny))
         (iy    (iseq ny))
         (ix    (iseq ny (1- nall)))
         (s-xx  (select s ix ix))
         (s-yx  (select s iy ix))
         (s-xy  (transpose s-yx)) 
         (prod  (matmult s-yx (inverse s-xx) (transpose s-yx)))
         (e-sol (eigen prod))
         (evals (select (first e-sol) (iseq nrank)))
         (redun-index (/ (sum evals) ny))
         (r-di  (sqrt (inverse (diagonal evals))))
         (evecs (second e-sol))
         (u-d   (transpose (matrix (list nrank ny) 
                                   (combine (select evecs (iseq nrank))))))  
         (a     (matmult      (inverse s-xx) s-xy u-d r-di));jackson
        ;(a     (matmult r-di (inverse s-xx) s-xy u-d     ));tyler
         (beta  (matmult (select a (iseq nx) (iseq nr)) 
                         (transpose (select a (iseq nx) (iseq nr))) 
                         s-xy)))
    (list redun-index evals u-d a beta)))
    

;old visualization replaced by fwy 4.31:10/30/97 through 4.32:12/11/97

(load (strcat *code-dir-name* "mmrvis"))
(provide "mmrmob2")
