# 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 ? Commented Dec 17, 2013 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
Commented Dec 17, 2013 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
Commented Dec 17, 2013 at 3:04
• @ssch Hm... you're right. Back to the drawing board. :^) Commented Dec 17, 2013 at 3:06
• Yes, I'm afraid @ssch is right. Thank you for your answer, though, Mr.Wizard.
– sps
Commented Dec 17, 2013 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. Commented Dec 17, 2013 at 3:15
• +1. This new answer looks correct to me. Commented Dec 17, 2013 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 Commented Dec 17, 2013 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? Commented Dec 18, 2013 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 ? Commented Dec 18, 2013 at 9:48
• Correct. It is IMHO "best practice" to avoid redundant evaluation in any general purpose code. +1 Commented Dec 18, 2013 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 Commented Dec 18, 2013 at 9:55