I've recently stumbled upon this very nice interactive visualization of eigenvectors of two-dimensional matrices, and how powers $A^k$ act on various vectors.

How can this sort of visualization be realized with Mathematica, leveraging its dynamical capabilities?

  • Maybe not what you want, but there are interactive examples at demonstrations.wolfram.com, such as this and this – Daniel Lichtblau Nov 10 at 15:55

The following is an attempt to recreate a similar sort of interactive visualization, showing the eigenvectors (when real), and how the various points of the unit circle are transformed by the matrix.

The matrix can be chosen by moving its two column vectors using the mouse. I used EventHandler for this, instead of Locators, for greater customizability and a more natural look.

To ease code readability and modularity, the components of the graphical object are defined separately in a private context, and injected into the final DynamicModule object.

Here is the full code:

BeginPackage["eigenvectorRepresentation`"];
dynamicalEigenvectorsRepresentation;
Begin["`Private`"];

Attributes[hold] = HoldAllComplete;
ClearAll@injectAndRelease;
Attributes[injectAndRelease] = HoldAllComplete;
injectAndRelease[x_, replacementRules_, hold_: hold] := 
  Hold@x /. replacementRules /. {hold[s__] :> s} // ReleaseHold;

redPoint = hold@{
    Red, If[TrueQ[movingPointIndex == 1], PointSize@0.04, 
     PointSize@0.03],
    Point@v1, Arrow@{{0, 0}, v1}
    };

greenPoint = hold@{
    Green, 
    If[TrueQ[movingPointIndex == 2], PointSize@0.04, PointSize@0.03],
    Point@v2, Arrow@{{0, 0}, v2}
    };

bluePointAndArrows = 
  hold@Dynamic@{Blue, PointSize@0.03, Point@v3, Arrowheads@0.02,
     Arrow /@ 
      Partition[NestList[Dot[matrix, #] &, v3, numOfIterations], 2, 
       1]
     };

showEigenvectors = hold@Dynamic@With[{eigs = Eigenvectors@N@matrix},
     If[MatchQ[eigs, {{__Real} ..}], {Purple, Thickness@0.01, 
       InfiniteLine@{-#, #} & /@ eigs}, {}]
     ];

principalAxes = hold@With[
    {singularVectors = {Transpose@#[[1]], #[[3]]} &@
       SingularValueDecomposition@matrix},
    {Map[{Thick, Orange, Arrow@{{0, 0}, #}} &, singularVectors[[1]]],
     Map[{Thick, Cyan, Arrow@{{0, 0}, #}} &, singularVectors[[2]]]}
    ];

additionalInfo = hold[
   Column@{
     "PlotRange",
     VerticalSlider[Dynamic@frameSize, {1, 10, 0.01}, 
      Appearance -> "Labeled"]
     }, "   ",
   Column@{
     "Number of iterations",
     VerticalSlider[Dynamic@numOfIterations, {1, 40, 1}, 
      Appearance -> "Labeled"]
     }
   ];

eigenvaluesDisplay = hold[
   "   ",
   Dynamic@With[{eigvals = Eigenvalues@matrix},
     Graphics[{Circle[], Point@{0, 0}, Thick,
       Arrow@{{0, 0}, ReIm@eigvals[[1]]},
       Arrow@{{0, 0}, ReIm@eigvals[[2]]}
       }, Axes -> True, PlotRangePadding -> 0.1, 
      PlotRange -> {{-1, 1}, {-1, 1}}, ImageSize -> 200, 
      PlotLabel -> "Eigenvalues"]
     ]
   ];

arrowRepresentationActionMatrix[matrix_] := 
  With[{pts = MeshCoordinates@DiscretizeRegion@Region@Circle[]},
   With[{finalPts = Dot[matrix, #] & /@ pts},
    Graphics[{
      PointSize@0.012, Point@finalPts,
      Arrow /@ Thread@{pts, finalPts}
      }]
    ]];

Options[dynamicalEigenvectorsRepresentation] = {
   "ShowBluePointAndArrows" -> True,
   "ShowEigenvectorsWhenReal" -> True,
   "ShowEigenvalues" -> True,
   "ShowPrincipalAxes" -> True
   };
dynamicalEigenvectorsRepresentation[OptionsPattern[]] := DynamicModule[
    {v1 = {0.7, -0.6}, v2 = {0.6, 0.6}, v3 = {1, 1}, movingPointIndex,
      matrix, frameSize = 1.5, numOfIterations = 30},
    Row[{
      EventHandler[
       Dynamic[
        matrix = Transpose@{v1, v2};
        Show[
         arrowRepresentationActionMatrix@matrix,
         Graphics[{
           PointSize@0.02, Circle[], Point@{0, 0},
           "RedPoint", "GreenPoint", "BluePoint",
           "ConditionallyShowEigenvectors",
           "PrincipalAxes"
           }],
         Frame -> True, 
         PlotRange -> Dynamic[{{-#, #}, {-#, #}} &@frameSize], 
         ImageSize -> 500
         ]
        ],
       {"MouseDown" :> With[{mp = MousePosition["Graphics"]},

          movingPointIndex = 
           Position[{v1, v2, v3}, First@Nearest[{v1, v2, v3}, mp]][[1,
             1]]
          ],
        "MouseUp" :> (movingPointIndex = 0),
        "MouseDragged" :> ReleaseHold[

          Hold[Set][Hold[v1, v2, v3][[{movingPointIndex}]], 
           MousePosition["Graphics"]]
          ]}
       ],
      "AdditionalInfoSlot",
      "EigenvaluesDisplay"
      }]
    ]~injectAndRelease~{
    "RedPoint" -> redPoint, "GreenPoint" -> greenPoint,
    "BluePoint" -> 
     If[OptionValue@"ShowBluePointAndArrows" === True, 
      bluePointAndArrows, {}],
    "AdditionalInfoSlot" -> additionalInfo,
    "EigenvaluesDisplay" -> 
     Sequence @@ 
      If[OptionValue@"ShowEigenvalues" === 
        True, {eigenvaluesDisplay}, {}],
    "ConditionallyShowEigenvectors" -> 
     If[OptionValue@"ShowEigenvectorsWhenReal" === True, 
      showEigenvectors, {}],
    "PrincipalAxes" -> 
     Sequence @@ 
      If[OptionValue@"ShowPrincipalAxes" === True, {principalAxes}, {}]
    };

End[];
EndPackage[];

Then to create the representation just use

dynamicalEigenvectorsRepresentation[
  "ShowEigenvectorsWhenReal" -> True,
  "ShowBluePointAndArrows" -> True,
  "ShowEigenvalues" -> True,
  "ShowPrincipalAxes" -> False
]

and this is the result:

enter image description here

  • 2
    This is really cool – user6014 Nov 9 at 1:03

Your Answer

 
discard

By clicking "Post Your Answer", you acknowledge that you have read our updated terms of service, privacy policy and cookie policy, and that your continued use of the website is subject to these policies.

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