code_perl/Maasha/Matrix.pm

   1 package Maasha::Matrix;
   2
   3 # Copyright (C) 2007 Martin A. Hansen.
   4
   5 # This program is free software; you can redistribute it and/or
   6 # modify it under the terms of the GNU General Public License
   7 # as published by the Free Software Foundation; either version 2
   8 # of the License, or (at your option) any later version.
   9
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program; if not, write to the Free Software
  17 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
  18
  19 # http://www.gnu.org/copyleft/gpl.html
  20
  21
  22 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> DESCRIPTION <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  23
  24
  25 # This modules contains subroutines for simple matrix manipulations.
  26
  27
  28 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  29
  30
  31 use warnings;
  32 no warnings 'recursion';
  33 use strict;
  34 use Data::Dumper;
  35 use Storable qw( dclone );
  36 use Maasha::Common;
  37 use Maasha::Filesys;
  38 use Maasha::Calc;
  39 use vars qw ( @ISA @EXPORT );
  40 use Exporter;
  41
  42 @ISA = qw( Exporter );
  43
  44 use constant {
  45     ROWS => 0,
  46     COLS => 1,
  47 };
  48
  49
  50 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> SUBROUTINES <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  51
  52
  53 sub matrix_dims
  54 {
  55     # Martin A. Hansen, April 2007
  56
  57     # returns the dimensions of a matrix: rows x cols
  58
  59     my ( $matrix,   # AoA data structure
  60        ) = @_;
  61
  62     # returns a tuple
  63
  64     my ( $rows, $cols );
  65
  66     $rows = scalar @{ $matrix };
  67     $cols = scalar @{ $matrix->[ 0 ] };
  68
  69     return wantarray ? ( $rows, $cols ) : [ $rows, $cols ];
  70 }
  71
  72
  73 sub matrix_check
  74 {
  75     # Martin A. Hansen, April 2007.
  76
  77     # Checks that the matrix of even columns.
  78     # return 1 if ok else 0.
  79
  80     my ( $matrix,      # AoA data structure
  81        ) = @_;
  82
  83     # returns boolean
  84
  85     my ( $dims, $row, $check );
  86
  87     $dims = matrix_dims( $matrix );
  88
  89     $check = $dims->[ COLS ];
  90
  91     foreach $row ( @{ $matrix } ) {
  92         return 0 if scalar @{ $row } != $check;
  93     }
  94
  95     return 1;
  96 }
  97
  98
  99 sub matrix_summary
 100 {
 101     # Martin A. Hansen, April 2007.
 102
 103     # For each column in a given matrix print:
 104
 105     my ( $matrix,   # AoA data structure
 106        ) = @_;
 107
 108     my ( $dims, $i, $col, $list, $type, $sort, $uniq, $min, $max, $mean );
 109
 110     die qq(ERROR: cannot summarize uneven matrix\n) if not matrix_check( $matrix );
 111
 112     $dims = matrix_dims( $matrix );
 113
 114     print join( "\t", "TYPE", "LEN", "UNIQ", "SORT", "MIN", "MAX", "MEAN" ), "\n";
 115
 116     for ( $i = 0; $i < $dims->[ COLS ]; $i++ )
 117     {
 118         $col  = cols_get( $matrix, $i, $i );
 119         $list = matrix_flip( $col )->[ 0 ];
 120
 121         if ( list_check_numeric( $list ) ) {
 122             $type = "num";
 123         } else {
 124             $type = "alph";
 125         }
 126
 127         if ( list_check_sort( $list, $type ) ) {
 128             $sort = "yes";
 129         } else {
 130             $sort = "no";
 131         }
 132
 133         if ( $type eq "num" )
 134         {
 135             if ( $sort eq "yes" )
 136             {
 137                 $min = $list->[ 0 ];
 138                 $max = $list->[ -1 ];
 139             }
 140             else
 141             {
 142                 ( $min, $max ) = Maasha::Calc::minmax( $list );
 143             }
 144
 145             $mean = sprintf( "%.2f", Maasha::Calc::mean( $list ) );
 146         }
 147         else
 148         {
 149             $min  = "N/A";
 150             $max  = "N/A";
 151             $mean = "N/A";
 152         }
 153
 154         $uniq = list_uniq( $list );
 155
 156         print join( "\t", $type, $dims->[ ROWS ], $uniq, $sort, $min, $max, $mean ), "\n";
 157     }
 158 }
 159
 160
 161 sub matrix_flip
 162 {
 163     # Martin A. Hansen, April 2007
 164
 165     # flips a matrix making rows to columns and visa versa.
 166
 167     my ( $matrix,   # AoA data structure
 168        ) = @_;
 169
 170     # returns AoA
 171
 172     my ( $i, $c, $dims, $AoA );
 173
 174     die qq(ERROR: cannot flip uneven matrix\n) if not matrix_check( $matrix );
 175
 176     $dims = matrix_dims( $matrix );
 177
 178     for ( $i = 0; $i < $dims->[ ROWS ]; $i++ )
 179     {
 180         for ( $c = 0; $c < $dims->[ COLS ]; $c++ ) {
 181             $AoA->[ $c ]->[ $i ] = $matrix->[ $i ]->[ $c ];
 182         }
 183     }
 184
 185     @{ $matrix } = @{ $AoA };
 186
 187     return wantarray ? @{ $matrix } : $matrix;
 188 }
 189
 190
 191 sub matrix_deflate_rows
 192 {
 193     # Martin A. Hansen, September 2009.
 194
 195     # Reduces the number of elements in all rows,
 196     # by collectiong elements in buckets that are
 197     # averaged.
 198
 199     my ( $matrix,   # AoA data structure
 200          $new_size
 201        ) = @_;
 202
 203     # Returns nothing.
 204
 205     my ( $row );
 206
 207     foreach $row ( @{ $matrix } ) {
 208         list_deflate( $row, $new_size );
 209     }
 210 }
 211
 212
 213 sub matrix_deflate_cols
 214 {
 215     # Martin A. Hansen, September 2009.
 216
 217     # Reduces the number of elements in all columns,
 218     # by collectiong elements in buckets that are
 219     # averaged.
 220
 221     my ( $matrix,   # AoA data structure
 222          $new_size
 223        ) = @_;
 224
 225     # Returns nothing.
 226
 227     my ( $col );
 228
 229     matrix_flip( $matrix );
 230
 231     foreach $col ( @{ $matrix } ) {
 232         list_deflate( $col, $new_size );
 233     }
 234
 235     matrix_flip( $matrix );
 236 }
 237
 238
 239 sub matrix_rotate_right
 240 {
 241     # Martin A. Hansen, April 2007
 242
 243     # Rotates elements in a given matrix a given
 244     # number of positions to the right by popping columns,
 245     # from the right matrix edge and prefixed to the left edge.
 246
 247     my ( $matrix,   # AoA data structure
 248          $shift,    # number of shifts - DEFAULT=1
 249        ) = @_;
 250
 251     # returns AoA
 252
 253     my ( $i, $dims, $col, $AoA );
 254
 255     $shift ||= 1;
 256
 257     die qq(ERROR: cannot right rotate uneven matrix\n) if not matrix_check( $matrix );
 258
 259     $dims = matrix_dims( $matrix );
 260
 261     for ( $i = 0; $i < $shift; $i++ )
 262     {
 263         $col = cols_get( $matrix, $dims->[ COLS ] - 1, $dims->[ COLS ] - 1 );
 264         $AoA = cols_get( $matrix, 0, $dims->[ COLS ] - 2 );
 265
 266         cols_unshift( $AoA, $col );
 267
 268         $matrix = $AoA;
 269     }
 270
 271     return wantarray ? @{ $matrix } : $matrix;
 272 }
 273
 274
 275 sub matrix_rotate_left
 276 {
 277     # Martin A. Hansen, April 2007
 278
 279     # Rotates elements in a given matrix a given
 280     # number of positions to the left while columns
 281     # are shifted from the left matrix edge and appended,
 282     # to the right edge.
 283
 284     my ( $matrix,   # AoA data structure
 285          $shift,    # number of shifts - DEFAULT=1
 286        ) = @_;
 287
 288     # returns AoA
 289
 290     my ( $i, $dims, $col, $AoA );
 291
 292     $shift ||= 1;
 293
 294     die qq(ERROR: cannot right rotate uneven matrix\n) if not matrix_check( $matrix );
 295
 296     $dims = matrix_dims( $matrix );
 297
 298     for ( $i = 0; $i < $shift; $i++ )
 299     {
 300         $col = cols_get( $matrix, 0, 0 );
 301         $AoA = cols_get( $matrix, 1, $dims->[ COLS ] - 1 );
 302
 303         cols_push( $AoA, $col );
 304
 305         $matrix = $AoA;
 306     }
 307
 308     return wantarray ? @{ $matrix } : $matrix;
 309 }
 310
 311
 312 sub matrix_rotate_up
 313 {
 314     # Martin A. Hansen, April 2007
 315
 316     # Rotates elements in a given matrix a given
 317     # number of positions up while rows are shifted
 318     # from the top of the matrix to the bottom.
 319
 320     my ( $matrix,   # AoA data structure
 321          $shift,    # number of shifts - DEFAULT=1
 322        ) = @_;
 323
 324     # returns AoA
 325
 326     my ( $dims, $i, $row, $AoA );
 327
 328     $shift ||= 1;
 329
 330     $dims = matrix_dims( $matrix );
 331
 332     for ( $i = 0; $i < $shift; $i++ )
 333     {
 334         $row = rows_get( $matrix, 0, 0 );
 335         $AoA = rows_get( $matrix, 1, $dims->[ ROWS ] - 1 );
 336
 337         rows_push( $AoA, dclone $row );
 338
 339         $matrix = $AoA;
 340     }
 341
 342     return wantarray ? @{ $matrix } : $matrix;
 343 }
 344
 345
 346 sub matrix_rotate_down
 347 {
 348     # Martin A. Hansen, April 2007
 349
 350     # Rotates elements in a given matrix a given
 351     # number of positions down while rows are shifted
 352     # from the bottom matrix edge to the top edge.
 353
 354     my ( $matrix,   # AoA data structure
 355          $shift,    # number of shifts - DEFAULT=1
 356        ) = @_;
 357
 358     # returns AoA
 359
 360     my ( $dims, $i, $row, $AoA );
 361
 362     $shift ||= 1;
 363
 364     $dims = matrix_dims( $matrix );
 365
 366     for ( $i = 0; $i < $shift; $i++ )
 367     {
 368         $row = rows_get( $matrix, $dims->[ ROWS ] - 1, $dims->[ ROWS ] - 1 );
 369         $AoA = rows_get( $matrix, 0, $dims->[ ROWS ] - 2 );
 370
 371         rows_unshift( $AoA, $row );
 372
 373         $matrix = $AoA;
 374     }
 375
 376     return wantarray ? @{ $matrix } : $matrix;
 377 }
 378
 379
 380 sub submatrix
 381 {
 382     # Martin A. Hansen, April 2007
 383
 384     # returns a submatrix sliced from a given matrix
 385
 386     my ( $matrix,    # AoA data structure
 387          $row_beg,   # first row - OPTIONAL (default 0)
 388          $row_end,   # last row  - OPTIONAL (default last row)
 389          $col_beg,   # first col - OPTIONAL (default 0)
 390          $col_end,   # last col  - OPTIONAL (default last col)
 391        ) = @_;
 392
 393     # returns AoA
 394
 395     my ( $submatrix, $subsubmatrix );
 396
 397     $submatrix    = rows_get( $matrix, $row_beg, $row_end );
 398     $subsubmatrix = cols_get( $submatrix, $col_beg, $col_end );
 399
 400     return wantarray ? @{ $subsubmatrix } : $subsubmatrix;
 401 }
 402
 403
 404 sub row_get
 405 {
 406     # Martin A. Hansen, April 2008.
 407
 408     # Returns a single row from a given matrix.
 409
 410     my ( $matrix,    # AoA data structure
 411          $row,       # row to get
 412        ) = @_;
 413
 414     # Returns a list;
 415
 416     my ( $dims, $i, @list );
 417
 418     $dims = matrix_dims( $matrix );
 419
 420     Maasha::Common::error( qq(Row->$row outside of matrix->$dims->[ ROWS ]) ) if $row > $dims->[ ROWS ];
 421
 422     @list = @{ $matrix->[ $row ] };
 423
 424     return wantarray ? @list : \@list;
 425 }
 426
 427
 428 sub rows_get
 429 {
 430     # Martin A. Hansen, April 2007
 431
 432     # returns a range of requested rows from a given matrix.
 433
 434     my ( $matrix,    # AoA data structure
 435          $row_beg,   # first row - OPTIONAL (default 0)
 436          $row_end,   # last row  - OPTIONAL (default last row)
 437        ) = @_;
 438
 439     # returns AoA
 440
 441     my ( @rows, $i );
 442
 443     $row_beg ||= 0;
 444
 445     if ( not defined $row_end ) {
 446         $row_end = scalar @{ $matrix };
 447     }
 448
 449     if ( $row_end >= scalar @{ $matrix } )
 450     {
 451         warn qq(WARNING: row end larger than matrix\n);
 452         $row_end = scalar( @{ $matrix } ) - 1;
 453     }
 454
 455     die qq(ERROR: row begin "$row_beg" larger than row end "$row_end"\n) if $row_end < $row_beg;
 456
 457     if ( $row_beg == 0 and $row_end == scalar( @{ $matrix } ) - 1 ) {
 458         @rows = @{ $matrix };
 459     } else {
 460         @rows = @{ $matrix }[ $row_beg .. $row_end ];
 461     }
 462
 463     return wantarray ? @rows : \@rows;
 464 }
 465
 466
 467 sub col_get
 468 {
 469     # Martin A. Hansen, April 2008.
 470
 471     # Returns a single column from a given matrix.
 472
 473     my ( $matrix,    # AoA data structure
 474          $col,       # column to get
 475        ) = @_;
 476
 477     # Returns a list;
 478
 479     my ( $dims, $i, @list );
 480
 481     $dims = matrix_dims( $matrix );
 482
 483     Maasha::Common::error( qq(Column->$col outside of matrix->$dims->[ COLS ]) ) if $col > $dims->[ COLS ];
 484
 485     for ( $i = 0; $i < $dims->[ ROWS ]; $i++ ) {
 486         push @list, $matrix->[ $i ]->[ $col ];
 487     }
 488
 489     return wantarray ? @list : \@list;
 490 }
 491
 492
 493 sub cols_get
 494 {
 495     # Martin A. Hansen, April 2007.
 496
 497     # returns a range of requested columns from a given matrix
 498
 499     my ( $matrix,    # AoA data structure
 500          $col_beg,   # first column - OPTIONAL (default 0)
 501          $col_end,   # last column  - OPTIONAL (default last column)
 502        ) = @_;
 503
 504     # returns AoA
 505
 506     my ( $dims, @cols, $row, @AoA );
 507
 508     $dims = matrix_dims( $matrix );
 509
 510     $col_beg ||= 0;
 511
 512     if ( not defined $col_end ) {
 513         $col_end = $dims->[ COLS ] - 1;
 514     }
 515
 516     if ( $col_end > $dims->[ COLS ] - 1 )
 517     {
 518         warn qq(WARNING: column end larger than matrix\n);
 519         $col_end = $dims->[ COLS ] - 1;
 520     }
 521
 522     die qq(ERROR: column begin "$col_beg" larger than column end "$col_end"\n) if $col_end < $col_beg;
 523
 524     if ( $col_beg == 0 and $col_end == $dims->[ COLS ] - 1 )
 525     {
 526         @AoA = @{ $matrix };
 527     }
 528     else
 529     {
 530         foreach $row ( @{ $matrix } )
 531         {
 532             @cols = @{ $row }[ $col_beg .. $col_end ];
 533
 534             push @AoA, [ @cols ];
 535         }
 536     }
 537
 538     return wantarray ? @AoA : \@AoA;
 539 }
 540
 541
 542 sub col_sum
 543 {
 544     my ( $matrix,
 545          $col,
 546        ) = @_;
 547
 548     my ( $list, $sum );
 549
 550     $list = cols_get( $matrix, $col, $col );
 551     $list = matrix_flip( $list )->[ 0 ];
 552
 553     die qq(ERROR: cannot sum non-nummerical column\n);
 554
 555     $sum = Maasha::Calc::sum( $list );
 556
 557     return $sum;
 558 }
 559
 560
 561 sub rows_push
 562 {
 563     # Martin A. Hansen, April 2007.
 564
 565     # Appends one or more rows to a matrix.
 566
 567     my ( $matrix,    # AoA data structure
 568          $rows,      # list of rows
 569        ) = @_;
 570
 571     # returns AoA
 572
 573     push @{ $matrix }, @{ $rows };
 574
 575     return wantarray ? @{ $matrix } : $matrix;
 576 }
 577
 578
 579 sub rows_unshift
 580 {
 581     # Martin A. Hansen, April 2007.
 582
 583     # Prefixes one or more rows to a matrix.
 584
 585     my ( $matrix,    # AoA data structure
 586          $rows,      # list of rows
 587        ) = @_;
 588
 589     # returns AoA
 590
 591     unshift @{ $matrix }, @{ $rows };
 592
 593     return wantarray ? @{ $matrix } : $matrix;
 594 }
 595
 596
 597 sub cols_push
 598 {
 599     # Martin A. Hansen, April 2007.
 600
 601     # Appends one or more lists as columns to a matrix.
 602
 603     my ( $matrix,    # AoA data structure
 604          $cols,      # list of columns
 605        ) = @_;
 606
 607     # returns AoA
 608
 609     my ( $dims_matrix, $dims_cols, $i );
 610
 611     $dims_matrix = matrix_dims( $matrix );
 612     $dims_cols   = matrix_dims( $cols );
 613
 614     die qq(ERROR: Cannot merge columns with different row count\n) if $dims_matrix->[ ROWS ] != $dims_cols->[ ROWS ];
 615
 616     for ( $i = 0; $i < $dims_matrix->[ ROWS ]; $i++ )
 617     {
 618         push @{ $matrix->[ $i ] }, @{ $cols->[ $i ] };
 619     }
 620
 621     return wantarray ? @{ $matrix } : $matrix;
 622 }
 623
 624
 625 sub cols_unshift
 626 {
 627     # Martin A. Hansen, April 2007.
 628
 629     # Prefixes one or more lists as columns to a matrix.
 630
 631     my ( $matrix,    # AoA data structure
 632          $cols,      # list of columns
 633        ) = @_;
 634
 635     # returns AoA
 636
 637     my ( $dims_matrix, $dims_cols, $i );
 638
 639     $dims_matrix = matrix_dims( $matrix );
 640     $dims_cols   = matrix_dims( $cols );
 641
 642     die qq(ERROR: Cannot merge columns with different row count\n) if $dims_matrix->[ ROWS ] != $dims_cols->[ ROWS ];
 643
 644     for ( $i = 0; $i < $dims_matrix->[ ROWS ]; $i++ ) {
 645         unshift @{ $matrix->[ $i ] }, @{ $cols->[ $i ] };
 646     }
 647
 648     return wantarray ? @{ $matrix } : $matrix;
 649 }
 650
 651
 652 sub rows_rotate_left
 653 {
 654     # Martin A. Hansen, April 2007.
 655
 656     # Given a matrix and a range of rows, rotates these rows
 657     # left by shifting a given number of elements from
 658     # the first position to the last.
 659
 660     my ( $matrix,    # AoA data structure
 661          $beg,       # first row to shift
 662          $end,       # last row to shit
 663          $shift,     # number of shifts - DEFAULT=1
 664        ) = @_;
 665
 666     # returns AoA
 667
 668     my ( $i, $c, $row );
 669
 670     $shift ||= 1;
 671
 672     for ( $i = $beg; $i <= $end; $i++ )
 673     {
 674         $row = rows_get( $matrix, $i, $i );
 675
 676         for ( $c = 0; $c < $shift; $c++ )
 677         {
 678             $row = list_rotate_left( @{ $row } );
 679             $matrix->[ $i ] = $row;
 680         }
 681     }
 682
 683     return wantarray ? @{ $matrix } : $matrix;
 684 }
 685
 686
 687 sub rows_rotate_right
 688 {
 689     # Martin A. Hansen, April 2007.
 690
 691     # Given a matrix and a range of rows, rotates these rows
 692     # right by shifting a given number of elements from the
 693     # last position to the first.
 694
 695     my ( $matrix,    # AoA data structure
 696          $beg,       # first row to shift
 697          $end,       # last row to shit
 698          $shift,     # number of shifts - DEFAULT=1
 699        ) = @_;
 700
 701     # returns AoA
 702
 703     my ( $dims, $i, $c, $row );
 704
 705     $shift ||= 1;
 706
 707     $dims = matrix_dims( $matrix );
 708
 709     die qq(ERROR: end < beg: $end < $beg\n) if $end < $beg;
 710     die qq(ERROR: row outside matrix\n)     if $end >= $dims->[ ROWS ];
 711
 712     for ( $i = $beg; $i <= $end; $i++ )
 713     {
 714         $row = rows_get( $matrix, $i, $i );
 715
 716         for ( $c = 0; $c < $shift; $c++ )
 717         {
 718             $row = list_rotate_right( @{ $row } );
 719             $matrix->[ $i ] = $row;
 720         }
 721     }
 722
 723     return wantarray ? @{ $matrix } : $matrix;
 724 }
 725
 726
 727 sub cols_rotate_up
 728 {
 729     # Martin A. Hansen, April 2007.
 730
 731     # Given a matrix and a range of columns, rotates these columns
 732     # ups by shifting the the first cell of each row from the
 733     # first position to the last.
 734
 735     my ( $matrix,    # AoA data structure
 736          $beg,       # first row to shift
 737          $end,       # last row to shit
 738          $shift,     # number of shifts - DEFAULT=1
 739        ) = @_;
 740
 741     # returns AoA
 742
 743     my ( $dims, $i, $c, $cols_pre, $col_select, $cols_post, $list );
 744
 745     $shift ||= 1;
 746
 747     $dims = matrix_dims( $matrix );
 748
 749     $cols_pre  = cols_get( $matrix, 0, $beg - 1 ) if $beg > 0;
 750     $cols_post = cols_get( $matrix, $end + 1, $dims->[ COLS ] - 1 ) if $end < $dims->[ COLS ] - 1;
 751
 752     for ( $i = $beg; $i <= $end; $i++ )
 753     {
 754         $col_select = cols_get( $matrix, $i, $i );
 755
 756         $list = matrix_flip( $col_select )->[ 0 ];
 757
 758         for ( $c = 0; $c < $shift; $c++ ) {
 759             $list = list_rotate_left( $list );
 760         }
 761
 762         $col_select = matrix_flip( [ $list ] );
 763
 764         if ( $cols_pre ) {
 765             cols_push( $cols_pre, $col_select );
 766         } else {
 767             $cols_pre = $col_select;
 768         }
 769     }
 770
 771     cols_push( $cols_pre, $cols_post ) if $cols_post;
 772
 773     $matrix = $cols_pre;
 774
 775     return wantarray ? @{ $matrix } : $matrix;
 776 }
 777
 778
 779 sub cols_rotate_down
 780 {
 781     # Martin A. Hansen, April 2007.
 782
 783     # Given a matrix and a range of columns, rotates these columns
 784     # ups by shifting the the first cell of each row from the
 785     # first position to the last.
 786
 787     my ( $matrix,    # AoA data structure
 788          $beg,       # first row to shift
 789          $end,       # last row to shit
 790          $shift,     # number of shifts - DEFAULT=1
 791        ) = @_;
 792
 793     # returns AoA
 794
 795     my ( $dims, $i, $c, $cols_pre, $col_select, $cols_post, $list );
 796
 797     $shift ||= 1;
 798
 799     $dims = matrix_dims( $matrix );
 800
 801     $cols_pre  = cols_get( $matrix, 0, $beg - 1 ) if $beg > 0;
 802     $cols_post = cols_get( $matrix, $end + 1, $dims->[ COLS ] - 1 ) if $end < $dims->[ COLS ] - 1;
 803
 804     for ( $i = $beg; $i <= $end; $i++ )
 805     {
 806         $col_select = cols_get( $matrix, $i, $i );
 807
 808         $list = matrix_flip( $col_select )->[ 0 ];
 809
 810         for ( $c = 0; $c < $shift; $c++ ) {
 811             $list = list_rotate_right( $list );
 812         }
 813
 814         $col_select = matrix_flip( [ $list ] );
 815
 816         if ( $cols_pre ) {
 817             cols_push( $cols_pre, $col_select );
 818         } else {
 819             $cols_pre = $col_select;
 820         }
 821     }
 822
 823     cols_push( $cols_pre, $cols_post ) if $cols_post;
 824
 825     $matrix = $cols_pre;
 826
 827     return wantarray ? @{ $matrix } : $matrix;
 828 }
 829
 830
 831 sub list_rotate_left
 832 {
 833     # Martin A. Hansen, April 2007.
 834
 835     # given a list, shifts off the first element,
 836     # and appends to the list, which is returned.
 837
 838     my ( $list,   # list to rotate
 839        ) = @_;
 840
 841     my ( @new_list, $elem );
 842
 843     @new_list = @{ $list };
 844
 845     $elem = shift @new_list;
 846
 847     push @new_list, $elem;
 848
 849     return wantarray ? @new_list : \@new_list;
 850 }
 851
 852
 853 sub list_rotate_right
 854 {
 855     # Martin A. Hansen, April 2007.
 856
 857     # given a list, pops off the last element,
 858     # and prefixes to the list, which is returned.
 859
 860     my ( $list,   # list to rotate
 861        ) = @_;
 862
 863     my ( @new_list, $elem );
 864
 865     @new_list = @{ $list };
 866
 867     $elem = pop @new_list;
 868
 869     unshift @new_list, $elem;
 870
 871     return wantarray ? @new_list : \@new_list;
 872 }
 873
 874
 875 sub list_check_numeric
 876 {
 877     # Martin A. Hansen, April 2007.
 878
 879     # Checks if a given list only contains
 880     # numerical elements. return 1 if numerical,
 881     # else 0.
 882
 883     my ( $list,   # list to check
 884        ) = @_;
 885
 886     # returns integer
 887
 888     my ( $elem );
 889
 890     foreach $elem ( @{ $list } ) {
 891         return 0 if not Maasha::Calc::is_a_number( $elem );
 892     }
 893
 894     return 1;
 895 }
 896
 897
 898 sub list_check_sort
 899 {
 900     # Martin A. Hansen, April 2007.
 901
 902     # Checks if a given list is sorted.
 903     # If the sort type is not specified, we
 904     # are going to check the type and make a guess.
 905     # Returns 1 if sorted else 0.
 906
 907     my ( $list,   # list to check
 908          $type,   # numerical of alphabetical
 909        ) = @_;
 910
 911     # returns integer
 912
 913     my ( $i, $cmp );
 914
 915     if ( not $type )
 916     {
 917         if ( list_check_numeric( $list ) ) {
 918             $type = "n";
 919         } else {
 920             $type = "a";
 921         }
 922     }
 923     else
 924     {
 925         if ( $type =~ /^a.*/i ) {
 926             $type = "a";
 927         } else {
 928             $type = "n";
 929         }
 930     }
 931
 932     if ( @{ $list } > 1 )
 933     {
 934         if ( $type eq "n" )
 935         {
 936             for ( $i = 1; $i < @{ $list }; $i++ )
 937             {
 938                 $cmp = $list->[ $i - 1 ] <=> $list->[ $i ];
 939
 940                 return 0 if $cmp > 0;
 941             }
 942         }
 943         else
 944         {
 945             for ( $i = 1; $i < @{ $list }; $i++ )
 946             {
 947                 $cmp = $list->[ $i - 1 ] cmp $list->[ $i ];
 948
 949                 return 0 if $cmp > 0;
 950             }
 951         }
 952     }
 953
 954     return 1;
 955 }
 956
 957
 958 sub list_deflate
 959 {
 960     # Martin A. Hansen, February 2010.
 961
 962     # Deflates a list of values to a specified size.
 963
 964     my ( $list,
 965          $new_size,
 966        ) = @_;
 967
 968     # Returns nothing.
 969
 970     my ( $len, $l_len, $r_len, $diff, $block_size, $space, $i );
 971
 972     while ( scalar @{ $list } > $new_size )
 973     {
 974         $len        = @{ $list };
 975         $diff       = $len - $new_size;
 976         $block_size = int( $len / $new_size );
 977
 978         if ( $block_size > 1 )
 979         {
 980             for ( $i = @{ $list } - $block_size; $i >= 0; $i -= $block_size ) {
 981                 splice @{ $list }, $i, $block_size, Maasha::Calc::mean( [ @{ $list }[ $i .. $i + $block_size - 1 ] ] );
 982             }
 983         }
 984         else
 985         {
 986              $space = $len / $diff;
 987
 988              if ( ( $space % 2 ) == 0 )
 989              {
 990                  splice @{ $list }, $len / 2 - 1, 2, Maasha::Calc::mean( [ @{ $list }[ $len / 2 - 1 .. $len / 2 ] ] );
 991              }
 992              else
 993              {
 994                  $l_len = $len * ( 1 / 3 );
 995                  $r_len = $len * ( 2 / 3 );
 996
 997                  splice @{ $list }, $r_len, 2, Maasha::Calc::mean( [ @{ $list }[ $r_len .. $r_len + 1 ] ] );
 998                  splice @{ $list }, $l_len, 2, Maasha::Calc::mean( [ @{ $list }[ $l_len .. $l_len + 1 ] ] ) if @{ $list } > $new_size;
 999              }
1000         }
1001     }
1002 }
1003
1004
1005 sub list_inflate
1006 {
1007     # Martin A. Hansen, February 2010.
1008
1009     # Inflates a list of values to a specified size. Newly
1010     # introduced elements are interpolated from neighboring elements.
1011
1012     my ( $list,
1013          $new_size,
1014        ) = @_;
1015
1016     # Returns nothing.
1017
1018     my ( $len, $diff, $block_size, $space, $i );
1019
1020     while ( $new_size - scalar @{ $list } > 0 )
1021     {
1022         $len        = @{ $list };
1023         $diff       = $new_size - $len;
1024         $block_size = int( $diff / ( $len - 1 ) );
1025
1026         if ( $block_size > 0 )
1027         {
1028             for ( $i = 1; $i < @{ $list }; $i += $block_size + 1 ) {
1029                 splice @{ $list }, $i, 0, interpolate( $list->[ $i - 1 ], $list->[ $i ], $block_size );
1030             }
1031         }
1032         else
1033         {
1034             $space = $len / $diff;
1035
1036             if ( ( $space % 2 ) == 0 )
1037             {
1038                 splice @{ $list }, $len / 2, 0, interpolate( $list->[ $len / 2 ], $list->[ $len / 2 + 1 ], 1 );
1039             }
1040             else
1041             {
1042                 splice @{ $list }, $len * ( 2 / 3 ), 0, interpolate( $list->[ $len * ( 2 / 3 ) ], $list->[ $len * ( 2 / 3 ) + 1 ], 1 );
1043                 splice @{ $list }, $len * ( 1 / 3 ), 0, interpolate( $list->[ $len * ( 1 / 3 ) ], $list->[ $len * ( 1 / 3 ) + 1 ], 1 ) if @{ $list } < $new_size;
1044             }
1045         }
1046     }
1047 }
1048
1049
1050 sub interpolate
1051 {
1052     # Martin A. Hansen, March 2010
1053
1054     # Given two values insert a specified number of values evenly
1055     # between these NOT encluding the given values.
1056
1057     my ( $beg,     # Begin of interval
1058          $end,     # End of interval
1059          $count,   # Number of values to introduce
1060        ) = @_;
1061
1062     # Returns a list
1063
1064     my ( $diff, $factor, $i, @list );
1065
1066     $diff   = $end - $beg;
1067
1068     $factor = $diff / ( $count + 1 );
1069
1070     for ( $i = 1; $i <= $count; $i++ ) {
1071         push @list, $beg + $i * $factor;
1072     }
1073
1074     return wantarray ? @list : \@list;
1075 }
1076
1077
1078 sub list_uniq
1079 {
1080     # Martin A. Hansen, April 2007.
1081
1082     # returns the number of unique elements in a
1083     # given list.
1084
1085     my ( $list,   # list
1086        ) = @_;
1087
1088     # returns integer
1089
1090     my ( %hash, $count );
1091
1092     map { $hash{ $_ } = 1 } @{ $list };
1093
1094     $count = scalar keys %hash;
1095
1096     return $count;
1097 }
1098
1099
1100 sub tabulate
1101 {
1102     # Martin A. Hansen, April 2007.
1103
1104     my ( $matrix,    # AoA data structure
1105          $col,
1106        ) = @_;
1107
1108     my ( $dims, $list, $i, $max, $len, %hash, $elem, @list );
1109
1110     $dims = matrix_dims( $matrix );
1111
1112     $list = cols_get( $matrix, $col, $col );
1113     $list = matrix_flip( $list )->[ 0 ];
1114
1115     $max = 0;
1116
1117     for ( $i = 0; $i < @{ $list }; $i++ )
1118     {
1119         $hash{ $list->[ $i ] }++;
1120
1121         $len = length $list->[ $i ];
1122
1123         $max = $len if $len > $max;
1124     }
1125
1126     @list = keys %hash;
1127
1128     if ( list_check_numeric( $list ) ) {
1129         @list = sort { $a <=> $b } @list;
1130     } else {
1131         @list = sort { $a cmp $b } @list;
1132     }
1133
1134     foreach $elem ( @list )
1135     {
1136         print $elem, " " x ( $max - length( $elem ) ),
1137         sprintf( "   %6s   ", $hash{ $elem } ),
1138         sprintf( "%.2f\n", ( $hash{ $elem } / $dims->[ ROWS ] ) * 100 );
1139     }
1140 }
1141
1142
1143 sub merge_tabs
1144 {
1145     # Martin A. Hansen, July 2008.
1146
1147     # Merge two given tables based on identifiers in a for each table
1148     # specified column which should contain a unique identifier.
1149     # Initially the tables are sorted and tab2 is merged onto tab1
1150     # row-wise.
1151
1152     my ( $tab1,       # table 1 - an AoA.
1153          $tab2,       # table 2 - an AoA.
1154          $col1,       # identifier in row1
1155          $col2,       # identifier in row2
1156          $sort_type,  # alphabetical or numeric comparison
1157        ) = @_;
1158
1159     # Returns nothing.
1160
1161     my ( $num, $cmp, $i, $c, @row_cpy, $max );
1162
1163     $max = 0;
1164     $num = 0;
1165
1166     if ( $sort_type =~ /num/i )
1167     {
1168         $num = 1;
1169
1170         @{ $tab1 } = sort { $a->[ $col1 ] <=> $b->[ $col1 ] } @{ $tab1 };
1171         @{ $tab2 } = sort { $a->[ $col2 ] <=> $b->[ $col2 ] } @{ $tab2 };
1172     }
1173     else
1174     {
1175         @{ $tab1 } = sort { $a->[ $col1 ] cmp $b->[ $col1 ] } @{ $tab1 };
1176         @{ $tab2 } = sort { $a->[ $col2 ] cmp $b->[ $col2 ] } @{ $tab2 };
1177     }
1178
1179     $i = 0;
1180     $c = 0;
1181
1182     while ( $i < @{ $tab1 } and $c < @{ $tab2 } )
1183     {
1184         if ( $num ) {
1185             $cmp = $tab1->[ $i ]->[ $col1 ] <=> $tab2->[ $c ]->[ $col2 ];
1186         } else {
1187             $cmp = $tab1->[ $i ]->[ $col1 ] cmp $tab2->[ $c ]->[ $col2 ];
1188         }
1189
1190         if ( $cmp == 0 )
1191         {
1192             @row_cpy = @{ $tab2->[ $c ] };
1193
1194             splice @row_cpy, $col2, 1;
1195
1196             push @{ $tab1->[ $i ] }, @row_cpy;
1197
1198             $i++;
1199             $c++;
1200         }
1201         elsif ( $cmp > 0 )
1202         {
1203             $c++;
1204         }
1205         else
1206         {
1207             map { push @{ $tab1->[ $i ] }, "null" } 0 .. ( scalar @{ $tab2->[ $c ] } - 2 );
1208
1209             $i++;
1210         }
1211     }
1212
1213     map { push @{ $tab1->[ -1 ] }, "null" } 0 .. ( scalar @{ $tab1->[ 0 ] } - scalar @{ $tab1->[ -1 ] } + 1 );
1214 }
1215
1216
1217 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> BINARY SEARCH <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
1218
1219
1220 sub interval_search
1221 {
1222     # Martin A. Hansen, February 2008.
1223
1224     # Uses binary search to locate the interval containing a
1225     # given number. The intervals are defined by begin and end
1226     # positions in seperate columns in a matrix. If a interval is
1227     # found then the index of that matrix row is returned, otherwise
1228     # -1 is returned.
1229
1230     my ( $matrix,   # data structure
1231          $col1,     # column with interval begins
1232          $col2,     # column with interval ends
1233          $num,      # number to search for
1234        ) = @_;
1235
1236     # Returns an integer.
1237
1238     my ( $high, $low, $try );
1239
1240     $low  = 0;
1241     $high = @{ $matrix };
1242
1243     while ( $low < $high )
1244     {
1245         $try = int( ( $high + $low ) / 2 );
1246
1247         # print "num->$num   low->$low   high->$high   try->$try   int1->$matrix->[ $try ]->[ $col1 ]   int2->$matrix->[ $try ]->[ $col2 ]\n";
1248
1249         if ( $num < $matrix->[ $try ]->[ $col1 ] ) {
1250             $high = $try;
1251         } elsif ( $num > $matrix->[ $try ]->[ $col2 ] ) {
1252             $low = $try + 1;
1253         } else {
1254             return $try;
1255         }
1256     }
1257
1258     return -1;
1259 }
1260
1261
1262 sub list_search
1263 {
1264     # Martin A. Hansen, February 2008.
1265
1266     # Uses binary search to locate a number in a list of numbers.
1267     # If the number is found, then the index (the position of the number
1268     # in the list) is returned, otherwise -1 is returned.
1269
1270     my ( $list,   # list of numbers
1271          $num,    # number to search for
1272        ) = @_;
1273
1274     # Returns an integer.
1275
1276     my ( $high, $low, $try );
1277
1278     $low  = 0;
1279     $high = @{ $list };
1280
1281     while ( $low < $high )
1282     {
1283         $try = int( ( $high + $low ) / 2 );
1284
1285         # print "num->$num   low->$low   high->$high   try->$try   int->$list->[ $try ]\n";
1286
1287         if ( $num < $list->[ $try ] ) {
1288             $high = $try;
1289         } elsif ( $num > $list->[ $try ] ) {
1290             $low = $try + 1;
1291         } else {
1292             return $try;
1293         }
1294     }
1295
1296     return -1;
1297 }
1298
1299
1300 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> DISK SUBROUTINES <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
1301
1302
1303 sub matrix_read
1304 {
1305     # Martin A. Hansen, April 2007
1306
1307     # Reads tabular data from file into a matrix
1308     # AoA data structure.
1309
1310     my ( $path,        # full path to file with data
1311          $delimiter,   # column delimiter - OPTIONAL (default tab)
1312          $comments,    # regex for comment lines to skip - OPTIONAL
1313          $fields_ok,   # list of fields to accept        - OPTIONAL
1314        ) = @_;
1315
1316     # returns AoA
1317
1318     my ( $fh, $line, @fields, @AoA );
1319
1320     $delimiter ||= "\t";
1321
1322     $fh = Maasha::Filesys::file_read_open( $path );
1323
1324     while ( $line = <$fh> )
1325     {
1326         chomp $line;
1327
1328         next if $comments and $line =~ /^$comments/;
1329
1330         @fields = split /$delimiter/, $line;
1331
1332         map { splice( @fields, $_, 1 ) } @{ $fields_ok } if $fields_ok;
1333
1334         push @AoA, [ @fields ];
1335     }
1336
1337     close $fh;
1338
1339     return wantarray ? @AoA : \@AoA;
1340 }
1341
1342
1343 sub matrix_write
1344 {
1345     # Martin A. Hansen, April 2007
1346
1347     # Writes a tabular data structure to STDOUT or file.
1348
1349     my ( $matrix,      # AoA data structure
1350          $path,        # full path to output file - OPTIONAL (default STDOUT)
1351          $delimiter,   # column delimiter         - OPTIONAL (default tab)
1352        ) = @_;
1353
1354     my ( $fh, $row );
1355
1356     $fh = Maasha::Filesys::file_write_open( $path ) if $path;
1357
1358     $delimiter ||= "\t";
1359
1360     foreach $row ( @{ $matrix } )
1361     {
1362         if ( $fh ) {
1363             print $fh join( $delimiter, @{ $row } ), "\n";
1364         } else {
1365             print join( $delimiter, @{ $row } ), "\n";
1366         }
1367     }
1368
1369     close $fh if $fh;
1370 }
1371
1372
1373 sub matrix_store
1374 {
1375     # Martin A. Hansen, April 2007.
1376
1377     # stores a matrix to a binary file.
1378
1379     my ( $path,      # full path to file
1380          $matrix,    # data structure
1381        ) = @_;
1382
1383     Maasha::Filesys::file_store( $path, $matrix );
1384 }
1385
1386
1387 sub matrix_retrive
1388 {
1389     # Martin A. Hansen, April 2007.
1390
1391     # retrieves a matrix from a binary file
1392
1393     my ( $path,   # full path to file
1394        ) = @_;
1395
1396     my $matrix = Maasha::Filesys::file_retrieve( $path );
1397
1398     return wantarray ? @{ $matrix } : $matrix;
1399 }
1400
1401
1402 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
1403
1404
1405 __END__