;;########################################################################
;; anovavs2.lsp
;; Copyright (c) 1993-97 by Forrest W. Young
;; anovavis.lsp and anovavs2.lsp contain the code for anova visualization.
;;########################################################################

(require "vista")

; ************ Leverage Plot ***********************************

(defun leverage-plot 
  (sel model &key (title "Regression Plot")
     (variable-labels (list "Predicted Values" "Values"))  
     point-labels location size y-range y-axis y-mean (go-away t) (show t))
  (send leverage-plot-proto :new sel model
        :title title :point-labels point-labels
        :variable-labels variable-labels 
        :location location  :size size 
        :y-range y-range :y-axis y-axis :y-mean y-mean
        :go-away go-away :show show))

(defun lplot (sel model &rest args)
  (apply #'leverage-plot sel model args))

(defproto leverage-plot-proto '(confidence-constant) () scatterplot-proto)

(defmeth leverage-plot-proto :isnew 
  (sel model &key title 
         variable-labels point-labels location size 
         y-range y-axis y-mean go-away show)
  (call-next-method 2 :title title :variable-labels variable-labels
                    :location location :size size :go-away go-away :show nil)
  (send self :confidence-constant 
        (send self :make-confidence-constant model))
  (send self :new-menu "RegPlot" 
              :items '(LINK SHOWING-LABELS MOUSE RESIZE-BRUSH DASH 
                            ERASE-SELECTION FOCUS-ON-SELECTION SHOW-ALL 
                            SYMBOL COLOR SELECTION))
  (send self :new-plot sel model 
        :variable-labels variable-labels
        :point-labels point-labels 
        :y-range y-range 
        :y-axis y-axis
        :y-mean y-mean)
  (when show (send self :show-window))
  self)

(defmeth leverage-plot-proto :confidence-constant 
  (&optional (number nil set))
"Method args: (&optional number)
Sets or returns constant for calculating confidence envelope."
  (if set (setf (slot-value 'confidence-constant) number))
  (slot-value 'confidence-constant))

(defmeth leverage-plot-proto :new-plot 
  (sel model &key variable-labels point-labels y-range y-axis y-mean)
  (let* ((upper nil)
         (lower nil)
         (nway (send model :nway-model))
         (grouped-data-and-labels nil)
         (permuted-point-labels nil)
         (grouped-data nil)
         (means nil)
         (lsmeans nil)
         (way nil)
         (x (send nway :x))
         (y (send nway :y))
         (s (standard-deviation y))
         (t-value nil))
    (send self :start-buffering)
    (send self :clear)
    (when (not (= sel 0))
          (setf grouped-data-and-labels 
                (send model :grouped-data (1- sel) point-labels))
          (setf permuted-point-labels 
                (combine (second grouped-data-and-labels)))
          (setf grouped-data (first grouped-data-and-labels))
          (setf means (mapcar #'mean grouped-data))
          (setf lsmeans (combine (map-elements 
                                  #'(lambda (x y) (repeat x (length y)))
                                  means grouped-data)))
          (setf way (select (send model :source-names) (1- sel)))
          (send self :title "Partial Regression Plot")
          (send self :add-points
                lsmeans 
                ;(combine (send model :grouped-values 
                ;               (select (send model :lev sel) 0)
                ;               model (- sel 1)))
                (combine (send model :grouped-values 
                               (select (send model :lev sel) 1) 
                               model (- sel 1))) :color 'blue :symbol 'square)
          (send self :point-label 
                (iseq (length point-labels)) permuted-point-labels)
          (send self :variable-label 0 
                (strcat (send model :response) " LS Means for " way)))
    (when (= sel 0)
          (send self :title "Regression Plot")
;          (send self :add-points
;                (send nway :fit-values) 
;                (send nway :y) :color 'blue :symbol 'square)
          (send self :add-points 
                (select (send model :lev sel) 0)
                (select (send model :lev sel) 1) :color 'blue :symbol 'square)
          (send self :point-label (iseq (length point-labels)) point-labels)
          (send self :variable-label 0 
                (strcat (send model :response) " LS Means")))
    (send self :variable-label 1 (send model :response))
    (send self :range 0 (first y-range) (second y-range))
    (apply #'send self :x-axis y-axis)
    (send self :range 1 (first y-range) (second y-range))
    (apply #'send self :y-axis y-axis)
    (send self :abline 0 1)
    (send self :linestart-color (iseq (send self :num-lines)) 'red)
    (send self :linestart-width (iseq (send self :num-lines)) 2)
    (send self :confidence-envelope model sel)
    (send self :abline y-mean 0)
    (send self :redraw)
    (send self :buffer-to-screen)
    ))

(defmeth leverage-plot-proto :make-confidence-constant (model)
"Args: Model
Calculates constant for calculating confidence interval."
  (let* ((nway-model (send model :nway-model))
         (s-sq (variance (combine (send model :data))))
         (t-sq (t-quant .975 (1- (send nway-model :num-cases))))
         (x (send model :leverages))
         (x-bar (matrix (list 1 (second (size x)))
                        (mapcar #'mean (column-list x))))
         (xpxi (inverse (matmult (transpose x) x)))
         (h-bar (select (matmult x-bar xpxi (transpose x-bar)) 0 0))
         )
    (* s-sq t-sq h-bar)))
  
(defmeth leverage-plot-proto :confidence-envelope (model sel)
  (flet ((z-value (x mean f-ratio)
                  (sqrt (+ (send self :confidence-constant)
                           (* f-ratio (^ (- x mean) 2))))))
  (let* ((nway-model (send model :nway-model))
         (df (send nway-model :source-degrees-of-freedom))
         (ms (/ (send nway-model :source-sum-of-squares) df))
         (f-obs  (/ (select ms sel) (first (last ms))))
         (f-crit (f-quant .95 (select df sel) (first (last df))))
         (f-ratio (if (/= 0 f-obs)
                      (/ f-crit f-obs)
                      1.0E30))
         (x-range (send self :range 0))
         (y-range (send self :range 1))
         (lev-mean (mean (select (send model :lev sel) 0)))
         (half-range (max (- (second x-range) lev-mean) 
                          (- lev-mean (first x-range))))
         (sequence (* half-range (/ (^ (iseq 9) 4) (^ 8 4))))
         (z (combine (reverse (- lev-mean sequence)) 
                     (rest (+ lev-mean sequence))))
         (x (combine (first x-range) 
                     (select z (which (< (first x-range) z (second x-range))))
                     (second x-range)))
         (boundary-line (z-value x lev-mean f-ratio))
         (y-low (- x boundary-line)); y= x-b  x=y+b
         (ok-y-low (which (< (first y-range) y-low (second y-range))))
         (y-low (select y-low ok-y-low))
         (x-low (select x ok-y-low))
        ; (y-low (combine (first y-range) y-low))
        ; (y-low-bound-value (sqrt (+ (send self :confidence-constant) 
        ;                             (z-value 64 lev-mean f-ratio)))) 
        ; (x-low (combine (+ (first y-range) y-low-bound-value) x-low))
         (y-up (+ x boundary-line))
         (ok-y-up (which (< (first y-range) y-up (second y-range))))
         (y-up (select y-up ok-y-up) )
         (x-up (select x ok-y-up))
         )
;(break)
    (when (/= 0 f-obs)
          (send self :add-lines x-low y-low :color 'red :width 2)
          (send self :add-lines x-up y-up  :color 'red :width 2))
    )))

(defmeth leverage-plot-proto :plot-help ()
  (plot-help-window (strcat "Help for " (send self :title)))
  (paste-plot-help (format nil 
"The ANOVA (partial) regression plot is a plot of the response variable versus the Least Squared (LS) Means for the selected ANOVA source. The LS Means are the values of the response variable that are predicted by the selected source. Since the LS Mean for a given level of the selected source is the same for all observations within that level, the plot shows vertical lines of dots. The dots in a line are the observations within a level of the source.~2%"))
(paste-plot-help (format nil
"The plot shows the relationship between the response variable and the predictions of the response made by the selected source. This relationship is represented by the scatter of points, and it is summarized by the straight. 45 degree line. This line is the (partial) regression line. The slope and intercept of this line are based on the parameter estimates computed by the analysis.~2%"))
(paste-plot-help (format nil
"If the scatter of points displays a linear relationship, then the assumption of linearity is satisfied for the analysis. The strength of relationship is displayed by the scatter of points around the regression line. ~2%"))
(paste-plot-help (format nil
"The plot also shows a horizontal line and two curved lines. The horizontal line is drawn at the mean of the response variable. The two curved lines are the upper and lower 95% confidence boundaries for the (partial) regression. If these lines intersect with the horizontal line, then the ANOVA source is significant, at the 95% level, in predicting the response variable."))
  (show-plot-help)
  )

;;methods taken from table object so analysis will work with mv data

(defmeth anova-model-object-proto :make-interaction-indicator-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-indicator-matrix 
                             j i)))))
          (send self :indicator-matrices
                (append (send self :indicator-matrices)
                        interaction-matrices))
          )))

(defmeth anova-model-object-proto :twoway-interaction-indicator-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 anova-model-object-proto :grouped-data (source &optional labels)
"Args: SOURCE &optional LABELS
Groups data, and optionally LABELS, according to SOURCE. Returns grouped data, or if labels is not nil, a list of grouped data and grouped labels."
  (let* ((data (combine (send self :data)))
         (indicator (nth source (send self :indicator-matrices)))
         (nclasses (second (size indicator)))
         (members nil)
         (grouped-data nil)
         (grouped-labels nil))
    (dotimes (i nclasses)
             (setf members (select data (which (= 1 (col indicator i)))))
             (setf grouped-data (append grouped-data (list members)))
             (when labels 
               (setf members (select labels (which (= 1 (col indicator i)))))
               (setf grouped-labels (append grouped-labels (list members))))
             )
    (if labels
        (list grouped-data grouped-labels)
        grouped-data)))

(defmeth anova-model-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 anova-model-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)))