Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

The function Minors yields the minors of a matrix. Is there a function that yields the permanent minors of a matrix?

share|improve this question
    
Anything wrong with the code in your link? –  ssch Feb 28 '13 at 14:57
2  
That gives me the permanent of a matrix, not the permanent minors. –  Jesko Hüttenhain Feb 28 '13 at 15:01
2  
Could you please post a matrix and its permanent minors as an example? –  belisarius Feb 28 '13 at 15:22
3  
Make a call to Minors[Array[Subscript[a,##]&,{n,n}],k] for any n and k<n, then replace all minus signs by plus signs =) –  Jesko Hüttenhain Feb 28 '13 at 16:07

3 Answers 3

up vote 9 down vote accepted

For matrices of numbers this is fairly efficient.

perm[mat_] := Module[{v, vec},
  vec = Array[v, Length[mat]];
  Coefficient[Times @@ (mat.vec), Times @@ vec]
  ]

permMinors[mat_, k_Integer] := Minors[mat, k, perm]

Example:

n = 12;
mat = RandomInteger[{-10, 10}, {n, n}];
Timing[p1 = permMinors[mat, n - 1];]

(* Out[228]= {19.910000, Null} *)

--- edit ---

I should mention that I did not come up with this method of computing a permanent. I was fairly certain I had seen it before. Tracking through past email, it turns out that Stephen Wolfram had sent substantially the code same to a bunch of people here, soliciting comments on efficiency (might have been related to his NKS book, I'm not sure).

For symbolic matrices the following may work better.

permanent2[m_] /; Length[m]==1 := m[[1,1]]
permanent2[m_] := permanent2[m] = With[{mp=Drop[m,None,1]},
    Apply[Plus, Table[m[[j,1]]*permanent2[Drop[mp,{j}]], {j,Length[m]}]]]

That was my one modest contribution to the thread. (This was in 1999; I now realize it was his 40th birthday. Also my brother's.)

--- end edit ---

share|improve this answer
1  
Actually, that answers my question perfectly. I did not know you could give a third argument to Minors, this is absolutely perfect. –  Jesko Hüttenhain Feb 28 '13 at 22:07
3  
I'm quite experienced with this, having dealt with an infinitude of arguments when my kids were minors... –  Daniel Lichtblau Feb 28 '13 at 22:21
2  
@DanielLichtblau It'd be worse if they were permanent minors... –  rm -rf Feb 28 '13 at 23:47
2  
@rm -rf I guess I walked into that. So I'll come back with an anecdote. Where my wife teaches, at first staff meeting several years ago, people were asked to say something brief about themselves. Her remark ended "...and I have three children: my daughter, my son, and my husband." –  Daniel Lichtblau Mar 1 '13 at 0:05
1  
@DanielLichtblau She wasn't talking about two kids and a pet. That's as good as you can get –  belisarius Mar 1 '13 at 1:46

Perhaps just:

pMinors[m_?MatrixQ, k_Integer] := Minors[Array[\[FormalM][##] &, Dimensions@m], k] /. 
                                                         -1 -> 1 /. \[FormalM][a__] :> m[[a]]
share|improve this answer
    
Heh, that's clever. Thanks a bunch! =D –  Jesko Hüttenhain Feb 28 '13 at 17:32

This seems like a case where memoizing could save a lot of speed.

Clear[perm2]

(* The permanent of the submatrix using rows I and columns J. *)
perm2[mat_, I_, J_] := perm2[mat, I, J] =
 If[Length[I] != Length[J], Print["Nonsquare permanent"],
   If[I == {}, 1,
     With[{k = Length[I]}, 
       Table[mat[[i, Last[J]]], {i, I}].Table[perm2[mat, Drop[I, {i}], Drop[J, {-1}]], {i, 1, k}]]]]  

 permMinors2[mat_, k_] :=
   With[{S = Subsets[Range[Length[mat]], {k}]}, Table[perm2[mat, s, t], {s, S}, {t, S}]]

I also loaded Daniel Lichtblau's solution. His testing run:

n = 12;
mat = RandomInteger[{-10, 10}, {n, n}];
Timing[p1 = permMinors[mat, n - 1];]

(* Out[43] = {37.6319, Null} *)

and mine

Timing[p2 = permMinors2[mat, n - 1];]

(* Out[44] = {1.06447, Null} *)

Check that the code works:

p1 == p2

(* Out[45] = True *)

Replacing the dot product of two Table[]s with Sum[] makes the code a little more readable:

perm3[mat_, I_, J_] := perm3[mat, I, J] =
  If[Length[I] != Length[J], Print["Nonsquare permanent"],
    If[I == {}, 1,
      With[{k = Length[I]}, 
        Sum[mat[[I[[i]], Last[J]]]*perm3[mat, Drop[I, {i}], Drop[J, {-1}]], {i, 1, k}]]]]

 permMinors3[mat_, k_] := 
    With[{S = Subsets[Range[Length[mat]], {k}]}, Table[perm3[mat, s, t], {s, S}, {t, S}]]

But has basically no effect on speed

Timing[p3 = permMinors3[mat, n - 1];]

(* Out[100] = {1.11478, Null} *)
share|improve this answer
1  
I think you posted this around the same time I added something similar in an edit. –  Daniel Lichtblau Mar 1 '13 at 15:22
    
Ah, so you did. –  David Speyer Mar 1 '13 at 15:24
    
(If your timing was a hair better, you'd have sent your reply perhaps slightly before I posted my comment...) –  Daniel Lichtblau Mar 1 '13 at 15:30

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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