math.statistics: Fix histogram and collect. Histogram used each-index even when it didn't need to.

basis/math/statistics/statistics-docs.factor

@@ -142,7 +142,7 @@ HELP: sequence>assoc
     { $example "! Iterate over a sequence and increment the count at each element"
                "! The first quotation has stack effect ( key -- key ), a no-op"
                "USING: assocs prettyprint kernel math.statistics ;"
-               "\"aaabc\" [ ] [ nip inc-at ] H{ } sequence>assoc ."
+               "\"aaabc\" [ ] [ inc-at ] H{ } sequence>assoc ."
                "H{ { 97 3 } { 98 1 } { 99 1 } }"
     }
 } ;
@@ -154,7 +154,7 @@ HELP: sequence>assoc!
 { $examples
     { $example "! Iterate over a sequence and add the counts to an existing assoc"
                "USING: assocs prettyprint math.statistics kernel ;"
-               "H{ { 97 2 } { 98 1 } } clone \"aaabc\" [ ] [ nip inc-at ] sequence>assoc! ."
+               "H{ { 97 2 } { 98 1 } } clone \"aaabc\" [ ] [ inc-at ] sequence>assoc! ."
                "H{ { 97 5 } { 98 2 } { 99 1 } }"
     }
 } ;
@@ -168,7 +168,7 @@ HELP: sequence>hashtable
 { $examples
     { $example "! Count the number of times an element occurs in a sequence"
                "USING: assocs kernel prettyprint math.statistics ;"
-               "\"aaabc\" [ ] [ nip inc-at ] sequence>hashtable ."
+               "\"aaabc\" [ ] [ inc-at ] sequence>hashtable ."
                "H{ { 97 3 } { 98 1 } { 99 1 } }"
     }
 } ;

basis/math/statistics/statistics-tests.factor

@@ -1,5 +1,6 @@
 USING: assocs kernel math math.functions math.statistics sequences
 math.order tools.test math.vectors ;
+FROM: math.ranges => [a,b] ;
 IN: math.statistics.tests
 
 [ 3 ] [ { 1 2 3 4 5 } 1 power-mean ] unit-test
@@ -207,3 +208,18 @@ IN: math.statistics.tests
 
 { { 0 1 3 6 } }
 [ { 1 2 3 4 } cum-sum0 ] unit-test
+
+{
+    H{
+        { 0 V{ 600 603 606 609 } }
+        { 1 V{ 601 604 607 610 } }
+        { 2 V{ 602 605 608 } }
+    }
+}
+[ 600 610 [a,b] [ 3 mod ] collect-by ] unit-test
+
+
+{
+    H{ { 0 V{ 0 3 6 9 } } { 1 V{ 1 4 7 10 } } { 2 V{ 2 5 8 } } }
+}
+[ 600 610 [a,b] [ 3 mod ] collect-index-by ] unit-test

basis/math/statistics/statistics.factor

@@ -210,26 +210,32 @@ PRIVATE>
 <PRIVATE
 
 : (sequence>assoc) ( seq map-quot insert-quot assoc -- assoc )
+    [ swap curry compose each ] keep ; inline
+
+: (sequence-index>assoc) ( seq map-quot insert-quot assoc -- assoc )
     [ swap curry compose each-index ] keep ; inline
 
 PRIVATE>
 
-: sequence>assoc! ( assoc seq map-quot: ( x -- ..y ) insert-quot: ( ..y index assoc -- ) -- assoc )
+: sequence>assoc! ( assoc seq map-quot: ( x -- ..y ) insert-quot: ( ..y assoc -- ) -- assoc )
     4 nrot (sequence>assoc) ; inline
 
 : sequence>assoc ( seq map-quot insert-quot exemplar -- assoc )
     clone (sequence>assoc) ; inline
 
+: sequence-index>assoc ( seq map-quot insert-quot exemplar -- assoc )
+    clone (sequence-index>assoc) ; inline
+
+: sequence-index>hashtable ( seq map-quot insert-quot -- hashtable )
+    H{ } sequence-index>assoc ; inline
+
 : sequence>hashtable ( seq map-quot insert-quot -- hashtable )
     H{ } sequence>assoc ; inline
 
 : histogram! ( hashtable seq -- hashtable )
-    [ ] [ nip inc-at ] sequence>assoc! ;
+    [ ] [ inc-at ] sequence>assoc! ;
 
 : histogram-by ( seq quot: ( x -- bin ) -- hashtable )
-    [ nip inc-at ] sequence>hashtable ; inline
-
-: histogram-index-by ( seq quot: ( x -- bin ) -- hashtable )
     [ inc-at ] sequence>hashtable ; inline
 
 : histogram ( seq -- hashtable )
@@ -241,14 +247,11 @@ PRIVATE>
 : normalized-histogram ( seq -- alist )
     [ histogram ] [ length ] bi '[ _ / ] assoc-map ;
 
-: collect-at ( seq quot -- hashtable )
-    [ push-at ] sequence>hashtable ; inline
-
 : collect-index-by ( seq quot -- hashtable )
-    [ swap ] prepose collect-at ; inline
+    [ swap ] prepose [ push-at ] sequence-index>hashtable ; inline
 
 : collect-by ( seq quot -- hashtable )
-    [ drop dup ] prepose collect-at ; inline
+    [ dup ] prepose [ push-at ] sequence>hashtable ; inline
 
 : equal-probabilities ( n -- array )
     dup recip <array> ; inline

basis/tools/profiler/sampling/sampling.factor

@@ -101,7 +101,7 @@ CONSTANT: zero-counts { 0 0 0 0 0 }
     ] [ f ] if ; inline
 
 :: collect-tops ( samples max-depth depth -- node )
-    samples [ drop unclip-callstack ] collect-at [
+    samples [ drop unclip-callstack ] collect-by [
         [ sum-counts ]
         [ max-depth depth [ max-depth depth 1 + collect-tops ] (collect-subtrees) ] bi
         depth <profile-node>