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

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.

-
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

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
-
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

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)

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

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
-
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