steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

math.statistics: Add sum-of-squares word, add sum-of-squared-errors/sum-of-absolute-errors words.

db4
Doug Coleman 2012-05-07 15:03:45 -07:00
parent f03a7f10bf
commit 0a5a2a74a7
1 changed files with 19 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
basis/math/statistics/statistics.factor
View File

@ -6,28 +6,36 @@ sequences.private sorting fry arrays grouping sets ;
IN: math.statistics IN: math.statistics
: power-mean ( seq p -- x ) : power-mean ( seq p -- x )
[ '[ _ ^ ] map-sum ] [ [ length / ] [ recip ^ ] bi* ] 2bi ; [ '[ _ ^ ] map-sum ] [ [ length / ] [ recip ^ ] bi* ] 2bi ; inline
: mean ( seq -- x ) : mean ( seq -- x )
[ sum ] [ length ] bi / ; [ sum ] [ length ] bi / ; inline
: sum-of-squares ( seq -- x )
[ sq ] map-sum ; inline
: sum-of-squared-errors ( seq -- x )
[ mean ] keep [ - sq ] with map-sum ; inline
: sum-of-absolute-errors ( seq -- x )
[ mean ] keep [ - ] with map-sum ; inline
: quadratic-mean ( seq -- x ) ! root-mean-square : quadratic-mean ( seq -- x ) ! root-mean-square
[ [ sq ] map-sum ] [ length ] bi / sqrt ; [ sum-of-squares ] [ length ] bi / sqrt ; inline
: geometric-mean ( seq -- x ) : geometric-mean ( seq -- x )
[ length ] [ product ] bi nth-root ; [ length ] [ product ] bi nth-root ; inline
: harmonic-mean ( seq -- x ) : harmonic-mean ( seq -- x )
[ recip ] map-sum recip ; [ recip ] map-sum recip ; inline
: contraharmonic-mean ( seq -- x ) : contraharmonic-mean ( seq -- x )
[ [ sq ] map-sum ] [ sum ] bi / ; [ sum-of-squares ] [ sum ] bi / ; inline
<PRIVATE <PRIVATE
:: ((kth-object)) ( seq k nth-quot exchange-quot quot: ( x y -- ? ) -- elt ) :: ((kth-object)) ( seq k nth-quot exchange-quot quot: ( x y -- ? ) -- elt )
#! Wirth's method, Algorithm's + Data structues = Programs p. 84 #! Wirth's method, Algorithm's + Data structues = Programs p. 84
#! The algorithm modifiers seq, so we clone it
k seq bounds-check 2drop k seq bounds-check 2drop
0 :> i! 0 :> i!
0 :> j! 0 :> j!
@ -56,6 +64,7 @@ IN: math.statistics
k seq nth ; inline k seq nth ; inline
: (kth-object) ( seq k nth-quot exchange-quot quot: ( x y -- ? ) -- elt ) : (kth-object) ( seq k nth-quot exchange-quot quot: ( x y -- ? ) -- elt )
#! The algorithm modifiers seq, so we clone it
[ clone ] 4dip ((kth-object)) ; inline [ clone ] 4dip ((kth-object)) ; inline
: kth-object-unsafe ( seq k quot: ( x y -- ? ) -- elt ) : kth-object-unsafe ( seq k quot: ( x y -- ? ) -- elt )
@ -224,20 +233,18 @@ ERROR: empty-sequence ;
minmax swap - ; minmax swap - ;
: sample-var ( seq -- x ) : sample-var ( seq -- x )
#! normalize by N-1 #! normalize by N-1; unbiased
dup length 1 <= [ dup length 1 <= [
drop 0 drop 0
] [ ] [
[ [ mean ] keep [ - sq ] with map-sum ] [ sum-of-squared-errors ] [ length 1 - ] bi /
[ length 1 - ] bi /
] if ; ] if ;
: full-var ( seq -- x ) : full-var ( seq -- x )
dup length 1 <= [ dup length 1 <= [
drop 0 drop 0
] [ ] [
[ [ mean ] keep [ - sq ] with map-sum ] [ sum-of-squared-errors ] [ length ] bi /
[ length ] bi /
] if ; ] if ;
ALIAS: var sample-var ALIAS: var sample-var