File Coverage

blib/lib/Optimization/NSGAII.pm
Criterion Covered Total %
statement 314 401 78.3
branch 50 68 73.5
condition 18 39 46.1
subroutine 19 21 90.4
pod 1 12 8.3
total 402 541 74.3


line stmt bran cond sub pod time code
1             package Optimization::NSGAII;
2              
3 23     23   1951021 use 5.006;
  23         69  
4 23     23   207 use warnings;
  23         46  
  23         460  
5 23     23   92 use strict;
  23         46  
  23         805  
6              
7 23     23   115 use feature 'say';
  23         23  
  23         2461  
8 23     23   115 use Exporter;
  23         46  
  23         1104  
9             our @ISA = ("Exporter");
10 23     23   35121 use Data::Dumper;
  23         133055  
  23         1196  
11 23     23   138 use List::Util qw/min max/;
  23         46  
  23         2047  
12 23     23   138 use Carp;
  23         23  
  23         88688  
13              
14             =pod
15            
16             =head1 NAME
17              
18             Optimization::NSGAII - non dominant sorting genetic algorithm for multi-objective optimization (also known as NSGA2)
19              
20             =head1 VERSION
21              
22             Version 0.02
23              
24             =cut
25              
26             our $VERSION = "0.02";
27              
28             =head1 SYNOPSIS
29              
30             use Optimization::NSGAII qw/ f_Optim_NSGAII /;
31             use Data::Dumper;
32              
33             # D E F I N E O B J E C T I V E S T O O P T I M I Z E
34             ###########################################################
35              
36             sub f_to_optimize {
37            
38             my $x = shift; # load input parameters (genes constituting a single individual)
39              
40             # ... # do your things using these inputs $x->[0], $x->[1] ...
41             # and produce the outputs to be minimized $f1, $f2 ...
42              
43             # examples of things you can do include:
44             # - mathematical formulas in perl to define $f1, $f2, ...
45             # - computations with commercial software and so:
46             # - write input file using $x->[0] ...
47             # - run the computation, for example with perl system() function
48             # - locally or
49             # - on a server for example with 'qsub... '
50             # - wait simulation to end
51             # - postprocess its output and define $f1, $f2 ...
52             # - ...
53            
54             my $out = [$f1,$f2,$f3]; # and finally return the set of these outputs for
55             return $out; # this single individual of the population
56            
57             }
58              
59             # D E F I N E B O U N D S [ A N D I N E Q U A L I T I E S ]
60             ###################################################################
61            
62             # define min and max bounds for $x->[0], $x->[1], ...
63             my $bounds = [[0,1],[0,1],[0,1]]; # example with 3 input parameters (genes) with min = 0 and max = 1:
64            
65             sub f_inequality { # optional inequality constraints set
66            
67             my $x =shift;
68            
69             my @ineq =
70             (
71             $x->[1] + 1 , # equations >= 0
72             $x->[0] + $x->[1] - 9,
73             ...
74             ...
75            
76             );
77            
78             return \@ineq;
79             }
80            
81             # R U N O P T I M I Z A T I O N
82             #################################
83              
84             # execute NSGA-II algorithm
85              
86             my $ref_input_output = f_Optim_NSGAII(
87             {
88            
89             'nPop' => 50, # population size
90             'nGen' => 250, # final generation number
91             'bounds' => $bounds, # loads the previously defined bounds
92             'function' => \&f_to_optimize, # loads the subroutine to optimize (minimize)
93             'nProc' => 8, # how many individuals to evaluate in parallel as separate processes
94             'filesDir' => '/tmp', # work directory
95            
96            
97             # optional parameters:
98            
99             'verboseFinal' => 1, # 0|1: input and output values print at final generation, for each individual of the population
100             # default: print is made ( = 1)
101             'f_ineq' => \&f_inequality, # subroutine describing the constraining inequality set
102             # default: no constraint function
103            
104             # parameters for mutation
105            
106             'distrib' => [-1,0,1], # distribution of values (for example a Gaussian distribution), used to perturb individuals
107             # default: [-1,-0.5,0,0.5,1]
108             'scaleDistrib' => 0.05, # scaling of the distribution array
109             # default: 0 (no perturbation will be done)
110             'percentMut' => 5, # percentage of individual that are randomly perturbated (in all their genes)
111             # and also percentage of input parameters (genes) that are randomly mutated in each individual
112             # default: 5%
113             'startPop' => [[0.3,0.18,-0.1],# initial population
114             [-0.38,0.5,0.1], # default: random population satisfying the bounds
115             ...,
116             ]
117              
118             },
119              
120             # the following is the optional set of parameters for 'Pareto front' 2D live plot
121             # if the part below is not present, no plot will be made
122              
123             {
124              
125             'dx' => 200, # characters width and height of the plot
126             'dy' => 40,
127             'xlabel' => 'stiffness [N/mm]', # horizontal and vertical axis labels
128             'ylabel' => 'mass [kg]',
129             'xlim' => [0,1], # horizontal and vertical axis limits
130             'ylim' => [0,1],
131             'nfun' => [0,2], # which function to plot from return value by f_to_optimize ($out) ; 0=f1, 1=f2 ...
132             }
133             );
134              
135             # U S E S O L U T I O N S
136             ############################
137              
138             # for example print of the input parameters and
139             # corresponding output functions' values of the final found Pareto front
140            
141             my @ref_input = @{$ref_input_output->[0]};
142             my @ref_output = @{$ref_input_output->[1]};
143              
144             print Dumper(\@ref_input);
145             print Dumper(\@ref_output);
146              
147              
148              
149              
150             =head1 EXPORT
151              
152             =over
153              
154             =item * f_Optim_NSGAII
155              
156             =back
157              
158             =cut
159              
160             our @EXPORT_OK = qw/ f_Optim_NSGAII /;
161              
162             =head1 DESCRIPTION
163              
164              
165             =head2 Reference
166              
167             NSGAII.pm apply (with some variations) the NSGA-II algorithm described in the paper:
168              
169             A Fast and Elitist Multiobjective Genetic Algorithm:NSGA-II
170              
171             =over
172              
173             Kalyanmoy Deb, Associate Member, IEEE, Amrit Pratap, Sameer Agarwal, and T. Meyarivan
174              
175             =back
176              
177              
178             =head2 Objective
179              
180             C performs multi-objective optimization using a genetic algorithm approach: it searches the input parameters (genes) which minimize a set of output functions and with some luck a Pareto front is produced.
181             In the Pareto front no solution is better than the others because each solution is a trade-off.
182              
183             =head2 Function to optimize
184              
185             This module requires to define a perl subroutine (C in the code above) which can take the input parameters and gives the corresponding outputs (in other words, it requires a subroutine to evaluate an individual of this population)
186              
187              
188             =head2 Features
189              
190             The optimization is done:
191              
192             =over 3
193              
194             =item * considering allowed B
195              
196             =item * considering optional B (x1^2 + sqrt(x2) -x3 >= 0 , ...)
197              
198             =item * with a B of the subroutine to optimize (and so of individuals) in each generation, by using perl fork() function
199              
200             =back
201              
202             The inequalities must be given by a subroutine which calculate the error, look below in the example: basically all the LHS of the inequalities in the form "... >=0" are put in an array.
203              
204             The number of B of C, and so the value of C, can be for example the max number of parallel C computation that you want and can:
205              
206             =over
207              
208             =item * run on your pc if you run the computation locally (e.g. 4)
209              
210             =item * run on a remote server if you run (inside the C) the computation there (e.g. 32)
211              
212             =back
213              
214             C should be multiple of C, to optimize resources use, but it is not necessary.
215              
216             Problems with this modules are expected on systems not supporting fork() perl function.
217              
218             A B<2D plot> can be activated to control in real time the convergence of the algorithm on two chosen output functions (to assist at the formation of the Pareto front, generation after generation).
219              
220             Each time a new generation finish, all information of the population are written in the C directory:
221              
222             =over
223              
224             =item * F: input (parameters values)
225              
226             =item * F: output (corresponding functions values)
227              
228             =back
229              
230             The algorithm can start by default with a random initial population (satisfying the bounds) or the B can be assigned by assigning it to the C option.
231              
232             Assigning the population at the start can be useful for example if:
233              
234             =over
235              
236             =item * there was an unexpected termination of the program during the optimization, so that one can restart by using the content of one of the last saved F
237              
238             =item * there is the interest in continuing the optimization with different parameters
239              
240             =item * there is already an idea of some input parameters which could give a good output
241              
242             =back
243              
244             For an example of use see F.
245              
246             =head2 Mutation
247              
248             The implementation of the B part has been done in a B.
249              
250             In particular B are applied in sequence:
251              
252             =over
253              
254             =item 1) mutation of all the input parameters (the genes), but only on a certain percentage C of the population:
255              
256             -> Small perturbation of the each gene by adding a number chosen randomly from the given C (scaled with both C and the difference between the two bounds).
257              
258             =item 2) mutation of all the individuals of the population, but only on a certain percentage C of the input parameters (the genes)
259              
260             -> Random change (inside the permitted bounds)
261              
262             =back
263              
264              
265             =head2 Verification
266              
267             This module has been tested, successfully, on many of the test problems defined in the paper described in the Reference section (see EXAMPLE section)
268              
269             The performance (convergence for same population number and max generation number) seems to be comparable to that described in that paper.
270              
271              
272              
273              
274             =head1 EXAMPLE
275              
276             B (the same test problems contained in the paper described in the Reference section) are available in the test folder (F containing ZDT1, ZDT2, TNK, ...).
277              
278             Here you see the B problem with:
279              
280             =over
281              
282             =item * two input parameters $x->[0] and $x->[1]
283              
284             =item * two output functions to optimize f1 and f2
285              
286             =item * two constraining equations between the input parameters
287              
288             =item * 8 process in parallel (8 subroutine f_CONTRS are evaluated in parallel as indipendent processes)
289              
290             =back
291              
292             use Optimization::NSGAII qw/ f_Optim_NSGAII /;
293            
294             # function to minimize
295             sub f_CONSTR {
296            
297             my $x = shift;
298            
299             my $n = scalar(@$x);
300            
301             my $f1 = $x->[0];
302             my $f2 = (1 + $x->[1])/$x->[0];
303            
304             my $out = [$f1,$f2];
305            
306             return $out;
307             }
308              
309             # inequality constraints set
310             sub f_inequality {
311             my $x =shift;
312            
313             # equation >= 0
314             my @ineq =
315             (
316             $x->[1] + 9*$x->[0] - 6 ,
317             -$x->[1] + 9*$x->[0] -1
318             );
319            
320             return \@ineq;
321             }
322              
323             my $bounds = [[0.1,1],[0,5]];
324              
325             my $ref_input_output = f_Optim_NSGAII(
326             {
327             'nPop' => 50,
328             'nGen' => 100,
329             'bounds' => $bounds,
330             'function' => \&f_CONSTR,
331             'f_ineq' => \&f_inequality,
332             'nProc' => 8,
333             'filesDir' => '/tmp',
334             'verboseFinal' => 1,
335             'distrib' => [-1,-0.9,-0.8,-0.7,-0.6,-0.5,-0.4,-0.3,-0.2,-0.1,0,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9],
336             'scaleDistrib' => 0.05,
337             'percentMut' => 5,
338             },
339             {
340             'dx' => 100,
341             'dy' => 40,
342             'xlabel' => 'stiffness [N/mm]',
343             'ylabel' => 'mass [kg]',
344             'xlim' => [0.1,1],
345             'ylim' => [0,10],
346             'nfun' => [0,1],
347             }
348             );
349              
350              
351              
352              
353             =head1 OUTPUT PREVIEW
354              
355             This below is a typical output of the final Pareto front (problem TNK).
356              
357             The numbers represent the rank of the points: in the initial generations you can see points of rank 1,2,3... where points with rank 1 dominate points of rank 2 and so on.
358              
359             Generation after generation all the points go on the Pareto front, so all the points become rank 1 (not dominated, nothing best is present in this population)
360              
361             The points will also expand to occupy the entire front.
362              
363             GENERATION 250
364             m|
365             a|
366             s|
367             s|
368             |
369             [|
370             k|
371             g| 1
372             ]| 11
373             | 11
374             | 1 1
375             | 11
376             | 1
377             | 11 1 1 1 1
378             | 1
379             | 1
380             |
381             | 1
382             | 1 1
383             | 1111
384             | 1
385             |
386             |
387             |
388             |
389             | 1
390             | 11
391             | 1
392             | 1
393             |
394             |______________________________________________________________________
395             stiffness [N/mm]
396              
397              
398              
399              
400             =head1 INSTALLATION
401              
402             Following the instruction in perlmodinstall:
403              
404             =over
405              
406             =item * download the F
407              
408             =item * decompress and unpack
409              
410             =over
411              
412             =item * C
413              
414             =item * C
415              
416             =back
417              
418             =item * C
419              
420             =item * C
421              
422             =item * C
423            
424             =item * C
425              
426             =item * C
427              
428             to install it locally use this instead of C:
429              
430             C if you want to install it in /my/folder
431             then you will have to use in your script: C before using C
432              
433             =back
434              
435              
436              
437              
438              
439             =head1 AUTHOR
440              
441             Dario Rubino, C<< >>
442              
443              
444              
445              
446             =head1 BUGS
447              
448             Solutions (input-output pairs) often contain duplicates, this would require some investigation.
449              
450             Please report any bugs to C, or through
451             the web interface at L. I will be notified, and then you'll
452             automatically be notified of progress on your bug as I make changes.
453              
454              
455              
456              
457             =head1 SUPPORT
458              
459             You can find documentation for this module with the perldoc command.
460              
461             perldoc Optimization::NSGAII
462              
463              
464             You can also look for information at:
465              
466             =over 4
467              
468             =item * RT: CPAN's request tracker (report bugs here)
469              
470             L
471              
472             =item * CPAN Ratings
473              
474             L
475              
476             =item * Search CPAN
477              
478             L
479              
480             =back
481              
482             =head1 LICENSE AND COPYRIGHT
483              
484             This software is Copyright (c) 2022 by Dario Rubino.
485              
486             This is free software, licensed under:
487              
488             The Artistic License 2.0 (GPL Compatible)
489              
490             =cut
491              
492             # A point in the population is defined by:
493             # - input values for the objective functions (input parameters) -> contained in the reference VP
494             # - correspondent output population (objective function values) -> contained in the reference P
495             #
496             # P is the most important set of values used in this package, because the objective functions' values lead the algorithm
497             # VP elements then are postprocessed accordingly so that P and VP maintain always a one to one index correspondence
498             #
499             # VARIABLES
500             #
501             # VP: input values for each population's point
502             # : [[x11,x12,...x1D],...]
503             # P : population (objective values for each point)
504             # : [[fun11,fun12,..fun1M],..]
505              
506             # D : number of dimension of the problem (how many input values for a point)
507             # N : size of population P
508              
509             # p,q : index of a single solution of the population
510             # : id_sol_ith
511             # Sp: set of solution dominated by p (worse than p) for each point
512             # : [[id_sol_i,id_sol_j,...],..]
513              
514             # np: number of solutions which dominate p (better than p), np = zero for first front solutions
515             # : [np1,np2,..]
516             # F: set of solution in front ith
517             # : [[id_sol_k,id_sol_t,...],...]
518             # rank : rank of each solution = front number , rank = 1 for first front solutions
519             # : [rank1,rank2...rankN];
520              
521             ########################################################################################################
522              
523             my @out_print;
524             my $inf = 1e9;
525              
526             sub f_ineq2maxerr {
527             # max error calculation in inequalities
528             # input: lhs inequalities ref (errors)
529             # output: max error
530 4378864     4378864 0 4749469 my $ref_ineq = shift;
531            
532 4378864         4550783 my @ineq = @{$ref_ineq};
  4378864         5477849  
533            
534 4378864         4648556 my $err = 0;
535 4378864         5112263 foreach my $el(@ineq){
536 4378864         6779400 $err = max( $err, -$el);
537             }
538 4378864         6023196 return $err;
539             }
540              
541              
542             sub f_fast_non_dominated_sort {
543             # reference to population
544 121     121 0 1021 my $P = shift;
545 121         545 my $VP = shift;
546 121         613 my $f_ineq = shift;
547            
548            
549 121         701 my $Sp;
550             my $np;
551 121         0 my $F;
552 121         0 my $rank;
553            
554 121         216 my $N = scalar(@{$P});
  121         430  
555              
556 121         1209 foreach my $p(0..$N-1){
557 12100         19981 $np->[$p] = 0;
558 12100         21941 foreach my $q(0..$N-1){
559 1210000 100       1665657 next if $p == $q; # max error <-- inequalities <-- input pars
560 1197900 100       1513338 if ( f_dominates($P->[$p],$P->[$q], f_ineq2maxerr( &{$f_ineq}($VP->[$p]) ), f_ineq2maxerr( &{$f_ineq}($VP->[$q])) ) ){
  1197900 100       1523269  
  1197900         1499479  
561 206368         213241 push @{$Sp->[$p]}, $q;
  206368         443244  
562             }
563 991532         1279083 elsif ( f_dominates($P->[$q],$P->[$p], f_ineq2maxerr( &{$f_ineq}($VP->[$q]) ), f_ineq2maxerr( &{$f_ineq}($VP->[$p])) ) ){
  991532         1262192  
564 202554         378515 $np->[$p] += 1;
565             }
566             }
567 12100 100       27161 if ($np->[$p] == 0){
568 3039         6905 $rank->[$p]=1; # front number, 1 = best
569 3039         5483 push @{$F->[0]}, $p;
  3039         7249  
570             }
571             }
572            
573             # all other fronts
574 121         260 my $i = 0;
575            
576 121         512 while (scalar(@{$F->[$i]})){
  1596         3914  
577 1475         1962 my @Q;# members of next front
578            
579 1475         1801 foreach my $p(@{$F->[$i]}){
  1475         2533  
580 12100         12427 foreach my $q(@{$Sp->[$p]}){
  12100         20760  
581 206368         217689 $np->[$q] -=1;
582 206368 100       306340 if ($np->[$q] == 0){
583 9061         10579 $rank->[$q] = $i + 1 + 1;
584 9061         12461 push @Q, $q;
585             }
586             }
587             }
588 1475         1526 $i++;
589 1475         3959 $F->[$i] = [@Q];
590            
591             }
592              
593 121         470 for my $p(0..$N-1){
594 12100         14255 push @out_print, join(' ',($rank->[$p],@{$P->[$p]}));
  12100         30894  
595             }
596              
597 121         6246 return ($rank,$F); # rank for each point, points in each front
598            
599             }
600              
601             ########################################################################################################
602              
603             sub f_dominates {
604             # input: two elements of P
605             # output: 1 if P1 dominate P2, 0 otherwise
606            
607 2189432     2189432 0 2414482 my $P1 = shift;
608 2189432         2209615 my $P2 = shift;
609            
610             # constraints errors
611 2189432         2263503 my $err1 = shift;
612 2189432         2225305 my $err2 = shift;
613            
614              
615             # number of objective (dimensions)
616 2189432         2224162 my $M = scalar(@{$P1});
  2189432         2306764  
617            
618 2189432         2303929 my $P1_dominate_P2_count = 0;
619            
620 2189432         2923832 for my $kM(0..$M-1){
621 4378864 100       6765582 if ($P1->[$kM] <= $P2->[$kM]){
622 2395800         2784693 $P1_dominate_P2_count++;
623             }
624             }
625              
626 2189432         2251784 my $P1_dominate_P2_p;
627             # if 1 has lower constraints errors, then 1 dominate 2, else if the error is the same (e.g 0) then the dominance is decided on objective value
628             # else simply 1 doesn't dominate 2
629 2189432 100 66     5957566 if (
      66        
630             $err1 < $err2
631             ||
632             ($err1 == $err2 && $P1_dominate_P2_count == $M)
633             ){
634 408922         450548 $P1_dominate_P2_p = 1;
635             }
636 1780510         1984476 else { $P1_dominate_P2_p = 0}
637            
638 2189432         4061422 return $P1_dominate_P2_p;
639            
640             }
641              
642             ########################################################################################################
643              
644             sub f_crowding_distance_assignment{
645             # input: ref of array of a subset of population P, population P
646             # output: distance value for each point of this set
647              
648             # global ids of the set of non dominated points of interest
649 562     562 0 685 my $ids = shift;
650             # objectives of all points
651 562         653 my $P = shift;
652            
653             # build the set of objectives for these global ids (I is a subset of P)
654 562         1275 my $I = [@{$P}[@{$ids}]];
  562         1610  
  562         744  
655            
656             # initialize distance
657 562         755 my $Dist;
658            
659             # number of objective (dimensions)
660 562         746 my $M = scalar(@{$P->[0]});
  562         739  
661             # number of points in I
662 562         626 my $n = scalar(@{$ids});
  562         657  
663            
664             # for each objective
665 562         1608 for my $kM(0..$M-1){
666              
667             # local id of the points, sorted by objective
668 1124         5054 my @index_sort = sort{$I->[$a][$kM] <=> $I->[$b][$kM]} 0..($n-1);
  43776         51609  
669              
670             # min & max for this objective
671 1124         2214 my $fmin = $I->[$index_sort[0]][$kM];
672 1124         1542 my $fmax = $I->[$index_sort[-1]][$kM];
673            
674 1124 50       1980 if ($fmax-$fmin<0.00001){$fmax += 0.00001}
  0         0  
675              
676             # build the distance
677 1124         2004 $Dist->[$index_sort[0]] = $inf;
678 1124         1787 $Dist->[$index_sort[-1]] = $inf;
679             # and for all other intermediate point
680 1124         2010 for my $i(1..($n-2)){
681 12510         21104 $Dist->[$index_sort[$i]] += ($I->[$index_sort[$i+1]][$kM] - $I->[$index_sort[$i-1]][$kM])/($fmax-$fmin);
682             }
683            
684             }
685             # return distances for each point, $Dist->[ith] is distance for point $ids->[ith]
686 562         1171 return $Dist;
687             }
688              
689             ########################################################################################################
690              
691             sub f_crowding_distance_operator {
692             # input: rank and distance of two element of the population (selected by GA)
693             # output: 1 if first dominate second, else 0
694            
695 12100     12100 0 13012 my $rank = shift;
696 12100         12493 my $Dist = shift;
697            
698 12100         12295 my $P1_dominate_P2_p;
699            
700 12100 100 100     31481 if (
      100        
701             $rank->[0] < $rank->[1]
702             ||
703             ($rank->[0] == $rank->[1]) && ($Dist->[0] > $Dist->[1])
704             ){
705 5601         6239 $P1_dominate_P2_p = 1
706             }
707 6499         7374 else {$P1_dominate_P2_p = 0}
708 12100         15362 return $P1_dominate_P2_p;
709             }
710              
711             ########################################################################################################
712              
713             sub f_NSGAII {
714             # input: current function input values VP(t) & VQ(t) ( VQ is obtained by GA)
715             # current population Pt & Qt (obtained by evaluating objective function using VPt & VQt)
716             # output: VP(t+1), P(t+1), rank & distance for each point of this new population
717            
718             # input variables' values
719 121     121 0 1015 my $VPt = shift;
720 121         878 my $VQt = shift;
721            
722             # population (objective function values)
723 121         455 my $Pt = shift;
724 121         328 my $Qt = shift;
725            
726             # constraints function
727 121         798 my $f_ineq = shift;
728            
729 121         11497 my $Rt = [(@$Pt,@$Qt)];
730 121         18594 my $VRt = [(@$VPt,@$VQt)];
731 121         895 my $N = scalar(@$Pt);
732            
733 121         1258 my ($temp,$F) = f_fast_non_dominated_sort($Rt,$VRt,$f_ineq);
734            
735             # input variables for the new population P_t+1
736 121         336 my $VPtp1=[];
737             # new population
738 121         223 my $Ptp1=[];
739 121         230 my $Dist=[];
740 121         243 my $rank=[];
741            
742 121         198 my $i=0;
743             # push the best fronts in final population & store crowding distance
744 121         196 while ( scalar(@{$Ptp1}) + scalar(@{$F->[$i]}) <= $N ){
  562         660  
  562         1414  
745 441         686 push @$Ptp1, @$Rt[@{$F->[$i]}];
  441         1351  
746 441         671 push @$VPtp1,@$VRt[@{$F->[$i]}];
  441         1611  
747 441         859 my $Dist_ = f_crowding_distance_assignment($F->[$i],$Rt);
748 441         1367 push @$rank, ($i+1) x @$Dist_;
749 441         1062 push @$Dist, @$Dist_;
750 441         762 $i++;
751             }
752              
753             # only part of the following front will be pushed in final population, sorting by crowding
754             # here rank is the same for all points, so the crowded-comparison operators reduce to a comparison of crowding distance
755 121         401 my $Dist_ = f_crowding_distance_assignment($F->[$i],$Rt);
756              
757 121         269 my $nf = scalar(@{$F->[$i]});
  121         639  
758            
759 121         493 my @index_sort = sort{$Dist_->[$b] <=> $Dist_->[$a]} 0..($nf-1);
  9008         10987  
760            
761             # cut to fill only the remaining part of Ptp1
762 121         676 @index_sort = @index_sort[0..(($N-scalar(@$Ptp1))-1)];
763              
764 121         776 push @$Ptp1, @$Rt[@{$F->[$i]}[@index_sort]];
  121         531  
765 121         279 push @$VPtp1, @$VRt[@{$F->[$i]}[@index_sort]];
  121         577  
766 121         827 push @$rank, ($i+1) x @index_sort;
767 121         699 push @$Dist, @$Dist_[@index_sort];
768              
769              
770 121         3086 return $VPtp1,$Ptp1,$rank,$Dist;
771              
772             }
773              
774             ########################################################################################################
775              
776             sub f_SBX {
777 6050     6050 0 6405 my $contiguity = shift; # >0 (usually between 2 and 5), greater value produces child values similar to those of the parents
778 6050         6234 my $VP1_ = shift; # input values of parent 1 (ref)
779 6050         6217 my $VP2_ = shift; # input values of parent 2 (ref)
780            
781             # array of equal length
782 6050         8828 my @VP1 = @$VP1_;
783 6050         7640 my @VP2 = @$VP2_;
784 6050         6104 my @out;
785            
786 6050         9165 for my $kp(0..$#VP1){
787             # for array of length=1 or rand<0.5 the cross is made
788 18150 100 66     42831 if ( $#VP1 == 0 || rand(1)<0.5){
789            
790 8910         10725 my $u = rand(1);
791            
792 8910         11767 my $exponent = (1/($contiguity+1));
793 8910 100       19181 my $beta = ($u < 0.5)? (2*$u)**$exponent : (0.5/(1-$u))**$exponent;
794            
795 8910 100       12631 my $sign = (rand(1) < 0.5)? -1 : 1;
796 8910         19668 $out[$kp] = (($VP1[$kp] + $VP2[$kp])/2) + $sign * $beta*0.5*abs($VP1[$kp] - $VP2[$kp])
797            
798             }
799             else {
800 9240         14044 $out[$kp] = $VP1[$kp]
801             }
802             }
803 6050         9696 return \@out;
804             }
805              
806             ########################################################################################################
807              
808             sub f_GA {
809             # input: input values, rank and Dist of the population P(t+1)
810             # output: input value of the population Q(t+1)
811            
812 121     121 0 287 my $VPtp1 = shift;
813 121         285 my $rank = shift;
814 121         166 my $Dist = shift;
815 121         199 my $contiguity = shift;
816            
817 121         208 my $bounds = shift; # for mutation
818            
819             # optional paramters for mutation:
820 121         215 my $distrib = shift;
821 121         187 my $scaleDistrib = shift;
822 121         187 my $percentMut =shift;
823            
824 121         172 my $VQtp1 = [];
825            
826             # binary tournament
827             # two random element are compared
828             # the best according crowding distance operator is selected as parent 1
829             # the same for selecting parent 2
830             # parent 1 and 2 are crossed with SBX to give a child
831             # the procedure is repeated to fill Q(t+1)
832            
833 121         312 my $N = scalar(@$VPtp1);
834            
835 121         922 for my $kt(0..$N-1){
836              
837             # selection of the two parent
838 6050         6653 my @index_parent;
839 6050         7683 for (1..2){
840 12100         20036 my ($r1,$r2) = (int(rand($N)),int(rand($N)));
841 12100         24360 my $P1_dominate_P2_p = f_crowding_distance_operator( [$rank->[$r1],$rank->[$r2]] , [$Dist->[$r1],$Dist->[$r2]] );
842            
843 12100 100       19318 if ($P1_dominate_P2_p == 1){push @index_parent, $r1}
  5601         7790  
844 6499         8874 else {push @index_parent, $r2}
845             }
846             # crossover of the two parent
847 6050         9268 my $out = f_SBX( $contiguity , $VPtp1->[$index_parent[0]] , $VPtp1->[$index_parent[1]] );
848 6050         9346 push @$VQtp1, $out;
849             }
850            
851             # mutation 1
852             # perturbation using distribution array
853 121         391 for my $k(0..(scalar(@$VQtp1) - 1)){
854             # $percentMut percentage of individuals are changed in all their elements (all input parameter will be perturbated)
855 6050 100       10400 if (rand(1)> 1-$percentMut/100){
856 466         576 for my $d(0..(scalar(@{$VQtp1->[0]}) - 1)){
  466         1043  
857             # increment the current value by a random value chosen from the distribution (many time it will be near to zero for a gaussian distribution) scaled with the delta_bounds
858 1398         3675 $VQtp1->[$k][$d] += ($bounds->[$d][1] - $bounds->[$d][0]) * $scaleDistrib * $distrib->[int(rand(scalar(@$distrib)))];
859             }
860             }
861             }
862            
863             # mutation 2
864             # 100% probability of mutation inside VQ(t+1), so the intention is to act on all individual of the population
865 121         1412 for my $k(0..int((scalar(@$VQtp1) - 1) * 100/100)){
866 6050         6385 for my $d(0..(scalar(@{$VQtp1->[0]}) - 1)){
  6050         7859  
867             # $percentMut percentage of values are changed inside each single individual, value is inside bounds
868 18150 100       28587 if (rand(1)> 1-$percentMut/100){
869 860         1806 $VQtp1->[$k][$d] = rand(1) * ($bounds->[$d][1] - $bounds->[$d][0]) + $bounds->[$d][0];
870             }
871             }
872             }
873              
874 121         474 return $VQtp1;
875              
876             }
877              
878              
879              
880             sub f_Optim_NSGAII {
881              
882 23     23 1 6187 my $par = shift;
883            
884 23         46 my $par_plot = shift;
885            
886            
887            
888 23         46 my %par = %{$par};
  23         115  
889              
890 23         46 my $nPop = $par{'nPop'};
891 23         46 my $nGen = $par{'nGen'};
892              
893 23         46 my $bounds = $par{'bounds'};
894 23         46 my $n = scalar @$bounds;
895            
896 23         23 my $fun = $par{'function'};
897            
898             # optional paramters:
899            
900 23   50 4378864   207 my $f_ineq = $par{'f_ineq'} // sub {return [0]};
  4378864         6278484  
901              
902 23   50     69 my $verboseFinal = $par{'verboseFinal'} // 1;
903              
904 23   50     69 my $distrib = $par{'distrib'} // [-1,-0.5,0,0.5,1]; # for mutation, default [-1,-0.5,0,0.5,1]
905 23   50     92 my $scaleDistrib = $par{'scaleDistrib'} // 0; # for mutation, default = 0, no perturbation
906 23   50     69 my $percentMut = $par{'percentMut'} // 5; # for mutation, default = 5%
907            
908 23   50     115 my $startPop = $par{'startPop'} // 'nostartPop';
909              
910             # control for no wrong use of keys
911 23         92 my @keys_ok = ('nPop','nGen','bounds','function','nProc','filesDir','verboseFinal','f_ineq','distrib','scaleDistrib','percentMut','startPop');
912 23         322 for my $key(keys %par){
913 207 50       2714 unless ( grep( /^$key$/, @keys_ok ) ) {
914 0         0 die 'E R R O R : the use of "'.$key.'" in the function to optimize is not defined! Compare with documentation.';
915             }
916             }
917            
918 23         69 my $VPt;
919             my $VQt;
920              
921              
922 23         92 for my $gen(0..$nGen){
923 143 100       582 if ($gen == 0){
924             # input
925 23         46 for (0..$nPop-1){
926 1150 50       1610 if ($startPop eq 'nostartPop'){
927 1150         1495 $VPt->[$_]=[map { rand(1) * ($bounds->[$_-1][1] - $bounds->[$_-1][0]) + $bounds->[$_-1][0] } 1..$n];
  3450         7636  
928             }
929             else {
930 0         0 $VPt = $startPop;
931             }
932 1150         1633 $VQt->[$_]=[map { rand(1) * ($bounds->[$_-1][1] - $bounds->[$_-1][0]) + $bounds->[$_-1][0] } 1..$n];
  3450         6716  
933             }
934             }
935              
936              
937              
938              
939              
940              
941              
942              
943 143         474 my $nProc = $par{'nProc'};
944 143         338 my $filesDir = $par{'filesDir'};
945              
946             # if ($nPop%$nProc != 0){warn "\n nPop should be divisible by nProc!\n\n"};
947              
948 143         184 my $fork = 0;
949              
950 143         582 for (1..$nProc){
951              
952 275         223336 my $pid = fork;
953 275 50       6635 die $! unless defined $pid;
954 275         2139 $fork++;
955            
956             # say "in PID = $$ with child PID = $pid fork# = $fork";
957             # parent process stop here, child processes go on
958 275 100       6210 next if $pid;
959            
960 22         2032 my $r = 0;
961            
962 22         1418 my $nameFileP = $filesDir.'/Pt_'.$fork.'.txt';
963 22         918 my $nameFileQ = $filesDir.'/Qt_'.$fork.'.txt';
964            
965             # remove existing input file for this process number
966 22         80423 system ('rm -f '.$nameFileP);
967 22         67117 system ('rm -f '.$nameFileQ);
968            
969            
970 22         1057 my $id_from = ($fork-1)*int($nPop/$nProc);
971 22         433 my $id_to = $fork *int($nPop/$nProc)-1;
972 22 100       1017 if ($fork == $nProc){$id_to = $nPop - 1};
  11         177  
973            
974             # output
975 22 50       5730 open my $fileoP, '>>', $nameFileP or croak "E R R O R : problem in writing the file ".$nameFileP.' -> "filesDir" path not reachable? -- ';
976 22 50       2544 open my $fileoQ, '>>', $nameFileQ or croak "E R R O R : problem in writing the file ".$nameFileQ.' -> "filesDir" path not reachable? -- ';
977 22         338 for ($id_from .. $id_to){
978 550         1227 my $Pt_ = &{$fun}($VPt->[$_]);
  550         3249  
979 550         15817 my $Qt_ = &{$fun}($VQt->[$_]);
  550         2450  
980 550         12952 say $fileoP join ',',@{$Pt_};
  550         10974  
981 550         989 say $fileoQ join ',',@{$Qt_};
  550         2924  
982             }
983 22         1504 close $fileoP;
984 22         701 close $fileoQ;
985 22         26660 exit;
986             }
987              
988             # wait for the processes to finish
989 121         1468 my $kid;
990 121         537 do {
991 363         43377577 $kid = waitpid -1, 0;
992             } while ($kid>0);
993              
994 121         1039 my $Pt;
995             my $Qt;
996            
997             # collect data together
998 121         2557 for (1..$nProc){
999            
1000 242         4402 my $nameFileP = $filesDir.'/Pt_'.$_.'.txt';
1001 242         1930 my $nameFileQ = $filesDir.'/Qt_'.$_.'.txt';
1002 242 50       20203 open my $fileiP, '<', $nameFileP or croak "E R R O R : problem in reading the file ".$nameFileP.' -> "filesDir" path not reachable? ';
1003 242 50       10247 open my $fileiQ, '<', $nameFileQ or croak "E R R O R : problem in reading the file ".$nameFileQ.' -> "filesDir" path not reachable? ';
1004            
1005 242         29781 while (my $line = <$fileiP>){
1006 6050         8555 chomp $line;
1007 6050         14948 my @vals = split ',', $line;
1008 6050         22409 push @$Pt, \@vals;
1009             }
1010 242         6295 while (my $line = <$fileiQ>){
1011 6050         9146 chomp $line;
1012 6050         15220 my @vals = split ',', $line;
1013 6050         22247 push @$Qt, \@vals;
1014             }
1015 242         3394 close $fileiP;
1016 242         3331 close $fileiQ;
1017             }
1018              
1019            
1020            
1021             # new input
1022 121         2738 my ($VPtp1,$Ptp1,$rank,$Dist)=f_NSGAII($VPt,$VQt,$Pt,$Qt,$f_ineq);
1023              
1024             # save inputs and corresponding outputs at this generation
1025 121         382 my $to_print;
1026             my $FILEO;
1027             # inputs (genes for each individual)
1028 121 50       21416 open $FILEO, '>', $filesDir.'/VPt_gen'.sprintf('%05d',$gen).'.txt' or croak 'E R R O R : problem in writing the generation file -> "filesDir" path not reachable? ';
1029 121         1503 $to_print = f_print_columns($VPt,'%25.15f');
1030 121         4542 print $FILEO (join "\n", @$to_print);
1031 121         24372 close $FILEO;
1032             # outputs (f1, f2 ... for each individual)
1033 121 50       8383 open $FILEO, '>', $filesDir.'/Pt_gen'.sprintf('%05d',$gen).'.txt' or croak 'E R R O R : problem in writing the generation file -> "filesDir" path not reachable? ';
1034 121         547 $to_print = f_print_columns($Pt,'%25.15f');
1035 121         2511 print $FILEO (join "\n", @$to_print);
1036 121         3629 close $FILEO;
1037              
1038            
1039             #print " example input values: " ;
1040             #say join ' ', @{$VPtp1->[0]};
1041            
1042 121 50       587 if (defined $par_plot){
1043 0         0 f_plot($par_plot,$gen,$Ptp1,$rank);
1044 0         0 say '';
1045              
1046 0         0 my $max = -$inf;
1047 0         0 my $min = $inf;
1048            
1049 0         0 for (0..$nPop-1){
1050 0         0 $max = max(@{$Pt->[$_]},@{$Qt->[$_]},$max);
  0         0  
  0         0  
1051 0         0 $min = min(@{$Pt->[$_]},@{$Qt->[$_]},$min);
  0         0  
  0         0  
1052             }
1053 0         0 say 'max output = '.$max;
1054 0         0 say 'min output = '.$min;
1055              
1056              
1057 0         0 my $maxV = -$inf;
1058 0         0 my $minV= $inf;
1059            
1060 0         0 my $minD = min(@$Dist);
1061            
1062              
1063 0         0 for (0..$nPop-1){
1064            
1065 0         0 $maxV = max(@{$VPt->[$_]},@{$VQt->[$_]},$maxV);
  0         0  
  0         0  
1066 0         0 $minV = min(@{$VPt->[$_]},@{$VQt->[$_]},$minV);
  0         0  
  0         0  
1067            
1068             }
1069 0         0 say 'max input = '.$maxV;
1070 0         0 say 'min input = '.$minV;
1071            
1072 0         0 say 'min Dist = '.$minD;
1073             }
1074              
1075              
1076 121         660 my ($VQtp1) = f_GA($VPtp1,$rank,$Dist,2.0,$bounds,$distrib,$scaleDistrib,$percentMut);
1077              
1078             # correction of input values produced by GA to respect bounds
1079 121         347 for my $p(0..$nPop-1){
1080 6050         6877 for my $d(0..$n-1){
1081 18150 50       26650 if($VQtp1->[$p][$d] < $bounds->[$d][0]){$VQtp1->[$p][$d] = $bounds->[$d][0]};
  0         0  
1082 18150 50       27256 if($VQtp1->[$p][$d] > $bounds->[$d][1]){$VQtp1->[$p][$d] = $bounds->[$d][1]};
  0         0  
1083             }
1084             }
1085              
1086             # new output
1087 121         297 my $Qtp1;
1088 121         378 for (0..$nPop-1){
1089 6050         88578 $Qtp1->[$_]=&{$fun}($VQtp1->[$_]);
  6050         10134  
1090             }
1091            
1092             # new became old
1093 121         7007 $VPt = [@$VPtp1];
1094 121         5309 $VQt = [@$VQtp1];
1095            
1096            
1097             # output final
1098 121 100       6177 if($gen == $nGen){
1099 1 50       10 if ($verboseFinal == 1){
1100 0         0 say '------------------------- I N P U T -------------------------:';
1101 0         0 map {say join ' ',@{$_}} @$VPt;
  0         0  
  0         0  
1102 0         0 say '------------------------- O U T P U T -------------------------';
1103 0         0 map {say join ' ',@{$_}} @$Pt;
  0         0  
  0         0  
1104             }
1105            
1106 1         99 return [$VPt,$Pt];
1107            
1108             }
1109            
1110             }
1111            
1112             }
1113              
1114              
1115              
1116             sub f_print_columns {
1117             # to print in columns format the content of $P, $Ptp1 ...
1118 242     242 0 540 my $P = shift;
1119 242         974 my $formato = shift; # e.g. '%25.15f'
1120            
1121             # how many input parameters (genes)
1122 242         398 my $n = scalar @{$P->[0]};
  242         709  
1123             # population number
1124 242         452 my $nPop = scalar @$P;
1125            
1126             # print, each line contains the genes of an individual
1127 242         465 my @to_print;
1128 242         1210 for my $kl(0..($nPop-1)){
1129 12100         12434 my $line;
1130 12100         15296 for my $kx(0..($n-1)){
1131 30250         94400 $line.= sprintf($formato,$P->[$kl][$kx]) . ' ';
1132             }
1133 12100         20763 push @to_print, $line;
1134             }
1135            
1136 242         999 return \@to_print;
1137             }
1138              
1139             ########################################################################################################
1140              
1141             sub f_plot {
1142 0     0 0   my $par_ref = shift;
1143            
1144 0           my $gen = shift;
1145              
1146 0           my $P = shift;
1147 0           my $rank = shift;
1148            
1149            
1150            
1151            
1152 0           my %par = %{$par_ref};
  0            
1153            
1154             # nfun: what objective to plot from all (x=f1 y=f4 -> [0,3])
1155 0           my $nfun = $par{'nfun'};
1156              
1157            
1158 0           my $title = 'GENERATION '.$gen;
1159              
1160             # inizialization of all lines of output
1161 0           my @output = map{ ' ' x $par{'dx'} } 1..$par{'dy'};
  0            
1162            
1163 0           my @nameFront =(0..9,"a".."z","A".."Z");
1164            
1165             # print points of the front
1166 0           my $xASCIImin = 0;
1167 0           my $xASCIImax = $par{'dx'}-1;
1168 0           my $yASCIImin = $par{'dy'}-1;
1169 0           my $yASCIImax = 0;
1170 0           my $n_outliers = 0;
1171            
1172 0           for my $kp(1..scalar(@{$P})-1){
  0            
1173             # conversion x,y -> xASCII,yASCII
1174 0           my $x = $P->[$kp][$nfun->[0]];
1175 0           my $y = $P->[$kp][$nfun->[1]];
1176 0           my $xmin = $par{'xlim'}->[0];
1177 0           my $xmax = $par{'xlim'}->[1];
1178 0           my $ymin = $par{'ylim'}->[0];
1179 0           my $ymax = $par{'ylim'}->[1];
1180            
1181 0           my $xASCII;
1182             my $yASCII;
1183              
1184            
1185 0 0 0       if ($x < $xmax && $x > $xmin && $y < $ymax && $y > $ymin && $rank->[$kp] < $#nameFront){
      0        
      0        
      0        
1186 0           $xASCII = f_interp($xmin,$xmax,$xASCIImin,$xASCIImax,$x);
1187 0           $yASCII = f_interp($ymin,$ymax,$yASCIImin,$yASCIImax,$y);
1188              
1189 0           substr($output[$yASCII],$xASCII,1,$nameFront[$rank->[$kp]]);
1190            
1191             }
1192 0           else {$n_outliers++};
1193             }
1194            
1195             # add axis
1196 0           push @output, '_' x $par{'dx'};
1197 0           @output = map{'|'.$_} @output;
  0            
1198             # add axis labels
1199 0           push @output, sprintf("%$par{'dx'}s",$par{'xlabel'});
1200 0           my @ylabelv = split '',$par{'ylabel'};
1201 0 0         @output = map{ defined $ylabelv[$_] ? $ylabelv[$_].$output[$_] : ' '.$output[$_]} 0..$#output;
  0            
1202             # add statistics
1203 0           unshift @output, sprintf("%".int(($par{'dx'}+length($title))/2)."s",$title);
1204 0           push @output, "xlim: ".(join ' ',@{$par{'xlim'}});
  0            
1205 0           push @output, "ylim: ".(join ' ',@{$par{'ylim'}});
  0            
1206 0           push @output, "#outliers: ".$n_outliers;
1207            
1208 0           print join "\n", @output;
1209            
1210             }
1211              
1212              
1213             sub f_interp{
1214 0     0 0   my ($xmin,$xmax,$xASCIImin,$xASCIImax,$x) = @_;
1215 0           my $xASCII = ($xASCIImax-$xASCIImin)/($xmax-$xmin)*($x-$xmin)+$xASCIImin;
1216 0           $xASCII = sprintf("%.0f",$xASCII);
1217 0           return $xASCII
1218             }
1219              
1220              
1221              
1222              
1223              
1224              
1225             1;