Построение стрелок по краям кривой

Question

Вдохновленный этим вопросом в ask.sagemath, каков лучший способ добавления стрелок в конец кривых, полученных с помощью Plot, ContourPlot и т. Д..?Это типы графиков, которые можно увидеть в старшей школе. Это означает, что кривая продолжается в конце страницы.

После некоторых поисков я не смог найти встроенный способ или современный пакет для выполнения.этот.(Существует ArrowExtended , но он довольно старый).

Решение, данное в вопросе ask.sagemath, основано на знании функции и ее конечных точек и (возможно) способности принятьпроизводные.Его перевод на Mathematica:

f[x_] := Cos[12 x^2]; xmin = -1; xmax = 1; small = .01; 
Plot[f[x],{x,xmin,xmax}, PlotLabel -> y==f[x], AxesLabel->{x,y},
  Epilog->{Blue,
    Arrow[{{xmin,f[xmin]},{xmin-small,f[xmin-small]}}],
    Arrow[{{xmax,f[xmax]},{xmax+small,f[xmax+small]}}]
  }]

Альтернативный метод состоит в простой замене Line[] объектов, сгенерированных на Plot[], Arrow[].Например,

Plot[{x^2, Sin[10 x], UnitStep[x]}, {x, -1, 1}, 
  PlotStyle -> {Red, Green, {Thick, Blue}},
  (*AxesStyle -> Arrowheads[.03],*) PlotRange -> All] /. 
 Line[x__] :> Sequence[Arrowheads[{-.04, .04}], Arrow[x]]

Но проблема заключается в том, что любые разрывы в строках генерируют наконечники стрелок там, где они вам не нужны (это часто можно исправить с помощью параметраExclusions -> None).Что еще более важно, этот подход безнадежен с CountourPlot с.Например, попробуйте

ContourPlot[x^2 + y^3 == 1, {x, -2, 2}, {y, -2, 1}] /. 
  Line[x__] :> Sequence[Arrowheads[{-.04, .04}], Arrow[x]]

(проблемы в вышеприведенном случае можно исправить с помощью правила, например, {a___, l1_Line, l2_Line, b___} :> {a, Line[Join[l2[[1]], l1[[1]]]], b} или с помощью соответствующих односторонних стрелок.).

Как вы можете видеть, ни один из вышеперечисленных (быстрые хаки) не является особенно надежным или гибким.Кто-нибудь знает такой подход?

Answer 1

Следующее, кажется, работает, сначала сортируя сегменты:

f[x_] := {E^-x^2, Sin[10 x], Sign[x], Tan[x], UnitBox[x], 
             IntegerPart[x], Gamma[x],
             Piecewise[{{x^2, x < 0}, {x, x > 0}}], {x, x^2}}; 

arrowPlot[f_] := 
 Plot[{#}, {x, -2, 2}, Axes -> False, Frame -> True, PlotRangePadding -> .2] /.

 {Hue[qq__], a___, x___Line} :> {Hue[qq], a, SortBy[{x}, #[[1, 1, 1]] &]} /. 

 {a___,{Line[x___], d___, Line[z__]}} :> 
                           List[Arrowheads[{-.06, 0}], a, Arrow[x], {d}, 
                                             Arrowheads[{0, .06}], Arrow[z]] /. 

 {a___,{Line[x__]}}:> List[Arrowheads[{-.06, 0.06}], a, Arrow[x]] & /@ f[x];  

arrowPlot[f]

Answer 2

Преимущество следующей конструкции состоит в том, что она не мешает внутренней структуре структуры Graphics и является более общей, чем предложенная в ask.sagemath, поскольку она лучше управляет PlotRange и бесконечностями.

f[x_] = Gamma[x]

{plot, evals} = 
  Reap[Plot[f[x], {x, -2, 2}, Axes -> False, Frame -> True, 
    PlotRangePadding -> .2, EvaluationMonitor :> Sow[{x, f[x]}]]];

{{minX, maxX}, {minY, maxY}} = Options[plot, PlotRange] /. {_ -> y_} -> y; 
ev = Select[evals[[1]], minX <= #[[1]] <= maxX && minY <= #[[2]] <= maxY &];
seq = SortBy[ev, #[[1]] &];
arr = {Arrow[{seq[[2]], seq[[1]]}], Arrow[{seq[[-2]], seq[[-1]]}]};

Show[plot, Graphics[{Red, arr}]]

Редактировать

Как функция:

arrowPlot[f_, interval_] := Module[{plot, evals, within, seq, arr},
   within[p_, r_] :=
    r[[1, 1]] <= p[[1]] <= r[[1, 2]] &&
     r[[2, 1]] <= p[[2]] <= r[[2, 2]];

   {plot, evals} = Reap[
     Plot[f[x], Evaluate@{x, interval /. List -> Sequence},
      Axes -> False,
      Frame -> True,
      PlotRangePadding -> .2,
      EvaluationMonitor :> Sow[{x, f[x]}]]];

   seq = SortBy[Select[evals[[1]],
      within[#, 
        Options[plot, PlotRange] /. {_ -> y_} -> y] &], #[[1]] &];

   arr = {Arrow[{seq[[2]], seq[[1]]}], Arrow[{seq[[-2]], seq[[-1]]}]};
   Show[plot, Graphics[{Red, arr}]]
   ];

arrowPlot[Gamma, {-3, 4}]  

Все еще думаю, что лучше для ListPlot и др.

Answer 3

Вдохновленный комментариями Алексея и ответами Велисария, вот моя попытка.

makeArrowPlot[g_Graphics, ah_: 0.06, dx_: 1*^-6, dy_: 1*^-6] := 
 Module[{pr = PlotRange /. Options[g, PlotRange], gg, lhs, rhs},
  gg = g /. GraphicsComplex -> (Normal[GraphicsComplex[##]] &);
  lhs := Or@@Flatten[{Thread[Abs[#[[1, 1, 1]] - pr[[1]]] < dx], 
                      Thread[Abs[#[[1, 1, 2]] - pr[[2]]] < dy]}]&;
  rhs := Or@@Flatten[{Thread[Abs[#[[1, -1, 1]] - pr[[1]]] < dx], 
                      Thread[Abs[#[[1, -1, 2]] - pr[[2]]] < dy]}]&;
  gg = gg /. x_Line?(lhs[#]&&rhs[#]&) :> {Arrowheads[{-ah, ah}], Arrow@@x};
  gg = gg /. x_Line?lhs :> {Arrowheads[{-ah, 0}], Arrow@@x};
  gg = gg /. x_Line?rhs :> {Arrowheads[{0, ah}], Arrow@@x};
  gg
  ]

Мы можем проверить это на некоторых функциях

Plot[{x^2, IntegerPart[x], Tan[x]}, {x, -3, 3}, PlotStyle -> Thick]//makeArrowPlot

А на некоторых контурных участках

ContourPlot[{x^2 + y^2 == 1, x^2 + y^2 == 6, x^3 + y^3 == {1, -1}}, 
   {x, -2, 2}, {y, -2, 2}] // makeArrowPlot

Единственное место, где это терпит неудачу, это где у вас есть горизонтальные или вертикальные линии по краю графика;

Plot[IntegerPart[x],{x,-2.5,2.5}]//makeArrowPlot[#,.03]&

Это можно исправить с помощью таких опций, как PlotRange->{-2.1,2.1} или Exclusions->None.

Наконец, было бы неплохо добавить опцию, чтобы каждая "кривая" могла стрелками только на своих границах. Это дало бы сюжеты, подобные тем, что были в ответе Велисария (это также позволило бы избежать проблемы, упомянутой выше). Но это дело вкуса.