3
$\begingroup$

I have a list of functions and I want to separate them into two lists:

  1. a list that contains the functions that have at least one zero and
  2. a list that contains the functions that do not have zeros.

Let's say that the list of functions is this:

listoffuns = 
 Flatten[Table[
   Rationalize[a + b*Cos[c*(t + d)], 0], {a, 0.0003, 0.009, 0.0001}, {b, 0.01, 0.1, 
    0.01}, {c, 1, 4, 1}, {d, 2, 5, 1}]] 

I initially used this:

lengthoflistoffuns = Length[listoffuns]; list1 = {}; list2 = {}; table = 
 For[i = 1, i <= lengthoflistoffuns, i = i + 1, 
  If[Resolve[Exists[t, listoffuns[[i]] == 0], Reals], AppendTo[list1, listoffuns[[i]]], 
   AppendTo[list2, listoffuns[[i]]]]]

because, back then, the number of functions was small and I didn't have problems concerning efficiency. But now it is a problem for me. I know that For and AppendTo are inefficient commands in Mathematica and I want to replace them. I thought that it would be an efficient way for constructing the above mentioned lists if I used Sow and Reap instead of AppendTo and defined a pure function that would do the separation applied with the Map command to the values of i in the For loop. So help me do this in the way that I proposed or in your own (efficient) way. This is what I tried:

sepfun := If[Resolve[Exists[t, listoffuns[[#]] == 0], Reals], 
   list1 = Reap[Sow[listoffuns[[#]]]], list2 = Reap[Sow[listoffuns[[#]]]]] &

table1 = Table[j, {j, 1, lengthoflistoffuns, 1}]

sepfun /@ table1

I didn't construct a representative problem before because I expected answers that would also fit my real problem. So, I 'll cite now my real problem.

I want to construct list1, list2, list3 and list4 in an efficient way. So, I want to modify table8 and table9 in my code. The listoffuns corresponds, in my real problem, to the listofMelnfunthroughSimpsintegr. Each of these functions correspond to an ordered 4-tuple (α, β, Ω, γ). In table8 I want to gather the 4-tuples (α, β, Ω, γ) that correspond to functions that have at least one zero in list1 and in list2 the rest of them. In table9 I want to gather the 4-tuples (α, β, Ω, γ) that correspond to functions that have only simple zeros in list4 and in list3 the rest of them (functions that have at least one zero with multiplicity two or greater). In table9 the functions that I separate are the functions that belong to the list listofMelnfunwhichhavezeros.

I have fixed γ in my code so some commands seem to be unnecessary but they 're not because I want to be able to vary γ if needed on my way to the solution of the whole problem.

Here is a link that might be helpful for some people http://en.wikipedia.org/wiki/Multiplicity_%28mathematics%29.

Although, I asked this question to solve the above mentioned problem any adaptations that can easily be done in my code that drastically save time are welcome. I know that there are because this is my first program in mathematica and now that I have learned it a little if I did it from the beginning I would have made some changes but I don't know if they are worth the time concerning the gained performance.

I don't know if it's useful for anyone but I tried to separate the functions listofMelnfunthroughSimpsintegr using the suggestions of Histograms and LLlAMnYP and it took 786 s (13.1 min).

c0 = 0.001; initvlofγ = 1; finvlofγ = 1; incrstepofγ = 1;

s = Partition[
 Flatten[Table[
  NDSolve[{x1'[t] == x2[t], x2'[t] == -γ*Sin[x1[t]], 
   x1[0] == -Pi + c0, 
    x2[0] == 0.9*(Sqrt[γ]*(-Pi + c0) + Sqrt[γ]*Pi), 
     WhenEvent[
      Abs[x2[t]] <= 10^-2, {"StopIntegration", end = t}]}, {x1, 
       x2}, {t, 0, Infinity}, MaxSteps -> 10^6], {γ, initvlofγ, 
        finvlofγ, incrstepofγ}]], 2];

lengthofs = Length[s]; listofx1 = Table[s[[x1, 1, 2]], {x1, 1,  
 lengthofs, 1}];

listofx2 = Table[s[[x2, 2, 2]], {x2, 1, lengthofs, 1}];

listofendfordifferentvlsofγ = Table[s[[nvofγ, 1, 2, 1, 1, 2]], {nvofγ, 1,  
 lengthofs, 1}];

ParametricPlot[
 Evaluate[Table[
  ConditionalExpression[{listofx1[[nvofγ]][t], listofx2[[nvofγ]][t]},
   0 <= t <= listofendfordifferentvlsofγ[[nvofγ]]], {nvofγ, 1, 
    lengthofs, 1}]], {t, 0, Max[listofendfordifferentvlsofγ]}, 
     PlotRange -> {{-Pi - 1, Pi + 1}, All}, 
      AxesLabel -> {"\!\(\*SubscriptBox[\(x\), \(1\)]\)", 
       "\!\(\*SubscriptBox[\(x\), \(2\)]\)"}]

initvlofα = 0.1; finvlofα = 2; incrstepofα = 0.1; 
initvlofβ = 0.1; finvlofβ = 2; incrstepofβ = 0.1;
initvlofΩ = 0.1; finvlofΩ = 2; incrstepofΩ = 0.1;

listofzfordifferentvlsofαβΩ = 
 Flatten[Table[
  With[{α = α, β = β, Ω = Ω}, (α*Cos[Ω*(#2 + t0)]*#1 - β*#1^2) &], {α,     
   initvlofα, 
    finvlofα, incrstepofα}, {β, initvlofβ, finvlofβ, incrstepofβ}, {Ω,
     initvlofΩ, finvlofΩ, incrstepofΩ}]];

timestep = 1;

x2tdyadsfordifferentvlsofγ = 
 Partition[
  Flatten[Table[{listofx2[[nvofγ]][ζ], ζ}, {nvofγ, 1, lengthofs, 
   1}, {ζ, 0, listofendfordifferentvlsofγ[[nvofγ]], timestep}]], 2];

listoflengthsofsublistsofx2tdyads = 
 Table[1 + 
  Floor[listofendfordifferentvlsofγ[[nvofγ]]/timestep], {nvofγ, 1, 
   lengthofs, 1}];

lengthoflistoflengthsofsublistsofx2tdyads = 
 Length[listoflengthsofsublistsofx2tdyads];

table1 = Table[
 Sum[listoflengthsofsublistsofx2tdyads[[index1]], {index1, 
  index1}], {index1, 1, lengthoflistoflengthsofsublistsofx2tdyads, 1}];

table2 = Drop[Riffle[table1, table1], -1];

table3 = Riffle[Table[0^nvofγ, {nvofγ, 1, lengthofs, 1}], 1];

pairs = Partition[Prepend[table2 + table3, 1], 2];

x2tdyadsorganizedinsublistscorrespondingtodifferentvlsofγ = 
 Take[x2tdyadsfordifferentvlsofγ, #] & /@ pairs;

lengthoflistofzfordifferentvlsofαβΩ =   
 Length[listofzfordifferentvlsofαβΩ];

listofoneplusfloorvls = listoflengthsofsublistsofx2tdyads;

listofpositionsofoneplusfloorvlswhichareeven = 
 Flatten[Position[listofoneplusfloorvls, _?EvenQ]];

listofx2tdyadstobeinserted = 
 Partition[
  Flatten[Table[{listofx2[[
   nvofγ]][(Sum[
    timestep, {index3, 
     Floor[listofendfordifferentvlsofγ[[nvofγ]]/timestep]}] + 
      Sum[timestep, {index3, 
       Floor[listofendfordifferentvlsofγ[[nvofγ]]/timestep] - 
        1}])/2], (Sum[
         timestep, {index3, 
          Floor[listofendfordifferentvlsofγ[[nvofγ]]/timestep]}] + 
           Sum[timestep, {index3, 
            Floor[listofendfordifferentvlsofγ[[nvofγ]]/timestep] - 1}])/
             2}, {nvofγ,   
              listofpositionsofoneplusfloorvlswhichareeven}]],2];

lengthoflistofx2tdyadstobeinserted = Length[listofx2tdyadstobeinserted];

x2tdyadsorganizedinsublistscorrespondingtoevenvlsofγbeforemodification
 = Table[AppendTo[
  x2tdyadsorganizedinsublistscorrespondingtodifferentvlsofγ[[
   listofpositionsofoneplusfloorvlswhichareeven[[pos]]]], 
    listofx2tdyadstobeinserted[[pos]]], {pos, 
     lengthoflistofx2tdyadstobeinserted}];

listoflengthsofx2tdyadsorganizedinsublistscorrespondingtoevenvlsofγbef
 oremodification = 
  Table[Length[
   x2tdyadsorganizedinsublistscorrespondingtoevenvlsofγbeforemodificat
    ion[[pos]]], {pos, lengthoflistofx2tdyadstobeinserted}];

x2tdyadsorganizedinsublistscorrespondingtoevenvlsofγ = 
 Table[Permute[ 
  x2tdyadsorganizedinsublistscorrespondingtoevenvlsofγbeforemodificat
   ion[[pos]], 
    Cycles[{{    
   listoflengthsofx2tdyadsorganizedinsublistscorrespondingtoevenvlsofγbef
    oremodification[[pos]] - 1, 
     listoflengthsofx2tdyadsorganizedinsublistscorrespondingtoevenvls
      ofγbeforemodification[[pos]]}}]], {pos, 
       lengthoflistofx2tdyadstobeinserted}];

finalx2tdyadsorganizedinsublistscorrespondingtodifferentvlsofγ = 
 ReplacePart[
  x2tdyadsorganizedinsublistscorrespondingtodifferentvlsofγ, 
   Table[listofpositionsofoneplusfloorvlswhichareeven[[pos]] -> 
    x2tdyadsorganizedinsublistscorrespondingtoevenvlsofγ[[pos]], {pos,
     lengthoflistofx2tdyadstobeinserted}]];

listoflengthsofsublistsoffinalx2tdyads = 
 Table[Length[
  finalx2tdyadsorganizedinsublistscorrespondingtodifferentvlsofγ[[
   index]]], {index, lengthofs}];

listoffwedgegvlsfordifferentvlsofαβΩvaryingγ = 
 Table[Apply[listofzfordifferentvlsofαβΩ[[index2]], 
  finalx2tdyadsorganizedinsublistscorrespondingtodifferentvlsofγ[[
   nvofγ]], {1}], {index2, 1, lengthoflistofzfordifferentvlsofαβΩ, 
    1}, {nvofγ, 1, lengthofs, 1}];

listofthefirstfactorsofSimpsrule = 
 Table[((Sum[
  timestep, {index3, 
   Floor[listofendfordifferentvlsofγ[[nvofγ]]/timestep]}] - 
    0)/(listoflengthsofsublistsoffinalx2tdyads[[nvofγ]] - 1))/
     3, {nvofγ, 1, lengthofs, 1}];

numberofvlsofα = Abs[finvlofα - initvlofα]/incrstepofα + 1;
numberofvlsofβ = Abs[finvlofβ - initvlofβ]/incrstepofβ + 1;
numberofvlsofΩ = Abs[finvlofΩ - initvlofΩ]/incrstepofΩ + 1;

listofthefirsttermsofthesecondfactorofSimpsrule = 
 Flatten[Table[
  listoffwedgegvlsfordifferentvlsofαβΩvaryingγ[[index4, index5, 
   1]], {index4, 1, numberofvlsofα*numberofvlsofβ*numberofvlsofΩ, 
    1}, {index5, 1, lengthofs, 1}]];

lengthoflistofthefirsttermsofthesecondfactorofSimpsrule = 
 Length[listofthefirsttermsofthesecondfactorofSimpsrule];

listofthesecondtermsofthesecondfactorofSimpsrule = 
 Flatten[Table[
  4*Sum[listoffwedgegvlsfordifferentvlsofαβΩvaryingγ[[index4, index5,
   index6]], {index6, 2, 
    listoflengthsofsublistsoffinalx2tdyads[[index5]] - 1, 
     2}], {index4, 1, numberofvlsofα*numberofvlsofβ*numberofvlsofΩ, 
      1}, {index5, 1, lengthofs, 1}]];

lengthoflistofthesecondtermsofthesecondfactorofSimpsrule = 
 Length[listofthesecondtermsofthesecondfactorofSimpsrule];

listofthethirdtermsofthesecondfactorofSimpsrule = 
 Flatten[Table[
  2*Sum[listoffwedgegvlsfordifferentvlsofαβΩvaryingγ[[index4, index5,
   index7]], {index7, 
    3, (listoflengthsofsublistsoffinalx2tdyads[[index5]] - 1) - 1, 
     2}], {index4, 1, numberofvlsofα*numberofvlsofβ*numberofvlsofΩ, 
      1}, {index5, 1, lengthofs, 1}]];

lengthoflistofthethirdtermsofthesecondfactorofSimpsrule = 
 Length[listofthethirdtermsofthesecondfactorofSimpsrule];

listofthefourthtermsofthesecondfactorofSimpsrule = 
 Flatten[Table[
  listoffwedgegvlsfordifferentvlsofαβΩvaryingγ[[index4, 
   index5, (listoflengthsofsublistsoffinalx2tdyads[[index5]] - 1) + 
    1]], {index4, 1, numberofvlsofα*numberofvlsofβ*numberofvlsofΩ, 
     1}, {index5, 1, lengthofs, 1}]];

lengthoflistofthefourthtermsofthesecondfactorofSimpsrule = 
 Length[listofthefourthtermsofthesecondfactorofSimpsrule];

listofMelnfunthroughSimpsintegrbeforemultiplyingwiththefirstfactors = 
 Table[Rationalize[
  listofthefirsttermsofthesecondfactorofSimpsrule[[index8]] + 
   listofthesecondtermsofthesecondfactorofSimpsrule[[index8]] + 
    listofthethirdtermsofthesecondfactorofSimpsrule[[index8]] + 
     listofthefourthtermsofthesecondfactorofSimpsrule[[index8]], 
      0], {index8, 1, 
       lengthoflistofthefirsttermsofthesecondfactorofSimpsrule, 1}];

lengthoflistofMelnfunthroughSimpsintegrbeforemultiplyingwiththefirstfa
 ctors = Length[
  listofMelnfunthroughSimpsintegrbeforemultiplyingwiththefirstfactors];

table4 = PadLeft[listofthefirstfactorsofSimpsrule, 
 lengthoflistofthefirsttermsofthesecondfactorofSimpsrule, 
  listofthefirstfactorsofSimpsrule];

lengthoftable4 = Length[table4];

listofMelnfunthroughSimpsintegr = 
 Thread[Times[table4, 
  listofMelnfunthroughSimpsintegrbeforemultiplyingwiththefirstfactors]];

lengthoflistofMelnfunthroughSimpsintegr =   
 Length[listofMelnfunthroughSimpsintegr];

listofzfordifferentvlsofαβΩaccompaniedbythevlsofαβΩ = 
 Flatten[Table[
  With[{α = α, β = β, 
   Ω = Ω}, (α*Cos[Ω*(#2 + t0)]*#1 - β*#1^2) {α, β, Ω} &], {α, 
    initvlofα, finvlofα, incrstepofα}, {β, initvlofβ, finvlofβ, 
     incrstepofβ}, {Ω, initvlofΩ, finvlofΩ, incrstepofΩ}]];

listofthevlsofαβΩ = 
 Table[listofzfordifferentvlsofαβΩaccompaniedbythevlsofαβΩ[[index9, 1,
  2]], {index9, 1, lengthoflistofzfordifferentvlsofαβΩ, 1}];

table5 = Flatten[
 Transpose[Table[listofthevlsofαβΩ, {index10, lengthofs}]], 1];

listofthevlsofγ = Table[{γ}, {γ, initvlofγ, finvlofγ, incrstepofγ}];

table6 = Flatten[Table[listofthevlsofγ, {index12, 
 numberofvlsofα*numberofvlsofβ*numberofvlsofΩ}], 1];

listofthevlsofαβΩγ = 
 Table[table5[[index13]]~Join~table6[[index13]], {index13, 1, 
  lengthoflistofMelnfunthroughSimpsintegr, 1}];

table7 = Range[1, lengthoflistofMelnfunthroughSimpsintegr, 1];

listofthevlsofαβΩγaccompaniedbytheindexofthecorrespondingMelnfun = 
 listofthevlsofαβΩγ[[#]]~Join~{{#}} & /@ table7;

list1 = {};list2 = {};

table8 = For[index15 = 1, 
 index15 <= lengthoflistofMelnfunthroughSimpsintegr, 
  index15 = index15 + 1, 
   If[Resolve[
    Exists[t0, listofMelnfunthroughSimpsintegr[[index15]] == 0 ], 
     Reals], AppendTo[list1, 
      listofthevlsofαβΩγaccompaniedbytheindexofthecorrespondingMelnfun[[
       index15]]], 
        AppendTo[list2, 
       listofthevlsofαβΩγaccompaniedbytheindexofthecorrespondingMelnfun[[
         index15]]]]];

listofαβΩγaccompaniedbytheindexofthecorrespondingMelnfunforwhichMelnfu
 nhavezeros = list1;

lengthoflistofαβΩγaccompaniedbytheindexofthecorrespondingMelnfunforwhi
 chMelnfunhavezeros = 
  Length[listofαβΩγaccompaniedbytheindexofthecorrespondingMelnfunforwhi
   chMelnfunhavezeros];

listofindexesofMelnfunthathavezeros = 
 Table[listofαβΩγaccompaniedbytheindexofthecorrespondingMelnfunforwhic
  hMelnfunhavezeros[[index17, 5, 1]], {index17, 1, 
   lengthoflistofαβΩγaccompaniedbytheindexofthecorrespondingMelnfunfor
    whichMelnfunhavezeros, 1}];

lengthoflistofindexesofMelnfunthathavezeros = 
 Length[listofindexesofMelnfunthathavezeros];

listofMelnfunwhichhavezeros = 
 Table[listofMelnfunthroughSimpsintegr[[index18]], {index18, 
  listofindexesofMelnfunthathavezeros}];

lengthoflistofMelnfunwhichhavezeros =   
 Length[listofMelnfunwhichhavezeros];

listofthederivativesofMelnfunthathavezeros =   
 D[listofMelnfunwhichhavezeros, t0];

list3 = {};list4 = {};

table9 = For[index25 = 1, 
 index25 <= lengthoflistofMelnfunwhichhavezeros, 
  index25 = index25 + 1, 
   If[Resolve[
    Exists[t0, 
     Abs[listofMelnfunwhichhavezeros[[index25]]] + 
      Abs[listofthederivativesofMelnfunthathavezeros[[index25]]] == 
       0], Reals], 
        AppendTo[list3, 
      listofαβΩγaccompaniedbytheindexofthecorrespondingMelnfunforwhichMe
       lnfunhavezeros[[index25]]], 
        AppendTo[list4, 
       listofαβΩγaccompaniedbytheindexofthecorrespondingMelnfunforwhichMe
        lnfunhavezeros[[index25]]]]];

listofαβΩγaccompaniedbytheindexofthecorrespondingMelnfunforwhichMelnfu
 nhaveonlysimplezeros = list4;
$\endgroup$
1
  • 1
    $\begingroup$ The most compact way to solve this would be {list1,list2} = GatherBy[listoffuns, Resolve[Exists[t, # == 0], Reals] &]; but the Resolve[...] is still the slowest part taking an avg of 0.01742 seconds per function tested on my machine $\endgroup$
    – Histograms
    Commented May 12, 2015 at 13:04

1 Answer 1

3
$\begingroup$
Select[listoffuns, Resolve[Exists[t, # == 0], Reals] &]

Constructs list1 for you and

Select[listoffuns, !Resolve[Exists[t, # == 0], Reals] &]

constructs lists2. However the test Resolve[Exists[t, # == 0], Reals] & is computationally so expensive, that the For loop does not add any significant overhead. You'd be best off performing a refined test based on coefficients. In this case (Abs[b] > Abs[a]) &

As Histograms suggests in the comments,

{list2, list1} = GatherBy[listoffuns, Resolve[Exists[t, # == 0], Reals] &]

Note, that I write {list2, list1} and not the other way round, as GatherBy returns first the list which returns False on the test, and then the one with True.

$\endgroup$
3
  • 1
    $\begingroup$ Using GatherBy as in my comment on the question would be more efficient than performing two separate selects. $\endgroup$
    – Histograms
    Commented May 12, 2015 at 13:07
  • 1
    $\begingroup$ Exactly two times as efficient, in fact. I'll add that. I was thinking, along the lines that one list is the complement of the other... $\endgroup$
    – LLlAMnYP
    Commented May 12, 2015 at 13:11
  • $\begingroup$ Yeah, that would work too with Complement. Still cant figure out a faster way around Resolve for the general case though :( A refined test, like you say, looks to be the best approach. It looks like the functions provided have zeros whenever (-c d \[PlusMinus] ArcCos[-(a/b)] + 2 \[Pi])/c exists $\endgroup$
    – Histograms
    Commented May 12, 2015 at 13:18

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.