学步园

        对向传播网络（Counter Propagation)，简称CPN,是将Kohonen特征映射网络与Grossberg基本竞争型网络相结合，发挥各自长处的一种新型特征映射网络，被广泛的运用于模式分类，函数近似，数据压缩等方面。
        CPN网络分为输入层，竞争层，隐含层。输入层与竞争层构成SOM网络，竞争层与输出层构成基本竞争 型网络，从整体上看，CPN网络属于有教师学习型网络，而由输入层和竞争层构成的SOM网络又属于典型的无教师网络，因此，这一网络既汲取了无教师型网络分类灵活，算法简练的特点，又采纳了有教师型网络分类精确的长处，使两种不同类型的网络结合起来。

      至于CPN网络的学习算法，这里不打算多提，有兴趣的请参考相关书籍。这里给出一个简单的实现CPN网络的代码.

Private mW1() As Double             '隐含层的权值           S1  X  R
Private mW2() As Double             '输出层的权值           S2  X  R
Private mErr() As Double            '误差
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 HiddenOut() As Double       '输出层的输出
Private OutCopy() As Double    '比较的
Private Ts As Long                  '输入向量的总个数
Private Initialized As Boolean      '是否已初始化

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

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

Public Property Get W2() As Double()
    W2 = mW2
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 Goal() As Double
    Goal = mGoal
End Property

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()
    mLr = 0.1
    mGama = 0.1
    mGoal = 0.0001
    mMaxEpochs = 1000
End Sub

'*********************************** 初始化参数  ***********************************
'
'函 数 名： IniParameters
'参    数： 略
'说    明： 重新定义数组大小，初始化权值矩阵
'作    者： laviewpbt
'时    间： 2006-11-17
'
'***********************************  初始化参数  ***********************************

Private Sub IniParameters(P() As Double, T() As Double)
   
    Dim i As Integer, j As Integer
    mS2 = UBound(T, 1)
    Ts = UBound(T, 2)
    mR = UBound(P, 1)
    ReDim mW1(mS1, mR) As Double
    ReDim mW2(mS2, mS1) As Double
    ReDim HiddenOut(mS1) As Double
    ReDim OutCopy(mS2, Ts) As Double
    ReDim mErr(mMaxEpochs) As Double
    For i = 1 To mSs
        For j = 1 To Ts
            OutCopy(i, j) = T(i, j) '复制原始输出
        Next
    Next
   
    For i = 1 To mS1
        For j = 1 To mR
            mW1(i, j) = Rnd         '初始正向权值
        Next
    Next
   
    For i = 1 To mS2
        For j = 1 To mS1
            mW2(i, j) = Rnd         '初始反向权值
        Next
    Next
    Initialized = True
End Sub

'*********************************** 训练函数  ***********************************
'
'函 数 名： Train
'参    数： P  -  输入矩阵
'           T  -  对应的输出矩阵
'返 回 值： 采用CPN训练算法训练网络
'作    者： laviewpbt
'时    间： 2006-11-19
'
'***********************************  训练函数  ***********************************

Public Sub Train(P() As Double, T() As Double)
   
    Dim i As Integer, j As Integer, k As Integer, m As Integer
    Dim MaxIndex As Integer
    Dim Sum As Double, Max As Double, Err As Double
    IniParameters P, T      '初始化数据
   
    ReDim CopyP(mR, Ts) As Double
    For i = 1 To mR
        For j = 1 To Ts
            CopyP(i, j) = P(i, j)       '备份原始的输入数据，因为在训练中会破坏输入数据
        Next
    Next

    For i = 1 To Ts
        Sum = 0
        For j = 1 To mR
            Sum = Sum + CopyP(j, i) * CopyP(j, i)
        Next
        Sum = Sqr(Sum)
        For j = 1 To mR
            If Sum <> 0 Then              '考虑到输入可能为[0 0 0 ]的形式
                CopyP(j, i) = CopyP(j, i) / Sum   '输入矩阵规一化处理
            End If
        Next
    Next
    mIteration = 0
    For i = 1 To mMaxEpochs
        mIteration = mIteration + 1
        Err = 0
        For j = 1 To Ts
            For k = 1 To mS1
                Sum = 0
                For m = 1 To mR
                    Sum = Sum + mW1(k, m) * mW1(k, m)  '规一化连接权向量
                Next
                Sum = Sqr(Sum)
                For m = 1 To mR
                    mW1(k, m) = mW1(k, m) / Sum
                Next
            Next
           
            For k = 1 To mS1
                Sum = 0
                For m = 1 To mR
                    Sum = Sum + CopyP(m, j) * mW1(k, m)     '计算隐含层的输出
                Next
                HiddenOut(k) = Sum
            Next
           
            Max = -0.01
            MaxIndex = 1
            For k = 1 To mS1
                If Max <= HiddenOut(k) Then  '竞争
                    Max = HiddenOut(k)
                    MaxIndex = k
                End If
            Next
            For k = 1 To mS1
                HiddenOut(k) = 0
            Next
            HiddenOut(MaxIndex) = 1     '将竞争获胜的神经元的输出置为1，其他为0
            For k = 1 To mR
                mW1(MaxIndex, k) = mW1(MaxIndex, k) + mLr * (CopyP(k, j) - mW1(MaxIndex, k))   '隐含层权值调整
            Next
           
            Sum = 0
            For k = 1 To mR
                Sum = Sum + mW1(MaxIndex, k) * mW1(MaxIndex, k)
            Next
            Sum = Sqr(Sum)
            For k = 1 To mR
                mW1(MaxIndex, k) = mW1(MaxIndex, k) / Sum '重新规一化权值
            Next
           
            For k = 1 To mS2
                mW2(k, MaxIndex) = mW2(k, MaxIndex) + mGama * (T(k, j) - OutCopy(k, j))  '输出层权值调整
            Next
            For k = 1 To mS2
                OutCopy(k, j) = mW2(k, MaxIndex)   ' 计算网络输出
                Err = Err + (T(k, j) - OutCopy(k, j)) * (T(k, j) - OutCopy(k, j))
            Next
        Next
        mErr(mIteration) = Sqr(Err)
        If mErr(mIteration) < mGoal Then Exit Sub
    Next
   
End Sub

'*********************************** 仿真函数  ***********************************
'
'函 数 名： Sim
'参    数： P  -  输入矩阵
'返 回 值： 返回对应的输出矩阵
'作    者： laviewpbt
'时    间： 2006-11-19
'
'***********************************  仿真函数  ***********************************

Public Function Sim(P() As Double) As Double()
   
    Dim i As Integer, j As Integer, Ts As Integer
    Dim MaxIndex As Integer
    Dim Sum As Double, Max As Double
    If Initialized = False Then Exit Function
    Ts = UBound(P, 2)
    ReDim CopyP(mR, Ts) As Double
    ReDim HiddenOut(mS1) As Double
    ReDim Out(mS2, Ts) As Double
   
    For i = 1 To mR
        For j = 1 To Ts
            CopyP(i, j) = P(i, j)   '复制原始数据
        Next
    Next
       
    For i = 1 To Ts
        Sum = 0
        For j = 1 To mR
            Sum = Sum + CopyP(j, i) * CopyP(j, i)
        Next
        Sum = Sqr(Sum)
        For j = 1 To mR
            If Sum <> 0 Then CopyP(j, i) = CopyP(j, i) / Sum '将输入规一化
        Next
    Next
   
    For i = 1 To Ts
        For j = 1 To mS1
            Sum = 0
            For k = 1 To mR
                Sum = Sum + CopyP(k, i) * mW1(j, k)
            Next
            HiddenOut(j) = Sum      '隐含层输出
        Next
        Max = -0.01
        MaxIndex = 1
        For j = 1 To mS1
            If Max <= HiddenOut(j) Then
                Max = HiddenOut(j)
                MaxIndex = j
            End If
        Next
        HiddenOut(MaxIndex) = 1     '竞争获胜
        For k = 1 To mS2
            Out(k, i) = mW2(k, MaxIndex)    '输出
        Next
    Next
    Sim = Out
   
End Function

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

Public Sub DrawErrorCurve(pic As PictureBox, Color As OLE_COLOR)
    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
    Dim Max As Double, i As Long
    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 CInt(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

'*********************************** 矩阵形式转为字符串  ***********************************
'
'函 数 名： MatrixToString
'参    数： mtxA  -    待转换的矩阵
'           sFormat -  显示的格式
'返 回 值： 返回转换后的字符串
'作    者： laviewpbt
'时    间： 2006-11-17
'
'***********************************  矩阵形式转为字符串  ***********************************

Public Function MatrixToString(mtxA() As Double, sFormat As String) As String
    Dim i As Integer, j As Integer, m As Integer, n As Integer
    Dim s As String
    m = UBound(mtxA, 1): n = UBound(mtxA, 2)
    For i = 1 To m
        For j = 1 To n
            s = s + Format(mtxA(i, j), sFormat) + "  "
        Next j
        s = s + vbCrLf
    Next i
    MatrixToString = s
End Function

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

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

应用

      这里我们没有给出数据的现实意义，仅就数据本省而论。

 Private Sub CmdYuce_Click()
    Dim str1 As String
    Dim str2 As String
    Dim s As New CPN
    Dim P() As Double, T() As Double, tt() As Double
    str1 = "0 0.5 0 1 0.5 1;0 0.5 0.5 5 1 0.5"
    str2 = "1 1 0 0 0 0;0 0 1 0 0 0;0 0 0 1 0 0;0 0 0 0 1 0;0 0 0 0 0 1"
    P = s.StringToMatrix(str1)
    T = s.StringToMatrix(str2)
    s.S1 = 15
    s.Lr = 0.1
    s.Gama = 0.1
    s.MaxEpochs = 3000
    s.Train P, T
    tt = s.Sim(P)
    s.DrawErrorCurve Picture1, vbRed
    MsgBox s.MatrixToString(tt, "0.00"), vbInformation
End Sub

结果图：

       由结果可以看到，网络成功的学习了所输入的模式，并且具有迭代速度快的特点，另外注意由于该网络会在训练函数的内部对输入数据进行归一化，所以如果输入模式中由两个列向量成比例的话，必须修改其中一个列向量的参数以产生区别，如本例中的4原本为1，这样的话0.5 0.5 和1 1两列成比例，会对网络的训练造成误差，并且减慢网络训练的速度。

  同样，该网络可以解决线性网络不能解决的异或问题。

Private Sub CmdXor_Click()
    Dim P(2, 4) As Double
    Dim T(1, 4) As Double
    Dim tt() As Double
    Dim s As New CPN
    P(1, 1) = 0: P(2, 1) = 0
    P(1, 2) = 0: P(2, 2) = 1
    P(1, 3) = 1: P(2, 3) = 0
    P(1, 4) = 1: P(2, 4) = 1
    T(1, 1) = 0
    T(1, 2) = 1
    T(1, 3) = 1
    T(1, 4) = 0
    s.Gama = 0.2
    s.S1 = 5
    s.Lr = 0.8
    s.MaxEpochs = 1000
    s.Train P, T
    tt = s.Sim(P)
    s.DrawErrorCurve Picture1, vbRed
    MsgBox s.MatrixToString(tt, "0.00"), vbInformation, "异或"

End Sub

 All Rights Reserved!