classbackprop.cls

采用vb编写的利用循环神经网络来预测股票走势的源程序

    grid.col = i
    grid.Text = OutputDimensionName(i - 1)
  Next
  'Call grid.AddItem("")
  
End Sub


Public Sub setOutputsToFile(FileNumber As Integer)
'sets the values within a data grid to the outputs of the network
  Dim i As Integer
  Dim v As Single
  
  For i = 0 To NoOfOutputs - 1
    v = CLng(getRealOutput(i) * 1000) / 1000
    Print #FileNumber, v;
    Print #FileNumber, " ";
  Next
  Print #FileNumber, " "
End Sub


Public Sub ShowGrid(steps As Integer, grid As MSFlexGrid)
  Dim i As Integer
  
  Call initGrid(grid)
  i = 0
  While (i < steps)
    Call setOutputsToGrid(grid, i + 1)
    Call feedForward
    Call setInputsAsOutputs
    Call storeOutputs
    If (i < steps - 1) Then
      Call grid.AddItem("")
    End If
    i = i + 1
  Wend
  
End Sub



Public Sub loadTrainingInstance(instance As Object)
'loads a training instance
  On Error GoTo loadTrainingInstance_err
  
  Dim i As Integer

  For i = 0 To instance.NoOfInputs - 1
    inputs(i).value = instance.getInput(i)
  Next

  For i = 0 To instance.NoOfOutputs - 1
    outputs(i).desiredValue = instance.getOutput(i)
  Next

loadTrainingInstance_exit:
  Exit Sub
loadTrainingInstance_err:
  MsgBox "classBackprop/loadTrainingInstance/" & Error$(Err)
  Resume loadTrainingInstance_exit
End Sub


Public Sub setImage(img As Object)
'loads in image into the inputs array
  On Error GoTo setImage_err
  
  Dim x As Integer
  Dim y As Integer
  Dim i As Integer
  
  i = 0
  For x = 0 To img.width - 1
    For y = 0 To img.height - 1
      inputs(i).value = img.getPoint(x, y) / 255
      i = i + 1
    Next
  Next

setImage_exit:
  Exit Sub
setImage_err:
  MsgBox "classBackprop/setImage/" & Error$(Err)
  Resume setImage_exit
End Sub


Public Sub Save(Filename As String)
  On Error GoTo save_err
  
  Dim i As Integer
  Dim FileNumber As Integer

  FileNumber = FreeFile
  Open Filename For Output As #FileNumber
    Print #FileNumber, "[Error Backpropogation Neural Network]"
    Print #FileNumber, Name
    Print #FileNumber, NoOfInputs
    Print #FileNumber, NoOfHiddens
    Print #FileNumber, noofStates
    Print #FileNumber, NoOfOutputs
    Print #FileNumber, BPerrorTotal
    Print #FileNumber, BPerror
    Print #FileNumber, learningRate
    Print #FileNumber, randomness
    Print #FileNumber, TrainingItterations
    Print #FileNumber, TrainingDataFilename
    Print #FileNumber, TestDataFilename
    Print #FileNumber, outputFilename
  
    For i = 0 To NoOfInputs - 1
      Call inputs(i).Save(FileNumber)
    Next
    For i = 0 To NoOfHiddens - 1
      Call hiddens(i).Save(FileNumber)
    Next
    For i = 0 To noofStates - 1
      Call states(i).Save(FileNumber)
    Next
    For i = 0 To NoOfOutputs - 1
      Call outputs(i).Save(FileNumber)
    Next
  
    For i = 0 To NoOfInputs - 1
      Print #FileNumber, InputDimensionName(i)
    Next
    For i = 0 To NoOfOutputs - 1
      Print #FileNumber, OutputDimensionName(i)
    Next
    
  Close #FileNumber
  
save_exit:
  Exit Sub
save_err:
  MsgBox "classBackprop/save/" & Error$(Err)
  Resume save_exit
End Sub


Public Function Load(Filename As String) As Boolean
  On Error GoTo Load_err
  
  Dim i As Integer
  Dim dummy As String
  Dim FileNumber As Integer
  Dim dimStr As String

  Load = False
  
  FileNumber = FreeFile
  Open Filename For Input As #FileNumber
    Input #FileNumber, dummy
    Input #FileNumber, Name
    Input #FileNumber, NoOfInputs
    Input #FileNumber, NoOfHiddens
    Input #FileNumber, noofStates
    Input #FileNumber, NoOfOutputs
    Input #FileNumber, BPerrorTotal
    Input #FileNumber, BPerror
    Input #FileNumber, learningRate
    Input #FileNumber, randomness
    Input #FileNumber, TrainingItterations
    Input #FileNumber, TrainingDataFilename
    Input #FileNumber, TestDataFilename
    Input #FileNumber, outputFilename
  
    Call init(NoOfInputs, NoOfHiddens, NoOfOutputs, noofStates)
  
    For i = 0 To NoOfInputs - 1
      Call inputs(i).Load(FileNumber)
    Next
    For i = 0 To NoOfHiddens - 1
      Call hiddens(i).Load(FileNumber)
    Next
    For i = 0 To noofStates - 1
      Call states(i).Load(FileNumber)
    Next
    For i = 0 To NoOfOutputs - 1
      Call outputs(i).Load(FileNumber)
    Next
    
    For i = 0 To NoOfInputs - 1
      Input #FileNumber, dimStr
      InputDimensionName(i) = dimStr
    Next
    For i = 0 To NoOfOutputs - 1
      Input #FileNumber, dimStr
      OutputDimensionName(i) = dimStr
    Next

  Close #FileNumber
  Load = True
  
Load_exit:
  Exit Function
Load_err:
  If (Err = 53) Then
    Resume Load_exit
  End If

  MsgBox "classBackprop/load/" & Err & "/" & Error$(Err)
  Resume Load_exit
End Function


Public Function getClassification() As Integer
'returns the output with the highest activation
  On Error GoTo getClassification_err
  
  Dim max As Single
  Dim i As Integer
  Dim value As Single
  
  max = -1
  For i = 0 To NoOfOutputs - 1
    value = outputs(i).value
    If (value > max) Then
      max = value
      getClassification = i
    End If
  Next
  
getClassification_exit:
  Exit Function
getClassification_err:
  MsgBox "classBackprop/getClassification/" & Error$(Err)
  Resume getClassification_exit
End Function


Public Function setClassification(classification As Integer) As Integer
'sets the unique classification
  On Error GoTo setClassification_err
  
  Dim i As Integer
  
  For i = 0 To NoOfOutputs - 1
    If (i <> classification) Then
      outputs(i).desiredValue = 0.1
      Else
      outputs(i).desiredValue = 0.9
    End If
  Next
  
setClassification_exit:
  Exit Function
setClassification_err:
  MsgBox "classBackprop/setClassification/" & Error$(Err)
  Resume setClassification_exit
End Function


Public Sub showWeights(canvas As Object, Layer As Integer)
  On Error GoTo showWeights_err
  
  Dim x As Integer
  Dim y As Integer
  Dim screenX(2) As Single
  Dim screenY(2) As Single
  Dim value As Single
  Dim c As Long
  Dim i As Integer
  Dim width As Integer
  Dim height As Integer
  Dim pos As Single
  Dim neg As Single
  
  Select Case Layer
    Case 1 ' hidden
      width = NoOfInputs + noofStates
      height = NoOfHiddens
    Case 2 ' state
      width = NoOfHiddens
      height = noofStates
    Case 3 ' output
      width = NoOfHiddens
      height = NoOfOutputs
  End Select
  
  If (Layer <> 2) Then
  
  canvas.FillStyle = 0
  For x = 0 To width - 1
    For y = 0 To height - 1
      Select Case Layer
        Case 1 'hidden
          value = hiddens(y).getWeight(x)
        Case 2 'state
          value = states(y).getWeight(x)
        Case 3 'output
          value = outputs(y).getWeight(x)
      End Select
      If (value > 0) Then
        pos = value * 255
        neg = 0
        Else
        pos = 0
        neg = Abs(value * 255)
      End If
      c = RGB(neg, 0, pos)
      canvas.FillColor = c
      screenX(0) = (x / width) * canvas.ScaleWidth
      screenY(0) = (y / height) * canvas.ScaleHeight
      screenX(1) = ((x + 1) / width) * canvas.ScaleWidth
      screenY(1) = ((y + 1) / height) * canvas.ScaleHeight
      canvas.Line (screenX(0), screenY(0))-(screenX(1), screenY(1)), c, B
    Next
  Next

  End If

showWeights_exit:
  Exit Sub
showWeights_err:
  MsgBox "classBackprop/showWeights/" & Error$(Err)
  Resume 0
  Resume showWeights_exit
End Sub


Public Sub showNeurons(canvas As Object, Layer As Integer)
  On Error GoTo showNeurons_err
  
  Dim x As Integer
  Dim screenX(2) As Single
  Dim screenY(2) As Single
  Dim value As Single
  Dim c As Long
  Dim i As Integer
  Dim width As Integer
  Dim pos As Single
  Dim neg As Single
  
  Select Case Layer
    Case 0 ' input
      width = NoOfInputs
    Case 1 ' hidden
      width = NoOfHiddens
    Case 2 ' state
      width = noofStates
    Case 3 ' output
      width = NoOfOutputs
    Case 4 ' output desired value
      width = NoOfOutputs
  End Select
  
  canvas.FillStyle = 0
  For x = 0 To width - 1
      Select Case Layer
        Case 0 'input
          value = inputs(x).value
        Case 1 'hidden
          value = hiddens(x).value
        Case 2 'state
          value = states(x).value
        Case 3 'output
          value = outputs(x).value
        Case 4 'output
          value = outputs(x).desiredValue
      End Select
      If (value > 0) Then
        pos = value * 255
        neg = 0
        Else
        pos = 0
        neg = Abs(value * 255)
      End If
      c = RGB(neg, 0, pos)
      canvas.FillColor = c
      screenX(0) = (x / width) * canvas.ScaleWidth
      screenY(0) = 0 * canvas.ScaleHeight
      screenX(1) = ((x + 1) / width) * canvas.ScaleWidth
      screenY(1) = canvas.ScaleHeight
      canvas.Line (screenX(0), screenY(0))-(screenX(1), screenY(1)), c, B
  Next

showNeurons_exit:
  Exit Sub
showNeurons_err:
  MsgBox "classBackprop/showNeurons/" & Error$(Err)
  Resume showNeurons_exit
End Sub



Public Sub showChart(chart As Object, chartType As Integer)
'displays using MS chart control
  On Error GoTo showChart_err
  
  Dim NoOfUnits As Integer
  Dim i As Integer
  Dim j As Integer
  Dim n As ClassBackPropNeuron

  Select Case chartType
    Case 0  'input units
      chart.chartType = 5
      chart.RowCount = NoOfInputs
      chart.ColumnCount = 1
    Case 1 'hidden units
      chart.chartType = 5
      chart.RowCount = NoOfHiddens
      chart.ColumnCount = 1
    Case 2 'state units
      chart.chartType = 5
      chart.RowCount = noofStates
      chart.ColumnCount = 1
    Case 3 'output units
      chart.chartType = 5
      chart.RowCount = NoOfOutputs
      chart.ColumnCount = 1
    Case 4 'hidden weights
      chart.chartType = 4
      chart.RowCount = NoOfInputs
      chart.ColumnCount = NoOfHiddens
    Case 5 'state weights
      chart.chartType = 4
      chart.RowCount = noofStates
      chart.ColumnCount = NoOfHiddens
    Case 6 'output weights
      chart.chartType = 4
      chart.RowCount = NoOfOutputs
      chart.ColumnCount = NoOfHiddens
  End Select
  
  For i = 0 To chart.RowCount - 1
    chart.row = i + 1
    Select Case chartType
      Case 0
        chart.Data = inputs(i).value
      Case 1
        chart.Data = hiddens(i).value
      Case 2
        chart.Data = states(i).value
      Case 3
        chart.Data = outputs(i).value
      Case 4
        For j = 0 To chart.ColumnCount - 1
          chart.Column = j + 1
          chart.Data = hiddens(j).getWeight(i)
        Next
      Case 5
        For j = 0 To chart.ColumnCount - 1
          chart.Column = j + 1
          chart.Data = states(i).getWeight(j)
        Next
      Case 6
        For j = 0 To chart.ColumnCount - 1
          chart.Column = j + 1
          chart.Data = outputs(i).getWeight(j)
        Next
    End Select
  Next
  chart.Refresh
  
showChart_exit:
  Exit Sub
showChart_err:
  MsgBox "classBackprop/showChart/" & Error$(Err)
  Resume showChart_exit
End Sub


Public Sub ClearStateUnits()
  Dim i As Integer
  
  For i = 0 To noofStates - 1
    states(i).value = 0
    states(i).desiredValue = 0
  Next
  
End Sub



Public Sub update()
  On Error GoTo update_err
  
  Call feedForward
  Call Backprop
  Call learn
  
update_exit:
  Exit Sub
update_err:
  MsgBox "classBackprop/update/" & Error$(Err)
  Resume update_exit
End Sub



Public Sub setInputsAsOutputs()
  Dim i As Integer
  
  For i = 0 To NoOfOutputs - 1
    inputs(i).value = outputs(i).value
  Next
End Sub