How do we optimise double Tables?

Question

I have made the following code which I shall explain it in two parts:

First Part:

ELCo = Alphabet["English"]; (*ELCo are the letters in English*)
Characters[ToLowerCase[WordList[Language -> "English"]]];
Select[%, SubsetQ[ELCo, ToLowerCase[#1]] &];
ELPr = Map[Sort, Map[DeleteDuplicates, %]]; (*In the past two steps I turn English words into characters and to lowercase*)
ELP = Length[ELPr];
ELPrPo = Total[x^Map[Length, ELPr]]; (*Here I make polynomials of english words based on their length, for example 3068 x^4 shows there are 3068 elements of size 4 and so on*)

This part of the code is fairly simple and easy to run. This is just the tool I need in second part of my code.

Second Part:

I first take the letters, there are 26 of them and make all the possible pairs: (there are 325 of them)

Pairs = Subsets[ELCo, {2}];

Then,

Table[LU = Select[ELPr, SubsetQ[#1, Pairs[[j]]] &]; (*I go through the original word list ELPr and select each pair to this part shall be done 325 times for each pair*)
  LUer = Total[x^Map[Length, LU]]; (*Then I make the new polynomial for each pair after selection*)
  LUerDelta = Expand[ELPrPo - LUer + LUer/x]; (*Use the new polynomial and the original one to make this equation*)
  Table[c = i;
   (27 - c)/
      27 (Coefficient[LUerDelta, x, c]/Coefficient[ELPrPo, x, c]) // 
    N, {i, 1, 2}], {j, 1, Length[Pairs]}];
PairPerformance = AssociationThread[Pairs, %];

In the last part for each new LUerDelta I want to make a ratio of the coefficients for c= 1 and 2, but having two table command into each other makes this process very slow, I was wondering if there is a better way of doing this?

Answer 1

Here's a way to speed things up significantly more:

{timeTab3, tabl3} =
  AbsoluteTiming@
   Module[
    {
     baseAssoc, 
     LUer, LUerDelta, 
     ELPrPo = N@CoefficientList[ELPrPo, x],
     bigELPr, bigELPrLens,
     pairInds, ELPrLens,
     lens, reshapedRange
     },
    (* precompile a list of specs for fast indexing *)

    bigELPr = ConstantArray[0, {Length@ELPr, 26}];
    MapThread[
     Function[bigELPr[[#, #2]] = 1;],
     {
      Range[Length@ELPr],
      ELPr /. AssociationThread[Alphabet[], Range[26]]
      }
     ];
    (* make a set of base coefficients for Counts to merge into *)

    baseAssoc = AssociationThread[Range[0, Length[ELPrPo] + 1], 0.];
    pairInds = Pairs /. AssociationThread[Alphabet[], Range[26]];
    ELPrLens = Length /@ ELPr;
    (* precompute the first set of indices we'll use in `Extract` *)

    reshapedRange = ArrayReshape[Range[Length@bigELPr], {Length@bigELPr, 1}];
    Table[
     lens =
      Pick[ (* 
       Pick is like a much faster Select designed for cases like these *)

          ELPrLens,
       Total@
        Map[
         Extract[bigELPr,
           Join[
            reshapedRange,
            ConstantArray[#, {Length@bigELPr, 1}],
            2
            ]
           ] &,
         pair
         ],
       2 (* 
       we have pairs so the number of elements pulled needs to be 2 *)
       ];
     LUer = Values@KeySort@Join[baseAssoc, N@Counts@lens];
     LUer = Take[LUer, Length[ELPrPo] + 1];
     LUerDelta = ELPrPo - Most@LUer + Rest@LUer;
     (27 - Range[2])/27*(LUerDelta[[{2, 3}]]/ELPrPo[[{2, 3}]]),
     {pair, pairInds}
     ]
    ];

On my machine this is a about 30 times faster than Jack's:

timeTab3

0.99519

timeTab2

31.5328

timeTab2/timeTab3

31.6852

And:

tabl2 == tabl3

True

The big thing I do here is I do here is that I drop any of the Select calls and instead use vectorized indexing operations and addition to do these things for me. I precompute all my arrays to index into. Then when computing the indices to pull I make sure to keep everything as a packed array using ConstantArray and the second argument to Join.

After doing that I avoid any symbolic processing, but the benefits of that are relatively minor.

Update:

There's a question about what:

      Pick[ (*Pick is like a much faster Select designed for cases like these *)
       ELPrLens,
       Total@
        Map[
         Extract[bigELPr,
           Join[
            reshapedRange,
            ConstantArray[#, {Length@bigELPr, 1}],
            2
            ]
           ] &,
         pair
         ],
       2 (* 
       we have pairs so the number of elements pulled needs to be 2 *)
       ];

does.

Basically I generate the set of indices pointed to by pair by making

{ {1, pair[[1]]}, {2, pair[[1]]}, ... }

and the same with pair[[2]].

I use that in Extract to pull out my precompiled positions from bigELPr. Then I add up the extracted values for pair[[1]] and pair[[2]] in vectorized fashion with Total. After that I use Pick to choose the elements in ELPrLens that correspond to a 2 in that summed up list of extracted positions, since 2 means both elements of the pair were in that element of ELPr.

Answer 2

First your expressions for English words with the alphabet broken down into lists of characters (only those that contain the alphabet), sorted with duplicate letters removed were copied from your question.

Intermediary variables were used so one wouldn't have to rely on using the % sign (not a big deal).

ELCo = Alphabet["English"];
char = Characters[ToLowerCase[WordList[Language -> "English"]]];
char = Select[char, SubsetQ[ELCo, ToLowerCase[#1]] &];
ELPr = Map[Sort, Map[DeleteDuplicates, char]];

Your code was copied and the time it took was studied. The comments were modified so it would be easier to follow the structure of the outer and inner loops.

{timeTabl, tabl} = AbsoluteTiming[
   Table[
    LU = Select[ELPr, SubsetQ[#1, Pairs[[j]]] &];
    LUer = Total[x^Map[Length, LU]];
    LUerDelta = Expand[ELPrPo - LUer + LUer/x];

    Table[
     c = i;
     (27 - c)/
       27 (Coefficient[LUerDelta, x, c]/Coefficient[ELPrPo, x, c]) // N,
     {i, 1, 2}
     ], (** end of inner Table **)

    {j, 1, Length[Pairs]}
    ] (** end of outer Table **)
   ];

This took a little over two minutes on my machine.

timeTabl
(* 129.307 *)

Use Complement rather than SubsetQ

On this site a discussion of performance of the built-in SubsetQ function can be found here.

Rather than using

SubsetQ[#1, Pairs[[j]]]

an increase of performance occurs if one uses

Complement[pair, #1] === {}

Note that the order of the arguments is reversed.

Another small enhancement was to compute LUer directly rather than using the intermediate variable LU.

{timeTab2, tabl2} = AbsoluteTiming[
  Table[
   LUer = Total[
     x^Map[
       Length,
       Select[ELPr, Complement[pair, #1] === {} &]
       ]
     ];

   LUerDelta = Expand[ELPrPo - LUer + LUer/x];

   Table[
    c = i;
    (27 - c)/
      27 (Coefficient[LUerDelta, x, c]/Coefficient[ELPrPo, x, c) // N,
    {i, 1, 2}
    ], (** end of Inner Table **)

   {pair, Pairs}
   ] (** end of Outer Table **)
  ]

This produces a significant increase in performance.

timeTabl2
(* 26.746 *)

This is a speedup of approximately a factor of five.

timeTabl/timeTabl3
(* 4.83465 *)

One can validate that the answers are (within numerical roundoff) the same by plotting the original vs the last answers using ListPlot.

Show[
 ListPlot[tabl, PlotStyle -> Blue],
 ListPlot[tab, 
  PlotMarkers -> {Graphics[{Red, Thin, Circle[]}], 0.05}]
 ]

Conclusion

A significant increase in performance was achieved by replacing

SubsetQ[#1, Pairs[[j]]]

with

Complement[pair, #1] === {}

This resulted in approximately 500% increase.

Since SubsetQ is called 38970 x 325 =~ 12,600,000` times it is clear that speeding up that computation would increase the performance.