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

Posted 1 year ago
1043 Views
|
0 Replies
|
0 Total Likes
|
 !CorrelationsAs 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, π}]