classbackprop.cls

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

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ClassBackprop"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Public Name As String
Public NoOfInputs As Integer
Public NoOfHiddens As Integer
Public noofStates As Integer
Public NoOfOutputs As Integer
Public TrainingDataFilename As String
Public TestDataFilename As String
Public outputFilename As String

Dim inputs() As ClassBackPropNeuron
Dim hiddens() As ClassBackPropNeuron
Dim states() As ClassBackPropNeuron
Dim outputs() As ClassBackPropNeuron

'used for scaling the outputs into real values
Dim MinValue() As Single
Dim MaxValue() As Single

'the total backprop error
Public BPerrorTotal As Single

'the actual error
Public BPerror As Single

Public learningRate As Single
Public randomness As Single

Public TrainingItterations As Long

Dim initialised As Integer


Dim outputGraphPosition As Integer
Dim outputGraph() As Single

Dim InputDimensionName() As String
Dim OutputDimensionName() As String


Public Sub setInputDimensionName(inputIndex As Integer, InputName As String)
  InputDimensionName(inputIndex) = InputName
End Sub

Public Function getInputDimensionName(inputIndex As Integer) As String
  getInputDimensionName = InputDimensionName(inputIndex)
End Function

Public Sub setOutputDimensionName(OutputIndex As Integer, OutputName As String)
  OutputDimensionName(OutputIndex) = OutputName
End Sub

Public Function getOutputDimensionName(OutputIndex As Integer) As String
  getOutputDimensionName = OutputDimensionName(OutputIndex)
End Function


Public Sub storeOutputs()
'stores outputs to a graph
  Dim i As Integer
  
  If (outputGraphPosition < 30000) Then
    For i = 0 To NoOfOutputs - 1
      outputGraph(outputGraphPosition, i) = outputs(i).value
      outputGraph(outputGraphPosition, i + NoOfOutputs) = outputs(i).desiredValue
    Next
    outputGraphPosition = outputGraphPosition + 1
  End If
End Sub


Public Sub clearGraph()
  outputGraphPosition = 0
End Sub


Public Sub showOutputGraph(canvas As PictureBox, OutputIndex As Integer, Optional clearGraph As Variant)
  Dim screenX(2) As Single
  Dim screenY(2) As Single
  Dim prevScreenX(2) As Single
  Dim prevScreenY(2) As Single
  Dim i As Integer
  
  If (Not IsMissing(clearGraph)) Then
    If (clearGraph = True) Then
      canvas.Cls
    End If
  End If
  
  For i = 0 To outputGraphPosition - 1
    screenX(0) = (i / outputGraphPosition) * canvas.ScaleWidth
    screenY(0) = (1 - outputGraph(i, OutputIndex)) * canvas.ScaleHeight
    If (i > 0) Then
      canvas.Line (prevScreenX(0), prevScreenY(0))-(screenX(0), screenY(0)), RGB(0, 0, 255)
    End If
  
    screenY(1) = (1 - outputGraph(i, OutputIndex + NoOfOutputs)) * canvas.ScaleHeight
    If (i > 0) Then
      canvas.Line (prevScreenX(0), prevScreenY(1))-(screenX(0), screenY(1)), RGB(255, 0, 0)
    End If
    prevScreenX(0) = screenX(0)
    prevScreenY(0) = screenY(0)
    prevScreenY(1) = screenY(1)
  Next
End Sub


Public Sub init(No_Of_Inputs As Integer, no_of_hiddens As Integer, No_Of_Outputs As Integer, Optional RetainState As Variant)
  On Error GoTo init_err
  
  Dim i As Integer
  Dim j As Integer
  Dim n As ClassBackPropNeuron
  
  If (initialised = 1) Then
    Call FreeMem
  End If
  
  NoOfInputs = No_Of_Inputs
  ReDim inputs(NoOfInputs)
  ReDim InputDimensionName(NoOfInputs)
  
  NoOfHiddens = no_of_hiddens
  ReDim hiddens(NoOfHiddens)
  
  NoOfOutputs = No_Of_Outputs
  ReDim outputs(NoOfOutputs)
  ReDim outputGraph(30000, NoOfOutputs * 2)
  ReDim OutputDimensionName(NoOfOutputs)
  ReDim MinValue(NoOfOutputs)
  ReDim MaxValue(NoOfOutputs)
  
  If (Not IsMissing(RetainState)) Then
    noofStates = no_of_hiddens
    ReDim states(noofStates)
    Else
    noofStates = 0
  End If
  
  For i = 0 To NoOfInputs - 1
    Set inputs(i) = New ClassBackPropNeuron
    Call inputs(i).init(i, 0, 0)
  Next
    
  For i = 0 To NoOfHiddens - 1
    Set hiddens(i) = New ClassBackPropNeuron
    Call hiddens(i).init(i, 1, NoOfInputs + noofStates)
    For j = 0 To NoOfInputs - 1
      Call hiddens(i).addConnection(j, inputs(j))
    Next
  Next
      
  For i = 0 To noofStates - 1
    Set states(i) = New ClassBackPropNeuron
    Call states(i).init(i, 2, 0)  'NoOfHiddens)
    For j = 0 To NoOfHiddens - 1
      'Call states(i).addConnection(j, hiddens(j))
      Call hiddens(j).addConnection(NoOfInputs + i, states(i))
    Next
  Next
  
  For i = 0 To NoOfOutputs - 1
    Set outputs(i) = New ClassBackPropNeuron
    Call outputs(i).init(i, 3, NoOfHiddens)
    For j = 0 To NoOfHiddens - 1
      Call outputs(i).addConnection(j, hiddens(j))
    Next
  Next
  
  Call initWeights
  
  initialised = 1

init_exit:
  Exit Sub
init_err:
  If (Err = 91) Then
    Resume Next
  End If
  
  MsgBox "classBackprop/init/" & Error$(Err)
  Resume init_exit
End Sub


Public Sub FreeMem()
'deallocates memory

  Dim i As Integer

  For i = 0 To NoOfInputs - 1
    Call inputs(i).FreeMem
    Set inputs(i) = Nothing
  Next
    
  For i = 0 To NoOfHiddens - 1
    Call hiddens(i).FreeMem
    Set hiddens(i) = Nothing
  Next
      
  For i = 0 To noofStates - 1
    Call states(i).FreeMem
    Set states(i) = Nothing
  Next
  
  For i = 0 To NoOfOutputs - 1
    Call outputs(i).FreeMem
    Set outputs(i) = Nothing
  Next

End Sub


Public Sub initWeights(Optional minVal As Variant, Optional maxVal As Variant)
'randomly initialises the weights within the given range
  On Error GoTo initWeights_err
  
  Dim min As Single
  Dim max As Single
  Dim i As Integer
  Dim n As ClassBackPropNeuron
  
  Randomize
  
  min = -0.9
  max = 0.9
  randomness = 0.1
  
  If (Not IsMissing(minVal)) Then
    min = minVal
  End If
  
  If (Not IsMissing(maxVal)) Then
    max = maxVal
  End If
  
  For i = 0 To NoOfInputs - 1
    Set n = inputs(i)
    Call n.initWeights(min, max)
  Next
  
  For i = 0 To NoOfHiddens - 1
    Set n = hiddens(i)
    Call n.initWeights(min, max)
  Next
  
  For i = 0 To noofStates - 1
    Set n = states(i)
    Call n.initWeights(min, max)
  Next
  
  For i = 0 To NoOfOutputs - 1
    Set n = outputs(i)
    Call n.initWeights(min, max)
  Next

initWeights_err:
  Exit Sub
initWeights_exit:
  MsgBox "classBackprop/initWeights/" & Error$(Err)
  Resume initWeights_exit
End Sub


Public Sub feedForward()
  On Error GoTo feedForward_err
  
  Dim i As Integer
  Dim n As ClassBackPropNeuron

  For i = 0 To NoOfHiddens - 1
    Set n = hiddens(i)
    Call n.feedForward(randomness)
  Next

  For i = 0 To noofStates - 1
    Set n = states(i)
    'Call n.feedForward(randomness)
    n.value = (n.value * 0.9) + ((1 - hiddens(i).value) * 0.1)
  Next

  For i = 0 To NoOfOutputs - 1
    Set n = outputs(i)
    Call n.feedForward(randomness)
  Next

feedForward_exit:
  Exit Sub
feedForward_err:
  MsgBox "classBackprop/feedForward/" & Error$(Err)
  Resume feedForward_exit
End Sub


Public Sub Backprop()
  On Error GoTo backprop_err
  
  Dim i As Integer
  Dim n As ClassBackPropNeuron
  
  'clear all previous backprop errors
  For i = 0 To NoOfInputs - 1
    Set n = inputs(i)
    n.BPerror = 0
  Next
  
  For i = 0 To NoOfHiddens - 1
    Set n = hiddens(i)
    n.BPerror = 0
  Next
  
  For i = 0 To noofStates - 1
    Set n = states(i)
    n.BPerror = 0
  Next
  
  'now back-propogate the error from the output units
  BPerrorTotal = 0
  For i = 0 To NoOfOutputs - 1
    Set n = outputs(i)
    Call n.Backprop
    BPerrorTotal = BPerrorTotal + n.BPerror
  Next
  BPerror = BPerrorTotal / NoOfOutputs
  
  For i = 0 To NoOfHiddens - 1
    Set n = hiddens(i)
    Call n.Backprop
    BPerrorTotal = BPerrorTotal + n.BPerror
  Next
  
  For i = 0 To noofStates - 1
    Set n = states(i)
    Call n.Backprop
    BPerrorTotal = BPerrorTotal + n.BPerror
  Next
  
  BPerrorTotal = BPerrorTotal / (NoOfOutputs + NoOfHiddens + noofStates)
  
backprop_exit:
  Exit Sub
backprop_err:
  MsgBox "classBackprop/backprop/" & Error$(Err)
  Resume backprop_exit
End Sub


Public Sub learn()
  On Error GoTo learn_err
  
  Dim i As Integer
  Dim n As ClassBackPropNeuron

  For i = 0 To NoOfHiddens - 1
    Set n = hiddens(i)
    Call n.learn(learningRate)
  Next

  For i = 0 To noofStates - 1
    Set n = states(i)
    Call n.learn(learningRate)
  Next

  For i = 0 To NoOfOutputs - 1
    Set n = outputs(i)
    Call n.learn(learningRate)
  Next

learn_exit:
  Exit Sub
learn_err:
  MsgBox "classBackprop/learn/" & Error$(Err)
  Resume learn_exit
End Sub


Public Sub setInput(index As Integer, value As Single)
  On Error GoTo setInput_err
  
  Dim n As ClassBackPropNeuron
  
  Set n = inputs(index)
  n.value = value
  
setInput_exit:
  Exit Sub
setInput_err:
  MsgBox "classBackprop/setInput/" & Error$(Err)
  Resume setInput_exit
End Sub


Public Sub setOutput(index As Integer, value As Single)
  On Error GoTo setOutput_err
  
  Dim n As ClassBackPropNeuron
  
  Set n = outputs(index)
  n.desiredValue = value
  
setOutput_exit:
  Exit Sub
setOutput_err:
  MsgBox "classBackprop/setOutput/" & Error$(Err)
  Resume setOutput_exit
End Sub


Public Function getOutput(index As Integer) As Single
  On Error GoTo getOutput_err
  
  Dim n As ClassBackPropNeuron
  
  Set n = outputs(index)
  getOutput = n.value
  
getOutput_exit:
  Exit Function
getOutput_err:
  MsgBox "classBackprop/getOutput/" & Error$(Err)
  Resume getOutput_exit
End Function


Public Function getRealOutput(index As Integer) As Single
  On Error GoTo getOutput_err
  
  Dim n As ClassBackPropNeuron
  Dim dx As Single
  
  dx = MaxValue(index) - MinValue(index)
  If (dx > 0) Then
    Set n = outputs(index)
    getRealOutput = (((n.value - 0.2) / 0.6) * dx) + MinValue(index)
    Else
    getRealOutput = 0
  End If
  
getOutput_exit:
  Exit Function
getOutput_err:
  MsgBox "classBackprop/getOutput/" & Error$(Err)
  Resume getOutput_exit
End Function


Public Sub setRealValues(index As Integer, min As Single, max As Single)
  MinValue(index) = min
  MaxValue(index) = max
End Sub

Public Sub setRealValuesFromTrainingSet(t As ClassTrainingSet)
  Dim i As Integer
  
  For i = 0 To NoOfOutputs - 1
    MinValue(i) = t.getMinValue(i)
    MaxValue(i) = t.getMaxValue(i)
  Next
End Sub


Public Sub setOutputsToGrid(grid As MSFlexGrid, row As Integer)
'sets the values within a data grid to the outputs of the network
  Dim i As Integer
  
  grid.row = row
  For i = 0 To NoOfOutputs
    grid.col = i
    If (i > 0) Then
      grid.Text = CLng(getRealOutput(i - 1) * 1000) / 1000
      Else
      grid.Text = row
    End If
  Next
End Sub


Public Sub initGrid(grid As MSFlexGrid)
  Dim i As Integer
  
  grid.Cols = NoOfOutputs + 1
  grid.Clear
  For i = 2 To grid.Rows - 1
    grid.RemoveItem (1)
  Next
  grid.row = 0
  For i = 1 To NoOfOutputs