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

ИИ поможет Вам:


  • решить любую задачу по программированию
  • объяснить код
  • расставить комментарии в коде
  • и т.д
Попробуйте бесплатно

Оцени полезность:

9   голосов , оценка 4.111 из 5
Похожие ответы