Sulprobil
Search…
Welcome to my Web Pages
Recent Changes
Access
Excel
Perl
Compare Correlation Matrices
Game of Nim
Eight Queens Puzzle
PowerShell
SQL
Word
Business Development
Human Resources
Information Technology
Organisation
Risk Management
Contact
Disclaimer
Download
Impressum
Powered By GitBook
Compare Correlation Matrices
"Remember, my friend, that knowledge is stronger than memory, and we should not trust the weaker." [Bram Stoker]
Some years ago I developed a Perl program for an Algorithmics client. Over time I enhanced this program and I made it read the RMLinks.cfg file so that new risk factors would automatically be included.
My implementation approach was:
1. Read first matrix Checks: Matrix quadratic? Risk factor order left->right (top row) == top->bottom (leftmost column)? Diagonals == 1 (warning)? No NC category (warning if there is)? Matrix symmetric: M(i,j) == M(j,i) for all i,j? [Not for DC files because not given there.]
2. Read second matrix Checks identical to above
3. Risk factors in both matrices identical? Warn about risk factors which are in first matrix but not in second and vice versa Highlight outliers per category Highlight outliers per ccy
Currently the program is supporting the following parameters:
b - breaches: do not report differences between the two input matrices but breaches beyond tolerances. d - debug [level] gives debugging information at detail level level level 1: - level 2: - level 3: Print all elements of matrices 1 and 2 f - read deviation file [-f needs to be followed by a valid filename] Reads min and max values for all slices for differences which should be ignored during comparison. See option -w to get format example h - help: list parameters and their explanation i - ignore risk factors in a given file [-i needs to be followed by a valid filename] m - set max rank index [default is 6 (=return highest 3 and lowest 3 of each slice); m needs to be even and >= 4 ! n - tolerate risk factor category NC r - set Algo risk factor category file [default is ./RMLinks.cfg s - summarize findings, no detailed warnings or error messages t - read file with tolerated changes for each matrix element and apply tolerance check v - print version w - write deviation file with min and max values of all slices. This file is comma-separated to be easily readable via Excel. It can be amended and used with option -f later [-w needs to be followed by a valid filename, preferrably ending with .csv x - read translation table [-x needs to be followed by a valid filename]. Risk factor names of matrix 1 will be translated by second name in comma-separated row
A typical call of this program from a Shell script could look like:
Please read my Disclaimer.
1
$PERL_LIB/compareCM.pl \
2
-i $PERL_LIB/Ignored_RiskFactors.csv \
3
-m 6 \
4
-n \
5
-r $ALGO_TOP/RMLinks.cfg \
6
-w $PERL_LIB/VCV_Deviation_Matrix.csv \
7
$VCV_PREVIOUS \
8
$VCV_CURRENT
Copied!
The source code of compareCM.pl:
1
#!/usr/bin/perl
2
#
3
# Implementation Approach:
4
#
5
# 1. Read first matrix
6
# Checks:
7
# Matrix quadratic?
8
# Risk factor order left->right (top row) == top->bottom (leftmost column)?
9
# Diagonals == 1 (warning)?
10
# No NC category (warning if there is)?
11
# Matrix symmetric: M(i,j) == M(j,i) for all i,j?
12
# [Not for DC files because not given there.]
13
#
14
# 2. Read second matrix
15
# Checks identical to above
16
#
17
# 3. Risk factors in both matrices identical?
18
# Warn about risk factors which are in first matrix but not in second and vice versa
19
# Highlight outliers per category
20
# Highlight outliers per ccy
21
#
22
# Version Date Author Comment
23
# 1.18 26/12/2018 Bernd Plumhoff Anonymized version
24
my $version = "'1.18,26/12/2018";
25
​
26
use strict;
27
use warnings;
28
use List::Util qw[min max];
29
use feature "switch";
30
use Getopt::Std;
31
​
32
###########################################################
33
# #
34
# Process parameters #
35
# #
36
###########################################################
37
​
38
our $opt_b; # b - breaches: do not report differences between the two input matrices
39
# but breaches beyond tolerances
40
our $opt_d; # d - debug ["level"] gives debugging information at detail level "level"
41
# level 1: -
42
# level 2: -
43
# level 3: Print all elements of matrices 1 and 2
44
our $opt_f; # f - read deviation file [-f needs to be followed by a valid filename]
45
# Reads min and max values for all slices for differences which should
46
# be ignored during comparison. See option -w to get format example.
47
our $opt_h; # h - help: list parameters and their explanation
48
our $opt_i; # i - ignore risk factors in a given file [-i needs to be followed by
49
# a valid filename]
50
our $opt_m; # m - set max rank index [default is 6 (=return highest 3
51
# and lowest 3 of each slice); m needs to be even and >= 4 !
52
our $opt_n; # n - tolerate risk factor category NC
53
our $opt_r; # r - set Algo risk factor category file [default is "./RMLinks.cfg"]
54
our $opt_s; # s - summarize findings, no detailed warnings or error messages
55
our $opt_t; # t - read tolerance file and apply tolerance check
56
our $opt_v; # v - print version
57
our $opt_w; # w - write deviation file with min and max values of all slices.
58
# This file is ","-separated to be easily readable via Excel.
59
# It can be amended and used with option -f later
60
# [-w needs to be followed by a valid filename,
61
# preferrably ending with ".csv"]
62
our $opt_x; # x - read translation table [-x needs to be followed by a valid filename].
63
# Risk factor names of matrix 1 will be translated by second name in
64
# comma-separated row
65
​
66
getopts('bd:f:hi:m:nr:st:vw:x:');
67
​
68
if (defined $opt_h) {
69
print "$0 parameters:\n" .
70
"b - breaches: do not report differences between the two input matrices\n" .
71
" but breaches beyond tolerances\n" .
72
"d - debug [\"level\"] gives debugging information at detail level \"level\"\n" .
73
" level 1: -\n" .
74
" level 2: -\n" .
75
" level 3: Print all elements of matrices 1 and 2\n" .
76
"f - read deviation file [-f needs to be followed by a valid filename]\n" .
77
" Reads min and max values for all slices for differences which should\n" .
78
" be ignored during comparison. See option -w to get format example.\n" .
79
"h - help: list parameters and their explanation\n" .
80
"i - ignore risk factors in a given file [-i needs to be followed by\n" .
81
" a valid filename]\n" .
82
"m - set max rank index [default is 6 (=return highest 3\n" .
83
" and lowest 3 of each slice); m needs to be even and >= 4 !\n" .
84
"n - tolerate risk factor category NC\n" .
85
"r - set Algo risk factor category file [default is \"./RMLinks.cfg\"]\n" .
86
"s - summarize findings, no detailed warnings or error messages\n" .
87
"t - read file with tolerated changes for each matrix element and apply\n" .
88
" tolerance check\n" .
89
"v - print version\n" .
90
"w - write deviation file with min and max values of all slices.\n" .
91
" This file is \",\"-separated to be easily readable via Excel.\n" .
92
" It can be amended and used with option -f later\n" .
93
" [-w needs to be followed by a valid filename,\n" .
94
" preferrably ending with \".csv\"]\n" .
95
"x - read translation table [-x needs to be followed by a valid filename].\n" .
96
" Risk factor names of matrix 1 will be translated by second name in\n" .
97
" comma-separated row\n";
98
exit(0);
99
}
100
​
101
if (defined $opt_v) {
102
print "$0\tVersion: $version\n";
103
exit(0);
104
}
105
​
106
$opt_m ||= 6;
107
if ($opt_m < 4 || $opt_m % 2 != 0) {
108
die "$0: parameter -m needs to be followed by an even number >= 4!\n";
109
}
110
​
111
# Initialize risk factor categories from file
112
# Please note that you will find info to fill that file in $ALGO_TOP\cfg\
113
$opt_r ||= "./RMLinks.cfg";
114
​
115
our $doutfile;
116
if (defined $opt_w) {
117
if (defined $opt_f) {
118
die "$0: Do not use option -w together with option -f!\n";
119
}
120
open($doutfile, ">", $opt_w) || die "$0: Can't open $opt_w: $!";
121
$opt_b ||= "";
122
print $doutfile "$0,$version,Min,Max,Total,Tolerance Breach Down,Tolerance Breach Up," .
123
"$opt_b,Do not change cells on the left." .
124
" They are used by an implicit format check.\n";
125
}
126
​
127
our $epsilon = 0.000001; # Tolerance for floating number rounding errors. Please note that the
128
# value 1e-6 has been chosen carefully: it coincides with the precision
129
# of printf's format %f (see sub printarr below, please).
130
​
131
###########################################################
132
# #
133
# Read deviation file #
134
# #
135
###########################################################
136
​
137
our $dinfile;
138
our $line;
139
our @fields=();
140
our @devglobal=(); # Stores global deviations as read by -f option if any
141
our %devrfcat=(); # Stores deviations per category if any
142
our %devccy=(); # Stores deviations per ccy if they exist
143
our %devrfcpair=(); # Stores deviations per category pair if they exist
144
if (defined $opt_f) {
145
open($dinfile, "<", $opt_f) || die "$0: Can't open $opt_f: $!";
146
@fields = split(",", <$dinfile>);
147
if ($0 ne $fields[0] || $version ne $fields[1] . ";" . $fields[2]) {
148
print STDERR "$0: Warning: $0,$version expected but $fields[0]," .
149
"$fields[1],$fields[2] found.\n";
150
}
151
if (! $opt_b && $fields[5] || $opt_b && ! $fields[5]) {
152
$opt_b ||= "";
153
die "$0: Option -b setting ($opt_b) does not match deviation file setting ($fields[5])";
154
}
155
while($line = <$dinfile>) {
156
@fields = split(";", substr($line,0,length($line)-2));
157
given($fields[0]) {
158
when ("GLOBAL") {
159
$devglobal[0] = $fields[3];
160
$devglobal[1] = $fields[4];
161
}
162
when ("CATEGORY") {
163
$devrfcat{$fields[1]}[0] = $fields[3];
164
$devrfcat{$fields[1]}[1] = $fields[4];
165
}
166
when ("CURRENCY") {
167
$devccy{$fields[1]}[0] = $fields[3];
168
$devccy{$fields[1]}[1] = $fields[4];
169
}
170
when ("CATEGORYPAIR") {
171
$devrfcpair{$fields[1] . "," . $fields[2]}[0] = $fields[3];
172
$devrfcpair{$fields[1] . "," . $fields[2]}[1] = $fields[4];
173
}
174
default {
175
die "$0: I don't know what to do with deviation definition $fields[0]";
176
}
177
}
178
}
179
close $dinfile;
180
}
181
​
182
###########################################################
183
# #
184
# Read file with riskfactors which should get ignored #
185
# #
186
###########################################################
187
​
188
our %rfignore=(); # Stores risk factors to be ignored
189
if (defined $opt_i) {
190
open($dinfile, "<", $opt_i) || die "$0: Can't open $opt_i: $!";
191
while($line = <$dinfile>) {
192
$line =~ s/[\r\n]+//g;
193
$rfignore{$line} = 1;
194
}
195
close $dinfile;
196
}
197
​
198
###########################################################
199
# #
200
# Read file with translation table for risk factors #
201
# #
202
###########################################################
203
​
204
our %rftrans=(); # Stores risk factors to be translated
205
if (defined $opt_x) {
206
open($dinfile, "<", $opt_x) || die "$0: Can't open $opt_x: $!";
207
while($line = <$dinfile>) {
208
$line =~ s/[\r\n]+//g;
209
@fields = split(",", $line);
210
$rftrans{$fields[0]} = $fields[1];
211
}
212
close $dinfile;
213
}
214
​
215
###########################################################
216
# #
217
# Read tolerance matrix #
218
# #
219
###########################################################
220
​
221
our $tinfile;
222
our @tnames=(); # risk factor names in tolerance matrix
223
our %hashtnames=(); # hash table of risk factor names and their position
224
our @tol=(); # array with tolerances (per risk factor)
225
our $i; # row index for loops
226
our $j; # column index in loops
227
if (defined $opt_t) {
228
open($tinfile, "<", $opt_t) || die "$0: Can't open $opt_t: $!";
229
$line = <$tinfile>;
230
$line =~ s/[\r\n]+//g;
231
@tnames = split(",", $line);
232
for ($i=1; $i<scalar(@tnames); $i++) {
233
$hashtnames{$tnames[$i]} = $i;
234
}
235
while($line = <$tinfile>) {
236
$line =~ s/[\r\n]+//g;
237
@fields=split(",", $line);
238
​
239
# Matrix quadratic?
240
if (scalar(@tnames) != scalar(@fields)) {
241
print STDERR "$ARGV[0]: matrix is not quadratic: # of columns (" . @tnames .
242
") != # of fields in row $. (" . @fields . ")!\n";
243
exit(1);
244
}
245
​
246
# Risk factor order left->right (top row) == top->bottom (leftmost column)?
247
if ($fields[0] ne @tnames[$. - 1]) {
248
print STDERR "$ARGV[0], Row $.: risk factor \"$fields[0]\" does not match" .
249
" corresponding column header \"@tnames[$. - 1]\".\n";
250
}
251
​
252
# No NC category (warning if there is)?
253
! $opt_n && ! $opt_s && get_rf_category($fields[0]) eq "NC" &&
254
print STDERR "$ARGV[0], Row $.: risk factor $fields[0] is linked to category NC.\n";
255
​
256
# Please note that we only fill triangle above diagonal since we check for symmetry
257
for ($i=$. - 2; $i<scalar(@tnames) - 1; $i++) {
258
$tol[$. - 2][$i] = $fields[$i + 1];
259
defined $opt_d && $opt_d > 2 && print "Tolerance[" . ($. - 2) . "][$i]=" .
260
$fields[$i + 1] . "\n";
261
}
262
for ($i=0; $i<$. - 1; $i++) {
263
# Matrix symmetric: M(i,j) == M(j,i) for all i,j?
264
if ($fields[$i + 1] != $tol[$i][$. - 2]) {
265
print STDERR "$ARGV[0], Row $.: M[" . ($. - 2) . "][" . $i ."] != M[" . $i .
266
"][" . ($. - 2) . "]: " . $fields[$i + 1] . "!=" .
267
$tol[$i][$. - 2] . ".\n";
268
}
269
}
270
}
271
​
272
# Matrix quadratic?
273
if (scalar(@tnames) != $.) {
274
print STDERR "$ARGV[0]: matrix is not quadratic: # of columns (" .
275
scalar(@tnames) . ") != # of rows ($.)!\n";
276
exit(1);
277
}
278
​
279
close $tinfile;
280
281
}
282
our %rfcatpat=(); # links search pattern to risk factor category
283
our %rfcat=(); # speeds up get_rf_category
284
our $rfcatcount=0; # counts risk factor categories in order to build @rfcatrank
285
​
286
our @m1=(); # First matrix
287
our @m2=(); # Second matrix
288
our $m2val; # Temporary value of second matrix
289
our @m3=(); # Diff matrix: Second minus First
290
our @names1=(); # risk factor names in matrix 1
291
our @names2=(); # risk factor names in matrix 2
292
our %rfnames1=(); # to store row number of risk factor names in matrix 1
293
our %rfnames2=(); # to store row number of risk factor names in matrix 2
294
our $ccy;
295
our $t; # tolerance
296
​
297
# Variables to process DC file
298
our @hnames=(); # helper array to split up risk factor names in DC file
299
our $rf1;
300
our $rf2;
301
our $old_rf; # for row change comparisons of the DC matrices
302
our $all_rfnames_read; # Boolean
303
our $start_next_row; # Boolean
304
our $is_upper_right_triangle; # Boolean
305
# Variables to rank outliers detected
306
our @diagnotone1=(); # ranks diagonal values <> 1 of matrix 1
307
our $dno1idx = 0; # number of elements in @diagnotone1
308
our @diagnotone2=(); # ranks diagonal values <> 1 of matrix 2
309
our $dno2idx = 0; # number of elements in @diagnotone2
310
our @totaldiff=(); # ranks all differences of matrix 2 minus matrix 1
311
our $tdidx = 0; # number of elements in @totaldiff
312
our %rfcatrank=();
313
our %rfcatidx=(); # number of elements in @{$rfcatrank{$rfcatidx{rfname}}}
314
our %rfcccyrank=();
315
our %rfcccyidx=(); # number of elements in @{$rfccyrank{$rfcccyidx{rfname}}}
316
our %rfcpairrank=();
317
our %rfcpairidx=(); # number of elements in @{$rfcpairrank{$rfcpairidx{rfname}}}
318
​
319
init_rf_category($opt_r);
320
​
321
###########################################################
322
# #
323
# 1. Read first matrix #
324
# #
325
###########################################################
326
​
327
open (FILE, "<", $ARGV[0]) || die "$0: Cannot open $ARGV[0]: $!";
328
$line = <FILE>;
329
$line =~ s/[\r\n]+//g;
330
if (substr($line,0,1) eq ",") {
331
​
332
# We read a CSV file
333
​
334
@names1 = split(",", $line);
335
for ($i=1; $i<@names1; $i++) {
336
$rftrans{$names1[$i]} ||= $names1[$i];
337
$rfnames1{$rftrans{$names1[$i]}} = $i;
338
}
339
​
340
while($line = <FILE>) {
341
$line =~ s/[\r\n]+//g;
342
@fields=split(",", $line);
343
​
344
# Matrix quadratic?
345
if (scalar(@names1) != scalar(@fields)) {
346
print STDERR "$ARGV[0]: matrix is not quadratic: # of columns (" . @names1 .
347
") != # of fields in row $. (" . @fields . ")!\n";
348
exit(1);
349
}
350
​
351
# Risk factor order left->right (top row) == top->bottom (leftmost column)?
352
if ($fields[0] ne @names1[$. - 1]) {
353
print STDERR "$ARGV[0], Row $.: risk factor \"$fields[0]\" does not match" .
354
" corresponding column header \"@names1[$. - 1]\".\n";
355
}
356
​
357
# No NC category (warning if there is)?
358
! $opt_n && ! $opt_s && get_rf_category($fields[0]) eq "NC" &&
359
print STDERR "$ARGV[0], Row $.: risk factor $fields[0] is linked to category NC.\n";
360
​
361
# Diagonals == 1 (warning)?
362
if (abs($fields[$. - 1] - 1) > $epsilon) {
363
($dno1idx, @diagnotone1) = rankinsert($fields[$. - 1],
364
"$ARGV[0], Row $.: $fields[0]",
365
2, -2, 0, $dno1idx, @diagnotone1)
366
unless $rfignore{$fields[0]};
367
! $opt_s && print STDERR "$ARGV[0], Row $.: Diagonal element is not equal to 1: M[" .
368
($. - 1) . "," . ($. - 1) . "] == " . $fields[$. - 1] . ".\n";
369
}
370
​
371
# Please note that we only fill triangle above diagonal since we check for symmetry
372
for ($i=$. - 2; $i<scalar(@names1) - 1; $i++) {
373
$m1[$. - 2][$i] = $fields[$i + 1];
374
defined $opt_d && $opt_d > 2 && print "Matrix1[" . ($. - 2) . "][$i]=" .
375
$fields[$i + 1] . "\n";
376
}
377
for ($i=0; $i<$. - 1; $i++) {
378
# Matrix symmetric: M(i,j) == M(j,i) for all i,j?
379
if ($fields[$i + 1] != $m1[$i][$. - 2]) {
380
print STDERR "$ARGV[0], Row $.: M[" . ($. - 2) . "][" . $i ."] != M[" . $i .
381
"][" . ($. - 2) . "]: " . $fields[$i + 1] . "!=" .
382
$m1[$i][$. - 2] . ".\n";
383
}
384
}
385
}
386
​
387
# Matrix quadratic?
388
if (scalar(@names1) != $.) {
389
print STDERR "$ARGV[0]: matrix is not quadratic: # of columns (" .
390
scalar(@names1) . ") != # of rows ($.)!\n";
391
exit(1);
392
}
393
​
394
} elsif (substr($line,0,1) eq "\*") {
395
​
396
# We read a DC file
397
​
398
$all_rfnames_read = 0; # We have not identified all risk factor names yet
399
$i = 1;
400
$is_upper_right_triangle = 0;
401
$old_rf = "";
402
​
403
while($line = <FILE>) {
404
$line = substr($line,0,length($line)-2);
405
next if (($line =~ /^\*/));
406
next if (($line =~ /^$/));
407
​
408
@fields = split(",", $line);
409
@hnames = split(/\./, $fields[0]);
410
if ($is_upper_right_triangle) {
411
$rf1 = $hnames[0] . "." . $hnames[1];
412
$rf2 = $hnames[2] . "." . $hnames[3];
413
} else {
414
$rf2 = $hnames[0] . "." . $hnames[1];
415
$rf1 = $hnames[2] . "." . $hnames[3];
416
}
417
418
if ($. == 4) {
419
if ($rf1 eq $old_rf) {
420
# DC file is of upper right triangle form
421
$is_upper_right_triangle = 1;
422
$rf2 = $rf1;
423
$rf1 = $hnames[0] . "." . $hnames[1];
424
}
425
}
426
​
427
if ($rf2 ne $old_rf) {
428
$start_next_row = 1;
429
} else {
430
$start_next_row = 0;
431
}
432
$old_rf = $rf2;
433
​
434
if ($start_next_row) {
435
if ($. > 3) {
436
$all_rfnames_read = 1;
437
}
438
if ($rf1 ne $rf2) {
439
print STDERR "$ARGV[0], Row $.: matrix is not quadratic: After change of 2." .
440
" risk factor name the next diagonal element has" .
441
" to have (name 1 == name 2)!\n";
442
exit(1);
443
}
444
# Diagonals == 1 (warning)?
445
if (abs($fields[1] - 1) > $epsilon) {
446
($dno1idx, @diagnotone1) = rankinsert($fields[1],
447
"$ARGV[0], Row $.: $rf1",
448
2, -2, 0, $dno1idx, @diagnotone1)
449
unless $rfignore{$rf1};
450
! $opt_s && print STDERR "$ARGV[0], Row $.: Diagonal element is not equal to 1: M[" .
451
($rfnames1{$rftrans{$rf1}}) . "," . ($rfnames1{$rftrans{$rf2}}) .
452
"] == " . $fields[1] . ".\n";
453
}
454
}
455
​
456
if (! $all_rfnames_read) {
457
$rftrans{$rf1} ||= $rf1;
458
$names1[$i] = $rftrans{$rf1};
459
if (! defined $rfnames1{$rftrans{$rf1}}) {
460
$rfnames1{$rftrans{$rf1}} = $i++;
461
}
462
} else {
463
# Risk factor order left->right (top row) == top->bottom (leftmost column)?
464
! defined $rftrans{$rf1} &&
465
print STDERR "$ARGV[0], Row $.: risk factor \"$rf1\" does not exist.\n";
466
! defined $rftrans{$rf2} &&
467
print STDERR "$ARGV[0], Row $.: risk factor \"$rf2\" does not exist.\n";
468
}
469
​
470
# No NC category (warning if there is)?
471
! $opt_n && ! $opt_s && get_rf_category($rf1) eq "NC" &&
472
print STDERR "$ARGV[0], Row $.: risk factor $rf1 is linked to category NC.\n";
473
! $opt_n && ! $opt_s && get_rf_category($rf2) eq "NC" &&
474
print STDERR "$ARGV[0], Row $.: risk factor $rf2 is linked to category NC.\n";
475
​
476
# Please note that we only fill triangle above diagonal
477
$m1[$rfnames1{$rftrans{$rf2}} - 1][$rfnames1{$rftrans{$rf1}} - 1] = $fields[1];
478
defined $opt_d && $opt_d > 2 && print "Matrix1[" . $rfnames1{$rftrans{$rf2}} .
479
"][$rfnames1{$rftrans{$rf1}}]=" . $fields[1] . "\n";
480
}
481
​
482
# Matrix quadratic?
483
if (scalar(@names1) != sqrt(2*$. - 3.75) + 0.5) {
484
print STDERR "$ARGV[0]: matrix is not quadratic: # of columns (" . scalar(@names1) .
485
") != # of rows (" . (sqrt(2*$. - 3.75) + 0.5) . ")!\n";
486
# exit(1);
487
}
488
​
489
}
490
​
491
close(FILE);
492
​
493
! $opt_s && $dno1idx && printarr("Diagonal in matrix 1 not 1:", $dno1idx, @diagnotone1);
494
​
495
###########################################################
496
# #
497
# 2. Read second matrix #
498
# #
499
###########################################################
500
our $m1name = $ARGV[0];
501
shift;
502
$all_rfnames_read = 0;
503
open (FILE, "<", $ARGV[0]) || die "Cannot open $ARGV[0]: $!";
504
​
505
$line = <FILE>;
506
$line =~ s/[\r\n]+//g;
507
if (substr($line,0,1) eq ",") {
508
​
509
# We read a CSV file
510
​
511
@names2 = split(",", $line);
512
for ($i=1; $i<@names2; $i++) {
513
$rfnames2{$names2[$i]} = $i;
514
}
515
​
516
while($line = <FILE>) {
517
$line =~ s/[\r\n]+//g;
518
@fields=split(",", $line);
519
​
520
# Matrix quadratic?
521
if (scalar(@names2) != scalar(@fields)) {
522
print STDERR "$ARGV[0]: matrix is not quadratic: # of columns (" . @names2 .
523
") != # of fields in row $. (" . @fields . ")!\n";
524
exit(1);
525
}
526
​
527
# Risk factor order left->right (top row) == top->bottom (leftmost column)?
528
if ($fields[0] ne @names2[$. - 1]) {
529
print STDERR "$ARGV[0], Row $.: risk factor \"$fields[0]\" does not match" .
530
" corresponding column header \"@names2[$. - 1]\".\n";
531
}
532
​
533
# Warn about risk factors which are in first matrix but not in second
534
#if (! (defined $rfnames1{$rftrans{$fields[0]}})) {
535
# print STDERR "$ARGV[0], Row $.: risk factor \"$fields[0]\" does not exist in " .
536
# "$m1name" . "\n";
537
#}
538
​
539
# No NC category (warning if there is)?
540
! $opt_n && ! $opt_s && get_rf_category($fields[0]) eq "NC" &&
541
print STDERR "$ARGV[0], Row $.: risk factor $fields[0] is linked to category NC.\n";
542
​
543
# Diagonals == 1 (warning)?
544
if (abs($fields[$. - 1] - 1) > $epsilon) {
545
($dno2idx, @diagnotone2) = rankinsert($fields[$. - 1],
546
"$ARGV[0], Row $.: $fields[0]",
547
2, -2, 0, $dno2idx, @diagnotone2)
548
unless $rfignore{$fields[0]};
549
! $opt_s && print STDERR "$ARGV[0], Row $.: Diagonal element is not equal to 1: M[" .
550
($. - 1) . "," . ($. - 1) . "] == " . $fields[$. - 1] . ".\n";
551
}
552
​
553
# Please note that we only fill triangle above diagonal since we check for symmetry
554
for ($i=$. - 2; $i<scalar(@names2) - 1; $i++) {
555
$m2[$. - 2][$i] = $fields[$i + 1];
556
defined $opt_d && $opt_d > 2 && print "Matrix2[" . ($. - 2) . "][$i]=" .
557
$fields[$i + 1] . "\n";
558
}
559
for ($i=0; $i<$. - 1; $i++) {
560
# Matrix symmetric: M(i,j) == M(j,i) for all i,j?
561
if ($fields[$i + 1] != $m2[$i][$. - 2]) {
562
print STDERR "$ARGV[0], Row $.: M[" . ($. - 2) . "][" . $i ."] != M[" . $i .
563
"][" . ($. - 2) . "]: " . $fields[$i + 1] . "!=" .
564
$m2[$i][$. - 2] . ".\n";
565
}
566
}
567
}
568
​
569
# Matrix quadratic?
570
if (scalar(@names2) != $.) {
571
print STDERR "$ARGV[0]: matrix is not quadratic: # of columns (" . scalar(@names2) .
572
") != # of rows ($.)!\n";
573
exit(1);
574
}
575
​
576
} elsif (substr($line,0,1) eq "\*") {
577
​
578
# We read a DC file
579
​
580
$all_rfnames_read = 0; # We have not identified all risk factor names yet
581
$i = 1;
582
$is_upper_right_triangle = 0;
583
$old_rf = "";
584
​
585
while($line = <FILE>) {
586
$line = substr($line,0,length($line)-2);
587
next if (($line =~ /^\*/));
588
next if (($line =~ /^$/));
589
​
590
@fields = split(",", $line);
591
@hnames = split(/\./, $fields[0]);
592
if ($is_upper_right_triangle) {
593
$rf1 = $hnames[0] . "." . $hnames[1];
594
$rf2 = $hnames[2] . "." . $hnames[3];
595
} else {
596
$rf2 = $hnames[0] . "." . $hnames[1];
597
$rf1 = $hnames[2] . "." . $hnames[3];
598
}
599
600
if ($. == 4) {
601
if ($rf1 eq $old_rf) {
602
# DC file is of upper right triangle form
603
$is_upper_right_triangle = 1;
604
$rf2 = $rf1;
605
$rf1 = $hnames[0] . "." . $hnames[1];
606
}
607
}
608
​
609
if ($rf2 ne $old_rf) {
610
$start_next_row = 1;
611
} else {
612
$start_next_row = 0;
613
}
614
$old_rf = $rf2;
615
​
616
if ($start_next_row) {
617
if ($. > 3) {
618
$all_rfnames_read = 1;
619
}
620
if ($rf1 ne $rf2) {
621
print STDERR "$ARGV[0], Row $.: matrix is not quadratic: After change of 2." .
622
" risk factor name the next diagonal element has to be" .
623
" given (name 1 == name 2)!\n";
624
exit(1);
625
}
626
# Diagonals == 1 (warning)?
627
if (abs($fields[1] - 1) > $epsilon) {
628
($dno2idx, @diagnotone2) = rankinsert($fields[1],
629
"$ARGV[0], Row $.: $rf1",
630
2, -2, 0, $dno2idx, @diagnotone2)
631
unless $rfignore{$rf1};
632
! $opt_s && print STDERR "$ARGV[0], Row $.: Diagonal element is" .
633
" not equal to 1: M[" .
634
($rfnames2{$rf1}) . "," . ($rfnames2{$rf2}) . "] == " .
635
$fields[1] . ".\n";
636
}
637
}
638
​
639
if (! $all_rfnames_read) {
640
$names2[$i] = $rf1;
641
if (defined $rfnames2{$rf1}) {
642
print STDERR "$ARGV[0], Row $.: risk factor \"$rf1\" already exists.\n";
643
} else {
644
$rfnames2{$rf1} = $i++;
645
}
646
} else {
647
# Risk factor order left->right (top row) == top->bottom (leftmost column)?
648
if (! (defined $rfnames2{$rf1})) {
649
print STDERR "$ARGV[0], Row $.: risk factor \"$rf1\" does not exist.\n";
650
}
651
if (! (defined $rfnames2{$rf2})) {
652
print STDERR "$ARGV[0], Row $.: risk factor \"$rf2\" does not exist.\n";
653
}
654
}
655
​
656
# No NC category (warning if there is)?
657
! $opt_n && ! $opt_s && get_rf_category($rf1) eq "NC" &&
658
print STDERR "$ARGV[0], Row $.: risk factor $rf1 is linked to category NC.\n";
659
! $opt_n && ! $opt_s && get_rf_category($rf2) eq "NC" &&
660
print STDERR "$ARGV[0], Row $.: risk factor $rf2 is linked to category NC.\n";
661
​
662
# Please note that we only fill triangle above diagonal
663
$m2[$rfnames2{$rf2} - 1][$rfnames2{$rf1} - 1] = $fields[1];
664
defined $opt_d && $opt_d > 2 && print "Matrix2[" . $rfnames2{$rf2} .
665
"][$rfnames2{$rf1}]=" . $fields[1] . "\n";
666
}
667
​
668
# Matrix quadratic?
669
if (scalar(@names2) != sqrt(2*$. - 3.75) + 0.5) {
670
print STDERR "$ARGV[0]: matrix is not quadratic: # of columns (" . scalar(@names2) .
671
") != # of rows (" . (sqrt(2*$. - 3.75) + 0.5) . ")!\n";
672
# exit(1);
673
}
674
​
675
}
676
​
677
close(FILE);
678
​
679
! $opt_s && $dno2idx && printarr("Diagonal in matrix 2 not 1:", $dno2idx, @diagnotone2);
680
​
681
# Warn about risk factors which are in first matrix but not in second
682
foreach (keys %rfnames1) {
683
if (! defined $rfnames2{$_}) {
684
print STDERR "Risk factors in $m1name but not in $ARGV[0]\n";
685
last;
686
}
687
}
688
foreach (keys %rfnames1) {
689
if (! defined $rfnames2{$_}) {
690
if ($_ eq $rftrans{$_}) {
691
print STDERR $rftrans{$_} . "\n";
692
} else {
693
print STDERR $rftrans{$_} . ",$_\n";
694
}
695
}
696
}
697
​
698
# Warn about risk factors which are in second matrix but not in first
699
foreach (keys %rfnames2) {
700
if (! defined $rfnames1{$_}) {
701
print STDERR "Risk factors in $ARGV[0] but not in $m1name\n";
702
last;
703
}
704
}
705
foreach (keys %rfnames2) {
706
if (! defined $rfnames1{$_}) {
707
print STDERR $_ . "\n";
708
}
709
}
710
​
711
###########################################################
712
# #
713
# 3. Compare Matrices #
714
# #
715
###########################################################
716
​
717
# Calculate differences
718
defined $opt_d && $opt_d > 2 && print "#Rows=" . scalar(@names1) . "\n";
719
for ($i=0; $i<scalar(@names1); $i++) {
720
defined $opt_d && $opt_d > 2 && print "Row," . $i . ",Start\n";
721
defined $opt_d && $opt_d > 2 && print "#Columns=" . scalar(@names1) . "\n";
722
for ($j=$i; $j<scalar(@names1); $j++) {
723
defined $opt_d && $opt_d > 2 && print "Row," . $i . ",Column," . $j . ",Start\n";
724
if (defined $names1[$i + 1] && defined $names1[$j + 1] &&
725
defined $rfnames2{$names1[$i + 1]} && defined $rfnames2{$names1[$j + 1]}) {
726
$m2val = $m2[min($rfnames2{$names1[$i + 1]} - 1,
727
$rfnames2{$names1[$j + 1]} - 1)][max($rfnames2{$names1[$i + 1]} - 1,
728
$rfnames2{$names1[$j + 1]} - 1)];
729
$m3[$i][$j] = $m2val - $m1[$i][$j];
730
if (defined $hashtnames{$names1[$i + 1]} && defined $hashtnames{$names1[$j + 1]}) {
731
$t = $tol[min($hashtnames{$names1[$i + 1]} - 1,
732
$hashtnames{$names1[$j + 1]} - 1)][max($hashtnames{$names1[$i + 1]} - 1,
733
$hashtnames{$names1[$j + 1]} - 1)];
734
} else {
735
$t = 0;
736
}
737
defined $opt_d && $opt_d > 2 && print "Matrix3[" . $i .
738
"][$j]=" . $m3[$i][$j] . ",Tol=$t\n";
739
($tdidx, @totaldiff) = rankinsert($m3[$i][$j],
740
get_rf_category($names1[$i + 1]) . ",$names1[$i + 1]," .
741
get_rf_category($names1[$j + 1]) . ",$names1[$j + 1]," .
742
$m1[$i][$j] . "," . $m2val,
743
$devglobal[0], $devglobal[1], $t,
744
$tdidx, @totaldiff)
745
unless $rfignore{$names1[$i + 1]} || $rfignore{$names1[$j + 1]};
746
# If you like to understand the next statement please have a look at
747
# http://perldoc.perl.org/perllol.html
748
($rfcatidx{get_rf_category($names1[$i + 1])},
749
@{$rfcatrank{get_rf_category($names1[$i + 1])}}) = rankinsert($m3[$i][$j],
750
get_rf_category($names1[$i + 1]) . ",$names1[$i + 1]," .
751
get_rf_category($names1[$j + 1]) . ",$names1[$j + 1]," .
752
$m1[$i][$j] . "," . $m2val,
753
$devrfcat{get_rf_category($names1[$i + 1])}[0],
754
$devrfcat{get_rf_category($names1[$i + 1])}[1], $t,
755
$rfcatidx{get_rf_category($names1[$i + 1])},
756
@{$rfcatrank{get_rf_category($names1[$i + 1])}})
757
unless $rfignore{$names1[$i + 1]} || $rfignore{$names1[$j + 1]};
758
if (get_rf_category($names1[$i + 1]) ne get_rf_category($names1[$j + 1])) {
759
($rfcatidx{get_rf_category($names1[$j + 1])},
760
@{$rfcatrank{get_rf_category($names1[$j + 1])}}) =
761
rankinsert($m3[$i][$j],
762
get_rf_category($names1[$i + 1]) . ",$names1[$i + 1]," .
763
get_rf_category($names1[$j + 1]) . ",$names1[$j + 1]," .
764
$m1[$i][$j] . "," . $m2val,
765
$devrfcat{get_rf_category($names1[$j + 1])}[0],
766
$devrfcat{get_rf_category($names1[$j + 1])}[1], $t,
767
$rfcatidx{get_rf_category($names1[$j + 1])},
768
@{$rfcatrank{get_rf_category($names1[$j + 1])}})
769
unless $rfignore{$names1[$i + 1]} || $rfignore{$names1[$j + 1]};
770
}
771
$rfcpairidx{get_rf_category($names1[$i + 1]) . "," .
772
get_rf_category($names1[$j + 1])} ||= 0;
773
($rfcpairidx{get_rf_category($names1[$i + 1]) . "," .
774
get_rf_category($names1[$j + 1])},
775
@{$rfcpairrank{get_rf_category($names1[$i + 1]) . "," .
776
get_rf_category($names1[$j + 1])}}) = rankinsert($m3[$i][$j],
777
get_rf_category($names1[$i + 1]) . ",$names1[$i + 1]," .
778
get_rf_category($names1[$j + 1]) . ",$names1[$j + 1]," .
779
$m1[$i][$j] . "," . $m2val,
780
$devrfcpair{get_rf_category($names1[$i + 1]) . "," .
781
get_rf_category($names1[$j + 1])}[0],
782
$devrfcpair{get_rf_category($names1[$i + 1]) . "," .
783
get_rf_category($names1[$j + 1])}[1], $t,
784
$rfcpairidx{get_rf_category($names1[$i + 1]) . "," .
785
get_rf_category($names1[$j + 1])},
786
@{$rfcpairrank{get_rf_category($names1[$i + 1]) . "," .
787
get_rf_category($names1[$j + 1])}})
788
unless $rfignore{$names1[$i + 1]} || $rfignore{$names1[$j + 1]};
789
$ccy = substr($names1[$i + 1], 0, 3);
790
$rfcccyidx{$ccy} ||= 0;
791
($rfcccyidx{$ccy}, @{$rfcccyrank{$ccy}}) = rankinsert($m3[$i][$j],
792
get_rf_category($names1[$i + 1]) . ",$names1[$i + 1]," .
793
get_rf_category($names1[$j + 1]) . ",$names1[$j + 1]," .
794
$m1[$i][$j] . "," . $m2val,
795
$devccy{$ccy}[0], $devccy{$ccy}[1], $t,
796
$rfcccyidx{$ccy}, @{$rfcccyrank{$ccy}})
797
unless $rfignore{$names1[$i + 1]} || $rfignore{$names1[$j + 1]};
798
if ($ccy ne substr($names1[$j + 1], 0, 3)) {
799
$ccy = substr($names1[$j + 1], 0, 3);
800
$rfcccyidx{$ccy} ||= 0;
801
($rfcccyidx{$ccy}, @{$rfcccyrank{$ccy}}) = rankinsert($m3[$i][$j],
802
get_rf_category($names1[$i + 1]) . ",$names1[$i + 1]," .
803
get_rf_category($names1[$j + 1]) . ",$names1[$j + 1]," .
804
$m1[$i][$j] . "," . $m2val,
805
$devccy{$ccy}[0], $devccy{$ccy}[1], $t,
806
$rfcccyidx{$ccy}, @{$rfcccyrank{$ccy}})
807
unless $rfignore{$names1[$i + 1]} || $rfignore{$names1[$j + 1]};
808
}
809
}
810
defined $opt_d && $opt_d > 2 && print "Row," . $i . ",Column," . $j . ",End\n";
811
}
812
defined $opt_d && $opt_d > 2 && print "Row," . $i . ",End\n";
813
}
814
​
815
###########################################################
816
# #
817
# Now standard output to Stdout #
818
# #
819
###########################################################
820
​
821
print "$0,$version,";
822
print "Ignored risk factors in " . $opt_i if defined $opt_i;
823
print "\nSlice,[Category/Currency],[Category],\n";
824
print "Min/max difference";
825
print " beyond tolerance" unless ! $opt_b;
826
print ",Category 1,Risk Factor 1,Category 2,Risk Factor2,Old value,New value\n\n";
827
​
828
$tdidx && printarr("GLOBAL,,", $tdidx, @totaldiff);
829
our $rfk;
830
foreach my $rfk (sort keys %rfcatidx) {
831
$rfcatidx{$rfk} && printarr("CATEGORY,$rfk,", $rfcatidx{$rfk}, @{$rfcatrank{$rfk}});
832
}
833
foreach $rfk (sort keys %rfcccyidx) {
834
$rfcccyidx{$rfk} && printarr("CURRENCY,$rfk,", $rfcccyidx{$rfk}, @{$rfcccyrank{$rfk}});
835
}
836
foreach $rfk (sort keys %rfcpairidx) {
837
$rfcpairidx{$rfk} && printarr("CATEGORYPAIR,$rfk", $rfcpairidx{$rfk}, @{$rfcpairrank{$rfk}});
838
}
839
​
840
$opt_w && close $doutfile;
841
​
842
exit(0);
843
​
844
sub printarr {
845
# Print array. With option -w write min & max into deviation file.
846
#
847
# Version Date Author Comment
848
# 1.4 26/12/2018 Bernd Plumhoff Anonymized version
849
my ($title, $idx, @arr) = @_;
850
my $i;
851
​
852
print "$title\n";
853
for ($i=0; $i<$idx; $i++) {
854
printf STDOUT "%7.4f,%s,\n", $arr[$i][0], $arr[$i][1];
855
}
856
print "\n";
857
​
858
if (defined $opt_w && $idx > 0) {
859
# If we have min and/or max write them into deviation file.
860
# Please note that in this version of Perl (5.12.4) the standard
861
# precision of the %f format is 6 digits - which coincides with
862
# our definition of $epsilon above.
863
$arr[$opt_m][0] ||= 0;
864
$arr[$opt_m + 1][0] ||= 0;
865
$arr[$opt_m + 2][0] ||= 0;
866
printf $doutfile "%s,%.6f,%.6f,%u,%u,%u\n", $title, $arr[0][0],
867
$arr[$idx - 1][0],$arr[$opt_m][0],$arr[$opt_m + 1][0],
868
$arr[$opt_m + 2][0];
869
}
870
}
871
​
872
sub init_rf_category {
873
# Initialize risk factor hashtable with recognition patterns
874
#
875
# Synopsis: init_rf_category(RF_Category_filename)
876
#
877
# Example: init_rf_category("./RF_Categories.csv");
878
#
879
# Version Date Author Comment
880
# 1.3 26/12/2018 Bernd Plumhoff Anonymized version
881
open (FILE, "<", $_[0]);
882
while (my $rfline = <FILE>) {
883
$rfline =~ s/[\r\n]+//g;
884
if (substr($rfline,0,2) ne '//' and 4 < length($rfline)) {
885
my @rffields = split(",", $rfline);
886
my $matchpattern = $rffields[0];
887
if (substr($matchpattern,0,1) eq '#') {
888
$matchpattern = '^(.*)' . substr($matchpattern,1,length($matchpattern) - 1) . '\(T[0-9]+\)#x27;;
889
} else {
890
$matchpattern = '^(.*)\.' . $matchpattern . '#x27;;
891
}
892
$rfcatpat{$matchpattern} = $rffields[3];
893
}
894
}
895
close (FILE);
896
}
897
​
898
sub get_rf_category {
899
# Return risk factor category (Super Category - SubCategory) for a recognized pattern
900
# or "NC-NC" if no pattern matched.
901
#
902
# Synopsis: get_rf_category(Risk_Factor)
903
#
904
# Example: get_rf_category("USD.#SPREAD-CORP-BB(T1825)");
905
# will result in "MR-CS-CORP".
906
#
907
# Version Date Author Comment
908
# 1.3 26/12/2018 Bernd Plumhoff Anonymized version
909
defined $rfcat{$_[0]} && return $rfcat{$_[0]};
910
my $searchpat = $_[0];
911
my $success = "NC";
912
$searchpat =~ s/\.\#/-/; # We have to substitute ".#" by "-" in order to match the patterns
913
foreach my $pat (keys %rfcatpat) {
914
# my $temp = $searchpat =~ /$pat/;
915
# print $searchpat . " =~ \"" . $pat . "\" -> " . $temp . "\n";
916
# Please note that if this approach is too slow we can try to apply
917
# the map, study and eval commands to speed this up later.
918
# See http://perldoc.perl.org/functions/study.html, for example. [Bernd 25/01/2012]
919
# General hints to speed perl up: http://www.ccl4.org/~nick/P/Fast_Enough/
920
# [Bernd 08/03/2012]
921
$success = $rfcatpat{$pat}, last if $searchpat =~ /$pat/;
922
}
923
if ($success eq "NC") {
924
# This is a trick because the RAI regex are sometimes comparing
925
# against $ when there still is a bracket term.
926
# For example: CZK.#SWAP(T30)
927
# In this case we omit the bracket term and look up CZK.#SWAP.
928
$searchpat = substr($searchpat, 0, index($searchpat, "("));
929
foreach my $pat (keys %rfcatpat) {
930
$success = $rfcatpat{$pat}, last if $searchpat =~ /$pat/;
931
}
932
}
933
$rfcat{$_[0]} = $success; # next call will be quicker
934
$rfcatidx{$success} = 0;
935
return $success;
936
}
937
​
938
sub rankinsert {
939
# Ranks and inserts value into array and stores text with it.
940
#
941
# Synopsis: rankinsert(value, text, deviation_lower_bound, deviation_upper_bound,
942
# tolerance, arrayindex, array[][])
943
#
944
# Example: rankinsert($fields[$. - 1], "$ARGV[0], Row $.: $fields[0]", 2, -2, 0,
945
# $dno1idx, @diagnotone1);
946
#
947
# Version Date Author Comment
948
# 1.1 26/12/2018 Bernd Plumhoff Anonymized version
949
​
950
my ($value, $text, $devlb, $devub, $tol, $idx, @arr) = @_;
951
my $i;
952
my $border = int($opt_m / 2) - 1;
953
if (defined $opt_b) {
954
if ($value > $tol + $epsilon) {
955
$value -= $tol;
956
if (defined $devlb && defined $devub &&
957
($value < $devlb - $epsilon || $value > $devub + $epsilon)) {
958
return ($idx, @arr);
959
}
960
$arr[$opt_m + 2][0]++; # Tolerance overshot
961
} elsif ($value < -$tol - $epsilon) {
962
$value += $tol;
963
if (defined $devlb && defined $devub &&
964
($value < $devlb - $epsilon || $value > $devub + $epsilon)) {
965
return ($idx, @arr);
966
}
967
$arr[$opt_m + 1][0]++; # Tolerance undershot
968
} else {
969
$arr[$opt_m][0]++; # Total count for this slice
970
return ($idx, @arr);
971
}
972
} else {
973
if ($value > $tol + $epsilon) {
974
if (defined $devlb && defined $devub &&
975
($value < $devlb - $epsilon || $value > $devub + $epsilon)) {
976
return ($idx, @arr);
977
}
978
$arr[$opt_m + 2][0]++; # Tolerance overshot
979
} elsif ($value < -$tol - $epsilon) {
980
if (defined $devlb && defined $devub &&
981
($value < $devlb - $epsilon || $value > $devub + $epsilon)) {
982
return ($idx, @arr);
983
}
984
$arr[$opt_m + 1][0]++; # Tolerance undershot
985
} else {
986
$arr[$opt_m][0]++; # Total count for this slice
987
return ($idx, @arr);
988
}
989
}
990
$arr[$opt_m][0]++; # Total count for this slice
991
​
992
if ($idx >= $opt_m) {
993
# @arr has been filled already. We potentially need to throw less extreme
994
# values out and we might need to move (apply a different rank to) others.
995
$i = $border;
996
if ($value < $arr[$i][0]) {
997
# We found a small outlier
998
do {
999
if ($i < $border) {
1000
$arr[$i + 1][0] = $arr[$i][0];
1001
$arr[$i + 1][1] = $arr[$i][1];
1002
}
1003
} while (--$i >= 0 && $value < $arr[$i][0]);
1004
$arr[$i + 1][0] = $value;
1005
$arr[$i + 1][1] = $text;
1006
return ($idx, @arr);
1007
} else {
1008
$i++;
1009
if ($value > $arr[$i][0]) {
1010
# We found a big outlier
1011
while ($i + 1 < $opt_m && $value > $arr[$i + 1][0]) {
1012
$arr[$i][0] = $arr[$i + 1][0];
1013
$arr[$i][1] = $arr[$i + 1][1];
1014
$i++;
1015
}
1016
$arr[$i][0] = $value;
1017
$arr[$i][1] = $text;
1018
}
1019
}
1020
} else {
1021
# @arr is not full yet. We are sure that the new value will be inserted
1022
# but we might need to move (apply a different rank to) others.
1023
if ($idx == 0) {
1024
# Ok, it's the very first array member
1025
$arr[$idx][0] = $value;
1026
$arr[$idx++][1] = $text;
1027
} else {
1028
$i = $idx - 1;
1029
if ($value < $arr[$i][0]) {
1030
# We found a small outlier
1031
do {
1032
$arr[$i + 1][0] = $arr[$i][0];
1033
$arr[$i + 1][1] = $arr[$i][1];
1034
} while (--$i >= 0 && $value < $arr[$i][0]);
1035
$arr[$i + 1][0] = $value;
1036
$arr[$i + 1][1] = $text;
1037
} else {
1038
# A new max can simply be added at the end
1039
$i++;
1040
$arr[$i][0] = $value;
1041
$arr[$i][1] = $text;
1042
}
1043
$idx++;
1044
}
1045
}
1046
return ($idx, @arr);
1047
}
Copied!
Previous
Perl
Next
Game of Nim
Last modified 7mo ago
Copy link