Option Explicit
'-----------------------------------------------------------------------------------------------
'This is the public function that is called by the .asp page. It initializes the BDK,
'sets up an BDK input object, performs a fit, and generates results for display in the calling
'page.
'-----------------------------------------------------------------------------------------------
'PARAMETERS:
'
'All the parameters of this function must be declared as variants, due to the requirements of
'the VBScript code which calls this routine.
'1. outputDir - The destination directory in which all results will be written.
'2. data - an array of values to fit.
'-----------------------------------------------------------------------------------------------
'RETURN VALUE:
'
'A String. Blank on success, or a descriptive error message on failure.
'-----------------------------------------------------------------------------------------------
'
Public Function PerformFit(outputDir, Data) As String
Dim errMsg$
Dim inputObj As BDKInput
Dim fitObj As BDKResult
'Initialize the BDK library:
On Error Resume Next
BDKApp.Init
If Err <> 0 Then errMsg = Err.Description: GoTo fail
On Error GoTo 0
errMsg = CreateInputDataObject(Data, inputObj): If errMsg <> "" Then GoTo fail
errMsg = GetBestFit(inputObj, fitObj): If errMsg <> "" Then GoTo fail
errMsg = GenerateResults(outputDir, inputObj, fitObj): If errMsg <> "" Then GoTo fail
fail:
'If there was an error, return the error string, else return a blank string:
If errMsg <> "" Then PerformFit = errMsg
'Release the BDK library
On Error Resume Next
BDKApp.Free
On Error GoTo 0
End Function
'Setup the BDK Input Data Object
'This routine creates a BDKInput object for the data set passed in.
'The return code of this function is a string, which is blank on success or an error description on failure.
Private Function CreateInputDataObject(Data, inputObj As BDKInput) As String
Dim errMsg$
Dim minIndex%
Dim maxIndex%
Dim numDataPoints%
Dim oneValue
Dim dblData#()
Dim i%
'Determine the size of the data array passed in:
On Error Resume Next
minIndex = LBound(Data)
maxIndex = UBound(Data)
numDataPoints = maxIndex - minIndex + 1
If Err <> 0 Then errMsg = "Illegal data array": GoTo fail
On Error GoTo 0
'Validate the input data and fill in the array of doubles:
ReDim dblData(1 To numDataPoints)
For i = 1 To numDataPoints
oneValue = Data(LBound(Data) - 1 + i)
If Not IsNumeric(oneValue) Then errMsg = "Illegal data value : " & oneValue: GoTo fail
dblData(i) = CDbl(oneValue)
Next i
'Now define a new BDKInput object based on this data:
Set inputObj = New BDKInput
On Error Resume Next
inputObj.Define BDKDataTypeSamples, False, False, dblData()
If Err <> 0 Then errMsg = Err.Description: GoTo fail
On Error GoTo 0
fail:
CreateInputDataObject = errMsg
End Function
'Find the BestFit for the input data object:
'The return code of this function is a string, which is blank on success or an error description on failure:
Private Function GetBestFit(inputObj As BDKInput, fitObj As BDKResult) As String
Dim errMsg$
Dim resultArray() As BDKResult
Dim numFits%
'Fit the input data to all possible distribution,
'and rank the results based on the Chisq statistic:
On Error Resume Next
numFits = inputObj.FitAll(BDKChiSqStatistic, resultArray)
If numFits = 0 Or Err <> 0 Then errMsg = "Unable to fit data.": GoTo fail
On Error GoTo 0
'Return the best fitting distribution:
Set fitObj = resultArray(1)
fail:
If errMsg <> "" Then GetBestFit = errMsg
End Function
'Generate the fit results.
'For this model, two files are generated in the output directory:
'1. .\GRAPH.JPG : A graph comparing the input data histogram to the fitted density function
'1. .\FITRESULTS.HTML : information about the fitted curve and some comparison statistics
'The return code of this function is a string, which is blank on success or an error description on failure:
Private Function GenerateResults(outputDir, inputObj As BDKInput, fitObj As BDKResult) As String
Dim errMsg$
Dim distObj As BDKDistribution
Dim inputStats As BDKStatistics
Dim fitStats As BDKStatistics
Dim fileNum%
Dim i%
'Generate a fit comparison graph
With BDKApp.GraphDefaults
.PictureHeight = 5500
.PictureWidth = 7000
.Destination = BDKJPGFile
.DestinationFile = outputDir & "\graph.jpg"
End With
On Error Resume Next
inputObj.Graph BDKInputCurveTypeHistogram, fitObj
If Err <> 0 Then errMsg = Err.Description: GoTo fail
On Error GoTo 0
'Generate an output file with some formatted HTML that can be included in an .asp page:
On Error Resume Next
Kill outputDir & "\FitResults.html"
Err = 0
fileNum = FreeFile()
Open outputDir & "\FitResults.html" For Binary As fileNum
If Err <> 0 Then errMsg = "Error writing fit results file": fileNum = 0: GoTo fail
On Error GoTo 0
'Write out the distribution name and parameters
With fitObj.Distribution
Put fileNum, , "<P><strong>Distribution</strong> = " & .distName & "<P>"
For i = 1 To .ArgCount
Put fileNum, , "<strong>" & .argName(i) & "</strong> = " & CStr(Round(.Arg(i), 4)) & "<P>"
Next
If .ShiftFactor <> 0 Then
Put fileNum, , "<P><strong>Shift</strong> = " & CStr(Round(.ShiftFactor, 4)) & "</P>"
End If
End With
'Write out some statistics for both the fit and the input data in a table:
'start with a "<TABLE>" tag, and write the table column headers:
inputStats = inputObj.Statistics
fitStats = fitObj.Distribution.Statistics
Put fileNum, , "<P><TABLE><TR><TH align=left>Statistics</TH><TH align=left>Fit</TH><TH align=left>Data</TH></TR>"
Put fileNum, , HTMLTableRow("Mean", inputStats.mean, fitStats.mean)
Put fileNum, , HTMLTableRow("Std Dev", Sqr(inputStats.variance), Sqr(fitStats.variance))
Put fileNum, , HTMLTableRow("Skewness", inputStats.skewness, fitStats.skewness)
Put fileNum, , HTMLTableRow("Kurtosis", inputStats.kurtosis, fitStats.kurtosis)
Put fileNum, , HTMLTableRow("5%", inputStats.Percentiles(1), fitStats.Percentiles(1))
Put fileNum, , HTMLTableRow("95%", inputStats.Percentiles(19), fitStats.Percentiles(19))
Put fileNum, , "</TABLE>"
fail:
If fileNum <> 0 Then Close fileNum
If errMsg <> "" Then GenerateResults = errMsg
End Function
Private Function HTMLTableRow$(statName$, col1Value#, col2Value#)
HTMLTableRow = "<tr><td><Strong><SPAN class=subheader_black>" & statName & "</SPAN></Strong></td>" & _
"<td>" & Format(col1Value, "0.0000") & "</td>" & _
"<td>" & Format(col2Value, "0.0000") & "</td>" & _
"</tr>"
End Function
'This utility function returns a nicely formatted HTML formatted set of input data.
'This is simply so a calling web page can get some nice default data to display to
'the user.
Public Function GetRandomData(formattedData) As String
Dim errMsg$
Dim j As Integer
Dim i As Integer
Dim k As Integer
Dim Data(1 To 100) As Double
Dim distObj As New BDKDistribution
'Initialize the BDK library:
On Error Resume Next
BDKApp.Init
If Err <> 0 Then errMsg = Err.Description: GoTo fail
On Error GoTo 0
'Generate some random data based on a lognormal distribution:
distObj.RiskFunction = "Lognorm(100,20)"
distObj.GenerateData BDKDataTypeSamples, 100, 0, Data()
'Return some nicely formatted results:
For i = 1 To 10
formattedData = formattedData & "<TR>"
For j = 1 To 10
k = k + 1
formattedData = formattedData & "<TD><INPUT style=""WIDTH: 55px"" size=""3"" name=""" & k & """ type=""text"" Value=""" & Round(Data(k), 2) & """></TD>"
Next
formattedData = formattedData & "</TR>"
Next
fail:
On Error Resume Next
BDKApp.Free
On Error GoTo 0
If errMsg <> "" Then GetRandomData = errMsg
End Function
VB Source Code
Publisher R2© Palisade Corporation, eDecisionTools.com, 2001