I have a set of normal vectors along a curve and want to calculate the curvature at each point. I'm not sure how to do this. Thank you in advance for your help :)
-
1$\begingroup$ Hi ForeverHopeful and welcome to Mma.SE! Your question needs more from your side. Here it's considered helpful and polite to show your own efforts and share your data and code attempts in a well formatted form, so we can quickly see the problem you are facing. Please help us to help you and edit your question accordingly. Please explain better what is that you have. Numeric or analytic? Also, please take the tour, it will help you understand the site. If you write an excellent question it will inspire great answers. $\endgroup$– rhermansJun 18, 2018 at 17:06
-
3$\begingroup$ You could use the formula $|\kappa| = \|d{\bf n}/ds\|$. Some code/data to play with would make it easier for folks to show you how to code it. $\endgroup$– Michael E2Jun 18, 2018 at 17:21
2 Answers
You can use FrenetSerretSystem
combined with Interpolation
(using only the first parts of the input data and ignoring the part corresponding to the normals) as follows:
ClearAll[curvature, f, if]
curvature[f_, t_] := First@First@FrenetSerretSystem[{t, f[t]}, t]
Using data
with a structure similar to the one in Michael E2's answer:
f = Sin;
data = Table[{{x, f[x]}, Normalize@Cross@{1, f'[x]}}, {x, 0., 6., 0.1}];
arrows = Graphics[{Red, Arrowheads[.025], Arrow[{#, # + #2}] & @@@ data}];
if = Interpolation[data[[All, 1]]];
Show[ParametricPlot[Evaluate @ {{t, if[t]}, {t, curvature[if, t] }}, {t, 0, 2 Pi}],
arrows, PlotRange -> All]
Using f = # Sin[Cos@#]&
, we get
Aw heck, here's a first-order forward difference approximation to the derivative, with unit normal vectors generated from a sine graph. The curvature kappa
is shown in gold.
data = Table[{{x, Sin[x]}, Normalize@Cross@{1, Cos[x]}}, {x, 0., 6., 0.1}];
kappa = Ratios /@
MapAt[Norm, Differences@MapAt[Apply[ArcTan], data, {All, 2}], {All, 1}] //
Flatten;
Graphics[{
Thick,
{ColorData[97][1], Line[data[[All, 1]]]},
Arrow[{#, # + #2}] & @@@ data,
{ColorData[97][2], Line@Transpose@{MovingAverage[data[[All, 1, 1]], 2], kappa}}
}, Frame -> True, Axes -> True]
And here's a second-order central difference approximation to the derivative, which doesn't look a lot different from the above graphics:
kappa = Ratios /@
MapAt[Norm,
Differences[MapAt[Apply[ArcTan], data, {All, 2}], 1, 2], {All, 1}] //
Flatten;
Graphics[{
Thick,
{ColorData[97][1], Line[data[[All, 1]]]},
Arrow[{#, # + #2}] & @@@ data,
{ColorData[97][2], Line@Transpose@{data[[2 ;; -2, 1, 1]], kappa}}
}, Frame -> True, Axes -> True]