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

enter image description here

to get something that looks like this?

enter image description here

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:

enter image description here

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. is computer-less 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
up vote 17 down vote accepted

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"];
     ImageAssemble[MapThread[Rasterize[
          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}]]}]]]

transverse Mercator


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}}, 
                   Masking -> All, 
                   PlotRange -> {{-InverseGudermannian[Δ/2], InverseGudermannian[Δ/2]},
                                 {-π/2, π/2}}],
                   {λ, -π, π - Δ, Δ}]]]

directly transformed image

  • Bonus image: here is the result of applying the piecewise transverse Mercator projection to the ETOPO1 global relief. – J. M. is computer-less 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. is computer-less 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}]]

Mercator-projected map

  • 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. is computer-less Jul 28 '16 at 11:31

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.