# Time-efficient creation of matrix

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 (!!!)

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][] // 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][]},
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 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_] :=
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)$

• wow, the second solution is more than 2600times faster than my approach :-o. Awesome! – Mario Krenn Aug 13 '14 at 13:08
• I tried to use your code, but replaced the input FF[a, b] GG[c, d] by JJ[a,b,c,d]. I was unable to change it. Could you please give a hint? Thx! – Mario Krenn Aug 14 '14 at 0:18
• @NicoDean I'm sorry but I don't understand what you mean. Would you please append a complete example of the input and output that you expect for this new case? – Mr.Wizard Aug 14 '14 at 5:20
• @NicoDean Assuming I understand now your "ugly workaround" seems like a perfectly good approach. However I'll add another one to my answer. – Mr.Wizard Aug 14 '14 at 10:20
• @Nico I can only follow the examples that you give me. I suggest converting any other formats you encounter using your "ugly workaround" and then using fn2 but I also wanted to show you how this might be done without CoefficientArrays. I think the original question has been well answered now so if you have further extensions please post a new Question. – Mr.Wizard Aug 14 '14 at 17:19

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}}}*)
`
• +1 for making it general. I had another answer using pattern matching but yours and @Mr.Wizard's answers were clearly superior than mine. – seismatica Aug 13 '14 at 2:25
• @kguler nice, this generalization. – sjdh Aug 13 '14 at 4:08
• Please see the update to my answer. – Mr.Wizard Aug 13 '14 at 6:12