14
$\begingroup$

Suppose I have the following list:

list = {a, b, c, d}

I want to generate this result:

{{f[a, a], f[a, b], f[a, c], f[a, d]}, {f[b, b], f[b, c],
  f[b, d]}, {f[c, c], f[c, d]}, {f[d, d]}}

What could be the shortest way?

The list elements can be anything and not necessarily sorted.

$\endgroup$
8
  • $\begingroup$ Very nice question, but I assume (because of your previous contributions) that you already have an answer (maybe not the shortest). If not, please excuse :) $\endgroup$
    – eldo
    Commented Jul 31, 2014 at 19:14
  • $\begingroup$ @eldo yes I have an answer but as you said it is not short. $\endgroup$ Commented Jul 31, 2014 at 19:43
  • $\begingroup$ Closely related: (9537), (42278) $\endgroup$
    – Mr.Wizard
    Commented Aug 1, 2014 at 0:43
  • 3
    $\begingroup$ Please see my updated answer. I argue against your choice of answer. $\endgroup$
    – Mr.Wizard
    Commented Aug 1, 2014 at 16:13
  • 1
    $\begingroup$ @eldo (1) halirutan's method is not the shortest, yet the question clearly asks for the shortest way. "Moving the goalposts" is generally discouraged here. (2) You will note that I removed my "duplicate" comment and replaced it with a related link. (3) Even as a moderator I am free to voice my opinion, which is all I have done. This is not the first time that I have argued for or against a particular choice. For example (7687) was really an extended comment arguing the superiority of kguler's answer. $\endgroup$
    – Mr.Wizard
    Commented Aug 1, 2014 at 23:50

13 Answers 13

12
$\begingroup$

How about a simple table?

Table[f @@ list[[{i, j}]], {i, 4}, {j, i, 4}]

If you want to use this for a general list, you should use Length[list] in the table iterators or maybe:

With[{n = Length[list]},
 Table[f @@ list[[{i, j}]], {i, n}, {j, i, n}]
]
$\endgroup$
5
  • 1
    $\begingroup$ Long live Fortran? $\endgroup$ Commented Jul 31, 2014 at 19:44
  • 2
    $\begingroup$ @haliturutan About to upvote, but couldn't you replace the static 4 with Length@list ??? $\endgroup$
    – eldo
    Commented Jul 31, 2014 at 19:53
  • 1
    $\begingroup$ Your table is prettier than mine. $\endgroup$ Commented Jul 31, 2014 at 19:56
  • $\begingroup$ @eldo Hehe, haliturutan sounds a bit like Truthahn in German :-) I edited the answer. $\endgroup$
    – halirutan
    Commented Aug 1, 2014 at 6:07
  • 2
    $\begingroup$ @alancalvitti Nope, I never used Fortran. Seems to be some other influence. $\endgroup$
    – halirutan
    Commented Aug 1, 2014 at 6:08
9
$\begingroup$

Solutions


Pick[
 Outer[f, list, list],
 UpperTriangularize@ConstantArray[True, {#, #} &@Length@list]
 ]

Using the new Composition shorthand:

Thread@*f @@@ MapIndexed[{#, list[[First@#2 ;;]]} &, list]

Timings


Testing with

list = Range[1000];

the first method takes 0.363 seconds to complete and the second takes 0.120 to complete. As a comparison, halirutan's Table method took 1.183 to complete. RunnyKine's is the fastest I have tested of the others, taking just 0.336 to complete. All times were measured with AbsoluteTiming.

$\endgroup$
4
  • 2
    $\begingroup$ @Uh, I like the use of the new Composition operator! Also, I would have gone with MapIndexed too but maybe combined it with Outer(but I don't have Mathematica to test right now) $\endgroup$
    – sebhofer
    Commented Jul 31, 2014 at 23:03
  • $\begingroup$ 6 significant digits for the timing results? Is this warranted (even if there is no variation in timing between several runs)? $\endgroup$ Commented Jul 31, 2014 at 23:17
  • $\begingroup$ @PeterMortensen Thanks for pointing this out; I was mindlessly copying what AbsoluteTiming told me, and didn't think about it. I looked through some other posts and they used three decimal numbers, so I updated and did the same. $\endgroup$
    – C. E.
    Commented Jul 31, 2014 at 23:25
  • 1
    $\begingroup$ Nice use of @* -- reasonably short and notably faster than my code. +1 :-) $\endgroup$
    – Mr.Wizard
    Commented Aug 1, 2014 at 16:19
6
$\begingroup$

This is not the shortest, but faster than all except Pickett's (almost just as fast)

f4 = Thread@f[#[[1]], #] & /@ Partition[#, Length@#, 1, {1, 1}, {}] &

OR

 dP = Developer`PartitionMap;

Then:

f5 = dP[Thread@f[#[[1]], #] &, #, Length@#, 1, {1, 1}, {}] &

Timings:

Needs["GeneralUtilities`"]

f1 = With[{n = Length[#]}, Table[f @@ #[[{i, j}]], {i, n}, {j, i, n}]] &; 

f2 = MapIndexed[#[[#2[[1]] ;;]] &, Outer[f, #, #]] &;

f3[x_] := Thread@*f @@@ MapIndexed[{#, x[[First@#2 ;;]]} &, x];

BenchmarkPlot[{f1, f2, f3, f4, f5}, RandomInteger[999, #] &, 2^Range[12

Mathematica graphics

$\endgroup$
0
5
$\begingroup$

A few obfuscations via Listable:

Block[{f, op},
 SetAttributes[f, Listable];
 op[x_] := {f[x, x]};
 op[x_, y__] := Sequence[f[x, {x, y}], op[y]];
 {op @@ list}
 ]


Block[{f},
 SetAttributes[f, Listable];
 f @@@ Table[{list[[i]], list[[i ;;]]}, {i, 4}]
 ]


Module[{op1, op2},
 op1 = Function[{x, l}, f[x, l], Listable];
 op2 = {op1[#, {##}], Sequence @@ If[{##2} =!= {}, op2[##2], {}]} &;
 op2 @@ list
 ]

Update

The second method above is actually pretty good. The others aren't bad, but they are limited by $RecursionLimit. This one is slightly faster:

f4 = Block[{f},
    SetAttributes[f, Listable];
    f[First[#], #] & /@ NestList[Rest, #, Length[#] - 1]
    ] &;

Timings

Adding to Mr.Wizard's comparison:

f1 = With[{n = Length[#]}, 
    Table[f @@ #[[{i, j}]], {i, n}, {j, i, n}]] &;

f2 = MapIndexed[#[[#2[[1]] ;;]] &, Outer[f, #, #]] &;

f3[x_] := Thread@*f @@@ MapIndexed[{#, x[[First@#2 ;;]]} &, x];

f4 = Block[{f},
    SetAttributes[f, Listable];
    f[First[#], #] & /@ NestList[Rest, #, Length[#] - 1]
    ] &;

Needs["GeneralUtilities`"]

BenchmarkPlot[{f1, f2, f3, f4}, RandomInteger[999, #] &, 2^Range[12]]

Mathematica graphics

$\endgroup$
5
$\begingroup$

I don't believe anyone has posted exactly this formulation:

MapIndexed[#[[#2[[1]] ;;]] &, Outer[f, #, #]] &

Not terribly efficient but the question asked for shortest, not fastest.


Argument

Although not optimal my method is both more efficient and shorter than the presently Accepted one.
The question clearly asked for the shortest way. You should not alter your standard after the fact.

Update: also including Pickett's code

Please consider:

f1 = With[{n = Length[#]}, Table[f @@ #[[{i, j}]], {i, n}, {j, i, n}]] &; 

f2 = MapIndexed[#[[#2[[1]] ;;]] &, Outer[f, #, #]] &;

f3[x_] := Thread@*f @@@ MapIndexed[{#, x[[First@#2 ;;]]} &, x];

Needs["GeneralUtilities`"]

BenchmarkPlot[{f1, f2, f3}, RandomInteger[999, #] &, 2^Range[12]]

enter image description here

$\endgroup$
4
$\begingroup$

A few more just for fun:

ReplaceList[list, {___, a__} :> Thread @ f[#& @ a, {a}]]

Thread @* f ~MapThread~ {list, NestList[Rest, list, 3]}

Pick[Outer[f, list, list], # <= #2 & ~Array~ {4, 4}]
$\endgroup$
3
$\begingroup$

There is probably something neater but the following works:

l = {a, b, c, d};
s = SplitBy[Tuples[l, {2}], First];
list = Take[s[[#]], #2] & @@@ Thread@{Range@Length@l, Range[-Length@l, -1]}
Map[f[Sequence @@ #] &, list, {-2}]
{{f[a, a], f[a, b], f[a, c], f[a, d]}, {f[b, b], f[b, c], f[b, d]}, 
 {f[c, c], f[c, d]}, {f[d, d]}}
$\endgroup$
3
$\begingroup$

Here is a straightforward implementation...

Table[Table[f[list[[i]], list[[j]]], {j, i, Length@list}], {i, Length@list}]

Here is my flattened table: If list is a sorted list of unique elements

list = {a, b, c, d}
g[a_, b_] := f @@ Sort@{a, b};
Union@Flatten@Outer[g, list, list]
$\endgroup$
2
  • $\begingroup$ My table is flat... $\endgroup$ Commented Jul 31, 2014 at 19:24
  • $\begingroup$ no the list is not sorted. it is random $\endgroup$ Commented Jul 31, 2014 at 19:38
3
$\begingroup$
Thread[f[First@#, #]] & /@ 
 NestList[Drop[#, 1] &, list, Length[list] - 1]

The above is a refinement of less efficient 1st attempt:

First@Outer[f, #, #] & /@ 
 NestList[Drop[#, 1] &, list, Length[list] - 1]
$\endgroup$
2
$\begingroup$
Outer[f, list, list] /. 
 f[x_, y_] /; 
   First@First@Position[list, x] >  First@First@Position[list, y] :> 
  Sequence[] 

What's annoying here is projecting #[[1,1]]&. How to make {{1}} <= {{2}} evaluate True?

$\endgroup$
2
$\begingroup$

Building up an Association

len=Length@list;
asso=<||>;
(asso[#]=list[[-#]])&/@Range@len;

and then

Array[Function[x,Array[f[x,#]&,x,{x,1}]],len,{len,1}]/.asso
$\endgroup$
2
$\begingroup$

Throwing my hat to the ring

Clear[splitList]
splitList[f_, list_List] := 
 SplitBy[DeleteDuplicates[Sort /@ Tuples[Sort[Hold[f] @@ list], 2]], First] // ReleaseHold

splitList[f, {a, b, c, d}]
(* {{f[a, a], f[a, b], f[a, c], f[a, d]}, {f[b, b], f[b, c], 
  f[b, d]}, {f[c, c], f[c, d]}, {f[d, d]}} *)

splitList[Plus, {a, b, c, d}]
(* {{2 a, a + b, a + c, a + d}, {2 b, b + c, b + d}, {2 c, c + d}, {2 d}} *)
$\endgroup$
1
  • $\begingroup$ @RunnyKine I fixed my answer based on your suggestion. Try splitList[f, {a, b, c, 6, d, 5, b}] and let me know what you think. $\endgroup$
    – seismatica
    Commented Aug 1, 2014 at 18:24
1
$\begingroup$
f1 = SplitBy[Tuples[f @@ #, 2] /. ( f[x__] /; Not[OrderedQ[{x}]] :> (## &[])), First]& 

f1 @ list // Grid // TeXForm

$\begin{array}{cccc} f(a,a) & f(a,b) & f(a,c) & f(a,d) \\ f(b,b) & f(b,c) & f(b,d) & \text{} \\ f(c,c) & f(c,d) & \text{} & \text{} \\ f(d,d) & \text{} & \text{} & \text{} \\ \end{array}$

Also

f2[l_] := Module[{i = 1, j}, Thread[j = i++; f[l[[j]], l[[j ;;]]]] & /@ l]

f2 @ list == f1 @ list

True

$\endgroup$

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.