More efficient way of generating list of occurrence counts?

Question

Given a list, e.g., target = {a, b, c, b, c, d, c, d, e, f, a, h, g}, I want to generate a list containing the occurrence count of the corresponding element of the target list, e.g., {1, 1, 1, 2, 2, 1, 3, 2, 1, 1, 2, 1, 1} for the example target. Target elements can be pretty much anything: atoms, sublists, etc. I'm using result = Module[{c}, c[_] = 0; ++c[#] & /@ #] &[target] which works fine, but wonder if the wizards have a more efficient way.

Update: Came up with this while 'cigar thinking':

result = Module[{ordarg, ord},
     ordarg[[ord]] = 
      Flatten[Range /@ (Tally[ordarg = #[[ord = Ordering[#]]]][[All, 2]])];
     ordarg] &[target];

On numeric/symbol/etc. items, this clobbers my original method by orders of magnitude with large lists. It is also 2-3+ times faster even then the most excellent compiled example provided below by L.S. Interestingly, my original method is faster than this or the compiled version for string/character data. (L.S./M.W. et al, perhaps you can illuminate this?)

This is plenty fast for my needs, though I'm still of course interested in the real masters' ideas.

Answer 1

I think that c[_] = 0; ++c[#] & /@ list is a perfectly good method and one that I make use of myself. There is an advantage in the fact that it can be interrupted or continued at any time, and it keeps a running count of the elements in the DownValues of c. (If not using Module that is.) Therefore I think it is a nice general method. One may alternately use either Scan or Map as needed in these incremental uses.

Nevertheless, your Ordering approach is quite clever and makes use of lower-level System functions and well optimized vector operations to do the work. (I imagine I'll starting using it myself; thanks!) General methods are often not optimal, especially in numeric cases, because often numeric data must be unpacked and handled at the top level rather than being operated on at a lower level by specialized functions. Even when data is not unpacked the low level code behind most system function (such as Ordering) can be expected to be faster than top-level code. See Leonid's answer to How are MemberQ and FreeQ so fast? for some interesting notes about this, especially a kind of middle ground.

Your code looks good and I don't see much room for improvement, except that Join is faster than Flatten on packed arrays (as produced by Range), and that I would write it a little differently:

f3 =
  Module[{ord = Ordering @ #},
    ord[[ord]] = Join @@ Range /@ Tally[ #[[ord]] ][[All, 2]];
    ord
  ] &;

Compared to your own functions as f1 and f2:

f1 = Module[{c}, c[_] = 0; ++c[#] & /@ #] &;

f2 =
  Module[{ordarg, ord},
    ordarg[[ord]] =
      Range /@ Tally[ordarg = #[[ord = Ordering[#]]]][[All, 2]] // Flatten;
    ordarg
  ] &;

list = RandomInteger[99999, 3500000];

First @ Timing @ #[list] & /@ {f1, f2, f3}

{6.646, 1.107, 0.593}

Answer 2

Well, you can trade memory for speed and use Compile, as follows:

accumC = 
   Compile[{{l, _Integer, 1}, {max, _Integer}},
      Module[{accum = Table[0, {max}], res = Table[0, {Length[l]}]},
         Do[res[[i]] = ++accum[[l[[i]]]], {i, Length[l]}];
         res
      ]
   ]

ClearAll[occurrences];
occurrences[lst_List] :=
   With[{rules =  Thread[# -> Range[Length[#]]] &@Union[lst]},
     accumC[ lst /. Dispatch[rules],Length[rules]]
   ]

Basically, this is the same idea that you are using, but I use an array for counters instead of a hash table, so this is faster because array lookup is much faster than a hash lookup (objective matter), and also because I avoid explicit top-level looping (Mathematica-specific matter). The bottleneck in this solution is in the lst /. Dispatch[rules] and Dispatch itself, but this is rather fast because no explicit looping is needed.

Benchmarks:

(result = Module[{c}, c[_] = 0; ++c[#] & /@ #] &[target]); // AbsoluteTiming

(* {0.030085, Null} *)

(result1 = occurrences[target]); // AbsoluteTiming

(* {0.006266, Null} *)

result1 == result

(* True *)

Compilation to C is unlikely to dramatically improve matters (because, as I said, the bottleneck is now not in accumC), but still may give another 1.5 - 2x speedup.

Answer 3

Here are a few possibilities:

MapThread[Count, {Take[target, #] & /@ Range@Length@target, target}]

{1, 1, 1, 2, 2, 1, 3, 2, 1, 1, 2, 1, 1}

MapThread[Count, {Reverse@NestList[Most, target, Length@target - 1], target}]

{1, 1, 1, 2, 2, 1, 3, 2, 1, 1, 2, 1, 1}

And my favorite:

MapThread[Coefficient, {Accumulate[target], target}]

{1, 1, 1, 2, 2, 1, 3, 2, 1, 1, 2, 1, 1}

Although possibly more "mathematica-esque" these approaches are all quite a bit slower than yours.

f1[target_] := Module[{c}, c[_] = 0; ++c[#] & /@ #] &[target]
f2[target_] := 
 MapThread[Count, {Take[target, #] & /@ Range@Length@target, target}]
f3[target_] := 
 MapThread[
  Count, {Reverse@NestList[Most, target, Length@target - 1], target}]
f4[target_] := MapThread[Coefficient, {Accumulate[target], target}]

target = RandomChoice[CharacterRange["a", "z"], 10000];

f1[target]; // AbsoluteTiming
f2[target]; // AbsoluteTiming
f3[target]; // AbsoluteTiming
f4[target]; // AbsoluteTiming

{0.031002, Null}

{1.700097, Null}

{1.700097, Null}

{0.134008, Null}

Answer 4

Fast, but still not as fast as the code in the question:

f5[target_] := Module[{n = Length[target], res},
  res = ConstantArray[0, n];
  Scan[(res[[#]] = Range@Length@#) &, 
   Last@Reap@MapThread[Sow, {Range[n], target}]];
  res]

Answer 5

Perhaps:

q[u_] := Count[{u}, u];
q[#]++ & /@ target

This yields:

{1, 1, 1, 2, 2, 1, 3, 2, 1, 1, 2, 1, 1}

Testing a larger example:

tgt = RandomChoice[CharacterRange["a", "z"], 100]

yields:

{"j", "z", "g", "l", "d", "r", "o", "v", "n", "s", "h", "r", "v", \
"y", "f", "n", "g", "y", "l", "u", "v", "c", "n", "a", "y", "y", "g", \
"v", "g", "d", "d", "h", "s", "b", "f", "r", "n", "j", "u", "b", "d", \
"z", "p", "q", "o", "j", "g", "p", "y", "d", "p", "r", "s", "g", "v", \
"f", "k", "v", "z", "b", "g", "k", "n", "p", "l", "o", "d", "i", "b", \
"w", "k", "t", "t", "b", "n", "e", "y", "g", "w", "l", "x", "t", "b", \
"n", "x", "a", "c", "u", "s", "a", "w", "l", "q", "u", "n", "p", "f", \
"z", "o", "j"}

Now,

q[#]++ & /@ tgt

yields:

{1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 1, 1, 2, 2, 2, 2, 1, 3, 1, 3, \
1, 3, 4, 3, 4, 4, 2, 3, 2, 2, 1, 2, 3, 4, 2, 2, 2, 4, 2, 1, 1, 2, 3, \
5, 2, 5, 5, 3, 4, 3, 6, 5, 3, 1, 6, 3, 3, 7, 2, 5, 4, 3, 3, 6, 1, 4, \
1, 3, 1, 2, 5, 6, 1, 6, 8, 2, 4, 1, 3, 6, 7, 2, 2, 2, 3, 4, 3, 3, 5, \
2, 4, 8, 5, 4, 4, 4, 4}

and Tally[tgt]:

Confirms:

{{"j", 4}, {"z", 4}, {"g", 8}, {"l", 5}, {"d", 6}, {"r", 4}, {"o", 
  4}, {"v", 6}, {"n", 8}, {"s", 4}, {"h", 2}, {"y", 6}, {"f", 
  4}, {"u", 4}, {"c", 2}, {"a", 3}, {"b", 6}, {"p", 5}, {"q", 
  2}, {"k", 3}, {"i", 1}, {"w", 3}, {"t", 3}, {"e", 1}, {"x", 2}}

Note: need to clear each time else will continue to increment.