# Linear mapping to fit points to subset of other points

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] Second larger set of points:

cities=CityData[{Large,"China"}];
coords=Select[Map[Reverse[CityData[#,"Coordinates"]]&,cities],Length[#]==2&] Here is my function to find nearest point:

findNearest[p_,list_]:=list[[Ordering[Map[(p[]-#[])^2+(p[]-#[])^2&,list],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}][]


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}]]}] 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: 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.

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


{{{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;

scale = .08;

scale = .12;


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

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