Animating a Vector Field

Question

I am trying to create animations of a time dependent vector field $\vec v(t,x,y)$. The problem is that VectorPlot scales the vectors for each time $ t $ separately based on the minimal and maximal norm of the vector field at that time.

This answer shows how to solve this problem using VectorScale in the case in which the ratio of the max. norm for some time $ t$ and the the max. norm over all times is known. I suppose this could be found by evaluating $ \vec v $ on a $ (t,x,y) $ grid, but that makes for quite a lot of evaluations which I'd rather avoid. Surely there is a simpler way?

Answer 1

I finally found the time to revisit this problem. In the end, I went with determining the correct scaling factors manually. The code below takes a vector field (as a function $v(t,x,y)$), $x$ & $y$ ranges, $t$ range & number of frames as arguments and produces an array of suitably scaled vector plots. The range of scale parameters can be set with Options, as can all the default VectorPlot directives.

Options[vecAnimate] = {
   "scaleMin" -> 0.01, "scaleMax" -> 0.075, 
   "vecScaleFun" -> Automatic
   };
vecAnimate[v_, {x_, xmin_, xmax_}, {y_, ymin_, ymax_}, {tmin_, tmax_, 
   nFrames_}, opt : OptionsPattern[{vecAnimate, VectorPlot}]] :=

 Module[{
   evalPoints =  
    Reap[VectorPlot[v[0, x, y], {x, xmin, xmax}, {y, ymin, ymax}, 
       EvaluationMonitor :> Sow[{x, y}]]][[-1, 1]],
   tR = Subdivide[tmin, tmax, nFrames][[;; -2]],
   scaleMin = OptionValue["scaleMin"], 
   scaleMax = OptionValue["scaleMax"],
   maxNorms, totalMaxNorm, scales 
   },
  maxNorms = Table[Max @ (Norm /@ (v[t, #1, #2] & @@@ evalPoints)), {t, tR}];
  totalMaxNorm = Max @ maxNorms;
  scales = maxNorms/totalMaxNorm;
  scales = scales * (scaleMax - scaleMin) + scaleMin;
  MapThread[
   VectorPlot[v[#1, x, y], {x, xmin, xmax}, {y, ymin, ymax}, 
     VectorScale -> {#2, Automatic, OptionValue["vecScaleFun"]}, 
     Evaluate@FilterRules[{opt}, Options[VectorPlot]]] &, {tR, scales}]
  ]

Demo (Hertzian Dipole):

With[{ex = 5, r = Sqrt[#.#] &, 
  d0 = {0, 1}}, {v = Function[{t, x, y}, If[r[{x, y}] > .75, 
     Cos[t - r[{x, y}]] (d0/r[{x, y}] - ( {x, y}*({x, y}.d0))/r[{x, y}]^3),
     {0, 0}]]
 }, 
 ListAnimate[
  vecAnimate[v, {x, -ex, ex}, {y, -ex, ex}, {0, 2 \[Pi], 30}, 
   PlotRange -> 1.2 {{-ex, ex}, {-ex, ex}}]
 ]
]

yields

The method above fails in the presence of poles. As in the example, this can be alleviated by just returning a zero vector in some region or above some vector field norm.

Answer 2

Try VectorScale this way:

Animate[
 VectorPlot[{Cos[2 \[Pi] x + t], Sin[2 \[Pi] y + t^2]},
  {x, -1, 1}, {y, -1, 1},
  VectorScale -> {Large, Scaled[1]}],
 {t, .1, 2, .05}]