http://blog.csdn.net/laviewpbt/article/details/1396261
对向传播网络（Counter Propagation)，简称CPN,是将Kohonen特征映射网络与Grossberg基本竞争型网络相结合，发挥各自长处的一种新型特征映射网络，被广泛的运用于模式分类，函数近似，数据压缩等方面。
CPN网络分为输入层，竞争层，隐含层。输入层与竞争层构成SOM网络，竞争层与输出层构成基本竞争 型网络，从整体上看，CPN网络属于有教师学习型网络，而由输入层和竞争层构成的SOM网络又属于典型的无教师网络，因此，这一网络既汲取了无教师型网络分类灵活，算法简练的特点，又采纳了有教师型网络分类精确的长处，使两种不同类型的网络结合起来。
至于CPN网络的学习算法，这里不打算多提，有兴趣的请参考相关书籍。这里给出一个简单的实现CPN网络的代码.
'作 者： laviewpbt
'联系方式： [email protected]
'QQ:33184777
'版本：Version 1.1.0
'说明：复制请保留源作者信息，转载请说明，欢迎大家提出意见和建议
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
