9
$\begingroup$

I want to be able to show different connections between cities based on modes of transportation. For instance, you could walk to any city, but it would take a long time, you could take a train, but only to/from certain cities. Is it possible to display all of this on the same graph?

Here is what I tried:

Coords = {{40.6642738`, -73.9385004`}, {34.0193936`, -118.4108248`},
{41.8375511`, -87.6818441`}, {29.7804724`, -95.3863425`}}; 

foot =
{{"NewYork", "NewYork", "UnitedStates"} -> {"LosAngeles", 
    "California", "UnitedStates"}, {"NewYork", "NewYork", 
    "UnitedStates"} -> {"Chicago", "Illinois", 
    "UnitedStates"}, {"NewYork", "NewYork", 
    "UnitedStates"} -> {"Houston", "Texas", 
    "UnitedStates"}, {"LosAngeles", "California", 
    "UnitedStates"} -> {"NewYork", "NewYork", 
    "UnitedStates"}, {"LosAngeles", "California", 
    "UnitedStates"} -> {"Chicago", "Illinois", 
    "UnitedStates"}, {"LosAngeles", "California", 
    "UnitedStates"} -> {"Houston", "Texas", 
    "UnitedStates"}, {"Chicago", "Illinois", 
    "UnitedStates"} -> {"NewYork", "NewYork", 
    "UnitedStates"}, {"Chicago", "Illinois", 
    "UnitedStates"} -> {"LosAngeles", "California", 
    "UnitedStates"}, {"Chicago", "Illinois", 
    "UnitedStates"} -> {"Houston", "Texas", 
    "UnitedStates"}, {"Houston", "Texas", 
    "UnitedStates"} -> {"NewYork", "NewYork", 
    "UnitedStates"}, {"Houston", "Texas", 
    "UnitedStates"} -> {"LosAngeles", "California", 
    "UnitedStates"}, {"Houston", "Texas", 
    "UnitedStates"} -> {"Chicago", "Illinois", "UnitedStates"}};

car = {{"NewYork", "NewYork", "UnitedStates"} -> {"Chicago", 
     "Illinois", "UnitedStates"}, {"Houston", "Texas", 
     "UnitedStates"} -> {"LosAngeles", "California", 
     "UnitedStates"}, {"LosAngeles", "California", 
     "UnitedStates"} -> {"Houston", "Texas", 
     "UnitedStates"}, {"Houston", "Texas", 
     "UnitedStates"} -> {"Chicago", "Illinois", "UnitedStates"}};

plane = {{"NewYork", "NewYork", "UnitedStates"} -> {"LosAngeles", 
     "California", "UnitedStates"}};
train = {{"LosAngeles", "California", "UnitedStates"} -> {"Chicago", 
     "Illinois", "UnitedStates"}, {"Chicago", "Illinois", 
     "UnitedStates"} -> {"Houston", "Texas", 
     "UnitedStates"}, {"Houston", "Texas", 
     "UnitedStates"} -> {"NewYork", "NewYork", "UnitedStates"}};

Graph[foot, VertexCoordinates -> Reverse[Coords, 2], 
 VertexStyle -> Red, VertexSize -> .1, ImageSize -> 650]

If it helps, the overall goal I'm working towards is not just to display the modes of transportation visually, but to run calculations based on the modes of transportation and routes you could take.

Improve this question
$\endgroup$
0

4 Answers 4

Reset to default
7
$\begingroup$

Edit: OP wanted EdgeLabels which are easily added, and as pointed out this is M10 compatible only (with the introduction of multigraph)

In cases like this I always think that Properties are the best way to go, here I provide various Properties to the edges OP provided.

edgeProperties = Join[Property[#, {"TransportMode" -> "Foot", EdgeStyle -> Red, EdgeCapacity -> 1,
                          EdgeLabels -> 1}] & /@ foot,
                      Property[#, {"TransportMode" -> "Car", EdgeStyle -> Green, 
                                EdgeCapacity -> 4,EdgeLabels -> 4}] & /@ car,
                      Property[#, {"TransportMode" -> "Plane", EdgeStyle -> Blue, 
                                EdgeCapacity -> 200,EdgeLabels -> 200}] & /@plane,
                      Property[#, {"TransportMode" -> "Train", EdgeStyle -> Orange,
                                EdgeCapacity -> 100,EdgeLabels -> 100}] & /@ train];

These edges can now be provided to the Graph easily, in this case just the edge colours and EdgeCapacities are shown. Please note I used @belisarius conventions for the VertexCoordinates.

g1=Graph[edgeProperties, VertexLabels -> Placed["Name",Tooltip], VertexCoordinates -> 
                       Reverse[Coords, 2], VertexSize -> Medium]

enter image description here

GeoGraphics Update

Ignored GeoGraphics functionality last night, but it is worthwhile adding another method to those given in other answers - GeoRange->Entity["Country","UnitedStates"].

map = GeoGraphics[GeoRange -> Entity["Country", "UnitedStates"],GeoProjection -> "Equirectangular"];
Show[Graphics[map[[1, 1]]], g1]

enter image description here

Improve this answer
$\endgroup$
2
  • 1
    $\begingroup$ Nice +1. Perhaps it should be noted that this works in Version 10 only. $\endgroup$
    – kglr
    Sep 13, 2014 at 22:01
  • $\begingroup$ Thanks, I was racing the clock I thought - note now added. I'll add an example of using this with FindMinimumCostFlow if I can think of sensible logic for it. $\endgroup$
    – Charlie Joey Hadley
    Sep 13, 2014 at 22:06
5
$\begingroup$

In the following I have changed Coords to coords,otherwise same names.

pl = GeoGraphics[Point[Reverse /@ coords], 
   GeoRange -> {{20, 49}, {-120, -65}}];
col = {Red, Green, Blue, Orange};
all = {foot, car, plane, train};
grp = Graph[Join @@ all, 
   EdgeStyle -> 
    Join @@ MapThread[Map[Function[x, x -> #2], #1] &, {all, col}], 
   VertexCoordinates -> Reverse[coords, 2], VertexSize -> 0.1];
leg = LineLegend[col, {"foot", "car", "plane", "train"}];
res = Legended[Show[Graphics[pl[[1, 1]]], grp], leg]

enter image description here

I have only done basic formattting. Edge styles and labeling can be added.

Improve this answer
$\endgroup$
5
  • $\begingroup$ Lazily going from NYC to Houston I certainly would avoid the Appalachian Trail. "Anyway" - + 1 $\endgroup$
    – eldo
    Sep 14, 2014 at 3:23
  • $\begingroup$ As far as I can see, the OP thinks it's a good idea to go from Houston to LA on foot. I see you thought it better $\endgroup$
    – Dr. belisarius
    Sep 14, 2014 at 5:46
  • $\begingroup$ @belisarius...I am afraid I did not as much thought into this,eg did not check correspondence of vertices and labels, viz entities...so my error...not much time at present...alas as an antipodean don't Houston to LA is a map not the territory... $\endgroup$
    – ubpdqn
    Sep 14, 2014 at 6:59
  • $\begingroup$ @ubpdqn Don't worry too much. My solution has a similar problem. And I bet I'm too lazy to fix it. $\endgroup$
    – Dr. belisarius
    Sep 14, 2014 at 7:06
  • $\begingroup$ Well, against all odds I fixed it :) $\endgroup$
    – Dr. belisarius
    Sep 14, 2014 at 7:26
5
$\begingroup$

The following works without V10. We can't use the easier Graph[] because in v9 (and before) it doesn't support multigraphs.

NB: Your city coordinates doesn't match any particular city ordering, so I calculated my own.

It was much more difficult than I expected due to the need to circumvent this bug. Perhaps there is a simpler way, but I can't find it:

all = {plane, foot, car, train}[[All, All, All, 1]];
pathsNoDup = Union /@ Map[Sort, (Apply[List, all, {2}]), {2}];
cities = Union@Flatten@pathsNoDup;
cityRules = MapIndexed[# -> #2[[1]] &, cities];
edges = pathsNoDup /. cityRules;
edgesRules = Flatten@Apply[Rule, edges, {2}];
cols = {Red, Yellow, Green, Orange};

citiCoords = (Reverse /@ (CityData[#, "Coordinates"] & /@ cities));
vertexRules = MapIndexed[#2[[1]] -> #1 &, citiCoords];
alltits = {"Plane", "Foot", "Car", "Train"};


(* Here's the bug circumenting code. A shame *)
Module[{queue = {edges, edges}}, 
        g = (Module[{p = Position[queue, #2][[1, 2]]}, 
                  queue = DeleteCases[queue, #2, 3, 1];
                  {Join[cols, cols][[p]], Line[#1]}] &);
    gp = GraphPlot[edgesRules, EdgeRenderingFunction -> g, VertexCoordinateRules -> vertexRules]];

legend = Column@Thread[Style[#2, #1, 20, Bold] &[cols, alltits]];

map = Join @@ ((List @@ First@CountryData["USA", "Polygon"]));
Show[Graphics[Polygon@map, Background -> Darker@Gray, 
  Epilog -> Inset[legend, {Right, Bottom}, {Right, Bottom}]], gp]

Mathematica graphics

Improve this answer
$\endgroup$
1
  • 1
    $\begingroup$ very nice...black US silhouette nice contrast to edges and subtle legend +1 :) $\endgroup$
    – ubpdqn
    Sep 14, 2014 at 7:02
4
$\begingroup$

I'm late to the party and only want to show that you can shorten the input to such questions considerably by using Interpreter:

cities = Interpreter["City"][#] & /@ {"LosAngeles", "NewYork", "Chicago", "Houston"};

paths = GeoPath /@ Subsets[cities, {2}];

Column[{
  GeoGraphics[{Blue, Thick, paths}, GeoProjection -> "AzimuthalEquidistant", ImageSize -> 400],
  GeoGraphics[{Red, Thick, paths}, GeoProjection -> "Mercator", ImageSize -> 400]
  }]

enter image description here

Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.