Question about Map and Total

Question

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 05 '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 05 '14 at 10:46
Worth to point out that there probably should be no duplicates. — Kuba, Feb 05 '14 at 11:08

score 7 · Answer 1 · edited Apr 13 '17 at 12:55

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}

See Case #4 in Alternatives to procedural loops and iterating over lists in Mathematica.

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

You asked about a variation of this operation. Here are examples.

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 05 '14 at 11:07

score 3 · Answer 2 · answered Feb 05 '14 at 10:58

3

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

answered Feb 05 '14 at 10:58

ciao

25,774
2
58
139

+1 for MapIndexed, which is cleaner than Table, but there is no need for the inner Function; please see my answer. – Mr.Wizard Feb 05 '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 05 '14 at 11:11
What about the @ notification system isn't working? – Mr.Wizard Feb 05 '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 05 '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 05 '14 at 11:53
Also no need to Map onto Total. Use level spec {2} with Total – Mike Honeychurch Feb 05 '14 at 21:47

score 1 · Answer 3 · answered Feb 05 '14 at 12:22

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}