From 59e97e1587e96ab08c8aae50ef1143db714bfb57 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 25 Sep 2012 17:21:02 -0700
Subject: [PATCH] math.extras: Add gini and concentration coefficient.
---
extra/math/extras/extras-tests.factor | 27 +++++++++++++++++++++++++++
extra/math/extras/extras.factor | 19 ++++++++++++++++++-
2 files changed, 45 insertions(+), 1 deletion(-)
diff --git a/extra/math/extras/extras-tests.factor b/extra/math/extras/extras-tests.factor
index 1f979ffaa0..ae3a69beb2 100644
--- a/extra/math/extras/extras-tests.factor
+++ b/extra/math/extras/extras-tests.factor
@@ -33,3 +33,30 @@ IN: math.extras.test
{ { 0 2/3 2/3 0 } } [ 4 bartlett ] unit-test
{ { 0 1/2 1 1/2 0 } } [ 5 bartlett ] unit-test
{ { 0 2/5 4/5 4/5 2/5 0 } } [ 6 bartlett ] unit-test
+
+{ 2819/3914 } [
+ {
+ 998,000
+ 20,000
+ 17,500
+ 70,000
+ 23,500
+ 45,200
+ } gini
+] unit-test
+
+{ 8457/9785 } [
+ {
+ 998,000
+ 20,000
+ 17,500
+ 70,000
+ 23,500
+ 45,200
+ } concentration-coefficient
+] unit-test
+
+{ 0 } [ { 1 } gini ] unit-test
+{ 0 } [ { 1 1 1 1 1 1 } gini ] unit-test
+{ 0 } [ { 10 10 10 10 } gini ] unit-test
+{ 0 } [ { } gini ] unit-test
diff --git a/extra/math/extras/extras.factor b/extra/math/extras/extras.factor
index 74e27c7a18..005a924453 100644
--- a/extra/math/extras/extras.factor
+++ b/extra/math/extras/extras.factor
@@ -4,7 +4,7 @@
USING: combinators.short-circuit grouping kernel locals math
math.combinatorics math.constants math.functions math.order
math.primes math.ranges math.statistics math.vectors memoize
-sequences ;
+sequences sequences.extras sorting assocs ;
IN: math.extras
@@ -154,3 +154,20 @@ PRIVATE>
: until-zero ( n quot -- )
[ dup zero? ] swap until drop ; inline
+
+<PRIVATE
+
+:: (gini) ( seq -- x )
+ seq natural-sort :> sorted
+ seq length :> len
+ len [1,b] sorted zip 0 [ * + ] assoc-reduce :> sum0
+ 2 sum0 * sorted sum len * / :> G
+ G 1 - 1 len / - ; inline
+
+PRIVATE>
+
+: gini ( seq -- x )
+ dup length 1 <= [ drop 0 ] [ (gini) ] if ;
+
+: concentration-coefficient ( seq -- x )
+ [ gini ] [ length [ ] [ 1 - ] bi / ] bi * ;