Changeset 36391 in project
 Timestamp:
 08/25/18 10:11:15 (4 weeks ago)
 Location:
 release/5
 Files:

 4 edited
Legend:
 Unmodified
 Added
 Removed

release/5/statistics/branches/collections/statistics.scm
r36388 r36391 179 179 (import scheme (chicken base) (chicken foreign) (chicken format) 180 180 (chicken keyword) (prefix (chicken sort) list.) 181 (prefix (only srfi1 fold iota filter find deleteduplicates every ) list.)181 (prefix (only srfi1 fold iota filter find deleteduplicates every first last) list.) 182 182 (only srfi13 string<) srfi25 srfi69 vectorlib 183 183 yasos yasoscollections) … … 273 273 (define PI 3.1415926535897932385) 274 274 275 275 276 (define (position item sequence) 276 (let (( index 1))277 (doitemswhile (lambda (x)278 (let ((res (equal? item (cadr x))))279 (if res (set! index (car x)))280 (not res)))281 sequence)282 (if ( > index 1)283 index277 (let ((founditem 278 (gfind 279 (lambda (x) (equal? item (cadr x))) 280 (gmap list 281 (genkeys sequence) 282 (genelts sequence))))) 283 (if (not (eofobject? founditem)) 284 (car founditem) 284 285 (error "Position: item not in sequence")))) 286 287 (define (positions item sequence) 288 (let ((founditems 289 (gfilter 290 (lambda (x) (equal? item (cadr x))) 291 (gmap list 292 (genkeys sequence) 293 (genelts sequence))))) 294 (map car founditems))) 285 295 286 296 (define (arrayshape arr) … … 296 306 ;; but lisp is 0 based, so add 1! 297 307 (define (averagerank value sortedvalues) 298 (let ((first (position value sortedvalues)) 299 (last ( ( (length sortedvalues) 1) 300 (position value (reverse sortedvalues))))) 301 (+ 1 (if (= first last) 302 first 303 (/ (+ first last) 2))))) 308 (let* ((idxs (positions value sortedvalues))) 309 (let ((result (+ 1 (mean idxs)))) 310 result))) 304 311 305 312 ;; BINANDCOUNT … … 320 327 bin 321 328 (reduce 322 (lambda ( axx)329 (lambda (x ax) 323 330 (if (and (>= x (+ smallest (* bin increment))) 324 331 (< x (+ smallest (* (+ 1 bin) increment)))) … … 404 411 (if (empty? sequence) 405 412 0 406 (reverse (reduce* (lambda (ax x) (cons (+ x (car ax)) ax)) 407 sequence)))) 413 (let ((g (genelts sequence))) 414 (reverse (greduce (lambda (x ax) (cons (+ x (car ax)) ax)) 415 (list (g)) g)) 416 ) 417 )) 408 418 409 419 (define (sign x) … … 462 472 (else 463 473 (let* ((keys (mapelts (lambda (w) (expt (randomuniform) (/ 1 w))) weights)) 464 (sorteditems (sort (lambda (x y) (> (car (cadr x)) (car (cadr y))))465 ( zipelts keys sequence))))474 (sorteditems (sort (lambda (x y) (> (car x) (car y))) 475 (gmap list (genelts keys) (genelts sequence))))) 466 476 (elttake sorteditems m)) 467 477 )) … … 489 499 (define (mode sequence) 490 500 (if (empty? sequence) 491 (error "Mode: Sequence must not be null")501 (error "Mode: Sequence must not be empty") 492 502 (let ((counttable (makehashtable eqv?)) 493 503 (modes (makeparameter '())) 494 504 (modecount (makeparameter 0))) 495 505 (foreachelt 496 (lambda (item) 506 (lambda (item) 497 507 (hashtableset! counttable 498 508 item 499 (+ 1 (hashtableref counttable item (lambda () 0)))))509 (+ 1 (hashtableref/default counttable item 0)))) 500 510 sequence) 501 511 (foreach 502 512 (lambda (key) 503 (let ((val (hashtableref counttable key (lambda () #f))))513 (let ((val (hashtableref/default counttable key #f))) 504 514 (cond ((> val (modecount)) ; keep mode 505 515 (modes (list key)) … … 570 580 (define (standarderrorofthemean sequence) 571 581 (/ (standarddeviation sequence) 572 (sqrt ( lengthsequence))))582 (sqrt (size sequence)))) 573 583 574 584 ;; MEANSDN … … 578 588 (values (mean sequence) 579 589 (standarddeviation sequence) 580 ( lengthsequence)))590 (size sequence))) 581 591 582 592 ;;  … … 796 806 (define (normalvariancecionsequence sequence alpha) 797 807 (let ((variance (variance sequence)) 798 (n ( lengthsequence)))808 (n (size sequence))) 799 809 (normalvarianceci variance n alpha))) 800 810 … … 809 819 (define (normalsdcionsequence sequence alpha) 810 820 (let ((sd (standarddeviation sequence)) 811 (n ( lengthsequence)))821 (n (size sequence))) 812 822 (normalsdci sd n alpha))) 813 823 … … 846 856 (tails (getkeyword #:tails args (lambda () ':both)))) 847 857 (let ((xbar (mean sequence)) 848 (n ( lengthsequence)))858 (n (size sequence))) 849 859 (ztest xbar n #:mu mu #:sigma sigma #:tails tails)))) 850 860 … … 1145 1155 (tails (getkeyword #:tails args (lambda () ':both)))) 1146 1156 (let* ((differences (mapelts  sequence1 sequence2)) 1147 (pluscount (reduce (lambda ( axx) (if (positive? x) (+ 1 ax) ax)) 0 differences))1148 (minuscount (reduce (lambda ( axx) (if (negative? x) (+ 1 ax) ax)) 0 differences)))1157 (pluscount (reduce (lambda (x ax) (if (positive? x) (+ 1 ax) ax)) 0 differences)) 1158 (minuscount (reduce (lambda (x ax) (if (negative? x) (+ 1 ax) ax)) 0 differences))) 1149 1159 (signtest pluscount minuscount :exact? exact :tails tails)))) 1150 1160 … … 1466 1476 (ybar (mean ys)) 1467 1477 (n (size points)) 1468 (Lxx (reduce + 0 1469 (map (lambda (xi) (square ( xi xbar))) xs)))1470 (Lyy (reduce + 0 1471 (map (lambda (yi) (square ( yi ybar))) ys)))1472 (Lxy (reduce + 0 1478 (Lxx (reduce + 0.0 1479 (mapelts (lambda (xi) (square ( xi xbar))) xs))) 1480 (Lyy (reduce + 0.0 1481 (mapelts (lambda (yi) (square ( yi ybar))) ys))) 1482 (Lxy (reduce + 0.0 1473 1483 (mapelts (lambda (point) (let ((xi (car point)) 1474 (yi (ca r point)))1484 (yi (cadr point))) 1475 1485 (* ( xi xbar) ( yi ybar)))) 1476 1486 points))) … … 1542 1552 (sortedxis (sort (lambda (xi x yi y) (< x y)) xis)) 1543 1553 (sortedyis (sort (lambda (xi x yi y) (< x y)) yis)) 1544 (averagexranks (map (lambda (x) (averagerank x sortedxis)) xis))1545 (averageyranks (map (lambda (y) (averagerank y sortedyis)) yis))1554 (averagexranks (mapelts (lambda (x) (averagerank x sortedxis)) xis)) 1555 (averageyranks (mapelts (lambda (y) (averagerank y sortedyis)) yis)) 1546 1556 (meanxrank (mean averagexranks)) 1547 1557 (meanyrank (mean averageyranks)) 
release/5/statistics/trunk/statistics.scm
r36303 r36391 289 289 first 290 290 (/ (+ first last) 2))))) 291 (define (averagerank value sortedvalues) 292 (let ((first (position value sortedvalues)) 293 (last ( ( (length sortedvalues) 1) 294 (position value (reverse sortedvalues))))) 295 (let ((result (+ 1 (if (= first last) 296 first 297 (/ (+ first last) 2))))) 298 (print "averagerank: value = " value " first = " first " last = " last " result = " result) 299 result))) 291 300 292 301 ;; BINANDCOUNT 
release/5/yasos/trunk/collections.scm
r36388 r36391 3 3 4 4 (collection? randomaccess? empty? size genkeys genelts 5 doelts dokeys doitems doitemswhile5 doelts dokeys doitems 6 6 mapelts mapkeys mapitems 7 7 foreachkey foreachelt eltref eltset! elttake eltdrop 8 reduce reduce* reduceitems reduceitems* anyelt? everyelt? zipelts sort! sort 9 makevecgenelts listgenelts vectorgenelts 10 stringgenelts hashtablegenelts 8 reduce reduce* reduceitems reduceitems* sort! sort 9 makevectorgenerator list>generator vector>generator 10 string>generator hashtable>generator 11 gmap greduce gfind gfilter 11 12 ) 12 13 13 (import scheme (chicken base) (chicken format) srfi69 14 (import scheme (chicken base) (chicken format) srfi69 14 15 (except yasos object objectwithancestors)) 15 16 … … 18 19 19 20 ;; (collection? obj)  predicate 21 ;; 22 ;; (empty? collection)  I bet you can guess what these do as well... 23 ;; (size collection) 20 24 ;; 21 25 ;; (doelts proc coll+)  apply proc elementwise to collections … … 30 34 ;; 31 35 ;; (reduce proc seed coll+)  e.g. (reduce + 0 (vector 1 2 3)) 32 ;; (any? predicate coll+)  e.g. (any? odd? (list 2 3 4 5))33 ;; (every? predicate coll+)  e.g. (every? collection collections)34 ;;35 ;; (empty? collection)  I bet you can guess what these do as well...36 ;; (size collection)37 36 ;; 38 37 ;;============================== … … 55 54 ;; eltdrop 56 55 ;; 57 ;;============================== 56 ;;============================== 57 58 (define *eofobject* (read (openinputstring ""))) 59 (define (eofobject) *eofobject*) 60 61 (define (listany pred lis) 62 (and (not (null? lis)) 63 (let lp ((head (car lis)) (tail (cdr lis))) 64 (if (null? tail) 65 (pred head) ; Last PRED app is tail call. 66 (or (pred head) (lp (car tail) (cdr tail))))))) 58 67 59 68 (define (listzip list1 . morelists) (apply map list list1 morelists)) … … 144 153 )) 145 154 146 (defineoperation (genelts <collection>);; return element generator155 (defineoperation (genelts <collection>);; return SRFI121 element generator 147 156 ;; default behavior 148 (cond ;; see utilities, below, for generators149 ((vector? <collection>) (vector genelts<collection>))150 ((list? <collection>) (list genelts<collection>))151 ((string? <collection>) (string genelts<collection>))152 ((hashtable? <collection>) (hashtable genelts<collection>))157 (cond 158 ((vector? <collection>) (vector>generator <collection>)) 159 ((list? <collection>) (list>generator <collection>)) 160 ((string? <collection>) (string>generator <collection>)) 161 ((hashtable? <collection>) (hashtable>generator <collection>)) 153 162 (else 154 163 (error "operation not supported: genelts ")) … … 166 175 (index (add1 i)) 167 176 i) 168 (else (e rror "no more keys in generator"))177 (else (eofobject)) 169 178 )) 170 179 )) 171 180 ) 172 181 ((hashtable? collection) 173 (list genelts(hashtablekeys collection)))182 (list>generator (hashtablekeys collection))) 174 183 (else 175 184 (error "operation not handled: genkeys " collection)) … … 218 227 ) ) 219 228 ) ) 220 221 (define (doitemswhile <proc> . <collections>)222 (let ( (max+1 (size (car <collections>)))223 (eltgenerators (map genelts <collections>))224 (keygenerators (map genkeys <collections>)) )225 (let loop ( (counter 0) )226 (cond227 ((< counter max+1)228 (let ((res (apply <proc> (listzip (map (lambda (g) (g)) keygenerators)229 (map (lambda (g) (g)) eltgenerators)))))230 (if res (loop (add1 counter)))231 ))232 (else 'unspecific) ; done233 ))234 ))235 229 236 230 (define (mapelts <proc> . <collections>) … … 281 275 ) ) 282 276 283 (defineoperation (foreachkey < collection> <proc>)277 (defineoperation (foreachkey <proc> <collection>) 284 278 ;; default 285 279 (dokeys <proc> <collection>) ;; talk about lazy! 286 280 ) 287 281 288 (defineoperation (foreachelt < collection> <proc>)282 (defineoperation (foreachelt <proc> <collection>) 289 283 (doelts <proc> <collection>) 290 284 ) … … 298 292 (cond 299 293 ((< count max+1) 300 (ax (apply <proc> ( cons (ax) (map (lambda (g) (g)) eltgenerators))))294 (ax (apply <proc> (append (map (lambda (g) (g)) eltgenerators) (list (ax))))) 301 295 (loop (add1 count)) 302 296 ) … … 315 309 (cond 316 310 ((< count max+1) 317 (ax (apply <proc> (cons (ax) (listzip (map (lambda (g) (g)) keygenerators) 318 (map (lambda (g) (g)) eltgenerators))))) 311 (ax (apply <proc> (append (listzip (map (lambda (g) (g)) keygenerators) 312 (map (lambda (g) (g)) eltgenerators)) 313 (list (ax))))) 319 314 (loop (add1 count)) 320 315 ) … … 333 328 (cond 334 329 ((< count max+1) 335 (ax (apply <proc> (append (ax) (map (lambda (g) (g)) eltgenerators)))) 330 (let ((args (append (map (lambda (g) (g)) eltgenerators) (ax)))) 331 (ax (list (apply <proc> args)))) 336 332 (loop (add1 count)) 337 333 ) 338 (else ( ax))334 (else (car (ax))) 339 335 ) ) 340 336 ) ) … … 350 346 (cond 351 347 ((< count max+1) 352 (ax (apply <proc> (append (ax) (listzip (map (lambda (g) (g)) keygenerators) 353 (map (lambda (g) (g)) eltgenerators))))) 348 (ax (list (apply <proc> (append (listzip (map (lambda (g) (g)) keygenerators) 349 (map (lambda (g) (g)) eltgenerators)) 350 (ax))))) 354 351 (loop (add1 count)) 355 352 ) 356 (else ( ax))353 (else (car (ax))) 357 354 ) ) 358 355 ) ) 359 356 360 ;; pred true for every elt? 361 (define (everyelt? <pred?> . <collections>) 362 (let ( (max+1 (size (car <collections>))) 363 (generators (map genelts <collections>)) 364 ) 365 (let loop ( (count 0) ) 366 (cond 367 ((< count max+1) 368 (if (apply <pred?> (map (lambda (g) (g)) generators)) 369 (loop (add1 count)) 370 #f) 371 ) 372 (else #t) 373 ) ) 374 ) ) 375 376 ;; pred true for any elt? 377 (define (anyelt? <pred?> . <collections>) 378 (let ( (max+1 (size (car <collections>))) 379 (generators (map genelts <collections>)) 380 ) 381 (let loop ( (count 0) ) 382 (cond 383 ((< count max+1) 384 (if (apply <pred?> (map (lambda (g) (g)) generators)) 385 #t 386 (loop (add1 count)) 387 )) 388 (else #f) 389 ) ) 390 ) ) 391 392 393 394 357 395 358 ;; generator for list elements 396 (define (list genelts<list>)359 (define (list>generator <list>) 397 360 (let ((l (makeparameter <list>))) 398 361 (lambda () 399 362 (if (null? (l)) 400 (e rror "no more list elements in generator")363 (eofobject) 401 364 (let ( (elt (car (l))) ) 402 365 (l (cdr (l))) … … 405 368 ) 406 369 407 (define (makevec genelts<accessor>)370 (define (makevectorgenerator <accessor>) 408 371 (lambda (vec) 409 372 (let ( (max+1 (size vec)) … … 416 379 (<accessor> vec i) 417 380 ) 418 (else #f)381 (else (eofobject)) 419 382 )) 420 383 )) 421 384 )) 422 385 423 (define vector genelts (makevecgeneltsvectorref))424 425 (define string genelts (makevecgeneltsstringref))426 427 (define (hashtable geneltstable)386 (define vector>generator (makevectorgenerator vectorref)) 387 388 (define string>generator (makevectorgenerator stringref)) 389 390 (define (hashtable>generator table) 428 391 (let ((keys (makeparameter (hashtablekeys table)))) 429 392 (lambda () 430 (cond ((null? keys) #f)393 (cond ((null? keys) (eofobject)) 431 394 (else (let ((res (hashtableref table (car (keys))))) 432 395 (keys (cdr (keys))) … … 434 397 )) 435 398 )) 436 437 438 (define (zipelts <collection> . <rest>)439 (let* (440 (<collections> (cons <collection> <rest>))441 (max+1 ( (size (car <collections>)) 1))442 (generators (map genelts <collections>))443 (result (makevector (+ 1 max+1)))444 )445 (let loop ( (count 0) )446 (cond447 ((< count max+1)448 (vectorset! result count (map (lambda (g) (g)) generators))449 (loop (add1 count))450 )451 (else result)452 ))453 ))454 455 399 456 400 … … 568 512 (define (sort elt< x) 569 513 (let* ((n (size x)) 570 (a (makevector n)) 571 (b (makevector n))) 514 (a (makevector n))) 572 515 (doitems (lambda (item) (vectorset! a (car item) (cadr item))) x) 573 (let recur ((m 1)) 574 (if (< m n) 575 (let innerrecur ((p 0)) 576 (if (< p ( n m)) 577 (let ((q (+ p m)) 578 (r (min (+ p (* 2 m)) n))) 579 (vectormerge! elt< a p q r b p) 580 (vectorblit! b p r a p) 581 (innerrecur (+ p (* 2 m))) 582 ) 583 (recur (* m 2)))) 584 b)) 516 (if (< n 2) 517 a 518 (let ((b (makevector n))) 519 (let recur ((m 1)) 520 (if (< m n) 521 (let innerrecur ((p 0)) 522 (if (< p ( n m)) 523 (let ((q (+ p m)) 524 (r (min (+ p (* 2 m)) n))) 525 (vectormerge! elt< a p q r b p) 526 (vectorblit! b p r a p) 527 (innerrecur (+ p (* 2 m))) 528 ) 529 (recur (* m 2)))) 530 b)) 531 )) 585 532 )) 586 533 587 534 535 ;; Generator combinators 536 (define (gmap f . gs) 537 (lambda () 538 (let ((vs (map (lambda (g) (g)) gs))) 539 (if (listany eofobject? vs) 540 (eofobject) 541 (apply f vs)) 542 )) 543 ) 544 545 546 (define (greduce f seed . gs) 547 (define (innerfold seed) 548 (let ((vs (map (lambda (g) (g)) gs))) 549 (if (listany eofobject? vs) 550 seed 551 (innerfold (apply f (append vs (list seed))))))) 552 (innerfold seed)) 553 554 555 (define (gfind pred g) 556 (let loop ((v (g))) 557 (if (or (pred v) (eofobject? v)) 558 v 559 (loop (g))) 560 )) 561 562 (define (gfilter pred g) 563 (let loop ((v (g)) (res '())) 564 (cond ((eofobject? v) res) 565 ((pred v) (loop (g) (cons v res))) 566 (else (loop (g) res))) 567 )) 568 588 569 589 570 ) 
release/5/yasos/trunk/tests/run.scm
r36387 r36391 306 306 ;; collection behaviors 307 307 ((collection? self) #t) 308 ((genkeys self) (list genelts(map car table)))309 ((genelts self) (list genelts(map cdr table)))308 ((genkeys self) (list>generator (map car table))) 309 ((genelts self) (list>generator (map cdr table))) 310 310 ((foreachkey self proc) 311 311 (foreach (lambda (bucket) (proc (car bucket))) table) … … 320 320 (testgroup "collections" 321 321 322 (foreachelt 323 (lambda (item) 324 (print "item: " item)) 325 '(1 2 3)) 322 326 (testassert (collection? t)) 323 327 (testassert (empty? t)) … … 332 336 (test "mapelts" #(2 1) (mapelts identity t)) 333 337 (test "reduce" 3 (reduce + 0 t)) 334 (test "reduceitems" 3 (reduceitems (lambda ( ax item)338 (test "reduceitems" 3 (reduceitems (lambda (item ax) 335 339 (+ (cadr item) ax)) 0 t)) 340 (test "reduce*" 1 (reduce* min '(1 2 3 4 10 5 6 8 7 9))) 336 341 (test "sort!" #(1 2 3 4 5) (sort! (lambda (i vi j vj) (< vi vj)) 337 342 #( 5 2 4 3 1)))
Note: See TracChangeset
for help on using the changeset viewer.