Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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}
share|improve this question
    
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 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 at 10:46
    
Worth to point out that there probably should be no duplicates. –  Kuba Feb 5 at 11:08
add comment

3 Answers 3

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}
share|improve this answer
    
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 at 11:07
    
+1 for the usual beautification of code! –  rasher Feb 5 at 11:12
    
@christian Complete. –  Mr.Wizard Feb 5 at 11:34
add comment
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} *)
share|improve this answer
    
+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 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? –  rasher Feb 5 at 11:11
    
What about the @ notification system isn't working? –  Mr.Wizard Feb 5 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. –  rasher Feb 5 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 at 11:53
show 1 more comment

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}

share|improve this answer
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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