6
$\begingroup$

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.

$\endgroup$
2
  • 1
    $\begingroup$ Riffle[f@#, {0,0}]& /@ c ? $\endgroup$ Dec 17, 2013 at 2:44
  • $\begingroup$ @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. $\endgroup$
    – sps
    Dec 17, 2013 at 3:09

3 Answers 3

5
$\begingroup$

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
$\endgroup$
7
  • 1
    $\begingroup$ 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 $\endgroup$
    – ssch
    Dec 17, 2013 at 3:04
  • $\begingroup$ @ssch Hm... you're right. Back to the drawing board. :^) $\endgroup$
    – Mr.Wizard
    Dec 17, 2013 at 3:06
  • $\begingroup$ Yes, I'm afraid @ssch is right. Thank you for your answer, though, Mr.Wizard. $\endgroup$
    – sps
    Dec 17, 2013 at 3:13
  • $\begingroup$ @sps Sorry for not reading more carefully. I updated my answer now; please take a look and tell me if this appears correct. $\endgroup$
    – Mr.Wizard
    Dec 17, 2013 at 3:15
  • $\begingroup$ +1. This new answer looks correct to me. $\endgroup$
    – RunnyKine
    Dec 17, 2013 at 3:18
4
$\begingroup$

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)

$\endgroup$
1
  • $\begingroup$ +1 for inspiration -- see my updated answer in a few minutes $\endgroup$
    – Mr.Wizard
    Dec 17, 2013 at 8:09
3
$\begingroup$

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
$\endgroup$
4
  • $\begingroup$ 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? $\endgroup$
    – Mr.Wizard
    Dec 18, 2013 at 0:14
  • $\begingroup$ @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 ? $\endgroup$
    – andre314
    Dec 18, 2013 at 9:48
  • $\begingroup$ Correct. It is IMHO "best practice" to avoid redundant evaluation in any general purpose code. +1 $\endgroup$
    – Mr.Wizard
    Dec 18, 2013 at 9:51
  • $\begingroup$ By the way this is the solution I was hoping to steer you toward: ReplacePart[{0, 0, 0, 0}, Thread[# -> f@#]] & /@ c $\endgroup$
    – Mr.Wizard
    Dec 18, 2013 at 9:55

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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