InterpolationOrder creates a sharp valley even if I increase the number of points. How to have a smooth curve?

Question

I have a set of data as the following

data = {{-(1/10), 0.1231238244553477`}, {0, 0.11842669584606009}, {1/
   10, 0.11295156506691292`}, {1/5, 0.10626995173555345`}, {1/4, 
   0.10225817762630054`}, {27/100, 0.10051846336254686`}, {7/25, 
   0.09963726811580004`}, {29/100, 0.09877358379658636`}, {3/10, 
   0.0979774456159904`}, {63/200, 0.09726355431994167`}, {8/25, 
   0.0974294913135746`}, {13/40, 0.09826117039951159`}, {1/3, 
   0.1265770484367747`}}

ListPloting the data

ListPlot[data, Frame -> True, Axes -> None, FrameStyle -> Black, 
 BaseStyle -> FontSize -> 13, RotateLabel -> True, PlotStyle -> Blue, 
 PlotRange -> {5/100, 15/100}, Joined -> True, 
 InterpolationOrder -> 3]

leads to the following plot

While keeping the interpolationOrder, I want to have a smooth graph without a sharp valley, something like the red curve in the following plot

What should I do?

p.s., Increasing the number of points didn't solve the problem.

I saw a similar plot in a paper:

Answer 1

First, hunting for a method that makes your data look nicer than standard methods looks suspicious, speaking as someone from outside science.

That said, here's a standard method, Eugene Lee's "centripetal" parametrization. See this answer by @J.M for more, including a reference.

parametrizeCurve[pts_List, a : (_?NumericQ) : 1/2] := 
  FoldList[Plus, 0, Normalize[(Norm /@ Differences[pts])^a, Total]] /;
    MatrixQ[pts, NumericQ];

tvals = parametrizeCurve[data, 0.6]; (* a = 0.6 *)
plot = ParametricPlot[
  Evaluate[Interpolation[Transpose@{tvals, data}, t]],
  {t, 0, 1}, AspectRatio -> 0.61, Frame -> True] (*//
 Show[#,
   Graphics[{First@
      Cases[Cases[#, {___, _Line, ___}, Infinity], _Directive, 
       Infinity],
     PointSize@Medium, Point@data}]
   ] &*)

Uncomment the Show[..] code to see the data points marked.

Note that Lee's method is a standard in computer design, not data analysis AFAIK. But it makes a pretty curve, if that is important. Searching for the value 0.6 for the parameter a is still a bit like $P$-hunting. While 0.7 looks a little nicer, the following shows whether the plot is the graph of a function (shows whether the horizontal coordinate steadily increases):

Cases[Normal@plot, _Line, Infinity][[1, 1, All, 1]] // 
  Differences // Min // Positive
(* True (a=0.6), False (a=0.7) *)

---

Update: Hacking Interpolation

If you want to be sure you have a function, you can adjust the derivatives at the interpolation nodes "by eye" to get a good looking plot:

ddata = NDSolve`FiniteDifferenceDerivative[
   1,                        (* first derivative *)
   data[[All, 1]],           (* grid ("x" values) *)
   data[[All, 2]],           (* function values *)
   "DifferenceOrder" -> 2];  (* central diff. rule *)
ddata = ReplacePart[         (* adjust f' by hand *)
   ddata, {-2 :> 0.3, -3 :> 0.08}]; 
ip = Interpolation[
   Transpose@{List /@ data[[All, 1]], data[[All, 2]], ddata}];
Plot[ip[x],
 {x, data[[1, 1]], data[[-1, 1]]},
 Frame -> True]

Again, you have to hunt for a=0.3 and b=0.08. (Using Manipulate[] is easiest.)

Answer 2

You are creating the "valley" yourself by using polynomial interpolation. Polynomials always overshoot if the slope changes rapidly.

What to do? You can ask yourself if high degree interpolation is really necessary, because the data is rather smooth:

ListLinePlot[data]

If you insists on interpolation by some curve, you may try Interpolation together with a spline method and InterpolationOrder->1. With this you get:

f = Interpolation[data, Method -> "Spline", InterpolationOrder -> 1];
Plot[f[x], {x, -0.10, .4}, PlotRange -> {0.09, .15}]

However, even if you increase the interpolation order by only, 1 you get some artefacts:

f = Interpolation[data, Method -> "Spline", InterpolationOrder -> 2]; Plot[f[x], {x, -0.10, .4}, PlotRange -> {0.09, .15}]

Answer 3

modified

Try Method -> "Hermite"

ip = Interpolation[data, Method -> "Hermite", InterpolationOrder -> 2 ];
Show[{Plot[ip[x], {x, -.1, .4}, PlotRange -> {0.09, .15}],ListPlot[data]}]

addendum

Inspired from @MichaelE2' comments here I show two alternatives ResourceFuncion["MonotonicInterpolation"] and pchip ( thanks to @J. M.'s lack of A.I. )

monotonic interpolation

Plot[ResourceFunction["CubicMonotonicInterpolation"][data][
  x], {x, .3, .35}, Axes -> None, 
 Epilog -> {Red, AbsolutePointSize[4], Point[data]}, Frame -> True
 , PlotRange -> {.05, .15}]

pchip

fcint[data_] := 
 Module[{del, slopes, tau}, del = #2/#1 & @@@ Differences[data];
  slopes = Flatten[{del[[1]], MovingAverage[del, 2], del[[-1]]}];
  tau = MapThread[Min, 
    Through[{Append, Prepend}[
      Min[#, 1] & /@ (3 del/(Norm /@ Partition[slopes, 2, 1])), 1]]];
  Interpolation[
   Transpose[{List /@ data[[All, 1]], data[[All, -1]], slopes tau}], 
   InterpolationOrder -> 3, Method -> "Hermite"]]

 Plot[fcint[data][x], {x, .3, .35}, Axes -> None, 
 Epilog -> {Red, AbsolutePointSize[4], Point[data]}, Frame -> True
 , PlotRange -> {0, .15}]

Both alternatives avoid valleys! Perhaps monotonic interpolation gives better extrapolation ...

Whether the additional effort of the two last variants is worthwhile compared with the first approach Hermite/InterpolationOrder->2 seems doubtful