Related
I am trying to model the spread of disease using the differential equations given on this site http://www.maa.org/press/periodicals/loci/joma/the-sir-model-for-spread-of-disease-the-differential-equation-model with Wolfram Mathematica.
I entered:
NDSolve[{i'[t]== 1/2s[t]i[t]-1/3i[t], s[t]==-1/2s[t]i[t],r[t]==1/3i[t], r[0] ==0, s[0]==1, i[0]==1.27*10^-6,s'[0]==0} i, {t, 0, 100}]
and received the error
NDSolve called with 2 arguments; 3 or more arguments are expected.
I also tried
NDSolve[{i'[t]== 1/2s[t]i[t]-1/3i[t], s[t]==-1/2s[t]i[t],r[t]==1/3i[t], r[0] ==0, s[0]==1, i[0]==1.27*10^-6,s'[0]==0} i, {t, 0, 100}]
and got the same error
I am a newcomer to both differential equations and Mathematica, so I'd be grateful if someone can help.
As Bill told these was no coma. Second argument of NDSolve is set of function. You can type it without arguments or with arguments. Your code should look like this:
sol = NDSolve[
{i'[t] == 1/2 s[t] i[t] - 1/3 i[t],
s[t] == -1/2 s[t] i[t], r[t] == 1/3 i[t],
r[0] == 0,
s[0] == 1,
i[0] == 1.27*10^-6,
s'[0] == 0}, {i[t], s[t], r[t]}, {t, 0, 10}]
It generates error connected with numerical problems:
NDSolve::ivres: NDSolve has computed initial values that give a zero residual for the differential-algebraic system, but some components are different from those specified. If you need them to be satisfied, giving initial conditions for all dependent variables and their derivatives is recommended. >>
But you can print your results:
Plot[{Evaluate[i[t] /. sol], Evaluate[s[t] /. sol],
Evaluate[r[t] /. sol]}, {t, 0, 10}]
I'm looking for a way to reduce the length of a huge list with the Total function and a threshold parameter. I would like to avoid the use of For and If (coming from old habits).
Example :
List that I want to "reduce" :{1,5,3,8,11,3,4} with a threshold of 5.
Output that I want : {6,11,11,7}
That means that I use the Total function on the first parts of the list and look if the result of this function is higher than my threshold. If so, I use the result of the Total function and go to the next part of the list.
Another example is {1,1,1,1,1} with a threshold of 5. Result should be {5}.
Thanks!
EDIT : it is working but it is pretty slow. Any ideas in order to be faster?
EDIT 2 : the loop stuff (quit simple and not smart)
For[i = 1, i < Length[mylist] + 1, i++,
sum = sum + mylist[[i]];
If[sum > Threshold ,
result = Append[result , sum]; sum = 0; ]; ];
EDIT 3 : I have now a new thing to do.
I have to work now with a 2D list like {{1,2}{4,9}{1,3}{0,5}{7,3}}
It is more or less the same idea but the 1st and 2nd part of the list have to be higher than the thresold stuff (both of them).
Example : If lst[[1]] and lst[[2]] > threshold do the summuation for each part of the 2D list. I tried to adapt the f2 function from Mr.Wizard for this case but I didn't succeed. If it is easier, I can provide 2 independant lists and work with this input f3[lst1_,lst2_,thres_]:=
Reap[Sow#Fold[If[Element of the lst1 > thr && Element of the lst2, Sow##; #2, # + #2] &, 0, lst1]][[2, 1]] for example.
EDIT 4 :
You are right, it is not really clear. But the use of the Min## > thr statement is working perfectly.
Old code (ugly and not smart at all):
sumP = 0;
resP = {};
sumU = 0;
resU = {};
For[i = 1, i < Length[list1 + 1, i++,
sumP = sumP + list1[[i]];
sumU = sumU + list2[[i]];
If[sumP > 5 && sumU > 5 ,
resP = Append[resP, sumP]; sumP = 0;
resU = Append[resU, sumU]; sumU = 0;
];
]
NEW fast by Mr.Wizard :
f6[lst_, thr_] :=
Reap[Sow#Fold[If[Min## > thr , Sow##1; #2, #1 + #2] &, 0, lst]][[2,
1]]
That ~40times faster. Thanks a lot.
Thread[{resP, resU}] == f6[Thread[{list1,list2}], 5] True
I recommend using Fold for this kind of operation, combined with either linked lists or Sow and Reap to accumulate results. Append is slow because lists in Mathematica are arrays and must be reallocated every time an element is appended.
Starting with:
lst = {2, 6, 4, 4, 1, 3, 1, 2, 4, 1, 2, 4, 0, 7, 4};
Here is the linked-list version:
Flatten # Fold[If[Last## > 5, {#, #2}, {First##, Last## + #2}] &, {{}, 0}, lst]
{8, 8, 7, 7, 11, 4}
This is what the output looks like before Flatten:
{{{{{{{}, 8}, 8}, 7}, 7}, 11}, 4}
Here is the method using Sow and Reap:
Reap[Sow # Fold[If[# > 5, Sow##; #2, # + #2] &, 0, lst]][[2, 1]]
{8, 8, 7, 7, 11, 4}
A similar method applied to other problems: (1) (2)
The Sow # on the outside of Fold effectively appends the last element of the sequence which would otherwise be dropped by the algorithm.
Here are the methods packaged as functions, along with george's for easy comparison:
f1[lst_, thr_] :=
Flatten # Fold[If[Last## > thr, {#, #2}, {First##, Last## + #2}] &, {{}, 0}, lst]
f2[lst_, thr_] :=
Reap[Sow#Fold[If[# > thr, Sow##; #2, # + #2] &, 0, lst]][[2, 1]]
george[t_, thresh_] := Module[{i = 0, s},
Reap[While[i < Length[t], s = 0;
While[++i <= Length[t] && (s += t[[i]]) < thresh]; Sow[s]]][[2, 1]]
]
Timings:
big = RandomInteger[9, 500000];
george[big, 5] // Timing // First
1.279
f1[big, 5] // Timing // First
f2[big, 5] // Timing // First
0.593
0.468
Here is the obvious approach which is oh 300x faster.. Pretty isn't always best.
t = Random[Integer, 10] & /# Range[2000];
threshold = 4;
Timing[
i = 0;
t0 = Reap[
While[i < Length[t], s = 0;
While[++i <= Length[t] && (s += t[[i]]) < threshold ];
Sow[s]]][[2, 1]]][[1]]
Total[t] == Total[t0]
Timing[ t1 =
t //. {a___, b_ /; b < threshold, c_, d___} -> {a, b + c, d} ][[1]]
t1 == t0
I interpret your requirement as:
if an element in the list is less than the threshold value, add it to the next element in the list;
repeat this process until the list no longer changes.
So, for the threshold 5 and the input list {1,5,3,8,11,3,4} you'ld get
{6,3,8,11,3,4}
{6,11,11,3,4}
{6,11,11,7}
EDIT
I've now tested this solution to your problem ...
Implement the operation by using a replacement rule:
myList = {1,5,3,8,11,3,4}
threshold = 5
mylist = mylist //. {a___, b_ /; b < threshold, c_, d___} :> {a, b+c, d}
Note the use of ReplaceRepeated (symbolification //.).
This is a fun little problem, and I wanted to check with the experts here if there is a better functional/Mathematica way to approach solving it than what I did. I am not too happy with my solution since I use big IF THEN ELSE in it, but could not find a Mathematica command to use easily to do it (such as Select, Cases, Sow/Reap, Map.. etc...)
Here is the problem, given a list values (numbers or symbols), but for simplicity, lets assume a list of numbers for now. The list can contain zeros and the goal is replace the each zero with the element seen before it.
At the end, the list should contain no zeros in it.
Here is an example, given
a = {1, 0, 0, -1, 0, 0, 5, 0};
the result should be
a = {1, 1, 1, -1, -1, -1, 5, 5}
It should ofcourse be done in the most efficient way.
This is what I could come up with
Scan[(a[[#]] = If[a[[#]] == 0, a[[#-1]], a[[#]]]) &, Range[2, Length[a]]];
I wanted to see if I can use Sow/Reap on this, but did not know how.
question: can this be solved in a more functional/Mathematica way? The shorter the better ofcourse :)
update 1
Thanks everyone for the answer, all are very good to learn from. This is the result of speed test, on V 8.04, using windows 7, 4 GB Ram, intel 930 #2.8 Ghz:
I've tested the methods given for n from 100,000 to 4 million. The ReplaceRepeated method does not do well for large lists.
update 2
Removed earlier result that was shown above in update1 due to my error in copying one of the tests.
The updated results are below. Leonid method is the fastest. Congratulation Leonid. A very fast method.
The test program is the following:
(*version 2.0 *)
runTests[sizeOfList_?(IntegerQ[#] && Positive[#] &)] :=
Module[{tests, lst, result, nasser, daniel, heike, leonid, andrei,
sjoerd, i, names},
nasser[lst_List] := Module[{a = lst},
Scan[(a[[#]] = If[a[[#]] == 0, a[[# - 1]], a[[#]]]) &,
Range[2, Length[a]]]
];
daniel[lst_List] := Module[{replaceWithPrior},
replaceWithPrior[ll_, n_: 0] :=
Module[{prev}, Map[If[# == 0, prev, prev = #] &, ll]
];
replaceWithPrior[lst]
];
heike[lst_List] := Flatten[Accumulate /# Split[lst, (#2 == 0) &]];
andrei[lst_List] := Module[{x, y, z},
ReplaceRepeated[lst, {x___, y_, 0, z___} :> {x, y, y, z},
MaxIterations -> Infinity]
];
leonid[lst_List] :=
FoldList[If[#2 == 0, #1, #2] &, First##, Rest##] & #lst;
sjoerd[lst_List] :=
FixedPoint[(1 - Unitize[#]) RotateRight[#] + # &, lst];
lst = RandomChoice[Join[ConstantArray[0, 10], Range[-1, 5]],
sizeOfList];
tests = {nasser, daniel, heike, leonid, sjoerd};
names = {"Nasser","Daniel", "Heike", "Leonid", "Sjoerd"};
result = Table[0, {Length[tests]}, {2}];
Do[
result[[i, 1]] = names[[i]];
Block[{j, r = Table[0, {5}]},
Do[
r[[j]] = First#Timing[tests[[i]][lst]], {j, 1, 5}
];
result[[i, 2]] = Mean[r]
],
{i, 1, Length[tests]}
];
result
]
To run the tests for length 1000 the command is:
Grid[runTests[1000], Frame -> All]
Thanks everyone for the answers.
Much (order of magnitude) faster than other solutions still:
FoldList[If[#2 == 0, #1, #2] &, First##, Rest##] &
The speedup is due to Fold autocompiling. Will not be so dramatic for non-packed arrays. Benchmarks:
In[594]:=
a=b=c=RandomChoice[Join[ConstantArray[0,10],Range[-1,5]],150000];
(b=Flatten[Accumulate/#Split[b,(#2==0)&]]);//Timing
Scan[(a[[#]]=If[a[[#]]==0,a[[#-1]],a[[#]]])&,Range[2,Length[a]]]//Timing
(c=FoldList[If[#2==0,#1,#2]&,First##,Rest##]&#c);//Timing
SameQ[a,b,c]
Out[595]= {0.187,Null}
Out[596]= {0.625,Null}
Out[597]= {0.016,Null}
Out[598]= True
This seems to be a factor 4 faster on my machine:
a = Flatten[Accumulate /# Split[a, (#2 == 0) &]]
The timings I get are
a = b = RandomChoice[Join[ConstantArray[0, 10], Range[-1, 5]], 10000];
(b = Flatten[Accumulate /# Split[b, (#2 == 0) &]]); // Timing
Scan[(a[[#]] = If[a[[#]] == 0, a[[# - 1]], a[[#]]]) &,
Range[2, Length[a]]] // Timing
SameQ[a, b]
(* {0.015815, Null} *)
(* {0.061929, Null} *)
(* True *)
FixedPoint[(1 - Unitize[#]) RotateRight[#] + # &, d]
is about 10 and 2 times faster than Heike's solutions but slower than Leonid's.
You question looks exactly like a task for ReplaceRepeated function. What it does basically is that it applies the same set of rules to the expression until no more rules are applicable. In your case the expression is a list, and the rule is to replace 0 with its predecessor whenever occurs in a list. So here is the solution:
a = {1, 0, 0, -1, 0, 0, 5, 0};
a //. {x___, y_, 0, z___} -> {x, y, y, z};
The pattern for the rule here is the following:
x___ - any symbol, zero or more repetitions, the beginning of the list
y_ - exactly one element before zero
0 - zero itself, this element will be replaced with y later
z___ - any symbol, zero or more repetitions, the end of the list
Given a vector A=[a_1, a_2, a_3,...,a_n], where a_i are integers, now
solving an equation
∑a_i x_i=0 with x_i>=0, and x_i to be integers.
Using Mathematica, we can write some code like
Solve[A . Table[x[i], {i, n}] = 0 && Table[x[i] > 0, {i, n}], Integers]
But the conditions above Table[x[i] > 0 is not rightly coded. It should be x[1]>0 && x[2]>0 && x[3]>0 &&...x[n]>0. Is there any easy way to write such code?
You want to use Reduce not Solve, as Reduce can handle inequalities. As to turning Table[x[i] > 0, {i, n}] into x[1] > 0 && ... && x[n] > 0 that's straightforward:
And ## Table[x[i] > 0, {i, n}]
which uses the short form of Apply (##) to turn
List[x[1] > 0, ..., x[n] > 0]
into
And[x[1] > 0, ..., x[n] > 0]
Or, more visually,
x[1] > 0 && ... && x[n] > 0
In answering a physics forum question this morning, I ran into really bad performance of DifferenceRoot and RecurrenceTable compared to calculating the expressions by naively taking derivatives of an exponential generating functional. A very small amount of digging showed that DifferenceRoot and RecurrenceTable do not simplify expressions as they go.
For example, look at the following output of RecurrenceTable and how it simplifies by just Expanding the result:
In[1]:= RecurrenceTable[f[n] == a f[n - 1] + (a - 1) f[n - 2] &&
f[0] == 0 && f[1] == 1,
f, {n, 6}]
% // Expand
Out[1]= {0, 1, a, -1+a+a^2, -a+a^2+a (-1+a+a^2), 1-a-a^2+a (-1+a+a^2)+a (-a+a^2+a (-1+a+a^2))}
Out[2]= {0, 1, a, -1+a+a^2, -2 a+2 a^2+a^3, 1-2 a-2 a^2+3 a^3+a^4}
This quickly gets out of hand, as the leaf count of the 20th iteration (calculated using DifferenceRoot) shows:
dr[k_] := DifferenceRoot[Function[{f, n},
{f[n] == a f[n - 1] + (a - 1) f[n - 2], f[0] == 0, f[1] == 1}]][k]
In[2]:= dr20 = dr[20]; // Timing
dr20Exp = Expand[dr20]; // Timing
Out[2]= {0.26, Null}
Out[3]= {2.39, Null}
In[4]:= {LeafCount[dr20], LeafCount[dr20Exp]}
Out[4]= {1188383, 92}
Which can be compared to the memoized implementation
In[1]:= mem[n_] := a mem[n-1] + (a-1) mem[n-2] // Expand
mem[0] = 0; mem[1] = 1;
In[3]:= mem20 = mem[20];//Timing
LeafCount[mem20]
Out[3]= {0.48, Null}
Out[4]= 92
So my question is:
Are there any options/tricks to get DifferenceRoot and RecurrenceTable to apply a (simplifying) function as they go and thus make them useful for non-numeric work?
Edit: A Sjoerd pointed out below, I foolishly chose an example with a RSolveable closed form solution. In this question I'm primarily concerned with the behaviour of DifferenceRoot and RecurrenceTable. If it helps, imagine the the f[n-2] term is multiplied by n, so that there is no simple closed form solution.
I can't really help with your question as I haven't used those functions until now, and the docs don't give a clue. But why don't you just use RSolve here? It gives a closed form solution for each of the table's elements:
sol = f /. RSolve[f[n] == a f[n - 1] + (a - 1) f[n - 2] &&
f[0] == 0 && f[1] == 1, f, n
][[1, 1]]
sol#Range[6] // Simplify