2D smoothing spline interpolation

Does Mathematica have 2D smoothing spline interpolation built in? I requires an interpolation method with smooth first derivatives and cubic bivariate splines fulfill this nicely. In python I would use RectBivariateSpline or SmoothBivariateSpline.

A quick search only revealed this answer, which I guess could be adapted to 2D with some effort.

Here is some test data:

RANGEX = 8;
RANGEY = 8;
F[x_, y_] :=
Sin[.5 y] Cos[.9 x]/Sec[0.1 x y] -
0.01 (x^2 + y^2) RiemannSiegelZ[1.5 Sqrt[x^2 + y^2]]
data = N[Flatten[
Table[{x, y, F[x, y]}, {x, -RANGEX, RANGEX, 1}, {y, -RANGEY,
RANGEY, 1}], 1]];
data[[All, 3]] =
data[[All, 3]] +
RandomVariate[NormalDistribution[0, 0.1], Length[data]];

PlotPointsAndSurface[points_, surface_, label_] := Module[{},
Show[
ListPointPlot3D[points,
PlotStyle -> {Directive[PointSize[0.01], Red],
Directive[PointSize[0.01], Green]}, PlotLabel -> label,
ImageSize -> Medium],
Plot3D[surface, {x, -RANGEX, RANGEX}, {y, -RANGEY, RANGEY},
PlotStyle -> Directive[Purple, Opacity[0.2]]]
]];
PlotPointsAndSurface[data, F[x, y], "orig and noise"] • Can GaussianFilter with further Interpolation/ListInterpolation with Method -> "Spline" be helpful? – ybeltukov Oct 15 '14 at 18:57
• @ybeltukov Yes, GaussianFilter (or any other smoothing algorithm; perhaps a wavelet transform) + Spline interpolation would work as well. – Ajasja Oct 15 '14 at 20:56
• @RahulNarain Indeed, but the surface also goes through every point, which if there is noise is not desirable. – Ajasja Oct 16 '14 at 11:11

Here is a Fourier Basis approach:

ClearAll[FourierBasis2D];

FourierBasis2D[{numx_, numy_}, {λx_, λy_}, x_, y_] :=
N[With[{ωn = 2 π/λx, ωm =
2 π/λy},
Flatten[
{1}~Join~
Table[ {Cos[ n ωn x] Cos[m  ωm y],
Cos[ n ωn x] Sin[  m  ωm y],
Sin[ n  ωn x] Cos[m ωm  y],
Sin[ n ωn x] Sin[ m  ωm y]}, {n, numx}, {m,
numy}]]]];
FourierBasis2D[num_, λ_, x_, y_] :=
FourierBasis2D[{num, num}, {λ, λ}, x, y];

Clear[basis, fit];
basis = FourierBasis2D[5, 20, x, y];
Length[basis]
Length[data]
fit[x_, y_] = Fit[data, basis, {x, y}];
PlotPointsAndSurface[data, fit[x, y], "fit and data"] Plot derivatives of original and interpolated function:

Clear[DFx, DFy, DfitX, DfitY]
DFx[x_, y_] = Simplify@D[F[x, y], x];
DFy[x_, y_] = Simplify@D[F[x, y], y];
DfitX[x_, y_] = Simplify@D[fit[x, y], x];
DfitY[x_, y_] = Simplify@D[fit[x, y], y];

Plot3D[{DFx[x, y], DfitX[x, y]}, {x, -RANGEX, RANGEX}, {y, -RANGEY,
RANGEY}, PlotStyle -> {Directive[Black, Opacity[0.5]],
Directive[Red, Opacity[0.5]]}]
Plot3D[{DFy[x, y], DfitY[x, y]}, {x, -RANGEX, RANGEX}, {y, -RANGEY,
RANGEY}, PlotStyle -> {Directive[Black, Opacity[0.5]],
Directive[Red, Opacity[0.5]]}]

It's not perfect, but it works...

• Thanks for the formatting @Mr.W – Ajasja Oct 16 '14 at 8:37

Update

Since version 12, this functionality in integrated in Mathematica via the Option FitRegularization

Following on @Ajasja's answer in the spirit of this answer one can in fact provide controlled smoothing va an explicit Tichonov like penalty as follows:

ff = Function[{x, y}, basis // Evaluate];
a = ff @@ # & /@ (Most /@ data);

so that

fit[x_, y_] =
basis.LinearSolve[
Transpose[a]. a + 0 IdentityMatrix[Length[basis]],
Transpose[a].( Last /@ data )];
pl0 = PlotPointsAndSurface[data, fit[x, y], "fit and data"];

reproduces exactly @Ajasja's fit, whereas e.g.

fit[x_, y_] =
basis.LinearSolve[
Transpose[a]. a + 10^1 IdentityMatrix[Length[basis]],
Transpose[a].( Last /@ data )];
pl1 = PlotPointsAndSurface[data, fit[x, y], "fit and data"];

would correspond to a smoother solution.

Show[pl1, pl0] Note the hyper parameter (here 10^1), which fixes the sought level of smoothness imposed onto the solution, by effectively correlating the coefficients of the basis expansion.

The main advantage is that one need not focus too much on the exact properties of the chosen basis.

For instance we could also use BSplineBasis

knots = Range[-RANGEX - 2, RANGEX + 2];
basis = Flatten@ Table[BSplineBasis[{3, knots}, i, x]
BSplineBasis[{3, knots}, j,  y], {i, 0, 2 RANGEX}
, {j, 0, 2 RANGEX}];

Then, as previously

ff = Function[{x, y}, basis // Evaluate];
a = ff @@ # & /@ (Most /@ data);

Then one could use a penalty function based on second derivatives:

s = SparseArray[{{i_, i_} -> -1, {i_, j_} /; i - j == 1 -> 2,
{i_, j_} /; i - j == 2 -> -1}, {17, 15}] // Transpose;
s1 = ArrayFlatten[TensorProduct[s, s]];
pen = Transpose[s1].s1; pen//ArrayPlot built so that s.( Range*0 + 1) and s.Range are both null (i.e. there is no penalty to have a constant or linear function of x and y.

Then, as previously

fit3[x_, y_] =
basis.LinearSolve[Transpose[a]. a + 10^1 pen,
Transpose[a].( Last /@ data )];
pl1 = PlotPointsAndSurface[data, fit3[x, y], "fit and data"] The main advantage of this second approach is that it is the penalty which sets smoothing, not the sampling of the basis function. Even if the conditioning of Transpose[a]. a is poor, the inverse will be well conditioned thanks to the regularisation terms pen.

Note that for the sake of efficiency and memory one could fill the a matrix using sparse matrices following this answer.

With[{xOrder = Ordering[Join[data[[All, 1]], knots]],
yOrder = Ordering[Join[data[[All, 2]], knots]]},
With[{xPar = xOrder[[# + 1 ;; #2 - 1]] & @@@ Partition[Ordering[xOrder, -Length[knots]], 2, 1],
yPar = yOrder[[# + 1 ;; #2 - 1]] & @@@ Partition[Ordering[yOrder, -Length[knots]], 2, 1]},
nonzero = Join @@ Outer[Intersection, Union @@@ Partition[xPar, 4, 1],
Union @@@ Partition[yPar, 4, 1], 1];]]

colIndex = Range[Length[basis]];

Function[{x, y}, #] @@@ data[[#2, {1, 2}]]] &, {basis, nonzero, colIndex}]];  a == a2

(* True *)

The choice of optimal level of smoothing can be done via generalised cross validation, i.e. by choosing the penalty weight to correspond to the minimum of $$\hat \lambda = {\rm min}_\lambda\left\{ \frac{||( \mathbf{1}- \tilde{\mathbf{a}}) \cdot {\mathbf{y}} ||^2}{ \left[{\rm trace}( \mathbf{1}- \tilde{\mathbf{a}}) \right]^2} \right\} \,.$$ having defined $$\tilde{\mathbf{a}}(\lambda) =\mathbf{a} \cdot ({\mathbf{a}^{\rm T}} \cdot \mathbf{a} + \lambda\, \mathbf{s}^{\rm T}\cdot \mathbf{s})^{-1} \cdot {\mathbf{a}^{\rm T}}$$

Table[at = a.Inverse[Transpose[a]. a + 10^i pen].Transpose[a];
{i, ((IdentityMatrix - at).(Last /@ data) // #.# &)/
Tr[IdentityMatrix - at]^2}, {i, -3, 3, 1/2}] // ListLinePlot Update:

Note that if smoothing is not an issue, then in version 10 and above mathematica can deal directly with the data as demonstrated here

PlotPointsAndSurface2[points_, surface_, label_] :=
Module[{},
Show[ListPlot3D[points, PlotLabel -> label, ImageSize -> Medium,
PlotStyle -> Directive[Orange, Opacity[0.5]]],
Plot3D[surface, {x, -RX, RX}, {y, -RY, RY},
PlotStyle -> Directive[Purple, Opacity[0.1]]]]];

pl2 = PlotPointsAndSurface2[data, fit3[x, y], "fit and data"];
Show[pl1,pl2] as can be seen the regularised and un regularised surfaces look quite similar.

It would be great if mathematica allowed for adding a penalty to the built in function behind ListPlot3D, ListContourPlot or ListInterpolate !

You can use ListPlot3D and its InterpolationOrder option. That has built in smoothing.

ListPlot3D[points, InterpolationOrder->3]

This will give you a cubic interpolation. Close to what you are looking for and built into Mma.

EDIT: Well, if the points are evenly spaced which they appear to be. But if not then no as this will not produce a scatter plot. Just realised the difference between ListPlot3D and ListPointPlot3D. I'm still a bit new here.

Edmund

• Hi! Perhaps the question or the example code was a bit misleading. I need to obtain a differentiable interpolated and smoothed function from the data. In the test case it should be as close as possible to the original. – Ajasja Oct 15 '14 at 17:59
• A duplicate question with code to solve this problem is mathematica.stackexchange.com/questions/11765/…. That gives the smoothest possible interpolation. The only problem is that the algorithm quickly gets slow as the number of points interpolated grows. – Ted Ersek Jun 6 at 0:40