Skip to main content

graphics - Mollweide maps in Mathematica


Context


In my field of research, many people use the following package: healpix (for Hierarchical Equal Area isoLatitude Pixelization) which has been ported to a few different languages (F90, C,C++, Octave, Python, IDL, MATLAB, Yorick, to name a few). It is used to operate on the sphere and its tangent space and implements amongst other things fast (possibly spinned) harmonic transform, equal area sampling, etc.



In the long run, I feel it would be useful for our community to be able to have this functionality as well.


As a starting point, I am interested in producing Mollweide maps in Mathematica. My purpose is to be able to do maps such as


Mollweide projection of the Milky Way


which (for those interested) represents our Milky Way (in purple) on top of the the cosmic microwave background (in red, the afterglow of the Big Bang) seen by the Planck satellite.


Attempt


Thanks to halirutan's head start, this is what I have so far:


cart[{lambda_, phi_}] := With[{theta = fc[phi]}, {2 /Pi*lambda Cos[theta], Sin[theta]}]
fc[phi_] := Block[{theta}, If[Abs[phi] == Pi/2, phi, theta /.
FindRoot[2 theta + Sin[2 theta] == Pi Sin[phi], {theta, phi}]]];


which basically allows me to do plots like


grid = With[{delta = Pi/18/2},
Table[{lambda, phi}, {phi, -Pi/2, Pi/2, delta}, {lambda, -Pi, Pi, delta}]];
gr1 = Graphics[{AbsoluteThickness[0.05], Line /@ grid, Line /@ Transpose[grid]},
AspectRatio -> 1/2];
gr0 = Flatten[{gr1[[1, 2]][[Range[9]*4 - 1]],gr1[[1, 3]][[Range[18]*4 - 3]]}] //
Graphics[{AbsoluteThickness[0.2], #}] &;
gr2 = Table[{Hue[t/Pi], Point[{ t , t/2}]}, {t, -Pi, Pi, 1/100}] //
Flatten // Graphics;
gr = Show[{gr1, gr0, gr2}, Axes -> True]


initial image


gr /. Line[pts_] :> Line[cart /@ pts] /. Point[pts_] :> Point[cart[ pts]]

and project them to a Mollweide representation


Mollweide projection of initial image


Question


Starting from an image like this one: spherical Perlin noise, equirectangular projection


(which some of you will recognize;-))


I would like to produce its Mollweide view.



Note that WorldPlot has this projection.


In the long run, I am wondering how to link (via MathLink?) to existing F90/C routines for fast harmonic transforms available in healpix.



Answer



Transform an image under an arbitrary projection? Looks like a job for ImageTransformation :)


@halirutan's cart function gives you a mapping from latitude and longitude to the Mollweide projection. What we need here is the inverse mapping, because ImageTransformation is going to look at each pixel in the Mollweide projection and fill it in with the colour of the corresponding pixel in the original image. Fortunately MathWorld has us covered:



$$\begin{align} \phi &= \sin^{-1}\left(\frac{2\theta+\sin2\theta}\pi\right), \\ \lambda &= \lambda_0 + \frac{\pi x}{2\sqrt2\cos\theta}, \end{align}$$ where $$\theta=\sin^{-1}\frac y{\sqrt2}.$$



Here $x$ and $y$ are the coordinates in the Mollweide projection, and $\phi$ and $\lambda$ are the latitude and longitude respectively. The projection is off by a factor of $\sqrt2$ compared to the cart function, so for consistency I'll omit the $\sqrt2$'s in my implementation. I'll also assume that the central longitude, $\lambda_0$, is zero.


invmollweide[{x_, y_}] := 

With[{theta = ArcSin[y]}, {Pi x/(2 Cos[theta]),
ArcSin[(2 theta + Sin[2 theta])/Pi]}]

Now we just apply this to our original equirectangular image, where $x$ is longitude and $y$ is latitude, to get the Mollweide projection.


i = Import["http://i.stack.imgur.com/4xyhd.png"]

ImageTransformation[i, invmollweide,
DataRange -> {{-Pi, Pi}, {-Pi/2, Pi/2}},
PlotRange -> {{-2, 2}, {-1, 1}}]


enter image description here


Comments

Popular posts from this blog

plotting - Filling between two spheres in SphericalPlot3D

Manipulate[ SphericalPlot3D[{1, 2 - n}, {θ, 0, Pi}, {ϕ, 0, 1.5 Pi}, Mesh -> None, PlotPoints -> 15, PlotRange -> {-2.2, 2.2}], {n, 0, 1}] I cant' seem to be able to make a filling between two spheres. I've already tried the obvious Filling -> {1 -> {2}} but Mathematica doesn't seem to like that option. Is there any easy way around this or ... Answer There is no built-in filling in SphericalPlot3D . One option is to use ParametricPlot3D to draw the surfaces between the two shells: Manipulate[ Show[SphericalPlot3D[{1, 2 - n}, {θ, 0, Pi}, {ϕ, 0, 1.5 Pi}, PlotPoints -> 15, PlotRange -> {-2.2, 2.2}], ParametricPlot3D[{ r {Sin[t] Cos[1.5 Pi], Sin[t] Sin[1.5 Pi], Cos[t]}, r {Sin[t] Cos[0 Pi], Sin[t] Sin[0 Pi], Cos[t]}}, {r, 1, 2 - n}, {t, 0, Pi}, PlotStyle -> Yellow, Mesh -> {2, 15}]], {n, 0, 1}]

plotting - Plot 4D data with color as 4th dimension

I have a list of 4D data (x position, y position, amplitude, wavelength). I want to plot x, y, and amplitude on a 3D plot and have the color of the points correspond to the wavelength. I have seen many examples using functions to define color but my wavelength cannot be expressed by an analytic function. Is there a simple way to do this? Answer Here a another possible way to visualize 4D data: data = Flatten[Table[{x, y, x^2 + y^2, Sin[x - y]}, {x, -Pi, Pi,Pi/10}, {y,-Pi,Pi, Pi/10}], 1]; You can use the function Point along with VertexColors . Now the points are places using the first three elements and the color is determined by the fourth. In this case I used Hue, but you can use whatever you prefer. Graphics3D[ Point[data[[All, 1 ;; 3]], VertexColors -> Hue /@ data[[All, 4]]], Axes -> True, BoxRatios -> {1, 1, 1/GoldenRatio}]

plotting - Adding a thick curve to a regionplot

Suppose we have the following simple RegionPlot: f[x_] := 1 - x^2 g[x_] := 1 - 0.5 x^2 RegionPlot[{y < f[x], f[x] < y < g[x], y > g[x]}, {x, 0, 2}, {y, 0, 2}] Now I'm trying to change the curve defined by $y=g[x]$ into a thick black curve, while leaving all other boundaries in the plot unchanged. I've tried adding the region $y=g[x]$ and playing with the plotstyle, which didn't work, and I've tried BoundaryStyle, which changed all the boundaries in the plot. Now I'm kinda out of ideas... Any help would be appreciated! Answer With f[x_] := 1 - x^2 g[x_] := 1 - 0.5 x^2 You can use Epilog to add the thick line: RegionPlot[{y < f[x], f[x] < y < g[x], y > g[x]}, {x, 0, 2}, {y, 0, 2}, PlotPoints -> 50, Epilog -> (Plot[g[x], {x, 0, 2}, PlotStyle -> {Black, Thick}][[1]]), PlotStyle -> {Directive[Yellow, Opacity[0.4]], Directive[Pink, Opacity[0.4]],