Counting the population of integers

Question

Suppose that myData is a list of sublists. Each sublist has a length of one or greater and contains any number of replicates of the integers 1, 2, 3, and 4. I would like to create a function myFun that counts the number of each integer in the sublist.

As an example, suppose that I have the following myData:

myData = {{2, 3, 3, 1, 1, 3, 2, 2, 4, 1, 1, 1, 2, 2, 2, 2, 2, 1, 1, 1},
  {2, 2, 3, 1, 1, 3, 2, 2, 3, 1, 1, 1, 2, 2, 1, 2, 2, 1, 1, 1},
  {1, 2, 2, 1, 1, 3, 2, 1, 3, 1, 1, 2, 2, 2, 2, 3, 1, 1},
  {2, 3, 3, 1, 1, 2, 3, 2, 3, 1, 2, 1, 2, 1, 2, 2, 2, 1, 1, 1}};

I would like myFun /@ myData to return the output:

{{{1, 8}, {2, 8}, {3, 3}, {4, 1}},
  {{1, 9}, {2, 8}, {3, 3}, {4, 0}},
  {{1, 8}, {2, 7}, {3, 3}, {4, 0}},
  {{1, 8}, {2, 8}, {3, 4}, {4, 0}}}

In other words, sublist 1 has eight 1s, eight 2s, three 3s, and one 4, and similarly for the other three sublists. The key feature here is that all of 1, 2, 3, and 4 are listed, even if one or more of them have zero population.

Using the following (taking advantage of Tally) gets me close:

myFun[sublist_] := SortBy[Tally[sublist], First]
myFun /@ myData

{{{1, 8}, {2, 8}, {3, 3}, {4, 1}},
 {{1, 9}, {2, 8}, {3, 3}},
 {{1, 8}, {2, 7}, {3, 3}},
 {{1, 8}, {2, 8}, {3, 4}}}

But Tally does not list members with zero population, so the above does not satisfy the key feature.

On the other hand, the following (using Count) seems to accomplish my goal:

myFun[sublist_] := Map[{#, Count[sublist, #]} &, {1, 2, 3, 4}]
myFun /@ myData

{{{1, 8}, {2, 8}, {3, 3}, {4, 1}},
 {{1, 9}, {2, 8}, {3, 3}, {4, 0}},
 {{1, 8}, {2, 7}, {3, 3}, {4, 0}},
 {{1, 8}, {2, 8}, {3, 4}, {4, 0}}}

But, is there a more succinct, more elegant way to do this? Thanks for your time!

Answer 1

Though it is not typically as fast as Tally I am fond of Sow and Reap for this kind of problem:

countBy[dat_, bins_] :=
 {bins, Tr /@ Reap[Sow[1, #], bins, Tr@#2 &][[2]]}\[Transpose] & /@ dat

countBy[myData, {1, 2, 3, 4}] // List // MatrixForm

Since Tally is probably better in the long run despite my enjoyment of Sow and Reap here is a way to use that efficiently:

countBy2[dat_, bins_] :=
 {bins, Replace[bins, Dispatch @ Append[Rule @@@ Tally @ #, _ -> 0], {1}]}\[Transpose] & /@ dat

---

Performance

I commented that while a method that jVincent proposed (also in a comment) was short and elegant that it was "not at all efficient computationally." He rebuts this in an answer, to which I will now reply. I was of course not speaking about the absolute performance on this tiny example but rather about algorithmic complexity and the way the method scales to a larger problem. The issue with using Count is that each list must be scanned as many times as there are unique elements. When the list is long and contains a large number of such elements this becomes a very slow process.

I shall use the faster Tally method (countBy3) rather than the playful Sow and Reap method while comparing performance. I will use the following functions:

SetAttributes[timeAvg, HoldFirst]

timeAvg[func_] := Do[If[# > 0.3, Return[#/5^i]] & @@ Timing@Do[func, {5^i}], {i, 0, 15}]

myFun[sublist_] := SortBy[Tally[sublist], First]
myFun[sublist_, elems_] := 
  Replace[myFun[sublist~Join~elems], {el : Alternatives @@ elems, n_} :> {el, n - 1}, 1];
leonid[dat_, bins_] := myFun[#, bins] & /@ dat

jV[dat_, bins_] :=
 Outer[{#2, Count[#1, #2]} &, dat, bins, 1]

First, using an array of fixed size but varying the number bins to tally:

times =
 Table[
  With[{dat = RandomInteger[{1, n}, {1000, 1000}]},
   timeAvg[#[dat, Range@n]] & /@ {jV, leonid, countBy2}
   ],
  {n, 3^Range@6}
 ]

{{0.1028, 0.01312, 0.007608},
 {0.2776, 0.01996, 0.012104},
 {0.811, 0.0418, 0.02372},
 {2.371, 0.1216, 0.05616},
 {7.161, 0.593, 0.2246},
 {21.45, 3.573, 0.468}}

ListPlot[times\[Transpose], PlotRange -> All, AxesOrigin -> {1, -1}, Joined -> True]

The blue line is the timing of jVincent's Count method, the purple line Leonid's, and the yellow line mine. Clearly Count does not scale well with regard to an increasing number of unique elements.

Here is a run-off between Leonid's code an my own (not that he wrote it with peak efficiency in mind), using much longer sublists to allow for more unique elements:

times2 =
 Table[
   With[{dat = RandomInteger[{1, n}, {20, 25000}]},
    timeAvg[#[dat, Range@n]] & /@ {leonid, countBy2}
   ],
   {n, 3^Range@9}
 ]

{{0.0011728, 0.0009232},
 {0.0012976, 0.0009984},
 {0.0017712, 0.001248},
 {0.003368, 0.001872},
 {0.011352, 0.003744},
 {0.0688, 0.009608},
 {0.561, 0.03304},
 {4.914, 0.156},
 {43.462, 0.39}}

ListPlot[times2\[Transpose], PlotRange -> All, AxesOrigin -> {1, -1}, Joined -> True, 
 PlotStyle -> ColorData[1] /@ {2, 3}]

So once again at the extremes Leonid's code "blows up" while mine does not.

That is what I meant by "not at all efficient computationally."

Answer 2

You can still use your original strategy, just add a list of unique elements you wish to track, to your sublists, and then adjust the counts. You can add a second definition to your original myFun, which would take a list of tracked elements as a second parameter, as follows:

ClearAll[myFun];
myFun[sublist_] := SortBy[Tally[sublist], First]
myFun[sublist_, elems_] :=
  Replace[myFun[sublist~Join~elems], 
     {el : Alternatives @@ elems, n_} :> {el, n - 1}, 1];

Then,

myFun[#, {1, 2, 3, 4}] & /@ myData

produces the result you desire.

EDIT

Since the performance issue came up, I have to mention that the above solution is suboptimal, but not due to Tally, but rather due to the use of Alternatives @@ elems, which makes its complexity to be O(Length[elems] * Length[sublist]). Here is a much faster one:

ClearAll[myFun1,leonid1];
myFun1[sublist_, elems_] :=
   Module[{tallyT = Transpose@Tally[elems ~ Join ~ sublist], 
      range = Range[Length[elems]]},
      tallyT[[2, range ]] = tallyT[[2, range ]] - 1;
      SortBy[Transpose[tallyT], First]
   ];
leonid1[dat_, bins_] := myFun1[#, bins] & /@ dat

from what I could see, it is the fastest so far. I save big because I put elems in front, and so, since Tally does its counts in the order it meets the elements, I know precisely the positions of elements where I need to adjust the counts. And I sort the result afterwards.

Answer 3

 Thread[{Range[Max@myData], BinCounts[#, {1, 1 + Max@myData, 1}]}] & /@ myData

or

 Thread[{Most@#[[1]], #[[2]]}] & /@ (HistogramList[#, {1, 1 + Max@myData, 1}] & /@ myData)

or

myTally[data_, elems_:{}] := 
Composition[# /. {e_, n_} :> {e, n - Boole[MemberQ[elems, e]]} &, Sort, Tally, Join][#, elems] & /@ data;
myTally[myData, {1, 2, 3, 4}]

All give:

 (* {{{1, 8}, {2, 8}, {3, 3}, {4, 1}},
     {{1, 9}, {2, 8}, {3, 3}, {4, 0}}, 
     {{1, 8}, {2, 7}, {3, 3}, {4, 0}},
     {{1, 8}, {2, 8}, {3, 4}, {4, 0}}} *)

Answer 4

Side note

I have performed a larger revision on this answer to reflect input from Leonid and further testing to highligh points raised in our discussion, it still contains the initial solutions and benchmarks, however leonids code was updated to his newest version as it behaves similarly to his original yet scales better with respect to number of unique elements.

Answer

My initial comment and naive solution posted was to simply perform andrews already stated double loop over the (subslists,uniqe) element pais using Outer:

Outer[{#2, Count[#1, #2]} &, myData, {1, 2, 3, 4}, 1]

This elegang solution performs quite well in the regime of the given example data compared to other solutions given to this answer as will be documented, however given large number of unique elements or very long sublists, this solution will scale better:

quickCount[data_,elms_] := 
   Transpose@{elms, #} & /@ (Map[Tally[Join[elms, #]] &, myData][[1 ;;, 1 ;;, 2]] - 1)

The above also outperforms any other answer (as of writing) and the naive solution for the regime of the example data. It's assumed that the data only contains elements found in elms.

The performance testing

The last solution above was added after Mr. wizard in response to the original solution raised concerns regarding computational efficiency for larger lists. The issue in short is that when we loop over the sublists elements performing n iterations and then for each iteration perform m comparisons taking the time T = (n*(loopT+m*checkT)) while for the count-based algorithm we carry out a loop for each unique element throughout the lists and then iterate through the sublist, thus: T=m*(n*(loopT+checkT)). Thus the latter has an additional temporal cost of (m-1)*loopT. Owing to the fact that loopT is small and that indeed in the question m was fixed at 4, I did not take issue with this scaling, but Mr.wizard is indeed correct that the asymtotic computational efficiency with respect to number of unique elements is worse for the Count-based solution than for the Tally based solution. If we assume that we are dealing with the 4 fixed unique elements listed in the myData test example, both solutions have the same asymptotic complexity in sublists lengths and number of subslist namely O(n) in both (verified below).

Now while it's nice to look at bigO, the real discussion arose because I had the aduacity to include test that showed that for the given usage case the naive algorithm outperformed Leonids Tally based solution. The performance meassurements are given below using two different input data, a randomized dataset of same dimensionality as myData, and a set containing much larger sublists (generation method is detailed at the end of the answer):

testdata was generated using SeedRandom[7529127];myData=RandomInteger[{1,4},{40,20}].

It is true however that Leonids solution will become better if we use many more unique elements. My testing shows that starting from the myData sizes we see that Leonids solution outperforms the naive when (numElms>16,lengthList=20). Now a different consideration is the length of the input sublists. Even though both algorithms have the same asymptotic bigO scaling does not mean that they will both follow that scaling for small n, and the exact prefactor needs to be know before any conclusion can be drawn.

testdata was generated using SeedRandom[7529127];myData=RandomInteger[{1,4},{40,500}];.

Looking at actual timings we see however that arguments based on asymptotic scaling don't really apply to Leonids solution until we reach lists that are more then 10^5 elements long, at which point we still can argue which is better since they all scale as O(n). The actual performance comparison becomes a question of finding the prefactors which is seen to be much much larger for the Count-based solution, specifically we see that in the regime of (numList=4,numList>~100) Leonids solution beats the naive, below the the naive outperforms his.

The above shows nicely Leonids objections, he was upset that the simpler solution was shown to be faster in the region of input similar to the example, (region between 10-100), even though it scales better. I would characterize it as a case of "You pay for everything not just for what scales". His solution shows a nice scaling with respect to input list size, however it is still slower for the testing cases because of slow handling of the nicely scaling output of Tally. When dealing with actual usage such considerations should be taken into account, and it is not generally the case that a method exists that will outperform another in all regimes.

Concluding remarks

BigO scale reasoning is a great tool for improving algorithms, but should be backed up by actual testing with representative data in order to verify that indeed performs better. In particular when dealing with functions typically called with small input.

And on second note, one should never argue that timings based on actual use-cases aren't meaningful because they are not "general" with the implied assumption that the "general" means representative of very large inputs, simply for the sake of letting better scaling algorithms win the race. A timing showing MethodA faster than methodB for a given dataset means just that, even if the ordering would hot have been the same for a different use-case.

For completeness the profiled code bits

I chose originally not to post this since it' s just repeating the code of other answers, but since Leonid asked, here it is :

andrewMap[sublist_] := Map[{#,Count[sublist,#]}&,{1,2,3,4}]
andrew := andrewMap/@myData

myFun1[sublist_, elems_] :=
   Module[{tallyT = Transpose@Tally[elems ~ Join ~ sublist], 
      range = Range[Length[elems]]},
      tallyT[[2, range ]] = tallyT[[2, range ]] - 1;
      SortBy[Transpose[tallyT], First]
   ];
leonid := myFun1[#, {1,2,3,4}] & /@ myData;

countBy[dat_, bins_] := {bins, Tr /@ Reap[Sow[1, #], bins, Tr@#2 &][[2]]}\[Transpose] & /@ dat
wizard := countBy[myData, {1, 2, 3, 4}];

myTally[data_, elems_:{}] := Composition[# /. {e_, n_} :> {e, n - Boole[MemberQ[elems, e]]} &, Sort, Tally, Join][#, elems] & /@ data;
kguler := myTally[myData, {1, 2, 3, 4}];

All the numbers for the timeings where found by looping many times over the code in order to get measurable timing per call. The random data was generated from SeedRandom[7529127].

1/10000*First[Do[jvincOuter, {10000}]; // AbsoluteTiming]

The asymptotic timing graph was created using(note the number of calls is larger when testing quicker calls):

testing=Hold[jvincOuter,jVquickCount,leonid2];
Table[
myData=RandomInteger[{1,4},{20,10^n}];
{10^n,timePerCall[Max[1,10^(4-n+1)]][testing[[i]]]}
,{i,1,3},{n,1,6}]//ListLogLogPlot

Answer 5

Here is a semi-imperative solution:

a = Array[{#, 0}&, 4];
myFun[sublist_] := Block[{a = a}, Scan[++a[[#, 2]]&, sublist]; a]

myFun /@ myData
(*
{{{1, 8}, {2, 8}, {3, 3}, {4, 1}},
 {{1, 9}, {2, 8}, {3, 3}, {4, 0}},
 {{1, 8}, {2, 7}, {3, 3}, {4, 0}},
 {{1, 8}, {2, 8}, {3, 4}, {4, 0}}}
*)

Answer 6

list =
  {{2, 3, 3, 1, 1, 3, 2, 2, 4, 1, 1, 1, 2, 2, 2, 2, 2, 1, 1, 1},
   {2, 2, 3, 1, 1, 3, 2, 2, 3, 1, 1, 1, 2, 2, 1, 2, 2, 1, 1, 1},
   {1, 2, 2, 1, 1, 3, 2, 1, 3, 1, 1, 2, 2, 2, 2, 3, 1, 1},
   {2, 3, 3, 1, 1, 2, 3, 2, 3, 1, 2, 1, 2, 1, 2, 2, 2, 1, 1, 1}};

These Association - related functions, introduced 2014 with V 10.0

Sort @* KeyValueMap[List] /@ KeyUnion[Counts /@ list, 0 &]

give the expected result:

{{{1, 8}, {2, 8}, {3, 3}, {4, 1}},
 {{1, 9}, {2, 8}, {3, 3}, {4, 0}},
 {{1, 8}, {2, 7}, {3, 3}, {4, 0}},
 {{1, 8}, {2, 8}, {3, 4}, {4, 0}}}

Answer 7

Another possibility:

MapIndexed[{#2[[2]],#1}&,BinCounts[#,{1,5,1}]& /@ myData,{2}]

(*{
    {{1,8},{2,8},{3,3},{4,1}},
    {{1,9},{2,8},{3,3},{4,0}},
    {{1,8},{2,7},{3,3},{4,0}},
    {{1,8},{2,8},{3,4},{4,0}}
   }*)

Answer 8

This has a lot of answers already, but here's an obvious (to me) solution that hasn't been mentioned:

inds = Range[4];
Map[Transpose[{inds, #}]&] @ Lookup[
  Counts /@ myData,
  inds,
  0
]