How to test if two plots are the same (say, for unit testing)

Question

I'd like to be able to test if two plots are the same. My use-cases involve plots that in one case might be of one type but in another of another type. Principally, I'm interested in the "calculus-and-analysis" plotters, so to speak, that produce curves, surfaces, and vector/stream plots defined by functions or equations.

Some time ago -- possibly in version 11.1 -- the obvious solution using SameQ no longer worked (see Testing equality of graphics):

Plot[x, {x, -1, 1}] === Plot[x, {x, -1, 1}]
(*  False  *)

SameQ works for some plotters, but it's hard to know which without testing:

ContourPlot[x y, {x, -1, 1}, {y, -1, 1}] === 
 ContourPlot[x y, {x, -1, 1}, {y, -1, 1}]
(*  True  *)

ContourPlot3D[10 x y z == 1, {x, -1, 1}, {y, -1, 1}, {z, -1, 1}] === 
 ContourPlot3D[10 x y z == 1, {x, -1, 1}, {y, -1, 1}, {z, -1, 1}]
(*  False  *)

The number of plotters has grown to about a hundred (not counting the *Chart ones and Histogram):

plotters = Join[
   Names["System`*Plot"],
   Names["System`*Plot3D"],
   Names["System`*Chart"],
   Names["System`*Chart3D"],
   DeleteCases[Names["System`*Histogram*"], 
    s_String /; StringMatchQ[s,
      __ ~~ ("Distribution" | "List" | "Transform" | "Interpolation")]]
   ];

plotData = WolframLanguageData[#, "DateIntroduced"] & /@ 
  Names["System`*Plot"] ~Join~ Names["System`*Plot3D"];

FoldList[{#2[[1]], #1[[2]] + #2[[2]]} &,
   Tally@Sort[DeleteCases[plotData, _Missing]]] //
 TimeSeries // 
 DateListPlot[#, Mesh -> All, 
   PlotLabel -> "Number of plotting commands by year"] &

That's a lot of checking to do. While it would be nice to have solutions that are verified for all types of plots, I'm embarrassed to ask someone to do that much work that I could do but am unwilling to do. I'd be satisfied with solutions that address the 2 and 3D versions, when they exist, of:

Plot(3D)
ParametricPlot(3D)
ContourPlot(3D)
RegionPlot(3D)
VectorPlot(3D)
StreamPlot

Having a way to test if code produces the expected plot in these cases would be sufficient for me. As I said, solutions that address more plotters would be beneficial for the site, as would noting which plotters are not addressed, but an answer to the following for the plotters above would be sufficient:

How do you test if two plots are the same?

Answer 1

The culprit in some plots is that an Annotation with an internal tag is wrapped around the graphics elements. In others (many *Chart plotters), the culprit is a DynamicModule variable that has a unique symbol. Below is a fix for Annotation, for which the undefined symbol Congruent, or ESC===ESC, seems an appropriate choice. (In practice, in code other users would use, I would use my own internal symbol.) Since the value of Annotation is its first argument, we can redefine it to be # &:

Congruent[x___] := Block[{Annotation = # &}, SameQ[x]];

The fix for the DynamicModule issue is to use the option PerformanceGoal -> Speed or set

$PerformanceGoal = "Speed"

This is mentioned in the documentation for the chart plotters. Finally, "GeoStreamPlot" and "MoleculePlot" sometimes come out the same, sometimes not. In "GeoStreamPlot", the arrows generated on what appears to be fixed data are not always the same (but sometimes are!); for instance, an edge stream line will appear in one but not the other plot. And in "MoleculePlot" there's some sort of random machine rounding error in a TransformationFunction that I cannot explain.

Code and results

I figured out how to test the first "Basic Example" from the documentation for all the plotters. Then I tested in turn SameQ[], Congruent[] (above), and SameQ[] with $PerformanceGoal = "Speed". I also tested Congruent[] with $PerformanceGoal = "Speed", but the two that failed with SameQ[] also fail with Congruent[].

The function runExample[] takes the list of Cell expressions that contains the example, converts it to an expression and runs it in a BlockRandom[] environment, so that examples that use random number generation will be reproducible. I was working on this in somewhat internet-challenged places of the world, and so I had to deal with the fact that a large sequence of queries to Wolfram servers were going to contain a certain proportion of failures. Most of you won't have to deal with that, should you want to check my work. Of course, the upshot is that you don't have to, if all you want to do is check plots (other than the two I failed to find a reliable test for).

(* retrieve first example from the docs *)
exampleCode = 
  Check[("BasicExamples" /. 
        WolframLanguageData[#, 
         "DocumentationExampleInputs"])[[1]], #] & /@ plotters;

(* attempt to get code that previous attempt failed to get *)
(* repeat as necessary *)
(* with a good internet connection, it won't be necessary *)
foo = exampleCode; (* backup in case next fails *)
exampleCode =
  Replace[exampleCode, 
   s_String :> 
    Check[Last@
      First["BasicExamples" /. 
        WolframLanguageData[echo@s, "DocumentationExampleInputs"]], s],
   1];

ClearAll[runExample];
runExample[ex : {__RawBoxes}] := Replace[
   Check[
    BlockRandom@ReleaseHold[
      ex /. r_RawBoxes :> MakeExpression[MakeBoxes@r, StandardForm]],
    Module[{$Failed}, {$Failed}]],
   {__, p_} :> p
   ];
runExample[_] := Module[{$Failed}, {$Failed}];

Examples that fail SameQ[]:

testSameQ = SameQ[runExample[#], runExample[#]] & /@ exampleCode;

sameQFailures = Extract[plotters, Position[testSameQ, False]]
sameQFailuresCode = Extract[exampleCode, Position[testSameQ, False]];

(* FAILS SameQ[]:
{"AbsArgPlot", "BodePlot", "ComplexPlot", "DiscretePlot", \
"GeoStreamPlot", "ListStreamDensityPlot", "LogLinearPlot", \
"LogLogPlot", "LogPlot", "MoleculePlot", "NicholsPlot", "NyquistPlot",
  "ParametricPlot", "Plot", "PolarPlot", "ReImPlot", \
"SingularValuePlot", "ChromaticityPlot3D", "ComplexPlot3D", \
"ContourPlot3D", "ListSliceDensityPlot3D", "ListSliceVectorPlot3D", \
"ParametricPlot3D", "Plot3D", "RevolutionPlot3D", \
"SliceDensityPlot3D", "SliceVectorPlot3D", "SphericalPlot3D", \
"KagiChart", "LineBreakChart", "PieChart", "PointFigureChart", \
"SectorChart", "TradingChart", "PieChart3D", "SectorChart3D", \
"SmoothHistogram3D"}
*)

Examples that fail SameQ[] and Congruent[]:

testCongruent = Congruent[runExample[#], runExample[#]] & /@ sameQFailuresCode;

congruentFailures = Extract[sameQFailures, Position[testCongruent, False, 1]]
congruentFailuresCode = Extract[sameQFailuresCode, Position[testCongruent, False, 1]];

(* FAILS Congruent[] and SameQ[]:
{"GeoStreamPlot", "MoleculePlot", "KagiChart", "LineBreakChart", \
"PieChart", "PointFigureChart", "SectorChart", "TradingChart", \
"PieChart3D", "SectorChart3D"}
*)

Examples that fail SameQ[] (and Congruent[]) with $PerformanceGoal = "Speed":

Block[{$PerformanceGoal = "Speed"},
 testPGSameQ = SameQ[
     runExample[#] /. 
      s_Symbol /; ! 
         MatchQ[Context[Unevaluated@s], "System`" | "Global`"] :> 
       RuleCondition[s], 
     runExample[#] /. 
      s_Symbol /; ! 
         MatchQ[Context[Unevaluated@s], "System`" | "Global`"] :> 
       RuleCondition[s]
     ] & /@ congruentFailuresCode
 ]

pgSameQFailures = Extract[congruentFailures, Position[testPGSameQ, False, 1]]
pgSameQFailuresCode = Extract[congruentFailuresCode, Position[testPGSameQ, False, 1]];

(*  {"GeoStreamPlot", "MoleculePlot"}  *)