31
$\begingroup$

I have two screenshots:

For a long screenshot picture I usually use PhotoShop to combine both images:

How do I use Mathematica to make an automated program to do this?

Is there a smarter method?The ImageCorrespondingPoints should be helpful,but I I don't know how to realize it.

Update:


The @Arnoud Buzing's answer almost solve this problem,but there are TWO difficulties still to overcome

1. First difficulty:

As the answer we can build a function to do this:

MergeImage[image1_, image2_] := 
 Module[{i1 = ImageData[image1], i2 = ImageData[image2]},
  {s1, s2} = LongestCommonSubsequencePositions[i1, i2];
  Join[Take[i1, Last@s1], Take[i2, {Last@s2 + 1, -1}]] // Image]

But when the

image1 is image2 is

Due to the common subsequence is not the Longest,the long-screenshots will be wrongly merge.

2. Second difficulty:

The MergeImage we built cannot distinguish this ordring of these screenshots automatically.Such as we can run it MergeImage[image1, image2],But not MergeImage[image2, image1].There is a image3:

If our last MergeImage can run it like this to get the right long-screenshots,the problem have been solved.

MergeImage[RandomSample[{image1, image2, image3}]]
$\endgroup$
7
  • 1
    $\begingroup$ Life would be easier if you first crop out the top of image2, image3 etc before attempting anything automatic. $\endgroup$
    – user484
    Mar 6, 2016 at 15:19
  • $\begingroup$ Possibly related: mathematica.stackexchange.com/q/32612/484 $\endgroup$
    – user484
    Mar 6, 2016 at 15:22
  • $\begingroup$ @Rahul Because the image2image3 can be different picture completely.I just use SE's screenshots to express this kind of question in here.So If you wanna crop it manually,It is a very dull works.And your case of that link have no part which is juxtaposition each other. $\endgroup$
    – yode
    Mar 6, 2016 at 15:44
  • $\begingroup$ You don't need to crop it exactly, you just need to get rid of the top bar assuming you know roughly how big it is. $\endgroup$
    – user484
    Mar 6, 2016 at 16:56
  • $\begingroup$ I think it worth pointing out that in version 13, Mathematica introduces ImageStitch. $\endgroup$
    – Ben Izd
    Jul 10, 2022 at 3:57

6 Answers 6

26
$\begingroup$

Very roughly (using image1 and image2):

i1 = ImageData[image1];
i2 = ImageData[image2];
css = LongestCommonSubsequence[i1, i2];
s1 = SequencePosition[i1, css];
s2 = SequencePosition[i2, css];
Join[Take[i1, s1[[1,2]] ], Take[i2, {s2[[1,2]] + 1, -1}]] // Image

That seems to work for me and gives the images concatenated together.

$\endgroup$
2
  • $\begingroup$ i1 = ImageData[image1]; i2 = ImageData[image2]; {s3, s4} = LongestCommonSubsequencePositions[i1, i2]; Join[Take[i1, Last@s3], Take[i2, {Last@s4 + 1, -1}]] // Image $\endgroup$
    – yode
    Mar 6, 2016 at 8:47
  • $\begingroup$ I have make this problem more clear just now.If you are available,you can take a try please. $\endgroup$
    – yode
    Mar 6, 2016 at 9:40
13
+100
$\begingroup$

This solves your "entangled images" case.

ClearAll[getMinRowFromImage, getBestMatch, findAllMatches, joinImages,
         findImagesSequence, getIntensity];

getIntensity[i_Image, pos_List] :=
 (* Calculates the intensity of a pixel for any image color space.*)
 First@ColorConvert[Flatten@{PixelValue[i, pos]}, ImageColorSpace[i] -> "Grayscale"]

getMinRowFromImage[i_Image] :=
 (* returns the min intensity value for an image and the row where it occurs*)
 {getIntensity[i, #[[1]]], #[[1, 2]]} &@PixelValuePositions[i, "Min"]

getBestMatch[i_List, {m_Integer, n_Integer}, lines_Integer] :=
 (* Finds the best match between i[[n]] and the last lines of i[[m]].
 Note that "Padding -> None" is what allows this to run within 
 reasonable time, calculating the correlation only by rows and 
 thus returning single column image*)
 getMinRowFromImage@ImageCorrelate[i[[n]], ImageTake[i[[m]], -lines],
                                  CorrelationDistance, Padding -> None]

findAllMatches[i_List, lines_Integer, sens_Real] :=
 (*forms all permutations {m,n} from the list of images
 calculates the best match between all pairs and 
 select those below the sensitivity parameter
 Could be done more efficiently, since we expect only one 
 valid continuation foreach image, so we don't really need to 
 calculate them all*)
 With[{permutations = Position[IdentityMatrix[Length@i], 0]},
  Select[{#, getBestMatch[i, #, lines]} & /@ permutations, #[[2, 1]] < sens &]
  ]  

.

findImagesSequence[g_Graph] :=
 (* g is  a directed PathGraph whose wheights are the best match lines 
 for each pair. So, the Max of the distance matrix is at the 
 {head, tail} pair. We  find the (only) path that goes from head
 to tail, hence finding the right image sequence. There is a function 
 in Mma help that does the same for undirected Graphs, but I think 
 this one is better for our purpose *)
 FindShortestPath[g, Sequence @@ VertexList[g][[First@Position[#, Max@#] &
                                          [GraphDistanceMatrix@g /. ∞ -> 0]]]]

joinImages[i_List, linesToMatch_Integer, sens_Real] :=
 (* Ensambles a full image from parts consisting in same column width 
 images matching from some row onwards for a minumum of "linesToMatch".
 The sensitivity parameter seeme not really needed but perhaps useful 
 for very similar images
 *)
 Module[{matches, g, seqimg, fromline},
  (* First find the pairs matching *)
  matches = findAllMatches[i, linesToMatch, sens];

  (*Now we build up the whole sequence, from head to tail.
  Graph features are great for that*)
  g = Graph[Rule @@@ #[[All, 1]], EdgeWeight -> Flatten@#[[All, 2, 2]]] &@matches;
  seqimg = findImagesSequence[g];
  fromline = PropertyValue[{g, DirectedEdge @@ #}, EdgeWeight] & /@ 
                                                        Partition[seqimg, 2, 1];

  (*Finally assemble the whole thing*)
  ImageAssemble@Join[{{i[[First@seqimg]]}},
    MapThread[{ImageTrim[#1, {{0, #2}, {ImageDimensions[#1][[2]], 0}}]} &,
              {i[[Rest@seqimg]], fromline}]]
  ]

Usage:

l = {"https://i.stack.imgur.com/IXFEq.png",
     "https://i.stack.imgur.com/FMtjm.png",
     "https://i.stack.imgur.com/aj8a1.png"};
(*Resize and GrayScale for speed*)
i = ImageResize[#, 500] & /@ (ColorConvert[#, "Grayscale"] & /@ Import /@ l);

sensitivity = .1;
lnsTomatch = 150;
joinImages[i, lnsTomatch, sensitivity]

Coloring not included in this code, used here to show how the image was composed from the three snapshots. The last step (the joining of images, excluding the import part) is instantaneous in my machine.

Mathematica graphics

$\endgroup$
7
  • $\begingroup$ "<del>Perhaps</del> I'll add some explanations" $\endgroup$
    – Aisamu
    Mar 14, 2016 at 22:21
  • $\begingroup$ It seem that you can reach the top of another mountain just cost my a nap time. $\endgroup$
    – yode
    Mar 14, 2016 at 23:19
  • $\begingroup$ The bounty expiring soon.I must choose a answer.But some bugs are exist still in this code.It'll give some error information when I run it like this.Look forward to your explanations and consummating it. $\endgroup$
    – yode
    Mar 15, 2016 at 14:13
  • $\begingroup$ Of course I have run that sentence of ImageResize.But the error imformations is still.And after this post,I'll take a good study of Graph Theory to follow your steps. $\endgroup$
    – yode
    Mar 15, 2016 at 15:41
  • 1
    $\begingroup$ @Aisamu Done :) $\endgroup$ Mar 17, 2016 at 16:31
6
$\begingroup$

This answer is late but stronger,I have packed it in a custom function and name after CombineImage.And since for merge some cell phone screenshots,the height should be same.Considering some APP has bottom menu bar,this answer actually can adapt that more complicated case than my original question

CombineImage[imgs_List] := 
 Module[{bottom, top, crop, data, threshold, height, bins, sortBins, 
   seq, oderImgs, order}, {bottom, top} = 
   Min /@ Transpose[
     BlockMap[Last[BorderDimensions[ImageSubtract @@ #]] &, imgs, 2]];
  crop = ImageTake[#, {top + 1, 
       Last[ImageDimensions[First[imgs]]] - bottom}] & /@ imgs;
  data = ImageData /@ crop;
  threshold = 
   Min[ImageMeasurements[ColorConvert[#, "Grayscale"] & /@ crop, 
     "Mean"]];
  height = Last[ImageDimensions[First[crop]]];
  bins = Binarize[#, threshold] & /@ crop;
  sortBins = 
   FindHamiltonianPath[
    RelationGraph[
     Sign[N[Mean[#]/height] & /@ 
          LongestCommonSubsequencePositions @@ 
           ImageData /@ {##} - .5] === {1, -1} &, bins]];
  order = FindPermutation[bins, sortBins]; {oderImgs, data} = 
   Permute[#, order] & /@ {imgs, data};
  seq = Developer`PartitionMap[
    LongestCommonSubsequencePositions @@ # &, ImageData /@ sortBins, 
    2, 1];
  Image[Join[
    Take[ImageData[First[oderImgs]], seq[[1, 1, 1]] + top - 1], 
    Sequence @@ 
     MapThread[
      Take, {data[[2 ;; -2]], 
       Partition[First /@ Catenate[seq][[2 ;; -2]], 2]}], 
    Take[ImageData[Last[oderImgs]], 
     seq[[-1, -1, 1]] - bottom - height - 1]]]]

Usage

I have provided four images to test in following

imgs = Import /@ {"https://i.stack.imgur.com/gmfPU.png", 
    "https://i.stack.imgur.com/sHJat.png", 
    "https://i.stack.imgur.com/LSbUk.png", 
    "https://i.stack.imgur.com/sOoGi.png"};
CombineImage[RandomSample[imgs]]

Note I use a RandomSample to show I don't care the order of image list.


Code interpretation

Get the crop images which delete the margin on top and the bottom.Note the notification bar are not very accordance

{bottom, top} = 
 Min /@ Transpose[
   BlockMap[Last[BorderDimensions[ImageSubtract @@ #]] &, imgs, 2]];
crop = ImageTake[#, {top + 1, 
     Last[ImageDimensions[First[imgs]]] - bottom}] & /@ imgs

enter image description here Calculate a threshold for binarize the image for speed.And for showing all valid information as much as possible,I will use a mean value.We cannot use Grayscale here like this anser by Dr. belisarius,which will make the imgs have little difference even the part is same tatally.

data = ImageData /@ crop;
threshold = 
  Min[ImageMeasurements[ColorConvert[#, "Grayscale"] & /@ crop, 
    "Mean"]];

0.824459

If the following page will continue the above page,the follow centre must be larger than $50\%height$ of the image,this is a explanatory drawing when the next page cover $90%$ of the above.The center of the next is $5.5(>50\% height)$ still.

Since this,we can sort the imgs,I will use RelationGraph to do this

height = Last[ImageDimensions[First[crop]]];
bins = Binarize[#, threshold] & /@ crop;
toImgs = Thread[bins -> imgs];
toCrop = Thread[bins -> crop];
sortImgs = 
 FindHamiltonianPath[
  RelationGraph[Sign[N[Mean[#]/height] & /@ 
        LongestCommonSubsequencePositions @@ 
         ImageData /@ {##} - .5] == {1, -1} &, bins]]

enter image description here

Use LongestCommonSubsequencePositions to find the overlapping part.Note we process all of imgs which have been croped.So when we recover it,we should use toImgs and toCrop

seq = Developer`PartitionMap[LongestCommonSubsequencePositions @@ # &,
    ImageData /@ sortImgs, 2, 1];
Image[Join[
  Take[ImageData[First[sortImgs] /. toImgs], 
   seq[[1, 1, 1]] + top - 1], 
  Sequence @@ 
   MapThread[
    Take, {Map[ImageData, sortImgs /. toCrop][[2 ;; -2]], 
     Partition[First /@ Catenate[seq][[2 ;; -2]], 2]}], 
  Take[ImageData[Last[sortImgs] /. toImgs], 
   seq[[-1, -1, 1]] - bottom - height - 1]]]

Then we get the long combine image.And I also give clor image for comparison enter image description here

$\endgroup$
3
$\begingroup$

When working with screenshots taken on a FullHD Android 10 smartphone, I found that the LongestCommonSubsequencePositions approach is unapplicable for them because the intensities slightly vary from one screenshot to another. The reason probably is that the screenshots were saved by the system as lossy JPEGs. In any case, I was forced to use much lesser pleasant ImageAlign for stiching them. Apart from the fact that it works slowly, it also is unstable and there is no way to restrict it to search for vertical alignment only. But in the implementation below I overcome this problem by "helping" ImageAlign via cropping the original image in different ways. Not ideal, but works.

First, load a testing set of screenshots:

imgs = Import /@ {"https://i.imgur.com/sXrjTom.jpg", "https://i.imgur.com/gWvFAod.jpg", 
                  "https://i.imgur.com/achK7u2.jpg", "https://i.imgur.com/4SWtQID.jpg", 
                  "https://i.imgur.com/Sbm3AZS.jpg", "https://i.imgur.com/87qCEqW.jpg", 
                  "https://i.imgur.com/nOOvWvJ.jpg", "https://i.imgur.com/t74mRht.jpg", 
                  "https://i.imgur.com/LY2tYa5.jpg", "https://i.imgur.com/bwZDNQz.jpg", 
                  "https://i.imgur.com/LUMa0YU.jpg", "https://i.imgur.com/i2gqr5B.jpg", 
                  "https://i.imgur.com/WIxrUGt.jpg", "https://i.imgur.com/QuhX70R.jpg", 
                  "https://i.imgur.com/jfCTehS.jpg", "https://i.imgur.com/eoULwVr.jpg", 
                  "https://i.imgur.com/BR4prMJ.jpg"};

Crop them:

imgsCrop = ImageTake[#, {230, 2210}] & /@ imgs;

Combine them:

findTranslVector[i1_, i2_, part_] := Module[{err, tr},
   {err, tr} = 
    FindGeometricTransform[ImageTake[i1, -part], ImageTake[i2, part], 
     TransformationClass -> "Translation", Method -> {"ImageAlign", "Fourier"}];
   {err, tr["AffineVector"]}
   ];

findCrop[i1_, i2_, thr_ : 10^-4] := 
  Module[{height, part, step, err = Infinity, tr, dx, dy},
   height = ImageDimensions[i1][[2]];
   step = Round[height/10];
   part = Round[height/3];
   While[4 < part <= height && (err > thr || dx != 0 || dy > 0),
    {err, {dx, dy}} = findTranslVector[i1, i2, part];
    Echo[Style[<|"err" -> err, "crop" -> -(dy - height + part), "disp" -> {dx, dy}|>, 
      If[err < thr && dx == 0 && dy <= 0, {}, Red]]];
    part -= step;
    If[part < 4, part = Round[height/3] + step; step = -step]
    ];
   If[err < thr && dx == 0 && dy <= 0,
    -(dy - height + part + step), $Failed]
   ];

finalImage = 
  ImageAssemble[
   Append[Table[{ImageTake[imgsCrop[[i]], 
       findCrop[imgsCrop[[i]], imgsCrop[[i + 1]]]]}, {i, 1, Length[imgsCrop] - 1}], 
      {Last[imgsCrop]}]];

Export it:

Export["Final Image.png", finalImage]

During the work, the main function findCrop prints diagnostic information. By Red are highlighted the cases when ImageAlign wasn't able to find the right transformation. For example, here 9 attempts were necessary to find the right transformation:

screenshot

$\endgroup$
2
  • $\begingroup$ If I remember correctly you are a staff member of wolfram? I've been looking forward to having a function to measure the similarity of the content of two images. That might help this a lot, combined with RelationGraph $\endgroup$
    – yode
    Apr 11, 2022 at 9:34
  • $\begingroup$ @yode Unfortunately, I'm not at Wolfram. $\endgroup$ Apr 11, 2022 at 9:35
3
$\begingroup$

Here I present another implementation based on the findings from this answer. It doesn't depend on ImageAlign or LongestCommonSubsequencePositions and uses direct linear search for finding the perfect alignment. With the default settings it is already sufficiently fast and robust, but one can try to decrease the search window for larger speed (with narrower search window some parasite additional alignments may appear, and in such situations algorithm automatically increases the window). One can also try to decrease the shrinking factor hStep if the algorithm fails completely (the default hStep subsamples the original images in the horizontal direction with targed width about 50 pixels, what may be too small in some situations). The algorithm requires the screenshots to be successive and of equal width, but allowed to have different heights.

Here is the implementation (one may comment out the Echo that prints the diagnostic plot):

Clear[distance, extractAlignments, findAlignments, findCrop]
distance[id1_, id2_, align_, maxWindow_] := 
 Module[{dists = 
    Abs[Flatten[
      Normal@id1[[align ;; Max[1, align - maxWindow + 1] ;; -1]] - 
       Normal@id2[[;; Min[align, maxWindow]]]]]}, {align, 
   Max[Max[dists] - Min[dists], Total[TakeLargest[dists, 20]]/20.]}]
extractAlignments[distances_, thr_] := 
  Module[{minimums = 
     Select[DeleteCases[
       SplitBy[distances, Last[#] <= thr &], {{1, _}, ___}], #[[1, 2]] <= thr &]}, 
   If[MemberQ[Length /@ minimums, _?(# > 1 &)], {}, minimums[[All, 1]]]];
findAlignments[id1_, id2_, initAlign_, maxWindow_, hStep_, thr_ : 55] := 
  Module[{width, height, hstep, distances, alignments}, height = Dimensions[id1][[1]];
   distances = Table[distance[id1, id2, align, maxWindow], {align, initAlign, height}];
   alignments = extractAlignments[distances, thr];
   Echo[ListLinePlot[distances, PlotRange -> All, ImageSize -> 550, AspectRatio -> 1/8, 
     GridLines -> {Prepend[
        alignments[[All, 1]], {maxWindow, 
         Directive[{Darker@Yellow, AbsoluteThickness[2], AbsoluteDashing[3]}]}], {thr}}, 
     PlotStyle -> Directive[{Blue, JoinForm["Round"]}], 
     GridLinesStyle -> {Directive[{Green, AbsoluteThickness[6]}], 
       Directive[{Red, Thin, AbsoluteDashing[1]}]}, 
     PlotLabel -> 
      Style[<|"alignments" -> alignments[[All, 1]], "distances" -> alignments[[All, 2]], 
        "maxWindow" -> maxWindow, "hStep" -> hStep, "thr" -> thr|>, 10]]];
   alignments[[All, 1]]];
findCrop::multiPeak = 
  "No confident alignment found. Trying again with doubled maximum window height `` \
pixels.";
findCrop::window = 
  "Maximal height of the window can't be larger than the heigth of the smallest image. \
The maximal window height is set to ``.";
findCrop::imageDims = 
  "The widths and numbers of channels of the screenshots must be equal. Aborting.";
findCrop[i1_, i2_, initAlign_ : 20, maxWindow_ : 400, hStep_ : Automatic, thr_ : 55] := 
  Module[{width, height, hstep, maxwindow, id1, id2, distances, alignments = {}},
   {width[1], height[1]} = ImageDimensions[i1];
   {width[2], height[2]} = ImageDimensions[i2];
   hstep = If[hStep === Automatic, Quotient[width[1], 50], hStep];
   id1 = Image`InternalImageData[i1, Interleaving -> True, 
       DataReversed -> True][[All, ;; ;; hstep]];
   id2 = Image`InternalImageData[i2, Interleaving -> True][[All, ;; ;; hstep]];
   If[Most@Dimensions[id1] =!= Most@Dimensions[id2], Message[findCrop::imageDims]; 
    Abort[]];
   If[TrueQ[maxWindow > Min[height[1], height[2]]], maxwindow = Min[height[1], height[2]];
     Message[findCrop::window, maxwindow], maxwindow = maxWindow];
   While[Length[alignments] != 1, 
    alignments = findAlignments[id1, id2, initAlign, maxwindow, hstep, thr];
    If[Length[alignments] != 1, maxwindow = Min[2 maxwindow, height[1], height[2]];
     Message[findCrop::multiPeak, maxwindow]];];
   height[1] - alignments[[1]]];

Here is how it can be used:

First, load a testing set of screenshots:

imgs = Import /@ {"https://i.imgur.com/sXrjTom.jpg", "https://i.imgur.com/gWvFAod.jpg", 
                  "https://i.imgur.com/achK7u2.jpg", "https://i.imgur.com/4SWtQID.jpg", 
                  "https://i.imgur.com/Sbm3AZS.jpg", "https://i.imgur.com/87qCEqW.jpg", 
                  "https://i.imgur.com/nOOvWvJ.jpg", "https://i.imgur.com/t74mRht.jpg", 
                  "https://i.imgur.com/LY2tYa5.jpg", "https://i.imgur.com/bwZDNQz.jpg", 
                  "https://i.imgur.com/LUMa0YU.jpg", "https://i.imgur.com/i2gqr5B.jpg", 
                  "https://i.imgur.com/WIxrUGt.jpg", "https://i.imgur.com/QuhX70R.jpg", 
                  "https://i.imgur.com/jfCTehS.jpg", "https://i.imgur.com/eoULwVr.jpg", 
                  "https://i.imgur.com/BR4prMJ.jpg"};

Crop them:

imgsCrop = ImageTake[#, {230, 2210}] & /@ imgs;

Find the cropping heights for the screenshots (I intentionally set here too small value for maximum window height just to demonstrate how the algorithm behaves in ambiguous situations):

crops = Table[findCrop[imgsCrop[[i]], imgsCrop[[i + 1]], 1, 100], {i, Length[imgsCrop] - 1}];

screenshot

{1368, 1400, 1419, 1547, 1334, 1324, 1531, 1524, 1433, 1571, 1608, 1525, 1333, 1485, 1541, 499}

Now assemble the final image and export it:

finalImage = 
  ImageAssemble@
   Append[Table[{ImageTake[imgsCrop[[i]], crops[[i]]]}, {i, 
      Length[imgsCrop] - 1}], {imgsCrop[[-1]]}];

Export["Final Image.png", finalImage]
$\endgroup$
2
$\begingroup$

Since this is an iphone screenshot, we know the exact pixel dimensions of the toolbar and so no fancy sequence matching need be done:

MergeImage[image1_, image2_] := Module[{i1, i2, i3},
  i1 = ImageData[image1][[;; 228]];
  i2 = ImageData[image1][[228 ;;]];
  i3 = ImageData[image2][[228 ;;]];
  Join[i1, i2, i3] // Image]

enter image description here

$\endgroup$
1
  • $\begingroup$ Thanks a lot for your answer,but maybe you misunderstand this topic.1.The screenshot from XiaoMi cell-phone(base in Andriod).2.Maybe ImageTake+ImageAssemble Can do what you have done.3.We have image1image2 and image3.And we want get a long screenshot by they,but they have some repeated part each other(you can look these picture carefully). $\endgroup$
    – yode
    Mar 14, 2016 at 7:53

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.

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