# Finding a function that fits the shape of an image

How can I find a function that fits the given shape of an image? Or instead extract a point set from the shape and then find an interpolating function fits the shape.

An example image is attached. ## 3 Answers

The following is something I made while trying to solve another (similar) problem

(*FindCurvedPath Replacement*)
ClearAll[findCurvedPath2, findClosedPath2];
findClosedPath2[inptList_, cutoff_] := Append[#, #[]] &@
findCurvedPath2[inptList, cutoff]
findCurvedPath2[inptList_, cutoff_] := Block[{
$RecursionLimit = Max[20, Round[ 2.1 Length@inptList]],$IterationLimit = Max[20, Round[ 2.1 Length@inptList]]},
findCurvedPath2[Rest@inptList, inptList[[1 ;; 1]], cutoff]]
findCurvedPath2[{}, outList_, cutoff_] := outList
findCurvedPath2[inptList_, outList_, cutoff_] :=
findCurvedPath2[Delete[inptList, #],
If[EuclideanDistance[inptList[[#]], Last@outList] < cutoff,
Append[outList, inptList[[#]]], outList], cutoff] &@
First@Nearest[inptList -> Automatic, Last@outList]

(*Two methodsfor calculating the perimeter curve for an Image*)
ClearAll[findPerimeterPath];
findPerimeterPath[i_Image, cutoff_, OptionsPattern[{Method -> EdgeDetect}]] :=
Module[{perimPts},
Switch[OptionValue[Method],
MorphologicalPerimeter,
perimPts = ImageValuePositions[MorphologicalPerimeter[Binarize[i, {0, .5}]], 1],
EdgeDetect,
perimPts = ImageValuePositions[Thinning@EdgeDetect@i, 1]];
findClosedPath2[perimPts, cutoff]]

(*For your image*)
ii = Import["http://i.stack.imgur.com/Z7rKJ.jpg"];
i1 = ColorNegate@FillingTransform[ColorNegate@Binarize[ii, .9]];
cutoff = Norm@ImageDimensions@i1/50 // N;
fcp2 = findPerimeterPath[i1, cutoff, Method -> MorphologicalPerimeter];
f = Interpolation /@ Transpose@fcp2;
pp = ParametricPlot[Through[f[x]], {x, 1, Length@fcp2}, Axes -> False] Now you can proceed the same way with the holes:

Needs["DifferentialEquationsInterpolatingFunctionAnatomy"];
i1 = DeleteSmallComponents[ColorNegate[Binarize[ii]], 5] // ColorNegate;
(* leave out components 0, 1 and 2*)
mcR = (UnitStep[# - 3] # &@MorphologicalComponents[i1]);
compsR = Rest@DeleteDuplicates@Flatten@mcR;
iR = Table[Image@Unitize[mcR - ConstantArray[r, Dimensions@mcR]], {r, compsR}];
cutoff = Norm@ImageDimensions@i1/50 // N;
fcp2R = findPerimeterPath[#, cutoff] & /@ iR;
fR = Table[Interpolation[fcp2R[[n]][[All, #]]] & /@ Range@2, {n, Length@fcp2R}];
pp1 = ParametricPlot[ Through[#[x]],
{x, 1, InterpolatingFunctionDomain[#[[1, 1]]][[1, 1, 2]]}] & /@ fR;

Show[pp, pp1]  Since your image is binary, you can just pick out the top-most point in each column of the data matrix:

img = Import["http://i.stack.imgur.com/Z7rKJ.jpg"];
dat = Transpose[ImageData@EdgeDetect[img]];
{c, r} = Dimensions[dat];
points = r - Min[Flatten@Position[dat[[#]], 1]] & /@ Range[c];
np = Interpolation[points, InterpolationOrder -> 1];
Plot[np[x], {x, 1, c}, AspectRatio -> Automatic, ImageSize -> 600] • I lost a nice statue! – Dr. belisarius Feb 25 '15 at 13:53
• @belisarius - Don't you hate it when that happens? But really -- if we are looking for a 1D interpolating function, something is going to get lost. You could do a 2D function, but how to deal with all the separated components? – bill s Feb 25 '15 at 13:55

I was stuck for a while with a not really acceptable result, but then @belisarius posted his answer and I was able to refine my code with the usage of his findCurvedPath2 function. So I am able to post my solution to the problem.

First, import and process the image:

img = Binarize@Import["http://i.stack.imgur.com/Z7rKJ.jpg", "JPEG"];
imgc = ColorNegate@Closing[ColorNegate@img, 10];
edge = ColorNegate@Thinning@Dilation[EdgeDetect@imgc, 1];
edgeData = {0, ImageDimensions[imgc][]} - #*{-1, 1} & /@
Reverse /@ Position[ImageData@edge, 0];


Then, I wrote my own method to sort the edge pixels:

dist[{u_, v_}, {x_, y_}] := 10 (x - u) - (u - x) + 10 Abs[v - y]

first = Sort[edgeData][];
odata = DeleteCases[edgeData, first];
ndata = {first};
Dynamic[{Length[ndata], np}]
While[Length[odata] > 1,
p = ndata[[-1]];
np = Nearest[odata, p, DistanceFunction -> dist][];
AppendTo[ndata, np];
odata = DeleteCases[odata, np];
]


Here's where I'd become stuck, because the result was problematic: Then, I improved the sorting with findCurvedPath2 borrowed from @belisarius' answer, and cleaned it up a bit:

ndata2 = findCurvedPath2[ndata];
d = Differences[ndata2];
s = Select[d, Max@Abs@# > 10 &];
sp = Flatten[Position[d, #] & /@ s, 1];
ndata2s = Delete[ndata2, DeleteDuplicates@Join[sp, sp + 1]][[;; -3]];


The result was very close to the real silhouette: The only thing left was to interpolate the sorted data:

curve = Interpolation@MapIndexed[{#2[], #1} &, ndata2s];
ParametricPlot[curve[t], {t, 1, Length[ndata2s]},
ImageSize -> ImageDimensions@imgc, AspectRatio -> Automatic,
PlotRange -> {{0, Max[edgeData]}, All}] • Sorry, I needed to change my code. Perhaps you want to test with the new one or recover the old one from the edit history – Dr. belisarius Aug 14 '15 at 14:35