Time-efficient creation of matrix

Question

I have expressions like

xx1=FF[1, 1] GG[1, 1] + FF[1, 1] GG[2, 2] + FF[2, 2] GG[2, 2]
xx2=2*FF[1, 2] GG[1, 1] + FF[1, 1] GG[1, 2] + FF[2, 2] GG[2, 2]

and I want to transform it to special matrices

CreateMatrix[xx1] (* {{1, 1}, {0, 1}} *)
CreateMatrix[xx2] (* {{0, 1, 0}, {2, 0, 0}, {0, 0, 1}} *)

The logic of CreateMatrix is that we construct a grid like this (here using elements from xx1):

{{FF[1, 1] GG[1, 1], FF[1, 1] GG[2, 2]}, 
 {FF[2, 2] GG[1, 1], FF[2, 2] GG[2, 2]}}

and if say FF[1,1] GG[1,1] exists in the expression then its coefficient takes the place of F[1,1], GG[1,1] in the grid. Elements that exist in the grid but not in the expression are taken to be zero.

My code works, but is slow (it runs a double-for-loop to fill the matrix):

CreateMatrix[state_] := (
  ElementsFF = Union[Cases[state, _FF, {0, Infinity}]];
  ElementsGG = Union[Cases[state, _GG, {0, Infinity}]];
  MatrixSize = Length[ElementsFF];
  startTime = AbsoluteTime[];
  If[MatrixSize > 0,
   dM = IdentityMatrix[MatrixSize];
   For[k = 1, k <= MatrixSize, k++,
    For[l = 1, l <= MatrixSize, l++,
      dM[[k, l]] = state /. {ElementsFF[[k]]*ElementsGG[[l]] -> 1};
      ];
    ];
   Block[{FF}, FF[__] = 0; dM = dM];
   Print["After MatrixConstr: " <> ToString[AbsoluteTime[] - startTime]]; 
   startTime = AbsoluteTime[];,
   dM = 0;
   ];
  Return[dM];
  )

xx1= FF[1, 1] GG[1, 1] + FF[1, 1] GG[2, 2] + FF[2, 2] GG[2, 2]
CreateMatrix[xx1]

A small part of the code is already optimized from an earlier partial question.

Can you create a faster algorithm for the given problem?

Comparison

I test with three huge matrices (those which I need later).

My original approach

• {136.7564571, 51.4342097, 20.0780016} seconds

kguler's solution

• {123.7996434, 46.8804843, 19.1074500} seconds

Mr.Wizard's solution1

• {123.3144573, 47.5587309, 18.2832670} seconds

Mr.Wizard's solution2

• {0.0510345, 0.0315209, 0.0255171} seconds (!!!)

Answer 1

Your code is like a Rube Goldberg machine! Try this instead:

fn[state_] :=
 Outer[Coefficient[state, #*#2] &, ##] & @@
  (Union @ Cases[state, #, -2] & /@ {_FF, _GG})

Test:

test = 7 FF[1, 1] GG[1, 1] + 2 FF[1, 1] GG[2, 2] + 4 FF[2, 2] GG[2, 2] + 11 FF[2, 1] GG[2, 4];

fn[test] // MatrixForm

$\left( \begin{array}{ccc} 7 & 2 & 0 \\ 0 & 0 & 11 \\ 0 & 4 & 0 \\ \end{array} \right)$

Also look at CoefficientArrays:

CoefficientArrays[test, Sort @ Variables @ test][[3]] // MatrixForm

$\left( \begin{array}{cccccc} 0 & 0 & 0 & 7 & 2 & 0 \\ 0 & 0 & 0 & 0 & 0 & 11 \\ 0 & 0 & 0 & 0 & 4 & 0 \\ 0 & 0 & 0 & 0 & 0 & 0 \\ 0 & 0 & 0 & 0 & 0 & 0 \\ 0 & 0 & 0 & 0 & 0 & 0 \\ \end{array} \right)$

---

If it is to be assumed that all symbolic coefficients that appear are to be treated like _FF and _GG above a general method may be written using CoefficientArrays as follows:

fn2[state_] :=
 With[{sa = CoefficientArrays[state, Sort @ Variables @ state][[3]]},
  Normal @ sa[[##]] & @@ (Min@# ;; Max@# &) /@ (sa @ "NonzeroPositions"\[Transpose])
 ]

This is superior to using Coefficient as the state expression is not rescanned repeatedly, leading to significantly better performance. As a rather extreme example:

Needs["GeneralUtilities`"]

test2 = Sum[RandomInteger[999] FF[i] GG[j], {i, 30}, {j, 30}];

(r1 = fn[test2])  // AccurateTiming
(r2 = fn2[test2]) // AccurateTiming

1.613092

0.00180972

r1 === r2

True

---

One more update to address the new format you describe in a comment.

fn3[state_] :=
 MapThread[{#, #2} -> #3 &,
   MapAt[
     ArrayComponents[#, 1] &,
     Cases[state, C_*_[a_, b_, c_, d_] :> {{a, b}, {c, d}, C}]\[Transpose],
     ;; 2
   ]
 ] // SparseArray

Now:

t2 = test /. FF[a_, b_] GG[c_, d_] :> JJ[a, b, c, d]

7 JJ[1, 1, 1, 1] + 2 JJ[1, 1, 2, 2] + 11 JJ[2, 1, 2, 4] + 4 JJ[2, 2, 2, 2]

fn3[t2] // MatrixForm

$\left( \begin{array}{ccc} 7 & 2 & 0 \\ 0 & 0 & 11 \\ 0 & 4 & 0 \\ \end{array} \right)$

Answer 2

A variation on @MrW's answer using a combination of Outer, Coefficient, Variables and GatherBy:

func = Function[{state}, 
   Coefficient[state, #] &@
    Outer[Times, ## & @@ (Sort /@ GatherBy[Variables[state], Head])]];

Test:

xx1 = FF[1, 1] GG[1, 1] + FF[1, 1] GG[2, 2] + FF[2, 2] GG[2, 2];
xx2 = 2*FF[1, 2] GG[1, 1] + FF[1, 1] GG[1, 2] + FF[2, 2] GG[2, 2];
test = 7 FF[1, 1] GG[1, 1] + 2 FF[1, 1] GG[2, 2] + 
   4 FF[2, 2] GG[2, 2] + 11 FF[2, 1] GG[2, 4];
test2 = 7 FF[3, 1] GG[1, 1] HH[1, 1] + 2 FF[3, 1] GG[2, 2] HH[1, 2] + 
  4 FF[2, 2] GG[2, 2] + 11 FF[2, 1] GG[2, 4] HH[1, 3]

func[xx1]
(* {{1, 1}, {0, 1}} *)
func[xx2]
(* {{0, 1, 0}, {2, 0, 0},{0, 0, 1}} *)
func[test]
(* {{7, 2, 0}, {0, 0, 11}, {0, 4, 0}} *)
func[test2]
(*{{{0, 0, 0}, {0, 0, 0}, {0 ,0, 11}},
   {{0, 0, 0}, {0, 0, 0}, {0, 0, 0}},
   {{7, 0, 0}, {0, 2, 0}, {0, 0, 0}}}*)