anacor.lsp

language: Lisp
license: GPL 2

Code for Snippet:

                
 
;;;
;;; Contingency table Correspondence analysis proto
;;; -                 -
 
(defproto anacor-dialog-proto nil nil dialog-proto)
 
(defproto cc-proto
   '(x
     row-labels
     col-labels 
     row-name
     col-name
     row-n 
     col-n 
     norm-option
     needs-computing
     fg 
     basicv
     axes-labels ))
 
 
(defmeth cc-proto :needs-computing (&optional (tf nil set))
  (if set (setf (slot-value 'needs-computing) tf))
  (slot-value 'needs-computing))
 
;;;
;;; Computing and display methods
;;;
 
;; First, 2 functions needed in the COMPUTE method
(defun column-sums (x)
  (mapcar #'sum (column-list x)))
(defun row-sums (x)
  (mapcar #'sum (row-list x)))
 
;;The compute method finds the row coordinates in F, the
;;col coordinates in G and then binds them together in FG since
;;row and col coords are plotted on one graph.  
 
(defmeth cc-proto :compute ()
"message args: ()
Computes estimates. For internal use"
 (let* ( (x (send self :x))
         (P (/ x (sum x)))
         (r (row-sums P))
         (c (column-sums P))
         (rc (outer-product r c))
         (S (/ (- P rc) (sqrt rc)))
         (n (send self :row-n))
         (m (send self :col-n))
         (option (send self :norm-option))
         (sv (if (>= n m) (sv-decomp S) 
                          (sv-decomp (transpose S))))
         (M1 (if (>= n m) (first sv) (third sv)))
         (N1 (if (>= n m) (third sv) (first sv)))
         (basicv (second sv))
         (eigen (^ basicv 2))
         (F (case option 
               (0 (matmult (diagonal (/ 1 (sqrt r)))
                           M1 (diagonal basicv)))
               (1 (matmult (diagonal (/ 1 (sqrt r)))
                           M1))
               (2 (matmult (diagonal (/ 1 (sqrt r)))
                           M1 (diagonal (sqrt basicv))))))
         (G (case option
               (0 (matmult (diagonal (/ 1 (sqrt c)))
                           N1))
               (1 (matmult (diagonal (/ 1 (sqrt c)))
                           N1 (diagonal basicv)))
               (2 (matmult (diagonal (/ 1 (sqrt c)))
                           N1 (diagonal (sqrt basicv))))))
         (FG (column-list (bind-rows F G)))
       )
   (setf (slot-value 'basicv) basicv)
   (setf (slot-value 'fg) FG)
   (send self :axes-labels basicv)
   (send self :needs-computing F)
 )
)
 
;;Method to print the inertia of the principal axes
;;
 
(defmeth cc-proto :pr-inertia (&optional (file "anacor.out")
                                         (print T))
"Message args ()
Prints the inertia of the principal axes"
   (let* ( 
          (eigen (^ (send self :slot-value 'basicv) 2))
          (rank (length eigen))
          (total (sum eigen))
          (perc  (* (/ eigen total) 100))
          (cperc (cumsum perc))
          (row-labels (send self :row-labels))
          (col-labels (send self :col-labels))
          (row-name (send self :row-name))
          (col-name (send self :col-name))
          (row-n (send self :row-n))
          (col-n (send self :col-n))
          (fg (row-list (apply #'bind-columns (send self :slot-value 'fg))))
          (ndim (length (first fg)))
          (len (floor (/ ndim 5)))
          (nax (iseq 1 rank)) )
(when print 
   (format t "~%          CORRESPONDENCE ANALYSIS~%")
   (format t "~% Decomposition of total inertia along principal axes~%~%")
   (format t "AXES   INERTIA (eigenvalues)  %of INERTIA    Cum %~%")
   (dotimes (i rank)
        (format t "~3d     ~10g            ~10g     ~10g~%"
                     (select nax i)
                     (select eigen i)
                     (select perc i)
                     (select cperc i)))
   (format t "~%Total  ~10g~%~%" total)
 
;;  Screen Row Output
   (format t "~%Variable: ~a~%" row-name)
   (dolist (i (iseq 0 (if (and (not (= len 0)) (= (mod ndim 5) 0))
                          (1- len) len)))
    (dolist (j (iseq (* i 5) (min (1- ndim) (+ 4 (* i 5)))))
      (format t "Dim: ~a       " (1+ j)))
    (format t "~%~a" (make-string (* 13 5) :initial-element #\=))
    (dolist (j (iseq row-n))
      (format t "~%")
      (mapcar #'(lambda (x) (format t "~7,4f      " x))
        (coerce (select (elt fg j) (iseq (* i 5) (min (1- ndim) (+ 4 (* i 5)))))
                         'list)))
    (format t "~%~%"))
;;  Screen Column Output
 
   (format t "~%~%Variable: ~a~%" col-name)
   (dolist (i (iseq 0 (if (and (not (= len 0)) (= (mod ndim 5) 0))
                          (1- len) len)))
    (dolist (j (iseq (* i 5) (min (1- ndim) (+ 4 (* i 5)))))
      (format t "Dim: ~a       " (1+ j)))
    (format t "~%~a" (make-string (* 13 5) :initial-element #\=))
    (dolist (j (iseq row-n (1- (+ row-n col-n))))
      (format t "~%")
      (mapcar #'(lambda (x) (format t "~7,4f      " x))
        (coerce (select (elt fg j) (iseq (* i 5) (min (1- ndim) (+ 4 (* i 5)))))
                         'list)))
    (format t "~%~%"))
)
(when file
   (with-open-file (outfile file :direction :output)
   (format outfile "~%          CORRESPONDENCE ANALYSIS~%")
   (format outfile "~% Decomposition of total inertia along principal axes~%~%")
   (format outfile "AXES   INERTIA (eigenvalues)  %of INERTIA    Cum %~%")
   (dotimes (i rank)
        (format outfile "~3d     ~10g            ~10g     ~10g~%"
                     (select nax i)
                     (select eigen i)
                     (select perc i)
                     (select cperc i)))
   (format outfile "~%Total  ~10g~%~%" total)
 
 
;;  Outfile Row Output
   (format outfile "~%~%Variable: ~a~%" row-name)
   (dolist (i (iseq 0 (if (and (not (= len 0)) (= (mod ndim 5) 0))
                          (1- len) len)))
    (dolist (j (iseq (* i 5) (min (1- ndim) (+ 4 (* i 5)))))
      (format outfile "Dim: ~a       " (1+ j)))
    (format outfile "~%~a" (make-string (* 13 5) :initial-element #\=))
    (dolist (j (iseq row-n))
      (format outfile "~%")
      (mapcar #'(lambda (x) (format outfile "~7,4f      " x))
       (coerce (select (elt fg j) (iseq (* i 5) (min (1- ndim) (+ 4 (* i 5)))))
                         'list)))
    (format outfile "~%~%"))
 
 
;;  Outfile Column Output
   (format outfile "~%~%Variable: ~a~%" col-name)
   (dolist (i (iseq 0 (if (and (not (= len 0)) (= (mod ndim 5) 0))
                          (1- len) len)))
    (dolist (j (iseq (* i 5) (min (1- ndim) (+ 4 (* i 5)))))
      (format outfile "Dim: ~a       " (1+ j)))
    (format outfile "~%~a" (make-string (* 13 5) :initial-element #\=))
    (dolist (j (iseq row-n (1- (+ row-n col-n))))
      (format outfile "~%")
      (mapcar #'(lambda (x) (format outfile "~7,4f      " x))
       (coerce (select (elt fg j) (iseq (* i 5) (min (1- ndim) (+ 4 (* i 5)))))
                         'list))) 
    (format outfile "~%~%")))
    (format t "~%Done Writing To File~%"))
(format t "~%Computations Complete~%")))
 
 
;;;
;;; Slot accessors and mutators
;;;
(defmacro normal-accessor (key slot prototype)
`(defmeth ,prototype ,key (&optional (content nil set))
   (when set (setf (slot-value ',slot) content))
   (slot-value ',slot)))
 
(normal-accessor :row-name row-name cc-proto)
(normal-accessor :col-name col-name cc-proto)
(normal-accessor :row-labels row-labels cc-proto)
(normal-accessor :col-labels col-labels cc-proto)
(normal-accessor :norm-option norm-option cc-proto)
 
 
 
(defmeth cc-proto :x (&optional new-x)
"Message args: (&optional new-x)
With no argument returns the x matrix. With an argument
NEW-X sets the x matrix to NEW-X, recomputes" 
 (when (and new-x (matrixp new-x))
       (setf (slot-value 'x) new-x)
       (send self :needs-computing t))
 (slot-value 'x))
 
(defmeth cc-proto :row-n (&optional (n nil set))
"Message args: (&optional row-n)
With no argument returns the # of rows in X. With an 
argument sets it." 
  (if set (setf (slot-value 'row-n) n))
  (slot-value 'row-n) )
 
(defmeth cc-proto :col-n (&optional (n nil set))
"Message args: (&optional col-n)
With no argument returns the # of cols in X. With an 
argument sets it." 
  (if set (setf (slot-value 'col-n) n))
  (slot-value 'col-n) )
 
(defmeth cc-proto :axes-labels 
                    (&optional (basicv nil set))
"Message args: (&optional basic-values)
With no argument returns all possible axes labels. With an 
argument sets it. The basic values are used to compute the 
% of inertia explained, which is used in each label."
  (when set 
     (let* ( (eigen (^ basicv 2))
             (perc (round (* (/ eigen (sum eigen)) 100)))
             (axes (iseq (length basicv))) 
             (labs
                (mapcar #'(lambda (ax p)
                     (format nil "Ax~s ~s%" ax p))
                 axes  (coerce perc 'list)))
           )        
        (setf (slot-value 'axes-labels) labs)
   )  )
  (slot-value 'axes-labels))
 
;;;
;;; The method for making 3-D plots is given below.
;;;
 
(defproto cc-3dplot-proto '(axes-labels cc-object) () spin-proto)
 
(defmeth cc-proto :plot-3d (&optional 
                              (axes '(0 1 2)))
"Message args: (&optional axes)
Opens a window with a spin-plot of the supplied axes or, by
default, the 1st 3 axes. The plot can (and should!) be linked 
to other plots including the plot-2d plot using the menu. 
Returns a plot object"
  (if (send self :needs-computing) (send self :compute))
  (let* ( (fg (send self :slot-value 'fg))
          (n (send self :row-n))
          (m (send self :col-n))
          (rlab (send self :row-labels))
          (clab (send self :col-labels))
          (xvar (select fg (first axes)))
          (yvar (select fg (second axes)))
          (zvar (select fg (third axes)))
          (fact (max (max xvar) (abs (min xvar))
                     (max yvar) (abs (min yvar))
                     (max zvar) (abs (min zvar))))
          (xvar (/ xvar fact))
          (yvar (/ yvar fact))
          (zvar (/ zvar fact))
          (titl (format nil "Plot ~s" (1+ axes)))
          (v-labs (mapcar #'(lambda (i)
                                 (format nil "~s" i)) (1+ axes)))
          (p (send cc-3dplot-proto :new 3 :title titl
                                    :variable-labels v-labs :scale nil)))
   (send p :cc-object self)
   (send p :add-points (list xvar yvar zvar))
   (send p :point-label (iseq (+ n m)) (append rlab clab))
   p
 )
)
 
 
(defmeth cc-3dplot-proto :show-cols ()
"Message args ()
Sets the points selected to the ones corresponding to the
columns"
  (let* ( (cc (send self :cc-object))
          (n (send cc :row-n))
          (m (send cc :col-n))
          (col-indexes (iseq n (+ n m -1))) )
     (send self :showing-labels T)
     (send self :point-selected col-indexes T)
))
 
 
(defmeth cc-3dplot-proto :show-rows ()
"Message args ()
Sets the points selected to the ones corresponding to the
rows"
  (let* ( (cc (send self :cc-object))
          (n (send cc :row-n))
          (row-indexes (iseq n)) )
     (send self :showing-labels T)
     (send self :point-selected row-indexes T)
))
 
(defmeth cc-3dplot-proto :menu-template ()
  (flet ( (action1 () (send self :show-cols))
          (action2 () (send self :show-rows)) )
    (let ( (item1 (send menu-item-proto 
                    :new "Col labels"
                    :action #'action1))
           (item2 (send menu-item-proto
                    :new "Row labels"
                    :action #'action2))
           (dash (send dash-item-proto :new)) )
      (append (call-next-method) (list dash item1 item2)))))
 
(defmeth cc-3dplot-proto :cc-object
                        (&optional (cc nil set))
"Message args: (&optional cc-object)
With no argument, returns the cc-proto object that initiated
the 2-d plot. When supplied with such an object, sets it."
  (when set (setf (slot-value 'cc-object) cc))
  (slot-value 'cc-object)) 
 
 
(defmeth cc-3dplot-proto :axes-labels 
                        (&optional (labs nil set))
"Message args: (&optional axes-labels)
    where axes-labels is a list of 2 strings.
With no argument, returns the axes-labels, else sets it."
  (when set (setf (slot-value 'axes-labels) labs))
  (slot-value 'axes-labels)) 
 
 
;;;
;;;
;;; The method for making 2-D plots is given below. It uses 
;;; a plot proto cc-2dplot-proto that is defined below.
;;;
 
(defmeth cc-proto :plot-2d (&optional 
                              (axes '(0 1)))
"Message args: (&optional axes)
Opens a window with a 2-d plot of the supplied axes or, by
default, the 1st 2 axes. The plot can (and should!) be linked 
to other plots including the plot-3d plot using the menu. 
Returns a plot object"
  (if (send self :needs-computing) (send self :compute))
  (let* ( 
     (fg (send self :slot-value 'fg))
     (n (send self :row-n))
     (m (send self :col-n))
     (rlab (send self :row-labels))
     (clab (send self :col-labels))
     (xvar (select fg (first axes)))
     (yvar (select fg (second axes)))
     (dely (* 0.1 (- (max yvar) (min yvar))))
     (delx (* 0.1 (- (max xvar) (min xvar))))
     (ymind (- (min yvar) dely) )
     (ymaxd (+ (max yvar) dely) )
     (xmind (- (min xvar) delx) )
     (xmaxd (+ (max xvar) delx) )
     (titl (format nil "Plot ~s" axes))
     (p (send cc-2dplot-proto :new 2 :title titl))
  )
    (send p :cc-object self)
    (send p :add-lines (list (list xmind xmaxd 0 0)
                             (list 0 0 ymind ymaxd)) 
            :draw nil)
    (send p :linestart-next 1 nil)
    (send p :label-axes 
              (select (send self :axes-labels) (1+ axes)))
    (send p :add-points (list xvar yvar)
            :point-labels (append rlab clab))
    (send p :point-symbol (iseq n (+ n m -1)) 'x)
    (send p :adjust-to-data)
;    (send p :scale-type 'fixed)
    p
 )
)
 
;;;
;;; The cc-2dplot-proto inherits from the graph-proto
;;; and is used in the :plot-2d method of cc-proto. It
;;; was necessary to make this proto since the 2-d plot
;;; has axes and labels in non-standard places. This meant,
;;; most importantly, a new redraw-content method.
;;;
 
 
(defproto cc-2dplot-proto '(axes-labels
                            cc-object)                      
   () scatterplot-proto)
 
 
(defmeth cc-2dplot-proto :redraw-content ()
   (let ((labels (send self :axes-labels)))
     (send self :start-buffering)
     (call-next-method)  
     (if labels (send self :label-axes labels))
     (send self :buffer-to-screen)
  ))
 
;;;
;;; A method to label the axes.
;;;
 
(defmeth cc-2dplot-proto :label-axes (labels)
"Message args: labels 
          where labels is a list of 2 labels.
The method draws this text on the graph near the axes"
  (let* ( (labx (first labels))
          (laby (second labels))
          (nulnul (send self :real-to-canvas 0 0))
        )
    (send self :draw-text laby (first nulnul) 12 1 0)
    (send self :draw-text-up labx 
                              12 (second nulnul) 1 0)
    (send self :axes-labels labels)
 )
)
 
;;;
;;; Methods to put row, column labels on the plot. The cc-object 
;;; is needed to get access to the # of rows and columns.
;;; 
 
(defmeth cc-2dplot-proto :show-cols ()
"Message args ()
Sets the points selected to the ones corresponding to the 
columns"
  (let* ( (cc (send self :cc-object))
          (n (send cc :row-n))
          (m (send cc :col-n))
          (col-indexes (iseq n (+ n m -1))) )
     (send self :showing-labels T)
     (send self :point-selected col-indexes T)
))
 
(defmeth cc-2dplot-proto :show-rows ()
"Message args ()
Sets the points selected to the ones corresponding to the 
rows"
  (let* ( (cc (send self :cc-object))
          (n (send cc :row-n))
          (row-indexes (iseq n)) )
     (send self :showing-labels T)
     (send self :point-selected row-indexes T)
))
 
;;;
;;; The option to show row and/or column labels is added to
;;; the standard menu through the :menu-template method.
;;; (No provision is made to turn them off as that is 
;;; automatically done by clicking on the plot.)
;;;
 
(defmeth cc-2dplot-proto :menu-template ()
  (flet ( (action1 () (send self :show-cols))
          (action2 () (send self :show-rows)) )
    (let ( (item1 (send menu-item-proto 
                    :new "Col labels"
                    :action #'action1))
           (item2 (send menu-item-proto
                    :new "Row labels"
                    :action #'action2))
           (dash (send dash-item-proto :new)) )
      (append (call-next-method) (list dash item1 item2)))))
 
;;;
;;; Accessor and mutation methods for the cc-2dplot-proto
;;;
 
(defmeth cc-2dplot-proto :cc-object
                        (&optional (cc nil set))
"Message args: (&optional cc-object)
With no argument, returns the cc-proto object that initiated
the 2-d plot. When supplied with such an object, sets it."
  (when set (setf (slot-value 'cc-object) cc))
  (slot-value 'cc-object)) 
 
 
(defmeth cc-2dplot-proto :axes-labels 
                        (&optional (labs nil set))
"Message args: (&optional axes-labels)
    where axes-labels is a list of 2 strings.
With no argument, returns the axes-labels, else sets it."
  (when set (setf (slot-value 'axes-labels) labs))
  (slot-value 'axes-labels)) 
 
 
(defun to-string-list (l)
  "Args: l
Converts L to a list of strings."
  (mapcar #'(lambda (x) (format nil "~a" x)) l)
  )
 
 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  New Stuff
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
(defproto cc-1-dim-proto '(name-rows name-columns cc-object myfg)
   () graph-proto)
 
(defmeth cc-1-dim-proto :redraw-content ()
   (let* (
          (cc (send p :cc-object))
          (name-cols (send cc :name-cols))
          (name-rows (send cc :name-rows))
          (x (send cc :x))
          (fg (send self :slot-value 'myfg))
         )
     (when (slot-value 'myfg)
           (send self :start-buffering)
           (call-next-method)
 
           (if labels (send self :label-axes labels))
           (send self :buffer-to-screen))
))
 
 
 
(defmeth cc-proto :plot-1d (&optional
                              (axis 0))
"Message args: (&optional axes)
Opens a window with a 1-d plot."
  (if (send self :needs-computing) (send self :compute))
  (let* (
         (fg (send self :slot-value 'fg))
         (n (send self :row-n))
         (m (send self :col-n))
         (xvar (select fg axis))
         (x (send self :x))  
         (titl (format nil "Plot ~s" axis))
         (p (send cc-2dplot-proto :new 2 :title titl))
         (x1 (select xvar (iseq n)))
         (x2 (select xvar (iseq n) (1- (+ m n))))
         (x1min (min x1))
         (x1max (max x1))
         (x2min (min x2))
         (x2max (max x2))
        )
    (send p :cc-object self)
    (send p :myfg xvar)
    (send p :variable-label 0 (send self :row-name))
    (send p :variable-label 1 (send self :col-name))
    (send p :x-axis t t 5)
    (send p :y-axis t t 5)
    (send p :range 0 x1min x1max)
    (send p :range 1 x2min x2max)
    (send p :scale-type 'fixed)
    (send p :redraw-content)
    p))
 
 
 
 
(defun get-dimension-dialog (n)
  (let* (
         (ask (send text-item-proto :new "Enter Dimensions Desired"))
         (ask-dims (mapcar #'(lambda (x) 
             (send text-item-proto :new (format nil "~a" x))) (iseq 1 n)))
         (get-dims (mapcar #'(lambda (x)
             (send edit-text-item-proto :new "" :text-length 4)) (iseq n)))
         (ok (send modal-button-proto :new "Ok" 
                   :action #'(lambda () 
                       (mapcar #'(lambda (x) 
                         (1- (read-from-string (send x :text)))) get-dims))))
         (dialog (send modal-dialog-proto :new (cons ask 
                     (append (transpose (list ask-dims get-dims)) (list ok)))))
        )
    (send dialog :modal-dialog)))
 
 
(defun anacor-dialog ()
  (let* (
         (anacor-obs (send cc-proto :new))
         (ask-plot (send text-item-proto :new "Choose a Plot:"))
         (plot-item (send choice-item-proto :new
                    (list "2-D Solution Plot" "3-D Solution Plot")))
         (plot-get (send button-item-proto :new "Plot"
               :action #'(lambda ()
                 (case (send plot-item :value)
                   (0 (send anacor-obs :plot-2d (get-dimension-dialog 2)))
                   (1 (send anacor-obs :plot-3d (get-dimension-dialog 3)))))))
         (ask-option (send text-item-proto :new "Normalization Option:"))
         (get-option (send choice-item-proto :new 
                    (list "Columns" "Rows" "Both")))
 
         (ask-var-name (send text-item-proto :new
                        "[Optional] Variable Names Filename:"))
         (show-var-file (send edit-text-item-proto :new "" :text-length 20))
         (ask-rows (send text-item-proto :new
                        "[Optional] Row Category Names Filename:"))
         (show-rows-file (send edit-text-item-proto :new "" :text-length 20))
         (ask-cols (send text-item-proto :new
                        "[Optional] Column Category Names Filename:"))
         (show-cols-file (send edit-text-item-proto :new "" :text-length 20))
 
         (get-files (send button-item-proto :new "Get/Remove Files"
                        :action #'(lambda ()
                  (let ((var-name-file
                            (if (> (length (send show-var-file :text)) 0)
                                (send show-var-file :text)))
                        (rows-name-file
                            (if (> (length (send show-rows-file :text)) 0)
                                (send show-rows-file :text)))
                        (cols-name-file
                            (if (> (length (send show-cols-file :text)) 0)
                                (send show-cols-file :text))))
                       (if var-name-file
                           (let ((names (first 
                                   (read-data-columns var-name-file))))
                             (send anacor-obs :row-name 
                                 (format nil "~a" (first names)))
                             (send anacor-obs :col-name 
                                 (format nil "~a" (second names))))
                           (progn (send anacor-obs :row-name "R")
                                  (send anacor-obs :col-name "C")))
                       (if rows-name-file
                           (let ((names (read-data-columns rows-name-file)))
                             (send anacor-obs :row-labels 
                               (to-string-list (combine names))))
                             (send anacor-obs :row-labels
                              (mapcar #'(lambda (x) (format nil "R~a" x))
                                 (iseq 1 (array-dimension 
                                         (send anacor-obs :x) 0)))))
                       (if cols-name-file
                           (let ((names (read-data-columns cols-name-file)))
                             (send anacor-obs :col-labels 
                               (to-string-list (combine names))))
                             (send anacor-obs :col-labels
                              (mapcar #'(lambda (x) (format nil "C~a" x))
                                 (iseq 1 (array-dimension 
                                         (send anacor-obs :x) 1)))))))))
 
         (tell-data-file (send text-item-proto :new "Data Filename: "))
         (show-data-file (send edit-text-item-proto :new "" :text-length 20))
         (get-data-file (send button-item-proto :new "Load Data File"
                    :action #'(lambda ()
                     (let* ((file (send show-data-file :text))
                            (data (if (> (length file) 0)
                                         (read-data-columns file))))
                        (when data
                         (send anacor-obs :x (apply #'bind-columns data))
                         (send anacor-obs :row-n (length (elt data 0)))
                         (send anacor-obs :col-n (length data)))
                     (send get-files :do-action)))))
 
         (tell-output-file (send text-item-proto :new
                     "[Optional] Output Filename: "))
         (show-output-file (send edit-text-item-proto :new "" :text-length 20))
 
         (seperator1 (send text-item-proto :new
                "___________________________________________________________"))
         (seperator2 (send text-item-proto :new
                "___________________________________________________________"))
         (print-get (send toggle-item-proto :new "Print output to Screen"))
         (compute-button (send button-item-proto :new "Compute"
                :action #'(lambda ()
                  (let (
                        (output-file
                           (if (> (length (send show-output-file :text)) 0)
                               (send show-output-file :text)))
                       )
                    (send anacor-obs :norm-option (send get-option :value))
                    (send anacor-obs :compute)
                    (send anacor-obs :pr-inertia output-file
                                     (send print-get :value))))))
        )
(send anacor-dialog-proto :new (list (list ask-plot plot-item) plot-get)
                   :location
#+unix (list 700 50)
#-unix (list 300 50)
                   :title "Plot Dialog")
 
(send dialog-proto :new (list (list tell-data-file show-data-file)
                              (list get-data-file)
                              (list seperator1)
                              (list ask-rows show-rows-file)
                              (list ask-cols show-cols-file)
                              (list ask-var-name show-var-file)
                              (list get-files)
                              (list seperator2)
                              (list tell-output-file show-output-file)
                              (list ask-option get-option)
                              (list print-get)
                              (list compute-button))
                   :location
#+unix (list 50 50)
#-unix (list 50 50)
                   :title "Anacor Dialog")))
 
(defmeth anacor-dialog-proto :close ()
(exit))
 
(anacor-dialog)
 
 
 
 
comments powered by Disqus

Info

Link to this snippet:


Download to Code Collector

To use the direct link to your snippet on CodeCollector.net either copy the html from the above section or drag the Download to Code Collector to where you would like to use it.

More Info:

Times Viewed: 605
Date Added: 2013-03-07 20:22:59
Last Modified: 2013-04-17 22:12:19

Web Analytics