vba遗传算法

Posted 2020-10-07

  1 Option Explicit
  2 
  3 ‘遗传算法参数
  4 Dim GeneLength As Integer ‘染色体长度
  5 Dim swarmNum As Integer ‘种群规模
  6 Dim Pc As Double ‘杂交概率
  7 Dim Pm As Double ‘突变概率
  8 Dim maxNum As Integer ‘遗传算法循环次数
  9 Dim panelBool As Boolean
 10 Dim tournamentBool As Boolean
 11 
 12 ‘种群适应度统计
 13 Dim optGene As Integer ‘最佳个体的位置
 14 Dim worstGene As Integer ‘最差个体的位置
 15 Dim sumFitness As Double ‘适应度总和
 16 Dim meanFitness As Double ‘平均适应度
 17 Dim maxFitness As Double ‘最大适应度
 18 Dim minFitness As Double ‘最小适应度
 19 Dim stdevFitness As Double ‘适应度标准差
 20 
 21 ‘Dim OriPool() As Byte
 22 Dim oriPool() As Double
 23 
 24 ‘Dim MatePool() As Byte
 25 Dim MatePool() As Double
 26 
 27 Dim Fitness() As Double
 28 Dim panelFitness() As Double
 29 
 30 Dim FileNum As Integer
 31 
 32 ‘高斯分布随机数
 33 
 34 Function randGauss() As Double
 35 Dim i As Integer
 36 randGauss = 0
 37 For i = 1 To 20
 38 randGauss = randGauss + Rnd
 39 Next i
 40 randGauss = (randGauss - 10) / (1.667) ^ 0.5
 41 End Function
 42 
 43 ‘轮盘赌博选择算子，利用累加临左法
 44 Function panelSelection(Fitness() As Double) As Integer
 45 
 46 Dim index, fir, las, i As Integer
 47 Dim temp, sum, sumFitness As Double
 48 
 49 fir = LBound(Fitness)
 50 las = UBound(Fitness)
 51 sumFitness = 0
 52 For i = fir To las
 53 sumFitness = sumFitness + Fitness(i)
 54 Next i
 55 temp = Rnd * sumFitness ‘产生随机数
 56 
 57 index = fir - 1
 58 sum = 0
 59 
 60 Do While sum < temp
 61 index = index + 1
 62 sum = sum + Fitness(index)
 63 Loop
 64 If index = fir - 1 Then
 65 panelSelection = fir
 66 Else
 67 panelSelection = index
 68 End If
 69 
 70 End Function
 71 
 72 ‘锦标赛选择算子
 73 Function tournamentSele(Fitness() As Double) As Integer
 74 Dim i, j As Integer
 75 i = Int(swarmNum * Rnd + 1)
 76 j = Int(swarmNum * Rnd + 1)
 77 If Fitness(i) >= Fitness(j) Then
 78 tournamentSele = i
 79 Else
 80 tournamentSele = j
 81 End If
 82 End Function
 83 
 84 ‘计算种群适应度
 85 Private Sub outFitness(oriPool() As Double, swarmNum As Integer)
 86 
 87     Dim i As Integer
 88     Dim a, b, e As Double
 89     For i = 1 To swarmNum
 90 
 91         ‘//***计算适应度语句***//
 92         Fitness(i) = 0
 93 
 94         ‘//***结束***//
 95 
 96     Next i
 97 
 98     sumFitness = 0
 99     maxFitness = Fitness(1)
100     minFitness = Fitness(1)
101     optGene = 1
102     worstGene = 1
103 
104     For i = 1 To swarmNum
105         sumFitness = sumFitness + Fitness(i)‘总适应度
106         If Fitness(i) > maxFitness Then ‘找到最大适应度评分及其位置
107             maxFitness = Fitness(i)
108             optGene = i
109         End If
110         If Fitness(i) < minFitness Then‘找到最小适应度评分及其位置
111             minFitness = Fitness(i)
112             worstGene = i
113         End If
114     Next i
115 
116     meanFitness = sumFitness / swarmNum ‘平均适应度评分
117 
118     stdevFitness = 0 ‘适应度标准差
119         For i = 1 To swarmNum
120             stdevFitness = stdevFitness + (Fitness(i) - meanFitness) ^ 2
121         Next i
122     stdevFitness = stdevFitness / swarmNum
123 
124     If maxFitness <> meanFitness Then ‘如果最小适应度不等于最大适应度
125         e = 1.5
126         a = (e - 1) * meanFitness / (maxFitness - meanFitness)
127         b = (1 - a) * meanFitness
128         For i = 1 To swarmNum
129             panelFitness(i) = a * Fitness(i) + b
130             If panelFitness(i) < 0 Then
131             panelFitness(i) = 0
132             End If
133         Next i
134     Else
135         For i = 1 To swarmNum
136             panelFitness(i) = Fitness(i)
137         Next i
138     End If
139 
140 End Sub
141 
142 Private Sub Command1_Click()
143 
144     Dim i, j As Integer
145     Dim iterNum As Integer
146     Dim coupleNum As Integer
147     Dim wife, husband As Integer
148     Dim mateLocation As Integer
149     Dim tempint As Integer
150     Dim tempdbl As Double
151 
152     Dim mutationLoc As Integer
153     Dim copySelection As Integer
154     Dim tempRnd As Double
155     Dim str As String
156 
157     FileNum = FreeFile
158     Open "D:\result.txt" For Output As FileNum
159 
160     swarmNum = 20‘种群规模，有多少个随机初始值
161     Pc = 0.8 ‘杂交概率
162     Pm = 0.001‘突变概率
163 
164     maxNum = 30 ‘循环次数 繁殖代数
165 
166     panelBool = False
167     tournamentBool = True
168 
169     GeneLength = 13 ‘基因长度
170     coupleNum = CInt(swarmNum * Pc / 2)‘20*0.8/2=8,有多少对夫妻结合
171 
172     ReDim oriPool(1 To swarmNum, 1 To GeneLength) ‘初始种群池 第一维为种群中每个个体，第二维为相应个体的基因长度
173     ReDim MatePool(1 To swarmNum, 1 To GeneLength) ‘交配池
174     ReDim Fitness(1 To swarmNum) ‘适应度
175     ReDim panelFitness(1 To swarmNum)‘轮盘适应度
176 
177     ‘initialize originpool‘
178 
179     Randomize ‘初始化随机数生成器
180 
181     For i = 1 To swarmNum ‘oriPool(i, j)的每个元素赋初始值
182         ‘//***初始化种群***//
183         ‘For j = 1 To GeneLength
184         ‘OriPool(i, j) = Int(2 * Rnd)
185         ‘Next j
186 
187         For j = 1 To 9
188         oriPool(i, j) = Rnd
189         Next j
190 
191         For j = 10 To 12
192         oriPool(i, j) = 100 * Rnd
193         Next j
194 
195         oriPool(13) = Rnd
196         ‘//***初始化结束***//
197     Next i
198 
199     For iterNum = 1 To maxNum ‘循环30代
200 
201             Call outFitness(oriPool, swarmNum)
202 
203             Print #FileNum, "第" + CStr(iterNum) + "代解"
204                 For i = 1 To swarmNum
205                 str = ""
206                     For j = 1 To GeneLength
207                     If TypeName(oriPool(i, j)) = "Double" Then
208                     str = str & Format(oriPool(i, j), "0.000") & ","
209                     Else
210                     str = str & CStr(oriPool(i, j))
211                     End If
212                     Next j
213 
214                 If TypeName(oriPool(i, 1)) = "Double" Then
215                 str = Left(str, Len(str) - 1)
216                 End If
217 
218                 Print #FileNum, str, Format(Fitness(i), "0.000")
219 
220                 Next i
221 
222             str = "最优个体 "
223             For j = 1 To GeneLength
224             If TypeName(oriPool(optGene, j)) = "Double" Then
225             str = str & Format(oriPool(optGene, j), "0.000") & ","
226             Else
227             str = str & CStr(oriPool(optGene, j))
228             End If
229             Next j
230             If TypeName(oriPool(optGene, GeneLength)) = "Double" Then
231             str = Left(str, Len(str) - 1)
232             End If
233             Print #FileNum, str, Format(Fitness(optGene), "0.000")
234 
235             str = "最差个体 "
236             For j = 1 To GeneLength
237             If TypeName(oriPool(worstGene, j)) = "Double" Then
238             str = str & Format(oriPool(worstGene, j), "0.000") & ","
239             Else
240             str = str & CStr(oriPool(worstGene, j))
241             End If
242             Next j
243             If TypeName(oriPool(worstGene, GeneLength)) = "Double" Then
244             str = Left(str, Len(str) - 1)
245             End If
246             Print #FileNum, str, Format(Fitness(worstGene), "0.000")
247             str = "平均适应度 = " & Format(meanFitness, "0.000") & " ; "
248             str = str & "适应度标准差 = " & Format(stdevFitness, "0.000")
249             Print #FileNum, str
250 
251             ‘//***复制算子无需改动***//
252             ‘copy operator‘
253 
254             For i = 1 To swarmNum
255 
256                 If panelBool Then
257                     copySelection = panelSelection(panelFitness)
258                 End If
259                 If tournamentBool Then
260                     copySelection = tournamentSele(Fitness)
261                 End If
262                 For j = 1 To GeneLength
263                     MatePool(i, j) = oriPool(copySelection, j)
264                 Next j
265 
266             Next i
267             ‘//***复制算子无需改动***//
268 
269             ‘crossover operator‘
270 
271             For i = 1 To coupleNum
272                 wife = Int(swarmNum * Rnd + 1)
273                 husband = Int(swarmNum * Rnd + 1)
274                 mateLocation = Int(GeneLength * Rnd + 1)
275                 For j = 1 To mateLocation
276                     If TypeName(MatePool(wife, j)) = "Double" Then
277                         tempdbl = MatePool(wife, j)
278                         MatePool(wife, j) = MatePool(husband, j)
279                         MatePool(husband, j) = tempdbl
280                     Else
281                         tempint = MatePool(wife, j)
282                         MatePool(wife, j) = MatePool(husband, j)
283                         MatePool(husband, j) = tempint
284                     End If
285                 Next j
286             Next i
287 
288             ‘mutation operator‘ ‘基因突变
289             For i = 1 To swarmNum ‘遍历种群中每个个体（染色体）
290 
291                 ‘//***二进制编码变异***//
292                 For j = 1 To GeneLength ‘遍历每个个体（也叫染色体）中的基因 。MatePool是一个二维数组，每行代表一个个体，每列代表基因长度（是个啥）
293                 tempRnd = Rnd
294                     If tempRnd <= Pm Then ‘pm 基因突变率，0.001，
295                         MatePool(i, j) = (MatePool(i, j) + 1) Mod 2 ‘mod 用来对两个数作除法并且只返回余数。
296                     End If
297                 Next j
298                 ‘//***二进制编码变异结束***//
299 
300             Next i
301 
302             ‘//***加速器***//
303 
304             ‘//***加速器结束***//
305 
306             ‘//***将交配池的个体复制到原始池***//
307             For i = 1 To swarmNum
308                 For j = 1 To GeneLength
309                     oriPool(i, j) = MatePool(i, j)
310                 Next j
311             Next i
312 
313 
314 Next iterNum
315 
316     Text1.Text = "the end"
317 
318 End Sub

View Code

能看懂部分，看不懂这个基因代表啥。也不是二进制表示基因，是浮点数。

用这个代码为模板用来解一个现实的问题吧：

f(x)=x*sin(10*pi*x)+2.0在区间【-1,2】的最大值。不求这个了，求多个摩尔圆的包线。

  1 ‘‘‘‘随机数的应用
  2 ‘Dim i As Integer, randGauss As Double
  3 ‘Dim myarray(4) As Integer
  4 ‘Sub myrnd()
  5 ‘For i = 1 To 11
  6 ‘ Cells(i, 1).Value = Int(100 * Rnd() + 1)
  7 ‘ Cells(i, 2).Value = WorksheetFunction.Dec2Bin(Cells(i, 1).Value, 7)
  8 ‘Next i
  9 ‘randGauss = 0
 10 ‘For i = 1 To 20
 11 ‘randGauss = randGauss + Rnd
 12 ‘Cells(i, 3).Value = randGauss
 13 ‘Next i
 14 ‘randGauss = (randGauss - 10) / (1.667) ^ 0.5
 15 ‘Cells(i + 1, 3).Value = randGauss
 16 ‘End Sub
 17 
 18     Dim minf As Double, df As Double, oxy() As Double, R() As Double, k As Double, b As Double, fric As Double, c As Double
 19     Dim dk As Double, db As Double, fb(2001) As Double, minfkb(1001, 3)
 20     Dim iRow As Long, i As Integer, j As Integer, jx As Integer, num As Integer, ii As Integer
 21 Sub readExcelToArr()
 22     b = 0: f = 0: df = 1: k = 0: num = 0: dk = 0.001: db = 0.05
 23     ‘Sheets("图表名").Activate   Sheets(图表编号).Activate
 24 ‘    Worksheets("Sheet1").Activate
 25 ‘    Charts("Chart1").Activate
 26 ‘    DialogSheets("Dialog1").Activate
 27     Sheets("zbl强度包线").Activate
 28     iRow = Cells(Rows.Count, 1).End(xlUp).Row ‘ iRow=5
 29     ReDim oxy(iRow - 1), R(iRow - 1)  ‘oxy(4),共有0 1 2 3 这四个元素
 30     For i = 2 To UBound(oxy) + 1 ‘UBound(oxy)为数组 oxy 第一维上限，为4
 31         oxy(i - 2) = Range("A" & i)
 32         R(i - 2) = Range("B" & i)
 33 ‘        Range("C" & i) = oxy(i - 2)
 34 ‘        Range("D" & i) = R(i - 2)
 35     Next i
 36     For i = 0 To UBound(oxy) - 2 ‘4-2
 37         For j = i + 1 To UBound(oxy) - 1
 38             num = num + 1
 39             k = k + (R(j) - R(i)) / Sqr(((oxy(j) - oxy(i)) ^ 2 - (R(j) - R(i)) ^ 2)) ‘Sqr((R(j) - R(i)) / (2 * R(i)))
 40         Next j
 41     Next i
 42     k = k / num
 43     Range("H" & 1) = k
 44     ‘k = (R(iRow - 2) - R(0)) / Sqr(((oxy(iRow - 2) - oxy(0)) ^ 2 - (R(iRow - 2) - R(0)) ^ 2)) ‘Sqr((R(iRow - 2) - R(0)) / (2 * R(0)))
 45 ‘    f = computeF(k, b)
 46 ‘     MsgBox "k=" & k & ",  b=" & b & " f=" & f
 47 
 48 ‘
 49 ‘For i = 0 To 1000
 50 ‘ minfkb(i, 0) = 0
 51 ‘ minfkb(i, 1) = 0
 52 ‘ minfkb(i, 2) = 0
 53 ‘Next i
 54 
 55 k = k - 0.2
 56 jx = 2000
 57 minf = computeF(k, b) ‘假定最小的圆心距离直线长度与半径差的平方和为minf
 58 c = Timer
 59 For i = 0 To 1000 ‘3000*dk=3000*0.001=3
 60    ‘ Range("I" & CStr(i + 1)).Value = i
 61     If k > 0 And b >= 0 Then
 62         k = k + dk ‘给k递增
 63         For j = 0 To jx ‘ 2000*db=2000*0.05=100，就是说最大算的粘聚力为100kpa,但是随着i的增大，j的个数是越来越小的。所以不必给个定值2000
 64          fb(j) = computeF(k, j * db)
 65          If minf > fb(j) Then ‘对每个k，遍历好多个b，这样比较出其中的最小的minf，输出到数组。最后在minfkb数组中找最小的minf值
 66             minf = fb(j)
 67             b = j * db
 68             minfkb(i, 0) = k ‘minfbk 存放最小f值所对应的k，b与f值，i值为k的变化系数
 69             minfkb(i, 1) = b
 70             minfkb(i, 2) = minf
 71             jx = j
 72             Range("C" & CStr(i + 1)).Value = i
 73             Range("D" & CStr(i + 1)).Value = j
 74             Range("E" & CStr(i + 1)).Value = k
 75             Range("F" & CStr(i + 1)).Value = b
 76             Range("G" & CStr(i + 1)).Value = minf
 77          End If
 78          Next j
 79     End If
 80     If i >= 1 Then
 81         df = minfkb(i, 2) - minfkb(i - 1, 2)
 82         If df = 0 Then
 83         Exit For
 84         End If
 85     End If
 86 Next i
 87  Range("I" & CStr(3)).Value = Timer - c
 88  c = 0
 89  c = Timer
 90      ‘下面寻找minfkb数组中最小的f值
 91      minf = minfkb(0, 2) ‘首先将第一次算出的f最小值给minf
 92      For i = 0 To 1000
 93         If minf > minfkb(i, 2) Then
 94             If minfkb(i, 2) <> 0 Then
 95             minf = minfkb(i, 2)
 96             k = minfkb(i, 0)
 97             b = minfkb(i, 1)
 98             End If
 99         End If
100 Next i
101 fric = 180 / 3.14159265358979 * Atn(k)
102  Range("J" & CStr(2)).Value = Timer - c
103  
104  
105     MsgBox " k=" & k & " fric=" & fric & ",  b=" & b & "  f=" & minf & " c=" & b
106 End Sub
107  
108 
109 ‘用来求各个圆圆心到包线（直线）距离差的平方和
110 Function computeF(k As Double, b As Double) As Double
111     Dim sum As Double, ii As Integer
112     sum = 0#
113     For ii = 0 To UBound(oxy) - 1
114     sum = sum + ((k * oxy(ii) + b) / (Sqr(k ^ 2 + 1)) - R(ii)) ^ 2
115     Next ii
116     computeF = sum
117 End Function

View Code

上面是原先的代码，方法是将k增大一级，变动很大范围的b，然后再将k增大一点，再变动很大的b，这样记录下所有的结果，再找到所有的解中的f最小值即为最精确的k和b。

---

 

下面用遗传算法。

首先还是大致确定出k和b的范围，然后给出一个变动范围，找使f（k,b）最小的k和b。