Sum of sine data fitting with mathematica - wolfram-mathematica

Hy everyones,
I've a little problem with a mathematica script which I need for fitting data points with a sum of 3 sine functions :
fit = NonlinearModelFit[Data,a1*Sin[b1*x + c1] + a2*Sin[b2*x + c2] + a3*Sin[b3*x + c3], {a1, b1,c1, a2, b2, c2, a3, b3, c3}, x]
I get this error :
NonlinearModelFit::cvmit: Failed to converge to the requested accuracy or precision within 100 iterations
I've tried with different starting values and with MaxIteration set to 10.000...
Maybe it's not the right way to do this kind of fitting. Does anyone have an idea about this?
Thanks!

Perhaps your data is too bad, but it works nicely with a good sample:
data = Table[{x, Sin[ x + .3] + 2 Sin[1.2 x] + 3 Sin[1.5 x + .5]},
{x, .01, 8 Pi, .001}];
fit = NonlinearModelFit[data,
a1*Sin[b1*x + c1] + a2*Sin[b2*x + c2] + a3*Sin[b3*x + c3],
{a1, b1, c1, a2, b2, c2, a3, b3, c3}, x]
Show[ListPlot[data], Plot[fit[x], {x, 0, 8 Pi}, PlotStyle -> Red], Frame -> True]

Related

Mathematica Issue: solving matrix equation AX=\lambdaBX Symbolically

I'm new to Mathematica, and I'm trying to solve a matrix equation in a form as
AX = \lambda BX
Here, Aand B are 4*4 matrices in the following, \lambda is a value, Xis the eigenvector- 4*1 matrix.
A = {{a1 + b1, c, d, f},
{c, a2 + b2 , f , e},
{d , f , a3 + b1 , c},
{ f, e , c, a4 + b2}}
B = {{1, 0, 0 , 0},
{0, 1 , 0 , 0},
{0 , 0 , -1 , 0},
{0, 0 , 0, -1}}
I would like to solve this matrix equation and get the symbolical solution for \lambda using a1,a2,a3,a4,b1,b2,c,d,e,f, etc.
It would be much grateful if anyone can tell me.
Best regards,
mike
See Wolfram: Matrix Computations - specifically the section 'Generalized Eigenvalues'.
For n×n matrices A, B the generalized eigenvalues are the n
roots of its characteristic polynomial, p(𝛇) = det(A - 𝛇 B). For
each generalized eigenvalue, λ ∊ λ(A, B), the vectors, 𝛇, that
satisfy
A χ = λ B χ
are described as generalized eigenvectors.
Example using symbolic values:
matA = {{a11, a12}, {a21, a22}};
matB = {{b11, b12}, {b21, b22}};
Eigenvalues[{matA, matB}]
{(1/(2 (-b12 b21+b11 b22)))(a22 b11-a21 b12-a12 b21+a11 b22-Sqrt[(-a22 b11+a21 b12+a12 b21-a11 b22)^2-4 (-a12 a21+a11 a22) (-b12 b21+b11 b22)]),(1/(2 (-b12 b21+b11 b22)))(a22 b11-a21 b12-a12 b21+a11 b22+Sqrt[(-a22 b11+a21 b12+a12 b21-a11 b22)^2-4 (-a12 a21+a11 a22) (-b12 b21+b11 b22)])}
Eigenvectors[{matA, matB}]
...

Parametric Equation solving in mathematica

I ma trying to solve this cubic equation for the variables a0,a1,a2,a3
ParametricNDSolve[{uz[t] == (a0[t]^3 + a1[t]^2 + a2[t] + a3),
uz[0] == 0, uz[T] == 1, uz'[] == 0, uz'[0] == 0}, {uz}, {t, 0,
T}, {a0, a1, a2, a3}];
but I am getting the following error in mathematica.
Dependent variables {a0,a1,a2} cannot depend on parameters {a0,a1,a2,a3}.
Which function to use in mathematica to solve the above parametric equation with the given initial conditions and get {a0, a1, a2, a3}

Creating random coefficients for linear equations in mathematica

Is there a way to assign a random value to p1, p2, p3 and p4 for the following equation?
p1 y1 + p2 y2 + p3 y3 = p4
given that y1, y2 and y3 are variables to be solved.
The easiest(?) way is to Thread a list of random values over a replacement rule:
For example:
p1 y1 + p2 y2 + p3 y3 == p4 /. Thread[{p1, p2, p3, p4} -> RandomReal[{0, 1}, 4]]
(* 0.345963 y1 + 0.333069 y2 + 0.565556 y3 == 0.643419 *)
Or, inspired by Leonid, you can use Alternatives and pattern matching:
p1 y1 + p2 y2 + p3 y3 == p4 /. p1 | p2 | p3 | p4 :> RandomReal[]
Just for fun, here's one more, similar solution:
p1 y1 + p2 y2 + p3 y3 == p4 /. s_Symbol :>
RandomReal[]/;StringMatchQ[SymbolName[s], "p"~~DigitCharacter]
Where you could replace DigitCharacter with NumberString if you want it to match more than just p0, p1, ..., p9. Of course, for large expressions, the above won't be particularly efficient...
The other answers are good, but if you do a lot of this sort of thing, I recommend naming your variables and coefficients in a more systematic way. This will not only allow you to write a much simpler rule, it will also make for much simpler changes when it's time to go from 3 equations to 4. For example:
In[1]:= vars = Array[y, 3]
Out[1]= {y[1], y[2], y[3]}
In[2]:= coeffs = Array[p, 4]
Out[2]= {p[1], p[2], p[3], p[4]}
You can be a little fancy when you make your equation:
In[3]:= vars . Most[coeffs] == Last[coeffs]
Out[3]= p[1] y[1] + p[2] y[2] + p[3] y[3] == p[4]
Substituting random numbers for the coefficients is now one one very basic rule:
In[4]:= sub = eqn /. p[_] :> RandomReal[]
Out[4]= 0.281517 y[1] + 0.089162 y[2] + 0.0860836 y[3] == 0.915208
The rule at the end could also be written _p :> RandomReal[], if you prefer. You don't have to type much to solve it, either.
In[5]:= Reduce[sub]
Out[5]= y[1] == 3.25099 - 0.31672 y[2] - 0.305785 y[3]
As Andrew Walker said, you use Reduce to find all the solutions, instead of just some of them. You can wrap this up in a function which paramerizes the number of variables like so:
In[6]:= reduceRandomEquation[n_Integer] :=
With[{vars = Array[y, n], coeffs = Array[p, n+1]},
Reduce[vars . Most[coeffs]]
In[7]:= reduceRandomEquation[4]
Out[7]= y[1] == 2.13547 - 0.532422 y[2] - 0.124029 y[3] - 2.48944 y[4]
If you need solutions with values substituted in, one possible way to do this is:
f[y1_, y2_, y3_] := p1 y1 + p2 y2 + p3 y3 - p4
g = f[y1, y2, y3] /. p1 -> RandomReal[] /. p2 -> RandomReal[] /.
p3 -> RandomReal[] /. p4 -> RandomReal[]
Reduce[g == 0, {y1}]
Reduce[g == 0, {y2}]
Reduce[g == 0, {y3}]
If all you need is the solution to the equations:
f[y1_, y2_, y3_] := p1 y1 + p2 y2 + p3 y3 - p4
g = f[y1, y2, y3]
Solve[g == 0, {y1}]
Solve[g == 0, {y2}]
Solve[g == 0, {y3}]
If you can live without the symbolic coefficient names p1 et al, then you might generate as below. We take a variable list, and number of equations, and a range for the coefficients and rhs vector.
In[80]:= randomLinearEquations[vars_, n_, crange_] :=
Thread[RandomReal[crange, {n, Length[vars]}].vars ==
RandomReal[crange, n]]
In[81]:= randomLinearEquations[{x, y, z}, 2, {-10, 10}]
Out[81]= {7.72377 x - 4.18397 y - 4.58168 z == -7.78991, -1.13697 x +
5.67126 y + 7.47534 z == -6.11561}
It is straightforward to obtain variants such as integer coefficients, different ranges for matrix and rhs, etc.
Daniel Lichtblau
Another way:
dim = 3;
eq = Array[p, dim].Array[y, dim] == p[dim + 1];
Evaluate#Array[p, dim + 1] = RandomInteger[10, dim + 1]
Solve[eq, Array[y, dim]]

How can I plot a function defined on the unit simplex in Mathematica?

I am trying to plot a function in Mathematica that is defined over the unit simplex. To take a random example, suppose I want to plot sin(x1*x2*x3) over all x1, x2, x3 such that x1, x2, x3 >= 0 and x1 + x2 + x3 = 1.
Is there a neat way of doing so, other than the obvious way of writing something like
Plot3D[If[x+y<=1,Sin[x y(1-x-y)]],{x,0,1},{y,0,1}]
?
What I want, ideally, is a way of plotting only over the simplex. I found the website http://octavia.zoology.washington.edu/Mathematica/ which has an old package, but it doesn't work on my up-to-date version of Mathematica.
If you want to get symmetric looking plots like in that package you linked, you need to figure out rotation matrix that puts the simplex into x/y plane. You can use this function below. It's kind of long because I left in the calculations to figure out simplex centering. Ironically, transformation for 4d simplex plot is much simpler. Modify e variable to get different margin
simplexPlot[func_, plotFunc_] :=
Module[{A, B, p2r, r2p, p1, p2, p3, e, x1, x2, w, h, marg, y1, y2,
valid},
A = Sqrt[2/3] {Cos[#], Sin[#], Sqrt[1/2]} & /#
Table[Pi/2 + 2 Pi/3 + 2 k Pi/3, {k, 0, 2}] // Transpose;
B = Inverse[A];
(* map 3d probability vector into 2d vector *)
p2r[{x_, y_, z_}] := Most[A.{x, y, z}];
(* map 2d vector in 3d probability vector *)
r2p[{u_, v_}] := B.{u, v, Sqrt[1/3]};
(* Bounds to center the simplex *)
{p1, p2, p3} = Transpose[A];
(* extra padding to use *)
e = 1/20;
x1 = First[p1] - e/2;
x2 = First[p2] + e/2;
w = x2 - x1;
h = p3[[2]] - p2[[2]];
marg = (w - h + e)/2;
y1 = p2[[2]] - marg;
y2 = p3[[2]] + marg;
valid =
Function[{x, y}, Min[r2p[{x, y}]] >= 0 && Max[r2p[{x, y}]] <= 1];
plotFunc[func ## r2p[{x, y}], {x, x1, x2}, {y, y1, y2},
RegionFunction -> valid]
]
Here's how to use it
simplexPlot[Sin[#1 #2 #3] &, Plot3D]
(source: yaroslavvb.com)
simplexPlot[Sin[#1 #2 #3] &, DensityPlot]
(source: yaroslavvb.com)
If you want to see domain in the original coordinate system, you could rotate the plot back to the simplex
t = AffineTransform[{{{-(1/Sqrt[2]), -(1/Sqrt[6]), 1/Sqrt[3]}, {1/
Sqrt[2], -(1/Sqrt[6]), 1/Sqrt[3]}, {0, Sqrt[2/3], 1/Sqrt[
3]}}, {1/3, 1/3, 1/3}}];
graphics = simplexPlot[5 Sin[#1 #2 #3] &, Plot3D];
shape = Cases[graphics, _GraphicsComplex];
Graphics3D[{Opacity[.5], GeometricTransformation[shape, t]},
Axes -> True]
(source: yaroslavvb.com)
Here's another simplex plot, using traditional 3d axes from here and MeshFunctions->{#3&}, complete code here
(source: yaroslavvb.com)
Try:
Plot3D[Sin[x y (1 - x - y)], {x, 0, 1}, {y, 0, 1 - x}]
But you can also use Piecewise and RegionFunction:
Plot3D[Piecewise[{{Sin[x y (1 - x - y)],
x >= 0 && y >= 0 && x + y <= 1}}], {x, 0, 1}, {y, 0, 1},
RegionFunction -> Function[{x, y}, x + y <= 1]]

how to solve for the unknowns given two equating polynomials in mathematica

I have, for example, the following polynomials to be equated, and I need to determine the unknowns c1, c2, c3, respectively. How can I do this automatically in mma, especially when there are many terms involved?
x+2*x^3+4*x^5==(c1+c2)*(x+2*c2*x^3)+(4-c1)*c3*x^5
Many thanks.
Edit: ideally, I want to equate the coefficients of left and right for the terms with equal exponents in x. Then solve this system of equations.
If this has to be true for all x, you could use SolveAlways (not tested)
SolveAlways[x+2*x^3+4*x^5==(c1+c2)*(x+2*c2*x^3)+(4-c1)*c3*x^5, x]
Try:
p1 = x + 2*x^3 + 4*x^5;
p2 = (c1 + c2)*(x + 2*c2*x^3) + (4 - c1)*c3*x^5;
Solve[CoefficientList[p2, x] == CoefficientList[p1, x], {c1, c2, c3}]
Out
{{c1 -> 0, c2 -> 1, c3 -> 1}}
This should do what you want even in more complicated situations.
eq = x + 2*x^3 + 4*x^5 == (c1 + c2)*(x + 2*c2*x^3) + (4 - c1)*c3*x^5;
list = CoefficientList[eq /. Equal[k__, l__] -> Plus[k, -l], x];
vars = Variables#list;
Solve[list == Table[0, {i, First#Dimensions#list}], vars]
Out[1] := {{c1 -> 0, c2 -> 1, c3 -> 1}}

Resources