Message Boards Message Boards

[GIF] Correlations (Mercator projection of contours for dot product sum)

Mercator projection of contours for dot product sum!

Correlations

As with Map and In Balance, this is showing the Mercator projection of some phenomenon happening on the sphere.

In this case, what I'm doing is plotting level sets of a function which computes the sum of the absolute values of the dot products of a given point on the sphere with the vertices of the regular octahedron, namely the points $(1,0,0),(-1,0,0),(0,1,0),(0,-1,0),(0,0,1),(0,0,-1)$. Or rather, to make the animation, I'm doing this after rotating the vertices of the octahedron around the axis $(1,0,1)$, which passes through the center of one of the edges of the octahedron. The maximum value $2\sqrt{3}\approx 3.46$ of this function is achieved at the centers of the faces of the octahedron, which correspond to the black points in the animation, and the minimum value $2$ is achieved at the vertices of the octrahedron, corresponding to the light points.

To define this as a function on the plane, I need to use the inverse of the Mercator projection, which is

InverseMercator[{x_, y_}] := {Sech[y] Cos[x], Sech[y] Sin[x], Tanh[y]};

So now in principle I should just be able to take the sum of Abs[InverseMercator[{x,y}].p] where p ranges over the rotated vertices of the octahedron and plug this into ContourPlot[]. Unfortunately, this turns out to be quite slow, so instead I am going to precompute what this will be as a function of $x$, $y$, and $\theta$ (the rotation angle), which boils down to evaluating

FullSimplify[
 Total[
  Abs /@
   (InverseMercator[{x, y}].RotationTransform[θ, {1, 0, 1}][#]
      & /@ Flatten[Permutations[# {0, 0, 1}] & /@ {1, -1}, 1])],
 -π < x < π && -π < y < π && 0 < θ < 2 π]

Now, the output of the above is

Abs[Sech[y] (Cos[x] (1 + Cos[θ]) + Sqrt[2] Sin[x] Sin[θ]) + Tanh[y] - Cos[θ] Tanh[y]]
+ Abs[Sech[y] (Cos[x] - Cos[x] Cos[θ] - Sqrt[2] Sin[x] Sin[θ]) + (1 + Cos[θ]) Tanh[y]]
+ Abs[2 Cos[θ] Sech[y] Sin[x] + Sqrt[2] Sin[θ] (-Cos[x] Sech[y] + Tanh[y])]

so this is what I actually plug into ContourPlot[]:

Manipulate[
 ContourPlot[
  Abs[Sech[y] (Cos[x] (1 + Cos[θ]) + Sqrt[2] Sin[x] Sin[θ]) + Tanh[y] - Cos[θ] Tanh[y]]
   + Abs[Sech[y] (Cos[x] - Cos[x] Cos[θ] - Sqrt[2] Sin[x] Sin[θ]) + (1 + Cos[θ]) Tanh[y]]
   + Abs[2 Cos[θ] Sech[y] Sin[x] + Sqrt[2] Sin[θ] (-Cos[x] Sech[y] + Tanh[y])],
  {x, -π, π}, {y, -π, π},
  Frame -> False, ImageSize -> 540, Contours -> Range[2, 4, .1], 
  ContourStyle -> None, PlotRangePadding -> -0.01, PlotPoints -> 50, 
  ColorFunction -> (ColorData["DeepSeaColors"][1 - #] &)],
 {θ, 0, π}]

enter image description here -- you have earned Featured Contributor Badge enter image description here Your exceptional post has been selected for our editorial column Staff Picks http://wolfr.am/StaffPicks and Your Profile is now distinguished by a Featured Contributor Badge and is displayed on the Featured Contributor Board. Thank you!

POSTED BY: Moderation Team
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract