Changeset 36391 in project
- Timestamp:
- 08/25/18 10:11:15 (16 months 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 srfi-1 fold iota filter find delete-duplicates every ) list.)181 (prefix (only srfi-1 fold iota filter find delete-duplicates every first last) list.) 182 182 (only srfi-13 string<) srfi-25 srfi-69 vector-lib 183 183 yasos yasos-collections) … … 273 273 (define PI 3.1415926535897932385) 274 274 275 275 276 (define (position item sequence) 276 (let (( index -1))277 (do-items-while (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 ((found-item 278 (g-find 279 (lambda (x) (equal? item (cadr x))) 280 (g-map list 281 (gen-keys sequence) 282 (gen-elts sequence))))) 283 (if (not (eof-object? found-item)) 284 (car found-item) 284 285 (error "Position: item not in sequence")))) 286 287 (define (positions item sequence) 288 (let ((found-items 289 (g-filter 290 (lambda (x) (equal? item (cadr x))) 291 (g-map list 292 (gen-keys sequence) 293 (gen-elts sequence))))) 294 (map car found-items))) 285 295 286 296 (define (array-shape arr) … … 296 306 ;; but lisp is 0 based, so add 1! 297 307 (define (average-rank value sorted-values) 298 (let ((first (position value sorted-values)) 299 (last (- (- (length sorted-values) 1) 300 (position value (reverse sorted-values))))) 301 (+ 1 (if (= first last) 302 first 303 (/ (+ first last) 2))))) 308 (let* ((idxs (positions value sorted-values))) 309 (let ((result (+ 1 (mean idxs)))) 310 result))) 304 311 305 312 ;; BIN-AND-COUNT … … 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 (gen-elts sequence))) 414 (reverse (g-reduce (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 (map-elts (lambda (w) (expt (random-uniform) (/ 1 w))) weights)) 464 (sorted-items (sort (lambda (x y) (> (car (cadr x)) (car (cadr y))))465 ( zip-elts keys sequence))))474 (sorted-items (sort (lambda (x y) (> (car x) (car y))) 475 (g-map list (gen-elts keys) (gen-elts sequence))))) 466 476 (elt-take sorted-items 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 ((count-table (make-hash-table eqv?)) 493 503 (modes (make-parameter '())) 494 504 (mode-count (make-parameter 0))) 495 505 (for-each-elt 496 (lambda (item) 506 (lambda (item) 497 507 (hash-table-set! count-table 498 508 item 499 (+ 1 (hash-table-ref count-table item (lambda () 0)))))509 (+ 1 (hash-table-ref/default count-table item 0)))) 500 510 sequence) 501 511 (for-each 502 512 (lambda (key) 503 (let ((val (hash-table-ref count-table key (lambda () #f))))513 (let ((val (hash-table-ref/default count-table key #f))) 504 514 (cond ((> val (mode-count)) ; keep mode 505 515 (modes (list key)) … … 570 580 (define (standard-error-of-the-mean sequence) 571 581 (/ (standard-deviation sequence) 572 (sqrt ( lengthsequence))))582 (sqrt (size sequence)))) 573 583 574 584 ;; MEAN-SD-N … … 578 588 (values (mean sequence) 579 589 (standard-deviation sequence) 580 ( lengthsequence)))590 (size sequence))) 581 591 582 592 ;; --------------------------------------------------------------------------- … … 796 806 (define (normal-variance-ci-on-sequence sequence alpha) 797 807 (let ((variance (variance sequence)) 798 (n ( lengthsequence)))808 (n (size sequence))) 799 809 (normal-variance-ci variance n alpha))) 800 810 … … 809 819 (define (normal-sd-ci-on-sequence sequence alpha) 810 820 (let ((sd (standard-deviation sequence)) 811 (n ( lengthsequence)))821 (n (size sequence))) 812 822 (normal-sd-ci sd n alpha))) 813 823 … … 846 856 (tails (get-keyword #:tails args (lambda () ':both)))) 847 857 (let ((x-bar (mean sequence)) 848 (n ( lengthsequence)))858 (n (size sequence))) 849 859 (z-test x-bar n #:mu mu #:sigma sigma #:tails tails)))) 850 860 … … 1145 1155 (tails (get-keyword #:tails args (lambda () ':both)))) 1146 1156 (let* ((differences (map-elts - sequence1 sequence2)) 1147 (plus-count (reduce (lambda ( axx) (if (positive? x) (+ 1 ax) ax)) 0 differences))1148 (minus-count (reduce (lambda ( axx) (if (negative? x) (+ 1 ax) ax)) 0 differences)))1157 (plus-count (reduce (lambda (x ax) (if (positive? x) (+ 1 ax) ax)) 0 differences)) 1158 (minus-count (reduce (lambda (x ax) (if (negative? x) (+ 1 ax) ax)) 0 differences))) 1149 1159 (sign-test plus-count minus-count :exact? exact :tails tails)))) 1150 1160 … … 1466 1476 (y-bar (mean ys)) 1467 1477 (n (size points)) 1468 (Lxx (reduce + 0 1469 (map (lambda (xi) (square (- xi x-bar))) xs)))1470 (Lyy (reduce + 0 1471 (map (lambda (yi) (square (- yi y-bar))) ys)))1472 (Lxy (reduce + 0 1478 (Lxx (reduce + 0.0 1479 (map-elts (lambda (xi) (square (- xi x-bar))) xs))) 1480 (Lyy (reduce + 0.0 1481 (map-elts (lambda (yi) (square (- yi y-bar))) ys))) 1482 (Lxy (reduce + 0.0 1473 1483 (map-elts (lambda (point) (let ((xi (car point)) 1474 (yi (ca r point)))1484 (yi (cadr point))) 1475 1485 (* (- xi x-bar) (- yi y-bar)))) 1476 1486 points))) … … 1542 1552 (sorted-xis (sort (lambda (xi x yi y) (< x y)) xis)) 1543 1553 (sorted-yis (sort (lambda (xi x yi y) (< x y)) yis)) 1544 (average-x-ranks (map (lambda (x) (average-rank x sorted-xis)) xis))1545 (average-y-ranks (map (lambda (y) (average-rank y sorted-yis)) yis))1554 (average-x-ranks (map-elts (lambda (x) (average-rank x sorted-xis)) xis)) 1555 (average-y-ranks (map-elts (lambda (y) (average-rank y sorted-yis)) yis)) 1546 1556 (mean-x-rank (mean average-x-ranks)) 1547 1557 (mean-y-rank (mean average-y-ranks)) -
release/5/statistics/trunk/statistics.scm
r36303 r36391 289 289 first 290 290 (/ (+ first last) 2))))) 291 (define (average-rank value sorted-values) 292 (let ((first (position value sorted-values)) 293 (last (- (- (length sorted-values) 1) 294 (position value (reverse sorted-values))))) 295 (let ((result (+ 1 (if (= first last) 296 first 297 (/ (+ first last) 2))))) 298 (print "average-rank: value = " value " first = " first " last = " last " result = " result) 299 result))) 291 300 292 301 ;; BIN-AND-COUNT -
release/5/yasos/trunk/collections.scm
r36388 r36391 3 3 4 4 (collection? random-access? empty? size gen-keys gen-elts 5 do-elts do-keys do-items do-items-while5 do-elts do-keys do-items 6 6 map-elts map-keys map-items 7 7 for-each-key for-each-elt elt-ref elt-set! elt-take elt-drop 8 reduce reduce* reduce-items reduce-items* any-elt? every-elt? zip-elts sort! sort 9 make-vec-gen-elts list-gen-elts vector-gen-elts 10 string-gen-elts hash-table-gen-elts 8 reduce reduce* reduce-items reduce-items* sort! sort 9 make-vector-generator list->generator vector->generator 10 string->generator hash-table->generator 11 g-map g-reduce g-find g-filter 11 12 ) 12 13 13 (import scheme (chicken base) (chicken format) srfi-69 14 (import scheme (chicken base) (chicken format) srfi-69 14 15 (except yasos object object-with-ancestors)) 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 ;; (do-elts proc coll+) -- apply proc element-wise 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 ;; elt-drop 56 55 ;; 57 ;;============================== 56 ;;============================== 57 58 (define *eof-object* (read (open-input-string ""))) 59 (define (eof-object) *eof-object*) 60 61 (define (list-any 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 (list-zip list1 . more-lists) (apply map list list1 more-lists)) … … 144 153 )) 145 154 146 (define-operation (gen-elts <collection>);; return element generator155 (define-operation (gen-elts <collection>);; return SRFI-121 element generator 147 156 ;; default behavior 148 (cond ;; see utilities, below, for generators149 ((vector? <collection>) (vector- gen-elts<collection>))150 ((list? <collection>) (list- gen-elts<collection>))151 ((string? <collection>) (string- gen-elts<collection>))152 ((hash-table? <collection>) (hash-table- gen-elts<collection>))157 (cond 158 ((vector? <collection>) (vector->generator <collection>)) 159 ((list? <collection>) (list->generator <collection>)) 160 ((string? <collection>) (string->generator <collection>)) 161 ((hash-table? <collection>) (hash-table->generator <collection>)) 153 162 (else 154 163 (error "operation not supported: gen-elts ")) … … 166 175 (index (add1 i)) 167 176 i) 168 (else (e rror "no more keys in generator"))177 (else (eof-object)) 169 178 )) 170 179 )) 171 180 ) 172 181 ((hash-table? collection) 173 (list- gen-elts(hash-table-keys collection)))182 (list->generator (hash-table-keys collection))) 174 183 (else 175 184 (error "operation not handled: gen-keys " collection)) … … 218 227 ) ) 219 228 ) ) 220 221 (define (do-items-while <proc> . <collections>)222 (let ( (max+1 (size (car <collections>)))223 (elt-generators (map gen-elts <collections>))224 (key-generators (map gen-keys <collections>)) )225 (let loop ( (counter 0) )226 (cond227 ((< counter max+1)228 (let ((res (apply <proc> (list-zip (map (lambda (g) (g)) key-generators)229 (map (lambda (g) (g)) elt-generators)))))230 (if res (loop (add1 counter)))231 ))232 (else 'unspecific) ; done233 ))234 ))235 229 236 230 (define (map-elts <proc> . <collections>) … … 281 275 ) ) 282 276 283 (define-operation (for-each-key < collection> <proc>)277 (define-operation (for-each-key <proc> <collection>) 284 278 ;; default 285 279 (do-keys <proc> <collection>) ;; talk about lazy! 286 280 ) 287 281 288 (define-operation (for-each-elt < collection> <proc>)282 (define-operation (for-each-elt <proc> <collection>) 289 283 (do-elts <proc> <collection>) 290 284 ) … … 298 292 (cond 299 293 ((< count max+1) 300 (ax (apply <proc> ( cons (ax) (map (lambda (g) (g)) elt-generators))))294 (ax (apply <proc> (append (map (lambda (g) (g)) elt-generators) (list (ax))))) 301 295 (loop (add1 count)) 302 296 ) … … 315 309 (cond 316 310 ((< count max+1) 317 (ax (apply <proc> (cons (ax) (list-zip (map (lambda (g) (g)) key-generators) 318 (map (lambda (g) (g)) elt-generators))))) 311 (ax (apply <proc> (append (list-zip (map (lambda (g) (g)) key-generators) 312 (map (lambda (g) (g)) elt-generators)) 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)) elt-generators)))) 330 (let ((args (append (map (lambda (g) (g)) elt-generators) (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) (list-zip (map (lambda (g) (g)) key-generators) 353 (map (lambda (g) (g)) elt-generators))))) 348 (ax (list (apply <proc> (append (list-zip (map (lambda (g) (g)) key-generators) 349 (map (lambda (g) (g)) elt-generators)) 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 (every-elt? <pred?> . <collections>) 362 (let ( (max+1 (size (car <collections>))) 363 (generators (map gen-elts <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 (any-elt? <pred?> . <collections>) 378 (let ( (max+1 (size (car <collections>))) 379 (generators (map gen-elts <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- gen-elts<list>)359 (define (list->generator <list>) 397 360 (let ((l (make-parameter <list>))) 398 361 (lambda () 399 362 (if (null? (l)) 400 (e rror "no more list elements in generator")363 (eof-object) 401 364 (let ( (elt (car (l))) ) 402 365 (l (cdr (l))) … … 405 368 ) 406 369 407 (define (make-vec -gen-elts<accessor>)370 (define (make-vector-generator <accessor>) 408 371 (lambda (vec) 409 372 (let ( (max+1 (size vec)) … … 416 379 (<accessor> vec i) 417 380 ) 418 (else #f)381 (else (eof-object)) 419 382 )) 420 383 )) 421 384 )) 422 385 423 (define vector- gen-elts (make-vec-gen-eltsvector-ref))424 425 (define string- gen-elts (make-vec-gen-eltsstring-ref))426 427 (define (hash-table- gen-eltstable)386 (define vector->generator (make-vector-generator vector-ref)) 387 388 (define string->generator (make-vector-generator string-ref)) 389 390 (define (hash-table->generator table) 428 391 (let ((keys (make-parameter (hash-table-keys table)))) 429 392 (lambda () 430 (cond ((null? keys) #f)393 (cond ((null? keys) (eof-object)) 431 394 (else (let ((res (hash-table-ref table (car (keys))))) 432 395 (keys (cdr (keys))) … … 434 397 )) 435 398 )) 436 437 438 (define (zip-elts <collection> . <rest>)439 (let* (440 (<collections> (cons <collection> <rest>))441 (max+1 (- (size (car <collections>)) 1))442 (generators (map gen-elts <collections>))443 (result (make-vector (+ 1 max+1)))444 )445 (let loop ( (count 0) )446 (cond447 ((< count max+1)448 (vector-set! 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 (make-vector n)) 571 (b (make-vector n))) 514 (a (make-vector n))) 572 515 (do-items (lambda (item) (vector-set! a (car item) (cadr item))) x) 573 (let recur ((m 1)) 574 (if (< m n) 575 (let inner-recur ((p 0)) 576 (if (< p (- n m)) 577 (let ((q (+ p m)) 578 (r (min (+ p (* 2 m)) n))) 579 (vector-merge! elt< a p q r b p) 580 (vector-blit! b p r a p) 581 (inner-recur (+ p (* 2 m))) 582 ) 583 (recur (* m 2)))) 584 b)) 516 (if (< n 2) 517 a 518 (let ((b (make-vector n))) 519 (let recur ((m 1)) 520 (if (< m n) 521 (let inner-recur ((p 0)) 522 (if (< p (- n m)) 523 (let ((q (+ p m)) 524 (r (min (+ p (* 2 m)) n))) 525 (vector-merge! elt< a p q r b p) 526 (vector-blit! b p r a p) 527 (inner-recur (+ p (* 2 m))) 528 ) 529 (recur (* m 2)))) 530 b)) 531 )) 585 532 )) 586 533 587 534 535 ;; Generator combinators 536 (define (g-map f . gs) 537 (lambda () 538 (let ((vs (map (lambda (g) (g)) gs))) 539 (if (list-any eof-object? vs) 540 (eof-object) 541 (apply f vs)) 542 )) 543 ) 544 545 546 (define (g-reduce f seed . gs) 547 (define (inner-fold seed) 548 (let ((vs (map (lambda (g) (g)) gs))) 549 (if (list-any eof-object? vs) 550 seed 551 (inner-fold (apply f (append vs (list seed))))))) 552 (inner-fold seed)) 553 554 555 (define (g-find pred g) 556 (let loop ((v (g))) 557 (if (or (pred v) (eof-object? v)) 558 v 559 (loop (g))) 560 )) 561 562 (define (g-filter pred g) 563 (let loop ((v (g)) (res '())) 564 (cond ((eof-object? 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 ((gen-keys self) (list- gen-elts(map car table)))309 ((gen-elts self) (list- gen-elts(map cdr table)))308 ((gen-keys self) (list->generator (map car table))) 309 ((gen-elts self) (list->generator (map cdr table))) 310 310 ((for-each-key self proc) 311 311 (for-each (lambda (bucket) (proc (car bucket))) table) … … 320 320 (test-group "collections" 321 321 322 (for-each-elt 323 (lambda (item) 324 (print "item: " item)) 325 '(1 2 3)) 322 326 (test-assert (collection? t)) 323 327 (test-assert (empty? t)) … … 332 336 (test "map-elts" #(2 1) (map-elts identity t)) 333 337 (test "reduce" 3 (reduce + 0 t)) 334 (test "reduce-items" 3 (reduce-items (lambda ( ax item)338 (test "reduce-items" 3 (reduce-items (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.