26
$\begingroup$

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. enter image description here

$\endgroup$
38
$\begingroup$

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

(*FindCurvedPath Replacement*)
ClearAll[findCurvedPath2, findClosedPath2];
findClosedPath2[inptList_, cutoff_] := Append[#, #[[1]]] &@
                                                   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]  

Mathematica graphics

Now you can proceed the same way with the holes:

Needs["DifferentialEquations`InterpolatingFunctionAnatomy`"];
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]  

Mathematica graphics Mathematica graphics

$\endgroup$
14
$\begingroup$

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]

enter image description here

$\endgroup$
  • $\begingroup$ I lost a nice statue! $\endgroup$ – Dr. belisarius Feb 25 '15 at 13:53
  • $\begingroup$ @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? $\endgroup$ – bill s Feb 25 '15 at 13:55
12
$\begingroup$

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][[2]]} - #*{-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][[1]];
odata = DeleteCases[edgeData, first];
ndata = {first};
Dynamic[{Length[ndata], np}]
While[Length[odata] > 1,
 p = ndata[[-1]];
 np = Nearest[odata, p, DistanceFunction -> dist][[1]];
 AppendTo[ndata, np];
 odata = DeleteCases[odata, np];
 ]

Here's where I'd become stuck, because the result was problematic:

first result

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:

improved result

The only thing left was to interpolate the sorted data:

curve = Interpolation@MapIndexed[{#2[[1]], #1} &, ndata2s];
ParametricPlot[curve[t], {t, 1, Length[ndata2s]}, 
 ImageSize -> ImageDimensions@imgc, AspectRatio -> Automatic, 
 PlotRange -> {{0, Max[edgeData]}, All}]

parametric plot of final result

$\endgroup$
  • $\begingroup$ 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 $\endgroup$ – Dr. belisarius Aug 14 '15 at 14:35

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.