Generating a broken or snipped axis in ListPlot
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]]
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}]}]]
]
ScalingFunctions
We can use custom piecewise linear ScalingFunctions
which efectively makes the interval $[3,1000]$ very short and add a glyph to indicate the break using Epilog
or AxesStyle
to
ClearAll[sf, isf, inset]
sf[t1_, t2_, gap_: 1/10][x_] := Piecewise[{{x, x <= t1}, {t1 + gap/(t2 - t1) (x - t1),
t1 <= x <= t2}, {t1 + gap + (x - t2), x >= t2}}]
isf[t1_, t2_, gap_: 1/10][x_] := InverseFunction[sf[t1, t2, gap]][x]
head = Graphics[{Antialiasing -> True,EdgeForm[None], FaceForm[White],
Polygon[{{-1, -1/6}, {1, 5/6}, {1, 1/6}, {-1, -5/6}}], Black,
CapForm["Butt"], AbsoluteThickness[1],
Line[{{{-1, -5/6}, {1, 1/6}}, {{-1, -1/6}, {1, 5/6}}}]}];
inset[pos_: Scaled[{0.005, .55}], size_: {1/3, 1/3}] := Inset[head, pos, Automatic, size]
{t1, t2} = {Ceiling[#[[1, 2]]], Floor[#[[2, 1]]]} &@
(CoordinateBounds[#][[2]]&/@ {data1, data2});
{yrange1, yrange2} = {Floor[#, .5], Ceiling[#2, .5]} & @@@
(CoordinateBounds[#][[2]] & /@ {data1, data2});
ticks = Join @@ (Charting`FindTicks[{0, 1}, {0, 1}][##] & @@@ {yrange1, yrange2});
Using inset[]
as Epilog
:
ListLinePlot[{data1, data2}, PlotStyle -> Thick,
ScalingFunctions -> {"Linear", {sf[t1, t2], isf[t1, t2]}},
Ticks -> {Automatic, ticks}, PlotRangeClipping -> False,
Epilog -> inset[], ImageSize -> Medium, AspectRatio -> Automatic]
Using head
as Arrowheads
in AxesStyle
:
ListLinePlot[{data1, data2}, PlotStyle -> Thick,
ScalingFunctions -> {"Linear", {sf[t1, t2], isf[t1, t2]}},
Ticks -> {Automatic, ticks}, PlotRangeClipping -> False,
ImageSize -> Medium, AspectRatio -> Automatic,
AxesStyle -> {Automatic, Arrowheads[{{.05, .55, MapAt[
GeometricTransformation[#, RotationTransform[Pi/2]] &, head, {1}]}}]}]
A modification of rm-rf's snip
used with Epilog
and AxesStyle
:
ClearAll[snip2, inset2]
head2 = Graphics[{Antialiasing -> True, FaceForm[White],
Rectangle[{-1/3, -1/2}, {2/3, 1/2}],
{#, Translate[#, {1/2, 0}]} & @
BezierCurve[{{0, -(1/2)}, {1/2, 0}, {-(1/2), 0}, {0, 1/2}}]}];
snip2[pos_] := Arrowheads[{{Automatic, pos, head2}}];
inset2[pos_: Scaled[{0.005, .55}], size_: {1/3, 1/3}] := Inset[MapAt[
GeometricTransformation[#, RotationTransform[Pi/2]] &, head2, {1}],
pos, Automatic, size]
ListLinePlot[{data1, data2}, PlotStyle -> Thick,
ScalingFunctions -> {"Linear", {sf[t1, t2], isf[t1, t2]}},
Ticks -> {Automatic, ticks}, PlotRangeClipping -> False,
Epilog -> inset2[], ImageSize -> Medium, AspectRatio -> Automatic]
ListLinePlot[{data1, data2}, PlotStyle -> Thick,
ScalingFunctions -> {"Linear", {sf[t1, t2], isf[t1, t2]}},
Ticks -> {Automatic, ticks}, PlotRangeClipping -> False,
AxesStyle -> {Automatic, snip2[.55]}, ImageSize -> Medium,
AspectRatio -> Automatic]
TranslationTransform
We can translate data2
and modify vertical tick labels taking the translation into account:
data2translated = TranslationTransform[{0, -997}] @ data2;
ticks2 = Join[Charting`FindTicks[{0, 1}, {0, 1}][##] & @@ yrange1,
Charting`FindTicks[#, # + 997][## & @@ #] &@(yrange2 - 997)];
ListLinePlot[{data1, data2translated },
PlotStyle -> Thick, PlotRangeClipping -> False,
ImageSize -> Medium, AspectRatio -> Automatic,
AxesStyle -> {Automatic, snip2[.55]},
Ticks -> {Automatic, ticks2}]