Creating a matrix from the determinants of submatices of a given square matrix

Question

I'm trying to create a Mathematica algorithm creates a matrix f when given a $n \times n$ square matrix L

1. If i = j, then f[[i, i]] = 0

2. If i != j, then f[[i, j]] = d[L, {i, j}] /d[L, {i, i}]

where d[L, {i, j}] is the determinant of s[L, {i, j}], and s[L, {i, j}] is the sub-matrix of L which omits all elements of L that have a row index or a column index that appears in the list {i, j}, where 1 <= i <= n and 1 <= j <= n.

Note that when i != j. s[L, {i, j}] has dimensions {n - 2, n - 2}, because it omits two distinct indices, while s[L, {i, i}] has dimensions {n - 1, n - 1} because it omits only one.

My problem is that I'm trying to use Drop to delete rows and columns, but I get this error when L is a 4 x 4 matrix.

Drop::drop: Cannot drop positions 4 through 4 in {{3,-1,-1},{-1,3,-1},{-1,-1,3}}.

My code is:

n = Dimensions[L][[1]]
f = 
  Table[
    If[i != j,
      Det[Drop[Drop[L, {i}, {i}], {j}, {j}]]/Det[Drop[L, {i}, {i}]], 
      f[[i, j]] = 0], 
    {i, n}, {j, n}]

I tried to change j to j-1, but doing so changes the concept of my problem and generates an incorrect matrix f.

Maybe my logic is not good. Could anyone help me?

Answer 1

A related Mathematica function is Minors, but that does more work than you need. So, here is a more custom version:

minor[L_, {i_, j_}] := With[{x = Delete[Range @ Length @ L, {{i}, {j}}]},
    Det @ L[[x, x]]
]

By happenstance, this version works when $i=j$ as well. For example, suppose:

SeedRandom[1];
L = RandomInteger[20, {4, 4}]
L //TeXForm

{{5, 0, 7, 0}, {2, 3, 0, 0}, {16, 14, 3, 8}, {19, 5, 18, 16}}

$\left( \begin{array}{cccc} 5 & 0 & 7 & 0 \\ 2 & 3 & 0 & 0 \\ 16 & 14 & 3 & 8 \\ 19 & 5 & 18 & 16 \\ \end{array} \right)$

Then, we can answer your question with:

n = Length @ L;
Table[If[i==j, 0, minor[L, {i, j}]/minor[L, {i, i}]], {i, n}, {j, n}]
% //TeXForm

{{0, 1/3, -(1/6), -(1/32)}, {12/151, 0, -(10/151), 97/1208}, {1/5, 1/3, 0, 1/ 16}, {-(9/95), 97/95, -(3/19), 0}}

$\left( \begin{array}{cccc} 0 & \frac{1}{3} & -\frac{1}{6} & -\frac{1}{32} \\ \frac{12}{151} & 0 & -\frac{10}{151} & \frac{97}{1208} \\ \frac{1}{5} & \frac{1}{3} & 0 & \frac{1}{16} \\ -\frac{9}{95} & \frac{97}{95} & -\frac{3}{19} & 0 \\ \end{array} \right)$

Answer 2

Is this the function you're after?

f = Function[{m, ij}, With[{i = First@ij, j = Last@ij},
  If[i == j, 0,Det[Drop[m, {i}, {j}]]/Det[Drop[m, {i}, {i}]]]]
]

If so, you can just

MapIndexed[f[L, #2] &, L, {2}]

Edit:

Given the edits to the question, you need to make a small change to the function:

f = Function[{m, ij}, 
  With[{i = First@ij, j = Last@ij, mn = Min@ij, mx = Max@ij},
   If[i == j, 0,
    Det[Drop[Drop[m, {mx}, {mx}], {mn}, {mn}]]/Det[Drop[m, {i}, {i}]]]
   ]]

Answer 3

ClearAll[f, f1, f2]
f[L_] := Divide @@ (First[Extract[L, {{#, #}}, Det]] & /@ 
         (Complement[Range@Length@L, #] & /@ {{##}, {#}})) &

f1[L_] := Table[If[i == j, 0, f[L][i, j]], {i, Length@L}, {j, Length@L}]

f2[L_] := Array[f[L], {#, #}] - IdentityMatrix[#] & @ Length[L]



Row[MatrixForm /@ {L, f1 @ L, f2 @ L}]

Answer 4

This is based on the now corrected definition of f in the question, which in turn is based on Carl Woll's insights.

d[mat_, all_, {i_, j_}] :=
  With[{indices = Delete[all, {{i}, {j}}]}, Det @ mat[[indices, indices]]]
f[m_?SquareMatrixQ] :=
   Module[{indices, subdets},
     indices = Range @ Length @ m;
     subdets = Array[d[m, indices, {##}] &, Dimensions[m]];
     ReplacePart[subdets/Diagonal[subdets], {i_, i_} -> 0]]

I think this code is a little more efficient than Carl's.

Here are some test cases.

f @ Array[a, {3, 3}]

f @ {{5, 0, 7, 0}, {2, 3, 0, 0}, {16, 14, 3, 8}, {19, 5, 18, 16}}