We’re rewarding the question askers & reputations are being recalculated! Read more.
5 deleted 24 characters in body
source | link

enter image description herecontour plot

Here is my code. Being fairly new to MathematicaMathematica, I am open to suggestions for improvement.

data = {{875, 3375, 632}, {500, 4000, 634}, {2250, 1250, 
    654.2}, {3000, 875, 646.4}, {2560, 1187, 641.5}, {1000, 750, 
    650}, {2060, 1560, 634}, {3000, 1750, 643.3}, {2750, 2560, 
    639.4}, {1125, 2500, 630.1}, {875, 3125, 638}, {1000, 3375, 
    632.3}, {1060, 3500, 630.8}, {1250, 3625, 635.8}, {750, 3375, 
    625.6}, {560, 4125, 632}, {185, 3625, 624.2}};

{xs, ys, zs} = Transpose[data];

phi[r_] := Which[r == 0, 0, r < 1, r Log[r^r], True, r^2 Log[r]];

n = Length[data];
f[p_] := Sum[
    a[j] phi@EuclideanDistance[pphi @ EuclideanDistance[p, {xs[[j]], ys[[j]]}], {j, n}] + 
   b[0] + {b[1], b[2]}.p;
sol = Solve[
  Table[zs[[i]] == f[{xs[[i]], ys[[i]]}], {i, n}]~
   Join~{Sum[a[i], {i, n}] == 0, Sum[a[i] xs[[i]], {i, n}] == 0, 
    Sum[a[i] ys[[i]], {i, n}] == 0}, 
  Table[a[i], {i, n}]~Join~{b[0], b[1], b[2]}];

ContourPlot[f[{x, y}] /. sol, {x, 0, 3500}, {y, 500, 4500}, 
 AspectRatio -> Automatic, Contours -> 20, 
 ColorFunction -> "TemperatureMap", 
 Epilog -> {PointSize[.015], 
   Point[{{875, 3375}, {500, 4000}, {2250, 1250}, {3000, 875}, {2560, 
      1187}, {1000, 750}, {2060, 1560}, {3000, 1750}, {2750, 
      2560}, {1125, 2500}, {875, 3125}, {1000, 3375}, {1060, 
      3500}, {1250, 3625}, {750, 3375}, {560, 4125}, {185, 3625}}]}]

enter image description here

Here is my code. Being fairly new to Mathematica, I am open to suggestions for improvement.

data = {{875, 3375, 632}, {500, 4000, 634}, {2250, 1250, 
    654.2}, {3000, 875, 646.4}, {2560, 1187, 641.5}, {1000, 750, 
    650}, {2060, 1560, 634}, {3000, 1750, 643.3}, {2750, 2560, 
    639.4}, {1125, 2500, 630.1}, {875, 3125, 638}, {1000, 3375, 
    632.3}, {1060, 3500, 630.8}, {1250, 3625, 635.8}, {750, 3375, 
    625.6}, {560, 4125, 632}, {185, 3625, 624.2}};

{xs, ys, zs} = Transpose[data];

phi[r_] := Which[r == 0, 0, r < 1, r Log[r^r], True, r^2 Log[r]];

n = Length[data];
f[p_] := Sum[
    a[j] phi@EuclideanDistance[p, {xs[[j]], ys[[j]]}], {j, n}] + 
   b[0] + {b[1], b[2]}.p;
sol = Solve[
  Table[zs[[i]] == f[{xs[[i]], ys[[i]]}], {i, n}]~
   Join~{Sum[a[i], {i, n}] == 0, Sum[a[i] xs[[i]], {i, n}] == 0, 
    Sum[a[i] ys[[i]], {i, n}] == 0}, 
  Table[a[i], {i, n}]~Join~{b[0], b[1], b[2]}];

ContourPlot[f[{x, y}] /. sol, {x, 0, 3500}, {y, 500, 4500}, 
 AspectRatio -> Automatic, Contours -> 20, 
 ColorFunction -> "TemperatureMap", 
 Epilog -> {PointSize[.015], 
   Point[{{875, 3375}, {500, 4000}, {2250, 1250}, {3000, 875}, {2560, 
      1187}, {1000, 750}, {2060, 1560}, {3000, 1750}, {2750, 
      2560}, {1125, 2500}, {875, 3125}, {1000, 3375}, {1060, 
      3500}, {1250, 3625}, {750, 3375}, {560, 4125}, {185, 3625}}]}]

contour plot

Here is my code. Being fairly new to Mathematica, I am open to suggestions for improvement.

data = {{875, 3375, 632}, {500, 4000, 634}, {2250, 1250, 
    654.2}, {3000, 875, 646.4}, {2560, 1187, 641.5}, {1000, 750, 
    650}, {2060, 1560, 634}, {3000, 1750, 643.3}, {2750, 2560, 
    639.4}, {1125, 2500, 630.1}, {875, 3125, 638}, {1000, 3375, 
    632.3}, {1060, 3500, 630.8}, {1250, 3625, 635.8}, {750, 3375, 
    625.6}, {560, 4125, 632}, {185, 3625, 624.2}};

{xs, ys, zs} = Transpose[data];

phi[r_] := Which[r == 0, 0, r < 1, r Log[r^r], True, r^2 Log[r]];

n = Length[data];
f[p_] := Sum[
    a[j] phi @ EuclideanDistance[p, {xs[[j]], ys[[j]]}], {j, n}] + 
   b[0] + {b[1], b[2]}.p;
sol = Solve[
  Table[zs[[i]] == f[{xs[[i]], ys[[i]]}], {i, n}]~
   Join~{Sum[a[i], {i, n}] == 0, Sum[a[i] xs[[i]], {i, n}] == 0, 
    Sum[a[i] ys[[i]], {i, n}] == 0}, 
  Table[a[i], {i, n}]~Join~{b[0], b[1], b[2]}];

ContourPlot[f[{x, y}] /. sol, {x, 0, 3500}, {y, 500, 4500}, 
 AspectRatio -> Automatic, Contours -> 20, 
 ColorFunction -> "TemperatureMap", 
 Epilog -> {PointSize[.015], 
   Point[{{875, 3375}, {500, 4000}, {2250, 1250}, {3000, 875}, {2560, 
      1187}, {1000, 750}, {2060, 1560}, {3000, 1750}, {2750, 
      2560}, {1125, 2500}, {875, 3125}, {1000, 3375}, {1060, 
      3500}, {1250, 3625}, {750, 3375}, {560, 4125}, {185, 3625}}]}]
4 added 26 characters in body
source | link
data = {{875, 3375, 632}, {500, 4000, 634}, {2250, 1250, 
    654.2}, {3000, 875, 646.4}, {2560, 1187, 641.5}, {1000, 750, 
    650}, {2060, 1560, 634}, {3000, 1750, 643.3}, {2750, 2560, 
    639.4}, {1125, 2500, 630.1}, {875, 3125, 638}, {1000, 3375, 
    632.3}, {1060, 3500, 630.8}, {1250, 3625, 635.8}, {750, 3375, 
    625.6}, {560, 4125, 632}, {185, 3625, 624.2}};

{xs, ys, zs} = Transpose[data];

phi[r_] := r^2Which[r Log[r];
phi[0]== :=0, 0;0, r < 1, r Log[r^r], True, r^2 Log[r]];

n = Length[data];
f[p_] := Sum[
    a[j] phi@EuclideanDistance[p, {xs[[j]], ys[[j]]}], {j, n}] + 
   b[0] + {b[1], b[2]}.p;
sol = Solve[
  Table[zs[[i]] == f[{xs[[i]], ys[[i]]}], {i, n}]~
   Join~{Sum[a[i], {i, n}] == 0, Sum[a[i] xs[[i]], {i, n}] == 0, 
    Sum[a[i] ys[[i]], {i, n}] == 0}, 
  Table[a[i], {i, n}]~Join~{b[0], b[1], b[2]}]];

ContourPlot[f[{x, y}] /. sol, {x, 0, 3500}, {y, 500, 4500}, 
 AspectRatio -> Automatic, Contours -> 20, 
 ColorFunction -> "TemperatureMap", 
 Epilog -> {PointSize[.015], 
   Point[{{875, 3375}, {500, 4000}, {2250, 1250}, {3000, 875}, {2560, 
      1187}, {1000, 750}, {2060, 1560}, {3000, 1750}, {2750, 
      2560}, {1125, 2500}, {875, 3125}, {1000, 3375}, {1060, 
      3500}, {1250, 3625}, {750, 3375}, {560, 4125}, {185, 3625}}]}]
data = {{875, 3375, 632}, {500, 4000, 634}, {2250, 1250, 
    654.2}, {3000, 875, 646.4}, {2560, 1187, 641.5}, {1000, 750, 
    650}, {2060, 1560, 634}, {3000, 1750, 643.3}, {2750, 2560, 
    639.4}, {1125, 2500, 630.1}, {875, 3125, 638}, {1000, 3375, 
    632.3}, {1060, 3500, 630.8}, {1250, 3625, 635.8}, {750, 3375, 
    625.6}, {560, 4125, 632}, {185, 3625, 624.2}};

{xs, ys, zs} = Transpose[data];

phi[r_] := r^2 Log[r];
phi[0] := 0;

n = Length[data];
f[p_] := Sum[
    a[j] phi@EuclideanDistance[p, {xs[[j]], ys[[j]]}], {j, n}] + 
   b[0] + {b[1], b[2]}.p;
sol = Solve[
  Table[zs[[i]] == f[{xs[[i]], ys[[i]]}], {i, n}]~
   Join~{Sum[a[i], {i, n}] == 0, Sum[a[i] xs[[i]], {i, n}] == 0, 
    Sum[a[i] ys[[i]], {i, n}] == 0}, 
  Table[a[i], {i, n}]~Join~{b[0], b[1], b[2]}]

ContourPlot[f[{x, y}] /. sol, {x, 0, 3500}, {y, 500, 4500}, 
 AspectRatio -> Automatic, Contours -> 20, 
 ColorFunction -> "TemperatureMap", 
 Epilog -> {PointSize[.015], 
   Point[{{875, 3375}, {500, 4000}, {2250, 1250}, {3000, 875}, {2560, 
      1187}, {1000, 750}, {2060, 1560}, {3000, 1750}, {2750, 
      2560}, {1125, 2500}, {875, 3125}, {1000, 3375}, {1060, 
      3500}, {1250, 3625}, {750, 3375}, {560, 4125}, {185, 3625}}]}]
data = {{875, 3375, 632}, {500, 4000, 634}, {2250, 1250, 
    654.2}, {3000, 875, 646.4}, {2560, 1187, 641.5}, {1000, 750, 
    650}, {2060, 1560, 634}, {3000, 1750, 643.3}, {2750, 2560, 
    639.4}, {1125, 2500, 630.1}, {875, 3125, 638}, {1000, 3375, 
    632.3}, {1060, 3500, 630.8}, {1250, 3625, 635.8}, {750, 3375, 
    625.6}, {560, 4125, 632}, {185, 3625, 624.2}};

{xs, ys, zs} = Transpose[data];

phi[r_] := Which[r == 0, 0, r < 1, r Log[r^r], True, r^2 Log[r]];

n = Length[data];
f[p_] := Sum[
    a[j] phi@EuclideanDistance[p, {xs[[j]], ys[[j]]}], {j, n}] + 
   b[0] + {b[1], b[2]}.p;
sol = Solve[
  Table[zs[[i]] == f[{xs[[i]], ys[[i]]}], {i, n}]~
   Join~{Sum[a[i], {i, n}] == 0, Sum[a[i] xs[[i]], {i, n}] == 0, 
    Sum[a[i] ys[[i]], {i, n}] == 0}, 
  Table[a[i], {i, n}]~Join~{b[0], b[1], b[2]}];

ContourPlot[f[{x, y}] /. sol, {x, 0, 3500}, {y, 500, 4500}, 
 AspectRatio -> Automatic, Contours -> 20, 
 ColorFunction -> "TemperatureMap", 
 Epilog -> {PointSize[.015], 
   Point[{{875, 3375}, {500, 4000}, {2250, 1250}, {3000, 875}, {2560, 
      1187}, {1000, 750}, {2060, 1560}, {3000, 1750}, {2750, 
      2560}, {1125, 2500}, {875, 3125}, {1000, 3375}, {1060, 
      3500}, {1250, 3625}, {750, 3375}, {560, 4125}, {185, 3625}}]}]
3 previous version was incorrect
source | link

One thing you can do is fit a smooth function to the data, and draw the contour plot of that instead. Using the thin plate case of thin plate splinespolyharmonic splines (see also this nice article by David Eberly), I get the following plot:

enter image description hereenter image description here

data = {{875, 3375, 632}, {500, 4000, 634}, {2250, 1250, 
    654.2}, {3000, 875, 646.4}, {2560, 1187, 641.5}, {1000, 750, 
    650}, {2060, 1560, 634}, {3000, 1750, 643.3}, {2750, 2560, 
    639.4}, {1125, 2500, 630.1}, {875, 3125, 638}, {1000, 3375, 
    632.3}, {1060, 3500, 630.8}, {1250, 3625, 635.8}, {750, 3375, 
    625.6}, {560, 4125, 632}, {185, 3625, 624.2}};

d[p_{xs, q_] :=ys, Norm[pzs} -= q];Transpose[data];
tps[r_]
phi[r_] := r^2 Log[r];
tps[0]phi[0] := 0;

n = Length[data];
f0f[p_] := 640;Sum[
f[p_] := f0 + Sum[c[j]a[j] tps[d[pphi@EuclideanDistance[p, data[[j{xs[[j]], 1 ;; 2]]]]ys[[j]]}], {j, n}];] + 
eqn[i_] :  b[0] + {b[1], b[2]}.p;
sol = data[[iSolve[
  Table[zs[[i]] == f[{xs[[i]], 3]]ys[[i]]}], {i, n}]~
   Join~{Sum[a[i], {i, n}] == f[data[[i0, 1Sum[a[i] ;;xs[[i]], 2]]];{i, n}] == 0, 
sol = Solve[Table[eqn[i]  Sum[a[i] ys[[i]], {i, n}] == 0}, Table[c[i]
  Table[a[i], {i, n}]];]~Join~{b[0], b[1], b[2]}]

ContourPlot[f[{x, y}] /. sol, {x, 0, 3500}, {y, 500, 4500}, 
 AspectRatio -> Automatic, Contours -> 20, 
 ColorFunction -> "TemperatureMap", 
 Epilog -> {PointSize[.015], 
   Point[{{875, 3375}, {500, 4000}, {2250, 1250}, {3000, 875}, {2560, 
      1187}, {1000, 750}, {2060, 1560}, {3000, 1750}, {2750, 
      2560}, {1125, 2500}, {875, 3125}, {1000, 3375}, {1060, 
      3500}, {1250, 3625}, {750, 3375}, {560, 4125}, {185, 3625}}]}]
 

Unfortunately, with thin plate splines,Note: My previous implementation was incorrect as it omitted the result depends on a choice of a "neutral" valuepolynomial terms parametrized by (e.g. the arbitrary number 640 above, which I picked because it's roughly in the middle of the data). Other spline functions may not require this choiceb.

One thing you can do is fit a smooth function to the data, and draw the contour plot of that instead. Using thin plate splines, I get the following plot:

enter image description here

data = {{875, 3375, 632}, {500, 4000, 634}, {2250, 1250, 
    654.2}, {3000, 875, 646.4}, {2560, 1187, 641.5}, {1000, 750, 
    650}, {2060, 1560, 634}, {3000, 1750, 643.3}, {2750, 2560, 
    639.4}, {1125, 2500, 630.1}, {875, 3125, 638}, {1000, 3375, 
    632.3}, {1060, 3500, 630.8}, {1250, 3625, 635.8}, {750, 3375, 
    625.6}, {560, 4125, 632}, {185, 3625, 624.2}};

d[p_, q_] := Norm[p - q];
tps[r_] := r^2 Log[r];
tps[0] := 0;

n = Length[data];
f0 = 640;
f[p_] := f0 + Sum[c[j] tps[d[p, data[[j, 1 ;; 2]]]], {j, n}];
eqn[i_] := data[[i, 3]] == f[data[[i, 1 ;; 2]]];
sol = Solve[Table[eqn[i], {i, n}], Table[c[i], {i, n}]];

ContourPlot[f[{x, y}] /. sol, {x, 0, 3500}, {y, 500, 4500}, 
 AspectRatio -> Automatic, Contours -> 20, 
 ColorFunction -> "TemperatureMap", 
 Epilog -> {PointSize[.015], 
   Point[{{875, 3375}, {500, 4000}, {2250, 1250}, {3000, 875}, {2560, 
      1187}, {1000, 750}, {2060, 1560}, {3000, 1750}, {2750, 
      2560}, {1125, 2500}, {875, 3125}, {1000, 3375}, {1060, 
      3500}, {1250, 3625}, {750, 3375}, {560, 4125}, {185, 3625}}]}]

Unfortunately, with thin plate splines, the result depends on a choice of a "neutral" value (e.g. the arbitrary number 640 above, which I picked because it's roughly in the middle of the data). Other spline functions may not require this choice.

One thing you can do is fit a smooth function to the data, and draw the contour plot of that instead. Using the thin plate case of polyharmonic splines (see also this nice article by David Eberly), I get the following plot:

enter image description here

data = {{875, 3375, 632}, {500, 4000, 634}, {2250, 1250, 
    654.2}, {3000, 875, 646.4}, {2560, 1187, 641.5}, {1000, 750, 
    650}, {2060, 1560, 634}, {3000, 1750, 643.3}, {2750, 2560, 
    639.4}, {1125, 2500, 630.1}, {875, 3125, 638}, {1000, 3375, 
    632.3}, {1060, 3500, 630.8}, {1250, 3625, 635.8}, {750, 3375, 
    625.6}, {560, 4125, 632}, {185, 3625, 624.2}};

{xs, ys, zs} = Transpose[data];

phi[r_] := r^2 Log[r];
phi[0] := 0;

n = Length[data];
f[p_] := Sum[
    a[j] phi@EuclideanDistance[p, {xs[[j]], ys[[j]]}], {j, n}] + 
   b[0] + {b[1], b[2]}.p;
sol = Solve[
  Table[zs[[i]] == f[{xs[[i]], ys[[i]]}], {i, n}]~
   Join~{Sum[a[i], {i, n}] == 0, Sum[a[i] xs[[i]], {i, n}] == 0, 
    Sum[a[i] ys[[i]], {i, n}] == 0}, 
  Table[a[i], {i, n}]~Join~{b[0], b[1], b[2]}]

ContourPlot[f[{x, y}] /. sol, {x, 0, 3500}, {y, 500, 4500}, 
 AspectRatio -> Automatic, Contours -> 20, 
 ColorFunction -> "TemperatureMap", 
 Epilog -> {PointSize[.015], 
   Point[{{875, 3375}, {500, 4000}, {2250, 1250}, {3000, 875}, {2560, 
      1187}, {1000, 750}, {2060, 1560}, {3000, 1750}, {2750, 
      2560}, {1125, 2500}, {875, 3125}, {1000, 3375}, {1060, 
      3500}, {1250, 3625}, {750, 3375}, {560, 4125}, {185, 3625}}]}]
 

Note: My previous implementation was incorrect as it omitted the polynomial terms parametrized by b.

2 added 263 characters in body
source | link
1
source | link