(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "DATASETS" ( USE "LISP" "PT") ( NICKNAMES "DS"
) ( PREFIX-NAME "DS")))
(il:filecreated " 8-Jan-89 19:00:08" il:{qv}<idl>next>datasets.\;25 9875
il:|changes| il:|to:| (il:functions get-cell define-case-by-variate-dataset make-table cv-matrix get-batch print-case-by-variate make-case-by-variate add-batch)
(il:structures table case-by-variate) (il:vars il:datasetscoms)
il:|previous| il:|date:| " 8-Jan-89 18:57:52" il:{qv}<idl>next>datasets.\;24)
; Copyright (c) 1988, 1989 by Xerox Corporation. All rights reserved.
(il:prettycomprint il:datasetscoms)
(il:rpaqq il:datasetscoms ((il:define-types datasets) (il:structures dataset) (il:coms (il:* il:|;;| "case by variate layout") (il:structures case-by-variate) (il:functions print-case-by-variate) (il:functions make-case-by-variate) (il:functions get-batch add-batch) (il:functions with-cv-batches with-cv-batch-vectors) (il:functions subset-cv cv-matrix) (il:functions define-case-by-variate-dataset)) (il:coms (il:* il:|;;| "Tables") (il:structures table) (il:functions make-table) (il:functions get-cell)) (eval-when (load compile) (il:p (export (quote (n p)) (find-package "DATASETS")))) (xcl:file-environments "DATASETS")))
(xcl:def-define-type datasets "IDL dataset(s)")
(defstruct (dataset (:constructor nil) (:copier nil)) documentation p-list)
(il:* il:|;;| "case by variate layout")
(defstruct (case-by-variate (:conc-name "CV-") (:include dataset) (:constructor %make-case-by-variate) (:print-function print-case-by-variate)) (il:* il:|;;| "Length for all data vectors ") n (il:* il:|;;| "number of batches") p case-identifier case-identifier-name variate-identifier batches)
(defun print-case-by-variate (cv stream print-level) (write-string "#<" stream) (princ (quote cv) stream) (write-string " " stream) (prin1 (cv-documentation cv) stream) (write-string ", n = " stream) (prin1 (cv-n cv) stream) (write-string " p = " stream) (prin1 (cv-p cv) stream) (write-string " identifier: " stream) (princ (cv-case-identifier-name cv) stream) (write-string " variates: " stream) (let* ((variate-identifier (cv-variate-identifier cv)) (vector (bt:identifier-vector variate-identifier)) (p (cv-p cv))) (dotimes (i p) (princ (aref vector i) stream) (unless (eq i p) (write-string " " stream)))) (write-string ">" stream))
(defun make-case-by-variate (documentation case-identifier case-identifier-name variate-identifier &rest batches) (let ((n (length (bt:identifier-vector case-identifier))) (p (length (bt:identifier-vector variate-identifier)))) (%make-case-by-variate :documentation documentation :n n :p p :case-identifier case-identifier :case-identifier-name case-identifier-name :variate-identifier variate-identifier :batches (apply (function vector) batches))))
(defun get-batch (name cv) (if (eql name (cv-case-identifier-name cv)) (cv-case-identifier cv) (let ((index (bt:identifier-index (cv-variate-identifier cv) name))) (aref (cv-batches cv) index))))
(defun add-batch (new-batch new-name cv) (let* ((new-vector (bt:batch-vector new-batch)) (variate-identifier (cv-variate-identifier cv)) (new-n (length new-vector))) (cond ((not (fixnum-eq new-n (cv-n cv))) (error "vector of incorrect length: ~s" new-n)) ((or (bt:identifier-name-p variate-identifier new-name) (eql new-name (cv-case-identifier-name cv))) (error "A variate with the same name already exits: ~s" new-name)) (t (incf (cv-p cv)) (bt:adjust-batch variate-identifier :new-vector (ea:array-adjoin (bt:identifier-vector variate-identifier) new-name)) (setf (cv-batches cv) (ea:array-adjoin (cv-batches cv) new-batch))))))
(defmacro with-cv-batches (cv variates &body body) (il:* il:|;;| "VARIATES is a list of variate names") (once-only (cv) (il:bquote (let ((n (cv-n (il:\\\, cv))) (p (cv-p (il:\\\, cv))) (il:\\\,@ (mapcar (function (lambda (variate) (il:bquote ((il:\\\, variate) (get-batch (quote (il:\\\, variate)) (il:\\\, cv)))))) variates))) (il:\\\,@ body)))))
(defmacro with-cv-batch-vectors (cv variates &body body) (il:* il:|;;| "VARIATES is a list of variate names") (once-only (cv) (il:bquote (let ((n (cv-n (il:\\\, cv))) (p (cv-p (il:\\\, cv))) (il:\\\,@ (mapcar (function (lambda (variate) (il:bquote ((il:\\\, variate) (bt:batch-vector (get-batch (quote (il:\\\, variate)) (il:\\\, cv))))))) variates))) (il:\\\,@ body)))))
(defun subset-cv (cv &key case-ids variate-names documentation) (let* ((n (cv-n cv)) (p (cv-p cv)) (cv-case-identifier (cv-case-identifier cv)) (cv-variate-identifier (cv-variate-identifier cv)) (cv-batches (cv-batches cv)) (case-selector (if (null case-ids) (ea:genvector n) (ea:array-apply (function bt:identifier-index) cv-case-identifier case-ids))) (variate-selector (if (null variate-names) (ea:genvector n) (ea:array-apply (function bt:identifier-index) cv-variate-identifier variate-names)))) (%make-case-by-variate :documentation documentation :n (if case-ids (length case-ids) n) :p (if variate-names (length variate-names) p) :case-identifier (bt:make-identifier :measurement (bt:identifier-measurement cv-case-identifier) :vector (ea:vector-select (bt:identifier-vector cv-case-identifier) case-selector)) :variate-identifier (bt:make-identifier :measurement (bt:identifier-measurement cv-variate-identifier) :vector (ea:vector-select (bt:identifier-vector cv-variate-identifier) variate-selector)) :batches (ea:array-apply (function (lambda (batch) (bt:make-batch :measurement (bt:batch-measurement batch) :vector (ea:vector-select (bt:batch-vector batch) case-selector)))) (ea:vector-select cv-batches variate-selector)))))
(defun cv-matrix (cv &key (element-type t)) (let* ((n (cv-n cv)) (p (cv-p cv)) (batches (cv-batches cv)) (matrix (make-array (list n p) :element-type element-type))) (dotimes (i p) (let ((batch (aref batches i))) (ea:array-blt (bt:batch-vector batch) matrix :destination-iterator (ea:make-iterator matrix :dimension 1 :level i)))) matrix))
(xcl:defdefiner define-case-by-variate-dataset datasets (name documentation case-identifier variates &rest cases) (il:* il:|;;| "Case-Identifier is of the form (name documentation &optional type &rest args); type defaults to label") (il:* il:|;;| "Variates are of the form (name documentation type &rest args) ") (il:* il:|;;| "cases are of the form (data &optional case-label); case-label defaults to a generated integer") (il:* il:|;;| "We'll follow defparameter semantics for dataset definitions") (let ((p (length variates)) (n (length cases))) (destructuring-bind (case-name case-doc &optional (case-type (quote :label)) &rest case-args) case-identifier (let* ((case-ids (with-collection (do ((i 0 (1+ i)) (cases-tail cases (cdr cases-tail))) ((fixnum-eq i n)) (collect (or (nth p (car cases-tail)) i))))) (case-identifier-form (il:bquote (bt:make-identifier :measurement (mt:make-measurement (quote (il:\\\, case-type)) (il:\\\, case-doc) (il:\\\,@ case-args)) :vector (vector (il:\\\,@ case-ids))))) (variate-names (mapcar (function (lambda (spec) (il:bquote (quote (il:\\\, (make-keyword (car spec))))))) variates)) (variate-identifier-form (il:bquote (bt:make-identifier :measurement (mt:make-measurement :label (il:\\\, (concatenate (quote string) (string-capitalize name) " variates"))) :vector (vector (il:\\\,@ variate-names))))) (batch-measurements (mapcar (function (lambda (measurement-spec) (destructuring-bind (name doc type &rest args) measurement-spec (il:bquote (mt:make-measurement (quote (il:\\\, type)) (il:\\\, doc) (il:\\\,@ args)))))) variates)) (batch-data (with-collection (dotimes (i p) (collect (maplist (function (lambda (cases-tail) (pop (car cases-tail)))) cases)))))) (il:bquote (defparameter (il:\\\, name) (make-case-by-variate (il:\\\, documentation) (il:\\\, case-identifier-form) (quote (il:\\\, (make-keyword case-name))) (il:\\\, variate-identifier-form) (il:\\\,@ (mapcar (function (lambda (measurement data) (il:bquote (bt:make-batch :measurement (il:\\\, measurement) :vector (vector (il:\\\,@ data)))))) batch-measurements batch-data)))))))))
(il:* il:|;;| "Tables")
(defstruct (table (:include dataset) (:constructor %make-table) (il:* il:|;;| "(:print-function print-table)")) rank (il:* il:|;;| "an identifier of classifier names") classifier-identifier (il:* il:|;;| "a vector of length rank") classifiers (il:* il:|;;| "a measurement") cell-measurement (il:* il:|;;| "a array of rank rank") cells)
(defun make-table (documentation classifier-identifier classifiers cell-measurement cells) (let ((rank (length classifiers))) (if (not (fixnum-eq rank (ea:rank cells))) (error "Dimensionality mismatch")) (%make-table :documentation documentation :rank rank :classifier-identifier classifier-identifier :classifiers classifiers :cell-measurement cell-measurement :cells cells)))
(defun get-cell (table &rest keyword-pairs) (apply (function aref) (table-data table) (let ((indices (make-array (array-rank table))) (classifier-identifier (table-classifier-identifier table)) (classifiers (table-classifiers table))) (do* ((keyword-tail keyword-pairs (cdr keyword-tail)) (classifier-name (car keyword-tail) (car keyword-tail)) (keyword-off-one-tail (cdr keyword-tail) (cdr keyword-off-one-tail)) (classifier-value (car keyword-off-one-tail) (car keyword-off-one-tail))) ((null keyword-tail) (coerce indices (quote list))) (let ((position (bt:identifier-index classifier-identifier classifier-name))) (setf (aref indices position) (bt:identifier-index (aref classifiers position) classifier-value)))))))
(eval-when (load compile)
(export (quote (n p)) (find-package "DATASETS"))
)
(xcl:define-file-environment "DATASETS" :readtable "XCL" :package (xcl:defpackage "DATASETS" (:use "LISP" "PT") (:nicknames "DS") (:prefix-name "DS")) :compiler :compile-file)
(il:putprops il:datasets il:copyright ("Xerox Corporation" 1988 1989))
(il:declare\: il:dontcopy
(il:filemap (nil)))
il:stop