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