11
$\begingroup$

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.

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

7 Answers 7

7
$\begingroup$

Two functions to consider: Diagonal and Reverse

Your data:

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]

Mathematica graphics


Documentation

Mathematica graphics

Mathematica graphics

$\endgroup$
2
  • 2
    $\begingroup$ The same idea, but only one reverse: Reverse@m~Diagonal~# & /@ Range[1 - Length@m, 0] $\endgroup$
    – ybeltukov
    Nov 13, 2015 at 22:57
  • 2
    $\begingroup$ At that point, I'd have used an explicit Table[], tho: Table[Diagonal[Reverse[m], k], {k, 1 - Length[m], 0}] $\endgroup$ Nov 14, 2015 at 2:33
6
$\begingroup$
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}}

$\endgroup$
6
$\begingroup$

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}}*)
$\endgroup$
6
  • $\begingroup$ @"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. $\endgroup$ Nov 13, 2015 at 22:50
  • $\begingroup$ 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. $\endgroup$
    – march
    Nov 13, 2015 at 23:16
  • $\begingroup$ 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? $\endgroup$
    – march
    Nov 14, 2015 at 0:00
  • $\begingroup$ @march, at that point I use an explicit Apply[] rather than appeal to a baroque construction. ;) $\endgroup$ Nov 14, 2015 at 2:24
  • 1
    $\begingroup$ @march Thanks! surely a copy-paste-mess error $\endgroup$ Nov 14, 2015 at 3:46
5
$\begingroup$

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}]
$\endgroup$
4
$\begingroup$
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}}

$\endgroup$
2
$\begingroup$

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

The solution in this answer:

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

Since submitting the answer two more answers have appeared.

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} *)
$\endgroup$
3
  • $\begingroup$ I find it surprising that my second solution is faster than my third. Interesting. $\endgroup$
    – march
    Nov 13, 2015 at 23:51
  • $\begingroup$ @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. $\endgroup$ Nov 14, 2015 at 0:41
  • $\begingroup$ 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. $\endgroup$
    – march
    Nov 14, 2015 at 0:43
2
$\begingroup$

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]
$\endgroup$
0

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.