;
;******************************************************
;
; menu action-items.
;
; ena - 3/7/2000
;
;******************************************************
;
(provide "menu-action-items")
;
(defun read-spectra ()
   (prog*
      (
         (name (get-string-dialog "Label for this data set:"))
         (inten NIL)
         (freq NIL)
         )
      (message-dialog "Select frequency data.")
      (setf freq (read-data-columns))
      (message-dialog "Select intensity data.")
      (setf inten (read-data-columns))
      (setf *freq* (append *freq* (list freq)))
      (setf *inten* (append *inten* (list inten)))
      (setf *spectra-names* (append *spectra-names* (list name)))
      (prin1 (concatenate 'string "finished reading " name))
      (terpri)
      (if (yes-or-no-dialog "Read another spectrum?") (read-spectra))
      )
   )
;
(defun read-covar ()
   (prog*
      (
         (tmp (get-read-covar-values))
         (name (first tmp))
         (jit (second tmp))
         (vals (read-data-file))
         )
      (if jit (setf vals (+ vals (- (/ (uniform-rand (length vals)) 10) 0.05))))
      (setf *covar-vals* (append *covar-vals* (list vals)))
      (setf *covar-names* (append *covar-names* (list name)))
      (prin1 (concatenate 'string "finished reading " name))
      (terpri)
      (if (yes-or-no-dialog "Read another covariate?") (read-covar))
      )
   )
;
(defun delete-spectra ()
   (prog*
      (
         (del (first (choose-subset-dialog "spectra to delete" *spectra-names*)))
         (keep (sort (set-difference (iseq (length *spectra-names*)) del) #'<))
         )
      (setf *spectra-names* (select *spectra-names* keep))
      (setf *freq* (select *freq* keep))
      (setf *inten* (select *inten* keep))
      (prin1 "finished deleting spectra")
      (terpri)
      )
   )
;
(defun delete-vars ()
   (prog*
      (
         (del (first (choose-subset-dialog "variable to delete" *covar-names*)))
         (keep (sort (set-difference (iseq (length *covar-names*)) del) #'<))
         )
      (setf *covar-names* (select *covar-names* keep))
      (setf *covar-vals* (select *covar-vals* keep))
      (prin1 "finished deleting variables")
      (terpri)
      )
   )
;
(defun fetch ()
   (let*
      (
         (vals (get-fetch-values))
         (name (first vals))
         (var-sel (second vals))
         (name-symbol (string2symbol name))
         (var (select *covar-vals* var-sel))
         )
      (myset name-symbol var)
      (prin1 "variable fetched")
      (terpri)
      )
   )
;
(defun store ()
   (prog*
      (
         (names (get-store-values))
         (name-in (first names))
         (name-store (second names))
         (val (eval (string2symbol name-in)))
         )
      (setf *covar-names* (append *covar-names* (list name-store)))
      (setf *covar-vals* (append *covar-vals* (list val)))
      (prin1 "variable stored")
      (terpri)
      )
   )
;
(defun register-by-area ()
   (prog*
      (
         (spectra (choose-item-dialog "Select spectrum for analysis:"
            *spectra-names*))
         (freq (transpose (select *freq* spectra)))
         (inten (transpose (select *inten* spectra)))
         (areas (mapcar #'integrate freq inten))
         (inten-registered (mapcar #'(lambda (x y) (/ x y)) inten areas))
         (name (get-string-dialog "Name for registered spectrum:"))
         (name-area (get-string-dialog "Covariate name for areas:"))
         )
      (setf *spectra-names* (append *spectra-names* (list name)))
      (setf *freq* (append *freq* (list (transpose freq))))
      (setf *inten* (append *inten* (list (transpose inten-registered))))
      (setf *covar-names* (append *covar-names* (list name-area)))
      (setf *covar-vals* (append *covar-vals* (list areas)))
      (prin1 "finished registration.")
      (terpri)
      )
   )
;
(defun register-by-max ()
   (prog*
      (
         (spectra (choose-item-dialog "Select spectrum for analysis:"
            *spectra-names*))
         (freq (transpose (select *freq* spectra)))
         (inten (transpose (select *inten* spectra)))
         (maxvals (mapcar #'max inten))
         (inten-registered (mapcar #'(lambda (x y) (/ x y)) inten maxvals))
         (name (get-string-dialog "Name for registered spectrum:"))
         (name-max (get-string-dialog "Covariate name for max vals:"))
         )
      (setf *spectra-names* (append *spectra-names* (list name)))
      (setf *freq* (append *freq* (list (transpose freq))))
      (setf *inten* (append *inten* (list (transpose inten-registered))))
      (setf *covar-names* (append *covar-names* (list name-max)))
      (setf *covar-vals* (append *covar-vals* (list maxvals)))
      (prin1 "finished registration.")
      (terpri)
      )
   )
;
(defun register-to-max ()
   (prog*
      (
         (spectra (choose-item-dialog "Select spectrum for analysis:"
            *spectra-names*))
         (freq (transpose (select *freq* spectra)))
         (inten (transpose (select *inten* spectra)))
         (pos-max (mapcar #'posmax inten))
         (max (mapcar #'(lambda (x y) (select x y)) freq pos-max))
         (mean-freq (mapcar #'mean (transpose freq)))
         (mean-inten (mapcar #'mean (transpose inten)))
         (ref-max (select mean-freq (posmax mean-inten)))
         (freq-registered (mapcar #'(lambda (x1 x2 x3)
            (register-one-to-max x1 x2 x3 ref-max)) freq pos-max max))
         (name (get-string-dialog "Name for registered spectrum:"))
         (name-pos-max (get-string-dialog "Covariate name for position of max:"))
         )
      (setf *spectra-names* (append *spectra-names* (list name)))
      (setf *freq* (append *freq* (list (transpose freq-registered))))
      (setf *inten* (append *inten* (list (transpose inten))))
      (setf *covar-names* (append *covar-names* (list name-pos-max)))
      (setf *covar-vals* (append *covar-vals* (list max)))
      (prin1 "finished registration.")
      (terpri)
      )
   )
;
(defun hist ()
   (let*
      (
         (var (choose-item-dialog "Select covariate:" *covar-names*))
      )
      (hist-link (select *covar-vals* var) (select *covar-names* var))
      )
   )
;
(defun scat ()
   (let*
      (
         (var (choose-2-covars))
      )
      (scat-link (first var) (second var))
      )
   )
;
(defun scat-mat ()
   (let*
      ((vars (first (choose-subset-dialog "Select covariates for plot." *covar-names*))))
      (scat-mat-link (select *covar-vals* vars) (select *covar-names* vars))
      )
   )
;
(defun spin ()
   (let*
      (
         (vars (choose-3-covars))
         )
      (spin-link vars)
      )
   )
;
(defun plot-data ()
   (prog* 
      (
         (dataset (choose-item-dialog "Select spectrum for analysis:" *spectra-names*))
         (inten (select *inten* dataset))
         (freq (select *freq* dataset))
         )
      (line-plot (transpose (list (transpose freq) (transpose inten)))
         (concatenate 'string "data: " (select *spectra-names* dataset)))
      )
   )
;
(defun plot-der ()
   (prog* 
      (
         (dataset (choose-item-dialog "Select spectrum for analysis:" *spectra-names*))
         (inten (select *inten* dataset))
         (freq (select *freq* dataset))
         (allspline (map 'list #'myspline (transpose freq) (transpose inten)))
         (trspl (transpose allspline))
         (allder (map 'list #'myder (select trspl 0) (select trspl 1)))
         (tallder (transpose allder))
         (derx (select tallder 0))
         (dery (select tallder 1))
         )
      (line-plot (transpose (list derx dery)) 
         (concatenate 'string "deriv: " (select *spectra-names* dataset)))
      )
   )
;
(defun plot-par ()
   (prog* 
      (
         (data (choose-2-spectra))
         (dataset1 (first data))
         (inten1 (select *inten* dataset1))
         (freq1 (select *freq* dataset1))
         (dataset2 (second data))
         (inten2 (select *inten* dataset2))
         (freq2 (select *freq* dataset2))
         (spl1 (map 'list #'myspline (transpose freq1) (transpose inten1)))
         (spl2 (map 'list #'myspline (transpose freq2) (transpose inten2)))
         (trspl1 (transpose spl1))
         (trspl2 (transpose spl2))
         (splinten1 (select trspl1 1))
         (splinten2 (select trspl2 1))
         )
      (line-plot (transpose (list splinten1 splinten2))
         (concatenate 
            'string (select *spectra-names* dataset1) " vs " (select *spectra-names* dataset2)))
      )
   )
;
(defun pc-analysis ()
   (let*
      (
         (info (get-pca-info))
         (spectrum (select info 0))
         (numpc (select info 1))
         (analysis-name (select info 2))
         (covariates (select info 3))
         (covars (which covariates))
         (weight-names (select info 4))
         (weight-fit-names (select info 5))
         (pca-resid-name (select info 6))
         (regress-resid-name (select info 7))
         (inten (select *inten* spectrum))
         (freq (select *freq* spectrum))
         (allspline (map 'list #'myspline (transpose freq) (transpose inten)))
         (trspl (transpose allspline))
         (splfreq (select trspl 0))
         (splinten (select trspl 1))
         (means (mapcar #'mean splinten))
         (splintenadj (mapcar #'- splinten means))
         (nrow (length splintenadj))
         (ncol (length (select splintenadj 0)))
         (intenmat (make-array (list nrow ncol) :initial-contents splintenadj))
         (svd (sv-decomp intenmat))
         (u (select svd 0))
         (w (select svd 1))
         (v (select svd 2))
         (v2 (column-list v))
         (v3 (mapcar #'vect2list (select v2 (iseq numpc))))
         (w2 (make-array (length w) :initial-element 0))
         (temp (setf (select w2 (iseq numpc)) (select w (iseq numpc))))
         (intenfit (matmult u (diagonal w2) (transpose v)))
         (intenfit2 (row-list intenfit))
         (intenfit3 (mapcar #'vect2list intenfit2))
         (pca-resid (mapcar #'- splintenadj intenfit2))
         (b (matmult (transpose v) (transpose intenmat)))
         (pcvals (select (row-list b) (iseq numpc)))
         (pcvals2 (mapcar #'vect2list pcvals))
         (reg-list 
            (mapcar #'(lambda (x) 
               (regression-model (select *covar-vals* covars) x 
               :print nil :predictor-names (select *covar-names* covars))) pcvals2))
         (fit-weights (mapcar #'(lambda (x) (send x :fit-values)) reg-list))
         (pred (matmult (list2matrix (transpose fit-weights)) (list2matrix v3)))
         (pred2 (mapcar #'vect2list (row-list pred)))
         (regress-resid (mapcar #'- splintenadj pred2))
         (norm-pca-resid (mapcar #'(lambda (x) (sqrt (sum (^ x 2)))) pca-resid))
         (norm-regress-resid (mapcar #'(lambda (x) (sqrt (sum (^ x 2)))) regress-resid))
         )
      (setf *covar-names* (append *covar-names* weight-names))
      (setf *covar-vals* (append *covar-vals* pcvals2))
      (setf *covar-names* (append *covar-names* weight-fit-names))
      (setf *covar-vals* (append *covar-vals* fit-weights))
      (setf *covar-names* (append *covar-names* (list pca-resid-name)))
      (setf *covar-vals* (append *covar-vals* (list norm-pca-resid)))
      (setf *covar-names* (append *covar-names* (list regress-resid-name)))
      (setf *covar-vals* (append *covar-vals* (list norm-regress-resid)))
      (setf *regress-names* (append *regress-names* (list analysis-name)))
      (setf *regress-vals* (append *regress-vals*
         (list
            (list 
               (select *covar-names* covars)
               reg-list
               v3
               splfreq
               splintenadj
               pca-resid
               intenfit3
               pred2
               regress-resid
               )
            )
         ))
      (prin1 (concatenate 'string "finished computing analysis " analysis-name))
      (terpri)
      )
   )
;
(defun plot-pc-curves ()
   (prog*
      (
         (pick-analysis (choose-item-dialog "Select PC analysis:" *regress-names*))
         (analysis (select *regress-vals* pick-analysis))
         (inten (select analysis 2))
         )
      (mapcar #'(lambda (x) (plot-lines (iseq (length x)) x)) inten)
      )
   )
;
(defun pca-resid ()
   (prog*
      (
         (pick-analysis (choose-item-dialog "Select PC analysis:" *regress-names*))
         (scaled (yes-or-no-dialog "Scale plot to (adjusted) data?"))
         (analysis (select *regress-vals* pick-analysis))
         (freq (select analysis 3))
         (pca-resid (select analysis 5))
         (name (select *regress-names* pick-analysis))
         (plot (line-plot (transpose (list freq pca-resid)) (concatenate 'string
            "PCA Residuals - " name)))
         )
      (if scaled
         (prog*
            (
               (inten (select analysis 4))
               (max-inten (max (mapcar #'max inten)))
               (min-inten (min (mapcar #'min inten)))
               )
            (send plot :range 1 min-inten max-inten)
            )
         )
      )
   )
;
(defun pca-obs-fit ()
   (prog*
      (
         (pick-analysis (choose-item-dialog "Select PC analysis:" *regress-names*))
         (analysis (select *regress-vals* pick-analysis))
         (inten (select analysis 4))
         (pca-fitted (select analysis 6))
         (name (select *regress-names* pick-analysis))
         )
      (line-plot (transpose (list inten pca-fitted)) (concatenate 'string
         "PCA Obs vs Fit - " name))
      )
   )
;
(defun regress-resid ()
   (prog*
      (
         (pick-analysis (choose-item-dialog "Select PC analysis:" *regress-names*))
         (scaled (yes-or-no-dialog "Scale plot to (adjusted) data?"))
         (analysis (select *regress-vals* pick-analysis))
         (freq (select analysis 3))
         (regress-resid (select analysis 8))
         (name (select *regress-names* pick-analysis))
         (plot (line-plot (transpose (list freq regress-resid)) (concatenate 'string
            "Regression Residuals - " name)))
         )
      (if scaled
         (prog*
            (
               (inten (select analysis 4))
               (max-inten (max (mapcar #'max inten)))
               (min-inten (min (mapcar #'min inten)))
               )
            (send plot :range 1 min-inten max-inten)
            )
         )
      )
   )
;
(defun regress-obs-fit ()
   (prog*
      (
         (pick-analysis (choose-item-dialog "Select PC analysis:" *regress-names*))
         (analysis (select *regress-vals* pick-analysis))
         (inten (select analysis 4))
         (regress-fitted (select analysis 7))
         (name (select *regress-names* pick-analysis))
         )
      (line-plot (transpose (list inten regress-fitted)) (concatenate 'string
         "Regression Obs vs Fit - " name))
      )
   )
;
(defun display-regress ()
   (let*
      (
         (pick-analysis (choose-item-dialog "Select PC analysis:" *regress-names*))
         (analysis (select *regress-vals* pick-analysis))
         (reg-list (select analysis 1))
         )
      (mapcar #'(lambda (x) (send x :display)) reg-list)
      (mapcar #'(lambda (x) (display-regress-dialog x)) reg-list)
      )
   )
;
(defun inten-covar-slider ()
   (prog*
      (
         (spect-sel (choose-item-dialog "Select spectrum:" *spectra-names*))
         (var-sel (choose-item-dialog "Select covariate:" *covar-names*))
         (freq (select *freq* spect-sel))
         (freq-list (first (transpose freq)))
         (inten (select *inten* spect-sel))
         (var (select *covar-vals* var-sel))
         (data (append (list var) inten))
         (n (length freq-list))
         (seg nil)
         (plot (send graph-proto :new (+ 1 n)))
         )
      (send plot :x-axis T)
      (send plot :y-axis T)
      (send plot :add-points data)
      (send plot :adjust-to-data)
      (send plot :title (num2string (first freq-list)))
      (send plot :linked T)
      (setf seq (sequence-slider-dialog (+ 1 (iseq n))
         :action 
            #'(lambda (x)
               (prog* ()
                  (send plot :current-variables 0 x)
                  (send plot :title (num2string (select freq-list (- x 1))))
                  )
               )
            )
         )
      (send seq :title (concatenate 'string (select *spectra-names* spect-sel)
         ": " (select *covar-names* var-sel) " vs inten"))
      )
   )
;
(defun bld-reg ()
   (prog*
      (
         (info (get-inten-reg-info))
         (spectrum (select info 0))
         (name (select info 1))
         (covariates (select info 2))
         (covars (which covariates))
         (covar-vals (select *covar-vals* covars))
         (covar-names (select *covar-names* covars))
         (inten (select *inten* spectrum))
         (freq (select *freq* spectrum))
         (allspline (map 'list #'myspline (transpose freq) (transpose inten)))
         (trspl (transpose allspline))
         (splfreq (select trspl 0))
         (splinten (select trspl 1))
         (inten-reg
            (send inten-reg-proto :new
               :freq splfreq :inten splinten :covars covar-vals 
               :covar-names covar-names
               :has-coeff-plot (repeat nil (+ (length covars) 1))
               :coeff-plot (repeat nil (+ (length covars) 1))
               )
            )
         )
      (setf *reg-names* (append *reg-names* (list name)))
      (setf *reg-objects* (append *reg-objects* (list inten-reg)))
      (prin1 "finished building regression.")
      (terpri)
      )
   )
;
(defun inten-by-covars ()
   (let*
      (
         (reg-sel nil)
         (reg nil)
         )
      (setf reg-sel (choose-item-dialog "Select regression for analysis." 
         *reg-names*))
      (setf reg (select *reg-objects* reg-sel))
      (send reg :install-plots)
      )
   )