# Question about Map and Total

Suppose I have a list and I want to generate a new list, such that

$$NewList[index] = \sum_{index \neq j}^{NumOfElts} \frac {1}{ \lvert OldList[index]-OldList[j] \rvert ^2 }$$

Can I do it using Map and Total on $OldList$?

### Edit

Given OldList = {a, b, c}, I want NewList to be

{1/Abs[a - b]^2 + 1/Abs[a - c]^2,
1/Abs[-a + b]^2 + 1/Abs[b - c]^2,
1/Abs[-a + c]^2 + 1/Abs[-b + c]^2}

• So that I don't misunderstand your notation would you please give a small example of the input and output that you desire? – Mr.Wizard Feb 5 '14 at 10:43
• Ok, let's say OldList = {a,b,c}. I want to construct a new list as NewList = { $$\frac{1}{\lvert a-b \rvert ^2}+ \frac{1}{\lvert a-c \rvert ^2}, \frac{1}{\lvert b-a \rvert ^2}+\frac{1}{\lvert b-c \rvert ^ 2}, \frac{1}{\lvert c-a \rvert ^2}+\frac{1}{\lvert c-b \rvert ^2}$$ } – christian Feb 5 '14 at 10:46
• Worth to point out that there probably should be no duplicates. – Kuba Feb 5 '14 at 11:08

## Literal methods

First way I thought of:

f1 = Table[Total[1/Abs[#[[i]] - Delete[#, i]]^2], {i, Length@#}] &;

f1[{a, b, c}]

{1/Abs[a - b]^2 + 1/Abs[a - c]^2,
1/Abs[-a + b]^2 + 1/Abs[b - c]^2,
1/Abs[-a + c]^2 + 1/Abs[-b + c]^2}


Or using MapIndexed as rasher did, but using the listability of all operations:

f2[old_List] := MapIndexed[Total[1/(Abs[# - Drop[old, #2]]^2)] &, old]

f2[{a, b, c}]

{1/Abs[a - b]^2 + 1/Abs[a - c]^2,
1/Abs[-a + b]^2 + 1/Abs[b - c]^2,
1/Abs[-a + c]^2 + 1/Abs[-b + c]^2}


Note: you can use Tr in place of Total for vector sums; it is slightly faster on packed arrays, and syntactically shorter which I like. However it gives the trace of a matrix (of course) rather than a sum, so I did not use it here just in case your list elements are themselves lists.

## Matrix method

Unlike the methods above that Delete or Drop the unwanted element, we can leave this element, replace the resulting zeros with ones, perform the sum, and then remove the ones again.

f3[old_List] :=
With[{diag = IdentityMatrix @ Length @ old},
Total[1/(Abs[# - old & /@ old]^2 + diag), {2}] - 1
]

f3[{a, b, c}]

{1/Abs[a - b]^2 + 1/Abs[a - c]^2,
1/Abs[-a + b]^2 + 1/Abs[b - c]^2,
1/Abs[-a + c]^2 + 1/Abs[-b + c]^2}


## Extensions

g1[old_List] := MapIndexed[# - Drop[old, #2] &, old] // Total[#/Abs[#]^2, {2}] &

g1[{a, b, c}]

{(a - b)/Abs[a - b]^2 + (a - c)/Abs[a - c]^2,
(-a + b)/Abs[-a + b]^2 + (b - c)/Abs[b - c]^2,
(-a + c)/Abs[-a + c]^2 + (-b + c)/Abs[-b + c]^2}

g2[old_List] :=
With[{
diag = IdentityMatrix @ Length @ old,
sub = # - old & /@ old
},
Total[sub/(Abs[sub]^2 + diag), {2}]
]

g2[{a, b, c}] === g1[{a, b, c}]

True


## Timings

Here are timings of each of these methods performed in Mathematica 7. I had hoped that the matrix method (f3) would be faster, but at least in the extended example it is faster than the alternative. (This test uses over 1GB of RAM.)

SetAttributes[timeAvg, HoldFirst]
timeAvg[func_] := Do[If[# > 0.3, Return[#/5^i]] & @@ Timing@Do[func, {5^i}], {i, 0, 15}]

big = RandomReal[{-9, 9}, 5000];

timeAvg[#@big] & /@ {f1, f2, f3}

{0.405, 0.39, 0.437}

timeAvg[#@big] & /@ {g1, g2}

{1.201, 0.484}

• Thank you so much. I'm newbie to Mathematica, so can you explain the reasoning a bit? one more question : If I want to make elements of the new list as $NewList[index] = \sum_{index \neq j}^{NumOfElts} \frac {OldList[index]-Oldlist[j]}{ \lvert OldList[index]-OldList[j] \rvert ^2 }$ how do I do it according to this logic? – christian Feb 5 '14 at 11:07
• +1 for the usual beautification of code! – ciao Feb 5 '14 at 11:12
• @christian Complete. – Mr.Wizard Feb 5 '14 at 11:34
oldlist = {a, b, c}

Total /@ MapIndexed[
Map[Function[arg, 1/(Abs[arg - #]^2)], Drop[oldlist, #2]] &,
oldlist]

(*  {1/Abs[-a + b]^2 + 1/Abs[-a + c]^2, 1/Abs[a - b]^2 + 1/Abs[-b + c]^2,
1/Abs[a - c]^2 + 1/Abs[b - c]^2} *)

• +1 for MapIndexed, which is cleaner than Table, but there is no need for the inner Function; please see my answer. – Mr.Wizard Feb 5 '14 at 11:09
• @Mr.Wizard: yep - I'm always forgetting listability, you'd think from my Lisp days it would be burned in...as an aside, the @ to reply does not seem to always work, is there some site issue? – ciao Feb 5 '14 at 11:11
• What about the @ notification system isn't working? – Mr.Wizard Feb 5 '14 at 11:35
• @Mr.Wizard: I'd say about 30% of the time, when I type the @, it does not fill in the name, and even if I explicitly fill out the whole name, comment shows up with no reference. Tried on three different browsers, so fairly sure it's not on my end. No big deal, just makes me feel sloppy. – ciao Feb 5 '14 at 11:45
• I am guessing you are attempting to notify the author of the post under which your are commenting; that author is automatically notified, so the @ isn't necessary, and in fact the system strips it out. – Mr.Wizard Feb 5 '14 at 11:53

Perhaps a little convoluted and not efficient (...it has been a long day...):

fun[u_] := Module[{len, arg},
len = Length[u] - 1;
arg = RotateLeft[u, #] & /@ Range[0, len];
Map[Function[s,
Total@Map[Function[x, 1/Abs[#1 - x]^2], {##2}] & @@ s], arg]]


Testing:

fun[{a, b, c}]


gives:

{1/Abs[a - b]^2 + 1/Abs[a - c]^2, 1/Abs[-a + b]^2 + 1/Abs[b - c]^2,
1/Abs[-a + c]^2 + 1/Abs[-b + c]^2}