;;########################################################################
;; regvis2.lsp
;; Visualization for OLS, Robust & Monotonic Regression ViSta model object
;; This file contains moral-spreadplot-supervisor-proto code
;; and linear regression, residual and influence plot proto code
;; Copyright (c) 1995-6 by Carla M. Bann. 
;; Updated 1998 for new spreadplot and for color by Forrest Young
;;########################################################################

(defmeth morals-spreadplot-supervisor-proto :location-array ()
  (let* ((location (make-array (list 2 3))))
    (dotimes (i 2)
         (dotimes (j 3)
              (setf (aref location i j)
                    (list (* j (+ plot-size window-decoration-width 3));i
                          (+ (* i (+ plot-size 2))
                             (* msdos-fiddle (+ 1 i));fwy 4.27
                        #+X11 (+ 5 (* 28 (+ (* 2 i) 1))) ;fwy 4.27
                             (* (1+ i) window-decoration-height))))))
    (setf loc11 (select location 0 0))
    (setf loc12 (select location 0 1))
    (setf loc13 (select location 0 2))
    (setf loc21 (select location 1 0))
    (setf loc22 (select location 1 1))
    (setf loc23 (select location 1 2))))

;next method replaced by simpler one that follows
(defmeth morals-spreadplot-supervisor-proto :close-dialog (plot)
  (let* ((choice (send choice-item-proto :new 
                       (list "Close 1 Plot" "Close All Plots")
                       :value 0))
         (ok (send modal-button-proto :new "OK" :action
                   #'(lambda ()
                       (let ((dialog (send ok :dialog))
                             (value (send choice :value))
                             )
                         (when (= value 0)
                               (send plot :hide-window)
                               (send (send plot :menu) :remove)
                               (send plot :showing nil))
                         (when (= value 1)
                               (send self :hide-ssp)
                               (send (send plot :menu) :remove))
                         (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)))))
         
         (close-dialog (send modal-dialog-proto :new
                             (list choice (list ok cancel))))
         )
  (send close-dialog :modal-dialog)
))

(defmeth morals-spreadplot-supervisor-proto :close-dialog (plot)
  (send self :remove) ;hide-ssp
  (send (send plot :menu) :remove)
  (send (send self :model) :spreadplot-supervisor nil)
  (setf *current-spreadplot* nil)
  )

(defmeth morals-spreadplot-supervisor-proto :make-menu-item (item-template)
  (if (kind-of-p item-template menu-item-proto)
      item-template
      (case item-template
        ( resid-plot1 (send graph-item-proto :new "Residual Plot-1"
                      (send self :residual-plot1) :show-plot) )
        ( resid-plot2 (send graph-item-proto :new "Residual Plot-2"
                            (if (send self :residual-plot2)
                                (send self :residual-plot2)
                                self)  :show-plot) )
        ( av-plot (send graph-item-proto :new "Added Variables Plot"
                        (if (send self :added-var-plot) (send self :added-var-plot)
                            self) :show-plot))
        ( infl-plot1 (send graph-item-proto :new "Influence Plot-1"
                           (if (send self :influence-plot1)
                               (send self :influence-plot1)
                               self)  :show-plot))
        ( infl-plot2 (send graph-item-proto :new "Influence Plot-2"
                          (if (send self :influence-plot2)
                               (send self :influence-plot2)
                               self)  :show-plot))
        ( trans-plot1 (send graph-item-proto :new "Fit/Transformation Plot"
                          (if (send self :transformation-plot)
                               (send self :transformation-plot)
                               self) :show-plot))
        ( trans-plot3 (send graph-item-proto :new "OLS Fit Plot"
                          (if (send self :transformation-plot)
                              (send self :transformation-plot)
                              self) :show-plot))
        ( trans-plot2 (send graph-item-proto :new "OLS Regression Plot"
                          (if (send self :lin-reg-plot)
                               (send self :lin-reg-plot)
                               self) :show-plot))
        ( rsq-plot (send graph-item-proto :new "RSQ-Beta Plot"
                        (if (send self :rsq-beta-plot)
                            (send self :rsq-beta-plot)
                            self) :show-plot))
       ; ( var-list (send graph-item-proto :new "Variable List"
       ;                 (if (send self :var-list)
       ;                     (send self :var-list)
       ;                     self) :show-window))
        ( obs-list (send graph-item-proto :new "Observation List"
                        (if (send self :obs-list)
                            (send self :obs-list)
                            self) :show-window))
        ( robust-plot (send graph-item-proto :new "Robust Weights Plot"
                        (if (send self :robust-plot)
                            (send self :robust-plot)
                            self) :show-window))
        ( robust-reg-plot (send graph-item-proto :new "Robust Fit Plot"
                        (if (send self :robust-reg-plot)
                            (send self :robust-reg-plot)
                            self) :show-window))
        ( t (call-next-method item-template))
        
)))

(defmeth morals-spreadplot-supervisor-proto :show-visible-plots () 
  (mapcar #'(lambda (x)
              (when (send x :showing) (send x :show-window)))
          (send self :all-plots)))

(defmeth morals-spreadplot-supervisor-proto :hide-all-plots ()
  (mapcar #'(lambda (x)
              (send x :hide-window))
          (send self :all-plots)))

(defmeth morals-spreadplot-supervisor-proto :get-residuals (plot)  
  (let* (
         (resid-list (list "MR-Raw" "MR-Bayes" "MR-Student" "MR-External"  
                           "RR-Raw" "RR-Bayes" "RR-Student" "RR-External"
                           "LR-Raw" "LR-Bayes" "LR-Student" "LR-External"))
         (mod (send self :model))        
         (morals-model (send mod :morals-model))
         (model (if (equalp (send mod :method) "Robust") 
                    (send mod :robust-model) morals-model))
         (lin-reg (send mod :lin-reg-model))
         (dv2 (select (send mod :variables) (send mod :dv)))
         (dv (if (listp dv2) (select dv2 0) dv2))
         (opred (strcat "OLS Predicted " dv))
         (mpred (strcat "Monotone Predicted " dv))
         (rpred (strcat "Robust Predicted " dv))
         (pindex nil)
         (i 0)
         (initial-index nil)
         (resid-type nil)
         (choice nil)
         (r (/ (send model :residuals) (send model :sigma-hat)))
         (r2 (/ (send lin-reg :residuals) (send lin-reg :sigma-hat)))
         (d (* 2 (sqrt (send model :leverages))))
         (low (- r d))
         (high (+ r d))
         (d2 (* 2 (sqrt (send lin-reg :leverages))))
         (low2 (- r2 d2))
         (high2 (+ r2 d2))
         (x-values (send model :fit-values))
         (x-values2 (send lin-reg :fit-values))
         (labels (send mod :labels))
         (color 'black)
        )

    #+color(when (> *color-mode* 0) (setf color 'blue))
    (if (equalp plot (send self :residual-plot1)) (setf pindex 1) (setf pindex 2)) 
    (if (= pindex 1) (setf resid-type (send self :resid-type1)) 
        (setf resid-type (send self :resid-type2)))
    (dotimes (i 12)
             (if (equalp resid-type (select resid-list i))
                 (setf initial-index i)))
    (when (equalp (send mod :method) "OLS")
         (setf choice (choose-item-dialog "Choose type of residuals: "
                  '("Residuals"
                    "Bayes Residuals"
                    "Standardized Residuals")
                   :initial (- initial-index 8)))) 
    (when (equalp (send mod :method) "Monotonic")
          (if (< initial-index 8)
              (setf initial-index (+ initial-index 3))
              (setf initial-index (- initial-index 8)))
        (setf choice (choose-item-dialog "Choose type of residuals: "
                  '("OLS Residuals" 
                    "Bayes OLS Residuals"
                    "Standardized OLS Residuals" 
                  ;  "Externally Standardized Residuals"
                    "Raw Monotone Residuals" 
                    "Bayes Monotone Residuals" 
                    "Standardized Monotone Residuals" 
                   ; "Externally Standardized Monotone Residuals" 
                         ) 
                    :initial initial-index)))
    (when (equalp (send mod :method) "Robust")
          (if (< initial-index 8)
              (setf initial-index (+ initial-index 3))
              (setf initial-index (- initial-index 8)))
        (setf choice (choose-item-dialog "Choose type of residuals: "
                  '("OLS Residuals" 
                    "Bayes OLS Residuals"
                    "Standardized OLS Residuals" 
                  ;  "Externally Standardized OLS Residuals"
                    "Weighted Robust Residuals"
                    "Bayes Robust Residuals"
                    "Standardized Robust Residuals"
                  ;  "Externally Standardized Robust Residuals"
                         ) 
                    :initial initial-index)))
    (if choice (when (> choice 2) (setf choice (+ choice 1))))
    (case choice
      (0 (send plot :clear-points)
         (send plot :clear-lines)
         (send plot :add-points (send lin-reg :fit-values)
               (send lin-reg :raw-residuals) 
               :color color
               :point-labels labels)
         (send plot :variable-label '(0 1) (list opred "OLS Residuals"))
         (send plot :abline 0 0)
         (send plot :adjust-to-data)
         (if (= pindex 1) (send self :resid-type1 "LR-Raw") (send self :resid-type2 "LR-Raw")))
      (1 (send plot :clear-points)
         (send plot :clear-lines)
         (send plot :add-points x-values2 r2 
               :color color :point-labels labels)
         (map 'list #'(lambda (a b c d) (send plot :plotline a b c d nil))
               x-values2 low2 x-values2 high2)
         (send plot :abline 0 0)
         (send plot :variable-label '(0 1) (list opred "Bayes OLS Residuals"))
         (send plot :adjust-to-data)
         (if (= pindex 1) (send self :resid-type1 "LR-Bayes") (send self :resid-type2 "LR-Bayes")))
      (2 (send plot :clear-points)
         (send plot :clear-lines)
         (send plot :add-points (send lin-reg :fit-values)
               (send lin-reg :studentized-residuals) 
               :color color :point-labels labels)
         (send plot :abline 0 0)
         (send plot :variable-label '(0 1) (list opred "Standardized OLS Residuals")) 
         (send plot :adjust-to-data)
         (if (= pindex 1) (send self :resid-type1 "LR-Student") (send self :resid-type2 "LR-Student")))
      (3 (send plot :clear-points)
         (send plot :clear-lines)
         (send plot :add-points (send lin-reg :fit-values) 
               (send lin-reg :externally-studentized-residuals)
               :color color :point-labels labels)
         (send plot :abline 0 0)
         (send plot :variable-label '(0 1) (list opred "Externally Standardized OLS Residuals"))
         (send plot :adjust-to-data)
         (if (= pindex 1) (send self :resid-type1 "LR-External") (send self :resid-type2 "LR-External")))
      (4 (send plot :clear-points)
         (send plot :clear-lines)
         (send plot :add-points (send model :fit-values)
               (send model :residuals) :color color :point-labels labels)
         (send plot :abline 0 0)
         (if (equalp (send mod :method) "Robust")
             (send plot :variable-label '(0 1) 
                   (list rpred "Weighted Robust Residuals"))
             (send plot :variable-label '(0 1) 
                   (list mpred "Monotone Residuals")))
         (send plot :adjust-to-data)
         (if (= pindex 1) (send self :resid-type1 "MR-Raw") (send self :resid-type2 "MR-Raw")))
      (5 (send plot :clear-points)
         (send plot :clear-lines)
         (send plot :add-points x-values r :color color :point-labels labels)
         (send plot :abline 0 0)
         (map 'list #'(lambda (a b c d) (send plot :plotline a b c d nil))
               x-values low x-values high)
         (if (equalp (send mod :method) "Robust")
             (send plot :variable-label '(0 1)
                   (list rpred "Bayes Robust Residuals"))
             (send plot :variable-label '(0 1) 
                   (list mpred "Bayes Monotone Residuals")))
         (send plot :adjust-to-data)
         (if (= pindex 1) (send self :resid-type1 "MR-Bayes") (send self :resid-type2 "MR-Bayes")))
      (6 (send plot :clear-points)
         (send plot :clear-lines)
         (send plot :add-points (send model :fit-values)
               (send model :studentized-residuals) 
               :color color :point-labels labels)
         (send plot :abline 0 0)
         (if (equalp (send mod :method) "Robust")
             (send plot :variable-label '(0 1)
                   (list rpred "Standardized Robust Residuals"))
             (send plot :variable-label '(0 1) 
                   (list mpred "Standardized Monotone Residuals")))
         (send plot :adjust-to-data)
         (if (= pindex 1) (send self :resid-type1 "MR-Student") (send self :resid-type2 "MR-Student")))
      (7 (send plot :clear-points)
         (send plot :clear-lines)
         (send plot :add-points (send model :fit-values) 
               (send model :externally-studentized-residuals)
               :color color :point-labels labels)
         (send plot :abline 0 0)
         (if (equalp (send mod :method) "Robust")
             (send plot :variable-label '(0 1)
                   (list rpred "Externally Standardized Robust Residuals"))
             (send plot :variable-label '(0 1) 
                   (list mpred "Externally Standardized Monotone Residuals")))
         (send plot :adjust-to-data)
         (if (= pindex 1) (send self :resid-type1 "MR-External") (send self :resid-type2 "MR-External")))

      )
    ))

(defmeth morals-spreadplot-supervisor-proto :get-influence (plot)
  (let* (
         (pindex nil)
         (infl-list (list "MR-Lev" "MR-Cooks" "RR-Lev" "RR-Cooks" "LR-Lev" "LR-Cooks"))
         (initial-index nil)
         (choice2 nil)
         (infl-type nil)
         (i 0)
         (mod (send self :model))
         (model (send mod :morals-model))
         (morals-model (send mod :morals-model))
         (lin-reg (send mod :lin-reg-model))
         (dv2 (select (send mod :variables) (send mod :dv)))
         (dv (if (listp dv2) (select dv2 0) dv2))
         (opred (strcat "OLS Predicted " dv))
         (mpred (strcat "Monotone Predicted " dv))
         (rpred (strcat "Robust Predicted " dv))
         (labels (send mod :labels))
         (color 'black)
        )
    #+color(when (> *color-mode* 0) (setf color 'blue))
   (if (equalp plot (send self :influence-plot1)) (setf pindex 1) (setf pindex 2))
   (if (= pindex 1) (setf infl-type (send self :infl-type1))
                    (setf infl-type (send self :infl-type2)))
   (if (equalp (send mod :method) "Robust") 
        (setf model (send mod :robust-model))
        (setf model (send mod :morals-model)))
   (dotimes (i 6)
            (if (equalp infl-type (select infl-list i))
                (setf initial-index i)))
   (when (equalp (send mod :method) "OLS") 
         (setf choice2 (choose-item-dialog "Choose an influence statistic:"
                       '("Leverages" 
                         "Cooks Distances")
                       :initial (- initial-index 4))))
   (when (equalp (send mod :method) "Monotonic")
         (if (> initial-index 3)
             (setf initial-index (- initial-index 4))
             (setf initial-index (+ initial-index 2)))
         (setf choice2 (choose-item-dialog "Choose an influence statistic:"
                  '("OLS Leverages" "OLS Cooks Distances"
                    "Monotone Leverages" 
                    "Monotone Cooks Distances")
                   :initial initial-index)))
   (when (equalp (send mod :method) "Robust")
         (if (> initial-index 3) (setf initial-index (- initial-index 4)))
         (setf choice2 (choose-item-dialog "Choose an influence statistic:"
                  '("OLS Leverages" "OLS Cooks Distances"
                    "Robust Leverages" "Robust Cooks Distances")
                   :initial initial-index))) 
  (case choice2
      (0 (send plot :clear-points)
         (send plot :add-points (send lin-reg :fit-values)
               (send lin-reg :leverages) :color color :point-labels labels)
         (send plot :variable-label '(0 1) (list opred "OLS Leverages"))
         (send plot :adjust-to-data)
         (if (= pindex 1) 
             (send self :infl-type1 "LR-Lev") 
             (send self :infl-type2 "LR-Lev")))
      (1 (send plot :clear-points)
         (send plot :add-points (send lin-reg :fit-values)
               (send lin-reg :cooks-distances) 
               :color color :point-labels labels)
         (send plot :variable-label '(0 1) (list opred "OLS Cook's Distances"))
         (send plot :adjust-to-data)
         (if (= pindex 1) 
             (send self :infl-type1 "LR-Cooks")
             (send self :infl-type2 "LR-Cooks")))
      (2 (send plot :clear-points)
         (send plot :add-points (send model :fit-values)
               (send model :leverages) :color color :point-labels labels)
         (cond 
           ((equalp (send mod :method) "Robust")
            (send plot :variable-label '(0 1)
                  (list rpred "Robust Leverages"))
            (if (= pindex 1) 
                (send self :infl-type1 "RR-Lev") 
                (send self :infl-type2 "RR-Lev")))
           (t
            (send plot :variable-label '(0 1) 
                  (list mpred "Monotone Leverages"))
            (if (= pindex 1) 
                (send self :infl-type1 "MR-Lev") 
                (send self :infl-type2 "MR-Lev"))))
         (send plot :adjust-to-data))
      (3 (send plot :clear-points)
         (send plot :add-points (send model :fit-values)
               (send model :cooks-distances) 
               :color color :point-labels labels)
         (cond
           ((equalp (send mod :method) "Robust")
            (send plot :variable-label '(0 1)
                  (list rpred "Robust Cook's Distances"))
            (if (= pindex 1) 
                (send self :infl-type1 "RR-Cooks") 
                (send self :infl-type2 "RR-Cooks")))
           (t
            (send plot :variable-label '(0 1) 
                  (list mpred "Monotone Cook's Distances"))
            (if (= pindex 1) 
                (send self :infl-type1 "MR-Cooks") 
                (send self :infl-type2 "MR-Cooks"))))
         (send plot :adjust-to-data)))))


 

;; residual-plot-proto

(defproto residual-plot-proto '(spreadplot-supervisor showing)
  '() scatterplot-proto)

(defmeth residual-plot-proto :spreadplot-supervisor (&optional (obj-id nil set)) 
  (when set (setf (slot-value 'spreadplot-supervisor) obj-id)) 
  (slot-value 'spreadplot-supervisor))

(defmeth residual-plot-proto :showing (&optional (obj-id nil set)) 
  (when set (setf (slot-value 'showing) obj-id)) 
  (slot-value 'showing))

(defmeth residual-plot-proto :show-plot ()
  (send self :show-window)
  (send self :showing t))

(defmeth residual-plot-proto :new-y () 
  (send self :change-y-axis))

(defmeth residual-plot-proto :change-y-axis ()
  (send (send self :spreadplot-supervisor) :get-residuals self))

(defun residual-plot (spreadplot-supervisor x y &rest args)
  (apply #'send residual-plot-proto :new spreadplot-supervisor x y args))


(defmeth residual-plot-proto :isnew
  (spreadplot-supervisor x y
     &rest args
     &key
     (title "Residuals")
     (menu-title "Resid")
     (scale 'nil)
     (show 't)
     showing)
  (let ((labels (send (send spreadplot-supervisor :model) :labels)))
    (send self :spreadplot-supervisor spreadplot-supervisor)
    (apply #'call-next-method 2 
           (append args `(:title ,title :menu-title ,menu-title :show nil)))
    (when (not (send spreadplot-supervisor :simple-reg))
          (send self :plot-buttons :new-x nil))
    (send self :add-points x y :point-labels labels :draw 'nil)
    #+color(when (> *color-mode* 0)
                 (send self :use-color t)
                 (send self :point-color 
                       (iseq (send self :num-points)) 'blue))
    (send self :adjust-to-data :draw 'nil)
    (send self :abline 0.0 0.0)
    (if show (send self :show-window))
    ))

(defmeth residual-plot-proto :close ()
  (send (send self :spreadplot-supervisor) :close-dialog self))

(defproto influence-plot-proto '(spreadplot-supervisor showing)
  '() scatterplot-proto)

(defmeth influence-plot-proto :spreadplot-supervisor (&optional (obj-id nil set)) 
  (when set (setf (slot-value 'spreadplot-supervisor) obj-id)) 
  (slot-value 'spreadplot-supervisor))

(defmeth influence-plot-proto :showing (&optional (obj-id nil set)) 
  (when set (setf (slot-value 'showing) obj-id)) 
  (slot-value 'showing))

(defmeth influence-plot-proto :show-plot ()
  (send self :show-window)
  (send self :showing t))

(defmeth influence-plot-proto :new-y () (send self :change-y-axis))

(defmeth influence-plot-proto :change-y-axis ()
  (send (send self :spreadplot-supervisor) :get-influence self))

(defun influence-plot (spreadplot-supervisor x y &rest args)
  (apply #'send influence-plot-proto :new spreadplot-supervisor x y args))


(defmeth influence-plot-proto :isnew
  (spreadplot-supervisor x y
     &rest args
     &key
     (title "Influence")
     (menu-title "Influence")
     (scale 'nil)
     (show 't)
     showing)
  (let ((labels (send (send spreadplot-supervisor :model) :labels)))
    (send self :spreadplot-supervisor spreadplot-supervisor)
    (apply #'call-next-method 2 
           (append args `(:title ,title :menu-title ,menu-title :show nil)))
    (when (not (send spreadplot-supervisor :simple-reg))
          (send self :plot-buttons :new-x nil :new-y nil))
    (send self :add-points x y :point-labels labels :draw 'nil)
    #+color(when (> *color-mode* 0)
                 (send self :use-color t)
                 (send self :point-color 
                       (iseq (send self :num-points)) 'blue))
    (send self :adjust-to-data :draw 'nil)
    (if show (send self :show-window))
    ))

(defmeth influence-plot-proto :close ()
  (send (send self :spreadplot-supervisor) :close-dialog self))


;******************** Linear Regression Plot *****************


(defproto lin-reg-plot-proto '(spreadplot-supervisor showing)
  '() scatterplot-proto)

(defmeth lin-reg-plot-proto :spreadplot-supervisor (&optional (obj-id nil set)) 
  (when set (setf (slot-value 'spreadplot-supervisor) obj-id)) 
  (slot-value 'spreadplot-supervisor))

(defmeth lin-reg-plot-proto :showing (&optional (obj-id nil set)) 
  (when set (setf (slot-value 'showing) obj-id)) 
  (slot-value 'showing))

(defmeth lin-reg-plot-proto :show-plot ()
  (send self :show-window)
  (send self :showing t))


(defun lin-reg-plot (spreadplot-supervisor x y &rest args)
  (apply #'send lin-reg-plot-proto :new spreadplot-supervisor x y args))


(defmeth lin-reg-plot-proto :isnew
  (spreadplot-supervisor x y
     &rest args
     &key
     (title "Fit")
     (menu-title "Fit")
     (scale 'nil)
     (show 't)
     showing)
  (let* ((model (send spreadplot-supervisor :model))
         (dv2 (select (send model :variables) (send model :dv)))
         (dv (if (listp dv2) (select dv2 0) dv2)))
    (send self :spreadplot-supervisor spreadplot-supervisor)
    (apply #'call-next-method 2 
           (append args `(:title ,title :menu-title ,menu-title 
                                 :show nil)))
    (send self :variable-label '(0 1)
          (list dv (strcat "OLS Predicted " dv)))
    
    (send self :add-points x y)
    #+color(when (> *color-mode* 0)
                 (send self :use-color t)
                 (send self :point-color 
                       (iseq (send self :num-points)) 'blue))
    (send self :adjust-to-data)
    (send self :abline 0 1)
    (send self :linked t)
    (if show (send self :show-window))
    ))

(defmeth lin-reg-plot-proto :close ()
  (send (send self :spreadplot-supervisor) :close-dialog self))
