【遗传算法】简单实例

香川群子 · 发表于 2015-12-23 22:37

遗传算法是模仿生物种群通过几代、几十代的遗传进化、依靠环境选择进行优胜劣汰，从中筛选得到最接近最优解的模糊算法。

当无法进行穷举遍历时，采用遗传算法可以很快地得到较优解。

具体过程比较复杂一些，所以一般VBA中很少使用。

但是，有简单的例子，可以给大家做个参考。

请看附件。

香川群子 · 发表于 2015-12-23 22:39

Option Base 1
Dim binVal, pop, popVal, newPop, maxPop
Dim popSize&, chromLen&, maxNum&, maxVal, maxCnt&, maxB&, maxX, fitM&, fitSum, pC, pM, cCnt&, mCnt&
Sub MainSub() 'by kagawa 2015/12/23
Dim j&, maxY
maxY = 16.9996092520257 'x=161
fitM = 20
maxNum = 10 'x∈[0,10) x最大值范围
chromLen = 10 'x=b/1024*maxNum 染色体长度(二进制位数)
pC = 0.85 '交叉概率
pM = 0.005 '变异概率
popSize = 20 '样本种群大小
ReDim binVal(0 To chromLen) '生成二进制Decode计算常量
For j = 0 To chromLen
binVal(j) = 2 ^ (chromLen - j)
Next
maxVal = 0 '记录最大值初始化
cCnt = 0 '记录交叉实施次数
mCnt = 0 '记录变异实施次数
Call InitPop '随机生成初始种群
For j = 1 To 10 '遗传迭代次数
Call decodeBin '解码计算x、y=f(x)、z=fit(y)
Call SortPop '对fit结果排序
If popVal(2, popSize) - fitM > maxVal Then
' If popVal(2, popSize) > maxVal Then
maxCnt = j '最大值时的迭代次数
maxB = decodeBinX(popVal(1, popSize), 1) '最大时的十进制值
maxX = decodeBinX(popVal(1, popSize)) '最大时的x值
maxVal = calObjVal(maxX) '更新最大记录y值
maxPop = Application.Index(pop, popVal(1, popSize)) '最大时的二进制值
End If
Call CrossPop '交叉遗传
Call MutationPop '变异遗传
Next
Debug.Print Join(maxPop, ""); maxB; maxX; maxVal; Format(maxVal / maxY, "0.0000%"); maxCnt; cCnt; mCnt
' Stop
End Sub
Sub InitPop() '样本种群初始化随机赋值
Dim i&, j&
ReDim pop(popSize, chromLen)
Randomize
For i = 1 To popSize
For j = 1 To chromLen
pop(i, j) = Int(Rnd * 2)
Next
Next
End Sub
Sub decodeBin() '对种群进行解码计算
Dim i&, j&, x, y, z
ReDim popVal(3, popSize)
fitSum = 0
For i = 1 To popSize
x = decodeBinX(i)
y = calObjVal(x)
z = calFitVal(y)
fitSum = fitSum + z
popVal(1, i) = i
popVal(2, i) = z
Next
End Sub
Function decodeBinX(i, Optional k = 0) '逐行解码计算得到x值
Dim binSum, j&
binSum = 0
For j = 1 To chromLen
If pop(i, j) Then binSum = binSum + binVal(j)
Next
If k Then decodeBinX = binSum Else decodeBinX = binSum / binVal(0) * maxNum '二进制binSum 或转为x=[0,10)内实数值
End Function
Function calObjVal(x) 'f(x)=10*sin(5x)+7*cos(4x) x∈[0,10] '目标计算函数
calObjVal = 10 * Sin(5 * x) + 7 * Cos(4 * x)
End Function
Function calFitVal(y) '适度评价函数
' calFitVal = fitM - y '求最小值
' calFitVal = fitM - Abs(y) '最接近0值
If fitM + y > 0 Then calFitVal = fitM + y Else calFitVal = 0 '求最大值
End Function
Sub SortPop() '解码计算结果排序、并得到累计占比
Dim i&, j&, t, popSum
For i = popSize To 2 Step -1 '冒泡排序
For j = 1 To i - 1
If popVal(2, j) > popVal(2, j + 1) Then '按适度值A-Z升序排序
t = popVal(1, j): popVal(1, j) = popVal(1, j + 1): popVal(1, j + 1) = t '索引值
t = popVal(2, j): popVal(2, j) = popVal(2, j + 1): popVal(2, j + 1) = t '适度值z值
End If
Next
Next
'计算累计占比
popSum = popVal(2, 1): popVal(3, 1) = popSum / fitSum
For i = 2 To popSize
popSum = popSum + popVal(2, i): popVal(3, i) = popSum / fitSum
Next
End Sub
Sub CrossPop() '交叉遗传复制
Dim i1&, i2&, j&, j2&, k&, l&, r, t
ReDim newPop(popSize, chromLen)
Randomize
For k = 1 To popSize Step 2
Do
r = Rnd '随机1
For i1 = 1 To popSize
If r < popVal(3, i1) Then i1 = popVal(1, i1): Exit For
Next
r = Rnd '随机2
For i2 = 1 To popSize
If r < popVal(3, i2) Then i2 = popVal(1, i2): Exit For
Next
If i1 <> i2 Then Exit Do
Loop
'首先确定需要复制的2个父本的随机位置i1/i2
If Rnd < pC Then '如果满足交叉概率则进行随机交叉
cCnt = cCnt + 1 '记录交叉实施次数
'随机得到交叉起始位置j 以及交叉长度l
j = Int(Rnd * chromLen) + 1 '交叉起始位置j
l = Int(Rnd * (chromLen - j + 1)) '交叉长度l
For j2 = 1 To j - 1 'DNA仅复制
newPop(k, j2) = pop(i1, j2)
newPop(k + 1, j2) = pop(i2, j2)
Next
For j2 = j To j + l '此区域进行DNA交叉
newPop(k, j2) = pop(i2, j2)
newPop(k + 1, j2) = pop(i1, j2)
Next
For j2 = j2 To chromLen 'DNA仅复制
newPop(k, j2) = pop(i1, j2)
newPop(k + 1, j2) = pop(i2, j2)
Next
End If
Next
pop = newPop '处理完成后，更新pop种群
End Sub
Sub MutationPop() '变异遗传计算
Dim i&, j&
For i = 1 To popSize
If Rnd < pM Then '如果满足变异概率则进行随机位置变异
mCnt = mCnt + 1 '记录变异实施次数
j = Int(Rnd * chromLen) + 1 '确定随机变异位置j
If pop(i, j) Then pop(i, j) = 0 Else pop(i, j) = 1 '进行0/1互换变异(只1位)
End If
Next
End Sub

复制代码

amzxfgh9632 · 发表于 2015-12-23 22:41

离楼主这么近，爽呀，支持下下，谢谢分享

excelhomesnake · 发表于 2015-12-23 22:55

谢谢,收藏了.支持.

bajifeng · 发表于 2015-12-24 10:18

这个算法有点复杂啊~~~~~~~

hehex · 发表于 2015-12-24 10:35

说实话，算法没太看明白，俺数学渣。很敬佩群子女侠的钻研精神，努力扣代码中......

Moneky · 发表于 2015-12-24 12:22

算法概述可以看看这个文章，讲得很有趣。http://songshuhui.net/archives/10462

香川群子 · 发表于 2015-12-24 17:24

遗传算法一个未知数x的优化版本，加了一些过程数据分析。

香川群子 · 发表于 2015-12-24 17:25

遗传算法 2个未知数x1、先的最新版本。

计算过程比1个未知数稍有变化，但总体算法结构是一样的。

学不完用不尽 · 发表于 2015-12-24 21:56

捧个人场，感谢分享！

		自动登录	找回密码
密码			免费注册

[分享] 【遗传算法】简单实例

评分

评分

评分