Suche nach einem funktionalen Minimierer für die Verwendung in VBA

Question

Hallo, ich bin neu im VBA-Code und arbeite an einer nichtlinearen Kurvenanpassung innerhalb einer UDF in Excel. Ich bin mit Matlab vertraut, woher ich die meiste Erfahrung habe. Ich bin auf der Suche nach einer Sub/Funktion, die mir eine ähnliche Funktionalität wie fminsearch() aus Matlab bietet. Für jede Hilfe wäre ich dankbar. Vielen Dank

Edit(2) als Antwort auf Brad

Angenommen, ich möchte meine eigene UDF schreiben, die eine Minimierung verwendet, um die Kubikwurzel einer Zahl iterativ zu finden. Könnte ich die folgende Funktion schreiben?

Function myCubRootSResd(root As Double, rootCubed As Double) As Double 
Dim a As Double 
a = (root * root * root - rootCubed)
myCubRootSResd = a * a
End Function 

Dann könnte dies in Verbindung mit Solver verwendet werden, um die Kubikwurzel einer beliebigen Zahl zu finden, indem man die Ausgabe dieser Funktion auf Null setzt, indem man die Eingabe "Wurzel" ändert. Dies ist jedoch nur ein Schritt, den ich in der UDF, die ich zu schreiben versuche, durchführen muss, und diese Ausgabe (in diesem Fall die Kubikwurzel) muss ich innerhalb meiner UDF verwenden, die letztendlich die endgültige Ausgabe berechnet. Dann möchte ich die relative Referenzierung verwenden, um meine Gesamt-UDF für die Berechnung über einen Bereich von Eingaben zu verwenden. Ich glaube, dies würde erfordern, die Minimierung innerhalb von VBA und nicht Referenzzellen zu tun. Die kapselnde Funktion würde in diesem Fall den Wert von "Root" verarbeiten und nur diesen zurückgeben. Sie hätte nur eine Eingabe, nämlich "rootCubed", und würde diese einfach an myCubeRootSResd weitergeben. Es würde also in etwa so aussehen:

Function myCubeRootFinder(rootCubed as Double) as Double

……. 

End Function

Jede Hilfe wäre sehr geschätzt Ich habe versucht, eine einfache Lösung für diese für eine Weile jetzt zu finden, und ich habe einfach nicht ein Beispiel von jemandem tun diese Art der numerischen Minimierung in VBA gefunden.

Mir ist klar, dass dies vielleicht nicht der richtige Weg ist, um dies in VBA zu tun, aber die Funktionalität muss erhalten bleiben. Ich danke Ihnen für Ihre Geduld mit mir.

Answer 1

OK, ich hatte etwas Spaß.

Erstellen Sie eine Klasse namens FuncEval:

Option Explicit

Dim output_ As Double
Dim input_() As Double

Public Property Get VectArr() As Double()
    VectArr = input_
End Property

Public Function Vect(i As Integer)
    Vect = input_(i)
End Function

Public Sub SetVect(ByRef newVect() As Double)
    Dim i As Integer
    ReDim input_(LBound(newVect) To UBound(newVect)) As Double
    For i = LBound(newVect) To UBound(newVect)
        input_(i) = newVect(i)
    Next i
End Sub

Public Property Get Result() As Double
    Result = output_
End Property

Public Property Let Result(newRes As Double)
    output_ = newRes
End Property

Und eine Klasse namens Func:

Option Explicit

Private cube_ As Double

Public Property Let Cube(newCube As Double)
    cube_ = newCube
End Property

Public Function Eval(ByRef val() As Double) As FuncEval
    Dim ret As New FuncEval
    ret.Result = Abs(cube_ - val(0) * val(0) * val(0))
    ret.SetVect val
    Set Eval = ret
End Function

Fügen Sie diesen Code nun in ein Standardmodul ein:

Option Explicit

Function NelderMead(f As Func, _
                    ByRef guess() As Double) As Double()

    'Algorithm follows that outlined here:
    'http://www.mathworks.com/help/techdoc/math/bsotu2d.html#bsgpq6p-11

    'Used as the perturbation for the initial guess when guess(i) == 0
    Dim zeroPert As Double
    zeroPert = 0.00025
    'The factor each element of guess(i) is multiplied by to obtain the
    'initial simplex
    Dim pertFact As Double
    pertFact = 1.05
    'Tolerance
    Dim eps As Double
    eps = 0.000000000001

    Dim shrink As Boolean
    Dim i As Integer, j As Integer, n As Integer
    Dim simplex() As Variant
    Dim origVal As Double, lowest As Double
    Dim m() As Double, r() As Double, s() As Double, c() As Double, cc() As Double, diff() As Double
    Dim FE As FuncEval, FR As FuncEval, FS As FuncEval, FC As FuncEval, FCC As FuncEval, newFE As FuncEval

    n = UBound(guess) - LBound(guess) + 1
    ReDim m(LBound(guess) To UBound(guess)) As Double
    ReDim r(LBound(guess) To UBound(guess)) As Double
    ReDim s(LBound(guess) To UBound(guess)) As Double
    ReDim c(LBound(guess) To UBound(guess)) As Double
    ReDim cc(LBound(guess) To UBound(guess)) As Double
    ReDim diff(LBound(guess) To UBound(guess)) As Double
    ReDim simplex(LBound(guess) To UBound(guess) + 1) As Variant

    Set simplex(LBound(simplex)) = f.Eval(guess)

    'Generate the simplex
    For i = LBound(guess) To UBound(guess)
        origVal = guess(i)
        If origVal = 0 Then
            guess(i) = zeroPert
        Else
            guess(i) = pertFact * origVal
        End If
        Set simplex(LBound(simplex) + i - LBound(guess) + 1) = f.Eval(guess)
        guess(i) = origVal
    Next i

    'Sort the simplex by f(x)
    For i = LBound(simplex) To UBound(simplex) - 1
        For j = i + 1 To UBound(simplex)
            If simplex(i).Result > simplex(j).Result Then
                Set FE = simplex(i)
                Set simplex(i) = simplex(j)
                Set simplex(j) = FE
            End If
        Next j
    Next i

    Do

        Set newFE = Nothing
        shrink = False
        lowest = simplex(LBound(simplex)).Result

        'Calculate m
        For i = LBound(m) To UBound(m)
            m(i) = 0
            For j = LBound(simplex) To UBound(simplex) - 1
                m(i) = m(i) + simplex(j).Vect(i)
            Next j
            m(i) = m(i) / n
        Next i

        'Calculate the reflected point
        For i = LBound(r) To UBound(r)
            r(i) = 2 * m(i) - simplex(UBound(simplex)).Vect(i)
        Next i
        Set FR = f.Eval(r)

        'Check acceptance conditions
        If (simplex(LBound(simplex)).Result <= FR.Result) And (FR.Result < simplex(UBound(simplex) - 1).Result) Then
            'Accept r, replace the worst value and iterate
            Set newFE = FR
        ElseIf FR.Result < simplex(LBound(simplex)).Result Then
            'Calculate the expansion point, s
            For i = LBound(s) To UBound(s)
                s(i) = m(i) + 2 * (m(i) - simplex(UBound(simplex)).Vect(i))
            Next i
            Set FS = f.Eval(s)
            If FS.Result < FR.Result Then
                Set newFE = FS
            Else
                Set newFE = FR
            End If
        ElseIf FR.Result >= simplex(UBound(simplex) - 1).Result Then
            'Perform a contraction between m and the better of x(n+1) and r
            If FR.Result < simplex(UBound(simplex)).Result Then
                'Contract outside
                For i = LBound(c) To UBound(c)
                    c(i) = m(i) + (r(i) - m(i)) / 2
                Next i
                Set FC = f.Eval(c)
                If FC.Result < FR.Result Then
                    Set newFE = FC
                Else
                    shrink = True
                End If
            Else
                'Contract inside
                For i = LBound(cc) To UBound(cc)
                    cc(i) = m(i) + (simplex(UBound(simplex)).Vect(i) - m(i)) / 2
                Next i
                Set FCC = f.Eval(cc)
                If FCC.Result < simplex(UBound(simplex)).Result Then
                    Set newFE = FCC
                Else
                    shrink = True
                End If
            End If
        End If

        'Shrink if required
        If shrink Then
            For i = LBound(simplex) + 1 To UBound(simplex)
                For j = LBound(simplex(i).VectArr) To UBound(simplex(i).VectArr)
                    diff(j) = simplex(LBound(simplex)).Vect(j) + (simplex(i).Vect(j) - simplex(LBound(simplex)).Vect(j)) / 2
                Next j
                Set simplex(i) = f.Eval(diff)
            Next i
        End If

        'Insert the new element in place
        If Not newFE Is Nothing Then
            For i = LBound(simplex) To UBound(simplex)
                If simplex(i).Result > newFE.Result Then
                    For j = UBound(simplex) To i + 1 Step -1
                        Set simplex(j) = simplex(j - 1)
                    Next j
                    Set simplex(i) = newFE
                    Exit For
                End If
            Next i
        End If

    Loop Until (simplex(UBound(simplex)).Result - simplex(LBound(simplex)).Result) < eps

    NelderMead = simplex(LBound(simplex)).VectArr

End Function

Function test(cube, guess) As Double

    Dim f As New Func
    Dim guessVec(0 To 0) As Double
    Dim Result() As Double
    Dim i As Integer
    Dim output As String

    f.cube = cube
    guessVec(0) = guess

    Result = NelderMead(f, guessVec)

    test = Result(0)

End Function

Die Klasse Func enthält Ihre Restfunktion. Die NelderMead-Methode erfordert nur die Result-Methode der Func-Klasse. Sie können also mit der Func-Klasse machen, was Sie wollen, solange die Eval-Methode einen Vektor der gleichen Länge wie Ihre anfängliche Schätzung behandelt und ein FuncEval-Objekt zurückgibt.

Rufen Sie die Testfunktion auf, um sie in Aktion zu sehen. Hinweis: Ich habe noch nicht mit mehrdimensionalen Vektoren getestet, ich muss noch raus.

Edit: Vorschlag zur Verallgemeinerung der Funktionsübergabe

Sie müssen eine Reihe verschiedener Klassen für unterschiedliche Probleme erstellen. Um die Funktion NelderMead allgemein zu halten, müssen Sie ihre Deklarationszeile wie folgt ändern:

Function NelderMead(f As Object, _
                    ByRef guess() As Double) As Double()

Was auch immer f ist, es muss immer eine Eval-Methode haben, die ein Array von Doubles annimmt.

Bearbeiten: Funktionsübergabe, wahrscheinlich die (dumme) Art, wie es in VBA gemacht werden soll

Function f(x() As Double) As Double
    f = x(0) * x(0)
End Function

Sub Test()
    Dim x(0 To 0) As Double
    x(0) = 5
    Debug.Print Application.Run("f", x)
End Sub

Mit dieser Methode würden Sie die folgende Erklärung erhalten:

Function NelderMead(f As String, _
                    ByRef guess() As Double) As Double()

Rufen Sie dann f mit der obigen Application.Run-Syntax auf. Sie müssen auch innerhalb der Funktion ein paar Änderungen vornehmen. Es ist nicht schön, aber ehrlich gesagt war es anfangs auch nicht so schön.

Answer 2

Sie können das Solver-Add-In, das in Excel enthalten ist, zur Lösung eines Minimierungsproblems verwenden.