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