forum.zelfbouwaudio.nl

CODE: Selecteer alles

' ======== algemene instellingen voor VBA ===================================
Option Explicit     ' Force explicit variable declaration                   |
Option Base 1       ' arrays beginnen bij 1                                 |
' ======== algemene instellingen voor VBA ===================================


' ------------ PolyFit ----------------------------------
Function PolyFit(ByVal punt As Double, known_Ys, Optional known_Xs, Optional graad)

Dim Q() As Double, H() As Double, C() As Double, _
    X() As Double, Y() As Double
Dim i As Integer, j As Integer, k As Integer, u As Integer, _
    N As Integer, numfunc As Integer, nf As Integer, graad2 As Integer
Dim Ysum As Double, pf As Double, p As Double
Dim is_mis_X As Boolean

  N = UBound(known_Ys.Value) - LBound(known_Ys.Value) + 1
  If IsMissing(graad) Then
      graad2 = 1 + Int((N - 1) / 2)           ' default: afhankelijk van aantal datapunten
      If graad2 > 2 Then graad2 = 2           ' zonder opgave nooit meer dan een 2e graads polynoom
    Else
      graad2 = CInt(graad)
  End If
  If graad2 > (N - 1) Then graad2 = N - 1     ' altijd graad+1 punten nodig!
  If graad2 < 0 Then PolyFit = 0 / 0          ' exit function with error
  numfunc = graad2 + 1
  nf = graad2 + 2

  is_mis_X = IsMissing(known_Xs)
  If UBound(known_Ys.Value, 2) <> 1 Then PolyFit = 0 / 0  ' exit function with error
  If Not is_mis_X Then _
    If (UBound(known_Xs.Value) <> N) Or (UBound(known_Xs.Value, 2) <> 1) _
      Then PolyFit = 0 / 0

  ReDim Q(1 To numfunc, 1 To nf)
  ReDim H(1 To N, 1 To numfunc)
  ReDim X(1 To N)
  ReDim Y(1 To N)
  ReDim C(1 To numfunc)

  For i = 1 To N
    Y(i) = known_Ys.Item(i)
    If is_mis_X Then
      X(i) = i
     Else
      X(i) = known_Xs.Item(i)
    End If
  Next i

  For k = 1 To numfunc
    For j = 1 To numfunc + 1
      Q(k, j) = 0
    Next j
  Next k

  Ysum = 0
  For i = 1 To N
    Ysum = Ysum + Y(i)
    H(i, 1) = 1
    For j = 2 To numfunc
      H(i, j) = H(i, j - 1) * X(i)
    Next j
    For j = 1 To numfunc
      Q(j, numfunc + 1) = Q(j, numfunc + 1) + H(i, j) * Y(i)
      For k = 1 To numfunc
        Q(k, j) = Q(k, j) + H(i, k) * H(i, j)
      Next k
    Next j
  Next i

  For j = 1 To numfunc
    For k = 1 To numfunc
      If j <> k Then
        p = Q(k, j) / Q(j, j)
        For u = j To numfunc + 1
          Q(k, u) = Q(k, u) - p * Q(j, u)
        Next u
      End If
    Next k
  Next j

  For k = 1 To numfunc
    C(k) = Q(k, numfunc + 1) / Q(k, k)
  Next k

  pf = C(numfunc)
  For i = numfunc - 1 To 1 Step -1
    pf = pf * punt + C(i)
  Next i

  PolyFit = pf
End Function  ' --- van PolyFit ------------------------------------------

     
' ------------ LaGrange ----------------------------------
Function LaGrange(ByVal punt As Double, known_Ys, Optional known_Xs, Optional sorted) As Double
' werkt voorlopig alleen nog maar met vertikale arrays
  Dim i As Integer, N As Integer, is_mis_Xs As Boolean, isSorted As Boolean
  Dim X() As Double, Y() As Double
  
  N = UBound(known_Ys.Value, 1) - LBound(known_Ys.Value, 1) + 1 'n=lengte array
  is_mis_Xs = IsMissing(known_Xs)
  
  If UBound(known_Ys.Value, 2) > 1 Then LaGrange = 0 / 0 'Exit Function
  If Not is_mis_Xs Then
    If UBound(known_Xs.Value, 1) <> UBound(known_Ys.Value, 1) Then LaGrange = 0 / 0 'Exit Function
    If UBound(known_Xs.Value, 2) > 1 Then LaGrange = 0 / 0 'Exit Function
  End If
  
  ReDim X(1 To N), Y(1 To N)
  
  For i = 1 To N
    Y(i) = known_Ys.Item(i)
    If is_mis_Xs Then X(i) = i Else X(i) = known_Xs.Item(i)    'als geen X dan 1,2,3,...
   Next i
  
  If IsMissing(sorted) Or VarType(sorted) <> vbBoolean Then
      isSorted = False
    Else
      isSorted = CBool(sorted)
  End If
  
  If Not isSorted Then Call sort(X(), Y(), N)
  
  If (N = 2) Or (punt < X(1)) Then                  'als maar 2 datapunten of punt < kleinste datapunt
       LaGrange = h_1(punt, Y(1), Y(2), X(1), X(2)) 'lineaire in/extrapolatie
      ElseIf (punt > X(N)) Then                     'als punt > grootste datapunt
            LaGrange = h_1(punt, Y(N - 1), Y(N), X(N - 1), X(N)) 'lineaire extrapolatie
         ElseIf punt < X(2) Then                    'als punt < een-na-kleintste
               LaGrange = (h_1(punt, Y(1), Y(2), X(1), X(2)) + _
                           h_2(punt, Y(1), Y(2), Y(3), X(1), X(2), X(3))) / 2
            ElseIf punt >= X(N - 1) Then            'als punt > een-na-grootste
                  LaGrange = (h_1(punt, Y(N - 1), Y(N), X(N - 1), X(N)) + _
                              h_2(punt, Y(N - 2), Y(N - 1), Y(N), X(N - 2), X(N - 1), X(N))) / 2
                Else
                  i = 3
                  While punt >= X(i)                'zoek plaats van punt in de data-array
                   i = i + 1
                  Wend
                  LaGrange = (X(i) - punt) / (X(i) - X(i - 1)) * _
                              h_2(punt, Y(i - 2), Y(i - 1), Y(i), X(i - 2), X(i - 1), X(i)) + _
                               (punt - X(i - 1)) / (X(i) - X(i - 1)) * _
                                 h_2(punt, Y(i - 1), Y(i), Y(i + 1), X(i - 1), X(i), X(i + 1))
    End If
End Function   ' {van LaGrange}