class1.cls

基于bp算法的异或问题

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "BP1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Private mW1() As Double             '隐含层的权值           S1  X  R
Private mW2() As Double             '输出层的权值           S2  X  R
Private mB1() As Double             '隐含层的偏置值         S1  X  1
Private mB2() As Double             '输出层的偏置值         S2  X  1
Private mErr() As Double            '均方误差
Private mMinMax() As Double         '输入向量的上下限       R  X  2
Private mS1 As Long                 '隐含层的神经元个数     S1
Private mS2 As Long                 '输出层的神经元个数     S2
Private mR As Long                  '输入层神经元个数       R
Private mGoal As Double             '收敛的精度
Private mLr As Double               '学习速度
Private mGama As Double             '动量系数
Private mMaxEpochs As Long          '最大的迭代次数
Private mIteration As Long          '实际的迭代次数

'****************************************  中间变量   *******************************************

Private HiddenOutput() As Double    '隐含层的输出
Private OutOutput() As Double       '输出层的输出
Private HiddenErr() As Double       '隐含层各神经元的误差
Private OutPutErr() As Double       '输出层各神经元的误差
Private Pdealing() As Double        '当前正在处理的输入
Private Tdealing() As Double        '当前正在处理的输入对应的输出
Private OldW1() As Double           '旧权值数组
Private OldW2() As Double           '旧权值数组
Private OldB1() As Double           '旧偏置值数组
Private OldB2() As Double           '旧偏置值数组
Private Ts As Long                  '输入向量的总个数
Private Initialized As Boolean      '是否已初始化

'****************************************  属性   *******************************************

Public Event Update(iteration)

Public Property Get W1() As Double()
    W1 = mW1
End Property

Public Property Get W2() As Double()
    W2 = mW2
End Property

Public Property Get B1() As Double()
    B1 = mB1
End Property

Public Property Get B2() As Double()
    B2 = mB2
End Property

Public Property Get Err() As Double()
    Err = mErr
End Property

Public Property Get S1() As Long
    S1 = mS1
End Property

Public Property Let S1(Value As Long)
    mS1 = Value
End Property

Public Property Get S2() As Long
    S2 = mS2
End Property

Public Property Get R() As Long
    R = mR
End Property

Public Property Get Goal() As Double
    Goal = mGoal
End Property

Public Sub MinMax(Value() As Double)
    mMinMax = Value
End Sub

Public Property Let Goal(Value As Double)
    mGoal = Value
End Property

Public Property Get Lr() As Double
    Lr = mLr
End Property

Public Property Let Lr(Value As Double)
    mLr = Value
End Property

Public Property Get Gama() As Double
    Gama = mGama
End Property

Public Property Let Gama(Value As Double)
    mGama = Value
End Property

Public Property Get MaxEpochs() As Long
    MaxEpochs = mMaxEpochs
End Property

Public Property Let MaxEpochs(Value As Long)
    mMaxEpochs = Value
End Property

Public Property Get iteration() As Long
    iteration = mIteration
End Property

'****************************************  初始化   *******************************************
Private Sub Class_Initialize()
    mS1 = 5
    mGoal = 0.0001
    mLr = 0.1
    mGama = 0.8
    mMaxEpochs = 1000
End Sub



'***********************************  训练  ***********************************
'
'过 程 名： Train
'参    数： P   -  输入矩阵
'           T   － 输出矩阵
'作    者： laviewpbt
'时    间： 2006-11-15
'
'***********************************  训练  ***********************************


Public Sub Train(P() As Double, T() As Double)
    Dim i As Long, j As Long, Index As Long
    Dim NmP() As Double
    mR = UBound(P, 1)                               '输入向量的元素个数
    mS2 = UBound(T, 1)                              '输出层神经元的个数
    Ts = UBound(P, 2)                               '输入向量的个数
    NmP = CopyArray(P)                              '保留原始的P,因为正规化的过程中会破坏原始数据
    IniParameters NmP                               '初始化参数和数组
    mIteration = 0
    For i = 1 To mMaxEpochs
        mIteration = mIteration + 1
        Index = Int(Rnd * Ts + 1)                   '随机选取一个输入向量作为训练样本，这样效果比按顺序循环要好
        For j = 1 To mR
            Pdealing(j) = NmP(j, Index)             '正在处理的输入向量
        Next
        For j = 1 To mS2
            Tdealing(j) = T(j, Index)               '正在处理的输出向量
        Next
        HiddenLayer                                 '计算隐含层各神经元的输出
        OutputLayer                                 '计算输出层各神经元的输出
        OutError                                    '计算输出层各神经元的误差
        HiddenError                                 '计算隐含层各神经元的误差
        Update_W2B2                                 '更新隐含层至输出层之间的连接权及输出层节点的偏置值
        Update_W1B1                                 '更新输入层至隐含层之间的连接权及隐含层节点的偏置值
        If iteration Mod 1000 = 0 Then RaiseEvent Update(mIteration)
        If mErr(mIteration) < mGoal Then Exit Sub    '达到要求，完成学习，退出
    Next
End Sub



'***********************************  初始化数据  ***********************************

Private Sub IniParameters(P() As Double)
    Dim i As Long, j As Long
    ReDim mW1(mS1, mR) As Double, mW2(mS2, mS1) As Double
    ReDim mB1(mS1) As Double, mB2(mS2) As Double
    ReDim OldW1(mS1, mR) As Double, OldW2(mS2, mS1) As Double
    ReDim OldB1(mS1) As Double, OldB2(mS2) As Double
    ReDim HiddenOutput(mS1) As Double, OutOutput(mS2) As Double
    ReDim HiddenErr(mS1) As Double, OutPutErr(mS2) As Double
    ReDim Pdealing(mR) As Double, Tdealing(mS2) As Double
    ReDim mErr(mMaxEpochs) As Double
    Randomize
    For i = 1 To mS1
        mB1(i) = 2 * Rnd - 1
        For j = 1 To mR
            mW1(i, j) = 2 * Rnd - 1
        Next
    Next
    For i = 1 To mS2
        mB2(i) = 2 * Rnd - 1
        For j = 1 To mS1
            mW2(i, j) = 2 * Rnd - 1
        Next
    Next
    NormalizeInput P
    Initialized = True
End Sub

'***********************************  输入数据影射到-1和1之间  ***********************************

Private Sub NormalizeInput(P() As Double)
    Dim i As Integer, j As Integer, m As Integer, n As Integer
    m = UBound(P, 1): n = UBound(P, 2)
    For i = 1 To m
        For j = 1 To n
            P(i, j) = 2 * (P(i, j) - mMinMax(i, 1)) / (mMinMax(i, 2) - mMinMax(i, 1)) - 1
        Next
    Next
End Sub

'***********************************  隐含层的数据  ***********************************

Private Sub HiddenLayer()
    Dim i As Long, j As Long
    Dim Sum As Double
    For i = 1 To mS1
        Sum = 0
        For j = 1 To mR
            Sum = Sum + mW1(i, j) * Pdealing(j)
        Next
        HiddenOutput(i) = 1 / (1 + Exp(-(Sum + mB1(i))))
    Next
End Sub





'***********************************  输出层的数据  ***********************************

Private Sub OutputLayer()
    Dim i As Long, j As Long
    Dim Sum As Double
    For i = 1 To mS2
        Sum = 0
        For j = 1 To mS1
            Sum = Sum + mW2(i, j) * HiddenOutput(j)
        Next
        OutOutput(i) = Sum + mB2(i)
    Next
End Sub

'***********************************  输出层的误差  ***********************************

Private Sub OutError()
    Dim i As Long, j As Long, Mse As Double
    For i = 1 To mS2
        OutPutErr(i) = Tdealing(i) - OutOutput(i)
        Mse = Mse + OutPutErr(i) * OutPutErr(i)
    Next
    mErr(mIteration) = Sqr(Mse / mS2)   '用某次迭代的均方误差来代替整体的均方误差
End Sub

'***********************************  隐含层的误差  ***********************************

Private Sub HiddenError()
    Dim i As Long, j As Long
    Dim Sum As Double
    For i = 1 To mS1
        Sum = 0
        For j = 1 To mS2
            Sum = Sum + OutPutErr(j) * mW2(j, i)
        Next
        HiddenErr(i) = Sum * (HiddenOutput(i)) * (1 - HiddenOutput(i))
    Next
End Sub

'***********************************  更新输出层的权值和偏置值  ***********************************

Private Sub Update_W2B2()
    Dim i As Long, j As Long
    Dim Temp As Double
    For i = 1 To mS2
        For j = 1 To mS1
            Temp = mLr * OutPutErr(i) * HiddenOutput(j) + mGama * OldW2(i, j) '动量学习方法
            mW2(i, j) = mW2(i, j) + Temp
            OldW2(i, j) = Temp
        Next
        Temp = mLr * OutPutErr(i) + mGama * OldB2(i)
        mB2(i) = mB2(i) + Temp
        OldB2(i) = Temp
    Next
End Sub


'***********************************  更新隐含层的权值和偏置值  ***********************************

Private Sub Update_W1B1()
    Dim i As Long, j As Long
    Dim Temp As Double
    For i = 1 To mS1
        For j = 1 To mR
            Temp = mLr * HiddenErr(i) * Pdealing(j) + mGama * OldW1(i, j)
            mW1(i, j) = mW1(i, j) + Temp
            OldW1(i, j) = Temp
        Next
        Temp = mLr * HiddenErr(i) + mGama * OldB1(i)
        mB1(i) = mB1(i) + Temp
        OldB1(i) = Temp
    Next
End Sub


'***********************************  均方误差  ***********************************


'Private Function Mse(P() As Double, T() As Double) As Double
    'Dim Temp() As Double
    'Dim i As Integer, j As Integer, Sum As Double, Subs As Double
    'Temp = Sim(P)
    'For i = 1 To mS2
        'For j = 1 To Ts
            'Subs = Temp(i, j) - T(i, j)
            'Sum = Sum + Subs * Subs
        'Next
    'Next
    'Mse = Sum / mS2 / Ts
'End Function


'***********************************  复制数组  ***********************************

Private Function CopyArray(P() As Double) As Double()
    CopyArray = P
End Function


Public Function Sim(P() As Double) As Double()
    Dim i As Integer, j As Integer, k As Integer
    Dim R As Integer, T As Integer
    Dim HiddenOut() As Double, OutOut() As Double, NmP() As Double
    R = UBound(P, 1): T = UBound(P, 2)
    ReDim HiddenOut(mS1, T) As Double, OutOut(mS2, T) As Double
    If Initialized = False Then Exit Function
    NmP = CopyArray(P)                              '保留原始的P,因为正规化的过程中会破坏原始数据
    NormalizeInput NmP                              '如果不是在训练，则把测试的输入正规化，如果在训练，则数据已经正规化
    For i = 1 To mS1
        For j = 1 To T
            For k = 1 To R
                HiddenOut(i, j) = HiddenOut(i, j) + mW1(i, k) * NmP(k, j)
            Next
            HiddenOut(i, j) = 1 / (1 + Exp(-(HiddenOut(i, j) + mB1(i))))
        Next
    Next

    For i = 1 To mS2
        For j = 1 To T
            For k = 1 To mS1
                OutOut(i, j) = OutOut(i, j) + mW2(i, k) * HiddenOut(k, j)
            Next
            OutOut(i, j) = OutOut(i, j) + mB2(i)
        Next
    Next
    Sim = OutOut
End Function


'***********************************  绘制误差曲线  ***********************************
'
'过 程 名： DrawErrorCurve
'参    数： pic   -  曲线绘制的容器
'           Color -  曲线的颜色
'作    者： laviewpbt
'时    间： 2006-11-15
'
'***********************************  绘制误差曲线  ***********************************

Public Sub DrawErrorCurve(pic As PictureBox, Color As OLE_COLOR)
    Dim i As Long, Max As Double
    pic.AutoRedraw = True
    pic.Cls
    pic.BorderStyle = 0
    pic.Scale (-0.15, 1)-(1.1, -0.1)
    pic.Line (-0.15, 1)-(1.095, -0.095), vbBlue, B
   
    For i = 1 To mIteration
        If Max < mErr(i) Then Max = mErr(i)
    Next
    pic.Line (0, 0)-(0, 1), Color
    pic.Line (0, 0)-(1.1, 0), Color
    For i = 1 To mIteration - 1
        pic.Line (i / mIteration, mErr(i) / Max)-((i + 1) / mIteration, mErr(i + 1) / Max), Color
    Next
    For i = 1 To 6
        pic.CurrentY = -0.02
        pic.CurrentX = 0.2 * (i - 1) - pic.TextWidth(mIteration / 5 * (i - 1))
        pic.Print CLng(mIteration / 5 * (i - 1))
    Next
        For i = 1 To 6
        pic.CurrentX = -0.13
        pic.CurrentY = 0.2 * (i - 1) - pic.TextHeight("5") + 0.02
        pic.Print Format(Max / 5 * (i - 1), "0.00")
    Next
    pic.CurrentX = 0.6 - pic.TextWidth("误差曲线")
    pic.CurrentY = 0.95
    pic.Print "误差曲线"
End Sub



'***********************************  字符串转为矩阵形式  ***********************************
'
'函 数 名： StringToMatrix
'参    数： str  -  待转换的矩阵
'返 回 值： 返回转换后的矩阵
'作    者： laviewpbt
'时    间： 2006-11-14
'
'***********************************  字符串转为矩阵形式  ***********************************

Public Function StringToMatrix(str As String) As Double()
    Dim i As Integer, m As Integer, n As Integer
    Dim Temp1() As String, Temp2() As String, Data() As Double
    Temp1 = Split(str, ";")
    Temp2 = Split(Temp1(0), " ")
    m = UBound(Temp1)
    n = UBound(Temp2)
    ReDim Data(1 To m + 1, 1 To n + 1) As Double
    For i = 1 To m + 1
        Temp2 = Split(Trim(Temp1(i - 1)), " ")
        For j = 1 To n + 1
            Data(i, j) = Val(Temp2(j - 1))
        Next
    Next
    StringToMatrix = Data
End Function