1
$\begingroup$

I have a contour plot made of the following list:

axialP1plot={{1, 0, 0.0267704}, {2, 0, 0.0614223}, {3, 0, 0.0490435}, {4, 
  0, -6.93889*10^-18}, {0, 1, 0}, {1, 1, 0.0538961}, {2, 1, 
  0.116213}, {3, 1, 0.0866826}, {4, 1, 1.38778*10^-16}, {0, 2, 0}, {1,
   2, 0.115877}, {2, 2, 0.221253}, {3, 2, 0.1464}, {4, 
  2, -6.93889*10^-17}, {0, 3, 0}, {1, 3, 0.280374}, {2, 3, 
  0.409284}, {3, 3, 0.218886}, {4, 3, -4.16334*10^-17}, {0, 4, 0}, {1,
   4, 0.747612}, {2, 4, 0.565985}, {3, 4, 0.217183}, {4, 4, 
  9.71445*10^-17}, {0, 0, 0}}

Now, if I use the cose suggested in a previous question I get the following:

enter image description here

Calculating the total length Sum[Norm[pts[[i + 1]] - pts[[i]]], {i, Length[pts] - 1}] which gives 7.4025.

I tried modifying the code:

    contour = 
      line[[1]];(* Select the points belonging to the outer contour *)

    ynear1 = Nearest[
       Flatten[line[[1]]][[2 ;; ;; 
          2]], {0}];(* Find the smallest y value *) 
    ynear2 = Nearest[
      Flatten[line[[1]]][[1 ;; ;; 
         2]], {4}]; (* Find biggest value of x *)
    pos1 = 
     Position[Chop[Flatten[# - ynear1 & /@ contour[[All, 2]]]], 0] ;
    pos2 = Position[Chop[Flatten[# - ynear2 & /@ contour[[All, 1]]]], 
      0];(* Chop replaces approximate real numbers in expr that are close \
    to zero by the exact integer. Instead of finding the point with the \
    smallest y coordinate,we reformulate the problem so that we find 0 in \
    the list of differences with the smallest y *)

plot = ListContourPlot[axialP1plot, PlotRange -> All, 
   ColorFunction -> "Rainbow"];
lines = Cases[plot // Normal, Line[x_], Infinity];
contournum = 7;(*change if you want to do it for other contour \
line*)line = lines[[contournum]];
{x1, y1} = Flatten[contour[[Flatten[pos1[[1]]]]]];
{x2, y2} = Flatten[contour[[Flatten[pos2[[1]]]]]];

pts = Join[{{0, 0}, {x1, y1}}, 
   Reverse@Select[
     line[[1]], #[[1]] < (x1 + x2)/2 && #[[2]] < 
         y1 || (x1 + x2)/2 < #[[1]] && #[[2]] < y2 &], {{x2, y2}, {4, 
     4}}];

ListContourPlot[axialP1plot, PlotRange -> All, 
 ColorFunction -> "Rainbow", Epilog -> {Thick, Black, Line[pts]}]

Which gives:

enter image description here

The length of this line is now Sum[Norm[pts[[i + 1]] - pts[[i]]], {i, Length[pts] - 1}]equal to6.29071. Ideally, I would want the line to follow the contour and not cut across it. Can anyone suggest a better way for coding this?

$\endgroup$
  • 1
    $\begingroup$ The graph is not from the data you provided. I think you have to replace x and y and plot the fourth column as z. $\endgroup$ – Sumit Jun 9 '16 at 11:17
  • $\begingroup$ @Sumit you are right, it should be correct now. $\endgroup$ – GEF Jun 9 '16 at 11:18
1
$\begingroup$

I misunderstood your question first. This algorithm find the point of minimum distance on the curve from left and right corner, but does not minimise total length.

Point at minimum distance from the corners st and end

plot = ListContourPlot[axialP1plot, PlotRange -> All, ColorFunction-> "Rainbow"];
lines = Cases[plot // Normal, Line[x_], Infinity];
contournum = 7;(*change if you want to do it for other contour line*)
line = lines[[contournum]]; 

st = {0, 0};end = {4, 4};

{x1, y1} = RegionNearest[line, st];
{x2, y2} = RegionNearest[line, end];

pts = Join[{st, {x1, y1}}, Reverse@Select[ line[[1]], #[[1]] < (x1 + x2)/2
      && #[[2]]<y1 || (x1+x2)/2 < #[[1]] && #[[2]] < y2 &],{{x2, y2}, end}];

ListContourPlot[axialP1plot, PlotRange -> All, 
  ColorFunction -> "Rainbow", Epilog -> {Thick, Black, Line[pts], Red, Point[pts]}]

enter image description here

Total length of the path is

Sum[Norm[pts[[i + 1]] - pts[[i]]], {i, Length[pts] - 1}]

7.4025

Shortest path from st to end

Getting the Shortest path is much easier than this. In absence of the middle region, the shortest path path would be the straight line connecting the two corners. So just find the points that fall below or above the line. I use FindShortestTour to verify this assumption.

pts = Join[{st}, Reverse@line[[1]], {end}];
path = pts[[FindShortestTour[pts][[2]]]];

poly1 = Polygon[{st, {end[[1]], st[[2]]}, end}]; (*lower triangle*)
poly2 = Polygon[{st, {st[[1]], end[[2]]}, end}]; (*upper triangle*)
path1 = Select[pts, RegionMember[poly1, #] &]
path2 = Select[pts, RegionMember[poly2, #] &]

Show[ListContourPlot[axialP1plot, PlotRange -> All, ColorFunction -> "Rainbow"],
Graphics[{Line[path], Green, Line[{st, end}], PointSize[Large],
Red, Point[path1], Blue, Point[path2]}]]

enter image description here

Sum[Norm[path1[[i + 1]] - path1[[i]]], {i, Length[path1] - 1}]
Sum[Norm[path2[[i + 1]] - path2[[i]]], {i, Length[path2] - 1}]

6.6619

10.3517

So path1 is the answer you are looking for.

Note that in your second approach you did not select all the points which gave you smaller value for the total.

$\endgroup$
  • 1
    $\begingroup$ Very nice, but that's not the shortest path, is it? :) $\endgroup$ – Lukas Jun 9 '16 at 13:26
  • 1
    $\begingroup$ actually it is @Lukas . Notice that scale along x is 50 times the scale along y which, if con considered, will make you think that the nearest point is supposed to be far away from origin ;) . Don't just take my words, check the distance of each point from origin. $\endgroup$ – Sumit Jun 9 '16 at 17:46
  • $\begingroup$ Eeek... True ;) I didn't notice the different scale. Sorry for typing to fastly. $\endgroup$ – Lukas Jun 9 '16 at 17:48
  • $\begingroup$ @Sumit thank you for your answer! I am fairly new to Mathematica, could you please comment on your script so I can follow it better? $\endgroup$ – GEF Jun 10 '16 at 20:17
  • $\begingroup$ I added it to my answer @GEF. $\endgroup$ – Sumit Jun 10 '16 at 20:43

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.