Option Explicit
'-----------------------------------------------------------------------------------------------
'This is the public function that is called by the .asp page. It initializes the RDK,
'sets up the model, runs a simulation, and generates results that can be included in an HTML
'page. All the parameters of this function must be declared as variants, due to the requirements
'of the VBScript code which calls this routine.
'
'-- PARAMETERS ----------------------------------------------------------------------------------
'1. outputDir - The destination directory in which all results will be written.
'2. showProgressGraph - a boolean value, which determines if a progress graph is displayed.
'3. policyDuration - the duration (in weeks) of the policy
'4. replacementCost - how much it costs to replace a machine
'5. profitArray - an array of 4 values indicating how much profit is generated by different machine types
'6. probMatrix - an array of 4x4 values which control the flow of machine from one state to another.
'
'-- RETURN VALUE -------------------------------------------------------------------------------
'A String. Blank on success, or a descriptive error message on failure.
'-----------------------------------------------------------------------------------------------
'
Public Function Simulate(outputDir, showProgressGraph, policyDuration, replacementCost, profitArray, probMatrix)
Dim appEvents As New RDKEvents
Dim errMsg$
'Initialize the RDK library, and the RDKEvents object:
On Error Resume Next
RDKApp.Init False
If Err <> 0 Then errMsg = Err.Description: GoTo fail
On Error GoTo 0
With appEvents
.Attach RDKApp
.InitializeProgressGraph CBool(showProgressGraph), CStr(outputDir)
End With
errMsg = SetupModel(policyDuration, replacementCost, profitArray, probMatrix, appEvents): If errMsg <> "" Then GoTo fail
errMsg = RunSimulation(): If errMsg <> "" Then GoTo fail
errMsg = GenerateResults(CStr(outputDir)): If errMsg <> "" Then GoTo fail
fail:
'detach the event class module and release the RDK library
On Error Resume Next
appEvents.Detach
RDKApp.Free
On Error GoTo 0
'If there was an error, return the error to the caller:
If errMsg <> "" Then Simulate = errMsg
End Function
'Setup the RDK Model.
'This routine defines an RDKOutput for each policy, and validates and stores the model parameters in the RDKEvents module.
'The return code of this function is a string, which is blank on success or an error description on failure.
Private Function SetupModel(policyDuration, replacementCost, profitArray, probMatrix, appEvents As RDKEvents) As String
Dim errMsg$
Dim oneArrayElement
Dim p#
Dim i%
Dim j%
'Check if the parameters passed in are valid
'If not, return an error description of the problem:
If Not IsNumeric(policyDuration) Then errMsg = "Invalid policy duration": GoTo fail
If CDbl(policyDuration) < 2 Or CDbl(policyDuration) > 1000 Then errMsg = "Choose a policy duration between 2 and 1000 weeks": GoTo fail
If Not IsNumeric(replacementCost) Then errMsg = "Invalid replacement cost": GoTo fail
If Not IsArray(profitArray) Then errMsg = "Invalid profit array": GoTo fail
If UBound(profitArray) - LBound(profitArray) + 1 <> NUM_MACHINE_TYPES Then errMsg = "Incorrect number of elements in profit array": GoTo fail
For Each oneArrayElement In profitArray
If Not IsNumeric(oneArrayElement) Then errMsg = "Invalid profit array value": GoTo fail
Next
If Not IsArray(probMatrix) Then errMsg = "Invalid probability array": GoTo fail
On Error Resume Next
If UBound(probMatrix, 1) - LBound(probMatrix, 1) + 1 <> NUM_MACHINE_TYPES Then errMsg = "Incorrect number of elements in probability matrix": GoTo fail
If UBound(probMatrix, 2) - LBound(probMatrix, 2) + 1 <> NUM_MACHINE_TYPES Then errMsg = "Incorrect number of elements in probability matrix": GoTo fail
If Err <> 0 Then errMsg = "Improperly dimensioned probability array": GoTo fail
On Error GoTo 0
For i = LBound(probMatrix, 1) To UBound(probMatrix, 1)
For j = LBound(probMatrix, 2) To UBound(probMatrix, 2)
oneArrayElement = probMatrix(i, j)
If Not IsNumeric(oneArrayElement) Then errMsg = "Invalid probability array value": GoTo fail
p = CDbl(oneArrayElement)
If p < 0 Or p > 1 Then errMsg = "Probability array values must be between 0 and 1": GoTo fail
Next j
Next i
'Define the outputs of the model. There is one output for each replacement policy
'This model does not contain any explicitly defined inputs:
With RDKApp
.ClearModel
For i = 1 To NUM_POLICIES
.Outputs.Add "Policy " & i
Next i
End With
'Finally, pass in the model parameters to the RDKEvent module, so it can use them during the simulation:
appEvents.InitializeModelParameters policyDuration, replacementCost, profitArray, probMatrix
fail:
SetupModel = errMsg
End Function
'Run the simulation.
'The return code of this function is a string, which is blank on success or an error description on failure:
Private Function RunSimulation() As String
Dim errMsg$
With RDKApp
'For web applications, you should turn off the progress bar (which is on by default):
.simSettings.DisplayProgressBar = False
'Tell the RDK to run a 500 iteration simulatation, and return any error message to the caller:
'The .Simulate call will pass control to the RDKX library, which will then call the Iteration
'event (in the RDKEvents module) 500 times, once for each iteration. Only when the simulation
'has completed, will the call to .Simulate return:
.simSettings.numIterations = 500
On Error Resume Next
.Simulate
If Err <> 0 Then errMsg = Err.Description: GoTo fail
On Error GoTo 0
End With
fail:
RunSimulation = errMsg
End Function
'Generate the simulation results:
'For this model, two files are generated in the output directory:
'1. .\GRAPH.JPG : A cumulative graph comparing all four policies' simulation results
'2. .\STATISTICS.JPG : A table of results for each policy formatted in HTML.
'These files are included in the result web page for the model:
'The return code of this function is a string, which is blank on success, or an error description on failure:
Private Function GenerateResults(outputDir$) As String
Dim errMsg$
Dim results(1 To NUM_POLICIES) As RDKResult
Dim statistics(1 To NUM_POLICIES) As RDKStatistics
Dim whichStatistic%
Dim statName$
Dim statValue#
Dim fileNum%
Dim i%
'For convenience, set up an array of the result and statistic objects:
For i = 1 To NUM_POLICIES
Set results(i) = RDKApp.Outputs(i).results
statistics(i) = results(i).statistics
Next i
'Make a comparison cumulative graph of the output results for each policy:
With RDKApp.GraphDefaults
.RevertToDefaultSettings
.Destination = RDKJPGFile
.DestinationFile = outputDir & "\graph.jpg"
.PictureHeight = 5000
.PictureWidth = 6000
.MainTitle = "Average Weekly Revenue"
.XAxis.Title = "Dollars"
.YAxis.Title = "Cumulative Probability"
.DisplayMean = True
End With
On Error Resume Next
results(1).Graph RDKResultCurveTypeCumulativeAscending, results(2), results(3), results(4)
If Err <> 0 Then errMsg = Err.Description: GoTo fail
On Error GoTo 0
'Generate the statistics file:
On Error Resume Next
Kill outputDir & "\statistics.html"
Err = 0
fileNum = FreeFile()
Open outputDir & "\statistics.html" For Binary As fileNum
If Err <> 0 Then errMsg = "Error writing statistics file": fileNum = 0: GoTo fail
On Error GoTo 0
'start with a "<TABLE>" tag, and write the table column headers:
Put fileNum, , "<TABLE><tr><td></td>"
For i = 1 To NUM_POLICIES
Put fileNum, , "<td WIDTH=60><Strong><SPAN class=subheader_black>Policy " & i & "</SPAN></Strong></td>"
Next i
Put fileNum, , "</tr>"
'Write the nine statistics that we are displaying:
For whichStatistic = 1 To 9
Select Case whichStatistic
Case 1: statName = "Minimum"
Case 2: statName = "Maximum"
Case 3: statName = "Mean"
Case 4: statName = "Std Dev"
Case 5: statName = "Skewness"
Case 6: statName = "Kurtosis"
Case 7: statName = "Mode"
Case 8: statName = "5%"
Case 9: statName = "95%"
End Select
Put fileNum, , "<tr><td><Strong><SPAN class=subheader_black>" & statName & "</SPAN></Strong></td>"
For i = 1 To NUM_POLICIES
Select Case whichStatistic
Case 1: statValue = statistics(i).Minimum
Case 2: statValue = statistics(i).Maximum
Case 3: statValue = statistics(i).mean
Case 4: statValue = statistics(i).StdDeviation
Case 5: statValue = statistics(i).Skewness
Case 6: statValue = statistics(i).Kurtosis
Case 7: statValue = statistics(i).mode
Case 8: statValue = statistics(i).percentiles(1)
Case 9: statValue = statistics(i).percentiles(19)
End Select
Put fileNum, , CStr("<td>" & Format(statValue, "0.0000") & "</td>")
Next i
Put fileNum, , "</tr>"
Next whichStatistic
'End the table:
Put fileNum, , "</TABLE>"
fail:
If fileNum <> 0 Then Close fileNum
If errMsg <> "" Then GenerateResults = errMsg
End Function
VB Source Code
Publisher R2© Palisade Corporation, eDecisionTools.com, 2001