Реализовать программу для апроксимации методом найменьших квадратов данной таблицы - 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
ИИ поможет Вам:
- решить любую задачу по программированию
- объяснить код
- расставить комментарии в коде
- и т.д