小提琴图

利用Mathematica绘制基本的小提琴图的命令大致如下：

1
2
3
4
5
6
7
(*指定随机种子库*)
SeedRandom[20230402];
data = Table[
   RandomVariate[NormalDistribution[\[Mu], 5], 100], {\[Mu], -6, 6, 
    2}];
(*绘制小提琴图*)
DistributionChart[data]

此时将会输出如下的图片

同时也可以绘制盒须图，定义盒须图的样式：

1
2
3
4
5
6
7
BoxWhiskerChart[data, 
{{"MedianMarker", 1, Directive[Black, Thickness -> 0.008]}, 
{"Outliers", "\[FilledCircle]", Red}, 
{"Whiskers", Directive[Dashed]}, 
{"Fences", 1, Directive[Blue, Thickness -> 0.003]}}, 
BarSpacing -> 3, 
ChartStyle -> Directive[EdgeForm[Black], White]]

指令解释如下

  • data：要绘制的数据。
  • "MedianMarker"：中位数标记采用标准宽度的粗细程度为0.00的黑线。
  • "Outliers"：用红色的实心点来标记异常值。
  • "Whiskers"：盒须采用虚线样式。
  • "Fences"：最大/小值标记线采用标准宽度的粗细程度为0.003的蓝线。
  • BarSpacing：设置直条的间隔为3。
  • ChartStyle：设置直条的样式为黑色实心线描边，白色背景色。

输出如下图

利用Show函数可以将两图进行结合

1
2
3
4
5
6
7
8
9
Show[
 DistributionChart[data, ChartStyle -> 24],
 BoxWhiskerChart[data,
  {{"MedianMarker", 1, Directive[Black, Thickness -> 0.008]},
   {"Outliers", "\[FilledCircle]", Red},
   {"Whiskers", Directive[Dashed]},
   {"Fences", 1, Directive[Blue, Thickness -> 0.003]}},
  BarSpacing -> 3,
  ChartStyle -> Directive[EdgeForm[Black], White]]]

输出如下图

对于多组对比数据的小提琴图可如下绘制：

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
(*生成随机数*)
datax = Table[
   RandomVariate[NormalDistribution[0, 1], 200] + 
    Table[Sin[j], {i, 1, 200}], {j, 1, 7}];
datay = Table[
   RandomVariate[NormalDistribution[0, 1], 200] + 
    Table[Cos[j], {i, 1, 200}], {j, 1, 7}];
data2 = {datax, datay} // Transpose;
(*指定图标元素函数*)
cEF[f_ : "BoxWhisker", w_ : .5] := {ChartElementData[f][{Mean@#[[1]] + {-w, w}/2, #[[2]]}, ##2]} &
(*绘制多组数据*)
Show[
   DistributionChart[data2,
    BarSpacing -> #,
    ChartStyle -> 89,
    ChartLegends -> SwatchLegend[{"randn+sin(x)", "randn+cos(x)"},
      LegendLayout -> (Grid[Join[{{"Func", SpanFromLeft}}, #],
          
          Dividers -> {{True, False, True}, {True, True, False, 
             True}}] &)],
    ChartLabels -> {{"1", "2", "3", "4", "5", "6", "7"}, {"a", 
       "b"}}],
   BoxWhiskerChart[data2,
    {{"MedianMarker", 1, Directive[Black, Thickness -> 0.008]},
     {"Outliers", "\[FilledCircle]", Red}, {"Whiskers", 
      Directive[Dashed]},
     {"Fences", 1, Directive[Blue, Thickness -> 0.003]}},
    BarSpacing -> #,
    ChartStyle -> Directive[EdgeForm[Black], White],
    ChartElementFunction -> cEF["BoxWhisker", 0.4]]] &[{0.4, 1.2}]

另一个案例

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
data3 = (Table[
       RandomVariate[NormalDistribution[0, 1], 200] + 
        Table[#[j], {i, 1, 200}], {j, 1, 7}] & /@ {Sqrt, Log, Tan, 
      Csc}) // Transpose;
Show[
   DistributionChart[data3,
    BarSpacing -> #,
    ChartStyle -> 24,
    ChartLegends -> 
     SwatchLegend[{"randn+sqrt(x)", "randn+ln(x)", "randn+tan(x)", 
       "randn+csc(x)"},
      LegendLayout -> (Grid[Join[{{"Func", SpanFromLeft}}, #],
          
          Dividers -> {{True, False, True}, {True, True, False, False,
              False, True}}] &)],
    ChartLabels -> {{"1", "2", "3", "4", "5", "6", "7"}, {"a", "b", 
       "c", "d"}}],
   BoxWhiskerChart[data3,
    {{"MedianMarker", 1, Directive[Black, Thickness -> 0.008]},
     {"Outliers", "\[FilledCircle]", Red}, {"Whiskers", 
      Directive[Dashed]},
     {"Fences", 1, Directive[Blue, Thickness -> 0.003]}},
    BarSpacing -> #,
    ChartStyle -> Directive[EdgeForm[Black], White],
    ChartElementFunction -> cEF["BoxWhisker", 0.4]]] &[{0.3, 0.6}]

当然，也可以指定绘图主题，例如

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Show[
   DistributionChart[data3,
    BarSpacing -> #,
    ChartStyle -> 24,
    ChartLegends -> 
     SwatchLegend[{"randn+sqrt(x)", "randn+ln(x)", "randn+tan(x)", 
       "randn+csc(x)"},
      LegendLayout -> (Grid[Join[{{"Func", SpanFromLeft}}, #],
          
          Dividers -> {{True, False, True}, {True, True, False, False,
              False, True}}] &)],
    ChartLabels -> {{"1", "2", "3", "4", "5", "6", "7"}, {"a", "b", 
       "c", "d"}}, PlotTheme -> #2],
   BoxWhiskerChart[data3,
    {{"MedianMarker", 1, Directive[Black, Thickness -> 0.008]},
     {"Outliers", "\[FilledCircle]", Red}, {"Whiskers", 
      Directive[Dashed]},
     {"Fences", 1, Directive[Blue, Thickness -> 0.003]}},
    BarSpacing -> #,
    ChartStyle -> Directive[EdgeForm[Black], White],
    ChartElementFunction -> cEF["BoxWhisker", 0.4]], 
   PlotTheme -> #2] &[{0.3, 0.6}, "Detailed"]

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Show[
   DistributionChart[data3,
    BarSpacing -> #,
    ChartStyle -> 24,
    ChartLegends -> 
     SwatchLegend[{"randn+sqrt(x)", "randn+ln(x)", "randn+tan(x)", 
       "randn+csc(x)"},
      LegendLayout -> (Grid[Join[{{"Func", SpanFromLeft}}, #],
          
          Dividers -> {{True, False, True}, {True, True, False, False,
              False, True}}] &)],
    ChartLabels -> {{"1", "2", "3", "4", "5", "6", "7"}, {"a", "b", 
       "c", "d"}}, PlotTheme -> #2],
   BoxWhiskerChart[data3,
    {{"MedianMarker", 1, Directive[Black, Thickness -> 0.008]},
     {"Outliers", "\[FilledCircle]", Red}, {"Whiskers", 
      Directive[Dashed]},
     {"Fences", 1, Directive[Blue, Thickness -> 0.003]}},
    BarSpacing -> #,
    ChartStyle -> Directive[EdgeForm[Black], White],
    ChartElementFunction -> cEF["BoxWhisker", 0.4]], 
   PlotTheme -> #2] &[{0.3, 0.6}, "Scientific"]

组合图

在前几篇文章中也简要介绍了一些绘图的方法，现在已经铺垫很好了，开始将这些方法进行结合，来绘制组合图。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
data4 = (Table[
       RandomVariate[NormalDistribution[0, 1], 200] + 
        Table[#[j], {i, 1, 200}], {j, 1, 4}] & /@ {Sin, Cos}) // 
   Transpose;
Show[
   DistributionChart[data4,
    BarSpacing -> #,
    ChartStyle -> {Red, Orange},
    ChartLegends -> SwatchLegend[{"randn+sin(x)", "randn+cos(x)"},
      LegendLayout -> (Grid[Join[{{"Func", SpanFromLeft}}, #],
          
          Dividers -> {{True, False, True}, {True, True, False, 
             True}}] &)],
    ChartLabels -> {{"1", "2", "3", "4"}, {"a", "b"}},
    PlotTheme -> #2,
    ChartElementFunction -> "HistogramDensity",
    ChartBaseStyle -> Directive[EdgeForm[Thin], Opacity[0.4]]],
   BoxWhiskerChart[data4,
    {{"MedianMarker", 1, Directive[Black, Thickness -> 0.008]},
     {"Outliers", "\[FilledCircle]", RGBColor[0, 1, 1]}, {"Whiskers", 
      Directive[Dashed]},
     {"Fences", 1, Directive[Blue, Thickness -> 0.003]}},
    BarSpacing -> #,
    ChartStyle -> Directive[EdgeForm[Black], White],
    ChartElementFunction -> cEF["BoxWhisker", 0.4],
    PlotTheme -> #2]] &[{0.2, 0.8}, "Detailed"]

类似上面的更改，有如下几个方案可供选择

设置DistributionChart的选项：ChartElementFunction -> "Density"。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Show[
   DistributionChart[data4,
    BarSpacing -> #,
    ChartStyle -> {Red, Orange},
    ChartLegends -> SwatchLegend[{"randn+sin(x)", "randn+cos(x)"},
      LegendLayout -> (Grid[Join[{{"Func", SpanFromLeft}}, #],
          
          Dividers -> {{True, False, True}, {True, True, False, 
             True}}] &)],
    ChartLabels -> {{"1", "2", "3", "4"}, {"a", "b"}},
    PlotTheme -> #2,
    ChartElementFunction -> "Density",
    ChartBaseStyle -> Directive[EdgeForm[Thin], Opacity[0.8]]],
   BoxWhiskerChart[data4,
    {{"MedianMarker", 1, Directive[Black, Thickness -> 0.008]},
     {"Outliers", "\[FilledCircle]", RGBColor[0, 1, 1]}, {"Whiskers", 
      Directive[Dashed]},
     {"Fences", 1, Directive[Blue, Thickness -> 0.003]}},
    BarSpacing -> #,
    ChartStyle -> Directive[EdgeForm[Black], White],
    ChartElementFunction -> cEF["BoxWhisker", 0.4],
    PlotTheme -> #2]] &[{0.2, 0.8}, "Detailed"]

设置DistributionChart的选项：ChartElementFunction -> "Density"。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Show[
   DistributionChart[data4,
    BarSpacing -> #,
    ChartStyle -> {Red, Orange},
    ChartLegends -> SwatchLegend[{"randn+sin(x)", "randn+cos(x)"},
      LegendLayout -> (Grid[Join[{{"Func", SpanFromLeft}}, #],
          
          Dividers -> {{True, False, True}, {True, True, False, 
             True}}] &)],
    ChartLabels -> {{"1", "2", "3", "4"}, {"a", "b"}},
    PlotTheme -> #2,
    ChartElementFunction -> "LineDensity",
    ChartBaseStyle -> Directive[EdgeForm[{Gray}], Opacity[0.4]]],
   BoxWhiskerChart[data4,
    {{"MedianMarker", 1, Directive[Black, Thickness -> 0.008]},
     {"Outliers", "\[FilledCircle]", RGBColor[0, 1, 1]}, {"Whiskers", 
      Directive[Dashed]},
     {"Fences", 1, Directive[Blue, Thickness -> 0.003]}},
    BarSpacing -> #,
    ChartStyle -> Directive[EdgeForm[Black], White],
    ChartElementFunction -> cEF["BoxWhisker", 0.4],
    PlotTheme -> #2]] &[{0.2, 0.8}, "Detailed"]

设置ChartElementFunction选项为：ChartElementData["SmoothDensity", "ColorScheme" -> "NeonColors"]

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Show[
   DistributionChart[data, ChartStyle -> 24, 
    ChartLegends -> BarLegend[{"NeonColors", {0, 1}},
      LegendLayout -> "Column"],
    ChartLabels -> {"1", "2", "3", "4", "5", "6", "7"},
    PlotTheme -> #,
    ChartElementFunction -> 
     ChartElementData["SmoothDensity", 
      "ColorScheme" -> "NeonColors"],
    ChartBaseStyle -> Directive[EdgeForm[Thin]]],
   BoxWhiskerChart[data,
    {{"MedianMarker", 1, Directive[Black, Thickness -> 0.008]},
     {"Outliers", "\[FilledCircle]", Green},
     {"Whiskers", Directive[Dashed]},
     {"Fences", 1, Directive[Blue, Thickness -> 0.003]}},
    BarSpacing -> 3,
    ChartStyle -> Directive[EdgeForm[Black], White], 
    PlotTheme -> #]] &["Detailed"]

一些比较好的案例

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
ClearAll[BoxWhiskerDistributionChart,cEF]
cEF[f_ : "BoxWhisker", 
  w_ : .5] := {ChartElementData[
     f][{Mean@#[[1]] + {-w, w}/2, #[[2]]}, ##2]} &
Options[BoxWhiskerDistributionChart] = {"InternalOpacity" -> 0.7, 
   "PointsToHighlight" -> {}, "PointToHighlightColor" -> Red, 
   "UpperCutoff" -> .75, "LowerCutoff" -> .25, 
   "EdgeColor" -> Charting`ChartStyleInformation["Color"]};

BoxWhiskerDistributionChart[{{xmin_, xmax_}, {ymin_, ymax_}}, values_,
   metadata_, OptionsPattern[]] := 
 Module[{chartParameters = 
    Sequence[{{xmin, xmax}, {ymin, ymax}}, values, 
     metadata]}, {(*Give boxes thin edges with black color*)
   EdgeForm[{Thin, 
     Black}],(*Alter boxes internal opacity with their respective \
color*)FaceForm[
    Opacity[OptionValue["InternalOpacity"], 
     Charting`ChartStyleInformation[
      "Color"]]],(*Use smooth density to change box shape,
   with given quantile cutoffs*)
   ChartElementDataFunction["SmoothDensity"][chartParameters] /. 
    GeometricTransformation[Polygon[x_, y___], transformation_] :> 
     Polygon[DeleteCases[
       AffineTransform[transformation]@
        x, {_, _?((# < 
              Quantile[values, OptionValue["LowerCutoff"]] || # > 
              Quantile[values, OptionValue["UpperCutoff"]]) &)}], y], 
   Opacity[1],(*Color points also foudn in the PointsToHighlight \
option*)ChartElementDataFunction["PointDensity", 
      "PointStyle" -> PointSize[0.004]][chartParameters] /. 
    GraphicsGroup[{x_, y__}] :> ({y} /. 
       Point[p_] :> (({If[
              MemberQ[OptionValue["PointsToHighlight"], #[[2]]], 
              OptionValue["PointToHighlightColor"]], Point[{#}]} & /@ 
           p))),(*Remove the default BoxWhiskerChart EdgeForm*)
   EdgeForm[],(*Remove the default BoxWhiskerChart FaceForm*)
   FaceForm[](*Produce the plot*)}]

Show[DistributionChart[data4,
    BarSpacing -> #,
    ChartLegends -> SwatchLegend[{"randn+sin(x)", "randn+cos(x)"},
      LegendLayout -> (Grid[Join[{{"Func", SpanFromLeft}}, #],
          
          Dividers -> {{True, False, True}, {True, True, False, 
             True}}] &)],
    ChartLabels -> {{"1", "2", "3", "4"}, {"a", "b"}},
    PlotTheme -> #2,
    ChartElementFunction -> (BoxWhiskerDistributionChart[##, 
        "PointsToHighlight" -> data4] &),
    ChartBaseStyle -> 
     Directive[EdgeForm[{Thick, Black}], Opacity[0.8]], 
    ImageSize -> 700],
   BoxWhiskerChart[data4,
    {{"MedianMarker", 3, 
      Directive[Blue, Thickness -> 0.002, Opacity[1]]},
     {"Outliers", "\[FilledCircle]", Red}, {"Whiskers", 
      Directive[Dashed, Opacity[1]]},
     {"Fences", 1, Directive[Blue, Thickness -> 0.003, Opacity[1]]}},
    BarSpacing -> #,
    ChartStyle -> Directive[EdgeForm[None], Opacity[0]],
    ChartElementFunction -> cEF["BoxWhisker", 0.2],
    PlotTheme -> #2]] &[{0.2, 0.8}, "Detailed"]

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
Options[plotGrid] = {ImagePadding -> 40, "KeepAR" -> False};
plotGrid[l_List, w_, h_, opts : OptionsPattern[]] := 
  Module[{nx, ny, sidePadding = OptionValue[plotGrid, ImagePadding], 
    topPadding = 0, widths, heights, dimensions, positions, 
    frameOptions = 
     FilterRules[{opts}, 
      FilterRules[Options[Graphics], 
       Except[{ImagePadding, Frame, FrameTicks}]]]}, {ny, nx} = 
    Dimensions[l];
   widths = 
    If[OptionValue["KeepAR"], 
     Module[{arfunc, arlist, tot}, 
      arfunc[img_] := 
       Module[{dims}, 
        dims = ImageDimensions[
          Show[img, ImagePadding -> {{0, 0}, {0, 0}}]];
        N@dims[[1]]/dims[[2]]];
      arlist = arfunc /@ l[[1]];
      tot = Total[arlist];
      Table[
       arlist[[n]] (w - 2 sidePadding)/tot, {n, 
        nx}]], (w - 2 sidePadding)/nx Table[1, {nx}]];
   (*widths=(w-2 sidePadding)/nx Table[1,{nx}];*)
   widths[[1]] = widths[[1]] + sidePadding;
   widths[[-1]] = widths[[-1]] + sidePadding;
   heights = 
    If[OptionValue["KeepAR"], 
     Module[{arfunc, arlist, tot}, 
      arfunc[img_] := 
       Module[{dims}, 
        dims = ImageDimensions[
          Show[img, ImagePadding -> {{0, 0}, {0, 0}}]];
        N@dims[[2]]/dims[[1]]];
      arlist = arfunc /@ l[[All, 1]];
      tot = Total[arlist];
      Table[
       arlist[[-n]] (h - 2 sidePadding)/tot, {n, 
        ny}]], (h - 2 sidePadding)/ny Table[1, {ny}]];
   (*heights=(h-2 sidePadding)/ny Table[1,{ny}];*)
   heights[[1]] = heights[[1]] + sidePadding;
   heights[[-1]] = heights[[-1]] + sidePadding;
   positions = 
    Transpose@
     Partition[
      Tuples[Prepend[Accumulate[Most[#]], 0] & /@ {widths, heights}], 
      ny];
   Graphics[
    Table[Inset[
      Show[l[[ny - j + 1, i]], 
       ImagePadding -> {{If[i == 1, sidePadding, 0], 
          If[i == nx, sidePadding, 0]}, {If[j == 1, sidePadding, 0], 
          If[j == ny, sidePadding, topPadding]}}, 
       AspectRatio -> Full], 
      positions[[j, i]], {Left, Bottom}, {widths[[i]], 
       heights[[j]]}], {i, 1, nx}, {j, 1, ny}], 
    PlotRange -> {{0, w}, {0, h}}, ImageSize -> {w, h}, 
    Evaluate@Apply[Sequence, frameOptions]]];

data5 = {RandomVariate[NormalDistribution[50, 10], 100], 
   RandomVariate[NormalDistribution[20, 1], 100], 
   RandomVariate[NormalDistribution[80, 5], 100]};

hist = Show[
   Plot[140 PDF[SmoothKernelDistribution[#], x] & /@ data5, {x, 0, 
     100}, Evaluated -> True, PlotStyle -> {Red, Green, Blue}, 
    Frame -> True, PlotRange -> {{0, 100}, All}], 
   Histogram[data5, ChartStyle -> {Red, Green, Blue}]];
bxchrt = 
  BoxWhiskerChart[data5, BarOrigin -> Left, AspectRatio -> 1/3, 
   ChartStyle -> {Red, Green, Blue}, 
   PlotRange -> {First@Charting`get2DPlotRange@hist, All}, 
   PlotRangePadding -> None];
plotGrid[{{hist}, {bxchrt}}, 500, 400, "KeepAR" -> True]