Changeset 40279 in project


Ignore:
Timestamp:
07/16/21 02:28:43 (2 weeks ago)
Author:
Kon Lovett
Message:

new test runner, X2 test (from C4 version)

Location:
release/5/micro-stats/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/5/micro-stats/trunk/micro-stats.scm

    r39876 r40279  
    44;;
    55;;- see the haskell benchmark suite (? name ?)
     6;;
     7;;- missing `nice` argument checking
    68
    79(module micro-stats
     
    1416  mean median mode
    1517  standard-deviation
    16   #; ;need to validate
    17   chi-square
    18   #; ;need to validate
    19   chi-squares)
     18  ;#; ;need to validate
     19  chi-square)
    2020
    2121(import scheme
     
    4848(: percentile (seq #!optional real binary-predicate --> real))
    4949
    50 (: chi-sample ((or real seq) (or real seq) --> real))
    51 (: chi-squares (seq seq --> seq))
    5250(: chi-square (seq (or real seq) --> real))
    5351
     
    103101            (loop (cdr ls) ) ) ) ) ) ) )
    104102
    105 (define (check-alist loc obj . args)
    106   (unless (alist? obj)
    107     (error-alist loc obj (let ((tmp args)) (if (null? tmp) #f (car tmp)))) )
    108   obj )
    109 
    110103(define (error-alist loc obj #!optional argnam)
    111104  (import (only (chicken string) conc))
     
    115108      " type - not " "an " "alist")
    116109    obj) )
     110
     111(define (check-alist loc obj . args)
     112  (unless (alist? obj)
     113    (error-alist loc obj (let ((tmp args)) (if (null? tmp) #f (car tmp)))) )
     114  obj )
    117115
    118116;;;
     
    273271(define (mode runs #!optional (eqal? =))
    274272  (define (occur> a b) (> (cdr a) (cdr b)))
    275   (if (seq:empty? runs) 0.0
     273  (if (seq:empty? runs)
     274    0.0
    276275    (let ((top-bin (first (seq*:sort! (seq*:histogram runs eqal?) occur>))))
    277276      (car top-bin)) ) )
     
    292291
    293292(define (variance runs m)
    294   (let ((acc 0) (siz 0))
    295     (seq:for
    296       (lambda (elm)
    297         (set! acc (+ acc (expt (- elm m) 2)))
    298         (set! siz (add1 siz)) )
    299       runs)
    300     (if (< siz 2) 0.0
    301       (/ acc (sub1 siz))) ) )
    302 
    303 ;;FIXME chi^2 dist is ???
    304 
    305 (define (ensure-seq x) (if (seq:sequence? x) x (list x)))
    306 
    307 ;observed : (seq-of real)
    308 ;expected : (or real (seq-of real))
    309 ;
    310 (define (chi-square observed expected)
    311   (seq:smap *empty-vector* (cut chi-sample <> expected) observed) )
    312 
    313 ;samples : (seq-of (seq-of real))
    314 ;expected : (or real (seq-of real))
    315 ;
    316 (define (chi-squares samples expected)
    317   (seq:smap *empty-vector* (cut chi-square <> expected) samples) )
    318 
    319 ;;
    320 
    321 (define (chi-component o e) (let ((r (- o e))) (/ (* r r) e)))
    322 
    323 ;(real (seq-of real)) or ((seq-of real) real)
    324 ;
    325 (define (chi-sample observed expected)
    326   (let (
    327     (components
    328       (cond
    329         ((not (seq:sequence? observed))
    330           (seq:smap *empty-vector* (cut chi-component observed <>) expected) )
    331         ((not (seq:sequence? expected))
    332           (seq:smap *empty-vector* (cut chi-component <> expected) observed) )
    333         (else
    334           (error 'chi-sample "seq X seq unsupported" observed expected)
    335           #; ;shouldn't happen
    336           (seq:smap*
    337             *empty-vector*
    338             (lambda (s it) (chi-component (seq:elt s it) (seq:elt expected (seq:index it))))
    339             observed) ) ) ) )
    340     (/ (seq:foldl + 0 components) (seq:size components)) ) )
     293  (let ((siz (seq:size runs)))
     294    (if (<= 0 siz 1)
     295      0.0
     296      (let ((acc (seq:foldl (lambda (acc elm) (+ acc (expt (- elm m) 2))) 0 runs)))
     297        (/ acc (sub1 siz)) ) ) ) )
     298
     299;;
     300
     301(: chi-sample (procedure seq (or real seq) --> real))
     302(: chi-square-component (real real --> real))
     303(: yates-chi-square-component (real real --> real))
     304
     305(define (chi-square observed expected #!optional yates?)
     306  (unless (seq:sequence? observed)
     307    (error 'chi-square "observed not a sequence" observed expected yates?) )
     308  (unless (or (seq:sequence? expected) (real? expected))
     309    (error 'chi-square "expected not a sequence or real" observed expected yates?) )
     310  (when (and (seq:sequence? observed) (seq:sequence? expected))
     311    (unless (= (seq:size expected) (seq:size observed))
     312      (error 'chi-square "length observed not same length expected" observed expected yates?) ) )
     313  ;
     314  (let ((component (if yates? yates-chi-square-component chi-square-component)))
     315    (chi-sample component observed expected) ) )
     316
     317(define (chi-sample component observed expected)
     318  (define (chi-components)
     319    (cond
     320      ((not (seq:sequence? expected))
     321        (seq:smap *empty-vector* (cut component <> expected) observed) )
     322      (else
     323        (seq:smap*
     324          *empty-vector*
     325          (lambda (s it) (component (seq:elt s it) (seq:elt expected (seq:index it))))
     326          observed))) )
     327  ;
     328  (seq:foldl + 0 (chi-components)) )
     329
     330(define (yates-chi-square-component o e)
     331  (let ((r (- (abs (- o e)) 0.5)))
     332    (/ (* r r) e) ) )
     333
     334(define (chi-square-component o e)
     335  (let ((r (- o e)))
     336    (/ (* r r) e) ) )
    341337
    342338) ;module micro-stats
  • release/5/micro-stats/trunk/tests/micro-stats-test.scm

    r39876 r40279  
    110110)
    111111
    112 #; ;need to validate
     112;#; ;need to validate
    113113(test-group "chi-square"
    114114  (define observed '(1003390.64498901 1003339.76300049 1002674.73300171))
    115115  (define expected '(1000726.09802246 1004995.05200195 1000966.09100342))
    116   (chi-square observed expected) )
     116  (gloss "chi-square T1" " : " (chi-square observed expected)) )
    117117
    118118(test-end "micro-stats")
  • release/5/micro-stats/trunk/tests/run.scm

    r39807 r40279  
    77    make-pathname pathname-file pathname-replace-directory pathname-strip-extension)
    88  (only (chicken process) system)
    9   (only (chicken process-context) command-line-arguments)
     9  (only (chicken process-context) command-line-arguments get-environment-variable)
    1010  (only (chicken format) format)
    1111  (only (chicken file) file-exists? find-files)
     
    1313
    1414;; Globals
     15
     16(define *csi* (or (get-environment-variable "CHICKEN_CSI") "csi"))
     17(define *csc* (or (get-environment-variable "CHICKEN_CSC") "csc"))
    1518
    1619(define *csc-init-options* '(
     
    7982
    8083(define (run-test-evaluated source)
    81   (format #t "*** csi ~A ***~%" (pathname-file source))
    82   (system-must (string-append "csi -s " source)) )
     84  (format #t "*** ~A ~A ***~%" *csi* (pathname-file source))
     85  (system-must (string-append *csi* " -s " source)) )
    8386
    8487(define (run-test-compiled source csc-options)
    8588  (let ((optstr (apply string-append (intersperse csc-options " "))))
    86     (format #t "*** csc ~A ~A ***~%" (pathname-file source) optstr)
     89    (format #t "*** ~A ~A ~A ***~%" *csc* (pathname-file source) optstr)
    8790    ;csc output is in current directory
    88     (system-must (string-append "csc" " " optstr " " source)) )
     91    (system-must (string-append *csc* " " optstr " " source)) )
    8992  (system-must (pathname-replace-directory (pathname-strip-extension source) *test-directory*)) )
    9093
Note: See TracChangeset for help on using the changeset viewer.