# Optimising Table iteration

I've asked a question here which was resolved by tweaking my code a little. So I shall reiterate, for the following list,

l = {{"a", "b"}, {"a", "b"}, {"c", "d"}, {"e", "f"}, {"e", "f"},
{"x", "y", "z"}, {"m", "n", "o"}, {"p", "q", "s"}};


I want to count each sublist and make a polynomial from them, I do this by:

AssociationThread[
l -> Table[
Total[(x^-Length@l[[i]]) x^
Map[Length, Select[l, ContainsAll[l[[i]]]]]], {i, Length[l]}]]


This code does the job correctly yet, the original list I am working with has 38968 sublists and thus the code would take a lot of time to be complied - I wonder how does one optimise this?

I used ParallelTable but for some reason it takes more time!

In:=
l -> Table[
Total[(x^-Length@l[[i]]) x^
Map[Length, Select[l, ContainsAll[l[[i]]]]]], {i,
Length[l]}]] // AbsoluteTiming
l -> ParallelTable[
Total[(x^-Length@l[[i]]) x^
Map[Length, Select[l, ContainsAll[l[[i]]]]]], {i,
Length[l]}]] // AbsoluteTiming

Out= {0.000812, <|{"a", "b"} -> 2, {"c", "d"} -> 1, {"e", "f"} ->
2, {"x", "y", "z"} -> 1, {"m", "n", "o"} -> 1, {"p", "q", "s"} ->
1|>}

Out= {0.002713, <|{"a", "b"} -> 2, {"c", "d"} -> 1, {"e", "f"} ->
2, {"x", "y", "z"} -> 1, {"m", "n", "o"} -> 1, {"p", "q", "s"} ->
1|>}

• I'm confused. Isn't your desired output identical to the output of Counts[l]? What am I missing? Sep 10, 2019 at 19:37
• @MarcoB I got mislead as well: try this list: l = {{"a", "a", "b"}, {"a", "b"}, {"a", "a"}, {"b", "b"}, {"b", "b"}, {"c", "d"}, {"e", "f"}, {"e", "f"}, {"x", "y", "z"}, {"m", "n", "o"}, {"p", "q", "s"}}; and you'll see that the output is different. Maybe it's worth editing the OP with this example as well to clarify the difference, but I'm not 100% sure Sep 11, 2019 at 8:06
• @marcoB in this very specific case the output is like that because powers of x are cancelling each other - this is not a general rule for the list that I am working with so the output is indeed correct as you see and one must use the formula I used... Sep 11, 2019 at 11:07
• I suggest you to update the test list with something more clear, as the one I provide in my answer below :) Sep 12, 2019 at 7:49

Here is an approach that is around 10 times faster (see below for timing of old approach on my machine):

al = AssociationThread[# -> 1] & /@ l;
Keys /@ al -> Table[
Total[
(x^-Length@al[[i]])
x^Map[
Length,
Pick[al, Times @@@ Lookup[al, Keys@al[[i]], 0], 1]
]
],
{i, Length[al]}
]
] // RepeatedTiming
(* {0.00012, <|{"a", "b"} -> 2, {"c", "d"} -> 1, {"e", "f"} ->
2, {"x", "y", "z"} -> 1, {"m", "n", "o"} -> 1, {"p", "q", "s"} ->
1|>} *)


This works by (ab)using Associations as hash-maps for faster membership checks. We first convert the list l into a list of associations (al) where the keys are the elements from the sublists of l and the values are all 1. Using Lookup, we perform a lookup in all of al at once, with non-existing keys defaulting to 0. We then Pick the sublists where the product of all lookup results is 1.

### Timing of old approach

Compared to the one in the question:

AssociationThread[
l -> Table[
Total[
(x^-Length@l[[i]])
x^Map[
Length,
Select[l, ContainsAll[l[[i]]]]
]
],
{i, Length[l]}
]
] // RepeatedTiming
(* {0.0009, <|{"a", "b"} -> 2, {"c", "d"} -> 1, {"e", "f"} ->
2, {"x", "y", "z"} -> 1, {"m", "n", "o"} -> 1, {"p", "q", "s"} ->
1|>} *)


Let's first create a test list:

l = Join @@
ConstantArray[{{"a", "a", "b"}, {"a", "b"}, {"a", "b"}, {"a",
"a"}, {"b", "b"}, {"b", "b"}, {"c", "d"}, {"e", "f"}, {"e",
"f"}, {"x", "y", "z"}, {"m", "n", "o"}, {"p", "q", "s"}}, 20];


One can use the following code to speed up the calculation:

RepeatedTiming[
dl = DeleteDuplicates[l];
exp1 = Length /@ dl;
exp2 = Length /@ Select[l, ContainsAll[#]] & /@ dl;
m3 = AssociationThread[dl -> Total /@ ((x^-exp1) (x^exp2))]]


{0.023, <|{"a", "a", "b"} -> 20 + 40/x, {"a", "b"} -> 40 + 20 x, {"a", "a"} -> 60 + 20 x, {"b", "b"} -> 80 + 20 x, {"c", "d"} -> 20, {"e", "f"} -> 40, {"x", "y", "z"} -> 20, {"m", "n", "o"} -> 20, {"p", "q", "s"} -> 20|>}

Compared with the old method:

RepeatedTiming[m1 = AssociationThread[l -> Table[
Total[
(x^-Length@l[[i]])
x^Map[Length, Select[l, ContainsAll[l[[i]]]]]
], {i, Length[l]}]
]]


{0.624, <|{"a", "a", "b"} -> 20 + 40/x, {"a", "b"} -> 40 + 20 x, {"a", "a"} -> 60 + 20 x, {"b", "b"} -> 80 + 20 x, {"c", "d"} -> 20, {"e", "f"} -> 40, {"x", "y", "z"} -> 20, {"m", "n", "o"} -> 20, {"p", "q", "s"} -> 20|>}

m1==m3


True

and ~ 30 times faster.

• Thank you but could you please read the comment I've posted under my question - it will answer your question. As it stands the output of yours is wrong as it is no matching with mine. Sep 11, 2019 at 11:09
• Are you sure? can you provide an example list where the output doesn't match yours? It seems to me that the two codes do the same thing :) If you notice, I changed the list so that the powers of X don't simplify, and the output of your code is the same as mine! Sep 11, 2019 at 11:34