# 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 Other methods for the choice of hyper parameters exist, see e.g. this page

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 !

• Is there a way to evaluate a sufficient number of knots without reference to the range of the dataset? For example, imagine a dataset within the interval [-0.5,0.5] in both x and y and highly varying in this interval – Daniele Binosi Apr 22 at 19:16
• 2@DanieleBinosi of course you can put the knots where you want. You need just to decide how you couple the coefficients for the penalty. Should it reflect this uneven sampling or not is up to you. – chris Apr 22 at 19:44
• I am new into this spline issue, so I am a bit lost. Allow me just 1D for the moment. In your original example the data extends in [-8,8] and you have chosen knots = Range[-8- 2, 8+ 2]. Now if I have data say in [0,0.02] how do I – Daniele Binosi Apr 22 at 20:25
• it depends :-) knots = Range[1,n]/n*0.025 -0.001 or something like that? you could have a look at this mathematica.stackexchange.com/a/34880/1089 and the link in the answer above – chris Apr 23 at 8:00
• Thank you @chris. I am now trying to put everything in a module (still 1D). But I have problems with the following block: ff = Function[{x}, basis // Evaluate]; a = ff @@ # & /@ (Most /@ data). The matrix a does not get evaluated. It seems to be related to the scope of the x variable in basis = Flatten@ Table[BSplineBasis[{3, knots}, i, x] , {i, 0, 2RANGEX}] and ff. I guess a solution could be to fill the matrix a using sparse matrices but I cannot reduce your 2D example to the 1D case – Daniele Binosi Apr 23 at 8:36

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 '19 at 0:40