Show Populations around Amusement Parks 

Indicate the area around each amusement park in the United States that contains about two million people.

show complete Wolfram Language inputhide input

In[1]:=

X allUSZIPCodes = EntityList[EntityClass["ZIPCode", "Standard"]];

In[2]:=

X population = EntityValue[allUSZIPCodes, "Population"];

In[3]:=

X coordinates = EntityValue[allUSZIPCodes, "Position"];

In[4]:=

X data = Select[Transpose[{allUSZIPCodes, coordinates, population}], FreeQ[#, _Missing] &];

In[5]:=

X data3D = {GeoPositionXYZ[#[[2]]][[1]], #} & /@ data;

In[6]:=

X amusementParks = EntityValue["AmusementPark", "Entities"];

In[7]:=

X amusementParksUS = Cases[Transpose[{amusementParks, EntityValue[amusementParks, EntityProperty["AmusementPark", "Country"]]}], {_, Entity["Country", "UnitedStates"]}];

In[8]:=

X amusementParksUSCoords = Select[Transpose[{First /@ amusementParksUS, EntityValue[(First /@ amusementParksUS), EntityProperty["AmusementPark", "Position"]]}], FreeQ[#, _Missing, \[Infinity]] &];

In[9]:=

X interpolateDistance[{pos_, pop_}, {{pos1_, pop1_}, {pos2_, pop2_}}] := With[{dist1 = GeoDistance[pos, pos1], dist2 = GeoDistance[pos, pos2]}, (dist1 pop - dist2 pop + dist2 pop1 - dist1 pop2)/(pop1 - pop2)]

In[10]:=

X populationRadius[{ap_, pos_}, pop_] := Module[{pos3D, sortedZIPCodes, sortedZIPCodes2, accumulatedPop, posPop, accumulatedPopReduced}, pos3D = GeoPositionXYZ[pos][[1]]; sortedZIPCodes = SortBy[data3D, EuclideanDistance[pos3D, #[[1]]] &]; sortedZIPCodes2 = {#2[[2]], QuantityMagnitude[#2[[3]]]} & @@@ sortedZIPCodes; accumulatedPop = Transpose[{#1, Accumulate[#2]} & @@ Transpose[sortedZIPCodes2]]; posPop = Position[accumulatedPop, {_, _?(# >= pop &)}, {1}, 1 ]; accumulatedPopReduced = Take[accumulatedPop, Max[posPop]]; interpolateDistance[{pos, pop}, Take[accumulatedPopReduced, -2]] ]

In[11]:=

X Monitor[disks = Table[Tooltip[ GeoDisk[amusementParksUSCoords[[j, 2]], populationRadius[amusementParksUSCoords[[j]], 2*10^6]], amusementParksUSCoords[[j, 1]]], {j, Length[amusementParksUSCoords]}];, j]

In[12]:=

X GeoGraphics[{GeoStyling[], {Opacity[0.4], RandomColor[], #} & /@ SortBy[disks, -#[[1, 2]] &]}, GeoRange -> Entity["Country", "UnitedStates"]]

Out[12]=