# Extract left-upper triangular data from a square matrix-form list

Hopefully, this question is not too basic or obscure. I'd like an idea on how to extract this

{{1}, {5, 2}, {9, 6, 3}, {13, 10, 7, 4}}


from

m = {{1, 2, 3, 4}, {5, 6, 7, 8}, {9, 10, 11, 12}, {13, 14, 15, 16}}


Naturally, the square matrix can grow in size, but I will need upper-left (reverse-triangular) information from it (including reverse-diagonal itself).

I thought this can be done by fist permuting (rotating) the matrix and then extracting upper or lower triangular, but not sure if Mathematica has the tools to follow on this approach or if there is a more natural/easier way.

Thanks in advance for a constructive idea or a reference to it.

• @rhermans . Thank you for suggestions and links. I will take the time to follow up on references and answers Commented Nov 13, 2015 at 21:57

Two functions to consider: Diagonal and Reverse

m = {{1, 2, 3, 4}, {5, 6, 7, 8}, {9, 10, 11, 12}, {13, 14, 15, 16}}


## Solution

Reverse@Table[
Reverse@Diagonal[Reverse /@ m, k], {k, 0, Length[m] - 1}]

{{1}, {5, 2}, {9, 6, 3}, {13, 10, 7, 4}}


Function:

lut[m_] :=
Reverse@Table[
Reverse@Diagonal[Reverse /@ m, k], {k, 0, Length[m] - 1}]


or as pointed by J. M.

 lut[m_] := Table[Diagonal[Reverse[m], k], {k, 1 - Length[m], 0}]


## Extended example

Column@Array[MatrixForm@lut@Partition[Range[# #], #] &, 7]


## Documentation

• The same idea, but only one reverse: Reverse@m~Diagonal~# & /@ Range[1 - Length@m, 0] Commented Nov 13, 2015 at 22:57
• At that point, I'd have used an explicit Table[], tho: Table[Diagonal[Reverse[m], k], {k, 1 - Length[m], 0}] Commented Nov 14, 2015 at 2:33
m = {{1, 2, 3, 4}, {5, 6, 7, 8}, {9, 10, 11, 12}, {13, 14, 15, 16}};

MapThread[m[[##]] &, {Reverse@Range@#, Range@#}] & /@ Range@Length@m


{{1}, {5, 2}, {9, 6, 3}, {13, 10, 7, 4}}

Just to show a less elegant way :)

f[m_] := Apply[m[[##]] &, Table[{i - j + 1, j}, {i, Length@m}, {j, i}], {2}]
f@m
(*{{1}, {5, 2}, {9, 6, 3}, {13, 10, 7, 4}}*)

• @"belisaurius has settled" I copied and pasted the definition twice but am getting an error message Part specification ... is longer than the depth of the object. Commented Nov 13, 2015 at 22:50
• I get the same error as @JackLaVigne! I used Extract instead of Part for this type of solution to avoid exactly that problem, I think. Commented Nov 13, 2015 at 23:16
• Ah! Fixed it: m[[##]] & @@@ # & /@ Table[{i - j + 1, j}, {i, Length@m}, {j, i}]. Now, have you ever before used a construction like f @@@ #& /@ list? Commented Nov 14, 2015 at 0:00
• @march, at that point I use an explicit Apply[] rather than appeal to a baroque construction. ;) Commented Nov 14, 2015 at 2:24
• @march Thanks! surely a copy-paste-mess error Commented Nov 14, 2015 at 3:46

Here's a different version, much more verbose.

m = {{1, 2, 3, 4}, {5, 6, 7, 8}, {9, 10, 11, 12}, {13, 14, 15, 16}};

DeleteCases[#, 0]&@*Reverse /@ Transpose @ UpperTriangularize @ MapThread[RotateRight[#1, #2] &, {m, Range[0, Length@m - 1]}]


Here's another one, slightly less verbose:

MapIndexed[Reverse@#1[[;; First@#2]] &, Transpose@MapThread[RotateRight[#1, #2] &, {m, Range[0, Length@m - 1]}]]


Even less verbose:

Extract[m, #] & /@ Table[{n - j + 1, j}, {n, 1, Length@m}, {j, 1, n}]

upperOffTriag[m_] := With[
{i = Table[Table[{n, k + 1 - n}, {n, k, 1, -1}], {k, 1, First@Dimensions[m]}]},
Map[Part[m, Sequence @@ #] &, i, {2}]
]

upperOffTriag[m]


{{1}, {5, 2}, {9, 6, 3}, {13, 10, 7, 4}}

Very verbose but I was trying to find a different way :)

Reverse[Flatten@
Pick[m, Normal@
SparseArray[{{i_, j_} /; Abs[j + i] == # -> 1}, {4, 4}], 1] & /@
Range[2, 5], 2]


We want to extract the index of the upper left triangular position using the positions:

{1,1}
{2,1}
{1,2}
{3,1}
{2,2}
{1,3}
⋮


The following function using Table uses the algorithm so that the row increments and then decrements as the column increments (not sure the words make sense but look at the algorithm below).

lut1[m_] := Table[
Table[
m[[j - i + 1, i]],
{i, 1, j}
],
{j, Length@m}
]


So now with

m = {{1, 2, 3, 4}, {5, 6, 7, 8}, {9, 10, 11, 12}, {13, 14, 15, 16}}


lut1[m] produces

{{1}, {5, 2}, {9, 6, 3}, {13, 10, 7, 4}}


Timing

Let's take a quick look at timing for a large matrix.

bigM = Table[i + j, {i, 1000}, {j, 1000}];


Applying rherman's first solution

lut[m_] :=
Reverse@Table[
Reverse@Diagonal[Reverse /@ m, k], {k, 0, Length[m] - 1}]

lut[bigM]; // Timing
(* {4.00923, Null} *)


lut1[bigM]; // Timing
(* {0.577204, Null} *)


is a bit faster.

But if you are looking for blinding speed, nothing beats March's second answer:

lut2[m_] :=
MapIndexed[Reverse@#1[[;; First@#2]] &,
Transpose@
MapThread[RotateRight[#1, #2] &, {m, Range[0, Length@m - 1]}]]

lut2[bigM]; // Timing
(* {0.0156001, Null} *)


## Update

Suba Thomas

upperOffTriag[m_] := With[
{i = Table[Table[{n, k + 1 - n}, {n, k, 1, -1}], {k, 1, First@Dimensions[m]}]},
Map[Part[m, Sequence @@ #] &, i, {2}]
]

upperOffTriag[bigM]; // Timing
(* {1.46641, Null} *)


Eldo

lutEldo[m_] :=
MapThread[m[[##]] &, {Reverse@Range@#, Range@#}] & /@ Range@Length@m

lutEldo[bigM]; // Timing
(* {0.592804, Null} *)

• I find it surprising that my second solution is faster than my third. Interesting. Commented Nov 13, 2015 at 23:51
• @march I get it is about 25 times slower ~ 0.4 compared to 0.0156. I don't know if this is related to the selection of 1000 x 1000 for the size. Commented Nov 14, 2015 at 0:41
• Yeah, me too. I just think it's weird. And I checked that the construction of the list of coordinates is essentially instantaneous. Since (I think) Map takes advantage of vectorized operations, there must be a lot of overhead for each call to Extract. Commented Nov 14, 2015 at 0:43
m = {{1, 2, 3, 4}, {5, 6, 7, 8}, {9, 10, 11, 12}, {13, 14, 15, 16}};


Another way using Reap and Sow:

Reap[Do[Sow[Diagonal[Thread[Reverse[m]], k]], {k, Length[m] - 1, 0, -1}]][[2, 1]]


{{1}, {5, 2}, {9, 6, 3}, {13, 10, 7, 4}}

Without using Reverse, Diagonal or Flatten:

Clear["Global*"];
m = {{1, 2, 3, 4}, {5, 6, 7, 8}, {9, 10, 11, 12}, {13, 14, 15, 16}}
pos = Permutations /@ IntegerPartitions[#, {2}] & /@ {2, 3, 4, 5} //
Map[Catenate] // Map[SortBy[{Last, First}]];
Extract[m, #] & /@ pos
`

{{1}, {5, 2}, {9, 6, 3}, {13, 10, 7, 4}}