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.

I'm trying to get used to Mathematica's approach to programming and list manipulation, and am struggling with one thing.

Say that I have a function f which takes a list of two values and returns a list of two values. I also have a list of doubles, c = {{1, 2}, {1, 3}, {1, 4}, {2, 3}, {2, 4}, {3, 4}}.

For each double in c, I want to return a list of four values: two of them zero, and the ones with corresponding indices in c should be defined by applying the function f to the double in c. Let me show some examples. For the value {1,3}, I would like to return { f[{1,3}][[1]], 0, f[{1,3}][[2]], 0 }, and for {2,3}, I would like { 0, f[{2,3}][[1]], f[{2,3}][[2]], 0 }.

I am completely stumped by this problem when I try to find a nice solution using Map and other standard Mathematica list operations. The approach that I've tried was to map over c trying to assign values to a list of zeroes depending on the values in c, but I'm lost as to how I would accomplish that. I can basically do what I want with a loop:

result = {};
Do[
 list = {0, 0, 0, 0};
 list[[x[[1]]]] = f[x][[1]];
 list[[x[[2]]]] = f[x][[2]];
 AppendTo[result, list],
{x, c}]

but I would like to learn a better approach. Here, I don't even know how to perform the operation inside the Do loop more elegantly, because something like

Map[(list[[x[[#]]]] = f [x][[#]])&, {1,2}]

does not work. I would appreciate any suggestions and help with this problem.

share|improve this question
1  
Riffle[f@#, {0,0}]& /@ c ? –  Ray Koopman Dec 17 '13 at 2:44
    
@RayKoopman I was not clear enough with my problem, the non-zero positions in the list should not be always 1 and 3, but should instead depend on the value of c. I edited in a clarification. –  sps Dec 17 '13 at 3:09
add comment

3 Answers

up vote 5 down vote accepted

Edit: I misinterpreted the question the first time. Hopefully I get this right now.

There is probably a cleaner way to do this, but as a start this is a bit more concise than your own loop. (I properly localize auxiliary Symbols with Module.)

c = {{1, 2}, {1, 3}, {1, 4}, {2, 3}, {2, 4}, {3, 4}};

f = Accumulate;

Module[{a, b},
 a = ConstantArray[0, 4];
 (b = a; b[[#]] = f@#; b) & /@ c
]
{{1, 3, 0, 0}, {1, 0, 4, 0}, {1, 0, 0, 5}, {0, 2, 5, 0}, {0, 2, 0, 6}, {0, 0, 3, 7}}

I used ConstantArray[0, 4] rather than simply {0,0,0,0} because it creates a packed array which will speed the replacement operations, assuming that the new elements are machine size integers.

ssch offhandedly mentioned another approach using SparseArray which tests several times faster than my code above. Turning both methods into generalized functions we have:

fn1[f_, c_] :=
 Module[{a, b},
  a = ConstantArray[0, Max@c];
  (b = a; b[[#]] = f@#; b) & /@ c
 ]

fn2[f_, c_] :=
 SparseArray[{Flatten[ConstantArray[Range@#, #2]\[Transpose]] & @@ Dimensions[c], 
      Flatten@c}\[Transpose] -> Flatten[f /@ c]] // Normal

Timings in version 7:

big = RandomChoice[Range@12, {350000, 7}];

fn1[Accumulate, big] // Timing // First
fn2[Accumulate, big] // Timing // First
0.796

0.265

Inspired by A.G.'s answer using UnitVector we could also do it this way:

f@#.(UnitVector[4, #] & /@ #) & /@ c
{{1, 3, 0, 0}, {1, 0, 4, 0}, {1, 0, 0, 5}, {0, 2, 5, 0}, {0, 2, 0, 6}, {0, 0, 3, 7}}

It is delightfully terse but quite a bit slower than the methods above:

fn3[f_, c_] := With[{n = Max@c}, f[#].(UnitVector[n, #] & /@ #) & /@ c]

fn3[Accumulate, big] // Timing // First
2.2

I realized that using UnitVector every time is inefficient. Instead we can build our lists once with IdentityMatrix then pull the vectors needed with Part:

With[{v = IdentityMatrix[4]},
 f[#].v[[#]] & /@ c
]
{{1, 3, 0, 0}, {1, 0, 4, 0}, {1, 0, 0, 5}, {0, 2, 5, 0}, {0, 2, 0, 6}, {0, 0, 3, 7}}

As a function:

fn4[f_, c_] := With[{v = IdentityMatrix @ Max @ c}, f[#].v[[#]] & /@ c]

fn4[Accumulate, big] // Timing // First
0.436

Second fastest so far. :-)


Inspired by Andre's answer here is a fifth function:

fn5[f_, c_] := With[{v = Table[0, {Max@c}]}, ReplacePart[v, Thread[# -> f@#]] & /@ c]

fn5[Accumulate, big] // Timing // First
3.307
share|improve this answer
1  
I don't think the poster always want position 1 and 3, but position $c_{i1}$ and $c_{i2}$ but without the Do, and presumably something prettier than f[{x_, y_}] := {fx[x, y], fy[x, y]}; Transpose@{Riffle[#, #] &@Range@Length@c, Flatten@c} -> Flatten[f /@ c] // SparseArray // Normal –  ssch Dec 17 '13 at 3:04
    
@ssch Hm... you're right. Back to the drawing board. :^) –  Mr.Wizard Dec 17 '13 at 3:06
    
Yes, I'm afraid @ssch is right. Thank you for your answer, though, Mr.Wizard. –  sps Dec 17 '13 at 3:13
    
@sps Sorry for not reading more carefully. I updated my answer now; please take a look and tell me if this appears correct. –  Mr.Wizard Dec 17 '13 at 3:15
    
+1. This new answer looks correct to me. –  RunnyKine Dec 17 '13 at 3:18
show 2 more comments

Here is an improvement suggestion on you idea :

ClearAll[f];
f[{u_, v_}] := {f1[u, v], f2[u, v]}
c = {{1, 2}, {1, 3}, {1, 4}, {2, 3}, {2, 4}, {3, 4}};
n = Length[c];
result = {};
Do[
 list = {0, 0, 0, 0};
 With[{p = c[[i]]},
   list[[First@p]] = First@f[p];
   list[[Last@p]] = Last@f[p];]
  AppendTo[result, list], {i, n}]
result

with output

{{f1[1, 2], f2[1, 2], 0, 0}, {f1[1, 3], 0, f2[1, 3], 0},
{f1[1, 4], 0, 0, f2[1, 4]}, {0, f1[2, 3], f2[2, 3], 0}, 
{0, f1[2, 4], 0, f2[2, 4]}, {0, 0, f1[3, 4], f2[3, 4]}, 
{0, 0, f2[4, 3], f1[4, 3]}}

Now, come to think of it this is better :

c /. {i_, j_} -> First@f[{i, j}] UnitVector[4, i] + Last@f[{i, j}] UnitVector[4, j]

(same output)

share|improve this answer
    
+1 for inspiration -- see my updated answer in a few minutes –  Mr.Wizard Dec 17 '13 at 8:09
add comment

One can use ReplacePart[] :

   c = {{1, 2}, {1, 3}, {1, 4}, {2, 3}, {2, 4}, {3, 4}}
   f = Accumulate
   ReplacePart[{0, 0, 0, 0}, {{#[[1]]} :>  f[#][[1]], {#[[2]]} :>  f[#][[2]]}] & /@ c

{1, 3, 0, 0}, {1, 0, 4, 0}, {1, 0, 0, 5}, {0, 2, 5, 0}, {0, 2, 0,6}, {0, 0, 3, 7}}

Edit

To avoid the double evaluation of f, one can use

With[
 {cple = #, fcple = f[#]}, 
 ReplacePart[
      {0, 0, 0, 0},
      {{cple[[1]]} :> fcple[[1]], {cple[[2]]} :> fcple[[2]]}
      ]
 ] & /@ c

or use Mr. Wizard's nice solution :

ReplacePart[{0, 0, 0, 0}, Thread[# -> f@#]] & /@ c
share|improve this answer
    
This applies f twice. One could memoize f but not all applications are conducive to that. Can you find a clean way to avoid this? –  Mr.Wizard Dec 18 '13 at 0:14
    
@Mr.Wizard I have done a edit concerning your remark. I suppose you want to avoid the double evaluation of f uniquely because of speed ? –  andre Dec 18 '13 at 9:48
    
Correct. It is IMHO "best practice" to avoid redundant evaluation in any general purpose code. +1 –  Mr.Wizard Dec 18 '13 at 9:51
    
By the way this is the solution I was hoping to steer you toward: ReplacePart[{0, 0, 0, 0}, Thread[# -> f@#]] & /@ c –  Mr.Wizard Dec 18 '13 at 9:55
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.