xkcd consensus new year

BeginPackage["prepPopYYYY`"]

plotPopYYYY::usage="plotPopYYYY[year, zone] retuns a plot and Missing[\"NotAvailable\"] when there are no available \"Population\" 'CountryData' for the input 'year'.";

Begin["`Private`"]

entry[name_,zone_,pop_]:=<|
"name"->name,
"zone"->zone,
(* population density per zone *)
"density"->pop
|>

makeEntry[entity_,year_]:=Module[{zones=CountryData[entity,"TimeZones"],name=CountryData[entity,"Name"],pop},
(* obvious oversimplification: population uniformly distributed over time zones in each country *)
pop=If[
(* is population missing for requested year? *)
MissingQ[#],
(* then return Missing *)
#,
(* else calc population density per zone *)
#/Quantity[Length[zones],IndependentUnit["zone"]]//N
]&@CountryData[entity,{"Population",year}];

Select[entry[name,#,pop]&/@zones,FreeQ[#,Missing]&]
]

entriesByZone[year_]:=Module[{zf=#["zone"]&},
(* sort (east to west) and gather up entries by zone *)
GatherBy[
SortBy[
Flatten[makeEntry[#,year]&/@CountryData[]],(-zf[#]&)],zf]
]

(* --- *)

summaryEntry[countries_,count_,zone_,density_]:=<|
"countries"->countries,
"n"->count,
"zone"->zone,
"density"->density
|>

(* input: list of entries by zone *)
makeSummary[entries_List]:=Module[{countries,count,density,iCountries,zone},
(* list of countries in the zone *)
countries=Query[All,"name"][entries];
count=Length[countries];
(* population density by zone *)
density=Query[Total,"density"][entries]Quantity[1,IndependentUnit["zone"]];

iCountries=Iconize[countries,"countries"];
(* all entries are from the same zone... *)
zone=Query[1,"zone"][entries];

(* output *)
summaryEntry[iCountries,count,zone,density]
]

(* --- *)

accumulatedEntry[count_,zone_,density_,time_,y_]:=<|
"n"->count,
"zone"->zone,
"density"->density,
"time"->time,
"y"->y
|>

accumulateByZone[summary_,year_,zone_]:=Module[{entry,density,time,y,total},

(* total population *)
total=Query[Total,"density"][summary];

density=Quantity[0,"People"];
time={year,12,31,23,0,0};
y=Quantity[0,"Percent"];

entry=accumulatedEntry[0,zone,density,time,y];

FoldList[
accumulatedEntry[
(* number of countries *)
#1["n"]+#2["n"],
(* zone *)
#2["zone"],
(* population density per zone - in persons *)
#1["density"]+#2["density"],
(* time *)
DatePlus[#1["time"],{#1["zone"]-#2["zone"],"Hours"}],
(* y *)
Quantity[100(#1["density"]+#2["density"])/total ,"Percent"]
]&,entry,summary]//Rest
]

(* --- *)

plotPopYYYY[YEAR_:2009,ZONE_:2]:=Module[{s,offset,a,d,t,y,tfst,tlst,t50,tmdn,xticks,yticks,label,tspec},

s=makeSummary/@entriesByZone[YEAR-1];

(* check if there are available data *)
If[
s=!={},

offset=Query[1,"zone"][s]+1;

a=accumulateByZone[s,YEAR-1,offset];
d=Values@Query[All,{"time","y"}][a];
{t,y}=Transpose[d];

t=DatePlus[#,{ZONE-(offset-1),"Hours"}]&/@t;

d=Transpose[{t,y}];


{tfst,tlst}=Through[{#[[1]]&,#[[-1]]&}[t]];

t50=First[Query[Select[#[[-1]]>=Quantity[50,"Percent"]&],First][d]];

tmdn={YEAR-1,12,31,24,0,0};
xticks={tfst,t50,tmdn,tlst};

yticks=Quantity[#,"Percent"]&/@{0,50,100};

label=StringTemplate["PERCENTAGE OF WORLD'S POPULATION LIVING IN `Y` (UTC`Z`)"];

tspec={"Hour12",":","Minute", "AMPM","\n","MonthNameShort"," ","Day","\n","Year"};

DateListPlot[

d,

PlotStyle->Thick,
DateTicksFormat->tspec,
FrameTicksStyle->Directive[Large],
FrameTicks->{{yticks,None},{xticks,None}},
GridLines->{Automatic,yticks},
FrameLabel->{{None,None},{None,label[<|"Y"->YEAR,"Z"->ZONE|>]}},
FrameStyle->Directive[Large],
PlotRange->Full,
ImageSize->Full
],

(* report no data available *)
Missing["NotAvailable"]

]

]

End[]

EndPackage[]