Excel VBA高级图表绘制: 分布相关图表

与概率分析有关的图表包括各种分布的概率密度函数曲线图、累加分布函数曲线图、各种分布的检验图等。本节主要介绍QQ图和PP图的绘制。[大谦Excel，dqexcel点com]

QQ图

QQ图用变量数据的分位数与所指定分布的分位数之间的关系曲线来检验一元数据是否服从指定的分布。也可以用两个一元数据的分位数之间的关系曲线来检验两个样本是否来自同一分布。如果图中的数据点在对角线附近呈现直线关系，认为一元数据服从指定分布，

图5-24 QQ图

绘制QQ图的核心代码如下所示。完整代码见：Samples->ch08 统计图表->22 QQ图->py.py。代码的重点在于经验分位数和理论分位数的计算，它们的计算结果用于绘制散点图。

code.vba

Sub DrawQQPlot()
  Dim rng As Range
  Dim data()
  Dim dblDT(1 To 20) As Double
  Set rng = Range("B2:B21")
  data = rng.Value
  Dim intI As Integer
  For intI = 1 To 20
    dblDT(intI) = CDbl(data(intI, 1))
  Next

  Dim dblTQ(1 To 20) As Double
  Dim dblEQ(1 To 20) As Double

  SortArray dblDT

  Dim shp As Shape
  Dim cht As Chart
  Set shp = ActiveSheet.Shapes.AddChart2()
  Set cht = shp.Chart
  cht.ChartType = xlXYScatter
  Dim ax1 As Axis
  Set ax1 = cht.Axes(1)
  Dim ax2 As Axis
  Set ax2 = cht.Axes(2)
  ax1.MinimumScale = dblDT(1)
  ax1.MaximumScale = dblDT(20)
  ax2.MinimumScale = dblDT(1)
  ax2.MaximumScale = dblDT(20)
  ax1.CrossesAt = dblDT(1)
  ax2.CrossesAt = dblDT(1)
  ax1.TickLabels.NumberFormat = "0.00"
  ax2.TickLabels.NumberFormat = "0.00"
  SetStyle cht
  TQuantile dblDT, dblTQ

  EQuantile dblDT, dblEQ

  With cht
    .ChartType = xlXYScatter
    .SetSourceData Source:=Range("b2:b" & UBound(dblDT) + 1)
    .SeriesCollection.NewSeries
    .SeriesCollection(1).XValues = dblTQ
    .SeriesCollection(1).Values = dblEQ
    '.HasTitle = True
    '.ChartTitle.Text = "QQ Plot"
    .Axes(xlCategory, xlPrimary).HasTitle = True
    .Axes(xlCategory, xlPrimary).AxisTitle.Text = "Theoretical Quantiles"
    .Axes(xlValue, xlPrimary).HasTitle = True
    .Axes(xlValue, xlPrimary).AxisTitle.Text = "Empirical Quantiles"
  End With
  Dim bx As Double
  Dim by As Double
  Dim ex As Double
  Dim ey As Double
  Dim shp2 As Shape
  bx = ShapeX(cht, CDbl(dblDT(1)))
  by = ShapeY(cht, CDbl(dblDT(1)))
  ex = ShapeX(cht, CDbl(dblDT(20)))
  ey = ShapeY(cht, CDbl(dblDT(20)))
  Set shp2 = cht.Shapes.AddLine(bx, by, ex, ey)
  shp2.Line.DashStyle = msoLineDashDotDot
  shp2.Line.ForeColor.RGB = RGB(0, 0, 0)
  shp2.Line.Weight = 1.5
  cht.SeriesCollection.NewSeries
  Dim intN As Integer
  intN = cht.SeriesCollection.Count
  cht.FullSeriesCollection(intN).ChartType = xlXYScatterLinesNoMarkers
  cht.FullSeriesCollection(intN).XValues = Array(dblDT(1), dblDT(20))
  cht.FullSeriesCollection(intN).Values = Array(dblDT(1), dblDT(1))
  cht.FullSeriesCollection(intN).Format.Line.ForeColor.RGB = RGB(0, 0, 0)
  cht.FullSeriesCollection(intN).Format.Line.Weight = 1
End Sub
Private Sub SortArray(data() As Double)
  Dim dblTemp As Double
  Dim intI As Integer, intJ As Integer

  For intI = LBound(data) To UBound(data) - 1
    For intJ = intI + 1 To UBound(data)
      If data(intI) > data(intJ) Then
        dblTemp = data(intI)
        data(intI) = data(intJ)
        data(intJ) = dblTemp
      End If
    Next
  Next
End Sub

用tquantile函数计算理论分位数。这里使用了工作表函数Norm_S_Inv计算分位数，假设理论分布为标准正态分布。

code.vba

Private Sub TQuantile(dblSortedData() As Double, dblTQ() As Double)
  Dim dblQ() As Double
  Dim intI As Integer

  ReDim dblQ(UBound(dblSortedData))

  For intI = LBound(dblSortedData) To UBound(dblSortedData)
    dblQ(intI) = Application.WorksheetFunction.Norm_S_Inv((intI - 0.5) / UBound(dblSortedData))
  Next

  For intI = LBound(dblSortedData) To UBound(dblSortedData)
    dblTQ(intI) = dblQ(intI)
  Next
End Sub

用equantile函数计算经验分位数。对于 QQ 图，经验分位数就是已排序的数据本身。

code.vba

Private Sub EQuantile(dblSortedData() As Double, dblEQ() As Double)
  Dim intI As Integer
  For intI = LBound(dblSortedData) To UBound(dblSortedData)
    dblEQ(intI) = dblSortedData(intI)
  Next
End Sub

运行代码生成类似图5-24的QQ图。图中用经验分位数和理论分位数绘制散点，绘制绘图区左下角到右上角的连线。数据点在直线附近分布，所以认为数据服从正态分布。

PP图

PP图用变量数据的经验累积概率与所指定分布的理论累积概率之间的关系曲线来检验一元数据是否服从指定的分布。也可以用两个一元数据的分位数之间的关系曲线来检验两个样本是否来自同一分布。如果图中的数据点在对角线附近呈现直线关系，认为一元数据服从指定分布，或两变量数据取自相同分布。

图5-25 PP图

绘制PP图的核心代码如下所示。完整代码见：Samples->ch08 统计图表->23 PP图->py.py。代码的重点在于经验累积概率和理论累积概率的计算，它们的计算结果用于绘制散点图。

code.vba

Sub DrawPPPlot()
  Dim rng As Range
  Dim data()
  Dim dt(1 To 20) As Double
  Set rng = Range("B2:B21")
  data = rng.Value
  Dim intI As Integer
  For intI = 1 To 20
    dt(intI) = CDbl(data(intI, 1))
  Next

  Dim shp As Shape
  Dim cht As Chart
  Set shp = ActiveSheet.Shapes.AddChart2()
  Set cht = shp.Chart
  cht.ChartType = xlXYScatter
  Dim ax1 As Axis
  Set ax1 = cht.Axes(1)
  Dim ax2 As Axis
  Set ax2 = cht.Axes(2)
  ax1.MinimumScale = 0
  ax1.MaximumScale = 1
  ax2.MinimumScale = 0
  ax2.MaximumScale = 1
  SetStyle cht
  Dim dblTProb(1 To 20) As Double
  Dim dblEProb(1 To 20) As Double

  SortArray dt

  TProb dt, dblTProb

  EProb dt, dblEProb

  With cht
    .ChartType = xlXYScatter
    .SetSourceData Source:=Range("b2:b" & UBound(dt) + 1)
    .SeriesCollection.NewSeries
    .SeriesCollection(1).XValues = dblTProb
    .SeriesCollection(1).Values = dblEProb
    '.HasTitle = True
    '.ChartTitle.Text = "PP Plot"
    .Axes(xlCategory, xlPrimary).HasTitle = True
    .Axes(xlCategory, xlPrimary).AxisTitle.Text = "Theoretical Cumulative Probabilities"
    .Axes(xlValue, xlPrimary).HasTitle = True
    .Axes(xlValue, xlPrimary).AxisTitle.Text = "Empirical Cumulative Probabilities"
  End With
  Dim bx As Double
  Dim by As Double
  Dim ex As Double
  Dim ey As Double
  Dim shp2 As Shape
  bx = ShapeX(cht, CDbl(0))
  by = ShapeY(cht, CDbl(0))
  ex = ShapeX(cht, CDbl(1))
  ey = ShapeY(cht, CDbl(1))
  Set shp2 = cht.Shapes.AddLine(bx, by, ex, ey)
  shp2.Line.DashStyle = msoLineDashDotDot
  shp2.Line.ForeColor.RGB = RGB(0, 0, 0)
  shp2.Line.Weight = 1.5
  cht.SeriesCollection.NewSeries
  Dim intN As Integer
  intN = cht.SeriesCollection.Count
  cht.FullSeriesCollection(intN).ChartType = xlXYScatterLinesNoMarkers
  cht.FullSeriesCollection(intN).XValues = Array(0, 1)
  cht.FullSeriesCollection(intN).Values = Array(0, 0)
  cht.FullSeriesCollection(intN).Format.Line.ForeColor.RGB = RGB(0, 0, 0)
  cht.FullSeriesCollection(intN).Format.Line.Weight = 1
End Sub

用tprob函数计算理论累积概率。这里使用了工作表函数Norm_S_Dist计算理论累积概率，假设理论分布为标准正态分布。

code.vba

Private Sub TProb(dblSortedData() As Double, dblTP() As Double)
  Dim dblProb() As Double
  Dim intI As Integer

  ReDim dblProb(UBound(dblSortedData))

  For intI = LBound(dblSortedData) To UBound(dblSortedData)
    dblProb(intI) = Application.WorksheetFunction.Norm_S_Dist(dblSortedData(intI), True)
  Next

  For intI = LBound(dblSortedData) To UBound(dblSortedData)
    dblTP(intI) = dblProb(intI)
  Next
End Sub

用eprob函数计算经验累积概率。

code.vba

Private Sub EProb(dblSortedData() As Double, dblEP() As Double)
  Dim dblProb() As Double
  Dim intI As Integer
  ReDim dblProb(UBound(dblSortedData))

  For intI = LBound(dblSortedData) To UBound(dblSortedData)
    dblProb(intI) = (intI - 0.5) / UBound(dblSortedData)
  Next

  For intI = LBound(dblSortedData) To UBound(dblSortedData)
    dblEP(intI) = dblProb(intI)
  Next
End Sub

运行代码生成类似图5-25的PP图。图中用经验累积概率和理论累积概率绘制散点，绘制绘图区左下角到右上角的连线。数据点在直线附近分布，所以认为数据服从正态分布。[大谦Excel，dqexcel点com]

本页目录

QQ图

PP图