Group Abstract

Message Boards

WOLFRAM COMMUNITY

7.6K Views

4 Replies

0 Total Likes

View groups...

Follow this post

Share this post:

GROUPS:

Find optimal match of points in 3-Dimensional space?

Haobo Xia

Posted 6 years ago

POSTED BY: Haobo Xia

4 Replies

Sort By:

Henrik Schachner

Henrik Schachner, Radiation Therapy Center, Weilheim, Germany

Posted 6 years ago

Hello Haobo Xia, my idea here is to use `FindShortestTour` - and to prohibit any direct step between points of the same set: aPts = RandomReal[{-1, 0}, {10, 3}]; bPts = RandomReal[{0, 1}, {10, 3}]; pts = Join[aPts, bPts]; sameListQ[a_, b_] := (MemberQ[aPts, a] && MemberQ[aPts, b]) \|\| (MemberQ[bPts, a] && MemberQ[bPts, b]) {length, order} = FindShortestTour[pts, DistanceFunction -> (If[sameListQ[#1, #2], Infinity, EuclideanDistance[#1, #2]] &)]; Graphics3D[{Black, Dashed, Line[pts[[order]]], PointSize[Large], Red, Point[aPts], Green, Point[bPts]}] Well, so much for this idea. The problem now seems to be that with this kind of `DistanceFunction` the function `FindShortestTour` does not work for more than about 20 points - at least on my system ("12.1.0 for Linux x86 (64-bit) (March 14, 2020)"). Does that help, anyway? Regards -- Henrik

Hello Haobo Xia,

my idea here is to use FindShortestTour - and to prohibit any direct step between points of the same set:

aPts = RandomReal[{-1, 0}, {10, 3}];
bPts = RandomReal[{0, 1}, {10, 3}];
pts = Join[aPts, bPts];

sameListQ[a_, b_] := (MemberQ[aPts, a] && MemberQ[aPts, b]) || (MemberQ[bPts, a] && MemberQ[bPts, b])

{length, order} = 
  FindShortestTour[pts, 
   DistanceFunction -> (If[sameListQ[#1, #2], Infinity, EuclideanDistance[#1, #2]] &)];

Graphics3D[{Black, Dashed, Line[pts[[order]]], PointSize[Large], Red, Point[aPts], Green, Point[bPts]}]

enter image description here

Well, so much for this idea. The problem now seems to be that with this kind of DistanceFunction the function FindShortestTour does not work for more than about 20 points - at least on my system ("12.1.0 for Linux x86 (64-bit) (March 14, 2020)"). Does that help, anyway?

Regards -- Henrik

POSTED BY: Henrik Schachner

Haobo Xia

Posted 6 years ago

Hello Henrik Schachner, Thank you, it is a creative idea but it need further processing and although it work for large amount of points on my system (Windows 10), it still slower than FindMinimumCostFlow, and sometimes it does not give right answer for my problem. Regards -- Haobo Xia (My Function) ca[n_] := ca[n] = ConstantArray[0, {n, n}] PointsMatch[s1_, s2_] := If[s1 == s2, {IdentityMatrix[#], 0}, Extract[FindMinimumCostFlow[ ArrayFlatten[{{0, 1., 0, 0}, {0, 0, DistanceMatrix[s1, s2, DistanceFunction -> EuclideanDistance], 0}, {0, ca[#], 0, -1.}, {0, 0, 0, 0}}], 1, 2# + 2, "OptimumFlowData"][{"FlowMatrix", "CostValue"}], {{1, Range[2, 1 + #], Range[# + 2, 2# + 1]}, {2}}]] &@Length[s1] aPts = RandomReal[{-10, 10}, {8, 3}]; bPts = RandomReal[{-10, 10}, {8, 3}]; pts = Join[aPts, bPts]; (By MaximizeOverPermutations) AbsoluteTiming[ MaximizeOverPermutations[-Plus @@ MapThread[EuclideanDistance, {aPts, bPts[[#]]}] &, 8]] (By FindShortestTour) AbsoluteTiming[{length, order} = FindShortestTour[pts, DistanceFunction -> (If[sameListQ[#1, #2], Infinity, EuclideanDistance[#1, #2]] &)]; MinimalBy[{Plus @@ (EuclideanDistance@(Sequence @@ pts[[#]]) & /@ #), #} & /@ (Partition[#, 2] & /@ {Rest[ order], order}), First]] (By FindMinimumCostFlow) AbsoluteTiming[MatrixForm /@ PointsMatch[aPts, bPts]]

Hello Henrik Schachner,

Thank you, it is a creative idea but it need further processing and although it work for large amount of points on my system (Windows 10), it still slower than FindMinimumCostFlow, and sometimes it does not give right answer for my problem.

Regards -- Haobo Xia

(*My Function*)
ca[n_] := ca[n] = ConstantArray[0, {n, n}]
PointsMatch[s1_, s2_] := 
 If[s1 == s2, {IdentityMatrix[#], 0}, 
    Extract[FindMinimumCostFlow[
       ArrayFlatten[{{0, 1., 0, 0}, {0, 0, 
          DistanceMatrix[s1, s2, 
           DistanceFunction -> EuclideanDistance], 0}, {0, ca[#], 
          0, -1.}, {0, 0, 0, 0}}], 1, 2*# + 2, 
       "OptimumFlowData"][{"FlowMatrix", "CostValue"}], {{1, 
       Range[2, 1 + #], Range[# + 2, 2*# + 1]}, {2}}]] &@Length[s1]
aPts = RandomReal[{-10, 10}, {8, 3}];
bPts = RandomReal[{-10, 10}, {8, 3}];
pts = Join[aPts, bPts];
(*By MaximizeOverPermutations*)
AbsoluteTiming[
 MaximizeOverPermutations[-Plus @@ 
     MapThread[EuclideanDistance, {aPts, bPts[[#]]}] &, 8]]
(*By FindShortestTour*)
AbsoluteTiming[{length, order} = 
  FindShortestTour[pts, 
   DistanceFunction -> (If[sameListQ[#1, #2], Infinity, 
       EuclideanDistance[#1, #2]] &)];
 MinimalBy[{Plus @@ (EuclideanDistance@(Sequence @@ 
            pts[[#]]) & /@ #), #} & /@ (Partition[#, 2] & /@ {Rest[
       order], order}), First]]
(*By FindMinimumCostFlow*)
AbsoluteTiming[MatrixForm /@ PointsMatch[aPts, bPts]]

enter image description here