share/stats/inference_result.lisp

   1 ;;                 COPYRIGHT NOTICE
   2 ;;
   3 ;;  Copyright (C) 2006-2012 Mario Rodriguez Riotorto
   4 ;;
   5 ;;  This program is free software; you can redistribute
   6 ;;  it and/or modify it under the terms of the
   7 ;;  GNU General Public License as published by
   8 ;;  the Free Software Foundation; either version 2
   9 ;;  of the License, or (at your option) any later version.
  10 ;;
  11 ;;  This program is distributed in the hope that it
  12 ;;  will be useful, but WITHOUT ANY WARRANTY;
  13 ;;  without even the implied warranty of MERCHANTABILITY
  14 ;;  or FITNESS FOR A PARTICULAR PURPOSE. See the
  15 ;;  GNU General Public License for more details at
  16 ;;  http://www.gnu.org/copyleft/gpl.html
  17
  18 ;;  This package handles objects returned by statistical inference
  19 ;;  procedures. Some code was copied and adapted from displa.lisp
  20
  21 ;; For questions, suggestions, bugs and the like, feel free
  22 ;; to contact me at
  23 ;; mario @@@ edu DOT xunta DOT es
  24
  25 (in-package :maxima)
  26
  27 ;; Constructs the 'inference_result' object, with
  28 ;;    title: string with the name of the inference procedure
  29 ;;    val: Maxima list, the elements of which are lists of
  30 ;;         the form: ["Value's name", value]
  31 ;;    selection: Maxima list numbering the values to be displayed
  32 (defun $inference_result (title val selection)
  33   (list '($inference_result) title val selection))
  34
  35
  36 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37 ;;                                              ;;
  38 ;;    DISPLAY PROPERTIES FOR inference_result   ;;
  39 ;;                                              ;;
  40 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41
  42
  43 ;; Functions d-matrixz, matoutz, coloutz and dim-$inference_result are similar to
  44 ;; d-matrix, matout, colout and dim-$matrix, respectively, from displa.lisp.
  45 ;; The left and right characters ($lmxchar and $rmxchar in displa.lisp) are
  46 ;; defined without additional global variables.
  47
  48
  49 (defun d-matrixz (linear? direction h d)
  50   (declare (fixnum h d))
  51   (d-vbar linear? h d (if (eq direction 'right) #\space #\|)))  ; <- right and left characters
  52
  53 (defun matoutz (dmstr cstr rstr result)
  54   (push `(d-matrixz left ,height ,depth) result)
  55   (push #\space result)
  56   (do ((d dmstr (cdr d)) (c cstr (cdr c)) (w 0 0)) ((null d))
  57     (declare (fixnum w))
  58     (do ((d (car d) (cdr d)) (r rstr (cdr r))) ((null d))
  59       (rplaca (cddar d) (f- height (car r)))
  60       (rplaca (cdar d) (f- (truncate (f- (car c) (caar d)) 2) w))
  61       (setq w (truncate (f+ (car c) (caar d)) 2))
  62       (rplaca d (cdar d)))
  63     (setq result (cons (list (f+ 2 (f- (car c) w)) 0) (nreconc (car d) result))))
  64   (setq width (f+ 2 width))
  65   (update-heights height depth)
  66   (rplaca (car result) (f1- (caar result)))
  67   (push `(d-matrixz right ,height ,depth) result)
  68   result)
  69
  70 (defun coloutz (dmstr cstr result)
  71   (setq width 0 height 1 depth 0)
  72   (do ((r dmstr (cdr r)) (c cstr (cdr c)) (col 1 (f1+ col)) (w 0 0) (h -1 -1) (d 0))
  73       ((null r))
  74     (declare (fixnum col w h d))
  75     (push-string " Col " result)
  76     (setq result (nreconc (exploden col) result))
  77     (push-string " = " result)
  78     (setq width (f+ 8 (flatc col) width))
  79     (do ((r (car r) (cdr r))) ((null r))
  80       (setq h (f+ 1 h (cadar r) (caddar r)))
  81       (rplaca (cddar r) (f- h (cadar r)))
  82       (rplaca (cdar r) (f- (truncate (f- (car c) (caar r)) 2) w))
  83       (setq w (truncate (f+ (car c) (caar r)) 2))
  84       (rplaca r (cdar r)))
  85     (setq d (truncate h 2) h (f- h d))
  86     (push `(d-matrixz left ,h ,d) result)
  87     (push #\space result)
  88     (push `(0 ,(f- d) . ,(nreverse (car r))) result)
  89     (push `(,(f1+ (f- (car c) w)) 0) result)
  90     (push `(d-matrixz right ,h ,d) result)
  91     (setq width (f+ 4 (car c) width) height (max h height) depth (max d depth))
  92     (update-heights h d)
  93     (checkbreak result width))
  94   result)
  95
  96 (displa-def $inference_result dim-$inference_result)
  97
  98 (defun dim-$inference_result (form result)
  99   (declare (special linearray))
 100   (prog (dmstr rstr cstr consp)
 101      (if (or (null (cdr form))
 102              (not (member 'simp (cdar form) :test #'eq))
 103              (memalike '((mlist simp)) (cdr form))
 104              (dolist (row (cdr form)) (if (not ($listp row)) (return t))))
 105          (return (dimension-function form result)))
 106      (do ((l (cdadr form) (cdr l))) ((null l))
 107        (setq dmstr (cons nil dmstr) cstr (cons 0 cstr)))
 108      (do ((r (cdr form) (cdr r)) (h1 0) (d1 0))
 109          ((or consp (null r))
 110           (setq width 0)
 111           (do ((cs cstr (cdr cs))) ((null cs)) (setq width (f+ 2 (car cs) width)))
 112           (setq h1 (f1- (f+ h1 d1)) depth (truncate h1 2) height (f- h1 depth)))
 113        (declare (fixnum h1 d1))
 114        (do ((c (cdar r) (cdr c))
 115             (nc dmstr (cdr nc))
 116             (cs cstr (cdr cs)) (dummy) (h2 0) (d2 0))
 117            ((null c) (setq d1 (f+ d1 h1 h2) h1 (f1+ d2)))
 118          (declare (fixnum h2 d2))
 119          (setq dummy (dimension (car c) nil 'mparen 'mparen nil 0)
 120                h2 (max h2 height) d2 (max d2 depth))
 121          (cond ((not (checkfit (f+ 14. width))) (setq consp t) (return nil))
 122                (t (rplaca nc (cons (list* width height depth dummy) (car nc)))
 123                   (rplaca cs (max width (car cs))))))
 124        (setq rstr (cons d1 rstr)))
 125      (when (> (+ height depth) (length linearray))
 126        (setq consp t))
 127      (return
 128        (cond ((and (not consp) (checkfit (f+ 2 width)))
 129               (matoutz dmstr cstr rstr result))
 130              ((and (not consp) (<= level 2)) (coloutz dmstr cstr result))
 131              (t (dimension-function form result))))))
 132
 133
 134 ;; Sets display properties
 135 (displa-def $inference_result dimension-inference)
 136
 137 (defun dimension-inference (form result)
 138   (let ((title (cadr form))
 139         (outputitems (reverse (cdr (cadddr form))))
 140          (output nil) aux)
 141     (dolist (k outputitems 'done)
 142       (setf aux (rest (nth k (caddr form))))
 143       (push (list '(mlist simp) (list '(mequal simp) (car aux) (cadr aux)))
 144             output))
 145    ; variable output has the following structure:
 146    ; '(($inference_result simp)
 147    ;      ((mlist simp) ,title)
 148    ;      ((mlist) ((mequal simp) value_name1 value1))
 149    ;      ((mlist) ((mequal simp) value_name2 value2))
 150    ;      ((mlist) ((mequal simp) value_name3 value3)))
 151    (setf output (append (list '($inference_result simp) (list '(mlist simp) title)) output))
 152    (dim-$inference_result output result)))
 153
 154
 155 ;; Format TeX output
 156 (defprop $inference_result tex-inference_result tex)
 157
 158 (defun tex-inference_result (x l r)
 159   ;; inference_result looks like
 160   ;; ((inference_result) string ((mlist) ((mlist)..) ((mlist)..)..))
 161   (append l `("\\left | \\matrix{" )
 162           (list "\\hbox{" (cadr x) "} \\cr \\matrix{")
 163           (mapcan #'(lambda(y)
 164                       (tex-list `(((mequal) ,(cadr y) ,(caddr y))) nil (list "\\cr ") "&"))
 165                   (cdar (butlast (cddr x))))
 166           '("}} \\right .") r))
 167
 168
 169
 170
 171
 172 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 173 ;;                                  ;;
 174 ;;  FUNCTIONS FOR inference_result  ;;
 175 ;;                                  ;;
 176 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 177
 178
 179 ;; Returns true or false, depending on whether 'obj' is an
 180 ;; 'inference_result' object or not.
 181 (defun $inferencep (obj)
 182   (and (listp obj)
 183        (equalp (car obj) '($inference_result simp)) ))
 184
 185
 186 ;;  Returns a Maxima list with the names
 187 ;;  of the items stored in the 'inference_result' object
 188 (defun $items_inference (obj)
 189   (let ((items (cdaddr obj)))
 190     (cons '(mlist) (mapcar #'second items))))
 191
 192
 193 ;;  Returns the n-th value of the 'inference_result' object,
 194 ;;  or the list of values associated to the indices in n,
 195 ;;  if n is a Maxima list.
 196 (defun $take_inference (n obj)
 197   (if ($inferencep obj)
 198       (cond ((and ($integerp n) (<= n (length (cdaddr obj))))
 199               (caddr (nth (- n 1) (cdaddr obj))))
 200             (($listp n)
 201               (let ((values nil)
 202                     (items (reverse (rest n))))
 203                  (dolist (k items (cons '(mlist) values))
 204                     (setf values (cons ($take_inference k obj) values)))) )
 205             (t
 206               (let ((m (position n (mapcar #'second (cdaddr obj)))))
 207                  (if (equal m nil)
 208                      (merror "Wrong label in 'take_inference' call")
 209                      (caddr (nth m (cdaddr obj)))))))
 210       (merror "Wrong object in 'take_inference' call")  ))
 211
 212
 213 ;;  Returns the title of the 'inference_result' object
 214 (defun $title_inference (obj)
 215   (if ($inferencep obj)
 216     (second obj)
 217     (merror "Wrong object in 'title_inference' call")) )
 218