Реализовать программу для апроксимации методом найменьших квадратов данной таблицы - VBA
Формулировка задачи:
Помогите реализовать программу для апроксимации методом найменьших квадратов данной таблицы:
x 0.88 1.460 2.040 2.620 3.200 3.780 4.360 4.940 5.520
y 1.338 2.172 2.921 3.645 4.350 5.041 5.72 6.389 7.048
Решение задачи: «Реализовать программу для апроксимации методом найменьших квадратов данной таблицы»
textual
Листинг программы
Sub aprox()
Dim x() As Single, y() As Single, eps() As Single, yNew() As Single
Dim i As Integer, j As Integer, h As Integer, m As Integer
m = 20
n = InputBox("Введіть кількість відрізків", "Кількість відрізків")
ReDim x(n) As Single
ReDim y(n) As Single
ReDim yNew(n) As Single
ReDim eps(m) As Single
mes = "Апроксимація функції за МНК:"
mes = mes & vbNewLine & vbNewLine
For i = 1 To n
x(i) = InputBox("Введіть " & i & "-e значення x", "Значення х")
Next i
For j = 1 To n
y(j) = InputBox("Введіть " & j & "-e значення y", "Значення у")
Next j
For j = 1 To n
For h = 1 To n
If j = h Then
yNew(h) = y(j)
End If
Next h
Next j
xAr = (x(1) + x(n)) / 2
xGeom = (x(1) * x(n)) ^ 0.5
xGarm = 2 * x(1) * x(n) / (x(1) + x(n))
yAr = (y(1) + y(n)) / 2
yGeom = (y(1) * y(n)) ^ 0.5
yGarm = 2 * y(1) * y(n) / (y(1) + y(n))
minimum = 100
minimum2 = 100
minimum3 = 100
For i = 1 To n
j = i
If xAr = x(i) Then
yzAr = y(j)
ElseIf Abs(xAr - x(i)) < minimum Then
minimum = Abs(xAr - x(i))
yzAr = y(j) + (y(j + 1) - y(j)) / (x(i + 1) - x(i)) * (xGeom - x(i))
End If
If xGeom = x(i) Then
yzGeom = y(j)
ElseIf Abs(xGeom - x(i)) < minimum2 Then
yzGeom = y(j) + (y(j + 1) - y(j)) / (x(i + 1) - x(i)) * (xGeom - x(i))
minimum2 = Abs(xGeom - x(i))
End If
If xGarm = x(i) Then
yzGarm = y(j)
ElseIf Abs(xGarm - x(i)) < minimum3 Then
minimum3 = Abs(xGarm - x(i))
yzGarm = y(j) + (y(j + 1) - y(j)) / (x(i + 1) - x(i)) * (xGarm - x(i))
End If
Next i
eps(1) = Abs(yzAr - yAr)
eps(2) = Abs(yzAr - yGeom)
eps(3) = Abs(yzAr - yGarm)
eps(4) = Abs(yzGeom - yAr)
eps(5) = Abs(yzGeom - yGeom)
eps(6) = Abs(yzGarm - yAr)
eps(7) = Abs(yzGarm - yGarm)
epsMin = eps(1)
For m = 2 To 7
If eps(m) < epsMin Then
epsMin = eps(m)
End If
Next m
If epsMin = eps(1) Then
Text = "Данна залежність є лінійною"
For j = 1 To n
For i = 1 To n
If j = i Then
y(j) = y(j)
x(i) = x(i)
End If
Next i
Next j
ElseIf epsMin = eps(2) Then
Text = "Дана залежність є показниковою"
For j = 1 To n
For i = 1 To n
If j = i Then
y(j) = Log(y(j)) / Log(10)
x(i) = x(i)
End If
Next i
Next j
ElseIf epsMin = eps(3) Then
Text = "Дана залежність є дробово-раціональною"
For j = 1 To n
For i = 1 To n
If j = i Then
x(i) = x(i)
y(j) = 1 / y(j)
End If
Next i
Next j
ElseIf epsMin = eps(4) Then
Text = "Дана залежність є логарифмічною"
For j = 1 To n
For i = 1 To n
If j = i Then
x(i) = Log(x(i))
y(j) = y(j)
End If
Next i
Next j
ElseIf epsMin = eps(5) Then
Text = "Дана залежність є степеневою"
For j = 1 To n
For i = 1 To n
If j = i Then
y(j) = Log(y(j)) / Log(10)
x(i) = Log(x(i)) / Log(10)
End If
Next i
Next j
ElseIf epsMin = eps(6) Then
Text = "Дана залежність є гіперболічною"
For j = 1 To n
For i = 1 To n
If j = i Then
x(i) = 1 / x(i)
y(j) = y(j)
End If
Next i
Next j
ElseIf epsMin = eps(7) Then
Text = "Дана залежність є добово-раціональною"
For j = 1 To n
For i = 1 To n
If j = i Then
y(j) = 1 / y(j)
x(i) = 1 / x(i)
End If
Next i
Next j
End If
mes = mes & Text & vbNewLine & vbNewLine & "y(задане) " & "y(апроксимоване)" & vbNewLine
sumX2 = 0
sumX = 0
For i = 1 To n
sumX = sumX + x(i)
sumX2 = sumX2 + x(i) ^ 2
Next i
sumY = o
For j = 1 To n
sumY = sumY + y(j)
Next j
summ = o
For i = 1 To n
For j = 1 To n
If i = j Then
summ = summ + x(i) * y(j)
End If
Next j
Next i
del = n * sumX2 - (sumX * sumX)
del1 = sumY * sumX2 - (summ * sumX)
del2 = n * summ - (sumX * sumY)
b0 = del1 / del
b1 = del2 / del
For j = 1 To n
For i = 1 To n
If j = i Then
y(j) = b0 + b1 * x(i)
End If
Next i
Next j
If epsMin = eps(1) Then
For j = 1 To n
For i = 1 To n
If j = i Then
y(j) = y(j)
x(i) = x(i)
End If
Next i
Next j
ElseIf epsMin = eps(2) Then
For j = 1 To n
For i = 1 To n
If j = i Then
y(j) = Exp(y(j) * Log(10))
x(i) = x(i)
End If
Next i
Next j
ElseIf epsMin = eps(3) Then
For j = 1 To n
For i = 1 To n
If j = i Then
x(i) = x(i)
y(j) = 1 / y(j)
End If
Next i
Next j
ElseIf epsMin = eps(4) Then
For j = 1 To n
For i = 1 To n
If j = i Then
x(i) = Exp(x(i))
y(j) = y(j)
End If
Next i
Next j
ElseIf epsMin = eps(5) Then
For j = 1 To n
For i = 1 To n
If j = i Then
y(j) = Exp(y(j) * Log(10))
x(i) = Exp(x(i) * Log(10))
End If
Next i
Next j
ElseIf epsMin = eps(6) Then
For j = 1 To n
For i = 1 To n
If j = i Then
x(i) = 1 / x(i)
y(j) = y(j)
End If
Next i
Next j
ElseIf epsMin = eps(7) Then
For j = 1 To n
For i = 1 To n
If j = i Then
y(j) = 1 / y(j)
x(i) = 1 / x(i)
End If
Next i
Next j
End If
For h = 1 To n
For j = 1 To n
If h = j Then
vseEps = vseEps + (yNew(h) - y(j)) ^ 2
mes = mes & yNew(h) & " " & y(j) & vbNewLine
End If
Next j
Next h
poh = (vseEps / (n - 1)) ^ 0.5
mes = mes & vbNewLine & vbNewLine & "Середньоквадратична похибка: " & poh
MsgBox mes
End Sub