Related
I have a code where we first need to generate n + 1 numbers in a range with a given step. However, I don't understand how and why it works:
a = 2;
b = 7;
h = (b-a)/n;
x[0] = a;
Array[x, n+1, 0];
For[i = 0, i < n + 1, i++, x[i] = a + h*i]
My questions are:
Are elements of x automatically generated when accessed? There's no mention of x before the line x[0] = a
Shouldn't index access be like x[[i]]?
What exactly does Array do here? It isn't assigned to anything which confuses me
Try Range[2,10,2] for a range of numbers from 2 to 10 in steps of 2, etc.
Beyond that there some faults in your code, or perhaps in your understanding of Mathematica ...
x[0] = a defines a function called x which, when presented with argument 0 returns a (or a's value since it is previously defined). Mathematica is particular about the bracketing characters used [ and ] enclose function argument lists. Since there is no other definition for the function x (at least not that we can see here) then it will return unevaluated for any argument other than 0.
And you are right, doubled square brackets, ie [[ and ]], are used to enclose index values. x[[2]] would indeed refer to the second element of a list called x. Note that Mathematica indexes from 1 so x[[0]] would produce an error if x existed and was a list.
The expression Array[x, n+1, 0] does return a value, but it is not assigned to any symbol so is lost. And the trailing ; on the line suppresses Mathematica's default behaviour to print the return value of any expression you execute.
Finally, on the issue of the use of For to make lists of values, refer to https://mathematica.stackexchange.com/questions/7924/alternatives-to-procedural-loops-and-iterating-over-lists-in-mathematica. And perhaps ask further Mathematica questions at that site, the real experts on the system are much more likely to be found there.
I suppose I might add ... if you are committed to using Array for some reason ask another question specifically about that. As you might (not) realise, I recommend not using that function to create a list of numbers.
From the docs, Array[f, n, r] generates a list using the index origin r.
On its own Array[x, n + 1, 0] just produces a list of x functions, e.g.
n = 4;
Array[x, n + 1, 0]
{x[0], x[1], x[2], x[3], x[4]}
If x is defined it is applied, e.g.
x[arg_] := arg^2
Array[x, 4 + 1, 0]
{0, 1, 4, 9, 16}
Alternatively, to use x as a function variable the Array can be set like so
Clear[x]
With[{z = Array[x, n + 1, 0]}, z = {m, n, o, p, q}]
{x[0], x[1], x[2], x[3], x[4]}
{m, n, o, p, q}
The OP's code sets function variables of x in the For loop, e.g.
Still with n = 4
a = 2;
b = 7;
h = (b - a)/n;
For[i = 0, i < n + 1, i++, x[i] = a + h*i]
which can be displayed by Array[x, n + 1, 0]
{2, 13/4, 9/2, 23/4, 7}
also x[0] == 2
True
The same could be accomplished thusly
Clear[x]
With[{z = Array[x, n + 1, 0]}, z = Table[a + h*i, {i, 0, 4}]]
{2, 13/4, 9/2, 23/4, 7}
Note also DownValues[x] shows the function definitions
{HoldPattern[x[0]] :> 2,
HoldPattern[x[1]] :> 13/4,
HoldPattern[x[2]] :> 9/2,
HoldPattern[x[3]] :> 23/4,
HoldPattern[x[4]] :> 7}
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}]
Suppose I want to construct a matrix A such that A[[i,i]]=f[x_,y_]+d[i], A[[i,i+1]]=u[i], A[[i+1,i]]=l[i], i=1,N . Say, f[x_,y_]=x^2+y^2.
How can I code this in Mathematica?
Additionally, if I want to integrate the first diagonal element of A, i.e. A[[1,1]] over x and y, both running from 0 to 1, how can I do that?
In[1]:= n = 4;
f[x_, y_] := x^2 + y^2;
A = Normal[SparseArray[{
{i_,i_}/;i>1 -> f[x,y]+ d[i],
{i_,j_}/;j-i==1 -> u[i],
{i_,j_}/;i-j==1 -> l[i-1],
{1, 1} -> Integrate[f[x,y]+d[1], {x,0,1}, {y,0,1}]},
{n, n}]]
Out[3]= {{2/3+d[1], l[1], 0, 0},
{u[1], x^2+y^2+ d[2], l[2], 0},
{0, u[2], x^2+y^2+d[3], l[3]},
{0, 0, u[3], x^2+y^2+d[4]}}
Band is tailored specifically for this:
myTridiagonalMatrix#n_Integer?Positive :=
SparseArray[
{ Band#{1, 1} -> f[x, y] + Array[d, n]
, Band#{1, 2} -> Array[u, n - 1]
, Band#{2, 1} -> Array[l, n - 1]}
, {n, n}]
Check it out (no need to define f, d, u, l):
myTridiagonalMatrix#5 // MatrixForm
Note that MatrixForm should not be part of a definition. For example, it's a bad idea to set A = (something) // MatrixForm. You will get a MatrixForm object instead of a table (= array of arrays) or a sparse array, and its only purpose is to be pretty-printed in FrontEnd. Trying to use MatrixForm in calculations will yield errors and will lead to unnecessary confusion.
Integrating the element at {1, 1}:
myTridiagonalMatrixWithFirstDiagonalElementIntegrated#n_Integer?Positive :=
MapAt[
Integrate[#, {x, 0, 1}, {y, 0, 1}]&
, myTridiagonalMatrix#n
, {1, 1}]
You may check it out without defining f or d, as well:
myTridiagonalMatrixWithFirstDiagonalElementIntegrated#5
The latter operation, however, looks suspicious. For example, it does not leave your matrix (or its corresponding linear system) invariant w.r.t. reasonable transformations. (This operation does not even preserve linearity of matrices.) You probably don't want to do it.
Comment on comment above: there's no need to define A[x_, y_] := … to Integrate[A[[1,1]], {x,0,1}, {y,0,1}]. Note that A[[1,1]] is totally different from A[1, 1]: the former is Part[A, 1, 1] which is a certain element of table A. A[1, 1] is a different expression: if A is some table then A[1, 1] is (that table)[1, 1], which is a valid expression but is normally considered meaningless.
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
On the documentation page for Equal we read that
Approximate numbers with machine
precision or higher are considered
equal if they differ in at most their
last seven binary digits (roughly
their last two decimal digits).
Here are examples (32 bit system; for 64 bit system add some more zeros in the middle):
In[1]:= 1.0000000000000021 == 1.0000000000000022
1.0000000000000021 === 1.0000000000000022
Out[1]= True
Out[2]= True
I'm wondering is there a "normal" analog of the Equal function in Mathematica that does not drop last 7 binary digits?
Thanks to recent post on the official newsgroup by Oleksandr Rasputinov, now I have learned two undocumented functions which control the tolerance of Equal and SameQ: $EqualTolerance and $SameQTolerance. In Mathematica version 5 and earlier these functions live in the Experimental` context and are well documented: $EqualTolerance, $SameQTolerance. Starting from version 6, they are moved to the Internal` context and become undocumented but still work and even have built-in diagnostic messages which appear when one try to assign them illegal values:
In[1]:= Internal`$SameQTolerance = a
During evaluation of In[2]:= Internal`$SameQTolerance::tolset:
Cannot set Internal`$SameQTolerance to a; value must be a real
number or +/- Infinity.
Out[1]= a
Citing Oleksandr Rasputinov:
Internal`$EqualTolerance ... takes a
machine real value indicating the
number of decimal digits' tolerance
that should be applied, i.e.
Log[2]/Log[10] times the number of
least significant bits one wishes to
ignore.
In this way, setting Internal`$EqualTolerance to zero will force Equal to consider numbers equal only when they are identical in all binary digits (not considering out-of-Precision digits):
In[2]:= Block[{Internal`$EqualTolerance = 0},
1.0000000000000021 == 1.0000000000000022]
Out[2]= False
In[5]:= Block[{Internal`$EqualTolerance = 0},
1.00000000000000002 == 1.000000000000000029]
Block[{Internal`$EqualTolerance = 0},
1.000000000000000020 == 1.000000000000000029]
Out[5]= True
Out[6]= False
Note the following case:
In[3]:= Block[{Internal`$EqualTolerance = 0},
1.0000000000000020 == 1.0000000000000021]
RealDigits[1.0000000000000020, 2] === RealDigits[1.0000000000000021, 2]
Out[3]= True
Out[4]= True
In this case both numbers have MachinePrecision which effectively is
In[5]:= $MachinePrecision
Out[5]= 15.9546
(53*Log[10, 2]). With such precision these numbers are identical in all binary digits:
In[6]:= RealDigits[1.0000000000000020` $MachinePrecision, 2] ===
RealDigits[1.0000000000000021` $MachinePrecision, 2]
Out[6]= True
Increasing precision to 16 makes them different arbitrary-precision numbers:
In[7]:= RealDigits[1.0000000000000020`16, 2] ===
RealDigits[1.0000000000000021`16, 2]
Out[7]= False
In[8]:= Row#First#RealDigits[1.0000000000000020`16,2]
Row#First#RealDigits[1.0000000000000021`16,2]
Out[9]= 100000000000000000000000000000000000000000000000010010
Out[10]= 100000000000000000000000000000000000000000000000010011
But unfortunately Equal still fails to distinguish them:
In[11]:= Block[{Internal`$EqualTolerance = 0},
{1.00000000000000002`16 == 1.000000000000000021`16,
1.00000000000000002`17 == 1.000000000000000021`17,
1.00000000000000002`18 == 1.000000000000000021`18}]
Out[11]= {True, True, False}
There is an infinite number of such cases:
In[12]:= Block[{Internal`$EqualTolerance = 0},
Cases[Table[a = SetPrecision[1., n];
b = a + 10^-n; {n, a == b, RealDigits[a, 2] === RealDigits[b, 2],
Order[a, b] == 0}, {n, 15, 300}], {_, True, False, _}]] // Length
Out[12]= 192
Interestingly, sometimes RealDigits returns identical digits while Order shows that internal representations of expressions are not identical:
In[13]:= Block[{Internal`$EqualTolerance = 0},
Cases[Table[a = SetPrecision[1., n];
b = a + 10^-n; {n, a == b, RealDigits[a, 2] === RealDigits[b, 2],
Order[a, b] == 0}, {n, 15, 300}], {_, _, True, False}]] // Length
Out[13]= 64
But it seems that opposite situation newer happens:
In[14]:=
Block[{Internal`$EqualTolerance = 0},
Cases[Table[a = SetPrecision[1., n];
b = a + 10^-n; {n, a == b, RealDigits[a, 2] === RealDigits[b, 2],
Order[a, b] == 0}, {n, 15, 3000}], {_, _, False, True}]] // Length
Out[14]= 0
Try this:
realEqual[a_, b_] := SameQ ## RealDigits[{a, b}, 2, Automatic]
The choice of base 2 is crucial to ensure that you are comparing the internal representations.
In[54]:= realEqual[1.0000000000000021, 1.0000000000000021]
Out[54]= True
In[55]:= realEqual[1.0000000000000021, 1.0000000000000022]
Out[55]= False
In[56]:= realEqual[
1.000000000000000000000000000000000000000000000000000000000000000022
, 1.000000000000000000000000000000000000000000000000000000000000000023
]
Out[56]= False
In[12]:= MyEqual[x_, y_] := Order[x, y] == 0
In[13]:= MyEqual[1.0000000000000021, 1.0000000000000022]
Out[13]= False
In[14]:= MyEqual[1.0000000000000021, 1.0000000000000021]
Out[14]= True
This tests if two object are identical, since 1.0000000000000021 and 1.000000000000002100 differs in precision they won't be considered as identical.
I'm not aware of an already defined operator. But you may define for example:
longEqual[x_, y_] := Block[{$MaxPrecision = 20, $MinPrecision = 20},
Equal[x - y, 0.]]
Such as:
longEqual[1.00000000000000223, 1.00000000000000223]
True
longEqual[1.00000000000000223, 1.00000000000000222]
False
Edit
If you want to generalize for an arbitrary number of digits, you can do for example:
longEqual[x_, y_] :=
Block[{
$MaxPrecision = Max ## StringLength /# ToString /# {x, y},
$MinPrecision = Max ## StringLength /# ToString /# {x, y}},
Equal[x - y, 0.]]
So that your counterexample in your comment also works.
HTH!
I propose a strategy that uses RealDigits to compare the actual digits of the numbers. The only tricky bit is stripping out trailing zeroes.
trunc = {Drop[First##, Plus ## First /# {-Dimensions#First##,
Last#Position[First##, n_?(# != 0 &)]}], Last##} &# RealDigits## &;
exactEqual = SameQ ## trunc /# {#1, #2} &;
In[1] := exactEqual[1.000000000000000000000000000000000000000000000000000111,
1.000000000000000000000000000000000000000000000000000111000]
Out[1] := True
In[2] := exactEqual[1.000000000000000000000000000000000000000000000000000111,
1.000000000000000000000000000000000000000000000000000112000]
Out[2] := False
I think that you really have to specify what you want... there's no way to compare approximate real numbers that will satisfy everyone in every situation.
Anyway, here's a couple more options:
In[1]:= realEqual[lhs_,rhs_,tol_:$MachineEpsilon] := 0==Chop[lhs-rhs,tol]
In[2]:= Equal[1.0000000000000021,1.0000000000000021]
realEqual[1.0000000000000021,1.0000000000000021]
Out[2]= True
Out[3]= True
In[4]:= Equal[1.0000000000000022,1.0000000000000021]
realEqual[1.0000000000000022,1.0000000000000021]
Out[4]= True
Out[5]= False
As the precision of both numbers gets higher, then they can always be distinguished if you set tol high enough.
Note that the subtraction is done at the precision of the lowest of the two numbers. You could make it happen at the precision of the higher number (which seems a bit pointless) by doing something like
maxEqual[lhs_, rhs_] := With[{prec = Max[Precision /# {lhs, rhs}]},
0 === Chop[SetPrecision[lhs, prec] - SetPrecision[rhs, prec], 10^-prec]]
maybe using the minimum precision makes more sense
minEqual[lhs_, rhs_] := With[{prec = Min[Precision /# {lhs, rhs}]},
0 === Chop[SetPrecision[lhs, prec] - SetPrecision[rhs, prec], 10^-prec]]
One other way to define such function is by using SetPrecision:
MyEqual[a_, b_] := SetPrecision[a, Precision[a] + 3] == SetPrecision[b, Precision[b] + 3]
This seems to work in the all cases but I'm still wondering is there a built-in function. It is ugly to use high-level functions for such a primitive task...