#|

     class19.lsp   

   - Regression scatterplot object

   - Smoothing calculations


|#


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                                         ;;
;;    Regression scatterplot extension                     ;;
;;                                     Stine, 1996         ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#|

  (def rs (regression-scatterplot '(1 2 3 4 5) '(3 5 4 6 8)
                                  "X" "Y"))
       

|#


(defun REGRESSION-SCATTERPLOT (x y labelx labely &key cases menuItems)
  (let ((p (send regr-scatter-proto :new x y labelx labely menuItems))   )
    (when cases
          (send p :point-label (iseq (length x)) cases)
          (send p :showing-labels t))
    p
    ))
        

(defproto regr-scatter-proto
  '(
    b0 b1        ; ols regr parms  -- also used to signal need to draw
    r0 r1        ; rob regr parms
    smthPct      ; how much to lowess
    sliderItem   ; slider menu item controlling smoother
    menuItems    ; externally supplied menu items
    )        
  '()
  scatterplot-proto
  )

(defmeth regr-scatter-proto :ISNEW (x y labelx labely menuItems)
  (if menuItems (send self :add-menu-items menuItems :new nil))
  (call-next-method 2 :title "Scatter Plot")
  (send self :add-points (list x y))
  (send self :add-mouse-mode 'move-point :title "Move point"
        :cursor 'hand :click :do-move-point)
  (send self :add-mouse-mode 'drag-point :title "Drag point"
        :cursor 'hand :click :do-drag-point)
  (setf (slot-value 'smthPct) .4)
  (send self :variable-label '(0 1) (list labelx labely))
  (send self :x-axis t nil 3)
  (send self :y-axis t nil 3)
  (send self :adjust-to-data)
  )

(defmeth regr-scatter-proto :SET-SMOOTH-PCT (sp)
  (setf (slot-value 'smthPct) sp))

(defmeth regr-scatter-proto :CLEAR-LINE-PARMS ()
  ; Resets intercepts to nil.
  (setf (slot-value 'b0) nil)
  (setf (slot-value 'r0) nil)
  )


(defmeth regr-scatter-proto :PRINT-LINES ()
  (if (or (slot-value 'b0) (slot-value 'r0))
       (let ((lab (send self :variable-label '(0 1)))  )
        (format t "Scatterplot regression lines...~%")
         (if (slot-value 'b0)
             (format t "  OLS  regression: ~a = ~8,3g + ~8,3g ~a~%"
                     (select lab 1) (slot-value 'b0) (slot-value 'b1)
                     (select lab 0))   )
         (if (slot-value 'r0)
             (format t "Robust regression: ~a = ~8,3g + ~8,3g ~a~%"
                     (select lab 1) (slot-value 'r0) (slot-value 'r1)
                     (select lab 0))   )
         )))
            


;;  Mouse Modes

(defmeth regr-scatter-proto :DO-MOVE-POINT (x y s o)  ; x y shift opt
  (let ((p (send self :drag-point x y)))
    (when p
          (when (slot-value 'b0) 
                (setf (slot-value 'b0) nil) ; force new line
                (send self :draw-ols-line))
          (when (slot-value 'r0)
                (setf (slot-value 'r0) nil) ; force new line
                (send self :draw-robust-line))
          (format t "Point ~d has been moved.~%" p)
          )))

(defmeth regr-scatter-proto :DO-DRAG-POINT (x y s o)
  (let ((p (first (send self :points-in-rect (- x 5) (- y 5) 10 10)))  )
    (when p
          (let ((save  (send self :point-coordinate '(0 1) p))
                (draw? (slot-value 'b0))  )
            (send self :while-button-down 
                  #'(lambda (x y)
                      (let ((xy (send self :canvas-to-real x y))  )
                        (send self :point-coordinate '(0 1) p xy)
                        (when draw? 
                              (setf (slot-value 'b0) nil) ; force new line
                              (send self :clear-lines)
                              (send self :draw-ols-line))
                        )))
            (send self :point-coordinate '(0 1) p save)
            (when draw? 
                  (setf (slot-value 'b0) nil) ; force new line
                  (send self :clear-lines)
                  (send self :draw-ols-line))
            ))))
        
(defmeth regr-scatter-proto :ADD-MENU-ITEMS (items &key (new t))   ; 2/23/94
  (let ((items (if (listp items) items (list items)))  )
    (setf (slot-value 'menuItems)
          (if (slot-value 'menuItems)
              (append items (slot-value 'menuItems))
              (append items (list 'dash))   ))
    (when new
          (send self :new-menu "Scatter"
                (send self :menu-template)))
    ))

(defmeth regr-scatter-proto :MENU-TEMPLATE ()
  (send self :menu-title "Scatter")
  (let ((sItem (send slider-menu-item-proto :new 
                     :target self
                     :label "Lowess Slider"
                     :action #'(lambda () (send self :build-slider)))) )
    (setf (slot-value 'sliderItem) sItem)
    (append (slot-value 'menuItems)
            (call-next-method)
            (list 'dash
                  (send menu-item-proto :new "Clear lines"
                        :action #'(lambda ()
                                    (send self :clear-lines)
                                    (send self :clear-line-parms)))
                  (send menu-item-proto :new "Show OLS" 
                        :action #'(lambda ()
                                    (send self :draw-ols-line)))
                  (send menu-item-proto :new "Show Robust"
                        :action #'(lambda ()
                                    (send self :draw-robust-line)))
                  (send menu-item-proto :new "Print lines"
                        :action #'(lambda () (send self :print-lines)))
                  (send menu-item-proto :new "Fit poly"
                        :action #'(lambda() (send self :fit-poly)))
                  'dash
                  sItem
                  (send menu-item-proto :new "Show Smooth"
                        :action #'(lambda () (send self :draw-smooth)))
                  (send menu-item-proto :new "Bootstrap Smooth"
                        :action #'(lambda ()
                                    (send self :bootstrap-smooth)) )
                  ))))
  
(defmeth regr-scatter-proto :FIT-POLY ()
  ; 2 Jul 96 ... 3 Jul 96
  (let ((order (get-pos-integer-dialog "Enter degree of polynomial"))  )
    (when order
        (let* ((index (send self :fit-indices))
               (xx ())
               (x  (send self :point-coordinate 0 index))
               (i  (order x))
               (xs (select x i))
               (y  (select (send self :point-coordinate 1 index) i))  )
          (send self :add-lines xs
                (send (regression-model 
                       (mapcar #'(lambda (p) (^ xs p)) (iseq 1 order))
                       y) :fit-values) :color 'green)
          ))))
              

(defmeth regr-scatter-proto :FIT-INDICES ()
  ;Indices of non-invisible points for fitting lines.
  (let ((all (iseq (send self :num-points)))  )
    (select all (which
                 (mapcar #'(lambda (s) (not (eq 'invisible s)))
                         (send self :point-state all))
                 ))))

           

(defun GET-POS-INTEGER-DIALOG (msg &key (init 1))
  (let ((n (get-value-dialog msg :initial init)))
    (when n
          (setf n (first n))
          (if (> n 0)  (floor n)
              (message-dialog "Need a positive integer."))
          )))
      
 
;;  Override these two to make sure the regression lines are there

(defmeth regr-scatter-proto :ERASE-SELECTION ()      ; OVERRIDE
  (call-next-method)
  (setf (slot-value 'b0) nil)
  (setf (slot-value 'r0) nil))

(defmeth regr-scatter-proto :SHOW-ALL-POINTS ()      ; OVERRIDE
  (call-next-method)
  (setf (slot-value 'b0) nil)
  (setf (slot-value 'r0) nil))

;;  Each of the calc functions calls fit-indices to locate valid points

(defmeth regr-scatter-proto :CALC-OLS-LINE ()
  (let* ((index (send self :fit-indices))
         (x  (send self :point-coordinate 0 index))
         (y  (send self :point-coordinate 1 index))
         (mx (mean x))
         (my (mean y))
         (dx (- x mx))
         (b1 (/ (inner-product dx y) (inner-product dx dx)))
         (b0 (- my (* b1 mx)))  )
    (setf (slot-value 'b0) b0)
    (setf (slot-value 'b1) b1)
    ))

(defmeth regr-scatter-proto :DRAW-OLS-LINE ()
    (unless (slot-value 'b0)
            (send self :calc-ols-line))
    (send self :abline (slot-value 'b0) (slot-value 'b1))
    )

(defmeth regr-scatter-proto :CALC-ROBUST-LINE ()
  (let* ((index (send self :fit-indices))
         (b  (first (send robust-regression-proto :robust-ests
                          (list (send self :point-coordinate 0 index))
                          (send self :point-coordinate 1 index))))  )
    (setf (slot-value 'r0) (first b))
    (setf (slot-value 'r1) (second b))
    ))


(defmeth regr-scatter-proto :DRAW-ROBUST-LINE ()
  (unless (slot-value 'r0)
          (send self :calc-robust-line)  )
  (let ((x (send self :range 0))
        (r0 (slot-value 'r0))
        (r1 (slot-value 'r1))   )
    (send self :add-lines (list x (+ r0 (* r1 x))) :color 'red)
    ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  
;;     Smoothing
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmeth regr-scatter-proto :BUILD-SLIDER ()
  (let ((slider (interval-slider-dialog (list 0 1)
                  :action #'(lambda(pct)
                              (send self :set-smooth-pct pct)
                              (send self :draw-smooth)
                              )))   )
    (send slider :add-slot 'menuitem)
    (send slider :menu-item-is (slot-value 'sliderItem))
    (send slider :value (slot-value 'smthPct))
    (send self :add-subordinate slider)
    (send (slot-value 'sliderItem) :slider-is slider)
    ))
       

(defmeth regr-scatter-proto :DRAW-SMOOTH ()
   (let* ((index (send self :fit-indices))
          (x  (send self :point-coordinate 0 index))
          (y  (send self :point-coordinate 1 index))   )
     (send self :clear-lines)
     (when (slot-value 'b0) (send self :draw-ols-line))
     (when (slot-value 'r0) (send self :draw-robust-line))
     (send self :add-lines (lowess x y :f (slot-value 'smthPct)))
     ))

(defmeth regr-scatter-proto :BOOTSTRAP-SMOOTH ()
  (let* ((bLim (get-pos-integer-dialog "How many samples?"))
         (indx (send self :fit-indices))
         (x    (send self :point-coordinate 0 indx))
         (y    (send self :point-coordinate 1 indx))
         (pct  (send self :slot-value 'smthPct))   )
    (dotimes (b bLim)
             (let* ((sample (sample indx (length indx) t))
                    (x*     (select x sample))
                    (y*     (select y sample))  )
               (send self :add-lines (lowess x* y* :f pct) :color 'blue)
               ))
    ))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  
;;     SLIDER MENU ITEM
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defproto SLIDER-MENU-ITEM-PROTO
  '(target     ; graph window it modifies
    slider )   ; slider used to make the changes
   ()
  menu-item-proto
  )

(defmeth slider-menu-item-proto :ISNEW (&key target label action)
  (setf (slot-value 'target) target)
  (call-next-method label :action action)
  )

(defmeth slider-menu-item-proto :SLIDER-IS (slider)
  (setf (slot-value 'slider) slider))

(defmeth slider-menu-item-proto :UPDATE ()
  ;  In order to be enabled, the target has no existing slider."
  (send self :enabled
        (if (slot-value 'slider)   ; we have no slider
            nil t)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                                         ;;
;;    B-Spline basis functions.                            ;;
;;                                                         ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun DIV-DIFF (x y)
  ; Computes the divided differences of desired order
  (let ((k (length x))  )
    (cond 
      ((= 1 k)  y)
      ((= 2 k)  (/ (- (second y) (first y))
                   (- (second x) (first x)))   )
      (  t      (/ (- (div-diff (rest x)    (rest y))
                      (div-diff (butlast x) (butlast y)))
                   (- (select x (1- k)) (first x)))    )
      )))
                  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                                         ;;
;;    Smoothing response function.                         ;;
;;                                                         ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#|
      
  (def n 200)
  (def x (rseq 0 1 n))

  (def  y (repeat 0 n))
  (setf (select y 10) 1)

  (def s (lowess x y :steps 0 :sorted t))
  (def p (plot-points s))

  (defun indicator (j) (let ((y (repeat 0 n))  )
                         (setf (select y j) 1)
                         y))
  (def frac .3)

  (def s0 (second (lowess x (indicator   0) :f frac :steps 0 :sorted t)))
  (def s1 (second (lowess x (indicator  20) :f frac :steps 0 :sorted t)))
  (def s2 (second (lowess x (indicator  40) :f frac :steps 0 :sorted t)))
  (def s3 (second (lowess x (indicator  60) :f frac :steps 0 :sorted t)))
  (def s4 (second (lowess x (indicator 100) :f frac :steps 0 :sorted t)))
   
  (def p (plot-lines x s0))
  (send p :add-lines x s1)
  (send p :add-lines x s2)
  (send p :add-lines x s3)
  (send p :add-lines x s4)

  (format t "Sums of smooth values is ~a~%" (sum s4))

|#