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: [mg74784] Re: Finding unknown parameters using Mathematica
  • From: Jean-Marc Gulliet <jeanmarc.gulliet at gmail.com>
  • Date: Thu, 5 Apr 2007 04:09:13 -0400 (EDT)
  • Organization: The Open University, Milton Keynes, UK
  • References: <euvmhf$e3v$1@smc.vnet.net>

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.
> 
> 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.
> 
>  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: how to get the area of circles
  • Next by Date: Fractals and Time Series Analysis by R.J. Korsan appearing in TMJ volume 3, issue 1
  • Previous by thread: Re: Finding unknown parameters using Mathematica
  • Next by thread: Re: Finding unknown parameters using Mathematica