2
$\begingroup$

I have some set of points making a specific pattern. I want to find a linear mapping (dilations + translations) to find a similar pattern in a second larger set of points. I want to find the best (or at least a good) fit in the second data. I am having a problem getting Mathematica to find the best one.

Set of points:

p1={{{5,80},{20,100}},{{15,90},{35,90}},{{15,75},{35,75}},{{5,55},{35,55}},{{20,25},{35,35}},{{25,30},{25,75}},{{45,85},{85,85}},{{45,85},{45,20}},{{85,85},{85,20}},{{45,25},{85,25}},{{45,55},{85,55}},{{60,85},{65,100}}};
data=Flatten[p1,1]

enter image description here

Second larger set of points:

cities=CityData[{Large,"China"}];
coords=Select[Map[Reverse[CityData[#,"Coordinates"]]&,cities],Length[#]==2&]

enter image description here

Here is my function to find nearest point:

findNearest[p_,list_]:=list[[Ordering[Map[(p[[1]]-#[[1]])^2+(p[[2]]-#[[2]])^2&,list],1]]][[1]]

These seems to work based on this test:

Graphics[{Black,Map[Point,coords],Red,Point[{112,35}],Green,Point[findNearest[{112,35},coords]]}]

Next I set up a measure of how close a particular mapping got the points in data to the points in coords.

score[a_,b_,c_,d_]:=Sum[With[{p={{a,0},{0,b}}.data[[i]]+{c,d}},Sqrt[#.#]&@(p-findNearest[p,coords])],{i,1,Length[data]}]

I them asked Mathematica to find the best a,b,c,d for the transformation. I added the minimum requirements on the scaling coefficients a and b so that it doesn't just shrink it to a single point.

sol=Minimize[{score[a,b,c,d],a>0.05,b>0.05},{a,b,c,d}][[2]]

This however ends up with points which looks nothing like the original shape.

Graphics[{Black,Map[Point,coords],Red,Map[Point,Map[{{a,0},{0,b}}.#+{c,d}/.sol&,data]],Green,Line[Map[{{a,0},{0,b}}.#+{c,d}/.sol&,p1,{2}]],Blue,Map[Point,Map[findNearest[#,coords]&,Map[{{a,0},{0,b}}.#+{c,d}/.sol&,data]]],Pink,Line[Map[findNearest[#,coords]&,Map[{{a,0},{0,b}}.#+{c,d}/.sol&,p1,{2}],{2}]]}]

Solution found by Code

manually trying some other mappings I find ones that look more like the original. For example with a=0.05, b=0.05, c=114, d=34.5 I get the image:

Manual Solution

Checking my 'score' for both shows that my mapping is 'worse' so my question is how do I improve my methodology so that I get a more human acceptable better mapping.

$\endgroup$
1
$\begingroup$

the following code finds the best fit in different scales of the pattern.
you have to choose the scale.

scale = .28;
mean = Table[
p1 = {{{5, 80}, {20, 100}}, {{15, 90}, {35, 90}}, {{15, 75}, {35, 
   75}}, {{5, 55}, {35, 55}}, {{20, 25}, {35, 35}}, {{25, 
   30}, {25, 75}}, {{45, 85}, {85, 85}}, {{45, 85}, {45, 
   20}}, {{85, 85}, {85, 20}}, {{45, 25}, {85, 25}}, {{45, 
   55}, {85, 55}}, {{60, 85}, {65, 100}}};
data = Flatten[p1, 1];
p1 = Partition[#*scale + {i, j} & /@ data, 2];
data = Flatten[p1, 1];
p2 = Partition[Flatten[Nearest[coords, data], 1], 2];
Mean@Array[
 EuclideanDistance[Flatten[p1, 1][[#]], Flatten[p2, 1][[#]]] &, 
 24], {i, x = 95, 130}, {j, y = 17, 50}];
pos = First@Position[mean, Min@mean] + {x - 1, y - 1};
p1 = {{{5, 80}, {20, 100}}, {{15, 90}, {35, 90}}, {{15, 75}, {35, 
 75}}, {{5, 55}, {35, 55}}, {{20, 25}, {35, 35}}, {{25, 30}, {25, 
 75}}, {{45, 85}, {85, 85}}, {{45, 85}, {45, 20}}, {{85, 85}, {85,
  20}}, {{45, 25}, {85, 25}}, {{45, 55}, {85, 55}}, {{60, 
 85}, {65, 100}}};
data = Flatten[p1, 1];
p1 = Partition[#*scale + pos & /@ data, 2];
data = Flatten[p1, 1];
p2 = Partition[Flatten[Nearest[coords, data], 1], 2];
Graphics[{Point[coords], Green, Line[p1], Red, Line@p2}]
p2     

enter image description here

{{{115.317, 38.4167}, {115.48, 38.87}}, {{115.317, 38.4167}, {116.1, 38.45}}, {{115.567, 38}, {116.1, 38.45}}, {{115.36, 37.37}, {116.3, 37.45}}, {{115.68, 36.85}, {115.68, 36.85}}, {{115.68, 36.85}, {115.567, 38}}, {{116.1, 38.45}, {117.351, 38.3683}}, {{116.1, 38.45}, {115.97, 36.43}}, {{117.351, 38.3683}, {117.491, 36.7583}}, {{115.97, 36.43}, {117.491, 36.7583}}, {{116.3, 37.45}, {117.217, 37.7333}}, {{116.87, 38.32}, {116.87, 38.32}}}

and you can try different scales

scale = .04;    

enter image description here

scale = .08;    

enter image description here

scale = .12;    

enter image description here

or make a Table for scales and choose the best one (but it will take some time to calculate)

$\endgroup$
  • $\begingroup$ Thanks. So much neater approach than mine. So many built in functions I didn't realise existed. $\endgroup$ – Ian Miller Nov 21 '18 at 11:36

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.