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.

$\endgroup$
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

$\endgroup$
  • 1
    $\begingroup$ Nice +1. Perhaps it should be noted that this works in Version 10 only. $\endgroup$ – kglr Sep 13 '14 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$ – Martin John Hadley Sep 13 '14 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.

$\endgroup$
  • $\begingroup$ Lazily going from NYC to Houston I certainly would avoid the Appalachian Trail. "Anyway" - + 1 $\endgroup$ – eldo Sep 14 '14 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 '14 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 '14 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 '14 at 7:06
  • $\begingroup$ Well, against all odds I fixed it :) $\endgroup$ – Dr. belisarius Sep 14 '14 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

$\endgroup$
  • 1
    $\begingroup$ very nice...black US silhouette nice contrast to edges and subtle legend +1 :) $\endgroup$ – ubpdqn Sep 14 '14 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

$\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.