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

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][]
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?

• This looks an edit to a question you asked previously: mathematica.stackexchange.com/q/148285 Jun 14 '17 at 23:19
• Yeah, sure, but after many changes I think my problem in the logic, not the code. Jun 14 '17 at 23:23
• Then it would a good idea for you to delete the previous question, Jun 14 '17 at 23:25
• I think it's pretty clear from Luis's code, and from his question (before it was edited), that he wants to divide the determinant of a $(n-2) \times (n-2)$ matrix by the determinant of a $(n-1) \times (n-1)$ matrix. My answer is the only one that does this. Luis, could you clarify? Jun 15 '17 at 1:55

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

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

• Thank you so much, Carl !!! It was exactly this what I was looking for ! I don't have enough reputation to vote, but I need to confirm that this is what I'm trying to do. Jun 15 '17 at 4:28
• @LuísEduardo But you said you wanted to delete row i and column j, not row i and j and column i and j.
– Alan
Jun 15 '17 at 5:35
• @LuísEduardo. Even if can't up-vote, you can show your approval by accepting this answer. You do that by clicking on the check mark that appears on the left of the answer below the down arrow. Jun 15 '17 at 8:41
• @Alan my post was edited by Mr Goldberg several times who maybe doesn't understand what I was looking for... But thanks for your help !! Jun 15 '17 at 15:22

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

• I don't understand this function. It didn't work! The output was just {1,1,1,1} to my 4x4 L matrix. Jun 14 '17 at 23:21
• @LuísEduardo Sorry for the typo. Fixed.
– Alan
Jun 15 '17 at 1:49
• Thanks, but it was not exactly this what I was looking for. Jun 15 '17 at 4:20
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}] • Thank you, your answer was very didactic, but it was similar to Alan, it's not exactly what I was looking for, because the solution will be different what I expected. Jun 15 '17 at 4:26
• @Luis, it is fixed now.
– kglr
Jun 16 '17 at 4:05

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