Convert image of graph to Graph [duplicate]

Question

The board game Ticket To Ride has a board readily represented as a graph. I have an image of a graph (taken from BoardGameGeek) that I'd like to convert to graph in Mathematica for further analysis.

I've used the following code which does produce a graph but it has too many (100) vertices.

img=Import["TTR-E.png"];
g = MorphologicalGraph[Binarize[ColorNegate[img]]];

I've tried the following to clean it up but it doesn't produce the GUI window as it should. In any case I'd like to convert it without such intervention.

Needs["GraphUtilities`"]
GraphEdit[g]

As a bonus I'd like to import the thick edges as two separate edges and the red (tunnels) and blue(ferries) edges with special labels. Eventually I can add edge lengths (route lengths), colors for edges (route colors) and vertex labels (city names).

Answer 1

On my system, MorphologicalGraph with the default Method can't seem to find all the vertices of the graph. I ended up with the following to get an initial graph that at least has all the vertices:

g=MorphologicalGraph[
    Thinning[Binarize @ ColorNegate @ image, 3, Method->"MedialAxis"]
]

This version of the graph had even more vertices than yours:

VertexCount @ g
(* 163 *)

Rather than trying to adjust the Image so that MorphologicalGraph would produce fewer vertices, I decided to post-process the Graph to eliminate extra vertices. First, here are the initial vertices:

vertexRules = Thread @ Rule[
    PropertyValue[g, VertexCoordinates],
    VertexList[g]
];

Now, using the fact that there should be 47 vertices, we can use FindClusters to group vertices that should be the same:

clusters = FindClusters[vertexRules, 47];

If I just use the FindClusters[vertexRules] I get 48 clusters, because one of the vertices at the top right gets displaced too far from the others. At any rate, using these clusters, we can come up with a list of rules to eliminate extra vertices:

substitutes = Flatten @ Replace[
    clusters,
    {
        {_}->Sequence[],
        {a__,b_}:>Thread[Rule[{a},b]]
    },
    {1}
]

Using the above rules, we can replace the vertices in the original edge list with a representative from each cluster:

edges = DeleteDuplicates @ DeleteCases[
    EdgeList[g] /. substitutes,
    x_<->x_
]

After replacing the vertices with the representatives, there are many self-loops and multiedges that need to be pruned, which explains the need for DeleteDuplicates and DeleteCases. Now, all that's left to do is to position the vertices in the right spots:

graph = Graph[
    edges,
    VertexShapeFunction -> "Square",
    VertexSize -> Large,
    VertexCoordinates -> SortBy[vertexRules, Last][[VertexList[edges], 1]]
]