Permanent minors

Question

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

Answer 1

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

Answer 2

Perhaps just:

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

Answer 3

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