Related
I would like to write a Mathematica function that constructs a list of all Fibonacci numbers less than n. Moreover, I would like to do this as elegantly and functionally as possible(so without an explicit loop).
Conceptually I want to take an infinite list of the natural numbers, map Fib[n] onto it, and then take elements from this list while they are less than n. How can I do this in Mathematica?
The first part can be done fairly easily in Mathematica. Below, I provide two functions nextFibonacci, which provides the next Fibonacci number greater than the input number (just like NextPrime) and fibonacciList, which provides a list of all Fibonacci numbers less than the input number.
ClearAll[nextFibonacci, fibonacciList]
nextFibonacci[m_] := Fibonacci[
Block[{n},
NArgMax[{n, 1/Sqrt[5] (GoldenRatio^n - (-1)^n GoldenRatio^-n) <= m, n ∈ Integers}, n]
] + 1
]
nextFibonacci[1] := 2;
fibonacciList[m_] := Fibonacci#
Range[0, Block[{n},
NArgMax[{n, 1/Sqrt[5] (GoldenRatio^n - (-1)^n GoldenRatio^-n) < m, n ∈ Integers}, n]
]
]
Now you can do things like:
nextfibonacci[15]
(* 21 *)
fibonacciList[50]
(* {0, 1, 1, 2, 3, 5, 8, 13, 21, 34} *)
The second part though, is tricky. What you're looking for is a Haskell type lazy evaluation that will only evaluate if and when necessary (as otherwise, you can't hold an infinite list in memory). For example, something like (in Haskell):
fibs = 0 : 1 : zipWith (+) fibs (tail fibs)
which then allows you to do things like
take 10 fibs
-- [0,1,1,2,3,5,8,13,21,34]
takeWhile (<100) fibs
-- [0,1,1,2,3,5,8,13,21,34,55,89]
Unfortunately, there is no built-in support for what you want. However, you can extend Mathematica to implement lazy style lists as shown in this answer, which was also implemented as a package. Now that you have all the pieces that you need, I'll let you work on this yourself.
If you grab my Lazy package from GitHub, your solution is as simple as:
Needs["Lazy`"]
LazySource[Fibonacci] ~TakeWhile~ ((# < 1000) &) // List
If you want to slightly more literally implement your original description
Conceptually I want to take an infinite list of the natural numbers, map Fib[n] onto it, and then take elements from this list while they are less than n.
you could do it as follows:
Needs["Lazy`"]
Fibonacci ~Map~ Lazy[Integers] ~TakeWhile~ ((# < 1000) &) // List
To prove that this is completely lazy, try the previous example without the // List on the end. You'll see that it stops with the (rather ugly) form:
LazyList[First[
LazyList[Fibonacci[First[LazyList[1, LazySource[#1 &, 2]]]],
Fibonacci /# Rest[LazyList[1, LazySource[#1 &, 2]]]]],
TakeWhile[
Rest[LazyList[Fibonacci[First[LazyList[1, LazySource[#1 &, 2]]]],
Fibonacci /# Rest[LazyList[1, LazySource[#1 &, 2]]]]], #1 <
1000 &]]
This consists of a LazyList[] expression whose first element is the first value of the expression that you're lazily evaluating and whose second element is instructions for how to continue the expansion.
Improvements
It's a little bit inefficient to continually call Fibonacci[n] all the time, especially as n starts getting large. It's actually possible to construct a lazy generator that will calculate the current value of the Fibonacci sequence as we stream:
Needs["Lazy`"]
LazyFibonacci[a_,b_]:=LazyList[a,LazyFibonacci[b,a+b]]
LazyFibonacci[]:=LazyFibonacci[1,1]
LazyFibonacci[] ~TakeWhile~ ((# < 1000)&) // List
Finally, we could generalize this up to a more abstract generating function that takes an initial value for an accumulator, a List of Rules to compute the accumulator's value for the next step and a List of Rules to compute the result from the current accumulator value.
LazyGenerator[init_, step_, extract_] :=
LazyList[Evaluate[init /. extract],
LazyGenerator[init /. step, step, extract]]
And could use it to generate the Fibonacci sequence as follows:
LazyGenerator[{1, 1}, {a_, b_} :> {b, a + b}, {a_, b_} :> a]
Ok, I hope I understood the question. But please note, I am not pure math major, I am mechanical engineering student. But this sounded interesting. So I looked up the formula and this is what I can come up with now. I have to run, but if there is a bug, please let me know and I will fix it.
This manipulate asks for n and then lists all Fibonacci numbers less than n. There is no loop to find how many Fibonacci numbers there are less than n. It uses Reduce to solve for the number of Fibonacci numbers less than n. I take the floor of the result and also threw away a constant that came up with in the solution a complex multiplier.
And then simply makes a table of all these numbers using Mathematica Fibonacci command. So if you enter n=20 it will list 1,1,2,3,5,8,13 and so on. I could do it for infinity as I ran out of memory (I only have 8 GB ram on my pc).
I put the limit for n to 500000 Feel free to edit the code and change it.
Manipulate[
Module[{k, m},
k = Floor#N[Assuming[Element[m, Integers] && m > 0,
Reduce[f[m] == n, m]][[2, 1, 2]] /. Complex[0, 2] -> 0];
TableForm#Join[{{"#", "Fibonacci number" }},
Table[{i, Fibonacci[i]}, {i, 1, k}]]
],
{{n, 3, "n="}, 2, 500000, 1, Appearance -> "Labeled", ImageSize -> Small},
SynchronousUpdating -> False,
ContentSize -> {200, 500}, Initialization :>
{
\[CurlyPhi][n_] := ((1 + Sqrt[5])/2)^n;
\[Psi][n_] := -(1/\[CurlyPhi][n]);
f[n_] := (\[CurlyPhi][n] - \[Psi][n])/Sqrt[5];
}]
Screen shot
The index k of the Fibonacci number Fk is k=Floor[Log[GoldenRatio,Fk]*Sqrt[5]+1/2]],
https://en.wikipedia.org/wiki/Fibonacci_number. Hence, the list of Fibonacci numbers less than or equal to n is
FibList[n_Integer]:=Fibonacci[Range[Floor[Log[GoldenRatio,Sqrt[5]*n+1/2]]]]
I was wondering if it is possible to use NMinimize from mathematica with an objective function, which contains random variables? E.g. I have a function with parameters which follow a distribution (normal and truncated normal). I want to fit its histogram to data that I have and constructed an objective function which now I need to minimize (so, the objective function depends on the mus and sigmas of the parameters and need to be determined). If I run my code, there is an error message: It claims the parameter for the NormalDistribution needs to be positive (If I plug in numbers for the mus and sigmas of my objective functionby hand, i don't get an error message).
So, I am wondering if it is not possible for NMinimize to handle a non-analytic function.
Thanks!
Here, I give you an example code (please note that the original function is more complicated)
listS and listT are both lists of event times. I want to fit the curve of my statistical model for the times (here, a very simple one, it consists of a truncated normal distribution) to the data I have.
For this I compare the survival curves and need to minimize the sum of the least squares.
My problem is that the function NMinimize doesn't seem to work. (Please note, that the original objective function consists of a more complicated function with parameters that are random variables)
(* Both lists are supposed to be the list of times *)
SurvivalS[listeS_, x_] := Module[{res, survivald},
survivald = SurvivalDistribution[listeS];
res = SurvivalFunction[survivald, x];
res]
Residuum[listeT_, listeS_] :=
Table[(SurvivalS[listeT, listeT[[i]]] - SurvivalS[listeS, listeT[[i]]]), {i,
1, dataN}];
LeastSquare[listeT_, listeS_] :=
Total[Function[x, x^2] /#
Residuum[listeT,
listeS]];(* objective function, here ist is the sum of least square *)
objectiveF[mu_, sigma_] :=
Piecewise[{{LeastSquare[listeT, listeS[mu, sigma]], mu > 0 && sigma > 0}},
20 (1 + (sigma + mu)^2)];
pool = 100; (* No. points from MonteCarlo *)
listeS[mu_, sigma_] := RandomVariate[TruncatedDistribution[{0, 1}, NormalDistribution[mu, sigma]],pool];(* simulated data *)
listeT = Sort[RandomVariate[TruncatedDistribution[{0, 1}, NormalDistribution[.5, .9]],60]]; (* list of "measured" data *)
dataN = Length[listeT];
NMinimize[objectiveF[mu, .9], {{mu, .4}}]
The error message is: "RandomVariate::realprm: Parameter mu at position 1 in NormalDistribution[mu,0.9] is expected to be real. >>"
I have a linear recurrence problem where the next element relies on more than just the prior value, e.g. the Fibonacci sequence. One method calculating the nth element is to define it via a function call, e.g.
Fibonacci[0] = 0; Fibonacci[1] = 1;
Fibonacci[n_Integer?Positive] := Fibonacci[n] + Fibonacci[n - 1]
and for the sequence I'm working with, that is exactly what I do. (The definition is inside of a Module so I don't pollute Global`.) However, I am going to be using this with 210 - 213 points, so I'm concerned about the extra overhead when I just need the last term and none of the prior elements. I'd like to use Fold to do this, but Fold only passes the immediately prior result which means it is not directly useful for a general linear recurrence problem.
I'd like a pair of functions to replace Fold and FoldList that pass a specified number of prior sequence elements to the function, i.e.
In[1] := MultiFoldList[f, {1,2}, {3,4,5}] (* for lack of a better name *)
Out[1]:= {1, 2, f[3,2,1], f[4,f[3,2,1],2], f[5,f[4,f[3,2,1],2],f[3,2,1]]}
I had something that did this, but I closed the notebook prior to saving it. So, if I rewrite it on my own, I'll post it.
Edit: as to why I am not using RSolve or MatrixPower to solve this. My specific problem is I'm performing an n-point Pade approximant to analytically continue a function I only know at a set number of points on the imaginary axis, {zi}. Part of creating the approximant is to generate a set of coefficients, ai, which is another recurrence relation, that are then fed into the final relationship
A[n+1]== A[n] + (z - z[[n]]) a[[n+1]] A[n-1]
which is not amenable to either RSolve nor MatrixPower, at least that I can see.
Can RecurrenceTable perform this task for you?
Find the 1000th term in a recurrence depending on two previous values:
In[1]:= RecurrenceTable[{a[n] == a[n - 1] + a[n - 2],
a[1] == a[2] == 1}, a,
{n, {1000}}]
Out[1]= {4346655768693745643568852767504062580256466051737178040248172\
9089536555417949051890403879840079255169295922593080322634775209689623\
2398733224711616429964409065331879382989696499285160037044761377951668\
49228875}
Edit: If your recurrence is defined by a function f[m, n] that doesn't like to get evaluated for non-numeric m and n, then you could use Condition:
In[2]:= f[m_, n_] /; IntegerQ[m] && IntegerQ[n] := m + n
The recurrence table in terms of f:
In[3]:= RecurrenceTable[{a[n] == f[a[n - 1], a[n - 2]],
a[1] == a[2] == 1}, a, {n, {1000}}]
Out[3]= {4346655768693745643568852767504062580256466051737178040248172\
9089536555417949051890403879840079255169295922593080322634775209689623\
2398733224711616429964409065331879382989696499285160037044761377951668\
49228875}
A multiple foldlist can be useful but it would not be an efficient way to get linear recurrences evaluated for large inputs. A couple of alternatives are to use RSolve or matrix powers times a vector of initial values.
Here are these methods applied to example if nth term equal to n-1 term plus two times n-2 term.
f[n_] = f[n] /. RSolve[{f[n] == f[n - 1] + 2*f[n - 2], f[1] == 1, f[2] == 1},
f[n], n][[1]]
Out[67]= 1/3 (-(-1)^n + 2^n)
f2[n_Integer] := Last[MatrixPower[{{0, 1}, {2, 1}}, n - 2].{1, 1}]
{f[11], f2[11]}
Out[79]= {683, 683}
Daniel Lichtblau
Wolfram Research
Almost a convoluted joke, but you could use a side-effect of NestWhileList
fibo[n_] :=
Module[{i = 1, s = 1},
NestWhileList[ s &, 1, (s = Total[{##}]; ++i < n) &, 2]];
Not too bad performance:
In[153]:= First#Timing#fibo[10000]
Out[153]= 0.235
By changing the last 2 by any integer you may pass the last k results to your function (in this case Total[]).
LinearRecurrence and RecurrenceTable are very useful.
For small kernels, the MatrixPower method that Daniel gave is the fastest.
For some problems these may not be applicable, and you may need to roll your own.
I will be using Nest because I believe that is appropriate for this problem, but a similar construct can be used with Fold.
A specific example, the Fibonacci sequence. This may not be the cleanest possible for that, but I believe you will see the utility as I continue.
fib[n_] :=
First#Nest[{##2, # + #2} & ## # &, {1, 1}, n - 1]
fib[15]
Fibonacci[15]
Here I use Apply (##) so that I can address elements with #, #2, etc., rathern than #[[1]] etc. I use SlotSequence to drop the first element from the old list, and Sequence it into the new list at the same time.
If you are going to operate on the entire list at once, then a simple Append[Rest##, ... may be better. Either method can be easily generalized. For example, a simple linear recurrence implementation is
lr[a_, b_, n_Integer] := First#Nest[Append[Rest##, a.#] &, b, n - 1]
lr[{1,1}, {1,1}, 15]
(the kernel is in reverse order from the built in LinearRecurrence)
Graphics#Flatten[Table[
(*colors, dont mind*)
{ColorData["CMYKColors"][(a[[r, t]] - .000007)/(.0003 - 0.000007)],
(*point size, dont mind*)
PointSize[1/Sqrt[r]/10],
(*Coordinates for your points "a" is your data matrix *)
Point[
{(rr =Log[.025 + (.58 - .25)/64 r]) Cos#(tt = t 5 Degree),
rr Sin#tt}]
} &#
(*values for the iteration*)
, {r, 7, 64}, {t, 1, 72}], 1]
(*Rotation, dont mind*)
/. gg : Graphics[___] :> Rotate[gg, Pi/2]
Okay, I'll bite. First, Mathematica allows functions to be applied via one of several forms: standard form - f[x], prefix form - f # x, postfix form - f // x, and infix form - x ~ f ~ y. Belisarius's code uses both standard and prefix form.
So, let's look at the outermost functions first: Graphics # x /. gg : Graphics[___]:> Rotate[gg,Pi/2], where x is everything inside of Flatten. Essentially, what this does is create a Graphics object from x and using a named pattern (gg : Graphics[___]) rotates the resulting Graphics object by 90 degrees.
Now, to create a Graphics object, we need to supply a bunch of primitives and this is in the form of a nested list, where each sublist describes some element. This is done via the Table command which has the form: Table[ expr, iterators ]. Iterators can have several forms, but here they both have the form {var, min, max}, and since they lack a 4th term, they take on each value between min and max in integer steps. So, our iterators are {r, 7, 64} and {t, 1, 72}, and expr is evaluated for each value that they take on. Since, we have two iterators this produces a matrix, which would confuse Graphics, so we using Flatten[ Table[ ... ], 1] we take every element of the matrix and put it into a simple list.
Each element that Table produces is simply: color (ColorData), point size (PointSize), and point location (Point). So, with Flatten, we have created the following:
Graphics[{{color, point size, point}, {color, point size, point}, ... }]
The color generation is taken from the data, and it assumes that the data has been put into a list called a. The individual elements of a are accessed through the Part construct: [[]]. On the surface, the ColorData construct is a little odd, but it can be read as ColorData["CMYKColors"] returns a ColorDataFunction that produces a CMYK color value when a value between 0 and 1 is supplied. That is why the data from a is scaled the way it is.
The point size is generated from the radial coordinate. You'd expect with 1/Sqrt[r] the point size should be getting smaller as r increases, but the Log inverts the scale.
Similarly, the point location is produced from the radial and angular (t) variables, but Point only accepts them in {x,y} form, so he needed to convert them. Two odd constructs occur in the transformation from {r,t} to {x,y}: both rr and tt are Set (=) while calculating x allowing them to be used when calculating y. Also, the term t 5 Degree lets Mathematica know that the angle is in degrees, not radians. Additionally, as written, there is a bug: immediately following the closing }, the terms & and # should not be there.
Does that help?
I have some periodic data, but the amount of data is not a multiple of
the period. How can I Fourier analyze this data? Example:
% Let's create some data for testing:
data = Table[N[753+919*Sin[x/623-125]], {x,1,25000}]
% I now receive this data, but have no idea that it came from the
formula above. I'm trying to reconstruct the formula just from 'data'.
% Looking at the first few non-constant terms of the Fourier series:
ListPlot[Table[Abs[Fourier[data]][[x]], {x,2,20}], PlotJoined->True,
PlotRange->All]
shows an expected spike at 6 (since the number of periods is really
25000/(623*2*Pi) or about 6.38663, though we don't know this).
% Now, how do I get back 6.38663? One way is to "convolve" the data with
arbitrary multiples of Cos[x].
convolve[n_] := Sum[data[[x]]*Cos[n*x], {x,1,25000}]
% And graph the "convolution" near n=6:
Plot[convolve[n],{n,5,7}, PlotRange->All]
we see a spike roughly where expected.
% We try FindMaximum:
FindMaximum[convolve[n],{n,5,7}]
but the result is useless and inaccurate:
FindMaximum::fmmp:
Machine precision is insufficient to achieve the requested accuracy or
precision.
Out[119]= {98.9285, {n -> 5.17881}}
because the function is very wiggly.
% By refining our interval (using visual analysis on the plots), we
finally find an interval where convolve[] doesn't wiggle too much:
Plot[convolve[n],{n,6.2831,6.2833}, PlotRange->All]
and FindMaximum works:
FindMaximum[convolve[n],{n,6.2831,6.2833}] // FortranForm
List(1.984759605826571e7,List(Rule(n,6.2831853071787975)))
% However, this process is ugly, requires human intervention, and
computing convolve[] is REALLY slow. Is there a better way to do this?
% Looking at the Fourier series of the data, can I somehow divine the
"true" number of periods is 6.38663? Of course, the actual result
would be 6.283185, since my data fits that better (because I'm only
sampling at a finite number of points).
Based on Mathematica help for the Fourier function / Applications / Frequency Identification:
Checked on version 7
n = 25000;
data = Table[N[753 + 919*Sin[x/623 - 125]], {x, 1, n}];
pdata = data - Total[data]/Length[data];
f = Abs[Fourier[pdata]];
pos = Ordering[-f, 1][[1]]; (*the position of the first Maximal value*)
fr = Abs[Fourier[pdata Exp[2 Pi I (pos - 2) N[Range[0, n - 1]]/n],
FourierParameters -> {0, 2/n}]];
frpos = Ordering[-fr, 1][[1]];
N[(pos - 2 + 2 (frpos - 1)/n)]
returns 6.37072
Look for the period length using autocorrelation to get an estimate:
autocorrelate[data_, d_] :=
Plus ## (Drop[data, d]*Drop[data, -d])/(Length[data] - d)
ListPlot[Table[{d, autocorrelate[data, d]}, {d, 0, 5000, 100}]]
A smart search for the first maximum away from d=0 may be the best estimate you can get form the available data?
(* the data *)
data = Table[N[753+919*Sin[x/623-125]], {x,1,25000}];
(* Find the position of the largest Fourier coefficient, after
removing the last half of the list (which is redundant) and the
constant term; the [[1]] is necessary because Ordering returns a list *)
f2 = Ordering[Abs[Take[Fourier[data], {2,Round[Length[data]/2+1]}]],-1][[1]]
(* Result: 6 *)
(* Directly find the least squares difference between all functions of
the form a+b*Sin[c*n-d], with intelligent starting values *)
sol = FindMinimum[Sum[((a+b*Sin[c*n-d]) - data[[n]])^2, {n,1,Length[data]}],
{{a,Mean[data]},{b,(Max[data]-Min[data])/2},{c,2*f2*Pi/Length[data]},d}]
(* Result (using //InputForm):
FindMinimum::sszero:
The step size in the search has become less than the tolerance prescribed by
the PrecisionGoal option, but the gradient is larger than the tolerance
specified by the AccuracyGoal option. There is a possibility that the method
has stalled at a point that is not a local minimum.
{2.1375902350021628*^-19, {a -> 753., b -> -919., c -> 0.0016051364365971107,
d -> 2.477886509998064}}
*)
(* Create a table of values for the resulting function to compare to 'data' *)
tab = Table[a+b*Sin[c*x-d], {x,1,Length[data]}] /. sol[[2]];
(* The maximal difference is effectively 0 *)
Max[Abs[data-tab]] // InputForm
(* Result: 7.73070496506989*^-12 *)
Although the above doesn't necessarily fully answer my question, I found it
somewhat remarkable.
Earlier, I'd tried using FindFit[] with Method -> NMinimize (which is
supposed to give a better global fit), but that didn't work well,
possibly because you can't give FindFit[] intelligent starting values.
The error I get bugs me but appears to be irrelevant.