! Copyright (C) 2008 Doug Coleman, Michael Judge, Loryn Jenkins.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs combinators fry generalizations grouping
-kernel locals math math.functions math.order math.vectors
+USING: accessors arrays assocs combinators
+combinators.short-circuit fry generalizations grouping kernel
+locals math math.functions math.order ranges math.vectors
sequences sequences.private sorting ;
IN: math.statistics
: mean ( seq -- x )
0 mean-ddof ; inline
-: sum-of-squares ( seq -- x )
- [ sq ] map-sum ; inline
+: meanest ( seq -- x )
+ [ mean ] keep [ - abs ] with infimum-by ;
+
+GENERIC: sum-of-squares ( seq -- x )
+M: object sum-of-squares [ sq ] map-sum ;
+M: iota sum-of-squares
+ n>> 1 - [ ] [ 1 + ] [ 1/2 + ] tri * * 3 / ;
+M: ranges:range sum-of-squares
+ dup { [ step>> 1 = ] [ from>> integer? ] } 1&& [
+ [ from>> ] [ length>> ] bi dupd +
+ [ <iota> sum-of-squares ] bi@ swap -
+ ] [ call-next-method ] if ;
+
+GENERIC: sum-of-cubes ( seq -- x )
+M: object sum-of-cubes [ 3 ^ ] map-sum ;
+M: iota sum-of-cubes sum sq ;
+M: ranges:range sum-of-cubes
+ dup { [ step>> 1 = ] [ from>> integer? ] } 1&& [
+ [ from>> ] [ length>> ] bi dupd +
+ [ <iota> sum-of-cubes ] bi@ swap -
+ ] [ call-next-method ] if ;
+
+GENERIC: sum-of-quads ( seq -- x )
+M: object sum-of-quads [ 4 ^ ] map-sum ;
+M: iota sum-of-quads
+ [let n>> 1 - :> n
+ n 0 > [
+ n
+ n 1 +
+ n 2 * 1 +
+ n sq 3 * n 3 * + 1 -
+ * * * 30 /
+ ] [ 0 ] if
+ ] ;
+M: ranges:range sum-of-quads
+ dup { [ step>> 1 = ] [ from>> integer? ] } 1&& [
+ [ from>> ] [ length>> ] bi dupd +
+ [ <iota> sum-of-quads ] bi@ swap -
+ ] [ call-next-method ] if ;
: sum-of-squared-errors ( seq -- x )
[ mean ] keep [ - sq ] with map-sum ; inline
k seq nth-unsafe ; inline
: (kth-object) ( seq k nth-quot exchange-quot quot: ( x y -- ? ) -- elt )
- ! The algorithm modifiers seq, so we clone it
+ ! The algorithm modifies seq, so we clone it
[ >array ] 4dip kth-object-impl ; inline
: kth-object-unsafe ( seq k quot: ( x y -- ? ) -- elt )
: trimean ( seq -- x )
quartile first3 [ 2 * ] dip + + 4 / ;
+: histogram-by! ( assoc seq quot: ( x -- bin ) -- hashtable )
+ rot [ '[ @ _ inc-at ] each ] keep ; inline
+
: histogram! ( hashtable seq -- hashtable )
- over '[ _ inc-at ] each ;
+ [ ] histogram-by! ; inline
: histogram-by ( seq quot: ( x -- bin ) -- hashtable )
- H{ } clone [ '[ @ _ inc-at ] each ] keep ; inline
+ [ H{ } clone ] 2dip histogram-by! ; inline
: histogram ( seq -- hashtable )
[ ] histogram-by ;
: z-score ( seq -- n )
[ demean ] [ sample-std ] bi v/n ;
+
+: dcg ( scores -- dcg )
+ dup length 1 + 2 swap [a..b] [ log 2 log /f ] map v/ sum ;
+
+: ndcg ( scores -- ndcg )
+ [ 0.0 ] [
+ dup dcg [
+ drop 0.0
+ ] [
+ swap natural-sort <reversed> dcg /f
+ ] if-zero
+ ] if-empty ;