Group Abstract Group Abstract

Message Boards Message Boards

Can this geo-3D histogram of USA population be improved?

Vitaliy Kaurov, WOLFRAM Research
Posted 11 years ago

I am looking for an optimal code to build a 3D histogram of USA population with bars bounded by state borders. Here is my initial version. Can anyone suggest improvements?

(* get the states *)
divisions = 
  EntityValue[Entity["AdministrativeDivision", {_, "UnitedStates"}], 
   "Entities"];

(* get polygons of borders *)
dat = EntityValue[
    divisions, {"Population", "Polygon"}] /. {GeoPosition -> Identity,
     Quantity[x_, _] -> x};

(* some arbitrary rescaling to improve relative height perception *)
pop = Rescale[(# - Min[#]) &@Log[dat[[All, 1]]] // N];

(* plot constants of population of regions of polygons *)
polygs = Plot3D[#1, {x, y} \[Element] #2, Mesh -> None, Filling -> 0, 
     ColorFunction -> "Rainbow", ColorFunctionScaling -> False] & @@@ 
   Transpose[{pop, dat[[All, 2]]}];

(* combine all *)
Show[polygs, PlotRange -> {{23, 50}, {-60, -130}, All}, 
 BoxRatios -> {27, 70, 50}, ImageSize -> 800, Boxed -> False, 
 Axes -> False]

enter image description here

enter image description here
POSTED BY: Vitaliy Kaurov
11 Replies
Sort By:
Jaebum Jung
Jaebum Jung, Wolfram
Posted 11 years ago

DeleteCases do almost same thing you described: 

DeleteCases[divisions, Entity[_, {"Alaska" | "Hawaii", _}]]

or

DeleteCases[el, Entity[_,"Venus"]]
POSTED BY: Jaebum Jung

Yes. But, my goal here is different.

I am looking for something that is more intuitive for students and beginners. Yours are good examples for just-beyond-beginners who are learning about pattern restrictions. For beginners, wouldn't DeleteEntities[entityList, {entityPattern, entityPattern}] be more initially more useful than writing it oneself?

POSTED BY: W. Craig Carter
Jaebum Jung
Jaebum Jung, Wolfram
Posted 11 years ago

you could do :

el = EntityList["Planet"];
DeleteCases[el, a_ /; MemberQ[a, "Venus", Infinity]]

divisions = 
 EntityValue[Entity["AdministrativeDivision", {_, "UnitedStates"}],   "Entities"];
DeleteCases[divisions,   a_ /; MemberQ[a, "Alaska" | "Hawaii", Infinity]]

for states you can also do:

divisions = 
 EntityValue[Entity["AdministrativeDivision", {Except["Alaska" | "Hawaii"],   "UnitedStates"}], "Entities"]
POSTED BY: Jaebum Jung

That is very nice Jaebum!

On a related note, I'm trying getting up to speed with Entity[]. When going though this example, I was wondering how to delete members from an EntityList (e.g., Alaska and Hawaii). The following seems a bit cludgy to me

el = EntityList["Planet"]
DeleteCases[el, a_ /; MemberQ[a, "Venus"]]

I've glanced at the documentation, but haven't found a way that would be more intuitive to beginners (i.e., my students). Is there a better way?

Perhaps this should be a separate thread?
POSTED BY: W. Craig Carter
Jaebum Jung
Jaebum Jung, Wolfram
Posted 11 years ago
POSTED BY: Jaebum Jung

I like Craigs idea of visualization very much. A lot of white space is generated by presence of islands. Here is the central pieces to enjoy the approach fully:

![enter image description here][1]
POSTED BY: Vitaliy Kaurov

Hello, Vitaliy's code doesn't crash my MacBook MacOS 10.9.4 (16GB Graphics NVIDIA GeForce GT 750M 2048 MB)

I tried a different angle on Vitaliy's code, but I don't think it is an improvement. I tried a 2d version of the data representation because some of the states were getting hidden behind the others.

This is the same as Vitaliy's code except I am grabbing the position and scaling a bit differently:

divisions = 
  EntityValue[Entity["AdministrativeDivision", {_, "UnitedStates"}], 
   "Entities"];
dat = EntityValue[
    divisions, {"Population", "Polygon", 
     "Position"}] /. {GeoPosition -> Identity, Quantity[x_, _] -> x};
dat[[All, 1]] = 
 Rescale[dat[[All, 1]], Through[{Min, Max}[dat[[All, 1]]]], {0.1, 1}]

Here is the 2D graphic where I have scaled the polygon of each state with its population and used a color scaling as well:

sizeScale[{population_, polygon_, center_}] := 
 With[{polygons =  polygon[[1]]},(*Print[polygons];*)
  polygons /. {x_?NumericQ, y_?NumericQ} :> 
    Reverse@(center + population ({x, y} - center))]

Show[
 Graphics[
  {FaceForm[], EdgeForm[Black], 
   dat[[All, 2]] /. p : {x_?NumericQ, y_?NumericQ} :> Reverse[p] }],

 Graphics[
  Transpose[{ColorData["DarkRainbow"] /@ dat[[All, 1]], 
    Polygon /@ (sizeScale /@ dat)}]], ImageSize -> Large
 ]

enter image description here

As you can see, there is a strange outlier near the international date line. It looks like the Philippines, but that isn't one of the Entities in divisions (???)
POSTED BY: W. Craig Carter

Duplicated the crash on a MacOS 10.9.4 machine. Ran fine on MacOS 10.8.5 and Windows 7.
Mixed results on Linux.

Problem report filed.
POSTED BY: Bruce Miller

Dear Vitaliy,

I have submitted the report. Also I tried four Macs with slightly different specifications, all on Mavericks, and they all crash at the same command.

Cheers, Marco
POSTED BY: Marco Thiel

Thanks for the kind words and sorry for the crash. Please do send the report. I wonder if anyone else experience this.

POSTED BY: Vitaliy Kaurov

Dear Vitaliy,

very nice indeed! I wanted to have a look at that but interestingly my system:

"10.0 for Mac OS X x86 (64-bit) (June 29, 2014)"

reproducibly crashes during the execution of the last command. I can send you the crash report.

Best wishes, Marco
POSTED BY: Marco Thiel
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Tag limit exceeded
Note: Only the first five people you tag will receive an email notification; the other tagged names will appear as links to their profiles.
Reply Preview
Attachments
Remove
or Discard