Changeset 36388 in project
 Timestamp:
 08/25/18 03:34:28 (4 weeks ago)
 Location:
 release/5
 Files:

 2 edited
Legend:
 Unmodified
 Added
 Removed

release/5/statistics/branches/collections/statistics.scm
r36371 r36388 80 80 permutations 81 81 randomnormal 82 randompick83 82 randomsample 84 83 randomweightedsample … … 179 178 180 179 (import scheme (chicken base) (chicken foreign) (chicken format) 181 (chicken keyword) (prefix (only srfi1 fold iota reverse) list.) 180 (chicken keyword) (prefix (chicken sort) list.) 181 (prefix (only srfi1 fold iota filter find deleteduplicates every) list.) 182 182 (only srfi13 string<) srfi25 srfi69 vectorlib 183 yasos yasoscollections dataseries)183 yasos yasoscollections) 184 184 185 185 ;;  … … 279 279 (if res (set! index (car x))) 280 280 (not res))) 281 sequence s)281 sequence) 282 282 (if (> index 1) 283 283 index … … 319 319 (vectorset! bins 320 320 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)) 326 327 (loop (+ 1 bin))))))) 327 328 … … 403 404 (if (empty? sequence) 404 405 0 405 ( list.reverse (reduce* (lambda (x ax) (cons (+ x (car ax)) ax))406 406 (reverse (reduce* (lambda (ax x) (cons (+ x (car ax)) ax)) 407 sequence)))) 407 408 408 409 (define (sign x) … … 462 463 (let* ((keys (mapelts (lambda (w) (expt (randomuniform) (/ 1 w))) weights)) 463 464 (sorteditems (sort (lambda (x y) (> (car (cadr x)) (car (cadr y)))) 464 (zip keys sequence))))465 (zipelts keys sequence)))) 465 466 (elttake sorteditems m)) 466 467 )) … … 476 477 (if (empty? sequence) 477 478 0 478 (/ (reduce (lambda (x ax) (+ (cadr x) ax))0 sequence) (size sequence))))479 (/ (reduce + 0 sequence) (size sequence)))) 479 480 480 481 ;; MEDIAN … … 490 491 (error "Mode: Sequence must not be null") 491 492 (let ((counttable (makehashtable eqv?)) 492 (modes '())493 (modecount 0))493 (modes (makeparameter '())) 494 (modecount (makeparameter 0))) 494 495 (foreachelt 495 496 (lambda (item) … … 501 502 (lambda (key) 502 503 (let ((val (hashtableref counttable key (lambda () #f)))) 503 (cond ((> val modecount) ; keep mode504 ( set!modes (list key))505 ( set!modecount val))506 ((= val modecount) ; store multiple modes507 ( set! modes (cons key modes))))))504 (cond ((> val (modecount)) ; keep mode 505 (modes (list key)) 506 (modecount val)) 507 ((= val (modecount)) ; store multiple modes 508 (modes (cons key (modes))))))) 508 509 (hashtablekeys counttable)) 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< ))) 511 512 ) 512 (values modes modecount))))513 (values (modes) (modecount))))) 513 514 514 515 ;; GEOMETRICMEAN … … 549 550 (error "variance: sequence must contain at least two elements") 550 551 (let ((mean1 (mean sequence))) 551 (/ (reduce (lambda (x ax) (+ (cadr x) ax))0552 (/ (reduce + 0 552 553 (map (lambda (x) (square ( mean1 x))) sequence)) 553 554 ( (size sequence) 1))))) … … 1143 1144 (let ((exact (getkeyword #:exact? args (lambda () #f))) 1144 1145 (tails (getkeyword #:tails args (lambda () ':both)))) 1145 (let* ((differences (map  sequence1 sequence2))1146 (pluscount ( length (filter positive? differences)))1147 (minuscount ( length (filter negative? differences))))1146 (let* ((differences (mapelts  sequence1 sequence2)) 1147 (pluscount (reduce (lambda (ax x) (if (positive? x) (+ 1 ax) ax)) 0 differences)) 1148 (minuscount (reduce (lambda (ax x) (if (negative? x) (+ 1 ax) ax)) 0 differences))) 1148 1149 (signtest pluscount minuscount :exact? exact :tails tails)))) 1149 1150 … … 1159 1160 (define (wilcoxonsignedranktest differences . args) 1160 1161 (let ((tails (getkeyword #:tails args (lambda () ':both)))) 1161 (let* ((nonzerodifferences (filter (lambda (n) (not (zero? n))) differences)) 1162 (sorteditems (sort (lambda (x y) (< (car x) (car y))) 1163 (mapitems (lambda (dif) 1164 (list (abs dif) 1165 (sign dif))) 1166 nonzerodifferences))) 1167 (distinctvalues (deleteduplicates (map car sortedlist))) 1162 (let* ((nonzerodifferences (list.filter (lambda (n) (not (zero? n))) differences)) 1163 (sortedlist (list.sort (map (lambda (dif) (list (abs dif) (sign dif))) 1164 nonzerodifferences) 1165 (lambda (x y) (< (car x) (car y))))) 1166 (distinctvalues (list.deleteduplicates (map car sortedlist))) 1168 1167 (ties '())) 1169 1168 (when (< (size nonzerodifferences) 16) … … 1176 1175 (last (position value (reverse (map car sortedlist))))) 1177 1176 (if (= first last) 1178 (append (find (lambda (item) (= (car item) value))1179 sortedlist)1180 (list (+ 1 first)))1181 (let ((numbertied (+ 1 ( last first)))1182 (avgrank (+ 1 (/ (+ first last) 2)))) ; + 1 since 0 based1183 (set! ties (cons numbertied ties))1184 (let loop ((i 0)1185 (result '()))1186 (if (= i numbertied)1187 (reverse result)1188 (loop (+ 1 i)1189 (cons (cons (listref sortedlist (+ first i))1190 (list avgrank))1191 result))))))))1177 (append (list.find (lambda (item) (= (car item) value)) 1178 sortedlist) 1179 (list (+ 1 first))) 1180 (let ((numbertied (+ 1 ( last first))) 1181 (avgrank (+ 1 (/ (+ first last) 2)))) ; + 1 since 0 based 1182 (set! ties (cons numbertied ties)) 1183 (let loop ((i 0) 1184 (result '())) 1185 (if (= i numbertied) 1186 (reverse result) 1187 (loop (+ 1 i) 1188 (cons (cons (listref sortedlist (+ first i)) 1189 (list avgrank)) 1190 result)))))))) 1192 1191 distinctvalues) 1193 1192 (set! ties (reverse ties)) 1194 1193 (let* ((direction (if (eq? tails ':negative) 1 1)) 1195 (r1 ( fold + 01196 (map (lambda (entry)1197 (if (= (cadr entry) direction)1198 (caddr entry)1199 0))1200 sortedlist)))1194 (r1 (list.fold + 0 1195 (map (lambda (entry) 1196 (if (= (cadr entry) direction) 1197 (caddr entry) 1198 0)) 1199 sortedlist))) 1201 1200 (n (length nonzerodifferences)) 1202 1201 (expectedr1 (/ (* n (+ 1 n)) 4)) 1203 1202 (tiesfactor (if ties 1204 (/ ( fold + 01205 (map (lambda (ti) ( (* ti ti ti) ti))1206 ties))1203 (/ (list.fold + 0 1204 (map (lambda (ti) ( (* ti ti ti) ti)) 1205 ties)) 1207 1206 48) 1208 1207 0)) … … 1292 1291 (let* ((ns (map + row1counts row2counts)) 1293 1292 (phats (map / row1counts ns)) 1294 (n ( fold + 0 ns))1295 (pbar (/ ( fold + 0 row1counts) n))1293 (n (list.fold + 0 ns)) 1294 (pbar (/ (list.fold + 0 row1counts) n)) 1296 1295 (qbar ( 1 pbar)) 1297 1296 (sbar (mean scores)) 1298 (a ( fold + 0.01299 (map (lambda (phat ni s)1300 (* ni ( phat pbar) ( s sbar)))1301 phats ns scores)))1302 (b (* 1.0 pbar qbar ( ( 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 (phat ni s) 1299 (* ni ( phat pbar) ( s sbar))) 1300 phats ns scores))) 1301 (b (* 1.0 pbar qbar ( (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)))) 1307 1306 (x2 (/ (square a) b)) 1308 1307 (significance ( 1 (chisquarecdf x2 1)))) … … 1462 1461 (unless (> (size points) 2) 1463 1462 (error "Requires at least three points")) 1464 (let ((xs ( eltmapcar points))1465 (ys ( eltmapcadr points)))1463 (let ((xs (mapelts car points)) 1464 (ys (mapelts cadr points))) 1466 1465 (let* ((xbar (mean xs)) 1467 1466 (ybar (mean ys)) … … 1472 1471 (map (lambda (yi) (square ( yi ybar))) ys))) 1473 1472 (Lxy (reduce + 0 1474 ( eltmap(lambda (point) (let ((xi (car point))1475 (yi (car point)))1476 (* ( xi xbar) ( yi ybar))))1473 (mapelts (lambda (point) (let ((xi (car point)) 1474 (yi (car point))) 1475 (* ( xi xbar) ( yi ybar)))) 1477 1476 points))) 1478 1477 (b (if (zero? Lxx) 0 (/ Lxy Lxx))) … … 1491 1490 ;; Also called Pearson Correlation 1492 1491 (define (correlationcoefficient points) 1493 (let* ((xs ( eltmapcar points))1494 (ys ( eltmapcadr points))1492 (let* ((xs (mapelts car points)) 1493 (ys (mapelts cadr points)) 1495 1494 (xbar (mean xs)) 1496 1495 (ybar (mean ys))) 1497 (/ (reduce + 0 ( eltmap(lambda (point)1496 (/ (reduce + 0 (mapelts (lambda (point) 1498 1497 (let ((xi (car point)) 1499 1498 (yi (cadr point))) 1500 1499 (* ( xi xbar) ( yi ybar)))) 1501 1500 points)) 1502 (sqrt (* (reduce + 0 ( eltmap(lambda (xi) (square ( xi xbar)))1501 (sqrt (* (reduce + 0 (mapelts (lambda (xi) (square ( xi xbar))) 1503 1502 xs)) 1504 (reduce + 0 ( eltmap(lambda (yi) (square ( yi ybar)))1503 (reduce + 0 (mapelts (lambda (yi) (square ( yi ybar))) 1505 1504 ys))))))) 1506 1505 … … 1538 1537 ;; and its significance. 1539 1538 (define (spearmanrankcorrelation points) 1540 (let ((xis ( eltmapcar points))1541 (yis ( eltmapcadr points)))1539 (let ((xis (mapelts car points)) 1540 (yis (mapelts cadr points))) 1542 1541 (let* ((n (size points)) 1543 1542 (sortedxis (sort (lambda (xi x yi y) (< x y)) xis)) … … 1548 1547 (meanyrank (mean averageyranks)) 1549 1548 (Lxx (reduce + 0 1550 ( eltmap(lambda (xirank) (square ( xirank meanxrank)))1549 (mapelts (lambda (xirank) (square ( xirank meanxrank))) 1551 1550 averagexranks))) 1552 1551 (Lyy (reduce + 0 1553 ( eltmap(lambda (yirank) (square ( yirank meanyrank)))1552 (mapelts (lambda (yirank) (square ( yirank meanyrank))) 1554 1553 averageyranks))) 1555 1554 (Lxy (reduce + 0 1556 ( eltmap(lambda (xirank yirank)1555 (mapelts (lambda (xirank yirank) 1557 1556 (* ( xirank meanxrank) 1558 1557 ( yirank meanyrank))) 
release/5/yasos/trunk/collections.scm
r36387 r36388 298 298 (cond 299 299 ((< count max+1) 300 (ax (apply <proc> ( ax) (map (lambda (g) (g)) eltgenerators)))300 (ax (apply <proc> (cons (ax) (map (lambda (g) (g)) eltgenerators)))) 301 301 (loop (add1 count)) 302 302 ) … … 315 315 (cond 316 316 ((< count max+1) 317 (ax (apply <proc> ( ax) (listzip (map (lambda (g) (g)) keygenerators)318 (map (lambda (g) (g)) eltgenerators))))317 (ax (apply <proc> (cons (ax) (listzip (map (lambda (g) (g)) keygenerators) 318 (map (lambda (g) (g)) eltgenerators))))) 319 319 (loop (add1 count)) 320 320 ) … … 326 326 327 327 (define (reduce* <proc> . <collections>) 328 (let* ( (max+1 ( size (car <collections>)))328 (let* ( (max+1 ( (size (car <collections>)) 1)) 329 329 (eltgenerators (map genelts <collections>)) 330 330 (ax (makeparameter (map (lambda (g) (g)) eltgenerators))) … … 333 333 (cond 334 334 ((< count max+1) 335 (ax (apply <proc> (a x) (map (lambda (g) (g)) eltgenerators)))335 (ax (apply <proc> (append (ax) (map (lambda (g) (g)) eltgenerators)))) 336 336 (loop (add1 count)) 337 337 ) … … 341 341 342 342 (define (reduceitems* <proc> . <collections>) 343 (let* ( (max+1 ( size (car <collections>)))343 (let* ( (max+1 ( (size (car <collections>)) 1)) 344 344 (keygenerators (map genkeys <collections>)) 345 345 (eltgenerators (map genelts <collections>)) … … 350 350 (cond 351 351 ((< count max+1) 352 (ax (apply <proc> (a x) (listzip (map (lambda (g) (g)) keygenerators)353 (map (lambda (g) (g)) eltgenerators))))352 (ax (apply <proc> (append (ax) (listzip (map (lambda (g) (g)) keygenerators) 353 (map (lambda (g) (g)) eltgenerators))))) 354 354 (loop (add1 count)) 355 355 )
Note: See TracChangeset
for help on using the changeset viewer.