Generating a broken or snipped axis in ListPlot

Question

I have two data sets, data1 and data2. For example:

data1 = {{1, 1.1}, {2, 1.5}, {3, 0.9}, {4, 2.3}, {5, 1.1}};
data2 = {{1, 1001.1}, {2, 1001.5}, {3, 1000.9}, {4, 1002.3}, {5, 1001.1}};
ListPlot[data1, PlotRange -> All, Joined -> True, Mesh -> Full, PlotStyle -> Red]
ListPlot[data2, PlotRange -> All, Joined -> True, Mesh -> Full, PlotStyle -> Blue]

Their $y$-values are in vastly different regimes, but their oscillations in $y$ are comparable, and I'd like to compare them visually using ListPlot. But if I simply overlay them, it is nearly impossible to see and compare their oscillations, because of the scaling:

Show[{
  ListPlot[data1, PlotRange -> {{1, 5}, {-100, All}}, Joined -> True, Mesh -> Full,
     PlotStyle -> Red, AxesOrigin -> {1, -50}],
  ListPlot[data2, Joined -> True, Mesh -> Full, PlotStyle -> Blue]
}]

Is there a way to "break" or "snip" the $y$ axis so that I can compare data1 and data2 on the same plot? There is no data in the range ~3 to ~1000, so I would like to snip this $y$-range out, if possible, and perhaps include a jagged symbol to show that this has been done.

Answer 1

Here is a solution that uses a BezierCurve to indicate a "snipped" axes. The function snip[x] places the mark on the axes at relative position x (0 and 1 being the ends). The function getMaxPadding gets the maximum padding on all sides for both plots (based on this answer). The two plots are then aligned one over the other, with the max padding applied for both.

snip[pos_] := Arrowheads[{{Automatic, pos, 
     Graphics[{BezierCurve[{{0, -(1/2)}, {1/2, 0}, {-(1/2), 0}, {0, 1/2}}]}]}}];
getMaxPadding[p_List] := Map[Max, (BorderDimensions@
    Image[Show[#, LabelStyle -> White, Background -> White]] & /@ p)~Flatten~{{3}, {2}}, {2}] + 1
p1 = ListPlot[data1, PlotRange -> All, Joined -> True, Mesh -> Full, PlotStyle -> Red, 
    AxesStyle -> {None, snip[1]}, PlotRangePadding -> None, ImagePadding -> 30];
p2 = ListPlot[data2, PlotRange -> All, Joined -> True, Mesh -> Full, PlotStyle -> Blue, 
    Axes -> {False, True}, AxesStyle -> {None, snip[0]}, PlotRangePadding -> None, ImagePadding -> 30];

Column[{p2, p1} /. Graphics[x__] :> 
    Graphics[x, ImagePadding -> getMaxPadding[{p1, p2}], ImageSize -> 400]]

Answer 2

This solution shifts data around and makes new ticks for the y axis.

compressYAxis[plot_,plotRange1_,plotRange2_] will modify the y axis of the supplied plot to exclude the region between the upper limit of plotRange1 and the lower limit of plotRange2. With your data, here is the plot with a compressed y axis:

data1 = {{1, 1.1}, {2, 1.5}, {3, 0.9}, {4, 2.3}, {5, 1.1}};
data2 = {{1, 1001.1}, {2, 1001.5}, {3, 1000.9}, {4, 1002.3}, {5, 1001.1}};

p = ListLinePlot[{data1, data2}, PlotRange -> All, 
 PlotLabel -> "Example of a compressed y axis", 
 AxesLabel -> {"x", "y"}];

compressYAxis[p, {0, 3}, {999, 1003}]

You will have to fiddle with this if you want tick subdivisions or a different background colour; the compression marks could be improved too.

The definition is

Clear[compressYAxis];
compressYAxis[plot_, range1_, range2_] := 
  Module[{ytick1, ytick2, epilog1, target},
   ytick1 = FindDivisions[range1, 5] /. y_?NumericQ :> {y, y} /. {y_?NumericQ, _} /; y >= range1[[2]] :> Sequence[];
   ytick2 = FindDivisions[range2, 5] /. y_?NumericQ :> {y - range2[[1]] + range1[[2]], y} /. {y_?NumericQ, _} /; y <= range1[[2]] :> Sequence[];
   epilog = Options[plot, Epilog][[1, 2]];
   target = Subtract @@ Reverse@range1/(Subtract @@ Reverse@range1 + Subtract @@ Reverse@range2);
   Show[plot /. {x_?NumericQ, y_?NumericQ /; y > range2[[1]]} :> {x, y - range2[[1]] + range1[[2]]}, 
     PlotRange -> {range1[[1]], range1[[2]] + Subtract @@ Reverse@range2}, 
     Ticks -> {Automatic, Join[ytick1, ytick2]}, 
     Epilog -> Join[epilog, {White, Rectangle[Scaled[{-0.1, 0.98 target}], Scaled[{1.1, 1.02 target}]], Black, Text[Rotate["\\", \[Pi]/2], Scaled[{0, 0.98 target}], {-1.5, 0}], Text[Rotate["\\", \[Pi]/2], Scaled[{0, 1.02 target}], {-1.5, 0}]}]]
 ]