En route to Mobile (driving distances)

Question

I want to find a nice way to display driving distances, but got stuck with the following problem:

1. Example data

vlist = {"Boston" -> 0, "Chicago" -> 80, "Denver" -> 160, 
   "Eugene" -> 40, "Fresno" -> 40, "Gary" -> 50, "Houston" -> 180, 
   "Irvine" -> 120, "Mobile" -> 50};

wlist = {"Boston" -> 0, "Canton" -> 100, "Dayton" -> 220, 
   "Erie" -> 70, "Francfort" -> 40, "Gary" -> 90, "Haggerton" -> 140, 
   "Mobile" -> 200};

vcum = Accumulate @ Values @ vlist;

vvals = Map[Append[1] @* List] @ vcum;

vplot = Transpose[{vvals, Keys @ vlist}] /. {{a_, b_}, c_} :> Callout[{a, 1}, c];

wvals = Map[Append[2] @* List] @ Accumulate @ Values @ wlist;

wplot = Transpose[{wvals, Keys @ wlist}] /. {{a_, b_}, c_} :> Callout[{a, 2}, c];

2. First possibility

ListPlot[{vplot, wplot},
 AspectRatio -> 1/4,
 BaseStyle -> Thickness[0.0015],
 Frame -> True,
 FrameTicks -> {{{1, 2}, None}, {vcum, None}},
 GridLines -> {vcum, None},
 GridLines -> {Automatic, None},
 ImageSize -> 700,
 PlotMarkers -> "OpenMarkers",
 PlotRange -> {All, {0.5, All}},
 Epilog ->
  {{ColorData[97, "ColorList"][[1]], Line[{{0, 1}, {Max @ vvals, 1}}]},
   {ColorData[97, "ColorList"][[2]], Line[{{0, 2}, {Max @ wvals, 2}}]}}
 ]

The advantages of this display form are the scaled distances between towns and the scaling between the two alternate routes. One big disadvantage is that we don't directly see the distance from one town to the next town. With other words: I don't know how to place a label of 160 between Chicago and Denver.

2. Second possibilty

The latter problem is nicely solved in this answer of kglr:

List processing to find distances between towns

vpath = Thread[Keys @ vlist -> vcum];

PathGraph[vpath[[All, 1]],
 EdgeWeight -> Differences[vpath[[All, 2]]],
 EdgeLabels -> Placed["EdgeWeight", {1/2, {1/2, 3/2}}],
 VertexWeight -> vlist,
 VertexLabels -> {v_ :> Placed[{v, v /. vpath}, {Above, Below}, Rotate[#, 90 Degree] &]},
 ImageSize -> Large,
 BaseStyle -> 10]

The disadvantage here is the missing scaling between the towns. Not being familiar at all with the countless Graph display options, I don't know how to overcome this limitation.

3. Question

Can we combine the advantages of ListPlot (scaling) and PathGraph (labeling)?

4. Note

The addition of an alternate route is purely optional

Answer 1

pathGraph = PathGraph[#[[All, 1]], 
    EdgeWeight -> Differences[#[[All, 2]]], 
    EdgeLabels -> Placed["EdgeWeight", {1/2, {1/2, #4}}, Rotate[#, 90 Degree] &],
    VertexWeight -> Prepend[0] @ Differences[#[[All, 2]]], 
    VertexSize -> Medium, 
    VertexStyle -> #3, 
    EdgeStyle -> Lighter @ #3, 
    VertexLabels ->
        {v_ :> Placed[{v, v /. #}, {Above, Below}, Rotate[#, 90 Degree] &]}, 
    ImageSize -> Large, 
    VertexCoordinates -> Thread[{#[[All, 2]], #2}], 
    BaseStyle -> 14] &;


vpath = Thread[Keys @ vlist -> Accumulate @ Values @ vlist];
wpath = Thread[Keys @ wlist -> Accumulate @ Values @ wlist];

Show[MapApply[pathGraph]@
 {{vpath, 50, Blue, 3/2}, {wpath, 200, Orange, 3/2}}, 
 ImageSize -> 900]

Answer 2

Using GeoGraphics

$Version

(* "13.3.1 for Mac OS X ARM (64-bit) (July 24, 2023)" *)

Clear["Global`*"]

vlist = Entity["City", {#[[1]], #[[2]], "UnitedStates"}] & /@ {{"Boston", 
     "Massachusetts"}, {"Chicago", "Illinois"},
    {"Denver", "Colorado"}, {"Eugene", "Oregon"},
    {"Fresno", "California"}, {"Gary", "Indiana"},
    {"Houston", "Texas"}, {"Irvine", "California"},
    {"Mobile", "Alabama"}};

wlist = Entity["City", {#[[1]], #[[2]], "UnitedStates"}] & /@
   {{"Boston", "Massachusetts"}, {"Canton", "Ohio"},
    {"Dayton", "Ohio"}, {"Erie", "Pennsylvania"},
    {"Frankfort", "Kentucky"}, {"Gary", "Indiana"},
    {"Hagerstown", "Maryland"}, {"Mobile", "Alabama"}};

vpos = GeoPosition /@ vlist;

wpos = GeoPosition /@ wlist;

{vdist, vtour} = FindShortestTour[vpos, vpos[[1]], vpos[[Length[vlist]]]]

(* {Quantity[5316.73, "Miles"], {1, 6, 2, 3, 4, 5, 8, 7, 9}} *)

{wdist, wtour} = FindShortestTour[wpos, wpos[[1]], wpos[[Length[wlist]]]]

(* {Quantity[1908.77, "Miles"], {1, 7, 4, 2, 6, 3, 5, 8}} *)

vdistances = Round[TravelDistanceList[vpos[[vtour]]] // Normal]

(* {Quantity[964, "Miles"], Quantity[30, "Miles"], Quantity[1001, "Miles"], 
 Quantity[1368, "Miles"], Quantity[643, "Miles"], Quantity[263, "Miles"], 
 Quantity[1530, "Miles"], Quantity[465, "Miles"]} *)

wdistances = Round[TravelDistanceList[wpos[[wtour]]] // Normal]

(* {Quantity[457, "Miles"], Quantity[298, "Miles"], Quantity[145, "Miles"], 
 Quantity[359, "Miles"], Quantity[261, "Miles"], Quantity[141, "Miles"], 
 Quantity[659, "Miles"]} *)

Manipulate[
 GeoGraphics[{{Style[Tooltip[Line[#[[1]]], #[[2]]], Thick, Red] & /@
      Transpose[{(TravelDirections /@ (Partition[vpos[[vtour]], 2, 1])),
        vdistances}],
     (Tooltip[GeoMarker[#[[1]], "Color" -> Opacity[0.5, Red]], #[[2]]] & /@ 
       Transpose[{vpos, vlist}])},
    {Style[Tooltip[Line[#[[1]]], #[[2]]], Thick, Blue] & /@
      Transpose[{(TravelDirections /@ (Partition[wpos[[wtour]], 2, 1])),
        wdistances}],
     (Tooltip[GeoMarker[#[[1]], "Color" -> Opacity[0.5, Blue]], #[[2]]] & /@ 
       Transpose[{wpos, wlist}])}}[[list]],
  ImageSize -> Large],
 {{list, {1, 2}}, {1 -> "vlist", 2 -> "wlist"}, ControlType -> TogglerBar},
 SynchronousUpdating -> False,
 TrackedSymbols :> {list}]

Answer 3

vv = vlist // Values;
labelpos = {#, 
    1} & /@ (Partition[Accumulate@(vlist // Values), 2, 1] // 
    Map[Mean]);

labels = MapThread[
  Text[Framed[ToString@#1, FrameMargins -> Tiny, Alignment -> Center, 
     RoundingRadius -> 3], #2, {0, 1.2}] &, {Rest@vv, labelpos}];

ListPlot[{vplot, wplot}
 , AspectRatio -> 1/4
 , BaseStyle -> Thickness[0.0015]
 , Frame -> True
 , FrameTicks -> {{{1, 2}, None}, {vcum, None}}
 , GridLines -> {vcum, None}
 , GridLines -> {Automatic, None}
 , ImageSize -> 700
 , PlotMarkers -> "OpenMarkers"
 , PlotRange -> {All, {0.5, All}}
 , ImageSize -> 400
 , Epilog -> {
   {ColorData[97, "ColorList"][[1]], 
    Line[{{0, 1}, {Max@vvals, 1}}]}, {ColorData[97, "ColorList"][[2]],
     Line[{{0, 2}, {Max@wvals, 2}}]}
   (* --- *)
   , labels
   }
 ]

The advantage of this solution is that it preserves the notion of relative distance as opposed to the PathGraph which shows the same information as edge weights.