Estimate the "Blurry" distribution of an image

You can define acutance to measure sharpness of an image part:

acutance[img_] := Mean@Flatten@ImageData@GradientFilter[img, 1]

You can then divide your image into blocks and calculate acutance for each of them. Blocks with higher acutance are sharper.

For your example:

blockSize = 50;
img = Import["https://i.stack.imgur.com/dNxZE.png"];
acutanceMap = Map[acutance, ImagePartition[img, blockSize], {2}];
MatrixPlot[acutanceMap, ColorFunction -> "TemperatureMap"]

you will get the following acutance map:

acutance map

where darker red regions correspond to the sharpest parts.

You can also calculate acutance distribution along the vertical axis:

acutanceDistribution = Transpose[
    {blockSize*Range@Length@acutanceMap, Mean[Transpose@acutanceMap]}]

ListPlot[acutanceDistribution, PlotRange -> All, Joined -> True, Frame -> True]

The sharpest part of the image is located between the lines 350-500:

acutance distribution

Results for the test images

enter image description here


I think what you're looking is related to "scale selection" (Wikipedia link) in scale space theory. Simply put, the idea is: If you have an edge in your image that's been blurred with some filter size sigma, and you apply Gaussian derivative or Laplacian of Gaussian filters with varying sigmas to that image, you get the highest impulse response if the filter sizes match. (Think of it as template matching, although the theoretical reasoning is somewhat different.)

I'll illustrate my idea with a simple sample image, for example, a disk:

sample = N[DiskMatrix[32, 128]];

Now let's blur this disk with different (Gaussian) filters:

Table[
  (
   blurrySample = 
    GaussianFilter[sample, {3 s1, s1}, Method -> "Gaussian"]; (* continued *)

and apply a range of Laplacian of Gaussian filters to it:

   scaleSpaceStep = 1.1;
   scaleSpace = scaleSpaceStep^Range[Log[scaleSpaceStep, 40]];
   filter = 
    Table[s^2*
      Total[LaplacianGaussianFilter[blurrySample, {3 s, s}, 
         Method -> "Gaussian"]^2, ∞], {s, scaleSpace}]; (* continued *)

Note that I have to multiply the LoG filter with s^2 to make this work. This is a "normalization factor", and it depends on the image content, i.e. it's different for point-like, line-like or area-like features. We'll have to estimate this for your images. Let's look at the results:

   ListLinePlot[{scaleSpace, filter}\[Transpose], PlotRange -> All, 
    GridLines -> {{s1}, {}},
    Prolog -> {Inset[Image[blurrySample, ImageSize -> 40], 
       Scaled[{1, 1}], Scaled[{1, 1}]]}]
   ), {s1, 0, 29, 2.5}]

enter image description here

As you can see, the LoG filters have the strongest squared impulse response if the LoG filter's size (roughly) matches the size of the blurring filter.

Now let's try this on your images. First, I choose the LoG filter sizes I'll use:

scaleSpaceStep = 1.2;
scaleSpace = 
  scaleSpaceStep^
   Range[Round[Log[scaleSpaceStep, 1]], Log[scaleSpaceStep, 100]];

Then the scale selection is quite simple:

estimateScale[img_] := (
  (* apply LoG filters with different sizes *)
  log = Table[
    GaussianFilter[
     s^4 LaplacianGaussianFilter[ImageData[img], {3 s, s}, 
        Method -> "Gaussian"]^2, 50, Method -> "Gaussian"], {s, 
     scaleSpace}];
  (* and estimate the "best scale" from a weighted average *)
  perPixelMaxScale = (scaleSpace.log)/Total[log];
  (* fancy display stuff *)
  {
   Image[img, ImageSize -> 400],
   ArrayPlot[perPixelMaxScale, PlotLegends -> Automatic, 
    ColorFunction -> "ThermometerColors", ImageSize -> 400]
   }
  )

Applied to your images:

imgs = ColorConvert[Import[#], 
    "Grayscale"] & /@ {"https://i.stack.imgur.com/dNxZE.png", 
   "https://i.stack.imgur.com/CZ2sU.png", 
   "https://i.stack.imgur.com/x44HL.png", 
   "https://i.stack.imgur.com/ugMEg.png"};    
Grid[estimateScale /@ imgs]

enter image description here


We can use Blur or Sharpen to show the blurry model roughly.They will give a similar result.I will use Blur here.

img = Import["https://i.stack.imgur.com/dNxZE.png"];
model = PeronaMalikFilter[img - Blur[img], 10]

Mathematica graphics

We need a border to locate the upper, cnenter and down as your demand.

border = Subdivide[Last[ImageDimensions[img]], 3]

{0,649/3,1298/3,649}

We can use the ListLinePlot to show the trend of blur.

data = MeanFilter[Mean@Transpose[
     ImageData[ImageAdjust[ColorConvert[model, "Grayscale"]]]], 10];
ListLinePlot[data, 
 Epilog -> {Red, Line[{{border[[2]], 0}, {border[[2]], 0.04}}], 
   Line[{{border[[3]], 0}, {border[[3]], 0.04}}]}, 
 Ticks -> {{{Mean[border[[;; 2]]], "Upper"}, {Mean[border[[2 ;; 3]]], 
     "Center"}, {Mean[border[[3 ;;]]], "down"}}}]

Mathematica graphics

As we see,the clear part is not very near to the center,but close to the bottom,and its position is $62\%$ in the vertical direction.

N[First[Ordering[data, -1]]/Length[data]]

0.619414