This is a solution based on interval operations.
Usage and examples
First, let's look at how to use the function. The code is at the end.
Let's generate some sample data and plot it:
data1 = RandomVariate[ExponentialDistribution[1], 200];
data2 = RandomVariate[NormalDistribution[2, 1], 200];
beeswarmPlot[data1]
Now let's plot two together:
beeswarmPlot[{data1, data2}]
We can also specify the circle radius explicitly, in plot coordinates:
beeswarmPlot[data2, 0.2]
Or we can change the colour while keeping the radius selection automatic:
apricot = RGBColor[1.`, 0.340007`, 0.129994`];
cornflower = RGBColor[0.392193`, 0.584307`, 0.929395`];
beeswarmPlot[{data1, data2}, Automatic, PlotStyle -> {apricot, cornflower}]
The code
Note: I'm going for readability here, not performance. Performance can be improved significantly at the cost of readability, which is already impaired by the large amount of code used just for option handling.
I am going to use these helper functions:
intervalInverse[Interval[]] := Interval[{-Infinity, Infinity}]
intervalInverse[Interval[int__]] :=
Interval @@ Partition[
Replace[Flatten[{int}],
{{-Infinity, mid___, Infinity} :> {mid},
{-Infinity, mid__} :> {mid, Infinity},
{mid__, Infinity} :> {-Infinity, mid},
{mid___} :> {-Infinity, mid, Infinity}
}
], 2]
intervalComplement[a_Interval, b__Interval] :=
IntervalIntersection[a, intervalInverse@IntervalUnion[b]]
This is the code for calculating the point coordinates and packing the circles. This is the only function that needs to be changed to implement an different packing method.
(* data is assumed to be a sorted vector of numbers *)
beeswarm[data_, radius_] :=
Module[{points, left, right, int},
points = {};
Do[
int = Interval @@ Cases[points, {x_, y_} /; y > pt - radius :> x + {-1, 1} Sqrt[radius^2 - (pt - y)^2]];
right = Min[intervalComplement[Interval[{0, Infinity}], int]];
left = Max[intervalComplement[Interval[{-Infinity, 0}], int]];
AppendTo[points, {If[right < -left, right, left], pt}],
{pt, data}
];
points
]
And this is the plotting function that provides a user friendly interface (option handling) and assembles the final Graphics object.
Options[beeswarmPlot] =
Join[
Options[Graphics],
{PlotStyle -> Automatic}
];
SetOptions[beeswarmPlot, Frame -> True];
SetOptions[beeswarmPlot, FrameTicks -> {None, Automatic}];
beeswarmPlot[data_?(VectorQ[#, NumericQ] &), radius : (_?NumericQ | Automatic) : Automatic, opt : OptionsPattern[]] := beeswarmPlot[{data}, radius, opt]
beeswarmPlot[data : {__?(VectorQ[#, NumericQ] &)}, radius : (_?NumericQ | Automatic) : Automatic, opt : OptionsPattern[]] :=
Module[{r, order, flatData, colours, colfun},
(* generate colour indices and sort them together with the data *)
flatData = Flatten[data];
order = Ordering[flatData];
colours = Flatten@Table[ConstantArray[i, Length[data[[i]]]], {i, Length[data]}];
flatData = flatData[[order]];
colours = colours[[order]];
(* automatic radius selection *)
r = If[radius === Automatic, 4 Mean@Differences[flatData], 2 radius];
(* handle the PlotStyle option *)
colfun = With[
{ps = OptionValue[PlotStyle]},
Switch[ps,
Automatic, ColorData[1],
_List, Function[i, ps[[ Mod[i, Length[ps], 1] ]] ],
_, ps &
]
];
(* call the packing function and build the graphics using the result *)
Graphics[
MapThread[{colfun[#2], Disk[#1, 0.95 r/2]} &, {beeswarm[flatData, r], colours}],
Sequence @@ FilterRules[{opt}, Options[Graphics]],
Frame -> OptionValue[Frame],
FrameTicks -> OptionValue[FrameTicks]
]
]
