3
$\begingroup$

Writing:

f[x_] := Piecewise[{{6.83 - 12.66 x + 3.88 x^2, 2.59 < x < 3.10}, 
                    {188.44 - 61.81 x + 4.88 x^2, 3.73 < x < 5.1}, 
                    {51.06 - 79.00 x + 20.25 x^2, 0 < x < 0.82}, 
                    {48.51 - 76.87 x + 20.25 x^2, 3.10 < x < 3.6}, 
                    {671.66 - 285.97 x + 30.25 x^2, 3.6 < x < 3.73}, 
                    {0, True}}]

g[x_] := Piecewise[{{6.83 - 12.66 x + 3.88 x^2, 0.68 < x < 0.82}, 
                    {51.06 - 79.00 x + 20.25 x^2, 1.2 < x < 3.08}, 
                    {48.51 - 76.88 x + 20.25 x^2, 0.82 < x < 1.2}, 
                    {594.35 - 270.81 x + 30.25 x^2, 3.85 < x < 5.1}, 
                    {0, True}}]

Plot[{f[x], g[x]}, {x, 0, 5.1}, PlotStyle -> {Red, Gray}]

I get:

enter image description here

So far everything is ok.

Now I would like to get the following plot (blue color) translated:

enter image description here

where in yellow I have indicated the characteristic points in which we must translate the points of the plots of f and g by t = 0.24.

I'm looking for a concise way to track the blue plot in an automated way by knowing f, g and t.


@kglr: thank you for your precious contribution!

Could you apply your technique in the following way?

enter image description here


@kglr: thanks again for the immense help, it is precisely what interests me!

Unfortunately, though, if I write:

f[x_] := Piecewise[{{12.09 x + 4.88 x^2, 0 < x < 1.37}, 
                    {-22.58 x + 30.25 x^2, 1.37 < x < 1.5}, 
                    {183.14 - 129.67 x + 20.25 x^2, 1.5 < x < 2.00}, 
                    {43.03 - 26.86 x + 3.88 x^2, 2.00 < x < 2.51}, 
                    {174.86 - 127.55 x + 20.25 x^2, 4.28 < x < 5.1}, 
                    {0, True}}]

g[x_] := Piecewise[{{-37.74 x + 30.25 x^2, 0 < x < 1.25}, 
                    {174.86 - 127.55 x + 20.25 x^2, 2.02 < x < 3.90}, 
                    {183.14 - 129.67 x + 20.25 x^2, 3.90 < x < 4.28}, 
                    {43.03 - 26.86 x + 3.88 x^2, 4.28 < x < 4.42}, 
                    {0, True}}]

I get:

enter image description here

where the horizontal piece on the right is missing and the blue color is on the contrary. If you could solve it it would be great!

$\endgroup$
  • 1
    $\begingroup$ The gray graph seems to be translated away from the minima (translating the segment up to the adjacent maxima) and the red graph translated away from the maxima (translating the segment up to the adjacent minima). Does that seem accurate? What's supposed to happen if two translated segments overlap? $\endgroup$ – Michael E2 Aug 16 '18 at 12:01
  • $\begingroup$ @MichaelE2: Thanks for the intervention. In the problem I should solve t is chosen in such a way as to never have overlaps. The graph of the attempt I got is not accurate at all, but for now I have no better ideas to achieve the goal. $\endgroup$ – TeM Aug 16 '18 at 12:13
  • 1
    $\begingroup$ So the translated parts are always separated by a horizontal segment on the x-axis (f[x] == 0) of length > 2t = 2 * 0.24? (Just how specific or general a problem is helps to formulate a good solution.) $\endgroup$ – Michael E2 Aug 16 '18 at 12:20
  • $\begingroup$ In fact, another typical case could be this: tinyurl.com/yc9wwwrr But for now I would be content to solve the first case, it seems less complicated. $\endgroup$ – TeM Aug 16 '18 at 12:49
3
$\begingroup$

You can post-process the Plot outputs to translate the graphics primitives based on the sign of the derivative:

ClearAll[tr, postprocess]
tr[f_, t_] := TranslationTransform[{-t Sign[f'[#[[1]]]], 0}][#] & ;
postprocess[fill_: False][o : OptionsPattern[]] := Show[Module[{tpts, pr = PlotRange @ #,
  pts = SortBy[Join @@ Cases[# /. Line[{{_, y_} ..}] :> {}, Line[x_] :> x, ∞], First]}, 
 tpts = Join[{{pr[[1, 1]], #[[1, 2]]}}, #, {{pr[[1, 2]], #[[-1, 2]]}}] & @
    DeleteDuplicates[tr[#2, #3] /@ pts]; 
 Graphics[{#4, Thick, Line @ tpts, fill /. {False -> {}, 
     True -> {Opacity[.3], 
      Polygon[Join[{{tpts[[1, 1]], 0}}, tpts, {{tpts[[-1, 1]], 0}}]]}}},
    Options[#]]] & @@@ #, PlotRange -> All, o] &; 

Examples:

{plot1, plot2} = Plot[#[x], {x, 0, 5.1}, PlotStyle -> #2, BaseStyle -> Thick] & @@@ 
   Transpose[{{f, g}, {Red, Gray}}];

t = .24;
Show[postprocess[][AxesOrigin -> {0, -30}, Frame -> True, ImageSize -> 600]@
  {{plot1, f, t, Directive[Blue, Dashed]}, {plot2, g, -t, Green}}, 
  plot1, plot2]

enter image description here

postprocess[True][Frame -> True, ImageSize -> 600]@
 {{plot1, f, t, Directive[Blue, Dashed]}, {plot2, g, -t, Green}}

enter image description here

$\endgroup$
  • $\begingroup$ Thank you for your precious contribution! Could you apply your technique also in the added way in the request? $\endgroup$ – TeM Aug 17 '18 at 7:40
  • 1
    $\begingroup$ @TeM, i will post an update if I figure out a clean way to handle the fillings. $\endgroup$ – kglr Aug 17 '18 at 8:08
  • 1
    $\begingroup$ @TeM, please see the new version. $\endgroup$ – kglr Aug 17 '18 at 9:00
  • $\begingroup$ I really do not have words, it's fabulous! If you could only (but it is not vital) prolong the green hatching up to zero would be perfect! $\endgroup$ – TeM Aug 17 '18 at 9:07
  • 1
    $\begingroup$ @TeM, updated with a fix. $\endgroup$ – kglr Aug 17 '18 at 10:00
2
$\begingroup$

You can use the functions themselves and build a new function from them, for example:

    f[x_] := Piecewise[{{6.83 - 12.66 x + 3.88 x^2, 
        2.59 < x < 3.10}, {188.44 - 61.81 x + 4.88 x^2, 
        3.73 < x < 5.1}, {51.06 - 79.00 x + 20.25 x^2, 
        0 <= x < 0.82}, {48.51 - 76.87 x + 20.25 x^2, 
        3.10 < x <= 3.6}, {671.66 - 285.97 x + 30.25 x^2, 
        3.6 < x < 3.73}, {0, True}}]
    fT[x_] := 
     Piecewise[{{f[0], 
        0 <= x < .24}, {f[x - .24], .24 < x < 2}, {f[x + .24], 
        2 < x < 3.6 - .24}, {f[3.6], 
        3.6 - .24 < x < 3.6 + .24}, {f[x - .24], 3.6 + .24 < x < 5.1
        }, {0, True}}]
    Plot[{fT[x], f[x]}, {x, 0, 5.1}]

fig1

We will think about automation, but for now we will show the second case

g[x_] := Piecewise[{{6.83 - 12.66 x + 3.88 x^2, 
    0.68 < x < 0.82}, {51.06 - 79.00 x + 20.25 x^2, 
    1.2 < x < 3.08}, {48.51 - 76.88 x + 20.25 x^2, 
    0.82 < x < 1.2}, {594.35 - 270.81 x + 30.25 x^2, 
    3.85 < x < 5.1}, {0, True}}]
gT[x_] := 
 Piecewise[{{g[x + .24], 0 < x < 1.95062 - .24}, {g[x - .24], 
    1.95062 + .24 < x < 3.5}, {g[1.95062], 
    1.95062 - .24 < x < 1.95062 + .24}, {g[x + .24], 
    3.5 < x < 4.4762 - .24}, {g[4.4762], 
    4.4762 - .24 < x < 4.4762 + .24}, {g[x - .24], 
    4.4762 + .24 < x < 5.1}, {0, True}}]
Plot[{gT[x], g[x]}, {x, 0, 5.1}]

fig2

In the second example, we used data

In[26]:= FindMinimum[g[x], {x, 2}]

Out[26]= {-25.9894, {x -> 1.95062}}

In[28]:= FindMinimum[{g[x], 4 <= x <= 5}, {x, 4.5}]

Out[28]= {-11.7496, {x -> 4.4762}}
$\endgroup$
  • $\begingroup$ Thank you so much, very interesting! On the other hand, I will have to think about it a little, because the functions shown have been obtained through PiecewiseExpand, so it's still a bit difficult for me to understand how to automate everything. $\endgroup$ – TeM Aug 16 '18 at 15:57

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.