# Using Apply over multi-dimensional table

Consider the following two codes. The first one

Table[Total[DeleteDuplicates[{p[i1], p[i2]}]], {i1, 2}, {i2, 2}]


works:

{{p[1], p[1] + p[2]}, {p[1] + p[2], p[2]}}

but the second one

Table @@ {Total[DeleteDuplicates[{p[i1], p[i2]}]], {i1, 2}, {i2, 2}}


does not:

{{2 p[1], p[1] + p[2]}, {p[1] + p[2], 2 p[2]}}

However, I want to construct this table in $m$-dimensional case, which means

t[n_, m_] := Table @@ {Total[DeleteDuplicates[Table[p[i[j]], {j, m}]]], Sequence @@ Table[{i[j], n}, {j, m}]}


and then it outputs the incorrect result as the second one above. I cannot use

t[n_, m_] := Table[Total[DeleteDuplicates[Table[p[i[j]], {j, m}]]], Sequence @@ Table[{i[j], n}, {j, m}]]


because it will cause a compile error:

t[4, 3]


Table: Iterator {Sequence[{i[1],4},{i[2],4},{i[3],4}]} does not have appropriate bounds.

How could I deal with it?

• For the second one, it doesn't work, because the DeleteDuplicates isn't carried over (i.e. {Total[DeleteDuplicates[{p[i1], p[i2]}]], {i1, 2}, {i2, 2}} evaluates first to {p[i1] + p[i2], {i1, 2}, {i2, 2}} before Table acts. To get the last version to work, do Sequence @@ Table[{i[j], n}, {j, m}] // Evaluate instead of just Sequence @@ Table[{i[j], n}, {j, m}]. – march Jun 22 '17 at 23:23

Is this what you're after?

n = 5
ps = Array[p, n]
Total /@ DeleteDuplicates /@ Tuples[ps, n]


Alan already gave a nice alternative using Tuples, but perhaps closer to the original formulation:

Array[Total[DeleteDuplicates[p /@ {##}]] &, {2, 2}]

{{p[1], p[1] + p[2]}, {p[1] + p[2], p[2]}}


Re: t[n_, m_] := Table @@ {...} outputs the incorrect result:

You need to pass the first element in your list {Total[...], Sequence@@...} to Table as Unevaluated so that DeleteDuplicates gets to work after iterator values are injected:

ClearAll[t]
t[n_, m_] := Table @@ {Unevaluated@Total[DeleteDuplicates[Table[p[i[j]], {j, m}]]],
Sequence @@ Table[{i[j], n}, {j, m}]}

t[2, 2]


{{p[1], p[1] + p[2]}, {p[1] + p[2], p[2]}}

t[3, 2]


{{p[1], p[1] + p[2], p[1] + p[3]}, {p[1] + p[2], p[2], p[2] + p[3]},
{p[1] + p[3], p[2] + p[3], p[3]}}

t[2, 3]


{{{p[1], p[1] + p[2]}, {p[1] + p[2], p[1] + p[2]}},
{{p[1] + p[2], p[1] + p[2]}, {p[1] + p[2], p[2]}}}

Re: I cannot use t[n_, m_] := Table[..] because it will cause a compile error

You can wrap Sequence@@... with Evaluate:

ClearAll[t2]
t2[n_, m_] := Table[Total[DeleteDuplicates[Table[p[i[j]], {j, m}]]],
Evaluate[Sequence @@ Table[{i[j], n}, {j, m}]]      ]
t2[2, 2]


{{p[1], p[1] + p[2]}, {p[1] + p[2], p[2]}}

Note: Cleanest way is defining your t[n_,m_] using Array as in Mr.Wizard and Alan's answers:

ClearAll[t0]
t0[n_, m_] := Array[Total[DeleteDuplicates[p /@ {##}]] &, ConstantArray[n, m]]

t0[3, 2]


{{p[1], p[1] + p[2], p[1] + p[3]}, {p[1] + p[2], p[2], p[2] + p[3]},
{p[1] + p[3], p[2] + p[3], p[3]}}

• Forgive me but I think this unnecessarily baroque, and I updated my answer with a competing recommendation if this sort of thing is desired. – Mr.Wizard Jul 23 '17 at 9:50
• @Mr.Wizard, somehow I could not get the version with Unevaluated work when I first tried. Thank you. – kglr Jul 23 '17 at 10:03

Updated for higher dimensions.

You may use Outer.

It seems that you just want to do an outer-product but with a special function instead of Times. This function should have the characteristics of f defined below.

With

ClearAll[f]
f[s : Repeated[a_, ∞]] := a
f[OrderlessPatternSequence[a_, a_, b__]] := f[a, b]
f[b__] := Total[{b}]


f is overloaded with three signatures. Note that f takes an arbitrary number of parameters.

1. The first is when all parameters are equal then return the parameter.
2. The second removes duplicates from the parameters. Here, f @@ DeleteDuplicates[{a, b}] could be used instead of f[a, b] to short-circuit recursive calls.
3. The third gives the sum of the terms; which will all be unique after passing through the definition above.

Actually, f can be simplified to,

ClearAll[f]
f[b__] := Total@DeleteDuplicates@{b}


Which makes t below noticeably faster. Perhaps the fastest posted thus far.

And

ClearAll[t, p];
t[dims__Integer?Positive] := Outer[f, Sequence @@ Map[p, Range /@ {dims}, {2}]]


t performs a generalised outer-product over the dimensions using f instead of Times; an outer-f. Note that t also takes an arbitrary number of parameters.

Then

t[2, 2]
% // MatrixForm

{{p[1], p[1] + p[2]}, {p[1] + p[2], p[2]}}


t[2, 3]
% // MatrixForm

{{p[1], p[1] + p[2], p[1] + p[3]}, {p[1] + p[2], p[2], p[2] + p[3]}}


And higher dimensions

t[3, 3, 3];
% // MatrixForm


t[2, 3, 2, 4];
% // MatrixForm


And so on.

Hope this helps.

• How would you generalize this to larger examples? I mean like Array[Total[DeleteDuplicates[p /@ {##}]] &, {2, 3, 2, 4}] – Mr.Wizard Jul 23 '17 at 13:49
• @Mr.Wizard See update – Edmund Jul 23 '17 at 19:47
• Actually, I could speed things up by changing f to ClearAll[f]; f[b__] := Total@DeleteDuplicates@{b}. Then I think this would be a contender to be one of the fastest here. – Edmund Jul 24 '17 at 1:34