src/lsp/oneway.lsp

   1 ;;;; XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney
   2 ;;;; Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz
   3 ;;;; You may give out copies of this software; for conditions see the file
   4 ;;;; COPYING included with this distribution.
   5
   6 (provide "oneway")
   7
   8 (require "regress")
   9
  10 ;;;;
  11 ;;;;
  12 ;;;; One Way ANOVA Model Prototype
  13 ;;;;
  14 ;;;;
  15
  16 (defproto oneway-model-proto '(grouped-data) '() regression-model-proto)
  17
  18 (defun oneway-model (data &key (print t) group-names)
  19 "Args: ( data &key (print t))
  20 DATA: list of compound-data
  21 Example:"
  22   (let ((data (mapcar #'(lambda (x) (coerce x 'list)) data))
  23         (m (send oneway-model-proto :new)))
  24     (send m :grouped-data data)
  25     (send m :group-names group-names)
  26     (if print (send m :display))
  27     m))
  28
  29 (defmeth oneway-model-proto :display ()
  30 "Message args: ()
  31 Prints the least squares regression summary."
  32   (call-next-method)
  33   (format t "Group Mean Square:~25t~13,6g~40t(~,6g)~%"
  34           (send self :group-mean-square) (send self :group-df))
  35   (format t "Error Mean Square:~25t~13,6g~40t(~,6g)~%"
  36           (send self :error-mean-square) (send self :error-df))
  37   (format t "~%"))
  38
  39 (defmeth oneway-model-proto  :save ()
  40 "Message args: ()
  41 Returns an expression that will reconstruct the model."
  42   `(oneway-model ',(send self :grouped-data)
  43                  :group-names ',(send self :group-names)))
  44
  45 ;;;
  46 ;;; Slot Accessors and Mutators
  47 ;;;
  48
  49 (defmeth oneway-model-proto :grouped-data (&optional data)
  50 "Message args: (&optional data)
  51 Sets or returns the grouped data."
  52   (when data
  53         (let* ((y (apply #'append data))
  54                (indices (repeat (iseq 0 (- (length data) 1))
  55                                 (mapcar #'length data)))
  56                (levels (remove-duplicates indices))
  57                (indicators (mapcar #'(lambda (x) (if-else (= x indices) 1 0))
  58                                    levels))
  59                (x (apply #'bind-columns indicators)))
  60           (setf (slot-value 'y) y)
  61           (setf (slot-value 'x) x)
  62           (setf (slot-value 'intercept) nil)
  63           (setf (slot-value 'grouped-data) data)
  64           (send self :needs-computing t)))
  65    (slot-value 'grouped-data))
  66
  67 (defmeth oneway-model-proto :group-names (&optional (names nil set))
  68 "Method args: (&optional names)
  69 Sets or returns group names."
  70   (if set (setf (slot-value 'predictor-names) names))
  71   (let ((g-names (slot-value 'predictor-names))
  72         (ng (length (slot-value 'grouped-data))))
  73     (if (not (and g-names (= ng (length g-names))))
  74         (setf (slot-value 'predictor-names)
  75               (mapcar #'(lambda (a) (format nil "Group ~a" a))
  76                       (iseq 0 (- ng 1))))))
  77   (slot-value 'predictor-names))
  78
  79 ;;;
  80 ;;; Overrides for Linear Regression Methods
  81 ;;;
  82
  83 (defmeth oneway-model-proto :y ()
  84 "
  85 Message args: ()
  86 Returns the response vector."
  87    (call-next-method))
  88
  89 (defmeth oneway-model-proto :x ()
  90 "Message args: ()
  91 Returns the design matrix."
  92    (call-next-method))
  93
  94 (defmeth oneway-model-proto :intercept (&rest args)
  95 "Message args: ()
  96 Always returns nil. For compatibility with linear regression."
  97   (declare (ignore args))
  98   nil)
  99
 100 (defmeth oneway-model-proto :predictor-names () (send self :group-names))
 101
 102 ;;;
 103 ;;; Other Methods
 104 ;;;
 105
 106 (defmeth oneway-model-proto :standard-deviations ()
 107 "Message args: ()
 108 Returns list of within group standard deviations."
 109   (mapcar #'standard-deviation (send self :grouped-data)))
 110
 111 (defmeth oneway-model-proto :group-df ()
 112 "Message args: ()
 113 Returns degrees of freedom for groups."
 114         (- (length (send self :grouped-data)) 1))
 115
 116 (defmeth oneway-model-proto :group-sum-of-squares ()
 117 "Message args: ()
 118 Returns sum of squares for groups."
 119   (sum (^ (- (send self :fit-values) (mean (send self :y))) 2)))
 120
 121 (defmeth oneway-model-proto :group-mean-square ()
 122 "Message args: ()
 123 Returns mean square for groups."
 124         (/ (send self :group-sum-of-squares) (send self :group-df)))
 125
 126 (defmeth oneway-model-proto :error-df ()
 127 "Message args: ()
 128 Returns degrees of freedom for error."
 129         (send self :df))
 130
 131 (defmeth oneway-model-proto :error-mean-square ()
 132 "Message args: ()
 133 Returna mean square for error."
 134         (/ (send self :sum-of-squares) (send self :df)))
 135
 136 (defmeth oneway-model-proto :boxplots ()
 137 "Message args: ()
 138 Produce parallel box plots of the groups."
 139         (boxplot (send self :grouped-data)))
 140