Skip to main content

functional style - Map a function across a list conditionally


It seems that this is a really basic question, and I feel that the answer should be obvious to me. However, I am not seeing. Can you please help me? Thanks.


Suppose I have a list of data list and a selector list sel. I would like to Map some function f onto elements in list that correspond to True in the selector list sel.


Thus for the input


list = {1, 10, 100};
sel = {True, False, True};

I would like to obtain the output



{f[1], 10, f[100]}

I can think of some complicated ways to accomplish this (e.g., using Table to step through both list and sel using an iterator i; or find the positions of True in sel using Position and then MapAt at those positions), but not simple ways. Do you have any advice?



Answer



Updated with new functions and additional timings


Since this question inspired so many answers, I think there is a need to compare them.
I have included two of my own functions, freely borrowing from previous answers:


wizard1[] :=
 Inner[Compose, sel /. {True -> f, False -> Identity}, list, List]


wizard2[] :=
 Module[{x = list}, x[[#]] = f /@ x[[#]]; x] & @ 
  SparseArray[sel, Automatic, False]@"AdjacencyLists"

(wizard1 may not work as expected if list is a matrix; a workaround is shown in that post.)


Notes


These timings are conducted with Mathematica 7 on Windows 7 and may differ significantly from those conducted on other platforms and versions.


Specifically, I know this affects Leonid's method, as Pick has been improved between versions 7 and 8. His newer form with Developer`ToPackedArray@Boole is slower on my system, so I used the original.


Rojo's first function had to be modified or it fails on packed arrays, but I believe this affects other versions as well.


kguler's method list /. Dispatch[Thread[# -> f1 /@ #] &@Pick[list, sel]] does not produce the correct result if there are duplicates in list and was omitted from the timings.



Timings with symbolic (undefined) f


Here are timings for all functions, when f is undefined:


Mathematica graphics


$x$ is length of list; $y$ is average time in seconds.


We can see that all the methods appear to have the same time complexity with the exception of one, the line at the top on the right-hand side. This is MapAt[f, list, Position[sel, True]] at it makes quite clear "what's wrong with" this method. The warning on this page regarding MapAt rings true.


Timings for 10^5 in the chart by rank are:


$\begin{array}{rl} \text{wizard2} & 0.02248 \\ \text{ecoxlinux2} & 0.02996 \\ \text{wizard1} & 0.03184 \\ \text{leonid} & 0.03244 \\ \text{simon} & 0.03868 \\ \text{ruebenko} & 0.04116 \\ \text{artes3} & 0.0468 \\ \text{rojo3} & 0.04928 \\ \text{verbeia} & 0.05744 \\ \text{rm2} & 0.0656 \\ \text{rm1} & 0.0936 \\ \text{artes2} & 0.0936 \\ \text{artes1} & 0.0966 \\ \text{jm2} & 0.106 \\ \text{rojo2} & 0.1154 \\ \text{rojo4} & 0.1404 \\ \text{kguler4} & 0.1434 \\ \text{kguler2} & 0.1496 \\ \text{kguler1} & 0.1592 \\ \text{jm1} & 0.1654 \\ \text{rojo1} & 0.3432 \\ \text{ecoxlinux1} & 19.797 \end{array}$


Timings with a numeric compilable f


For an array of 10^6 Reals and with f = 1.618` + # & timings are:


$\begin{array}{rl} \text{wizard2} & 0.04864 \\ \text{leonid} & 0.2154 \\ \text{ecoxlinux2} & 0.452 \\ \text{ruebenko} & 0.53 \\ \text{artes3} & 0.577 \\ \text{simon} & 0.639 \\ \text{wizard1} & 0.702 \\ \text{rojo3} & 0.811 \\ \text{rm1} & 0.982 \\ \text{verbeia} & 1.014 \\ \text{artes2} & 1.06 \\ \text{artes1} & 1.123 \\ \text{rojo2} & 1.279 \\ \text{rm2} & 1.357 \\ \text{jm2} & 1.45 \\ \text{rojo4} & 1.747 \\ \text{kguler4} & 1.841 \\ \text{kguler2} & 1.934 \\ \text{kguler1} & 2.012 \\ \text{jm1} & 2.106 \\ \text{rojo1} & 3.37 \end{array}$



We're not done yet.


Leonid wrote his method specifically to allow for auto-compilation within Map, and my second method is directly based on his. We can take this a step further for a Listable function or one constructed of such functions as is f = 1.618` + # & by using f @ in place of f /@ as described here:


Module[{x = list}, x[[#]] = f @ x[[#]]; x] & @ 
  SparseArray[sel, Automatic, False]@"AdjacencyLists" // timeAvg


0.03496




Reference



The functions, as I named and used them, are:


ruebenko[] :=
 Block[{f},
  f[i_, True] := f[i];
  f[i_, False] := i;
  MapThread[f, {list, sel}]
 ]

artes1[] :=
 (If[#1[[2]], f[#1[[1]]], #1[[1]]] &) /@ Transpose[{list, sel}]


artes2[] :=
 If[Last@#, f@First@#, First@#] & /@ Transpose[{list, sel}]

artes3[] :=
 Inner[If[#2, f, Identity][#] &, list, sel, List]

ecoxlinux1[] :=
 MapAt[f, list, Position[sel, True]]


ecoxlinux2[] :=
 Transpose[{list, sel}] /. {{x_, True} :> f[x], {x_, _} :> x}

rm1[] :=
 Transpose[{list, sel}] /. {x_, y_} :> (f^Boole[y])[x] /. 1[x_] :> x

rm2[] :=
 Transpose[{list, sel}] /. {x_, y_} :> (y /. {True -> f, False -> Identity})[x]

rojo1[] :=

 With[{list = Developer`FromPackedArray@list},
  Normal[SparseArray[{i_ /; sel[[i]] :> f[list[[i]]], i_ :> list[[i]]}, Dimensions[list]]]
 ]

rojo2[] :=
 Total[{#~BitXor~1, #} &@Boole@sel {list, f /@ list}]

rojo3[] :=
 If[#1, f[#2], #2] & ~MapThread~ {sel, list}


rojo4[] :=
 #2 /. _ /; #1 :> f[#2] & ~MapThread~ {sel, list}

jm1[] :=
 MapIndexed[If[sel[[Sequence @@ #2]], f[#1], #1] &, list]

jm2[] :=
 MapIndexed[If[Extract[sel, #2], f[#1], #1] &, list]

verbeia[] :=

 If[#2, f[#1], #1] & @@@ Transpose[{list, sel}]

kguler1[] :=
 MapThread[(#2 f[#1] + (1 - #2) #1) &, {list, Boole[#] & /@ sel}]

kguler2[] :=
 (#2 f[#1] + (1 - #2) #1) & @@@ Thread[{list, Boole@sel}]

(*kguler3[]:=
list/.Dispatch@Thread[#->f/@#]&@Pick[list,sel]*)


kguler4[] :=
  Inner[(#2 f[#1] + (1 - #2) #1) &, list, Boole@sel, List]

simon[] :=
 Block[{g},
  g[True, x_] := f[x];
  g[False, x_] := x;
  SetAttributes[g, Listable];
  g[sel, list]

 ]

leonid[] :=
  With[{pos = Pick[Range@Length@list, sel]},
   Module[{list1 = list},
    list1[[pos]] = f /@ list1[[pos]];
    list1
   ]
  ]


wizard1[] :=
 Inner[Compose, sel /. {True -> f, False -> Identity}, list, List]

wizard2[] :=
 Module[{x = list}, x[[#]] = f /@ x[[#]]; x] & @ 
  SparseArray[sel, Automatic, False]@"AdjacencyLists"

Timing code:


SetAttributes[timeAvg, HoldFirst]
timeAvg[func_] := 

  Do[If[# > 0.3, Return[#/5^i]] & @@ Timing@Do[func, {5^i}], {i, 0, 15}]

funcs = {ruebenko, artes1, artes2, artes3,(*ecoxlinux1,*)ecoxlinux2, 
   rm1, rm2, rojo1, rojo2, rojo3, rojo4, jm1, jm2, verbeia, kguler1, 
   kguler2,(*kguler3,*)kguler4, simon, leonid, wizard1, wizard2};

ClearAll[f]
time1 = Table[
  list = RandomInteger[99, n];
  sel = RandomChoice[{True, False}, n];

  timeAvg@ fn[],
  {fn, funcs},
  {n, 10^Range@5}
 ] ~Monitor~ fn

f = 1.618 + # &;
time2long = Table[
    list = RandomReal[99, 1*^6];
    sel = RandomChoice[{True, False}, 1*^6];
    {fn, timeAvg@ fn[]},

    {fn, funcs}
   ] ~Monitor~ fn

Comments

Post a Comment

Popular posts from this blog

front end - keyboard shortcut to invoke Insert new matrix

I frequently need to type in some matrices, and the menu command Insert > Table/Matrix > New... allows matrices with lines drawn between columns and rows, which is very helpful. I would like to make a keyboard shortcut for it, but cannot find the relevant frontend token command (4209405) for it. Since the FullForm[] and InputForm[] of matrices with lines drawn between rows and columns is the same as those without lines, it's hard to do this via 3rd party system-wide text expanders (e.g. autohotkey or atext on mac). How does one assign a keyboard shortcut for the menu item Insert > Table/Matrix > New... , preferably using only mathematica? Thanks! Answer In the MenuSetup.tr (for linux located in the $InstallationDirectory/SystemFiles/FrontEnd/TextResources/X/ directory), I changed the line MenuItem["&New...", "CreateGridBoxDialog"] to read MenuItem["&New...", "CreateGridBoxDialog", MenuKey["m", Modifiers-...
Post a Comment
Read more

How to thread a list

I have data in format data = {{a1, a2}, {b1, b2}, {c1, c2}, {d1, d2}} Tableform: I want to thread it to : tdata = {{{a1, b1}, {a2, b2}}, {{a1, c1}, {a2, c2}}, {{a1, d1}, {a2, d2}}} Tableform: And I would like to do better then pseudofunction[n_] := Transpose[{data2[[1]], data2[[n]]}]; SetAttributes[pseudofunction, Listable]; Range[2, 4] // pseudofunction Here is my benchmark data, where data3 is normal sample of real data. data3 = Drop[ExcelWorkBook[[Column1 ;; Column4]], None, 1]; data2 = {a #, b #, c #, d #} & /@ Range[1, 10^5]; data = RandomReal[{0, 1}, {10^6, 4}]; Here is my benchmark code kptnw[list_] := Transpose[{Table[First@#, {Length@# - 1}], Rest@#}, {3, 1, 2}] &@list kptnw2[list_] := Transpose[{ConstantArray[First@#, Length@# - 1], Rest@#}, {3, 1, 2}] &@list OleksandrR[list_] := Flatten[Outer[List, List@First[list], Rest[list], 1], {{2}, {1, 4}}] paradox2[list_] := Partition[Riffle[list[[1]], #], 2] & /@ Drop[list, 1] RM[list_] := FoldList[Transpose[{First@li...
Post a Comment
Read more

functions - Get leading series expansion term?

Given a function f[x] , I would like to have a function leadingSeries that returns just the leading term in the series around x=0 . For example: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x)] x and leadingSeries[(1/x + 2 + (1 - 1/x^3)/4)/(4 + x)] -(1/(16 x^3)) Is there such a function in Mathematica? Or maybe one can implement it efficiently? EDIT I finally went with the following implementation, based on Carl Woll 's answer: lds[ex_,x_]:=( (ex/.x->(x+O[x]^2))/.SeriesData[U_,Z_,L_List,Mi_,Ma_,De_]:>SeriesData[U,Z,{L[[1]]},Mi,Mi+1,De]//Quiet//Normal) The advantage is, that this one also properly works with functions whose leading term is a constant: lds[Exp[x],x] 1 Answer Update 1 Updated to eliminate SeriesData and to not return additional terms Perhaps you could use: leadingSeries[expr_, x_] := Normal[expr /. x->(x+O[x]^2) /. a_List :> Take[a, 1]] Then for your examples: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x), x] leadingSeries[Exp[x], x] leadingSeries[(1/x + 2 + (1 - 1/x...
Post a Comment
Read more