Find gridlines in image of blots arranged in a grid

Question

I have an image with a grid of equal separations. I would like to detect the lines in this image. I tried with ImageLines in but it does not work.

@MelaGo Thank you for the solution. Unfortunately, I got some error while I run into my Mathematica. I wonder if you could look at it.

Clear[x0, y0, angle]
grid[x0_?NumericQ, y0_?NumericQ, angle_?NumericQ] := 
RotationTransform[angle, {pix/2, pix/2}][
Flatten[Table[{x0 + x, y0 + y}, {x, 0, pix, div}, {y, 0, pix, 
  div}], 1]];

minfunc[x0_?NumericQ, y0_?NumericQ, angle_?NumericQ] := 
Total[EuclideanDistance[#, Nearest[grid[x0, y0, angle], #][[1]]] & /@
cents]

sol = FindMinimum[{minfunc[x0, y0, angle]}, {{x0, 10}, {y0, 
10}, {angle, 0}}, Method -> "PrincipalAxis"]
(**Errors**)
Nearest::neard: The default distance function does not give a 
real numeric distance when applied to the point pair 
{319.5,488.5} and {x0 Cos[angle]-250 (-1+Cos[angle]- 
Sin[angle])-y0 Sin[angle],y0 Cos[angle]+x0 Sin[angle]-250 
(-1+Cos[angle]+Sin[angle])}.
Thread::tdlen: Objects of unequal length in {319.5,488.5}-{{x0 
Cos[angle]-250 (-1+Cos[angle]-Sin[<<1>>])-y0 Sin[angle],y0 
Cos[angle]+x0 Sin[angle]-250 (-1+Cos[angle]+Sin[angle])},{x0 
Cos[angle]-250 (-1+Cos[angle]-Sin[<<1>>])-(26+y0) Sin[angle],

(26+y0) Cos[angle]+x0 Sin[angle]-250 (-1+Cos[angle]+Sin[angle])},<<48>>,<<350>>} cannot be combined.

I have a feeling that this can be solved with Fourier analysis similar to what I did here, but that it won't be straight forward and that I will need to do some pre-processing to make the points more distinct. I won't be able to provide an answer today. — C. E., Oct 29 '19 at 21:30
Thank you very much for your reply. The work you have done was impressive. I also already tried what you have done in this image. What I need here the lines over the lines of this image (horizontal as well as verticle ). — Ramesh Giri, Oct 29 '19 at 21:40
https://mathematica.stackexchange.com/users/731/c-e . I am waiting for your response. I wonder if you could look at it and suggest it. — Ramesh Giri, Oct 30 '19 at 16:23
I realized that there is a much simpler way, and I wrote it down as an answer. I hope that it can be of help. — C. E., Oct 30 '19 at 21:52

C. E. · Answer 1 · 2019-10-30T22:12:59.040

This is a tricky problem for some algorithms because there are multiple grids that we may be referring to. The lines can be horizontal and vertical, but we can also find a grid of lines of equal separation that run along the diagonal. And these lines are not very well separated from other lines that we don't consider part of any grid, at all, based on our visual, intuitive understanding of the image.

I'm going to ignore all rotations and just focus on horizontal and vertical lines since that is the most obvious grid for us humans.

Start by loading the image and negating its color:

img = Import["https://i.stack.imgur.com/23UoA.jpg"];
img = ColorNegate@ColorConvert[img, "Grayscale"];

Mathematica graphics

One simple method for detecting lines is to sum the values in all columns and rows. Such data will have peaks where the lines are. It seems to be working quite well here:

data = ImageData[img];
rows = Total /@ data;
cols = Total /@ data;
Row[{ListLinePlot[rows, ImageSize -> 300], ListLinePlot[cols, ImageSize -> 300]}]

Mathematica graphics

We can use FindPeaks to find the peaks. I had to fiddle a bit with its parameters to exclude spurious peaks around the minima:

rowPeaks = FindPeaks[rows, 2, 0.2];
colPeaks = FindPeaks[cols, 2, 0.2];

Row[{
  ListLinePlot[rows, Epilog -> {
     Red, PointSize[Medium],
     Point[rowPeaks]
     }, ImageSize -> 200],
  ListLinePlot[cols, Epilog -> {
     Red, PointSize[Medium],
     Point[colPeaks]
     }, ImageSize -> 200]
  }]

Mathematica graphics

Let's see what the positions that we've found look like when we visualize them on top of the image.

HighlightImage[
 ColorNegate[img], {
  Opacity[0.2],
  InfiniteLine[{#, 0}, {0, 1}] & /@ colPeaks[[All, 1]],
  InfiniteLine[{0, 500 - #}, {1, 0}] & /@ rowPeaks[[All, 1]]
  }]

Mathematica graphics

I had to compute 500 - # because the first row is at the top, but image coordinates are reversed in the y-coordinate; in image coordinates, y is zero in the lower-left corner.

Very nice! However, if the image is rotated any more than it already is, this method probably won't work correctly, will it? I suppose you could add some function to search for the rotation that contains the highest peaks... — Carl Lange, Oct 30 '19 at 22:14
@CarlLange I did preface the question by saying that I will not consider rotation, but yeah, if there is rotation then one can, in theory at least, rotate the color negated image over a black background until one finds a good fit. But note that you run into exactly the problem that I mention in my opening paragraph; there is not just one grid in this image. — C. E., Oct 30 '19 at 22:20
Ah, sorry, I didn't see that in your answer. And that's a great point! — Carl Lange, Oct 30 '19 at 22:24

score 5 · Answer 2 · edited Oct 31 '19 at 04:43

Here is another approach (though this seems overly complicated - I'm sure there's a better way).

Pre-process the image for component detection:

img = ColorConvert[img, "Grayscale"];
img2 = Binarize[ColorNegate[img], .07]

img3 = ImageAdjust@DistanceTransform[img2]

Detect centroids of components:

spots = MorphologicalComponents[img3, .4, Method -> "Convex"];
cents = ComponentMeasurements[spots, "Centroid"][[All, 2]];
Show[Image[spots], Graphics[{Red, PointSize[Small], Point[cents]}]]

Determine the expected line spacing with a fourier transform (and help from this answer)

data = ImageData[img];
pix = Dimensions[data][[1]]
 (* 500 *)
d = data*(-1)^Table[i + j, {i, pix}, {j, pix}];
fw = Fourier[d, FourierParameters -> {1, 1}];
abs = Log[1 + Abs@fw];

Image[abs/Max[abs]]

Find the maximum (excluding the highest (middle) one)

m = Max[abs /. Max[abs] -> 0]
 (* 7.16139 *)

And the resulting distance between lines

div = Round[pix/(pix/2. - Position[abs, m][[1, 1]] + 1)]
 (* 26 *)

Find a grid with spacing div, x and y offsets x0 and y0, and rotation angle angle, that minimizes the distances between grid points and spot centroid positions:

Clear[x0, y0, angle]
grid[x0_?NumericQ, y0_?NumericQ, angle_?NumericQ] := 
  RotationTransform[angle, {pix/2, pix/2}][
   Flatten[Table[{x0 + x, y0 + y}, {x, 0, pix, div}, {y, 0, pix, 
      div}], 1]];

minfunc[x0_?NumericQ, y0_?NumericQ, angle_?NumericQ] := 
 Total[EuclideanDistance[#, Nearest[grid[x0, y0, angle], #][[1]]] & /@cents]

sol = FindMinimum[{minfunc[x0, y0, angle]}, {{x0, 10}, {y0, 10}, {angle, 0}}, Method -> "PrincipalAxis"]
 (* {805.343, {x0 -> 23.0244, y0 -> 8.93629, angle -> -0.0102424}} *)

Compare grid points and spot centroids:

Graphics[{Red, Point[cents], Blue, Point[grid[x0, y0, angle] /. sol[[2]]]}]

Make the grid lines

newgrid = 
  RotationTransform[angle, {pix/2, pix/2}][
    Table[{x0 + x, y0 + y}, {x, 0, pix, div}, {y, 0, pix, div}]] /. sol[[2]];
lines = Graphics[{Line@newgrid[[All, {1, -1}]], Line@Transpose[newgrid][[All, {1, -1}]]}];
Show[ImageAdjust[img, {0, 0, 1}, {.5, 1}], lines]

Find gridlines in image of blots arranged in a grid

2 Answers2

Linked