Mapping a function that assigns values to a list over a different list

Question

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.

Answer 1

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

Answer 2

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)

Answer 3

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