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, September 2009.
 961
 962     # Deflates a list of values to a specified size
 963     # and at the same time average the values.
 964
 965     my ( $list,       # list to deflate
 966          $new_size,   # new number of elements in list
 967        ) = @_;
 968
 969     # Returns nothing.
 970
 971     my ( $bin_size, $i, @new_list );
 972
 973     Maasha::Common::error( qq(new_size->$new_size must be a positive integer) ) if $new_size < 1;
 974     Maasha::Common::error( qq(new_size->$new_size larger than list) )           if $new_size > scalar @{ $list };
 975
 976     $bin_size = int( scalar @{ $list } / $new_size );
 977
 978     for ( $i = 0; $i < @{ $list } - $bin_size + 1; $i += $bin_size ) {
 979         push @new_list, Maasha::Calc::mean( [ @{ $list }[ $i .. $i + $bin_size ] ] );
 980     }
 981
 982     # Maasha::Common::error( sprintf( "List size != new size: %d != %d" ), scalar @new_list, $new_size ) if scalar @new_list != $new_size;
 983
 984     @{ $list } = @new_list;
 985 }
 986
 987
 988 sub list_inflate
 989 {
 990     # Martin A. Hansen, February 2010.
 991
 992     # Inflates a list of values to a specified size recursively.
 993     # Newly introduced elements are means of neighboring elements.
 994     # This routine is a rough and not very precise.
 995
 996     my ( $list,
 997          $new_size,
 998        ) = @_;
 999
1000     # Returns nothing.
1001
1002     my ( $len, $diff, $space );
1003
1004     $len  = @{ $list };
1005     $diff = $new_size - $len;
1006
1007     if ( $diff > 0 )
1008     {
1009         $space = $len / $diff;
1010
1011         if ( ( $space % 2 ) == 0 )
1012         {
1013             splice @{ $list }, $len / 2, 0, Maasha::Calc::mean( [ $list->[ $len / 2 ], $list->[ $len / 2 + 1 ] ] );
1014         }
1015         else
1016         {
1017             splice @{ $list }, $len * ( 2 / 3 ), 0, Maasha::Calc::mean( [ $list->[ $len * ( 2 / 3 ) ], $list->[ $len * ( 2 / 3 ) + 1 ] ] );
1018             splice @{ $list }, $len * ( 1 / 3 ), 0, Maasha::Calc::mean( [ $list->[ $len * ( 1 / 3 ) ], $list->[ $len * ( 1 / 3 ) + 1 ] ] ) if @{ $list } < $new_size;
1019         }
1020
1021         list_inflate( $list, $new_size );
1022     }
1023 }
1024
1025
1026 sub list_uniq
1027 {
1028     # Martin A. Hansen, April 2007.
1029
1030     # returns the number of unique elements in a
1031     # given list.
1032
1033     my ( $list,   # list
1034        ) = @_;
1035
1036     # returns integer
1037
1038     my ( %hash, $count );
1039
1040     map { $hash{ $_ } = 1 } @{ $list };
1041
1042     $count = scalar keys %hash;
1043
1044     return $count;
1045 }
1046
1047
1048 sub tabulate
1049 {
1050     # Martin A. Hansen, April 2007.
1051
1052     my ( $matrix,    # AoA data structure
1053          $col,
1054        ) = @_;
1055
1056     my ( $dims, $list, $i, $max, $len, %hash, $elem, @list );
1057
1058     $dims = matrix_dims( $matrix );
1059
1060     $list = cols_get( $matrix, $col, $col );
1061     $list = matrix_flip( $list )->[ 0 ];
1062
1063     $max = 0;
1064
1065     for ( $i = 0; $i < @{ $list }; $i++ )
1066     {
1067         $hash{ $list->[ $i ] }++;
1068
1069         $len = length $list->[ $i ];
1070
1071         $max = $len if $len > $max;
1072     }
1073
1074     @list = keys %hash;
1075
1076     if ( list_check_numeric( $list ) ) {
1077         @list = sort { $a <=> $b } @list;
1078     } else {
1079         @list = sort { $a cmp $b } @list;
1080     }
1081
1082     foreach $elem ( @list )
1083     {
1084         print $elem, " " x ( $max - length( $elem ) ),
1085         sprintf( "   %6s   ", $hash{ $elem } ),
1086         sprintf( "%.2f\n", ( $hash{ $elem } / $dims->[ ROWS ] ) * 100 );
1087     }
1088 }
1089
1090
1091 sub merge_tabs
1092 {
1093     # Martin A. Hansen, July 2008.
1094
1095     # Merge two given tables based on identifiers in a for each table
1096     # specified column which should contain a unique identifier.
1097     # Initially the tables are sorted and tab2 is merged onto tab1
1098     # row-wise.
1099
1100     my ( $tab1,       # table 1 - an AoA.
1101          $tab2,       # table 2 - an AoA.
1102          $col1,       # identifier in row1
1103          $col2,       # identifier in row2
1104          $sort_type,  # alphabetical or numeric comparison
1105        ) = @_;
1106
1107     # Returns nothing.
1108
1109     my ( $num, $cmp, $i, $c, @row_cpy, $max );
1110
1111     $max = 0;
1112     $num = 0;
1113
1114     if ( $sort_type =~ /num/i )
1115     {
1116         $num = 1;
1117
1118         @{ $tab1 } = sort { $a->[ $col1 ] <=> $b->[ $col1 ] } @{ $tab1 };
1119         @{ $tab2 } = sort { $a->[ $col2 ] <=> $b->[ $col2 ] } @{ $tab2 };
1120     }
1121     else
1122     {
1123         @{ $tab1 } = sort { $a->[ $col1 ] cmp $b->[ $col1 ] } @{ $tab1 };
1124         @{ $tab2 } = sort { $a->[ $col2 ] cmp $b->[ $col2 ] } @{ $tab2 };
1125     }
1126
1127     $i = 0;
1128     $c = 0;
1129
1130     while ( $i < @{ $tab1 } and $c < @{ $tab2 } )
1131     {
1132         if ( $num ) {
1133             $cmp = $tab1->[ $i ]->[ $col1 ] <=> $tab2->[ $c ]->[ $col2 ];
1134         } else {
1135             $cmp = $tab1->[ $i ]->[ $col1 ] cmp $tab2->[ $c ]->[ $col2 ];
1136         }
1137
1138         if ( $cmp == 0 )
1139         {
1140             @row_cpy = @{ $tab2->[ $c ] };
1141
1142             splice @row_cpy, $col2, 1;
1143
1144             push @{ $tab1->[ $i ] }, @row_cpy;
1145
1146             $i++;
1147             $c++;
1148         }
1149         elsif ( $cmp > 0 )
1150         {
1151             $c++;
1152         }
1153         else
1154         {
1155             map { push @{ $tab1->[ $i ] }, "null" } 0 .. ( scalar @{ $tab2->[ $c ] } - 2 );
1156
1157             $i++;
1158         }
1159     }
1160
1161     map { push @{ $tab1->[ -1 ] }, "null" } 0 .. ( scalar @{ $tab1->[ 0 ] } - scalar @{ $tab1->[ -1 ] } + 1 );
1162 }
1163
1164
1165 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> BINARY SEARCH <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
1166
1167
1168 sub interval_search
1169 {
1170     # Martin A. Hansen, February 2008.
1171
1172     # Uses binary search to locate the interval containing a
1173     # given number. The intervals are defined by begin and end
1174     # positions in seperate columns in a matrix. If a interval is
1175     # found then the index of that matrix row is returned, otherwise
1176     # -1 is returned.
1177
1178     my ( $matrix,   # data structure
1179          $col1,     # column with interval begins
1180          $col2,     # column with interval ends
1181          $num,      # number to search for
1182        ) = @_;
1183
1184     # Returns an integer.
1185
1186     my ( $high, $low, $try );
1187
1188     $low  = 0;
1189     $high = @{ $matrix };
1190
1191     while ( $low < $high )
1192     {
1193         $try = int( ( $high + $low ) / 2 );
1194
1195         # print "num->$num   low->$low   high->$high   try->$try   int1->$matrix->[ $try ]->[ $col1 ]   int2->$matrix->[ $try ]->[ $col2 ]\n";
1196
1197         if ( $num < $matrix->[ $try ]->[ $col1 ] ) {
1198             $high = $try;
1199         } elsif ( $num > $matrix->[ $try ]->[ $col2 ] ) {
1200             $low = $try + 1;
1201         } else {
1202             return $try;
1203         }
1204     }
1205
1206     return -1;
1207 }
1208
1209
1210 sub list_search
1211 {
1212     # Martin A. Hansen, February 2008.
1213
1214     # Uses binary search to locate a number in a list of numbers.
1215     # If the number is found, then the index (the position of the number
1216     # in the list) is returned, otherwise -1 is returned.
1217
1218     my ( $list,   # list of numbers
1219          $num,    # number to search for
1220        ) = @_;
1221
1222     # Returns an integer.
1223
1224     my ( $high, $low, $try );
1225
1226     $low  = 0;
1227     $high = @{ $list };
1228
1229     while ( $low < $high )
1230     {
1231         $try = int( ( $high + $low ) / 2 );
1232
1233         # print "num->$num   low->$low   high->$high   try->$try   int->$list->[ $try ]\n";
1234
1235         if ( $num < $list->[ $try ] ) {
1236             $high = $try;
1237         } elsif ( $num > $list->[ $try ] ) {
1238             $low = $try + 1;
1239         } else {
1240             return $try;
1241         }
1242     }
1243
1244     return -1;
1245 }
1246
1247
1248 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> DISK SUBROUTINES <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
1249
1250
1251 sub matrix_read
1252 {
1253     # Martin A. Hansen, April 2007
1254
1255     # Reads tabular data from file into a matrix
1256     # AoA data structure.
1257
1258     my ( $path,        # full path to file with data
1259          $delimiter,   # column delimiter - OPTIONAL (default tab)
1260          $comments,    # regex for comment lines to skip - OPTIONAL
1261          $fields_ok,   # list of fields to accept        - OPTIONAL
1262        ) = @_;
1263
1264     # returns AoA
1265
1266     my ( $fh, $line, @fields, @AoA );
1267
1268     $delimiter ||= "\t";
1269
1270     $fh = Maasha::Filesys::file_read_open( $path );
1271
1272     while ( $line = <$fh> )
1273     {
1274         chomp $line;
1275
1276         next if $comments and $line =~ /^$comments/;
1277
1278         @fields = split /$delimiter/, $line;
1279
1280         map { splice( @fields, $_, 1 ) } @{ $fields_ok } if $fields_ok;
1281
1282         push @AoA, [ @fields ];
1283     }
1284
1285     close $fh;
1286
1287     return wantarray ? @AoA : \@AoA;
1288 }
1289
1290
1291 sub matrix_write
1292 {
1293     # Martin A. Hansen, April 2007
1294
1295     # Writes a tabular data structure to STDOUT or file.
1296
1297     my ( $matrix,      # AoA data structure
1298          $path,        # full path to output file - OPTIONAL (default STDOUT)
1299          $delimiter,   # column delimiter         - OPTIONAL (default tab)
1300        ) = @_;
1301
1302     my ( $fh, $row );
1303
1304     $fh = Maasha::Filesys::file_write_open( $path ) if $path;
1305
1306     $delimiter ||= "\t";
1307
1308     foreach $row ( @{ $matrix } )
1309     {
1310         if ( $fh ) {
1311             print $fh join( $delimiter, @{ $row } ), "\n";
1312         } else {
1313             print join( $delimiter, @{ $row } ), "\n";
1314         }
1315     }
1316
1317     close $fh if $fh;
1318 }
1319
1320
1321 sub matrix_store
1322 {
1323     # Martin A. Hansen, April 2007.
1324
1325     # stores a matrix to a binary file.
1326
1327     my ( $path,      # full path to file
1328          $matrix,    # data structure
1329        ) = @_;
1330
1331     Maasha::Filesys::file_store( $path, $matrix );
1332 }
1333
1334
1335 sub matrix_retrive
1336 {
1337     # Martin A. Hansen, April 2007.
1338
1339     # retrieves a matrix from a binary file
1340
1341     my ( $path,   # full path to file
1342        ) = @_;
1343
1344     my $matrix = Maasha::Filesys::file_retrieve( $path );
1345
1346     return wantarray ? @{ $matrix } : $matrix;
1347 }
1348
1349
1350 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
1351
1352
1353 __END__