Mathematica 9 is now available
Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
2006
*January
*February
*March
*April
*May
*June
*July
*August
*September
*October
*November
*December
*Archive Index
*Ask about this page
*Print this page
*Give us feedback
*Sign up for the Wolfram Insider

MathGroup Archive 2006

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

Search the Archive

Re: Simplifying equations for Mathematica

  • To: mathgroup at smc.vnet.net
  • Subject: [mg65863] Re: Simplifying equations for Mathematica
  • From: Maxim <m.r at inbox.ru>
  • Date: Wed, 19 Apr 2006 04:54:22 -0400 (EDT)
  • References: <200604160749.DAA11245@smc.vnet.net> <e22h8k$e56$1@smc.vnet.net>
  • Sender: owner-wri-mathgroup at wolfram.com

On Tue, 18 Apr 2006 11:07:00 +0000 (UTC), Daniel Lichtblau  
<danl at wolfram.com> wrote:

> Yaroslav Bulatov wrote:
>> [This post has been delayed due to email problems - moderator]
>>
>>
>> I'm trying to solve some likelihood equations, and Mathematica will not
>>
>> finish in reasonable time. I'm wondering if there is a way I can
>>
>> rewrite it so that Mathematica can do them
>>
>>
>>
>> The concrete example is
>>
>> f[t1,t2,t3,t4,t5]=Log[Exp[0]+Exp[t1]+Exp[t2]+Exp[t1+t2]+Exp[t5]+Exp[t5+t1
>> +t2]+Exp[t5+t2+t4]+Exp[t1+t2+t3+t4+t5]]
>>
>>
>>
>> The gradient of f defines a map R^5->R^5, and I need to invert that
>>
>> map. (This particular example can be solved by hand, but I'm wondering
>> about other cases of the same form)
>>
>>
>>
>> Here's the command I use to solve it (works on Mathematica 5.2 only)
>>
>> Solve[Map[Apply[Equal,#]&,Thread[{D[Log[Exp[0]+Exp[t1]+Exp[t2]+Exp[t1+t2]
>> +Exp[t5]+Exp[t5+t1+t2]+Exp[t5+t2+t4]+Exp[t1+t2+t3+t4+t5]],
>> {{t1,t2,t3,t4,t5},1}],{m1,m2,m3,m4,m5}}]],{t1,t2,t3,t4,t5}]
>>
>>
>>
>> It's been running for several days on a Pentium 2Ghz. Are there simple
>>
>> transformations I can do to help Mathematica solve it?
>
>
> One method is to make it explicitly polynomial by working, in effect,
> with "variables" Exp[t1], etc. This can be done as below. We work with
> expressions rather than equations.
>
> exprs = Map[Apply[Subtract,#]&,
>    Thread[{D[Log[Exp[0]+Exp[t1]+Exp[t2]+Exp[t1+t2]+Exp[t5]+
>    Exp[t5+t1+t2]+Exp[t5+t2+t4]+Exp[t1+t2+t3+t4+t5]],
>    {{t1,t2,t3,t4,t5},1}],{m1,m2,m3,m4,m5}}]];
>
> Below we make exponentials into variables, keeping the same names. This
> will not work if the variables appear other than in powers of  
> exponentials.
>
> exprs2 = exprs /. {Exp[a_]:>a, Exp[Plus[a__]]:>Apply[Times,a]};
> vars = {t1,t2,t3,t4,t5};
>
> This we can solve.
>
> In[75]:= Timing[soln = Solve[exprs2==0, vars];]
> Out[75]= {0.344022 Second, Null}
>
> Now take logs of results since in effect we solved for Exp[tj]'s rather
> than tj's.
>
> In[76]:= InputForm[Log[vars] /. First[soln]]
> Out[76]//InputForm=
> {Log[-(5*m1 - 3*m2 - 5*m3 + 4*m4 - m5)/(4*(-2 + m1 + m2 - m3 + m5))],
>   Log[-(3*m1 - 5*m2 - 3*m3 + 4*m4 + m5)/(4*(2 - m1 - m2 + m3 - m5))],
>   Log[-(-5*m1 + 3*m2 + 21*m3 - 12*m4 + m5)/(4*(-2 + m1 + m2 - m3 + m5))],
>   Log[-((m1 - m2 - 3*m3 + 4*m4 - m5)/(-2 + m1 + m2 - m3 + m5))],
>   Log[-(-m1 - m2 + m3 - 4*m4 + 5*m5)/(4*(-2 + m1 + m2 - m3 + m5))]}
>
>
> Daniel Lichtblau
> Wolfram Research
>

I have my doubts about this method, because the rule (Exp[a_] :> a) will  
be tried first and so it will replace E^(t1 + t2) with (t1 + t2).  
Numerical tests show that after we replace ti with Log[ti] and get rid of  
denominators one of the solutions is t1 == t2 == -1, t5 == 0. This  
suggests that the ordering of the variables can matter:

In[1]:= f[t1_, t2_, t3_, t4_, t5_] :=
   Log[Exp[0] + Exp[t1] + Exp[t2] + Exp[t1 + t2] + Exp[t5] +
     Exp[t5 + t1 + t2] + Exp[t5 + t2 + t4] + Exp[t1 + t2 + t3 + t4 + t5]]

In[2]:= Lvar = {t1, t2, t3, t4, t5};
   Lvar2 = {t4, t3, t2, t1, t5};
   Lm = {m1, m2, m3, m4, m5};
   Lexpr = D[f @@ Lvar, {Lvar}] - Lm;
   Lexpr2 = Lexpr /. Thread[Lvar -> Log[Lvar]] // Together // Numerator;

In[7]:= SetOptions[Roots, Cubics -> False, Quartics -> False];
   (Lsol = Solve[GroebnerBasis[Lexpr2, Lvar2] == 0, Lvar2] //
     Simplify) // ByteCount // Timing

Out[8]= {10.922*Second, 204216}

The last three seem to be generic solutions:

In[9]:= Lexpr /. Thread[Lvar -> Log[Lvar /. #]]& /@ Rest@ Lsol /.
     Thread[Lm -> Array[Random[Real, {-10, 10}, 20]&, Length@ Lm]] //
   MatrixQ[#, # == 0&]&

Out[9]= True

Maxim Rytin
m.r at inbox.ru



  • Prev by Date: Re: Re: unable to FullSimplify
  • Next by Date: command line question
  • Previous by thread: Re: Simplifying equations for Mathematica
  • Next by thread: Re: Re: Simplifying equations for Mathematica