Find lengths of contours in a ContourPlot - Mathematica Stack Exchange most recent 30 from mathematica.stackexchange.com 2019-11-21T08:30:05Z https://mathematica.stackexchange.com/feeds/question/46383 https://creativecommons.org/licenses/by-sa/4.0/rdf https://mathematica.stackexchange.com/q/46383 4 Find lengths of contours in a ContourPlot pirtle https://mathematica.stackexchange.com/users/13812 2014-04-19T02:05:48Z 2014-04-22T04:07:52Z <p>I am trying to find the lengths of different contours in the following plot:</p> <p><img src="https://i.stack.imgur.com/6qsD1.jpg" alt="ContourPlot of interest!!"></p> <p>It is a complicated piecewise function evaluated on the unit disk. I am hoping there is an easy, generalized way to numerically approximate each of the contours' lengths.</p> <p>Essentially, I am looking for a way to solve for the length of a homogenous equation bound by a region. Given a function <code>f(x,y) - f* == 0</code> on a region <code>R</code>, where <code>f*</code> is the value of the contour of interest, is there a way to find the length of the curve that satisfies that equation?</p> <p>For concreteness, the above is the <code>ContourPlot</code> of </p> <pre><code>q[r_] := Piecewise[{{25/(0.1*1), r &lt; 0.1}, {25/r, r &gt;= 0.1}}] phi[r_, t_] := (Pi/2) + q[r]*t v[r_, t_] := q[r]*r*Cos[phi[r, t]] s[x_] := Piecewise[{{x = -1, x &lt; 0}, {x = 1, x &gt;= 0}}] f[x_,y_] := s[x]*v[Sqrt[x^2 + y^2],ArcTan[y/x]/q[Sqrt[x^2 + y^2]]] </code></pre> <p>How does one numerically find the lengths of each of those contours?</p> https://mathematica.stackexchange.com/questions/46383/-/46524#46524 4 Answer by chris for Find lengths of contours in a ContourPlot chris https://mathematica.stackexchange.com/users/1089 2014-04-21T13:43:06Z 2014-04-21T13:43:06Z <p>How about </p> <pre><code>pl = ContourPlot[f[x, y], {x, -1, 1}, {y, -1, 1}, RegionFunction -&gt; Function[{x, y}, x^2 + y^2 &lt; 1], PlotPoints -&gt; 25,ContourShading -&gt; False] </code></pre> <p><img src="https://i.stack.imgur.com/9CHX8.png" alt="Mathematica graphics"></p> <p>Then </p> <pre><code>lines = Cases[pl // Normal, Line[pts_] :&gt; List[pts], Infinity]; lines = Select[lines, Length[#[]] &gt; 20 &amp;]; lines = Map[Flatten[Transpose[#], 1] &amp;, lines]; </code></pre> <p>Picking up the first segment;</p> <pre><code> l1 = lines[]; ListLinePlot[l1] </code></pre> <p><img src="https://i.stack.imgur.com/MVMoq.png" alt="Mathematica graphics"></p> <p>So that the Length is just</p> <pre><code> pts = (l1 - RotateLeft[l1] // Most); Total@ Map[Norm, pts] </code></pre> <p>(* 1.91 *)</p> <p>If you want all lengths, then loop</p> <pre><code> Table[l1 = lines[[i]];pts = (l1 - RotateLeft[l1] // Most);Total@ Map[Norm, pts], {i, Length[lines] - 1}] </code></pre> <p>(* {1.91801,1.9595,1.98317,1.99609,1.9987,1.99605,1.9832,1.95951,1.91821} *)</p>