MathGroup Archive 2007

[Date Index] [Thread Index] [Author Index]

Search the Archive

Re: Finding unknown parameters using Mathematica

  • To: mathgroup at smc.vnet.net
  • Subject: [mg74824] Re: Finding unknown parameters using Mathematica
  • From: "Jean-Marc Gulliet" <jeanmarc.gulliet at gmail.com>
  • Date: Fri, 6 Apr 2007 04:26:52 -0400 (EDT)
  • References: <4614D43E0200000B002AF26F@its-gw-inet57.its.rmit.edu.au>

On 4/5/07, Shafiq Ahmad <shafiq.ahmad at rmit.edu.au> wrote:
> Hi Jean-Marc,
> Thanks for your good response. I tried to run your codes but could not.
> Could you please send me again with input formate and appreciate if you
> could add comments with your codes. Looks to me that you have better
> idea than me to get values of all unknown parameters and also to get the
> value of LMN from main equaition and plot result in 3D for LMN, r1 and
> r2.
>
> Really appreciate your quick response.
> Reagrds
> Shafiq
>
>
> >>> Jean-Marc Gulliet <jeanmarc.gulliet at gmail.com> 05/04/07 5:59 AM >>>
> Shafiq Ahmad wrote:
> > Hi Danial, Andres Guzmanand and Group members,
> >
> > Thanks indeed for a good response from Danial and Andres. This is my
> > first experience to find such a cooperative group.
> >
> > I did try to solve these non-linear equations doing some
> modifications.
> > I put 2 parameters r1 and r2 equal to 1 and solved rest of the
> equations
> > for 3 parameters using FindRoot function (as mentioned by Andres).
> >
> > Below are the codes in the input form. Thanks for Danial to give me
> good
> > advice and now really easy for every one to understand codes in the
> > input formate. Next I'm trying to make these codes as generalized in
> the
> > following manner and strongly appreciate if any one can help me in
> this
> > regard.
> >
> > 1): I need to use a loop function for r1 and r2 values with an
> increment
> > of 0.1 and range for 0 to 1, it should come up with an array or list
> of
> > 10 values for b1, b2 and p.   I did try it many ways, but mathematica
> > could not accept it.

Are you sure you want 10 values only? (This request is inconsistent
with request #3.)

I have defined LMN as a function of 5 parameters/variables. The "loop"
is done by the function Table over the variables (r1 and r2, with r2 =
r1 according to what you stated above), which also returns a lists of
transformation rules for the unknown parameters (b1, b2, p). Join adds
the rules for the r1 and r2 to the results returned by FindRoot. The
last line (pts = ...) compute the corresponding values of LMN.

Note that I have assumed that the undefined function L in your code is
indeed the function LMN. Moreover, the code I wrote is almost a
literal translation of what I have understood of your requirements
into Mathematica programming language.

LMN[r1_, r2_, b1_, b2_, p_] :=
 Module[{n = Length[x1]},
 n*Log[p] + n*Log[p + 1] +
 n*Log[b1] + n*Log[r1] +
 n*Log[b2] + n*Log[r2] +
 (b1 - 1)*Sum[Log[x1[[j]]],
 {j, 1, n}] + (b2 - 1)*
 Sum[Log[x2[[j]]], {j, 1, n}] -
 (p + 2)*Sum[Log[
 1 + r1*x1[[j]]^b1 +
 r2*x2[[j]]^b2], {j, 1, n}]]
x1 = {1, 2, 3, 4};
x2 = {1.7, 3.8, 4.9, 4.6};
sols = Table[Block[{r2, b1, b2, p,
 Eqn1, Eqn2, Eqn3},
 r2 = r1; Eqn1 =
  D[LMN[r1, r2, b1, b2, p],
 b1] == 0; Eqn2 =
  D[LMN[r1, r2, b1, b2, p],
 b2] == 0; Eqn3 =
  D[LMN[r1, r2, b1, b2, p],
 p] == 0; Join[{a -> r1,
  b -> r2}, FindRoot[
 {Eqn1, Eqn2, Eqn3},
 {b1, 10}, {b2, 10},
 {p, 10}]]], {r1, 0.1, 1,
 0.1}] /. a -> r1 /. b -> r2
pts = LMN[r1, r2, b1, b2, p] /. sols

> > 2): After having values for all 5 parameters (r1,r2,b1,b2 and p), I
> need
> > to put all these values in the main equation " LMN" to get another
> list
> > or array for LMN values . Individually I used all parameter values, I
> > got LMN value but mathematica don't accept if I give all values in the
> > form of list or array and do it all one time.
> >
> > 3): After having LMN values, I would like plot a 3D plot or 3D contour
> > plot / surface plot with array / or list values for r1,r2 and LMN.

If you have a one-dimensional list of 10 values you cannot use any of
the contour/density/surface plots. Below is a version of the code
returning a square array (10 by 10) that can be used with, say,
ListContourPlot.

LMN[r1_, r2_, b1_, b2_, p_] :=
 Module[{n = Length[x1]},
 n*Log[p] + n*Log[p + 1] +
 n*Log[b1] + n*Log[r1] +
 n*Log[b2] + n*Log[r2] +
 (b1 - 1)*Sum[Log[x1[[j]]],
 {j, 1, n}] + (b2 - 1)*
 Sum[Log[x2[[j]]], {j, 1, n}] -
 (p + 2)*Sum[Log[
 1 + r1*x1[[j]]^b1 +
 r2*x2[[j]]^b2], {j, 1, n}]]
x1 = {1, 2, 3, 4};
x2 = {1.7, 3.8, 4.9, 4.6};
 sols =
 Table[Block[{b1, b2, p, Eqn1,
 Eqn2, Eqn3},
  Eqn1 = D[LMN[r1, r2, b1, b2,
 p], b1] == 0;
  Eqn2 = D[LMN[r1, r2, b1,
 b2, p], b2] == 0;
  Eqn3 = D[LMN[r1, r2, b1,
 b2, p], p] == 0;
 Join[{a -> r1, b -> r2},
  FindRoot[{Eqn1, Eqn2,
 Eqn3}, {b1, 10},
 {b2, 10}, {p, 10}]]],
 {r1, 0.1, 1, 0.1},
 {r2, 0.1, 1, 0.1}] /.
 a -> r1 /. b -> r2;
pts = LMN[r1, r2, b1, b2, p] /.
 sols;
ListContourPlot[pts];

Regards,
Jean-Marc

> >  Strongly appreciate if some one can share his/her thoughts.
> >
> > Regards
> > Shafiq
> >
> > ===================================================
> >
> > n = 4
> >
> > x1 = {1, 2, 3, 4}
> > x2 = {1.7, 3.8, 4.9, 4.6}
> >
> > r1 = 1
> > r2 = 1
> >
> > LMN = n*Log[p] + n*Log[p + 1] + n*Log[b1] + n*Log[r1] + n*Log[b2] +
> > n*Log[r2] +
> >    (b1 - 1)*Sum[Log[x1[[j]]], {j, 1, n}] +
> >    (b2 - 1)*Sum[Log[x2[[j]]], {j, 1, n}] -
> >    (p + 2)*Sum[Log[1 + r1*x1[[j]]^b1 + r2*x2[[j]]^b2], {j, 1, n}]
> >
> > Eqn1 = D[L, b1] == 0
> >
> > Eqn2 = D[L, b2] == 0
> >
> > Eqn3 = D[L, p] == 0
> >
> > FindRoot[{Eqn1, Eqn2, Eqn3}, {b1, 10}, {b2, 10}, {p, 10}]
> >
> > ================================================
> > Regards
> > Shafiq
> [snip]
>
> Please, find hereunder an example of what you could do to achieve what
> you want, assuming that I have correctly understood your request. (Note
> that the following code is not an example of good programming practice.
> Quick and dirty, but it works!)
>
> In[1]:=
> LMN[r1_, r2_, b1_, b2_, p_] :=
>    Module[{n = Length[x1]}, n*Log[p] + n*Log[p + 1] +
>      n*Log[b1] + n*Log[r1] + n*Log[b2] + n*Log[r2] +
>      (b1 - 1)*Sum[Log[x1[[j]]], {j, 1, n}] +
>      (b2 - 1)*Sum[Log[x2[[j]]], {j, 1, n}] -
>      (p + 2)*Sum[Log[1 + r1*x1[[j]]^b1 +
>          r2*x2[[j]]^b2], {j, 1, n}]]
>
> In[2]:=
> x1 = {1, 2, 3, 4};
> x2 = {1.7, 3.8, 4.9, 4.6};
>
> In[4]:=
> sols = Table[Block[{r2, b1, b2, p, Eqn1, Eqn2, Eqn3},
>        r2 = r1; Eqn1 = D[LMN[r1, r2, b1, b2, p], b1] ==
>           0; Eqn2 = D[LMN[r1, r2, b1, b2, p], b2] == 0;
>         Eqn3 = D[LMN[r1, r2, b1, b2, p], p] == 0;
>         Join[{a -> r1, b -> r2}, FindRoot[
>           {Eqn1, Eqn2, Eqn3}, {b1, 10}, {b2, 10},
>           {p, 10}]]], {r1, 0.1, 1, 0.1}] /. a -> r1 /.
>     b -> r2
>
> Out[4]=
> {{r1 -> 0.1, r2 -> 0.1, b1 -> 5.341935448717984,
>     b2 -> 3.9436875174176804, p -> 0.3721885234758986},
>    {r1 -> 0.2, r2 -> 0.2, b1 -> 5.534042581697728,
>     b2 -> 4.045832415596042, p -> 0.2940686067033152},
>    {r1 -> 0.30000000000000004,
>     r2 -> 0.30000000000000004, b1 -> 5.626397092321994,
>     b2 -> 4.095035940496871, p -> 0.26139996011190647},
>    {r1 -> 0.4, r2 -> 0.4, b1 -> 5.697719904063341,
>     b2 -> 4.136114771126181, p -> 0.24147559059244234},
>    {r1 -> 0.5, r2 -> 0.5, b1 -> 5.7580442518190855,
>     b2 -> 4.172731896134758, p -> 0.22753002319002713},
>    {r1 -> 0.6000000000000001, r2 -> 0.6000000000000001,
>     b1 -> 5.810601737463024, b2 -> 4.20572325658841,
>     p -> 0.2170152505036831},
>    {r1 -> 0.7000000000000001, r2 -> 0.7000000000000001,
>     b1 -> 5.8571172402134515, b2 -> 4.235590112750038,
>     p -> 0.20870033683174416}, {r1 -> 0.8, r2 -> 0.8,
>     b1 -> 5.898742384194647, b2 -> 4.262751009402106,
>     p -> 0.20190091294950313}, {r1 -> 0.9, r2 -> 0.9,
>     b1 -> 5.9363209375865305, b2 -> 4.287567369366186,
>     p -> 0.19619991348677382}, {r1 -> 1., r2 -> 1.,
>     b1 -> 5.970499008585786, b2 -> 4.310347981142145,
>     p -> 0.1913259981578475}}
>
> In[5]:=
> pts = LMN[r1, r2, b1, b2, p] /. sols
>
> Out[5]=
> {-12.86601076530539, -13.020764326190708,
>    -13.17718328097974, -13.311047643795543,
>    -13.424702323411111, -13.522321810909304,
>    -13.607333751744086, -13.682314918879541,
>    -13.749187133239175, -13.809399854995021}
>
> In[6]:=
> sols = Table[Block[{b1, b2, p, Eqn1, Eqn2, Eqn3},
>         Eqn1 = D[LMN[r1, r2, b1, b2, p], b1] == 0;
>          Eqn2 = D[LMN[r1, r2, b1, b2, p], b2] == 0;
>          Eqn3 = D[LMN[r1, r2, b1, b2, p], p] == 0;
>          Join[{a -> r1, b -> r2}, FindRoot[
>            {Eqn1, Eqn2, Eqn3}, {b1, 10}, {b2, 10},
>            {p, 10}]]], {r1, 0.1, 1, 0.1},
>        {r2, 0.1, 1, 0.1}] /. a -> r1 /. b -> r2;
> pts = LMN[r1, r2, b1, b2, p] /. sols;
> ListContourPlot[pts];
>
> [...graphic deleted...]
>
> Hope this helps,
> Jean-Marc
>
>


  • Prev by Date: Re: (Not trivial) Definite Integration of a rational function
  • Next by Date: Re: (Not trivial) Definite Integration of a rational function
  • Previous by thread: Re: Finding unknown parameters using Mathematica
  • Next by thread: Re: Re: Finding unknown parameters using Mathematica