0
$\begingroup$

I have 4 maps defined on a plane, i.e. on $\mathbb{R}^{2}$. Let's call them $F,G,H,J$. Let $(s,t) \in \mathbb{R}^{2}$. Define $F(s,t) = (f_{1}(s,t), f_{2}(s,t)).$ Likewise, in components, write

$$ G(s,t) = (g_{1}(s,t), g_{2}(s,t))$$ $$H(s,t) = (h_{1}(s,t), h_{2}(s,t))$$ $$J(s,t) = (j_{1}(s,t), j_{2}(s,t))$$

The specific form of these maps is in the code given below.

Let's take a point $(-\pi + \pi/n + x(1-n), \pi/n +x)$, where $n>4$ is an integer and $x$ a small parameter. I am interested in evaluating partial derivatives (up to third order partial derivatives) of the composition

$$A(s,t) = J \circ H \circ G \circ F(s,t)$$

at the point $(-\pi + \pi/n + x(1-n), \pi/n +x)$. So I'm finding $\frac{\partial A}{\partial s}$, etc. Then, I would like to expand the result in series in $x$ up to first order, at least, and simplify the result, to make use of it in further calculations.

However, the maps contain trigonometric functions. When I put them in Mathematica, it struggles to evaluate the series and simplify even the first order partial derivative - I suspect mainly because it cannot automatically recognise simple trig identities.and I am stuck.

Please, any help to modify or simplify my expressions to enable Mathematica to handle them efficiently? The code I use is below. The last expression, "a[x]" is just not being evaluated.

$Assumptions = n > 4 && n \[Element] Integers

R[x] := (Cos[Pi + n*x] + Cos[x + Pi/n])/Cos[Pi + n*x]

f1[s_, t_] := R[x] (2*Pi  - (f2[s, t] + t + s + 2 (n - 1) t)) + Pi

f2[s_, t_] := ArcCos[(-Cos[t] - (1 - R[x]) Cos[t + s + 2 (n - 1) t])/R[x]]

g1[s_, t_] := ArcCos[-R[x]*Cos[f2[s, t]] - (1 - R[x])*Cos[f2[s, t] - (f1[s, t] - Pi)/R[x]]]

g2[s_, t_] := f2[s, t] + g1[s, t] - (f1[s, t] - Pi)/R[x]

h1[s_, t_] := R[x] (2*Pi  - (h2[s, t] + g1[s, t] + g2[s, t] + 2 (n - 1) g1[s, t])) + Pi

h2[s_, t_] := ArcCos[(-Cos[g1[s, t]] - (1 - R[x]) Cos[g1[s, t] + g2[s, t] + 2 (n - 1) g1[s, t]])/R[x]]

j1[s_, t_] := ArcCos[-R[x]*Cos[h2[s, t]] - (1 - R[x])*Cos[h2[s, t] - (h1[s, t] - Pi)/R[x]]]

j2[s_, t_] := h2[s, t] + j1[s, t] - (h1[s, t] - Pi)/R[x]

a[x] := Series[Derivative[1, 0][j2][-Pi + Pi/n + x (1 - n), Pi/n + x], {x, 0, 1}]
$\endgroup$
  • $\begingroup$ Welcome to Mathematica.SE! I suggest the following: 1) As you receive help, try to give it too, by answering questions in your area of expertise. 2) Take the tour! 3) When you see good questions and answers, vote them up by clicking the gray triangles, because the credibility of the system is based on the reputation gained by users sharing their knowledge. Also, please remember to accept the answer, if any, that solves your problem, by clicking the checkmark sign! $\endgroup$ – Michael E2 Mar 8 '16 at 23:38
  • $\begingroup$ In the text you have F(s,t)=(f1(s,t), f2(s,t)). By that do you mean that converted to Mathematica F[s,t] would return the list {f1[s,t], f2[s,t]}? I am also uncertain as to what the circle between J, H, G, and F(s,t) represents. $\endgroup$ – Jack LaVigne Mar 9 '16 at 0:56
  • $\begingroup$ By $F(s,t) = (f1,f2)$ I mean that $F$ has two components, as it's vector-valued function: $F: \mathbb{R}^{2} \mapsto \mathbb{R}^{2}$. In Mathematica code, I write each component separately, as above (without using lists). The circle means composition of functions, i.e. I have $JHGF(s,t)$: so $G$ acts on $F(s,t)$, then $H$ acts on that output, and so on. @JackLaVigne $\endgroup$ – Alex Mar 9 '16 at 1:05
1
$\begingroup$

I copied your functions (see above) and assumptions and made R a normal function of x and n.

$Assumptions = n > 4 && n \[Element] Integers
R[x_, n_] := (Cos[Pi + n*x] + Cos[x + Pi/n])/Cos[Pi + n*x]

f1[s_, t_] := R[x, n] (2*Pi - (f2[s, t] + t + s + 2 (n - 1) t)) + Pi

f2[s_, t_] := 
 ArcCos[(-Cos[t] - (1 - R[x, n]) Cos[t + s + 2 (n - 1) t])/R[x, n]]

g1[s_, t_] := 
 ArcCos[-R[x, n]*Cos[f2[s, t]] - (1 - R[x, n])*
    Cos[f2[s, t] - (f1[s, t] - Pi)/R[x, n]]]

g2[s_, t_] := f2[s, t] + g1[s, t] - (f1[s, t] - Pi)/R[x, n]

h1[s_, t_] := 
 R[x, n] (2*
      Pi - (h2[s, t] + g1[s, t] + g2[s, t] + 2 (n - 1) g1[s, t])) + Pi

h2[s_, t_] := 
 ArcCos[(-Cos[g1[s, t]] - (1 - R[x, n]) Cos[
       g1[s, t] + g2[s, t] + 2 (n - 1) g1[s, t]])/R[x, n]]

j1[s_, t_] := 
 ArcCos[-R[x, n]*Cos[h2[s, t]] - (1 - R[x, n])*
    Cos[h2[s, t] - (h1[s, t] - Pi)/R[x, n]]]

j2[s_, t_] := h2[s, t] + j1[s, t] - (h1[s, t] - Pi)/R[x, n]

Here is what R[x,n] looks like for various values of n.

Manipulate[
 Plot[Evaluate[R[x, n]], {x, -\[Pi]/2, \[Pi]/2}, PlotStyle -> Black],
 {{n, 4}, 4, 9, 1}
 ]

Mathematica graphics

It is clear that one has to stay close to zero in order to avoid discontinuities.

You assigned s and t to be functions of x and n when you computed the derivative at the point {-Pi + Pi/n + x (1 - n), Pi/n + x}.

I made the derivative of the second parts of A[s,t] (i.e., j2[s,t]) at the point {-Pi + Pi/n + x (1 - n), Pi/n + x} a function of x and n.

dAx[x_, n_] := 
  Evaluate[Derivative[1, 0][j2][-Pi + Pi/n + x (1 - n), Pi/n + x]]

This will also have discontinuties.

This is what it looks like where the scale has been adjusted to magnify the value around zero.

Manipulate[
 Plot[Evaluate[dAx[x, n]], {x, -\[Pi]/2^j, \[Pi]/2^j}, 
  PlotStyle -> Black],
 {{n, 4}, 4, 9, 1},
 {{j, 8}, 4, 12, 1}
 ]

Mathematica graphics

In order to get a series I used an explicit value of n.

dSx=Series[Evaluate[dAx[-Pi + Pi/4 + x (1 - 4), Pi/4 + x]], {x, 0, 3}]

You get warning messages but eventually it will produce a result.

Normal[dSx] // N
(* -0.137192 + 314.455 x - 31299.9 x^2 + 105330. x^3 *)

The result is very very poor compared to the original data.

Show[
 Plot[Evaluate[dAx[x, 4]], {x, -0.01, 0.01}, PlotStyle -> Black],
 Plot[-0.137192` + 314.455` x - 31299.9` x^2 + 
   105330.` x^3, {x, -0.01, 0.01}, PlotStyle -> Red],
 PlotRange -> {{-0.01, 0.01}, {-2, 1}}
 ]

Mathematica graphics

I think you might have to make a table of data and use FindFormula rather than Series in order to get better results (although to be fair, I only tried a cubic for Series).

data = Table[{x, dAx[x, 4]}, {x, -0.1, 0.1, 0.1/100}];

and then

fit = FindFormula[data, x]
(* 1. - 2.74485 x - 1163.38 x^2 + 2193.77 x^3 + 54516.9 x^4 - 
 1.03608*10^6 x^5 + 1.14378*10^7 x^6 - 1.12698*10^8 x^7 + 
 9.76945*10^8 x^8 - 4.52158*10^9 x^9 + 2.33234*10^10 x^10 - 
 1.2622*10^12 x^11 + 1.18997*10^13 x^12 + 1.4307*10^14 x^13 - 
 1.41042*10^15 x^14 - 2.03368*10^16 x^15 + 1.76293*10^17 x^16 + 
 1.23261*10^18 x^17 - 1.01487*10^19 x^18 - 4.16959*10^19 x^19 + 
 3.17986*10^20 x^20 *)

Here is the comparison

Show[
 Plot[Evaluate[dAx[x, 4]], {x, -0.1, 0.1}, PlotStyle -> Black],
 Plot[fit, {x, -0.1, 0.1}, PlotStyle -> {Red,Dashed}],
 PlotRange -> {{-0.1, 0.1}, {-2, 4}}
 ]

Mathematica graphics

$\endgroup$
  • $\begingroup$ Hi Jack, thank you very much for these details. However, what I really need is to be able to compute a whole bunch of partial derivatives like $\frac{\partial A}{\partial s}$, $\frac{\partial^{2} A}{\partial s^{2}}$, $\frac {\partial A}{\partial t}$, and so on, explicitly as a series in terms of $x$, for general $n$. The reason why I need a closed form expression is because intend to plug in these values of partial derivatives, for any $n$, into yet ANOTHER formula. @ $\endgroup$ – Alex Mar 9 '16 at 16:37
  • $\begingroup$ So for example, I take $f_{1}$ and expand in series of $x$ its partial derivatives at $(-\pi + \pi/n + x(1-n), \pi/n +x)$. Mathematica can handle that, and it can simplify the resulting expression into something simple. But when I ask to do the same for, say, $j_{1}$, it struggles to simplify, or even compute the expressions. In the best case scenario, I'd just get a HUGE (thousands of characters) trigonometric expression; and when I ask Mathematics to simplify that, it hangs up. @Jack $\endgroup$ – Alex Mar 9 '16 at 16:48
  • $\begingroup$ I was unable to get the Series to run when using n rather than an explicit integer. $\endgroup$ – Jack LaVigne Mar 9 '16 at 20:15

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.