IBM® SPSS® Amos™ 28

The following program fits the model of Example 8 and displays derivatives evaluated at the discrepancy function minimum. For purposes of comparison, approximate derivatives based on finite differences are also displayed.

Imports AmosEngineLib
Module MainModule
    Dim Sem As New AmosEngine
    Dim ad As New AmosDebug.AmosDebug
 
    Sub Main()
        Dim Originalparameters() As Double
 
        Sem.BeginGroup(AmosEngine.AmosDir & "Examples\English\UserGuide.xls", "Grnt_fem")
        Sem.AStructure("visperc = (1) spatial + (1) err_v")
        Sem.AStructure("cubes = (a) spatial + (1) err_c")
        Sem.AStructure("lozenges = (b) spatial + (1) err_l")
        Sem.AStructure("paragraph = (1) verbal + (1) err_p")
        Sem.AStructure("sentence = (c) verbal + (1) err_s")
        Sem.AStructure("wordmean = (d) verbal + (1) err_w")
 
        If (Sem.FitModel() = 0) Then
            'Save parameter values so they can be restored
            Sem.ParameterVector(Originalparameters)
            TestDerivatives()
            'Restore the parameter values and display them
            Sem.PutParameterVector(Originalparameters)
            ad.PrintX(Originalparameters, "Parameter values")
        End If
        Sem.Dispose()
    End Sub
 
    Sub TestDerivatives()
        Dim Ind As Integer, F As Double
        Dim G() As Double, GNumeric() As Double
        Dim H() As Double, HNumeric() As Double
        Sem.Evaluate2e(Ind, F, G, H)
        If Ind <> 0 Then
            Throw(New System.exception("Could not evaluate function and derivatives."))
        End If
        NumericDerivatives(Sem, GNumeric, HNumeric)
        ad.DecimalPlaces = 8
        ad.PrintX(G, "1st Derivatives")
        ad.PrintX(GNumeric, "Numerical 1st Derivatives")
        ad.PrintTriangle(H, "2nd Derivatives")
        ad.PrintTriangle(HNumeric, "Numerical 2nd Derivatives")
    End Sub
 
    Sub NumericDerivatives(ByVal Sem As AmosEngine, ByRef GNumeric() As Double, ByRef HNumeric() As Double)
        Const Delta As Double = 0.0001
        Dim NParams As Integer
        Dim FPlus As Double, FMinus As Double
        Dim FPP As Double, FMM As Double
        Dim FPM As Double, FMP As Double
        Dim i As Integer, j As Integer, k As Integer
        Dim DTempi As Double, DTempj As Double
        NParams = Sem.NumberOfParameters
        ReDim GNumeric(NParams - 1)
        ReDim HNumeric(NParams * (NParams + 1) \ 2 - 1)
 
        '1st Derivatives
        For i = 1 To NParams
            DTempi = Sem.ParameterValue(i)
            Sem.PutParameterValue(i, DTempi + Delta)
            FPlus = Evaluate()
            Sem.PutParameterValue(i, DTempi - Delta)
            FMinus = Evaluate()
            Sem.PutParameterValue(i, DTempi)
            GNumeric(i - 1) = (FPlus - FMinus) / (2 * Delta)
        Next
 
        '2nd Derivatives
        k = 0
        For i = 1 To NParams
            For j = 1 To i
                DTempi = Sem.ParameterValue(i)
                DTempj = Sem.ParameterValue(j)
                If i = j Then
                    FPM = Evaluate()
                    FMP = FPM
                    Sem.PutParameterValue(i, DTempi + 2 * Delta)
                    FPP = Evaluate()
                    Sem.PutParameterValue(i, DTempi - 2 * Delta)
                    FMM = Evaluate()
                Else
                    Sem.PutParameterValue(i, DTempi + Delta)
                    Sem.PutParameterValue(j, DTempj + Delta)
                    FPP = Evaluate()
                    Sem.PutParameterValue(j, DTempj - Delta)
                    FPM = Evaluate()
                    Sem.PutParameterValue(i, DTempi - Delta)
                    FMM = Evaluate()
                    Sem.PutParameterValue(j, DTempj + Delta)
                    FMP = Evaluate()
                End If
                Sem.PutParameterValue(i, DTempi)
                Sem.PutParameterValue(j, DTempj)
 
                HNumeric(k) = (FPP + FMM - FPM - FMP) / (4 * Delta ^ 2)
                k = k + 1
            Next
        Next
    End Sub
 
    Function Evaluate() As Double
        Dim Ind As Integer
        Dim F As Double
        Sem.Evaluate0(Ind, F)
        If Ind <> 0 Then
            Throw(New System.Exception("Could not evaluate function."))
        End If
        Evaluate = F
    End Function
End Module