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