Message Boards Message Boards

[GIF] Visualising climate change with a spiral animation

GROUPS:

I recently came across an article which features a visualisation of the change of the average global temperature. The data to reproduce that visualisation is readily available, and so it is quite straight forward to generate the animation in Mathematica.

enter image description here

The data for this animation is imported like so:

tempdata = Transpose[{Interpreter["Date"][#[[All, 1]]], #[[All, 2]]}] &@
   Import["http://www.metoffice.gov.uk/hadobs/hadcrut4/data/current/time_series/HadCRUT.4.4.0.0.monthly_ns_avg.txt", "Data"];

Let's first generate the final frame:

Show[ListLinePlot[#[[1]]*{Cos[-#[[2]] + Pi/2], Sin[-#[[2]] + Pi/2]} & /@ 
Transpose[{(Abs[#] + 1)^Sign[#] & /@ tempdata[[All, 2]], Mod[Pi/6 Range[0, 1994], 2 Pi]}][[1 ;; 1994]], AspectRatio -> 1,
Background -> Black, Axes -> None, ColorFunction -> Function[{x, y}, ColorData["Temperature"][0.35 Norm[{x, y}]^2.2]], 
PlotRange -> {{-4, 4}, {-4, 4}}, ColorFunctionScaling -> False, ImageSize -> Large, 
Epilog -> {White, Text[Style[(Normal@tempdata[[1994, 1]])[[1]], 22], {-3.5, 3.5}]}],
Graphics[{Function[{x, y}, ColorData["Temperature"][0.35 Norm[{x, y}]^2.2]][2.5, 0], Thickness[0.005], Circle[{0, 0}, 2.5]}], 
Graphics[{Function[{x, y}, ColorData["Temperature"][0.35 Norm[{x, y}]^2.2]][3, 0], Thickness[0.005], Circle[{0, 0}, 3]}], 
Graphics[{White, Rotate[Text[Style[#[[1]], 14], 3.5 {Cos[Pi/2 - #[[2]]], Sin[Pi/2 - #[[2]]]}], -#[[2]]] & /@ 
Transpose[{{"Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"}, 
Range[0, 2 Pi - Pi/6, Pi/6]}]}], Graphics[{Red, Text[Style["1.5\[Degree]C", 12], {0, 2.6}]}], 
Graphics[{Red, Text[Style["2.0\[Degree]C", 12], {0, 3.1}]}]]

enter image description here

The idea is quite straight forward: we can think of this as a polar plot. The angle corresponds to the month of the year and the radius relates to the mean temperature, or in fact to the deviation from the "standard temperature". This deviation can be negative, but the radius cannot. So we use the following "scaling" for the radius:

(Abs[#] + 1)^Sign[#] &

If the temperature deviation from the standard is zero, this gives 1. If the temperature difference is positive the radius grows larger than 1. If the temperature is negative, this value is between 0 and smaller 1. The outer red rings indicate a 1.5 and a 2 degree temperature change which are critical values for a future climate change - we appear to be getting quite close now... Note that for the colours of the circles I needed to consider the scaling function from above, so that I need to feed the values 2.5 for 1.5 degrees and 3 for 2 degrees into the ColourFunction.

It is very easy to generate all frames for the movie:

Monitor[frames = 
   Table[Show[ListLinePlot[#[[1]]*{Cos[-#[[2]] + Pi/2], Sin[-#[[2]] + Pi/2]} & /@ 
   Transpose[{(Abs[#] + 1)^Sign[#] & /@ tempdata[[All, 2]], Mod[Pi/6 Range[0, 1994], 2 Pi]}][[1 ;; k]], 
   AspectRatio -> 1, Background -> Black, Axes -> None, ColorFunction -> Function[{x, y}, ColorData["Temperature"][0.35 Norm[{x, y}]^2.2]], 
   PlotRange -> {{-4, 4}, {-4, 4}}, ColorFunctionScaling -> False, ImageSize -> Large, 
   Epilog -> {White, Text[Style[(Normal@tempdata[[k, 1]])[[1]], 22], {-3.5, 3.5}]}], 
   Graphics[{Function[{x, y}, ColorData["Temperature"][0.35 Norm[{x, y}]^2.2]][2.5, 0], Thickness[0.005], Circle[{0, 0}, 2.5]}], 
   Graphics[{Function[{x, y}, ColorData["Temperature"][0.35 Norm[{x, y}]^2.2]][3, 0], Thickness[0.005], Circle[{0, 0}, 3]}], 
   Graphics[{White, Rotate[Text[Style[#[[1]], 14], 3.5 {Cos[Pi/2 - #[[2]]], Sin[Pi/2 - #[[2]]]}], -#[[2]]] & /@
   Transpose[{{"Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"}, Range[0, 2 Pi - Pi/6, Pi/6]}]}], 
   Graphics[{Red, Text[Style["1.5\[Degree]C", 12], {0, 2.6}]}], 
   Graphics[{Red, Text[Style["2.0\[Degree]C", 12], {0, 3.1}]}]], {k,1, 1995, 6}];, k]

Using

ListAnimate[frames]

one can animate this. I chose to export the frames:

Monitor[Do[Export["~/Desktop/ClimateSpiral/frame" <> ToString[1000 + k] <> ".jpg", frames[[k]], ImageResolution -> 100], {k, 1, Length[frames], 2}], k]

And then used the terminal (!!!) command

convert -delay 5 -loop 0 frame*.jpg animated.gif

to generate the animation. It is a bit long for a post (15MB), but if I make it smaller the resolution is not good enough. It is obviously quite tricky to determine the "mean temperature of the world", particularly because in some areas there is only very sparse data. There is beautiful maths to actually generate estimates.

A slightly more standard visualisation would be this:

DateListPlot[tempdata, PlotTheme -> "Marketing", LabelStyle -> Directive[Bold, Large], FrameLabel -> {"Year", "\[CapitalDelta]T"}, ImageSize -> Full]

enter image description here

Cheers,

Marco

PS: As a small variation you can change the interpolation order in the ListLinePlot function to 1, i.e. add the option

InterpolationOrder->2

and you obtain the attached animation.

Attachment

Attachments:
POSTED BY: Marco Thiel
Answer
1 year ago

enter image description here - another post of yours has been selected for the Staff Picks group, congratulations !

We are happy to see you at the tops of the "Featured Contributor" board. Thank you for your wonderful contributions, and please keep them coming!

POSTED BY: Moderation Team
Answer
1 year ago

I have just posted an alternative representation of this same dataset. I have opened a new thread because the gifs get quite large and I wanted to avoid having large load times of the pages.

Cheers,

Marco

POSTED BY: Marco Thiel
Answer
1 year ago

Group Abstract Group Abstract