;;########################################################################
;; dissobj.lsp
;; Copyright (c) 1991-95 by Forrest W. Young
;; This file contains code to implement dissimilarity data objects.
;;########################################################################

(require "vista")

;;########################################################################
;;define prototype dissimilarity data object and it's isnew method
;;prototype inherits from multivariate data-object prototype
;;########################################################################

#|The following function appears in dataobj2.lsp
(defproto diss-data-object-proto 
  '(enames mshapes nmat nele mat-window mat-window-object mat-states) 
  () mv-data-object-proto)|#

(defmeth diss-data-object-proto :isnew 
  (data variables title labels types matrices shapes element-labels name)
  (let* ((nmat (length matrices))
         (nele (^ (length variables) 2))
         )
    (when (send self :initialize-object data variables title labels types name)
          (send self :data 
                (combine (transpose (matrix (list nmat nele) data))))                     
          (send self :nmat nmat)
          (send self :nele nele)
          (send self :matrices  matrices)
          (send self :mat-window nil)
          (send self :mat-states (repeat 'NORMAL nmat))
          (if shapes (send self :shapes shapes)
             (send self :shapes 
             (mapcar #'(lambda (x) (format nil "Symmetric" x)) (iseq nmat))))
          (send self :element-labels
             (if element-labels element-labels
                (mapcar #'(lambda (x) (format nil "Elem~a" x)) (iseq nele))))
          (send self :labels
                (if labels labels (repeat variables nmat)))
          )))

;;--------------------------------------------------------------------------
;;define slot-accessor methods for the dissimilarity data-object
;;--------------------------------------------------------------------------

(defmeth diss-data-object-proto :nmat (&optional (number nil set))
  (if set (setf (slot-value 'nmat) number))
  (slot-value 'nmat))

(defmeth diss-data-object-proto :nele (&optional (number nil set))
  (if set (setf (slot-value 'nele) number))
  (slot-value 'nele))

(defmeth diss-data-object-proto :mat-window (&optional (logical nil set))
  (if set (setf (slot-value 'mat-window) logical))
  (slot-value 'mat-window))

(defmeth diss-data-object-proto :mat-window-object (&optional (object nil set))
  (if set (setf (slot-value 'mat-window-object) object))
  (slot-value 'mat-window-object))

(defmeth diss-data-object-proto :mat-states (&optional (list nil set))
"Message args: (&optional list)
 Sets or retrieves the selection states of the matrices in the dissimilarity
 data object. States mimic point selection states (normal, selected, invisible)." 
  (if set (setf (slot-value 'mat-states) list))
  (slot-value 'mat-states))

(defmeth diss-data-object-proto :shapes  (&optional (names nil set))
  (if set (setf (slot-value 'mshapes) names))
  (slot-value 'mshapes))

(defmeth diss-data-object-proto :active-shapes (ok-types)
  (select (send self :shapes) (send self :current-matrices ok-types)))

(defmeth diss-data-object-proto :active-matrices (ok-types)
"Message args: (&optional strings)
Sets or retrieves the names of active ok-type matrices in dissimilarity data.
An active matrix is one which is selected in the mat-window, or if none 
selected, which is visible in the window.  Ok-types must be one of the 
following strings: all, symmetric, asymmetric, rectangular."
  (select (send self :matrices) (send self :current-matrices ok-types)))

(defmeth diss-data-object-proto :element-labels (&optional (names nil set))
  (if set (setf (slot-value 'enames) names))
  (slot-value 'enames))

(defmeth diss-data-object-proto :active-data (ok-types)
    (combine (send self :active-data-matrix ok-types)))

(defmeth diss-data-object-proto :active-data-matrix (ok-types)
"Message args: (ok-types)
Reports, for ok-types variables which are active, the dissimilarity data in multivariate matrix form. An active variable is one which is selected in the 
var-window, or if none selected, which is visible in the window.  Ok-types 
must be one of the following strings: all, numeric, ordinal, category, label."
  (select (send self :data-matrix) (iseq (send self :nele))
       (send self :current-matrices ok-types)))

(defmeth diss-data-object-proto :data-matrix ()
"Message args: none
Returns the dissimilarity data as a matrix in internally stored multivariate format."
  (let* ((n (send self :nmat))
         (m (send self :nele)))
         (matrix (list m n) (send self :data))))

(defmeth diss-data-object-proto :get-matrix (k)
"Message arg: (matrix-number)
Requires an integer denoting the position of the dissimilarity data matrix
in the data-list. Returns the matrix in dissimilarity form."
  (let ((nvar (send self :nvar))
        (nele (send self :nele))
        (nmat (send self :nmat))
        )
    (matrix (list nvar nvar) 
            (combine (col (matrix (list nele nmat) (send self :data)) k)))
    ))

(defmeth diss-data-object-proto :get-matrices (q)
"Message arg: (matrix-number-list)
Reguires a list of integers denoting the positions of the dissimilarity
data matrices in the data-list.  Returns the matrices in dissimilarity form."
  (let ((request (repeat "g" (length q))))
       (dotimes (i (length q))
         (setf (select request i) (send self :get-matrix (select q i))))   
         request))

(defmeth diss-data-object-proto :active-labels ()
"Message args: none
Reports the labels (names) of the active variables (rows and columns of a matrix).  Active variables are those which are selected in the var-window, or if none are selected, which are visible in the window."
  (send self :active-variables '(all)))

(defmeth diss-data-object-proto :get-active-matrix (k ok-var-types)
"Message arg: (matrix-number ok-var-types)
Requires an integer denoting the position of the dissimilarity data matrix
in the data-list and a list of ok-type variables. Returns a matrix containng the rows and columns of matrix k that correspond to the active ok-var-type variables."
  (let ((current-vars (send self :current-variables ok-var-types)))
    (select (send self :get-matrix k) current-vars current-vars) ))

(defmeth diss-data-object-proto :get-active-data-matrices ()
"Message args: none
Returns a list of dissimilarity matrices (in dissimilarity form) consisting of the active matrices, where each returned matrix contains only the active numeric rows and columns of each data matrix."
  (let* ((q (send self :current-matrices '(symmetric asymmetric)))
         (nmat (length q))
         (request (iseq nmat)))
    (dotimes (i nmat)
             (setf (select request i) 
                   (send self :get-active-matrix (select q i) '(numeric))))  
         request))

;;-------------------------------------------------------------------------
;;define menu methods for the dissimilarity data-object
;;-------------------------------------------------------------------------


(defmeth diss-data-object-proto :create-data (&optional name) 
"Message args: (&optional name)
Creates a new data object from the current active data.  The data object is
named NAME (a string) if specified, otherwise a dialog is presented for name.
Only the active symmetric or asymmetric matrices are used, and only the active numeric variables in each active matrix are used. Returns the object identification of the new data object."
  (if (not (eq current-data self)) (setcd self))
  (setf merge-dob nil)
  (let ((menu-name nil)
        (data (send self :active-data '(all)))
        (matrices (send self :active-matrices '(all))))
    (if name
        (setf menu-name name)
        (setf menu-name (get-string-dialog "Name of the New Data Object:"
                                           :initial "Unnamed")))
    (cond 
      (menu-name 
       (data menu-name
             :created (send *workmap* :selected-icon)
             :matrices matrices
             :shapes  (send self :active-shapes '(symmetric asymmetric))
             :title   (concatenate 'string "Created from "(send self :title))
             :data    (combine (send self :get-active-data-matrices))
             :variables (send self :active-variables '(numeric))
             :labels  (send self :active-labels)
             :types   (send self :active-types '(numeric))
             )))))

(defmeth diss-data-object-proto :visualize (&key dialog) 
  (if (not (eq current-data self)) (setcd self))
  (error-message "Visualization not supported for dissimilarity data. Instead, you can perform a Multidimensional Scaling, and then visualize the MDS model of the data.")
  t)

(defmeth diss-data-object-proto :report()
"Method Args: none
Presents a numeric listing of the data."
  (if (not (eq current-data self)) (setcd self))
  (send self :print-diss-data))

(defmeth diss-data-object-proto :print-diss-data ()
  (let* ((data (send self :data))
         (nmat (send self :nmat))
         (nvar (send self :nvar))
         (matnames (send self :active-matrices '(all)))
         (variables (send self :variables))
         (w nil)
         )
    (setf w (report-header (strcat (send self :name) " Data Listing")))
    (display-string (format nil "Title: ~a" (send self :title)) w)
    (display-string
        (format nil "~2%Data:  ~a~2%" (send self :name)) w)
    (display-string
        (format nil "Variable Names: ~a~2%" variables) w)
    (display-string
        (format nil "Variable Types: ~a~2%" (send self :types)) w)
    (display-string
        (format nil "Matrix Names:   ~a~2%" matnames) w)
    (display-string
        (format nil "Matrix Shapes:  ~a~2%" 
                (send self :active-shapes '(all))) w)
    (display-string (format nil "Data Matrices: ~%") w)
    (let ((j 0))
      (dolist (i (send self :current-matrices '(all)))      
              (display-string (format nil "~%~a~%" (select matnames j)) w)
              (print-matrix-to-window (send self :get-matrix i) w
                                      :labels variables)
              (setf j (+ j 1))))
    w))
 
(defmeth diss-data-object-proto :current-matrices (ok-shapes)
"Args: (list) 
Takes a list of matrix shapes and returns a list of indices
of the matrices of those shapes which are also visible (if any
matrices are selected, visible AND selected) in the variables window.
Shapes can be Symmetric, Asymmetric or Rectangular, or All 
(which means select all shapes of matrices)."
  (let* ((nmat (send self :nmat))
         (states (send self :mat-states))
         (selected-matrices 
          (which (mapcar #'equal (repeat 'SELECTED nmat) states)))
         (shapes  (send self :shapes))
         (rectangular-matrices ())
         (symmetric-matrices ())
         (asymmetric-matrices ())
         )
    (setf shapes (mapcar #'string-downcase shapes))
    (if (member 'rectangular ok-shapes) 
        (setf rectangular-matrices 
         (which (mapcar #'equal (repeat '"rectangular" nmat) 
                        shapes))))
    (if (member 'symmetric ok-shapes) 
        (setf symmetric-matrices 
         (which (mapcar #'equal (repeat '"symmetric" nmat) 
                        shapes))))
    (if (member 'asymmetric ok-shapes) 
        (setf asymmetric-matrices 
         (which (mapcar #'equal (repeat '"asymmetric" nmat) 
                        shapes))))
    (if (member 'all ok-shapes)
        (setf symmetric-matrices (iseq nmat)))
    (if (equal selected-matrices nil) 
        (setf selected-matrices
             (which (mapcar #'not (mapcar #'equal 
                    (repeat 'INVISIBLE nmat) states)))))
    (setf selected-matrices 
        (intersection selected-matrices 
           (union rectangular-matrices  
                  (union symmetric-matrices asymmetric-matrices))))
    (if selected-matrices (sort-data selected-matrices)
        nil)))

(defmeth diss-data-object-proto :save-data-template (f)
  (unwind-protect
   (print 
    `(data ,(send self :name)
           :title      ,(send self :title)
           :about      ,(send self :about)
           :variables ',(send self :active-variables '(numeric))
           :types     ',(send self :active-types '(numeric))
           :labels    ',(send self :active-labels)
           :matrices  ',(send self :active-matrices '(all))
           :shapes    ',(send self :active-shapes '(all))
           :data      ',(combine (send self :get-active-data-matrices))
           :datasheet-arguments ',(send self :datasheet-arguments))
    f)))

(defmeth diss-data-object-proto :active-nmat (ok-shapes)
"Args: (list)
Takes a list of matrix shapes and returns the number of active matrices of that shape."
  (length (send self :current-matrices ok-shapes)))

(defun merge-matrices (&optional name) 
  (send current-data :merge-matrices name))

(defmeth diss-data-object-proto :merge-matrices (&optional name)
(if (not (eq current-object self)) (setcd self))
  (let ((object nil)
        (prev-data-icon (send previous-data :icon-number))
        (menu-name nil)
        )
    (cond 
      ((/= (send self :active-nvar '(all)) 
           (send previous-data :active-nvar '(all)))
           (error-message "Data Matrices cannot be merged because they do not have the same number of columns."))
      (t
       (if name
           (setf menu-name name)
           (setf menu-name 
                 (get-string-dialog "Please Name the Created Data Matrix:"
                                    :initial "Unnamed")))
       (cond 
         (menu-name 
          (setf object 
                (data menu-name
                      :title (strcat "Merger of " (send self :title)
                             " with " (send previous-data :title))
                      :created (send *workmap* :selected-icon)  
                      :variables (send self :active-variables '(all))
                      :types (send self :active-types '(all))
                      :labels (send self :active-variables '(all))
                      :matrices 
                      (combine (send self :active-matrices'(all)) 
                               (send previous-data :active-matrices '(all)))
                      :shapes 
                      (combine (send self :active-shapes '(all))
                               (send previous-data :active-shapes '(all)))
                      :data 
                      (combine 
                       (send self :get-active-data-matrices)
                       (send previous-data :get-active-data-matrices))))
          (send *workmap* :connect-icons 
                (- prev-data-icon 1) 
                (- (send *workmap* :num-icons) 1) :new t)
          (send object :dob-parents (add-element-to-list 
                 (send object :dob-parents) previous-data))
          (send previous-data :dob-children (add-element-to-list 
                 (send previous-data :dob-children) object))
         ))))
    object))

;added next method fwy4.25
(defmeth diss-data-object-proto :select-matrices (mat-name-list)
"Args: MAT-NAME-LIST
Selects the matrices in MAT-NAME-LIST from the list of matrix names.  Displays the selection in the mats window when it is open."
  (if (not (eq current-data self)) (setcd self))
  (let* ((w (send *vista* :mat-window-object))
         (mat-num-list ($position mat-name-list (send self :matrices)))
         (states (repeat 'NORMAL (send self :nmat)))
         )
    (cond 
      (w (send w :selection mat-num-list)
         (send self :mat-states 
               (send w :point-state (iseq (send w :num-points)))))
      (t (setf (select states mat-num-list)
                     (repeat 'SELECTED (length mat-num-list)))
         (send self :mat-states states)))))

;;constructor function for dissimilarity (matrix) data

(defun matrix-data (data variables title labels types matrices shapes
                         element-labels name)
  (send diss-data-object-proto :new
      data variables title labels types matrices shapes element-labels name))