用vb 求回归方程和相关系数的代码?
VB实现最小二乘法多次曲线拟合 Option Explicit '**************************************************************************************************** 'X()－－－－－－Double 实型一维数组，长度为 n 。 存放给定 n 个数据点的 X 坐标。 'Y()－－－－－－Double 实型一维数组，长度为 n 。存放给定 n 个数据点的 Y 坐标。 'n－－－－－－－Integer 变量。给定数据点的个数。 ' a()－－－－－－Double 实型一维数组，长度为 ...全部
VB实现最小二乘法多次曲线拟合 Option Explicit '**************************************************************************************************** 'X()－－－－－－Double 实型一维数组，长度为 n 。
存放给定 n 个数据点的 X 坐标。 'Y()－－－－－－Double 实型一维数组，长度为 n 。存放给定 n 个数据点的 Y 坐标。 'n－－－－－－－Integer 变量。给定数据点的个数。
' a()－－－－－－Double 实型一维数组，长度为 m 。返回 m-1 次拟合多项式的 m 个系数。 ' m－－－－－－－Integer 变量。拟合多项式的项数，即拟合多项式的最高次数为 m-1。
' 要求 mn 或 m>20 ，则本函数自动按 m=min{n,20} 处理。 'rdblAverageX－－Double 变量，返回给定n个数据点的 X 坐标的平均值 'dt()－－－－－－Double 实型一维数组，长度为 3。
其中： 'dt(0) 返回拟合多项式与数据点误差的平方和； 'dt(1) 返回拟合多项式与数据点误差的绝对值之和； 'dt(2) 返回拟合多项式与数据点误差绝对值的最大值。 '***************************************************************************************************** Public Sub Iapcir(X() As Double,Y() As Double,ByVal n As Integer, _ ByRef a() As Double,ByVal m As Integer,ByRef rdblAverageX As Double, _ ByRef dt() As Double) Dim I , J, K As Integer Dim Z, P, C, G, Q, D1, D2 As Double Dim S(19), T(19), B(19) As Double '给多项式各项系数赋初值0 For I = 0 To m - 1 a(I) = 0 Next I '保证系数项目个数小于数据点个数以及小于或者等于20 If m > n Then m = n If m > 20 Then m = 20 '计算x点的平均值 Z = 0# For I = 0 To n - 1 rdblAverageX = rdblAverageX X(I) '统计所有x点的总和 Z = Z X(I) / (1# * n) '双精度表示 Next I rdblAverageX = rdblAverageX / n B(0) = 1# D1 = 1# * n P = 0# C = 0# For I = 0 To n - 1 P = P (X(I) - Z) 'x各点与x平均值的差的和 C = C Y(I) 'y各点的和 Next I C = C / D1 P = P / D1 a(0) = C * B(0) If m > 1 Then T(1) = 1# T(0) = (-1) * P D2 = 0# C = 0# G = 0# For I = 0 To n - 1 Q = X(I) - Z - P D2 = D2 Q * Q C = C Y(I) * Q G = G (X(I) - Z) * Q * Q Next I C = C / D2 P = G / D2 Q = D2 / D1 D1 = D2 a(1) = C * T(1) a(0) = C * T(0) a(0) End If For J = 2 To m - 1 S(J) = T(J - 1) S(J - 1) = (-1) * P * T(J - 1) T(J - 2) If J >= 3 Then For K = J - 2 To 1 Step -1 S(K) = (-1) * P * T(K) T(K - 1) - Q * B(K) Next K End If S(0) = (-1) * P * T(0) - Q * B(0) D2 = 0# C = 0# G = 0# For I = 0 To n - 1 Q = S(J) For K = J - 1 To 0 Step -1 Q = Q * (X(I) - Z) S(K) Next K D2 = D2 Q * Q C = C Y(I) * Q G = G (X(I) - Z) * Q * Q Next I C = C / D2 P = G / D2 Q = D2 / D1 D1 = D2 a(J) = C * S(J) T(J) = S(J) For K = J - 1 To 0 Step -1 a(K) = C * S(K) a(K) B(K) = T(K) T(K) = S(K) Next K Next J dt(0) = 0# dt(1) = 0# dt(2) = 0# For I = 0 To n - 1 Q = a(m - 1) For K = m - 2 To 0 Step -1 Q = a(K) Q * (X(I) - Z) Next K P = Q - Y(I) If Abs(P) > dt(2) Then dt(2) = Abs(P) End If dt(0) = dt(0) P * P dt(1) = dt(1) Abs(P) Next I End Sub 说明:这是将一段工业数据(不规则曲线)拟合成一条光滑的曲线,Excel有同样的功能,经验证,该过程得到的二次方程比Excel要准确。
方程:Y = a(0) a(1) * (X - X1) a(2) * (X - X1)^2 。。。。。 。 a(n) * (X - X1)^n 其中X1为X轴的平均值 验证方法:你可以用一组不规则的数据经过该程序得到方程式后,代入你的不规则数得到另一组数据,用Excel来比较这两组数据有何不同。
有X轴和Y轴系列不规则曲线点:X(50),Y(50), 欲得到二次方程式各项系数为a(2),X轴系列点平均值X1,dt(2)见首楼,则: 函数调用:Call Iapcir(X, Y,50, a, 3, X1, dt)。
收起
