Finding a function that fits the shape of an image

27

17

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

Mikayel

Posted 2015-02-25T13:00:00.030

Reputation: 541

That's a tough image, but I guess you could start with ImageCorners[img] as per http://reference.wolfram.com/language/ref/ImageCorners.html

– dr.blochwave – 2015-02-25T13:05:35.200

Please give examples of input, output and define silhouette. – Kuba – 2015-02-25T13:17:05.260

3

You may start with the people therein

– Dr. belisarius – 2015-02-25T13:26:43.933

Answers

39

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

Dr. belisarius

Posted 2015-02-25T13:00:00.030

Reputation: 112 848

14

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

bill s

Posted 2015-02-25T13:00:00.030

Reputation: 62 963

I lost a nice statue! – Dr. belisarius – 2015-02-25T13:53:34.507

@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 – 2015-02-25T13:55:47.847

13

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

shrx

Posted 2015-02-25T13:00:00.030

Reputation: 7 577

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 – 2015-08-14T14:35:27.730