2
$\begingroup$

Is there any possibility to reproduce the following in Mathematica:

enter image description here

Based on my previous question here, I can obtain the real coordinates of some of the points, in particular those whose their $x$ coordinates are known, i.e., $x = 2, 8, 16$. But how can I obtain the others and also to produce such a plot?

$\endgroup$
12
  • $\begingroup$ There are quite a few posts for extracting plot points on stack exchange. Maybe you can use the answers here. I tried the one in the first answer and it is quite enjoyable to use. $\endgroup$ Nov 16, 2022 at 21:53
  • 1
    $\begingroup$ You might also be interested in WebPlotDigitizer $\endgroup$ Nov 16, 2022 at 22:11
  • 1
    $\begingroup$ If you just want to upload a clean version of the plot in svg or pdf format in your thesis then you can vectorize the image. There are options online but they are not free as I understand. This Mathematica code gives a result that is not too bad ImageGraphics[img, Method -> "DualMarchingSquares"] but the online options might look nicer. You can choose other methods if you prefer. $\endgroup$ Nov 18, 2022 at 9:59
  • 1
    $\begingroup$ Perhaps Inkscape would give a nicer vectorized image but I am not really good at using inkscape. $\endgroup$ Nov 18, 2022 at 10:21
  • 1
    $\begingroup$ Actually i found a lot of free image vectorizations web pages. One way to find them is to google alternatives for a non free one. That said, one should verify the safety and privacy of such sites. $\endgroup$ Nov 18, 2022 at 18:08

2 Answers 2

5
$\begingroup$

The tricky part is finding coordinates from the touching points. One idea is from a WRI blog post on microscopy application.

To focus on isolating the points, crop the image to remove the frame. Then erode to clean the image and remove the dashed horizontal line:

img1 = Binarize[Erosion[ColorNegate[img],3]]

This makes the points more distinct, but they still touch as seen in this image (width reduced to 200 pixels for this post, but the evaluation used the original size):

enter image description here

Then use DistanceTransform and MaxDetect to estimate centers of the points, even those that touch:

centers = ComponentMeasurements[MaxDetect[DistanceTransform[img1]], "Centroid", All, "ComponentAssociation"]

A plot of these points:

ListPlot[Values@centers, AspectRatio -> Automatic, PlotStyle -> Black]

point centers

This gets some of the touching points, but not all. Adjusting erosion and binarizing thresholds may help.

These points are measured in pixels. The Get Coordinates tool on the graphic allows determining the coordinates.

The horizontal locations of the middle of the three groups are at about 150, 440 and 730. The horizontal scale in the original image appears to be labels, not equally spaced logarithmic since the value of 4 is missing. So is not clear what the original horizontal coordinates are. Instead we can use the locations of the group centers for horizontal tick labels.

The vertical locations range from 18 for the minimum value, corresponding to 0 on the original image, to about 715 for the point just below the horizontal dashed line with coordinate 100. Rescaling the vertical values reproduces the original coordinates.

points = {#[[1]], Rescale[#[[2]], {18, 715}, {0, 100}]} & /@ centers;

Plot these points with the labels for the horizontal groups, a dashed grid line, and vertical tick label to indicate values above 100:

ListPlot[Values@points,
  PlotStyle -> Black, AspectRatio -> 1,
  GridLines -> {None, {100}},
  GridLinesStyle -> Directive[Black, Dashed],
  Ticks -> {{{150, 2}, {440, 8}, {730, 16}}, 
    Append[Range[0, 100, 20], {120, ">100"}]},
  LabelStyle -> 14
]

enter image description here

$\endgroup$
5
  • 1
    $\begingroup$ @Marteen I had made a mistake with the base 2 log scale. It should be 2 4 8 16 in that case. Thus, the 2 8 and 16 seem to be just labels. If you obtain enough of the points as a list of data you can maybe ask as a separate question how to reproduce that figure although maybe some people here might consider that you should edit this question instead by mentioning that you now have the data. Maybe using ListPlot and removing the horizontal ticks and labels and placing 2 8 and 16 after. $\endgroup$ Nov 18, 2022 at 10:31
  • $\begingroup$ @Marteen: see the edit which gets the vertical coordinates. It's not clear how to interpret the horizontal scale, but we can reproduce the labels with Ticks. $\endgroup$
    – tad
    Nov 18, 2022 at 17:59
  • 1
    $\begingroup$ They're the y coordinates on image of two points: one at the bottom and another just below the horizontal dashed line. You can get coordinates of any point in an image with the Get Coordinates tool in a Mathematica notebook (right-click on the image and select Get Coordinates then move your mouse to the point you're interested in). $\endgroup$
    – tad
    Nov 22, 2022 at 17:43
  • 1
    $\begingroup$ For the vertical coordinate, you can use the same method with Rescale as I used to convert from centers to points. The horizontal scale isn't clear, e.g., what horizontal coordinate would you assign a point halfway between 2 and 8 on the horizontal axis. If you determine the horizontal scaling, you could adjust the first coordinate analogously to that for the vertical coordinate. I hope that helps. $\endgroup$
    – tad
    Nov 28, 2022 at 22:12
  • 1
    $\begingroup$ The Get Coordinates tool on that plot will give both horizontal & vertical coordinates of any point you click on. Check the documentation for examples. $\endgroup$
    – tad
    Nov 29, 2022 at 22:24
3
$\begingroup$

See links at the end for documentation links of Mathematica functions used in this answer. One possibility might be to copy paste the current page to a separate tab and scroll to the bottom there to check documentation when needed.


I will focus here on the clumps of points that make it hard to obtain the markers.


Edit

The previous version was slow and did not provide a tight packing of disks in the clumps.

The idea here will be to choose a circle that is close to the boundary of the clump using Erosion[img,DiskMatrix@radius] where radius is the typical radius of disk in the image. Then we will obtain the curve from the eroded contour with ImageMeasurements and then choose a random point on this contour which will have a radius distance with the original boundary. Then we define the new region to be the previous region minus the disk found. We repeat the process above recursively.

First we upscale the image to have less pixeled circles later:

Note : Image@ImageGraphics changes the size of the images in certain versions such as mathematica 13.1. Hence the scales given in the other answer would have to be re computed or adjusted to the image sizes here.

img3 = Image@ImageGraphics[img2, Method -> "Exact"];

Second, we remove the components that are completely attached to clumps. We need to separate the little links they have with one another. This is done using Erosion.

HighlightImage[img3, {Magenta, ColorNegate@img4, Blue, 
  Erosion[ColorNegate@img4, 3]}]

The image below shows the original image, the binarized image in red and the eroded binarized image in blue. Notice that the eroded regions are better separated than in the binarized image.

enter image description here

We can then extract just the clumps using:

img5 = img4 // ColorNegate // Erosion[#, 3] & // 
    SelectComponents[#, Large] & // Dilation[#, 3] & // ColorNegate;

enter image description here

Now we erode the clump and center a disk at a random part of the boundary of the eroded region. I chose a radius of 5.6 a bit arbitrarily you might want to adjust that.

contours = 
  img5 // ColorNegate // Erosion[#, DiskMatrix[5.6]] & // 
   ImageMeasurements[#, "Contours"] &;

point = contours // RegionUnion // RandomPoint;

disk = Disk[point, 5.6];

Next we make a mask from disk. As I understand, recent versions of Mathematica have a bug that makes it difficult to convert regions to image while preserving coordinates. This work around worked for me. You should check if it works for you.

mask = Binarize@ImageResize[#, ImageDimensions[img5]] &@
  ImageCrop@
   Image@Graphics@
     RegionDifference[
      BoundaryDiscretizeRegion@
       Rectangle[{0, 0}, ImageDimensions@img5], 
      BoundaryDiscretizeRegion@disk]

HighlightImage[img5, {contours, Blue, disk, Green, mask}]

The image below shows the contour of the eroded region and the disk centered at a point of the boundary of the eroded region. Notice that the circle is very close to the boundary of the original image. You should check whether the blue and green overlap which implies that the mask overlaps well with the disk position.

enter image description here

We now remove the disk from the original img5:

img5 = ImageDifference[img5, mask]

enter image description here

We then repeat the process. The function below repeats the process above:

getDisks[img_, radius_, iterations_] :=
 Module[{contours, point, disk,
   diskList, imgaux, scale, mask},
  
  imgaux = Binarize@img;
  
  diskList = {};
  
  Do[
   contours = 
    imgaux // ColorNegate // Erosion[#, DiskMatrix[radius]] & // 
     ImageMeasurements[#, "Contours"] &;
   
   point = contours // RegionUnion // RandomPoint;
   
   disk = Disk[point, radius];
   
   diskList = {\[FormalW] @@ point, diskList};
   
   mask = 
    Binarize@ImageResize[#, ImageDimensions[img]] &@
     ImageCrop@
      Image@Graphics@
        RegionDifference[
         BoundaryDiscretizeRegion@
          Rectangle[{0, 0}, ImageDimensions@img], 
         BoundaryDiscretizeRegion@disk];
   
   imgaux = ImageDifference[imgaux, mask];
   
   , iterations];
  
  Flatten[diskList, Infinity] /. \[FormalW] -> List // 
   Map[Disk[#, radius] &]
  
  ]

Test and example

(NI decreased the disk radius because I was trying to fit more disks. You might need to adjust the radius to your needs)

HighlightImage[img5, getDisks[img5, 5.4, 51]]

enter image description here

If time is not much of an issue you can also consider using getDisks on the entire image (other than the labels) (img5 will be defined in the preprocessing step below):

HighlightImage[img5, getDisks[img5, 4, 100]]

100 disks (you can probably ask for more but it takes a while if time is important it might be best to use the code above only on the clumps )

enter image description here

The preprocessing:

The cropped image which is set to img2

enter image description here

vectorize the image:

img3 = Image@ImageGraphics[img2, Method -> "Exact"]

remove noise :

img4 = ColorNegate@DeleteSmallComponents[#, 40] &@
       ColorNegate@Binarize@img3

remove horizontal lines :

img5 = Erosion[#, 3] &@Dilation[img4, 3]

Previous version

The idea is to randomly pack markers within that region. Getting markers to fit within the region is non trivial given the shape of the clumps. Here is an attempt:

First we can focus on the first clump by cropping the image:

clump

That image is called img2 in the following. To extract the clump we could maybe use :

mesh = ImageMesh@ColorNegate@Binarize@img2

Without any parameters, Binarize will remove the light gray markers. You can use something like Binarize[img2, 0.9] to get some or all of the gray markers (I did not check if all are kept). In the following, the gray markers are discarded.

Then one may obtain disks that are roughly/approximately contained within the region:

r = 2 (* Radius of disk as an example. I did not check what the radius should be *);

circlearea = π*r^2

disks = Select[(1/circlearea)
      RegionMeasure@
       RegionIntersection[BoundaryDiscretizeRegion@#, mesh] > 0.9 &]@
   Thread@Disk[RandomPoint[mesh, 10000], 2];

nooverlaps = 
  DeleteDuplicates[disks, 
   Not[RegionIntersection[#1, #2] === EmptyRegion[2]] &];

visualization of the markers:

Graphics[{Red, Opacity[0.2], mesh}~Join~{Blue}~Join~nooverlaps, 
 Background -> White]

markers_randomly_placed

With 10000 markers it takes a lot of time and the region was not filled with the random points I got.


Links below are generated automatically using Mathematica on the text of this answer . May contain errors .

{Erosion,DiskMatrix,ImageMeasurements,First,Image,ImageGraphics,Method,HighlightImage,Magenta,ColorNegate,Blue,SelectComponents,Large,Dilation,Now,Contours,RegionUnion,RandomPoint,Disk,Next,Binarize,ImageResize,ImageDimensions,ImageCrop,Graphics,RegionDifference,BoundaryDiscretizeRegion,Rectangle,Green,ImageDifference,Module,Do,[[FormalW]](https://reference.wolfram.com/language/ref/\[FormalW].html),Flatten,Infinity,List,Map,If,DeleteSmallComponents,Previous,Here,ImageMesh,In,Select,RegionMeasure,RegionIntersection,Thread,DeleteDuplicates,Not,EmptyRegion,Red,Opacity,Join,Background,White,With,Links}

$\endgroup$
4
  • 1
    $\begingroup$ You can use Echo and EchoFunction to manually check parts you do not understand. To check the sequence of all the steps you can use traceview2 from this answer : mathematica.stackexchange.com/a/29340/86543 $\endgroup$ Nov 19, 2022 at 8:12
  • 1
    $\begingroup$ I used BoundaryDiscretizeRegion@# to transform a disk into a mesh so that Mathematica could compute the area of the intersection between the disk and the clump region. Mathematica will not compute the area in this case without discretizing the disk. $\endgroup$ Nov 19, 2022 at 8:16
  • 1
    $\begingroup$ ColorNegate@ was necessary to mesh the black region rather than the white background. The Background -> White is because I use a custom style sheet where the background is not white but it is not needed if you use the default white background color. $\endgroup$ Nov 19, 2022 at 8:30
  • 1
    $\begingroup$ @Marteen depends you can't know until you try. I learned those stuff I wrote here in a couple of days but I was curious about it and tried some of the stuff I read so I remembered more and faster. That said I have been using Mathematica since 2017 so it's more like learning new words in a language you already know fairly well at this point for me. $\endgroup$ Nov 21, 2022 at 13:42

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.