4
$\begingroup$

Building on this question, how to make two dots moving along two curves?, let's say someone has given you the Graphics[] produced by Plot[] of one or more functions, and they've asked you to add animated points following along each curve.

So suppose we have plot, and did not know plot was generated by

plot = Plot[{Sin[x], Tan[x]}, {x, 0, 10}, GridLines -> Automatic]

Q1: Is it possible to achieve the effect of the following dynamically changing mesh points by processing plot?:

Dynamic@Plot[{Sin[x], Tan[x]}, {x, 0, 10}, GridLines -> Automatic, 
  Mesh -> {{Clock[{0, 10}]}}]

Please keep in mind that we don't know that the functions used to construct the plot were Sin[x] and Tan[x]. One drawback with the Dynamic code is that it regenerates the same plot just to change two mesh points, and that seems wasteful. If the functions are slow to compute, then the result would be unsatisfactory.

Q2: Is it possible to add styling to the mesh points so that the point on each curve gets a different style, or have more than one point on each curve? I'm not too particular about the syntax here, other than explicitly specifying at least one abscissa would be necessary, since that is what is shown in the Dynamic example above. And I'm not asking that arbitrary MeshFunctions be implemented, although it seems feasible.

$\endgroup$

1 Answer 1

6
$\begingroup$

The function addDynamicMesh[plot, meshopts...] (see below) adds mesh points wrapped in Dynamic, so that they will change whenever appropriate. The meshopts include Mesh :> spec and MeshStyle -> spec and may be omitted. The Mesh :> spec needs RuleDelayed to prevent OptionValue in the code from evaluating spec. For instance, if Mesh -> {{Clock[{0, 10}]}}, the Clock[] will evaluate to 0 before being injected into Dynamic and we'll lose the dynamic animation.

Restriction: It is based on the current structure of the graphics returned by Plot[], which hasn't changed in a while. But it might change. An alternative is given further below, but you lose some functionality.

Examples

The default Mesh behavior is a single point animated by Clock[] over the plotrange:

plot = Plot[{Sin[x], Tan[x]}, {x, 0, 10}, GridLines -> Automatic];
addDynamicMesh[plot, 
 MeshStyle -> {Directive[PointSize[Large], Red], 
   Directive[PointSize[Medium], Blue]}]

This animates ten mesh points on each graph:

addDynamicMesh[plot, Mesh :> {{Mod[Clock[Infinity] + Range@10, 10]}}, 
 MeshStyle -> {Directive[PointSize[Large], Red], 
   Directive[PointSize[Medium], Blue]}]

This adds a static mesh (though still wrapped in Dynamic) to plot:

addDynamicMesh[plot, Mesh -> {9}]

This shows mesh points at the current mouse $x$-coordinate, whenever the mouse is over the graphics:

meshx = Mean@First@PlotRange@plot;
addDynamicMesh[plot, 
 Mesh :> {{meshx = First@MousePosition["Graphics", {meshx, 0}]}}, 
 MeshStyle -> {Directive[PointSize[Large], Red], 
   Directive[PointSize[Medium], Blue]}]

enter image description here

Code

For each function to be plotted, Plot[] puts the lines of its graph in List that starts with a styling Directive[]. It's convenient to get each list, because we also get the styling for the line. Since we don't have the functions for each curve, we use Interpolation on their points.

getLineGroups // ClearAll;
getLineGroups[g_GraphicsComplex] := With[{coords = First@g},
   Cases[g,
    l_List /; 
      MemberQ[l, _Line] :> (l /. 
       Line[ics_, ___] :>   (* get rid of VertexColors *)
        Line[ics /. i : {__Integer} :> coords[[i]]]),
    Infinity]
   ];
getLineGroups[g_Graphics] := With[{glines = Join @@ 
      Cases[g, gc_GraphicsComplex :> getLineGroups@gc, Infinity]},
   Join[
    glines,
    Cases[
     DeleteCases[g, _GraphicsComplex, Infinity],
     l_List /; MemberQ[l, _Line] :>
      (l /. Line[p_, ___] :> Line[p]), (* get rid of VertexColors *)
     Infinity]
    ]
   ];
addDynamicMesh // ClearAll;
addDynamicMesh // Attributes = {HoldRest};
addDynamicMesh // Options = {
   Mesh -> Automatic, 
   MeshStyle -> Automatic};
addDynamicMesh[plot_, opts : OptionsPattern[]] :=
  With[{groups = getLineGroups[plot],
        pr = First@PlotRange[plot]},
   With[{
     mesh = OptionValue[Automatic, Automatic, Mesh, Hold] /.
       { None -> {}
       , Automatic :> Mod[Clock@Infinity, pr[[2]] - pr[[1]], pr[[1]]]
       , Hold[n_Integer] | Hold[{n_Integer}] :> 
          Hold@Evaluate[Subdivide[pr[[2]], pr[[1]], n + 1][[2 ;; -2]]]
        },
     meshFN = Evaluate[
          MapThread[
           Function[{style, line},
            line /. Line[p_] :> 
              With[{y = Interpolation[p, 
                  "ExtrapolationHandler" -> {Indeterminate &, 
                    "WarningMessage" -> False}]},
               Hold@
                If[NumberQ[y[#]], (* delete Indeterminate y *)
                 {style, Point[{#, y[#]}]},
                 {}]
               ]
            ],
           {Charting`getPlotStyles[None][ (* convenient internal func *)
             Length@groups,               (* not hard to code tho' *)
             OptionValue[MeshStyle]],
            groups}
           ]
          ] & // ReleaseHold},
     mesh /. Hold[m_] :> (* mesh needs to be held *)
       Show[             (* until injected in Dynamic *)
        plot,
        Graphics[{Dynamic[meshFN /@ Flatten@{m}]}]
        ]
     ]];

Alternative

For Graphics[] not produced by Plot[] -- or if the workings of Plot change -- then we could just get all lines, instead of groups of lines. The groups were convenient for styling each group in a similar way, so hopefully they won't go away. But if they do:

getLineCoords // ClearAll;
getLineCoords[g_GraphicsComplex] := With[{
    coords = First@g},
   Cases[
    Cases[g, Line[p_] :> p, Infinity] /. 
     i : {__Integer} /; Length[i] > 2 :> coords[[i]],
    m_ /; MatrixQ[m, Developer`RealQ],
    Infinity]
   ];
getLineCoords[g_Graphics] := With[{
    glines = 
     Join @@ Cases[g, gc_GraphicsComplex :> getLines@gc, Infinity]},
   Join[
    glines,
    Cases[
     Cases[
      DeleteCases[g, _GraphicsComplex, Infinity],
      Line[p_] :> p, Infinity],
     m_ /; MatrixQ[m, Developer`RealQ],
     Infinity]
    ]
   ];
getLines // ClearAll;
getLines[g_] := Line /@ getLineCoords[g];

Example: Notice in the output of the following that both the Sin[x] and Tan[x] curves are broken up at the exclusions coming from Tan[x]. This means there are eight curves to style, in order s1, s2, s3, s4, t1, t2, t3, t4, and the two styles alternate through this list, so that styling of the point on the sine curve alternates between the two styles, as it does also for the tangent graph. To fix it, determine the order of the curves and construct an appropriate MeshStyle. No easy way to do this without experimental inspection occurs to me without assuming the underlying structure of the Graphics[].

Block[{getLineGroups = getLines},
 addDynamicMesh[plot, Mesh :> Clock[{0, 10}], 
  MeshStyle -> {Directive[PointSize[Large], Red], 
    Directive[PointSize[Medium], Blue]}]
 ]
$\endgroup$

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.