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.

|improve this question
$\endgroup$
  • $\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 Jul 31 '14 at 19:14
  • $\begingroup$ @eldo yes I have an answer but as you said it is not short. $\endgroup$ – Algohi Jul 31 '14 at 19:43
  • $\begingroup$ Closely related: (9537), (42278) $\endgroup$ – Mr.Wizard♦ Aug 1 '14 at 0:43
  • 3
    $\begingroup$ Please see my updated answer. I argue against your choice of answer. $\endgroup$ – Mr.Wizard♦ Aug 1 '14 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♦ Aug 1 '14 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}]
]
|improve this answer
$\endgroup$
  • 1
    $\begingroup$ Long live Fortran? $\endgroup$ – alancalvitti Jul 31 '14 at 19:44
  • 2
    $\begingroup$ @haliturutan About to upvote, but couldn't you replace the static 4 with Length@list ??? $\endgroup$ – eldo Jul 31 '14 at 19:53
  • 1
    $\begingroup$ Your table is prettier than mine. $\endgroup$ – Timothy Wofford Jul 31 '14 at 19:56
  • $\begingroup$ @eldo Hehe, haliturutan sounds a bit like Truthahn in German :-) I edited the answer. $\endgroup$ – halirutan♦ Aug 1 '14 at 6:07
  • 2
    $\begingroup$ @alancalvitti Nope, I never used Fortran. Seems to be some other influence. $\endgroup$ – halirutan♦ Aug 1 '14 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.

|improve this answer
$\endgroup$
  • 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 Jul 31 '14 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$ – Peter Mortensen Jul 31 '14 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. Jul 31 '14 at 23:25
  • 1
    $\begingroup$ Nice use of @* -- reasonably short and notably faster than my code. +1 :-) $\endgroup$ – Mr.Wizard♦ Aug 1 '14 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

|improve this answer
$\endgroup$
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

|improve this answer
$\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

|improve this answer
$\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}]
|improve this answer
$\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]}}
|improve this answer
$\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]
|improve this answer
$\endgroup$
  • $\begingroup$ My table is flat... $\endgroup$ – Timothy Wofford Jul 31 '14 at 19:24
  • $\begingroup$ no the list is not sorted. it is random $\endgroup$ – Algohi Jul 31 '14 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]
|improve this answer
$\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?

|improve this answer
$\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
|improve this answer
$\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}} *)
|improve this answer
$\endgroup$
  • $\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 Aug 1 '14 at 18:24
0
$\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

|improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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