[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『Excel散布図の平滑線の値を取得する方法について』（γ）
[[20211227140628]]のスレッドで、
Excelの散布図（平滑線とマーカー）で使用されている平滑線の値を再現したい、 という議論がありました。 ・グラフに表現された曲線の数式を求められないか、とか ・指定したｘ軸の数値に対応する数値を知りたい、 といった話でした。
ネットで検索したところ、下記の記事にあるように、 https://answers.microsoft.com/ja-jp/msoffice/forum/all/excel%E3%81%A7%E3%83%9D%E3%82%A4%E3%83%B3%E3%83%88/951f5703-a161-4d7e-989f-faa3dcccfe6e こうしたニーズは結構あるものの（「私も同じ質問を持っています52人」など）、 日本語による記事で、コードを提供しているものがなかったので、 こちらで紹介することも有益かと思い発言させていただきます。
上記のスレッド[[20211227140628]]の質問者さんは、 既にExcel以外のグラフツールで解決されたようですので、あえて別のスレッドを立てました。 (質問事項は含まれませんが、事情ご了解いただきたいと思います。）
さて、Excelの散布図における平滑線については、 マイクロソフト社が仕様（算定方法）を公開していません。 これを巡る議論については、この後で別途まとめることとし、 当面の対応策を、コードとともに示してみたいと思います。
■ 平滑線を再現する方法として、 (1)Cubic Spline （3次スプライン） (2)Catmull-Rom Spline （提案者2名の名前を冠したスプラインの一種です） の二つを取り上げます。
●Sheet1で、実例を用いて、二つの方法によるExcel平滑線の再現度合いを可視化してみました。 その結果、(2)のCatmull-Rom Spline が、Excel平滑線にほぼ近いものであることが改めて確認できました。
●Sheet2では、 「ユーザーが指定するX軸の値に対応するy軸数値を求める方法」について示します。
いずれも、マクロで数値例を作成しますので、ユーザーの確認作業は、 ・マクロをコピーペイストすること ・マクロを実行すること だけです。
■マクロの内容 4つのmoduleに分けました。 (1)module1 Cubic Splineによる補間 (2)module2 Catmull-Rom Splineによる補間 (3)module3 (1)(2)の実例の作成 (4)module4 Catmull-Rom Splineを用いた、指定したｘ値に対応したy値の算出例
■使い方
・新規ブックを作成し、Sheet1,Sheet2を用意してください。
・4つの標準モジュールに、下記に示すコードをコピーペイストしてください。
・module3 main プロシージャ を実行してください。Sheet1に 下記の表とグラフ が得られます。
・A:B列は、散布図の元データです。（6個の制御点を持つサンプルです）
・C:D列は、Cubic Splineを用いて、制御点の間に10個の補間値を算出したもの
・E:F列は、Catmull-Rom Splineを用いて、制御点の間に10個の補間値を算出したもの
・グラフも示します。
・module4 の main2 プロシージャ を実行してください。Sheet2に 下記の表とグラフが得られます。
・A:B列は、上記と同一の散布図の元データです。
・C 列は、補間点の x軸方向の数値を指定したものです。（例として、等間隔で指定しています）
・F:H列は、作業列です。
・D 列は、算出されたy軸方向補間値です（H列の結果をコピーしたものです）
・グラフも示します。
Excel2019で一応の動作確認はしています。あまり念入りに検証していませんので、思わぬ不具合が あるかもしれません（特にサンプル検証部分）。 何かお気づきの方はコメントください。
＜ 使用 Excel：Excel2019、使用 OS：Windows10 ＞
【参考コード】 ' ============ module1 ================================= Option Explicit Rem cubic spline Dim wsData As Worksheet Dim wsOut As Worksheet
Public Const firstRow& = 3 'x,yデータの開始行 Const numOfInterp As Long = 10 '1区間あたりの補間点の個数
Dim x#(), y#(), h#(), dl#(), d_tmp#(), du#(), tA#(), D#(), z#() Dim points#() Dim num& ' 制御点の数
Sub CubicSpline()
Dim xx#, k&, j&, p&
Set wsData = Worksheets("Sheet1") '■要修正
Set wsOut = Worksheets("Sheet1") '■要修正
Call dataSet 'wsDataシートからデータを読み、基本的配列を作成
'補間点pointsの算出
ReDim points#(1 To (num - 1) * numOfInterp + 1, 1 To 2) '補間点の配列
For k = 1 To num - 1
For j = 1 To numOfInterp
xx = x(k) + (x(k + 1) - x(k)) / numOfInterp * (j - 1)
p = p + 1
points(p, 1) = xx
points(p, 2) = getValue(xx, k)
Next
Next
'最後の端点を書き込み
p = p + 1
points(p, 1) = x(num)
points(p, 2) = y(num)
'補間点をワークシートに出力
wsOut.Cells(firstRow, "C").Resize(UBound(points), 2) = points
End Sub
Function getValue(xx As Double, k As Long) As Double
Dim A#, C#, D#
A = z(k) * (x(k + 1) - xx) ^ 3 / (6 * h(k + 1)) + z(k + 1) * (xx - x(k)) ^ 3 / (6 * h(k + 1))
C = (y(k + 1) / h(k + 1) - z(k + 1) * h(k + 1) / 6) * (xx - x(k))
D = (y(k) / h(k + 1) - z(k) * h(k + 1) / 6) * (x(k + 1) - xx)
getValue = A + C + D
End Function
Sub dataSet()
Dim n&, k&
num = wsData.Cells(Rows.Count, "A").End(xlUp).Row - (firstRow - 1) ' 観測点の個数
n = num - 1
'---- x, y --------制御点（観測点）
ReDim x#(1 To num)
ReDim y#(1 To num)
For k = 1 To num
x(k) = wsData.Cells(firstRow + k - 1, "A")
y(k) = wsData.Cells(firstRow + k - 1, "B")
Next
' ---- h -----
ReDim h#(1 To num + 1)
For k = 2 To num
h(k) = x(k) - x(k - 1)
Next
' ---- dl -------------
ReDim dl#(1 To n)
For k = 1 To n
dl(k) = h(k + 1)
Next
' --- d_tmp --------
ReDim d_tmp#(1 To n + 1)
For k = 1 To n + 1
d_tmp(k) = 2 * (h(k) + h(k + 1))
Next
' ---- du -------------
ReDim du#(1 To n)
du = dl
' ---- tA ---------- Tridiagonal行列
ReDim tA#(1 To num, 1 To num)
For k = 1 To num
tA(k, k) = d_tmp(k)
Next
For k = 1 To num - 1
tA(k + 1, k) = dl(k)
tA(k, k + 1) = du(k)
Next
' --- d ----------
ReDim D#(1 To n + 1, 1 To 1)
For k = 2 To n
D(k, 1) = 6 * (y(k + 1) - y(k)) / h(k + 1) - 6 * (y(k) - y(k - 1)) / h(k)
Next
Dim zz
zz = Application.MMult(Application.MInverse(tA), D)
ReDim z#(1 To num)
For k = 1 To num
z(k) = zz(k, 1)
Next
End Sub
' ============ module2 =================================
Option Explicit
Rem Catmull-Rom Spline
Const firstRow& = 3 'x,yデータの開始行 Const numOfInterp As Long = 10 '1区間あたりの補間点の個数
Dim data As Variant ' もともとの制御点（シートから読み込み) Dim num As Long Dim p0#(1 To 2), p1#(1 To 2), v0#(1 To 2), v1#(1 To 2) Dim c0#(1 To 2), c1#(1 To 2), c2#(1 To 2), c3#(1 To 2)
Sub catmullRomSpline()
Dim wsData As Worksheet
Dim wsOut As Worksheet
Dim t As Double
Dim vv As Variant
Dim k&, p&, j&
Set wsData = Worksheets("Sheet1") '■要修正
Set wsOut = Worksheets("Sheet1") '■要修正
'元データのセット
num = wsData.Cells(Rows.Count, "A").End(xlUp).Row - (firstRow - 1)
data = wsData.Cells(firstRow, "A").Resize(num, 2).Value
'補間点 points を作成
ReDim points(1 To (num - 1) * numOfInterp + 1, 1 To 2) As Double
'元のポイントどうしを10個の補間点で結ぶ
For k = 1 To num - 1
Call getCoefficient(k) '諸係数の作成
For p = 1 To numOfInterp
t = 1 / numOfInterp * (p - 1)
vv = getInterpolate(t) '補間点の作成
j = j + 1
points(j, 1) = vv(1)
points(j, 2) = vv(2)
Next
Next
j = j + 1
points(j, 1) = data(num, 1)
points(j, 2) = data(num, 2)
'結果の書き出し
wsOut.Cells(firstRow, "E").Resize(UBound(points), 2) = points
End Sub
Function getCoefficient(i As Long) '
Dim k&
'直近の制御点p0 と 次の制御点p1
p0(1) = data(i, 1): p0(2) = data(i, 2)
p1(1) = data(i + 1, 1): p1(2) = data(i + 1, 2)
'p0での向き
If i > 1 Then '(直前(i)の制御点と直後(i+2)の制御点から「移動方向」を取得）
v0(1) = 0.5 * (data(i + 1, 1) - data(i - 1, 1))
v0(2) = 0.5 * (data(i + 1, 2) - data(i - 1, 2))
Else '(最初の制御点と２番目の制御点から「移動方向」を取得）
v0(1) = data(i + 1, 1) - data(i, 1)
v0(2) = data(i + 1, 2) - data(i, 2)
End If
'p1での向き
If i < (num - 1) Then
v1(1) = 0.5 * (data(i + 2, 1) - data(i, 1))
v1(2) = 0.5 * (data(i + 2, 2) - data(i, 2))
Else
v1(1) = data(i + 1, 1) - data(i, 1)
v1(2) = data(i + 1, 2) - data(i, 2)
End If
'補間計算のための係数の作成
For k = 1 To 2
c0(k) = 2 * p0(k) - 2 * p1(k) + v0(k) + v1(k)
c1(k) = -3 * p0(k) + 3 * p1(k) - 2 * v0(k) - v1(k)
c2(k) = v0(k)
c3(k) = p0(k)
Next
End Function
Function getInterpolate(t As Double) As Variant
ReDim w#(1 To 2)
Dim k&
For k = 1 To 2
w(k) = c0(k) * t ^ 3 + c1(k) * t ^ 2 + c2(k) * t + c3(k)
Next
getInterpolate = w
End Function
' ============ module3 =================================
Option Explicit
Sub main()
Worksheets("Sheet1").Select
Call setting 'データの設定
Call CubicSpline
Call catmullRomSpline
Call makeGraph '結果を対比するためのグラフ
End Sub
Sub setting()
Columns("A:F").ClearContents
Rows(2).Clear
[A1] = "Excel散布図": [c1] = "Cubic Spline": [E1] = "Catmull-Rom Spline"
[A2:F2] = [{"x","y","x","y","x","y"}]
[A2:B2].Interior.ThemeColor = xlThemeColorAccent5
[C2:D2].Interior.ThemeColor = xlThemeColorAccent4
[E2:F2].Interior.Color = 65535
'data
[A3:B8] = [{0,14.7;62.25,11.51;109.66,10.41;162.66,14.95;205.8,12.24;252.3,11.22}]
End Sub
Sub makeGraph()
Dim shp As Shape
Dim ch As Chart
Dim lastRow As Long
Set shp = ActiveSheet.Shapes.AddChart2(240, xlXYScatterSmooth)
With shp
.Top = [H3:P27].Top
.Left = [H3:P27].Left
.Width = [H3:P27].Width
.Height = [H3:P27].Height
End With
lastRow = Cells(Rows.Count, "C").End(xlUp).Row '修正しました
With shp.Chart
.SetSourceData Source:=Range("Sheet1!$A$3:$B$8")
.FullSeriesCollection(1).Name = "=Sheet1!$A$1"
.SeriesCollection.NewSeries
.FullSeriesCollection(2).Name = "=Sheet1!$C$1"
.FullSeriesCollection(2).XValues = "=Sheet1!$C$3:$C$" & lastRow
.FullSeriesCollection(2).Values = "=Sheet1!$D$3:$D$" & lastRow
.SeriesCollection.NewSeries
.FullSeriesCollection(3).Name = "=Sheet1!$E$1"
.FullSeriesCollection(3).XValues = "=Sheet1!$E$3:$E$" & lastRow
.FullSeriesCollection(3).Values = "=Sheet1!$F$3:$F$" & lastRow
.FullSeriesCollection(2).ChartType = xlXYScatter
.FullSeriesCollection(3).ChartType = xlXYScatter
.SetElement (msoElementLegendTop)
.ChartTitle.Delete
.Axes(xlValue).MinimumScale = 10
With .FullSeriesCollection(1).Format.Line
.Visible = msoTrue
.weight = 2.5
End With
With .FullSeriesCollection(1)
.MarkerStyle = 1
.MarkerSize = 8
End With
.FullSeriesCollection(2).Format.Line.Visible = msoFalse
With .FullSeriesCollection(3)
.MarkerStyle = 8
.MarkerSize = 5
End With
With .FullSeriesCollection(3).Format.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 255, 0)
End With
End With
End Sub
' ============ module4 ================================= Option Explicit
Dim lastRow&
Sub main2()
Worksheets("Sheet2").Select
Application.Calculation = xlCalculationManual
'A:B列に 制御点のデータ。
'C 列に 補間すべきX軸の値をセット
Call setting2 'テスト用のアドホックなもの
'以下が、ユーザーが指定する補間用のX軸方向の値をもとに
' 補間値(y軸値）を求めるもの
' ============================= ここから
lastRow = Cells(Rows.Count, "C").End(xlUp).Row
'parameterには仮数値をセット
Range("F3:F" & lastRow).Value = 0.5
'D列のパラメータに対応する補間値計算式をセット
Range("G3:H" & lastRow).ClearContents
Range("G3:H3").FormulaArray = "=catmullRomSpline2(F3,$A$3:$B$8)"
Range("G3:H3").Copy Range("G4:H" & lastRow)
Application.Calculation = xlCalculationAutomatic
'ゴールシークを使って、xに対応するparameterを逆算。対応するy値を取得
Call calculateParameters
'y値をD列に値貼り付け
Range("H3:H" & lastRow).Copy
Range("D3").PasteSpecial xlPasteValues
Application.CutCopyMode = False
' ============================== ここまで
Call makeGraph2 '結果確認のためのグラフ
End Sub
Sub setting2()
Columns("A:H").ClearContents
[A1] = "Excel散布図"
[A2:B2] = [{"x","y"}]
[A3:B8] = [{0,14.7;62.25,11.51;109.66,10.41;162.66,14.95;205.8,12.24;252.3,11.22}]
[C1:D1] = [{"指定値","計算値"}]
[C2:D2] = [{"x","y"}]
'補間に使用するXの値を設定
[c3] = 0
[c3].DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=10, Stop:=250, Trend:=False
[F1:H1] = Split("作業列,自動計算,自動計算", ",")
[F2:H2] = Split("parameter,x,y", ",")
End Sub
Rem GoalSeekを使って、パラメータを逆算する
Sub calculateParameters()
Dim i As Long
Application.MaxChange = 0.00000000001
Application.MaxIterations = 1000
For i = 3 To lastRow
Cells(i, "G").GoalSeek Cells(i, "C"), Cells(i, "F")
'数式セル 数式の目標値 , 変動セル
Next
End Sub
'ユーザー定義関数(制御点データrngを元に、パラメータtに対応する補間値(x,y)を算出）
Function catmullRomSpline2(t As Double, rng As Range)
Dim data
Dim numsOfData&
Dim progress#, i&, weight#
Dim p0#(1 To 2)
Dim p1#(1 To 2)
Dim A As Range
Dim ws As Worksheet
Set A = Application.Caller
Set ws = A.Parent
numsOfData = rng.Rows.Count
data = rng.Value
progress = (numsOfData - 1) * t
i = Application.Floor(progress, 1)
weight = progress - i
If Abs(weight) < 10 ^ -5 And i >= numsOfData - 1 Then
i = numsOfData - 2
weight = 1
End If
'直近の制御点p0 と 次の制御点p1
p0(1) = data(i + 1, 1): p0(2) = data(i + 1, 2)
p1(1) = data(i + 2, 1): p1(2) = data(i + 2, 2)
'p0での向き
ReDim v0#(1 To 2)
If i > 0 Then
v0(1) = 0.5 * (data(i + 2, 1) - data(i, 1))
v0(2) = 0.5 * (data(i + 2, 2) - data(i, 2))
Else
v0(1) = data(i + 2, 1) - data(i + 1, 1)
v0(2) = data(i + 2, 2) - data(i + 1, 2)
End If
'p1での向き
ReDim v1#(1 To 2)
If i < (numsOfData - 2) Then
v1(1) = 0.5 * (data(i + 3, 1) - data(i + 1, 1))
v1(2) = 0.5 * (data(i + 3, 2) - data(i + 1, 2))
Else
v1(1) = data(i + 2, 1) - data(i + 1, 1)
v1(2) = data(i + 2, 2) - data(i + 1, 2)
End If
catmullRomSpline2 = getInterpolate(p0, p1, v0, v1, weight)
End Function
Function getInterpolate(p0, p1, v0, v1, t As Double)
Dim c0#(1 To 2), c1#(1 To 2), c2#(1 To 2), c3#(1 To 2)
ReDim w#(1 To 2)
Dim k&
For k = 1 To 2
c0(k) = 2 * p0(k) - 2 * p1(k) + v0(k) + v1(k)
c1(k) = -3 * p0(k) + 3 * p1(k) - 2 * v0(k) - v1(k)
c2(k) = v0(k)
c3(k) = p0(k)
w(k) = c0(k) * t ^ 3 + c1(k) * t ^ 2 + c2(k) * t + c3(k)
Next
getInterpolate = w
End Function
Sub makeGraph2()
Dim shp As Shape
Dim ch As Chart
Dim r As Range
Set shp = ActiveSheet.Shapes.AddChart2(240, xlXYScatterSmooth)
Set r = [J2:R26]
With shp
.Top = r.Top
.Left = r.Left
.Width = r.Width
.Height = r.Height
End With
With shp.Chart
.SetSourceData Source:=Range("Sheet2!$A$3:$B$8")
.FullSeriesCollection(1).Name = "散布図(平滑線付き）"
.SeriesCollection.NewSeries
.FullSeriesCollection(2).Name = "補間値"
.FullSeriesCollection(2).XValues = "=Sheet2!$C$3:$C$" & lastRow
.FullSeriesCollection(2).Values = "=Sheet2!$D$3:$D$" & lastRow
.FullSeriesCollection(2).ChartType = xlXYScatter
.SetElement (msoElementLegendTop)
.ChartTitle.Delete
.Axes(xlValue).MinimumScale = 10
With .FullSeriesCollection(1).Format.Line
.Visible = msoTrue
.weight = 2.5
End With
With .FullSeriesCollection(1)
.MarkerStyle = 1
.MarkerSize = 8
End With
.FullSeriesCollection(2).Format.Line.Visible = msoFalse
With .FullSeriesCollection(2).Format.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 255, 0) '黄色
End With
End With
End Sub
なお、cubic splineのコードは、下記を参考にしました。 https://github.com/PumasAI/DataInterpolations.jl
Catmull-Rom Splineのコードは、下記を参考にしました。 https://hadashia.hatenablog.com/entry/201
（γ） 2022/01/05(水) 23:12
■概要説明
(1)Cubic Splineは、区分ごとの3次関数で各制御点を結ぶという考え方です。
単に結ぶだけでなく、
・制御点での微分が連続していること
・制御点での二階微分が連続していること
を条件とするもので、かなり一般的な手法です。
(2)Catmull-Rom Splineも、区分ごとの3次関数ですが、
・開始点での向きを、 (p(2) - p(1) とし、
・それ以降の向きは (p(1+1)- p(i-1))/2 となるよう条件を課したものです。
（p(i)は、i番目の制御点の位置を示すvector（x,yの二要素からなるもの）です。）
(3)Catmull-Rom Splineは、x値を基にy値を算出する方式ではなく、 0<=t<=1 のパラメータを基に、x,ｙを同時に算出する方式なので、 ｘからいったん t を逆算し、それをもとに y値を求める必要があります。 それを実行しているのが、module4にあるプロシージャです。 逆算にはGoalseekを使っています。 このため、ワークシートにユーザー関数を置く必要がありました。
【参考とした記事】 (1)については、下記がよいでしょう。 http://www.yamamo10.jp/yamamoto/lecture/2006/5E/interpolation/interpolation_html/node3.html (2)については、下記がイメージ湧きやすかったですね。 https://hadashia.hatenablog.com/entry/201
■このテーマ（Excelの散布の平滑線はどう作成しているのか）に関する経緯
(4)これについての議論は、下記が基本文献かと思います。 https://answers.microsoft.com/en-us/msoffice/forum/all/how-does-excel-plot-smooth-curves/c751e8ff-9f99-4ac7-a74a-fba41ac80300
(5)最初に注目を浴びたのは、下記のブライアン・マーフィー氏の記事のようです。
BezierスプラインをExcelは使っているのではないかと公表しました。
http://web.archive.org/web/20041030121555/http://www.xlrotor.com/resources/files.shtml
| Smooth_curve_bezier_example_file.xls solves one of the long standing mysteries of Excel.
| This file demonstrates that it is possible to compute a curve that matches the one Excel
| draws for its "smooth curve" feature on xy scatter charts. This algorithm is also used
| in Chartool to enable its cursor to follow Excel's smooth curve.
| Download by clicking here (smooth_curve_bezier_example_file.zip 23,750 bytes, last updated Mar 15, 2003).
(そのリンクはダウンロード可能です。）
(6)しかし、 https://peltiertech.com/excel-interpolation-formulas/#comment-234464 によれば、 | Wednesday, June 13, 2012 at 11:08 pm | Jon ? yes, I saw that. I believe that the Bezier algorithms may be very similar, | but MS Excel actually uses modified Catmull-Rom splines, per the July 4, 2011 post | by Answers.Microsoft in response to Tushar Mehta. のように、Microsoft社は非公式ですが、"修正したCatmull-Rom splineを使用している"としているようです。（私自身は未確認）
(7)両者（BezierスプラインとCatmull-Romスプライン）は、ある種の変換で相互に移りうる
ことが知られていて、Catmull-Rom splines と実質的に同等とされているようです。
実際、Catmull-Rom splineを使用して算出したものは、
ブライアン・マーフィー氏の結果とまったく同一の結果となることが確認できました。
ただし、Catmull-Rom splineのほうが、Bezier Splineよりも見通しのよい方法のように
感じます（私見）。
(8)なお、
・特定のケースでは、Bezier Splineは誤った結果をもたらすことがあるとの指摘もあり、
・Catmull-Rom splineでも、特定のケースでは精度が落ちるらしいです
詳細は確認していません。なんらかの修正が必要なケースはあるようです。
追記：
なお、通常のCubic Splineは x1 < x2 < x3 < .... < xn を前提としています。
従って、次のような散布図で、上から順次平滑線で結ぼうとすると、
x y
1 10
3 9
2 8
4 7
5 11
上記の前提を満たしませんので Cubic Splineは想定したものとなりません。
（制御点で接線の傾きは同じになるものの、向きが反転するような図形になってしまいます。
いわゆるCusp状況となります。）
このような場合でも、Catmull-Rom Splineは、Excelと同様の結果が得られます。
（γ） 2022/01/05(水) 23:14
全く理解できていませんが
＞'makeGraphで時間がかかるのは原因不明
たぶん、ここでは
lastRow = Cells(Rows.Count, "C").End(xlUp).Row
（マナ） 2022/01/06(木) 11:23
ご指摘ありがとうございました。
# 本文中の記載は、後で修正しておいて、読む方に迷惑がかからないようにしておきます。
## 2022/1/6 リンク先の誤りを修正しました。
（γ） 2022/01/06(木) 11:48
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.