Permanent minors

Question

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

That gives me the permanent of a matrix, not the permanent minors. — Jesko Hüttenhain, Feb 28 '13 at 15:01
Could you please post a matrix and its permanent minors as an example? — Dr. belisarius, Feb 28 '13 at 15:22
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

Daniel Lichtblau · Accepted Answer · 2013-02-28T22:47:21.630

11

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

edited Feb 28 '13 at 22:47

answered Feb 28 '13 at 20:23

Daniel Lichtblau

58,970
2
101
199

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
4

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
That actually made me laugh out quite loud. – Jesko Hüttenhain Feb 28 '13 at 22:23
4

@DanielLichtblau It'd be worse if they were permanent minors... – rm -rf Feb 28 '13 at 23:47
4

@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 01 '13 at 00:05
2

@DanielLichtblau She wasn't talking about two kids and a pet. That's as good as you can get – Dr. belisarius Mar 01 '13 at 01:46

score 5 · Answer 2 · answered Feb 28 '13 at 17:27

5

Perhaps just:

pMinors[m_?MatrixQ, k_Integer] := Minors[Array[\[FormalM][##] &, Dimensions@m], k] /. 
                                                         -1 -> 1 /. \[FormalM][a__] :> m[[a]]

answered Feb 28 '13 at 17:27

Dr. belisarius

115,881
13
203
453

Heh, that's clever. Thanks a bunch! =D – Jesko Hüttenhain Feb 28 '13 at 17:32

score 5 · Answer 3 · edited Apr 13 '17 at 12:55

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} *)

I think you posted this around the same time I added something similar in an edit. — Daniel Lichtblau, Mar 01 '13 at 15:22
(If your timing was a hair better, you'd have sent your reply perhaps slightly before I posted my comment...) — Daniel Lichtblau, Mar 01 '13 at 15:30

Permanent minors

3 Answers3