# Extracting road curves from an image

I have taken several gps readings while driving around town.

gpsPositions=GeoPosition[{{33.657, -84.5197}, {33.6687, -84.4977},
{33.692, -84.4907}, {33.7057, -84.4287}, {33.7431, -84.4027}, {33.7285,
-84.3493}}]

map = GeoGraphics[GeoMarker[gpsPositions],
GeoRange ->Entity["City",{"Atlanta","Georgia","UnitedStates"}],ImageSize->Large]


Were are able to extract the main roads by the following functions:

    bgnd = GeoGraphics[ GeoRange ->Entity["City",{"Atlanta","Georgia","UnitedStates"}],ImageSize->Large];
Dilation[#, DiskMatrix[3]] & /@
DominantColors[bgnd, 7, {"CoverageImage", "Color"}][[5 ;; 6, 1]]];


Road Extraction worked fine. Now convert the gpsPositions and map them to the road image.

range = Abs[#1 - #2] & @@@ map[[8, 2]]
origin = #1 & @@@ map[[8, 2]];
waypoints = gpsPositions[[1]];
points = Reverse@(Round[(max (#)/range), 1]) & /@ ((# - origin) & /@
waypoints);
Graphics[{Red, PointSize[Large], Point[points]}]]


I would like to be able to segment the lines between the dots. Then, set up an interpolation function between each dot so we can simulate the placement of the vehicle at any point of the road as needed.

Any thoughts on how this can be achieved?

• range appears to be undefined. Mar 23, 2015 at 22:41

I'm not 100% sure what you want: "segmentation" has a well-defined meaning in image processing, and I think that's not what you want. Also, I couldn't reproduce your results (I think DominantColors isn't guaranteed to give the same order or even the same results every time it's run). So this may or may not help...

First, this seems more reproducible than DominantColors:

roadColors = List @@@ {Yellow, Blue};

colorDist =
Total[(# -
Transpose[
ImageData[bgnd][[All, All, ;; 3]], {2, 3, 1}])^2] & /@

MorphologicalBinarize[
DiskMatrix[3]], {0.43, 0.8}]]


Next, I convert the white pixel locations to a graph:

whitePixels = PixelValuePositions[roads, 1];

nearestFn = Nearest[whitePixels -> Automatic];

Function[{point, potentialNeighbors},
point <-> # & /@
Select[potentialNeighbors,
0 < EuclideanDistance[whitePixels[[#]], whitePixels[[point]]] <
2 &]],
{Range[Length[whitePixels]], nearestFn[#, 10] & /@ whitePixels}];

g = Graph[DeleteDuplicates@Flatten[edges]];


Now, if I choose point locations in the image:

pts = {{133, 97}, {464, 461}};


I can use nearestFn to find the nearest road pixel, and FindShortestPath to find the shortest path between two points:

path = FindShortestPath[g, nearestFn[pts[[1]]][[1]],
nearestFn[pts[[2]]][[1]]];

Show[Image@bgnd,
Graphics[{Red, Line[whitePixels[[path]]], PointSize[Large],
Point[whitePixels[[path[[;; ;; 10]]]]]}]]


We can even make a little Indiana Jones-style animation:

Animate[Show[Image@bgnd,
Graphics[{Red, Thick, Line[whitePixels[[path[[;; i ;; 2]]]]]}]], {i,
1, Length[path], 1}]


(unfortunately, I don't think I can upload videos to Mathematica.SE)

• I'm getting the error Nearest::dmtch: The dimension of... does not match when evaluating the second code block. Mar 23, 2015 at 22:43
• @Nikie, this is what I wanted to achieve. Thx. I'll be checking the code a wee bit later. Any recommendation for changing the title to something more meaningful? Mar 23, 2015 at 23:04
• @Nikie, have you done anything special with the definition of bgnd? I get the following error message Show::gcomb: Could not combine the graphics objects in Show Mar 23, 2015 at 23:58
• @Zviovich: I've used bgnd=Image[bgnd], to make my experiments with colorDist faster. I didn't realize this changed the behavior of Show. I've updated my answer. Regarding the title: Maybe something like "Extracting road graphs from an image"? Mar 24, 2015 at 6:55
• @Pickett: Weird. The documentation doesn't say that this syntax is new, and I could have sworn I've used it like this since v8. OTOH, the speed difference isn't that large (in this case) so I'll change it to your version. Mar 24, 2015 at 9:06