Changeset 36388 in project


Ignore:
Timestamp:
08/25/18 03:34:28 (4 weeks ago)
Author:
iraikov
Message:

WIP: porting statistics to use yasos collections

Location:
release/5
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/5/statistics/branches/collections/statistics.scm

    r36371 r36388  
    8080    permutations
    8181    random-normal
    82     random-pick
    8382    random-sample
    8483    random-weighted-sample
     
    179178
    180179  (import scheme (chicken base) (chicken foreign) (chicken format)
    181           (chicken keyword) (prefix (only srfi-1 fold iota reverse) list.)
     180          (chicken keyword) (prefix (chicken sort) list.)
     181          (prefix (only srfi-1 fold iota filter find delete-duplicates every) list.)
    182182          (only srfi-13 string<) srfi-25 srfi-69 vector-lib
    183           yasos yasos-collections data-series)
     183          yasos yasos-collections)
    184184
    185185  ;; ---------------------------------------------------------------------------
     
    279279                          (if res (set! index (car x)))
    280280                          (not res)))
    281                       sequences)
     281                      sequence)
    282282      (if (> index -1)
    283283        index
     
    319319            (vector-set! bins
    320320                         bin
    321                          (length
    322                            (filter
    323                              (lambda (x) (and (>= x (+ smallest (* bin increment)))
    324                                               (< x  (+ smallest (* (+ 1 bin) increment)))))
    325                              sequence)))
     321                         (reduce
     322                          (lambda (ax x)
     323                            (if (and (>= x (+ smallest (* bin increment)))
     324                                     (< x  (+ smallest (* (+ 1 bin) increment))))
     325                                (+ 1 ax) ax)) 0
     326                                sequence))
    326327            (loop (+ 1 bin)))))))
    327328
     
    403404    (if (empty? sequence)
    404405        0
    405         (list.reverse (reduce* (lambda (x ax) (cons (+ x (car ax)) ax))
    406                                sequence))))
     406        (reverse (reduce* (lambda (ax x) (cons (+ x (car ax)) ax))
     407                          sequence))))
    407408
    408409  (define (sign x)
     
    462463             (let* ((keys (map-elts (lambda (w) (expt (random-uniform) (/ 1 w))) weights))
    463464                    (sorted-items (sort (lambda (x y) (> (car (cadr x)) (car (cadr y))))
    464                                         (zip keys sequence))))
     465                                        (zip-elts keys sequence))))
    465466               (elt-take sorted-items m))
    466467             ))
     
    476477    (if (empty? sequence)
    477478      0
    478       (/ (reduce (lambda (x ax) (+ (cadr x) ax)) 0 sequence) (size sequence))))
     479      (/ (reduce + 0 sequence) (size sequence))))
    479480
    480481  ;; MEDIAN
     
    490491      (error "Mode: Sequence must not be null")
    491492      (let ((count-table (make-hash-table eqv?))
    492             (modes '())
    493             (mode-count 0))
     493            (modes (make-parameter '()))
     494            (mode-count (make-parameter 0)))
    494495        (for-each-elt
    495496         (lambda (item)
     
    501502         (lambda (key)
    502503           (let ((val (hash-table-ref count-table key (lambda () #f))))
    503              (cond ((> val mode-count) ; keep mode
    504                     (set! modes (list key))
    505                     (set! mode-count val))
    506                    ((= val mode-count) ; store multiple modes
    507                     (set! modes (cons key modes))))))
     504             (cond ((> val (mode-count)) ; keep mode
     505                    (modes (list key))
     506                    (mode-count val))
     507                   ((= val (mode-count)) ; store multiple modes
     508                    (modes (cons key (modes)))))))
    508509         (hash-table-keys count-table))
    509         (cond ((every number? modes) (set! modes (sort < modes)))
    510               ((every string? modes) (set! modes (sort string< modes)))
     510        (cond ((list.every number? (modes)) (modes (list.sort (modes) <)))
     511              ((list.every string? (modes)) (modes (list.sort (modes) string< )))
    511512              )
    512         (values modes mode-count))))
     513        (values (modes) (mode-count)))))
    513514
    514515  ;; GEOMETRIC-MEAN
     
    549550      (error "variance: sequence must contain at least two elements")
    550551      (let ((mean1 (mean sequence)))
    551         (/ (reduce (lambda (x ax) (+ (cadr x) ax)) 0
     552        (/ (reduce + 0
    552553                   (map (lambda (x) (square (- mean1 x))) sequence))
    553554           (- (size sequence) 1)))))
     
    11431144    (let ((exact (get-keyword #:exact? args (lambda () #f)))
    11441145          (tails (get-keyword #:tails args (lambda () ':both))))
    1145       (let* ((differences (map - sequence1 sequence2))
    1146              (plus-count (length (filter positive? differences)))
    1147              (minus-count (length (filter negative? differences))))
     1146      (let* ((differences (map-elts - sequence1 sequence2))
     1147             (plus-count (reduce (lambda (ax x) (if (positive? x) (+ 1 ax) ax)) 0 differences))
     1148             (minus-count (reduce (lambda (ax x) (if (negative? x) (+ 1 ax) ax)) 0 differences)))
    11481149        (sign-test plus-count minus-count :exact? exact :tails tails))))
    11491150
     
    11591160  (define (wilcoxon-signed-rank-test differences . args)
    11601161    (let ((tails (get-keyword #:tails args (lambda () ':both))))
    1161       (let* ((nonzero-differences (filter (lambda (n) (not (zero? n))) differences))
    1162              (sorted-items (sort (lambda (x y) (< (car x) (car y)))
    1163                                  (map-items (lambda (dif)
    1164                                               (list (abs dif)
    1165                                                     (sign dif)))
    1166                                             nonzero-differences)))
    1167              (distinct-values (delete-duplicates (map car sorted-list)))
     1162      (let* ((nonzero-differences (list.filter (lambda (n) (not (zero? n))) differences))
     1163             (sorted-list (list.sort (map (lambda (dif) (list (abs dif) (sign dif)))
     1164                                          nonzero-differences)
     1165                                     (lambda (x y) (< (car x) (car y)))))
     1166             (distinct-values (list.delete-duplicates (map car sorted-list)))
    11681167             (ties '()))
    11691168        (when (< (size nonzero-differences) 16)
     
    11761175                          (last (position value (reverse (map car sorted-list)))))
    11771176                      (if (= first last)
    1178                         (append (find (lambda (item) (= (car item) value))
    1179                                       sorted-list)
    1180                                 (list (+ 1 first)))
    1181                         (let ((number-tied (+ 1 (- last first)))
    1182                               (avg-rank (+ 1 (/ (+ first last) 2)))) ; + 1 since 0 based
    1183                           (set! ties (cons number-tied ties))
    1184                           (let loop ((i 0)
    1185                                      (result '()))
    1186                             (if (= i number-tied)
    1187                               (reverse result)
    1188                               (loop (+ 1 i)
    1189                                     (cons (cons (list-ref sorted-list (+ first i))
    1190                                                 (list avg-rank))
    1191                                           result))))))))
     1177                          (append (list.find (lambda (item) (= (car item) value))
     1178                                             sorted-list)
     1179                                  (list (+ 1 first)))
     1180                          (let ((number-tied (+ 1 (- last first)))
     1181                                (avg-rank (+ 1 (/ (+ first last) 2)))) ; + 1 since 0 based
     1182                            (set! ties (cons number-tied ties))
     1183                            (let loop ((i 0)
     1184                                       (result '()))
     1185                              (if (= i number-tied)
     1186                                  (reverse result)
     1187                                  (loop (+ 1 i)
     1188                                        (cons (cons (list-ref sorted-list (+ first i))
     1189                                                    (list avg-rank))
     1190                                              result))))))))
    11921191                  distinct-values)
    11931192        (set! ties (reverse ties))
    11941193        (let* ((direction (if (eq? tails ':negative) -1 1))
    1195                (r1 (fold + 0
    1196                          (map (lambda (entry)
    1197                                 (if (= (cadr entry) direction)
    1198                                   (caddr entry)
    1199                                   0))
    1200                               sorted-list)))
     1194               (r1 (list.fold + 0
     1195                              (map (lambda (entry)
     1196                                     (if (= (cadr entry) direction)
     1197                                         (caddr entry)
     1198                                         0))
     1199                                   sorted-list)))
    12011200               (n (length nonzero-differences))
    12021201               (expected-r1 (/ (* n (+ 1 n)) 4))
    12031202               (ties-factor (if ties
    1204                               (/ (fold + 0
    1205                                        (map (lambda (ti) (- (* ti ti ti) ti))
    1206                                             ties))
     1203                              (/ (list.fold + 0
     1204                                            (map (lambda (ti) (- (* ti ti ti) ti))
     1205                                                 ties))
    12071206                                 48)
    12081207                              0))
     
    12921291      (let* ((ns (map + row1-counts row2-counts))
    12931292             (p-hats (map / row1-counts ns))
    1294              (n (fold + 0 ns))
    1295              (p-bar (/ (fold + 0 row1-counts) n))
     1293             (n (list.fold + 0 ns))
     1294             (p-bar (/ (list.fold + 0 row1-counts) n))
    12961295             (q-bar (- 1 p-bar))
    12971296             (s-bar (mean scores))
    1298              (a (fold + 0.0
    1299                       (map (lambda (p-hat ni s)
    1300                              (* ni (- p-hat p-bar) (- s s-bar)))
    1301                            p-hats ns scores)))
    1302              (b (* 1.0 p-bar q-bar (- (fold + 0 (map (lambda (ni s) (* ni (square s)))
    1303                                                  ns scores))
    1304                                   (/ (square (fold + 0 (map (lambda (ni s) (* ni s))
    1305                                                             ns scores)))
    1306                                      n))))
     1297             (a (list.fold + 0.0
     1298                           (map (lambda (p-hat ni s)
     1299                                  (* ni (- p-hat p-bar) (- s s-bar)))
     1300                                p-hats ns scores)))
     1301             (b (* 1.0 p-bar q-bar (- (list.fold + 0 (map (lambda (ni s) (* ni (square s)))
     1302                                                          ns scores))
     1303                                      (/ (square (list.fold + 0 (map (lambda (ni s) (* ni s))
     1304                                                                     ns scores)))
     1305                                         n))))
    13071306             (x2 (/ (square a) b))
    13081307             (significance (- 1 (chi-square-cdf x2 1))))
     
    14621461    (unless (> (size points) 2)
    14631462      (error "Requires at least three points"))
    1464     (let ((xs (elt-map car points))
    1465           (ys (elt-map cadr points)))
     1463    (let ((xs (map-elts car points))
     1464          (ys (map-elts cadr points)))
    14661465      (let* ((x-bar (mean xs))
    14671466             (y-bar (mean ys))
     
    14721471                        (map (lambda (yi) (square (- yi y-bar))) ys)))
    14731472             (Lxy (reduce + 0
    1474                           (elt-map (lambda (point) (let ((xi (car point))
    1475                                                          (yi (car point)))
    1476                                                      (* (- xi x-bar) (- yi y-bar))))
     1473                          (map-elts (lambda (point) (let ((xi (car point))
     1474                                                          (yi (car point)))
     1475                                                      (* (- xi x-bar) (- yi y-bar))))
    14771476                             points)))
    14781477             (b (if (zero? Lxx) 0 (/ Lxy Lxx)))
     
    14911490  ;; Also called Pearson Correlation
    14921491  (define (correlation-coefficient points)
    1493     (let* ((xs (elt-map car points))
    1494            (ys (elt-map cadr points))
     1492    (let* ((xs (map-elts car points))
     1493           (ys (map-elts cadr points))
    14951494           (x-bar (mean xs))
    14961495           (y-bar (mean ys)))
    1497       (/ (reduce + 0 (elt-map (lambda (point)
     1496      (/ (reduce + 0 (map-elts (lambda (point)
    14981497                                (let ((xi (car point))
    14991498                                      (yi (cadr point)))
    15001499                                  (* (- xi x-bar) (- yi y-bar))))
    15011500                              points))
    1502          (sqrt (* (reduce + 0 (elt-map (lambda (xi) (square (- xi x-bar)))
     1501         (sqrt (* (reduce + 0 (map-elts (lambda (xi) (square (- xi x-bar)))
    15031502                                       xs))
    1504                   (reduce + 0 (elt-map (lambda (yi) (square (- yi y-bar)))
     1503                  (reduce + 0 (map-elts (lambda (yi) (square (- yi y-bar)))
    15051504                                       ys)))))))
    15061505
     
    15381537  ;; and its significance.
    15391538  (define (spearman-rank-correlation points)
    1540     (let ((xis (elt-map car points))
    1541           (yis (elt-map cadr points)))
     1539    (let ((xis (map-elts car points))
     1540          (yis (map-elts cadr points)))
    15421541      (let* ((n (size points))
    15431542             (sorted-xis (sort (lambda (xi x yi y) (< x y)) xis))
     
    15481547             (mean-y-rank (mean average-y-ranks))
    15491548             (Lxx (reduce + 0
    1550                         (elt-map (lambda (xi-rank) (square (- xi-rank mean-x-rank)))
     1549                        (map-elts (lambda (xi-rank) (square (- xi-rank mean-x-rank)))
    15511550                                 average-x-ranks)))
    15521551             (Lyy (reduce + 0
    1553                           (elt-map (lambda (yi-rank) (square (- yi-rank mean-y-rank)))
     1552                          (map-elts (lambda (yi-rank) (square (- yi-rank mean-y-rank)))
    15541553                                   average-y-ranks)))
    15551554             (Lxy (reduce + 0
    1556                           (elt-map (lambda (xi-rank yi-rank)
     1555                          (map-elts (lambda (xi-rank yi-rank)
    15571556                                     (* (- xi-rank mean-x-rank)
    15581557                                        (- yi-rank mean-y-rank)))
  • release/5/yasos/trunk/collections.scm

    r36387 r36388  
    298298       (cond
    299299        ((< count max+1)
    300          (ax (apply <proc> (ax) (map (lambda (g) (g)) elt-generators)))
     300         (ax (apply <proc> (cons (ax) (map (lambda (g) (g)) elt-generators))))
    301301         (loop (add1 count))
    302302         )
     
    315315       (cond
    316316        ((< count max+1)
    317          (ax (apply <proc> (ax) (list-zip (map (lambda (g) (g)) key-generators)
    318                                           (map (lambda (g) (g)) elt-generators))))
     317         (ax (apply <proc> (cons (ax) (list-zip (map (lambda (g) (g)) key-generators)
     318                                                  (map (lambda (g) (g)) elt-generators)))))
    319319         (loop (add1 count))
    320320         )
     
    326326
    327327 (define (reduce* <proc> . <collections>)
    328    (let* ( (max+1 (size (car <collections>)))
     328   (let* ( (max+1 (- (size (car <collections>)) 1))
    329329           (elt-generators (map gen-elts <collections>))
    330330           (ax (make-parameter (map (lambda (g) (g)) elt-generators)))
     
    333333       (cond
    334334        ((< count max+1)
    335          (ax (apply <proc> (ax) (map (lambda (g) (g)) elt-generators)))
     335         (ax (apply <proc> (append (ax) (map (lambda (g) (g)) elt-generators))))
    336336         (loop (add1 count))
    337337         )
     
    341341
    342342 (define (reduce-items* <proc> . <collections>)
    343    (let* ( (max+1 (size (car <collections>)))
     343   (let* ( (max+1 (- (size (car <collections>)) 1))
    344344           (key-generators (map gen-keys <collections>))
    345345           (elt-generators (map gen-elts <collections>))
     
    350350       (cond
    351351        ((< count max+1)
    352          (ax (apply <proc> (ax) (list-zip (map (lambda (g) (g)) key-generators)
    353                                           (map (lambda (g) (g)) elt-generators))))
     352         (ax (apply <proc> (append (ax) (list-zip (map (lambda (g) (g)) key-generators)
     353                                                  (map (lambda (g) (g)) elt-generators)))))
    354354         (loop (add1 count))
    355355         )
Note: See TracChangeset for help on using the changeset viewer.