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