# How can I generate an interrupted projection of a world map?

How can I generate a world map like the one here, but for an arbitrary hand-drawn map?

For example, starting from scratch, how can I manipulate this world map

to get something that looks like this?

Attempt: Starting with the world map, I thought to cut the image into vertical strips and somehow contract each rectangular strip at its upper and lower ends while keeping the middle constant to make symmetric lenses, i.e. the transformation that does this:

However, I don't how to do this, and I suspect there may be an easier way. Any suggestions are appreciated.

• Your first image seems to be cut off (i.e. not a complete equirectangular projection of the world). – J. M.'s discontentment Jul 26 '16 at 4:00
• Wolfram Research has posted a page, Make a Map That Wraps a Globe. There you can find Mathematica code that should answer your question; follow this link – m_goldberg Jul 26 '16 at 4:32
• @m_goldberg I was aware of that page (it was the first link I included in my question). I am asking how to do something similar but with an arbitrary map, say the map of some fictional planet, not one of Earth. I wasn't aware that the code given on that page could be adapted for an imported image as JM's answer demonstrated. – user170231 Jul 26 '16 at 13:17

I'm going to take the interpretation that you want to apply the transverse Mercator projection to an image you have to produce something like the one in the Wolfram page you linked to. One only needs to make a few changes to the code in that link. I will be using a different image, since the one in the OP is awkwardly cut off, which will mess with the mapping.

With[{Δ = 30},
earth = Import["http://i.stack.imgur.com/jteWq.jpg"];
GeoGraphics[GeoBackground -> GeoStyling[{"GeoImage", #2}],
GeoRange -> {{-90, 90}, #1[[1]]},
GeoProjection -> {"TransverseMercator", "Centering" -> #1[[2]]},
ImageSize -> Large],
ImageSize -> Large] &,
{Table[{{λ, λ + Δ}, {0, λ + Δ/2}}, {λ, -180, 180 - Δ, Δ}],
First @ ImagePartition[earth, Scaled[{Δ/360, 1}]]}]]]


Here is a slower method that uses ImageTransformation[] and formulae 22-23 from here to directly transform the map (note that I took the liberty to work directly in radians instead of degrees):

With[{Δ = π/6},
earth = Import["http://i.stack.imgur.com/jteWq.jpg"];
ImageAssemble[Table[ImageTransformation[earth,
Module[{x = #[[1]], y = #[[2]], h = Δ/2, λt},
λt = ArcTan[Cos[y], Sinh[x]];
If[-h <= λt <= h,
{λ + h + λt, ArcSin[Sin[y] Sech[x]]},
{π, π/2} (* dummy value for off-range pixels *)]] &,
Background -> White, DataRange -> {{-π, π}, {-π/2, π/2}},
PlotRange -> {{-InverseGudermannian[Δ/2], InverseGudermannian[Δ/2]},
{-π/2, π/2}}],
{λ, -π, π - Δ, Δ}]]]


• Bonus image: here is the result of applying the piecewise transverse Mercator projection to the ETOPO1 global relief. – J. M.'s discontentment Jul 26 '16 at 8:34
• This looks quite promising. I'll give it a try when I get to my desktop. – user170231 Jul 26 '16 at 13:17
• @J.M. What would be the parametric equation for a single flat gore region? – Young Jul 26 '16 at 14:13
• @Young, pardon me, but what is a "flat gore region"? – J. M.'s discontentment Jul 26 '16 at 14:15
• I'm trying this img = Import["http://i.stack.imgur.com/jteWq.jpg"]; gore = 12; tex = First@ImagePartition[img, Scaled[{1/gore, 1}]]; Row[Table[ ParametricPlot[{phi Sin[theta]^2, gore/2 phi Cos[theta]}, {phi, -Pi/gore, Pi/gore}, {theta, -Pi, Pi}, PlotStyle -> Directive[Texture[tex[[i]]], Opacity[1]], TextureCoordinateFunction -> ({#1, #2} &), Frame -> False, Axes -> False, BoundaryStyle -> None, ImageSize -> Medium], {i, 1, gore}]] – Young Jul 26 '16 at 14:19

J.M.'s answer is the best and he helped me figure out the correct parametric equations from here, but the method I've been working on is very fast (<0.5 sec) and doesn't include any white-space where the slices connect.

img = Import["http://i.stack.imgur.com/jteWq.jpg"];
gore = 12;
tex = First @ ImagePartition[img, Scaled[{1/gore, 1}]];
ImageAssemble[Table[
ParametricPlot[{ArcTanh[Cos[ϕ] Sin[λ]],  ArcTan[Cos[ϕ] Cos[λ], Sin[ϕ]]},
{ϕ, -π/2, π/2}, {λ, -π/gore, π/gore},
PlotStyle -> Directive[Texture[tex[[i]]], Opacity[1]],
TextureCoordinateFunction -> ({#1, #2} &), Frame -> False,
Axes -> False, BoundaryStyle -> None, PlotRangePadding -> 0],
{i, 1, gore}]]


• Here's an alternative: Show[Table[ParametricPlot[{2 (i - 1) InverseGudermannian[π/gore] + ArcTanh[Cos[ϕ] Sin[λ]], ArcTan[Cos[ϕ] Cos[λ], Sin[ϕ]]}, {ϕ, -π/2, π/2}, {λ, -π/gore, π/gore}, Axes -> False, BoundaryStyle -> None, Frame -> False, PlotStyle -> Directive[Texture[tex[[i]]], Opacity[1]], TextureCoordinateFunction -> ({#1, #2} &)], {i, 1, gore}], PlotRange -> All]. – J. M.'s discontentment Jul 28 '16 at 11:31