4
$\begingroup$

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 (!!!)
$\endgroup$
8
$\begingroup$

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)$

$\endgroup$
  • 1
    $\begingroup$ wow, the second solution is more than 2600times faster than my approach :-o. Awesome! $\endgroup$ – Mario Krenn Aug 13 '14 at 13:08
  • $\begingroup$ 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! $\endgroup$ – Mario Krenn Aug 14 '14 at 0:18
  • $\begingroup$ @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? $\endgroup$ – Mr.Wizard Aug 14 '14 at 5:20
  • 1
    $\begingroup$ @NicoDean Assuming I understand now your "ugly workaround" seems like a perfectly good approach. However I'll add another one to my answer. $\endgroup$ – Mr.Wizard Aug 14 '14 at 10:20
  • 1
    $\begingroup$ @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. $\endgroup$ – Mr.Wizard Aug 14 '14 at 17:19
3
$\begingroup$

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

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.