Optimising Table iteration

Question

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[130]:= 
AssociationThread[
  l -> Table[
    Total[(x^-Length@l[[i]]) x^
       Map[Length, Select[l, ContainsAll[l[[i]]]]]], {i, 
     Length[l]}]] // AbsoluteTiming
AssociationThread[
  l -> ParallelTable[
    Total[(x^-Length@l[[i]]) x^
       Map[Length, Select[l, ContainsAll[l[[i]]]]]], {i, 
     Length[l]}]] // AbsoluteTiming

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

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

Answer 1

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

al = AssociationThread[# -> 1] & /@ l;
AssociationThread[
  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|>} *)

Answer 2

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.