# How to plot paired smooth histogram/distribution plots?

I've been trying to get paired distribution (aka "violin") plots like those shown below for a few hours, but all my attempts have failed. The key features here are

1. paired smooth histograms/distribution plots with a common vertical abscissa and divergent horizontal ordinates;
2. different fill colors for the two subplots;

The closest Mathematica has are DistributionCharts, but these plots are not paired (i.e. they are always symmetrical).

I first tried SmoothHistogram, but it appears that there's no simple way to get a SmoothHistogram with a vertical abscissa.

Next I tried PairedSmoothHistogram, but I can't manage to assign different fill colors to the two sides.

BlockRandom[SeedRandom;
Quiet[
PairedSmoothHistogram[
RandomVariate[NormalDistribution[], 100]
, RandomVariate[NormalDistribution[], 100]
, AspectRatio -> Automatic
, Axes -> {False, True}
, Ticks -> None
, Spacings -> 0
, ImageSize -> 30
, Filling -> Axis
]
, OptionValue::nodef
]
] Then I tried a combination of SmoothKernelDistribution and either ListPlot, ParametricPlot or ContourPlot, but this won't work because neither ParametricPlot nor ContourPlot accepts a Fill option, and I can't figure out how to get ListPlot to fill the spaces between the curves and the vertical axis.

For example,

violin[data1_, data2_, rest___] := Module[
{  d1 = SmoothKernelDistribution[data1]
, d2 = SmoothKernelDistribution[data2]
, x
, xrange
}, xrange = {x, Sequence @@ (#[data1, data2] & /@ {Min, Max})}
; ParametricPlot[ {{-PDF[d1, x], x}, {PDF[d2, x], x}}
, Evaluate@xrange
, rest
, PlotRange -> All
, Axes -> {None, True}
, Ticks -> None
]
];

BlockRandom[SeedRandom;
violin[RandomVariate[NormalDistribution[], 100],
RandomVariate[NormalDistribution[], 100],
ImageSize -> 30
]
] I didn't expect this would be so hard. My brain is now fried.

Does anyone know how one does this?

Here is something using a custom ChartElementFunction

Module[{c = 0},
half[{{xmin_, xmax_}, {ymin_, ymax_}}, data_, metadata_] := (c++;
Map[Reverse[({0, Mean[{xmin, xmax}]} + # {1, (-1)^c})] &,
First@Cases[
First@Cases[InputForm[SmoothHistogram[data, Filling -> Axis]],
gc_GraphicsComplex :> Normal[gc], ∞],
p_Polygon, ∞], {2}])]


(thanks to @halirutan for reminding me about how to do closures in WL).

data = RandomVariate[NormalDistribution[0, 1], {4, 2, 100}];

DistributionChart[data, BarSpacing -> -1, ChartElementFunction -> half] • This looks like it has the right areas as I inserted data[[1, 1, All]] = 0.5 data[[1, 1, All]] + 2; and it looks like it is supposed to look. – JimB May 11 '17 at 22:26
• What's the rationale for p_Polygon :> p? (I get the same results if I replace it with just p_Polygon.) – kjo May 12 '17 at 14:03
• Oh its not needed, just something I forgot to clean up, during some test I was doing. I will change it now. – chuy May 12 '17 at 15:10

I just followed your approach but rather created tables of the density and associated x-values. I added a shift parameter to violin to allow the placement of each pair of probability density estimates.

violin[data1_, data2_, shift_] :=
Module[{d1 = SmoothKernelDistribution[data1],
d2 = SmoothKernelDistribution[data2], x, xrange},
{xmin1, xmax1} = MinMax[data1];
{xmin2, xmax2} = MinMax[data2];
xrange1 = xmax1 - xmin1;
xrange2 = xmax2 - xmin2;
(* Create a table of the density values along with the associated x value *)
pdf1 = Table[{-PDF[d1, x] + shift, x}, {x, xmin1 - 0.2 xrange1,
xmax1 + 0.2 xrange1, 1.4 xrange1/100}];
pdf2 = Table[{PDF[d2, x] + shift, x}, {x, xmin2 - 0.2 xrange2,
xmax2 + 0.2 xrange2, 1.4 xrange2/100}];
(* Construct violin graphic *)
Show[Graphics[{Darker[Green], EdgeForm[Darker[Green]],
Polygon[pdf1]}],
Graphics[{Orange, EdgeForm[Orange], Polygon[pdf2]}]]]

(* Generate some data *)
data11 = RandomVariate[NormalDistribution[], 100];
data12 = RandomVariate[NormalDistribution[0.5, 1], 100];
data21 = RandomVariate[NormalDistribution[1, 2], 100];
data22 = RandomVariate[NormalDistribution[0.5, 1.5], 100];

Show[ListPlot[{{-1, 3}}, AxesOrigin -> {-1, -8},
Ticks -> {{{0, "A"}, {2, B}}, Automatic},
PlotRange -> {{-1, 3}, {-8, 10}}, PlotStyle -> White],
violin[data11, data12, 0],
violin[data21, data22, 2],
ImageSize -> Large] Update: Using GeometricTransformations to post-process SmoothHistogram outputs:

ClearAll[halfSH, pairedSH]
halfSH[side : (Left | Right) : Right][data_, o : OptionsPattern[]] :=
Module[{i = 1, tr = If[side === Left, ReflectionTransform[{-1, 0}], Identity],
col = If[side === Left, Blue, Red]},
Graphics[GeometricTransformation[SmoothHistogram[#, Automatic, "PDF", o,
Filling -> Axis, FillingStyle -> Lighter@col, PlotStyle -> col][],
Composition[TranslationTransform[{i++, 0}], tr, ReflectionTransform[{1, -1}]]],
FilterRules[{o}, Options[Graphics]]] & /@ data]

halfSH[side : (Left | Right) : Right][data_, bwkernel__,
o : OptionsPattern[]] :=
Module[{i = 1, tr = If[side === Left, ReflectionTransform[{-1, 0}], Identity],
col = If[side === Left, Blue, Red]},
Graphics[GeometricTransformation[SmoothHistogram[#, bwkernel, o, Filling -> Axis,
FillingStyle -> Lighter@col, PlotStyle -> col][],
Composition[TranslationTransform[{i++, 0}], tr, ReflectionTransform[{1, -1}]]],
FilterRules[{o}, Options[Graphics]]] & /@ data]

pairedSH[bw_: Automatic, df_: "PDF"][{d1_, o1 : OptionsPattern[]},
{d2_, o2 : OptionsPattern[]},  o : OptionsPattern[]] :=
Show[halfSH[Left][d1, bw, df, o1], halfSH[][d2, bw, df, o2],
PlotRange -> {{0, 1 + Length@d1}, Automatic}, o, Frame -> True,
FrameTicks -> {{Automatic, Automatic}, {Range[Length@d1],
Automatic}}, AspectRatio -> 1/GoldenRatio]


Examples:

{data1, data2} = RandomVariate[NormalDistribution[#, #], {4, 1000}] & /@ {2, 1};

pairedSH[][{data1}, {data2}] pairedSH[{"Adaptive", 0.3, .5}][{data1, FillingStyle->Lighter[Cyan], PlotStyle->Green},
{data2, FillingStyle -> Lighter@Orange, PlotStyle -> Red}] Original post:

{data1, data2} = RandomVariate[NormalDistribution[#, #], {4, 1000}] & /@ Range;

cedf1 = ChartElementDataFunction["SmoothDensity", "Shape" -> "SingleSided"];
cedf2 = ChartElementDataFunction["SmoothDensity", "Shape" -> "FlippedSingleSided"];

Show[DistributionChart[data1, ChartStyle -> Yellow, BarSpacing -> 2,
ChartElementFunction -> cedf1, ChartLabels -> {"a", "b", "c", "d"}],
DistributionChart[data2, ChartStyle -> Red, BarSpacing -> 2,
ChartElementFunction -> cedf2]] • The OP stated "Next I tried PairedSmoothHistogram, but I can't manage to assign different fill colors to the two sides." – David G. Stork May 11 '17 at 18:07
• oops, thank you @David. – kglr May 11 '17 at 18:09
• Wow! That is both compact and understandable. – JimB May 11 '17 at 21:28
• Uh, maybe I spoke too soon. My comment still holds but...the areas under the curves should all be equal and they are not. Can that be adjusted? It looks like they are all scaled to the same height rather than the same area. – JimB May 11 '17 at 21:44
• Great function with "halfSH". I use it but I don't succeed to include the bandwith option in SmoothHistogram. – Porty Sep 13 '17 at 9:08
data1 = RandomVariate[NormalDistribution[], 1000];
data2 = RandomVariate[NormalDistribution[], 1000];
GraphicsRow[{
Rotate[Graphics[SmoothHistogram[data1,
PlotStyle -> Red,
Filling -> Axis,
PlotRange -> {{-3.5, 3.5}, Automatic}]], π/2],
Rotate[Graphics[SmoothHistogram[data2, PlotStyle -> Green,
Filling -> Axis, PlotRange -> {{-3.5, 3.5}, Automatic}]], -π/
2]},
Spacings -> {-234, 5}
] (You may need to flip one distribution to keep the orientation of the vertical axes the same for the two plots.)

Step 1:

I tried PairedSmoothHistogram, but I can't manage to assign different fill colors to the two sides.

It turns out that FillingStyle option setting can be a Function so we can inject the two colors using an appropriate Function as the value of this option.

Example:

SeedRandom
dd1 = RandomVariate[NormalDistribution[1, 2], 100];
dd2 = RandomVariate[NormalDistribution[], 100];
options = {Axes -> {False, True}, Ticks -> None, Filling -> Axis,
AxesStyle -> Directive[Thickness[.005], Gray], Spacings -> 0};

PairedSmoothHistogram[dd1, dd2,
FillingStyle -> Module[{i = 1}, ({{Red, Blue}[[i++]], #} &)], options] An alternative, and less convenient, approach is to post-process the PairedSmoothHistogram output

Module[{i = 1}, PairedSmoothHistogram[dd1, dd2, options] /.
p_Polygon :> {{ Opacity[1, Blue], Opacity[1, Red]}[[i++]], p}]


which gives the same output.

This method also works for multiple data pairs using a longer list of colors:

SeedRandom
data = Table[RandomVariate[NormalDistribution[c, RandomInteger[{1, 3}]],
500], {k, 2}, {c, 4}];
options = {Axes -> {False, True}, Ticks -> None, Filling -> Axis, Spacings -> 0,
AxesStyle -> Directive[Thin, White]};

colors = Opacity[.5, #] & /@ {Red, Blue, Green, Orange, Purple, Yellow, Cyan, Pink};

PairedSmoothHistogram[##& @@ data,
FillingStyle -> Module[{i = 1}, ({colors[[i++]], #} &)], options] Step 2:

paired smooth histograms/distribution plots with a common vertical abscissa and divergent horizontal ordinates

To get a chart that looks like a DistributionChart we can (1) use PairedSmoothHistogram on individual pairs and (2) combine them with appropriate translations.

The function pshListF creates a list of paired histograms from a data set with multiple data pairs. The function displaceF below (slightly modified version from this answer) performs the necessary translations.

ClearAll[pshListF, displaceF]
pshListF[data_, colors_: {Red, Blue}][o : OptionsPattern[]] :=
Module[{d = Transpose[data]}, PairedSmoothHistogram[##,
FillingStyle -> Module[{i = 1}, ({{Red, Blue}[[i++]], #} &)], o] & @@@ d]

displaceF[p : {__Graphics}, labels_: Automatic, o : OptionsPattern[]] :=
Module[{d = Accumulate[PlotRange[#][[1, 2]] & /@ p],
labeledticks = If[labels == Automatic, Range[Length@p],
Show[Graphics[Translate[#[], {#2, 0}] & @@@ Transpose[{p, d}]],
AspectRatio -> 1/GoldenRatio, PlotRange -> {{0, 1 + Length@p}, Automatic},
Frame -> True, FrameTicks -> {{Automatic, Automatic}, {labeledticks, Automatic}}, o]]


Examples:

displaceF[pshListF[data][ options]] displaceF[pshListF[data][ options], {"A", "B", "C", "D"},
FrameTicksStyle -> {Automatic, Directive[14, "Panel"]}] 