1# -*- mode: perl; coding: utf-8-unix -*- 2 3package Math::Matrix; 4 5use strict; 6use warnings; 7 8use Carp; 9use Scalar::Util 'blessed'; 10 11our $VERSION = '0.94'; 12our $eps = 0.00001; 13 14use overload 15 16 '+' => sub { 17 my ($x, $y, $swap) = @_; 18 $x -> add($y); 19 }, 20 21 '-' => sub { 22 my ($x, $y, $swap) = @_; 23 if ($swap) { 24 return $x -> neg() if !ref($y) && $y == 0; 25 26 my $class = ref $x; 27 return $class -> new($y) -> sub($x); 28 } 29 $x -> sub($y); 30 }, 31 32 '*' => sub { 33 my ($x, $y, $swap) = @_; 34 $x -> mul($y); 35 }, 36 37 '**' => sub { 38 my ($x, $y, $swap) = @_; 39 if ($swap) { 40 my $class = ref $x; 41 return $class -> new($y) -> pow($x); 42 } 43 $x -> pow($y); 44 }, 45 46 '==' => sub { 47 my ($x, $y, $swap) = @_; 48 $x -> meq($y); 49 }, 50 51 '!=' => sub { 52 my ($x, $y, $swap) = @_; 53 $x -> mne($y); 54 }, 55 56 'int' => sub { 57 my ($x, $y, $swap) = @_; 58 $x -> int(); 59 }, 60 61 'abs' => sub { 62 my ($x, $y, $swap) = @_; 63 $x -> abs(); 64 }, 65 66 '~' => 'transpose', 67 '""' => 'as_string', 68 '=' => 'clone'; 69 70=pod 71 72=encoding utf8 73 74=head1 NAME 75 76Math::Matrix - multiply and invert matrices 77 78=head1 SYNOPSIS 79 80 use Math::Matrix; 81 82 # Generate a random 3-by-3 matrix. 83 srand(time); 84 my $A = Math::Matrix -> new([rand, rand, rand], 85 [rand, rand, rand], 86 [rand, rand, rand]); 87 $A -> print("A\n"); 88 89 # Append a fourth column to $A. 90 my $x = Math::Matrix -> new([rand, rand, rand]); 91 my $E = $A -> concat($x -> transpose); 92 $E -> print("Equation system\n"); 93 94 # Compute the solution. 95 my $s = $E -> solve; 96 $s -> print("Solutions s\n"); 97 98 # Verify that the solution equals $x. 99 $A -> multiply($s) -> print("A*s\n"); 100 101=head1 DESCRIPTION 102 103This module implements various constructors and methods for creating and 104manipulating matrices. 105 106All methods return new objects, so, for example, C<$X-E<gt>add($Y)> does not 107modify C<$X>. 108 109 $X -> add($Y); # $X not modified; output is lost 110 $X = $X -> add($Y); # this works 111 112Some operators are overloaded (see L</OVERLOADING>) and allow the operand to be 113modified directly. 114 115 $X = $X + $Y; # this works 116 $X += $Y; # so does this 117 118=head1 METHODS 119 120=head2 Constructors 121 122=over 4 123 124=item new() 125 126Creates a new object from the input arguments and returns it. 127 128If a single input argument is given, and that argument is a reference to array 129whose first element is itself a reference to an array, it is assumed that the 130argument contains the whole matrix, like this: 131 132 $x = Math::Matrix->new([[1, 2, 3], [4, 5, 6]]); # 2-by-3 matrix 133 $x = Math::Matrix->new([[1, 2, 3]]); # 1-by-3 matrix 134 $x = Math::Matrix->new([[1], [2], [3]]); # 3-by-1 matrix 135 136If a single input argument is given, and that argument is not a reference to an 137array, a 1-by-1 matrix is returned. 138 139 $x = Math::Matrix->new(1); # 1-by-1 matrix 140 141Note that all the folling cases result in an empty matrix: 142 143 $x = Math::Matrix->new([[], [], []]); 144 $x = Math::Matrix->new([[]]); 145 $x = Math::Matrix->new([]); 146 147If C<L</new()>> is called as an instance method with no input arguments, a zero 148filled matrix with identical dimensions is returned: 149 150 $b = $a->new(); # $b is a zero matrix with the size of $a 151 152Each row must contain the same number of elements. 153 154=cut 155 156sub new { 157 my $that = shift; 158 my $class = ref($that) || $that; 159 my $self = []; 160 161 # If called as an instance method and no arguments are given, return a 162 # zero matrix of the same size as the invocand. 163 164 if (ref($that) && (@_ == 0)) { 165 @$self = map [ (0) x @$_ ], @$that; 166 } 167 168 # Otherwise return a new matrix based on the input arguments. The object 169 # data is a blessed reference to an array containing the matrix data. This 170 # array contains a list of arrays, one for each row, which in turn contains 171 # a list of elements. An empty matrix has no rows. 172 # 173 # [[ 1, 2, 3 ], [ 4, 5, 6 ]] 2-by-3 matrix 174 # [[ 1, 2, 3 ]] 1-by-3 matrix 175 # [[ 1 ], [ 2 ], [ 3 ]] 3-by-1 matrix 176 # [[ 1 ]] 1-by-1 matrix 177 # [] empty matrix 178 179 else { 180 181 my $data; 182 183 # If there is a single argument, and that is not a reference, 184 # assume new() has been called as, e.g., $class -> new(3). 185 186 if (@_ == 1 && !ref($_[0])) { 187 $data = [[ $_[0] ]]; 188 } 189 190 # If there is a single argument, and that is a reference to an array, 191 # and that array contains at least one element, and that element is 192 # itself a reference to an array, then assume new() has been called 193 # with the matrix as one argument, i.e., a reference to an array of 194 # arrays, e.g., $class -> new([ [1, 2], [3, 4] ]) ... 195 196 elsif (@_ == 1 && ref($_[0]) eq 'ARRAY' 197 && @{$_[0]} > 0 && ref($_[0][0]) eq 'ARRAY') 198 { 199 $data = $_[0]; 200 } 201 202 # ... otherwise assume that each argument to new() is a row. Note that 203 # new() called with no arguments results in an empty matrix. 204 205 else { 206 $data = [ @_ ]; 207 } 208 209 # Sanity checking. 210 211 if (@$data) { 212 my $nrow = @$data; 213 my $ncol; 214 215 for my $i (0 .. $nrow - 1) { 216 my $row = $data -> [$i]; 217 218 # Verify that the row is a reference to an array. 219 220 croak "row with index $i is not a reference to an array" 221 unless ref($row) eq 'ARRAY'; 222 223 # In the first round, get the number of elements, i.e., the 224 # number of columns in the matrix. In the successive 225 # rounds, verify that each row has the same number of 226 # elements. 227 228 if ($i == 0) { 229 $ncol = @$row; 230 } else { 231 croak "each row must have the same number of elements" 232 unless @$row == $ncol; 233 } 234 } 235 236 # Copy the data into $self only if the matrix is non-emtpy. 237 238 @$self = map [ @$_ ], @$data if $ncol; 239 } 240 } 241 242 bless $self, $class; 243} 244 245=pod 246 247=item new_from_sub() 248 249Creates a new matrix object by doing a subroutine call to create each element. 250 251 $sub = sub { ... }; 252 $x = Math::Matrix -> new_from_sub($sub); # 1-by-1 253 $x = Math::Matrix -> new_from_sub($sub, $m); # $m-by-$m 254 $x = Math::Matrix -> new_from_sub($sub, $m, $n); # $m-by-$n 255 256The subroutine is called in scalar context with two input arguments, the row and 257column indices of the element to be created. Note that no checks are performed 258on the output of the subroutine. 259 260Example 1, a 4-by-4 identity matrix can be created with 261 262 $sub = sub { $_[0] == $_[1] ? 1 : 0 }; 263 $x = Math::Matrix -> new_from_sub($sub, 4); 264 265Example 2, the code 266 267 $x = Math::Matrix -> new_from_sub(sub { 2**$_[1] }, 1, 11); 268 269creates the following 1-by-11 vector with powers of two 270 271 [ 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024 ] 272 273Example 3, the code, using C<$i> and C<$j> for increased readability 274 275 $sub = sub { 276 ($i, $j) = @_; 277 $d = $j - $i; 278 return $d == -1 ? 5 279 : $d == 0 ? 6 280 : $d == 1 ? 7 281 : 0; 282 }; 283 $x = Math::Matrix -> new_from_sub($sub, 5); 284 285creates the tridiagonal matrix 286 287 [ 6 7 0 0 0 ] 288 [ 5 6 7 0 0 ] 289 [ 0 5 6 7 0 ] 290 [ 0 0 5 6 7 ] 291 [ 0 0 0 5 6 ] 292 293=cut 294 295sub new_from_sub { 296 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 297 croak "Too many arguments for ", (caller(0))[3] if @_ > 4; 298 my $class = shift; 299 300 croak +(caller(0))[3], " is a class method, not an instance method" 301 if ref $class; 302 303 my $sub = shift; 304 croak "The first input argument must be a code reference" 305 unless ref($sub) eq 'CODE'; 306 307 my ($nrow, $ncol) = @_ == 0 ? (1, 1) 308 : @_ == 1 ? (@_, @_) 309 : (@_); 310 311 my $x = bless [], $class; 312 for my $i (0 .. $nrow - 1) { 313 for my $j (0 .. $ncol - 1) { 314 $x -> [$i][$j] = $sub -> ($i, $j); 315 } 316 } 317 318 return $x; 319} 320 321=pod 322 323=item new_from_rows() 324 325Creates a new matrix by assuming each argument is a row vector. 326 327 $x = Math::Matrix -> new_from_rows($y, $z, ...); 328 329For example 330 331 $x = Math::Matrix -> new_from_rows([1, 2, 3],[4, 5, 6]); 332 333returns the matrix 334 335 [ 1 2 3 ] 336 [ 4 5 6 ] 337 338=cut 339 340sub new_from_rows { 341 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 342 my $class = shift; 343 344 croak +(caller(0))[3], " is a class method, not an instance method" 345 if ref $class; 346 347 my @args = (); 348 for (my $i = 0 ; $i <= $#_ ; ++$i) { 349 my $x = $_[$i]; 350 $x = $class -> new($x) 351 unless defined(blessed($x)) && $x -> isa($class); 352 if ($x -> is_vector()) { 353 push @args, $x -> to_row(); 354 } else { 355 push @args, $x; 356 } 357 } 358 359 $class -> new([]) -> catrow(@args); 360} 361 362=pod 363 364=item new_from_cols() 365 366Creates a matrix by assuming each argument is a column vector. 367 368 $x = Math::Matrix -> new_from_cols($y, $z, ...); 369 370For example, 371 372 $x = Math::Matrix -> new_from_cols([1, 2, 3],[4, 5, 6]); 373 374returns the matrix 375 376 [ 1 4 ] 377 [ 2 5 ] 378 [ 3 6 ] 379 380=cut 381 382sub new_from_cols { 383 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 384 my $class = shift; 385 386 croak +(caller(0))[3], " is a class method, not an instance method" 387 if ref $class; 388 389 $class -> new_from_rows(@_) -> swaprc(); 390} 391 392=pod 393 394=item id() 395 396Returns a new identity matrix. 397 398 $I = Math::Matrix -> id($n); # $n-by-$n identity matrix 399 $I = $x -> id($n); # $n-by-$n identity matrix 400 $I = $x -> id(); # identity matrix with size of $x 401 402=cut 403 404sub id { 405 my $self = shift; 406 my $ref = ref $self; 407 my $class = $ref || $self; 408 409 my $n; 410 if (@_) { 411 $n = shift; 412 } else { 413 if ($ref) { 414 my ($mx, $nx) = $self -> size(); 415 croak "When id() is called as an instance method, the invocand", 416 " must be a square matrix" unless $mx == $nx; 417 $n = $mx; 418 } else { 419 croak "When id() is called as a class method, the size must be", 420 " given as an input argument"; 421 } 422 } 423 424 bless [ map [ (0) x ($_ - 1), 1, (0) x ($n - $_) ], 1 .. $n ], $class; 425} 426 427=pod 428 429=item new_identity() 430 431This is an alias for C<L</id()>>. 432 433=cut 434 435sub new_identity { 436 id(@_); 437} 438 439=pod 440 441=item eye() 442 443This is an alias for C<L</id()>>. 444 445=cut 446 447sub eye { 448 new_identity(@_); 449} 450 451=pod 452 453=item exchg() 454 455Exchange matrix. 456 457 $x = Math::Matrix -> exchg($n); # $n-by-$n exchange matrix 458 459=cut 460 461sub exchg { 462 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 463 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 464 my $class = shift; 465 466 my $n = shift; 467 bless [ map [ (0) x ($n - $_), 1, (0) x ($_ - 1) ], 1 .. $n ], $class; 468} 469 470=pod 471 472=item scalar() 473 474Returns a scalar matrix, i.e., a diagonal matrix with all the diagonal elements 475set to the same value. 476 477 # Create an $m-by-$m scalar matrix where each element is $c. 478 $x = Math::Matrix -> scalar($c, $m); 479 480 # Create an $m-by-$n scalar matrix where each element is $c. 481 $x = Math::Matrix -> scalar($c, $m, $n); 482 483Multiplying a matrix A by a scalar matrix B is effectively the same as multiply 484each element in A by the constant on the diagonal of B. 485 486=cut 487 488sub scalar { 489 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 490 croak "Too many arguments for ", (caller(0))[3] if @_ > 4; 491 my $class = shift; 492 493 croak +(caller(0))[3], " is a class method, not an instance method" 494 if ref $class; 495 496 my $c = shift; 497 my ($m, $n) = @_ == 0 ? (1, 1) 498 : @_ == 1 ? (@_, @_) 499 : (@_); 500 croak "The number of rows must be equal to the number of columns" 501 unless $m == $n; 502 503 bless [ map [ (0) x ($_ - 1), $c, (0) x ($n - $_) ], 1 .. $m ], $class; 504} 505 506=pod 507 508=item zeros() 509 510Create a zero matrix. 511 512 # Create an $m-by-$m matrix where each element is 0. 513 $x = Math::Matrix -> zeros($m); 514 515 # Create an $m-by-$n matrix where each element is 0. 516 $x = Math::Matrix -> zeros($m, $n); 517 518=cut 519 520sub zeros { 521 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 522 croak "Too many arguments for ", (caller(0))[3] if @_ > 3; 523 my $self = shift; 524 $self -> constant(0, @_); 525}; 526 527=pod 528 529=item ones() 530 531Create a matrix of ones. 532 533 # Create an $m-by-$m matrix where each element is 1. 534 $x = Math::Matrix -> ones($m); 535 536 # Create an $m-by-$n matrix where each element is 1. 537 $x = Math::Matrix -> ones($m, $n); 538 539=cut 540 541sub ones { 542 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 543 croak "Too many arguments for ", (caller(0))[3] if @_ > 3; 544 my $self = shift; 545 $self -> constant(1, @_); 546}; 547 548=pod 549 550=item inf() 551 552Create a matrix of positive infinities. 553 554 # Create an $m-by-$m matrix where each element is Inf. 555 $x = Math::Matrix -> inf($m); 556 557 # Create an $m-by-$n matrix where each element is Inf. 558 $x = Math::Matrix -> inf($m, $n); 559 560=cut 561 562sub inf { 563 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 564 croak "Too many arguments for ", (caller(0))[3] if @_ > 3; 565 my $self = shift; 566 567 require Math::Trig; 568 my $inf = Math::Trig::Inf(); 569 $self -> constant($inf, @_); 570}; 571 572=pod 573 574=item nan() 575 576Create a matrix of NaNs (Not-a-Number). 577 578 # Create an $m-by-$m matrix where each element is NaN. 579 $x = Math::Matrix -> nan($m); 580 581 # Create an $m-by-$n matrix where each element is NaN. 582 $x = Math::Matrix -> nan($m, $n); 583 584=cut 585 586sub nan { 587 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 588 croak "Too many arguments for ", (caller(0))[3] if @_ > 3; 589 my $self = shift; 590 591 require Math::Trig; 592 my $inf = Math::Trig::Inf(); 593 my $nan = $inf - $inf; 594 $self -> constant($nan, @_); 595}; 596 597=pod 598 599=item constant() 600 601Returns a constant matrix, i.e., a matrix whose elements all have the same 602value. 603 604 # Create an $m-by-$m matrix where each element is $c. 605 $x = Math::Matrix -> constant($c, $m); 606 607 # Create an $m-by-$n matrix where each element is $c. 608 $x = Math::Matrix -> constant($c, $m, $n); 609 610=cut 611 612sub constant { 613 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 614 croak "Too many arguments for ", (caller(0))[3] if @_ > 4; 615 my $class = shift; 616 617 croak +(caller(0))[3], " is a class method, not an instance method" 618 if ref $class; 619 620 my $c = shift; 621 my ($m, $n) = @_ == 0 ? (1, 1) 622 : @_ == 1 ? (@_, @_) 623 : (@_); 624 625 bless [ map [ ($c) x $n ], 1 .. $m ], $class; 626} 627 628=pod 629 630=item rand() 631 632Returns a matrix of uniformly distributed random numbers in the range [0,1). 633 634 $x = Math::Matrix -> rand($m); # $m-by-$m matrix 635 $x = Math::Matrix -> rand($m, $n); # $m-by-$n matrix 636 637To generate an C<$m>-by-C<$n> matrix of uniformly distributed random numbers in 638the range [0,C<$a>), use 639 640 $x = $a * Math::Matrix -> rand($m, $n); 641 642To generate an C<$m>-by-C<$n> matrix of uniformly distributed random numbers in 643the range [C<$a>,C<$b>), use 644 645 $x = $a + ($b - $a) * Math::Matrix -> rand($m, $n); 646 647See also C<L</randi()>> and C<L</randn()>>. 648 649=cut 650 651sub rand { 652 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 653 croak "Too many arguments for ", (caller(0))[3] if @_ > 3; 654 my $class = shift; 655 656 croak +(caller(0))[3], " is a class method, not an instance method" 657 if ref $class; 658 659 my ($nrow, $ncol) = @_ == 0 ? (1, 1) 660 : @_ == 1 ? (@_, @_) 661 : (@_); 662 663 my $x = bless [], $class; 664 for my $i (0 .. $nrow - 1) { 665 for my $j (0 .. $ncol - 1) { 666 $x -> [$i][$j] = CORE::rand; 667 } 668 } 669 670 return $x; 671} 672 673=pod 674 675=item randi() 676 677Returns a matrix of uniformly distributed random integers. 678 679 $x = Math::Matrix -> randi($max); # 1-by-1 matrix 680 $x = Math::Matrix -> randi($max, $n); # $n-by-$n matrix 681 $x = Math::Matrix -> randi($max, $m, $n); # $m-by-$n matrix 682 683 $x = Math::Matrix -> randi([$min, $max]); # 1-by-1 matrix 684 $x = Math::Matrix -> randi([$min, $max], $n); # $n-by-$n matrix 685 $x = Math::Matrix -> randi([$min, $max], $m, $n); # $m-by-$n matrix 686 687See also C<L</rand()>> and C<L</randn()>>. 688 689=cut 690 691sub randi { 692 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 693 croak "Too many arguments for ", (caller(0))[3] if @_ > 4; 694 my $class = shift; 695 696 croak +(caller(0))[3], " is a class method, not an instance method" 697 if ref $class; 698 699 my ($min, $max); 700 my $lim = shift; 701 if (ref($lim) eq 'ARRAY') { 702 ($min, $max) = @$lim; 703 } else { 704 $min = 0; 705 $max = $lim; 706 } 707 708 my ($nrow, $ncol) = @_ == 0 ? (1, 1) 709 : @_ == 1 ? (@_, @_) 710 : (@_); 711 712 my $c = $max - $min + 1; 713 my $x = bless [], $class; 714 for my $i (0 .. $nrow - 1) { 715 for my $j (0 .. $ncol - 1) { 716 $x -> [$i][$j] = $min + CORE::int(CORE::rand($c)); 717 } 718 } 719 720 return $x; 721} 722 723=pod 724 725=item randn() 726 727Returns a matrix of random numbers from the standard normal distribution. 728 729 $x = Math::Matrix -> randn($m); # $m-by-$m matrix 730 $x = Math::Matrix -> randn($m, $n); # $m-by-$n matrix 731 732To generate an C<$m>-by-C<$n> matrix with mean C<$mu> and standard deviation 733C<$sigma>, use 734 735 $x = $mu + $sigma * Math::Matrix -> randn($m, $n); 736 737See also C<L</rand()>> and C<L</randi()>>. 738 739=cut 740 741sub randn { 742 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 743 croak "Too many arguments for ", (caller(0))[3] if @_ > 3; 744 my $class = shift; 745 746 croak +(caller(0))[3], " is a class method, not an instance method" 747 if ref $class; 748 749 my ($nrow, $ncol) = @_ == 0 ? (1, 1) 750 : @_ == 1 ? (@_, @_) 751 : (@_); 752 753 my $nelm = $nrow * $ncol; 754 my $twopi = 2 * atan2 0, -1; 755 756 # The following might generate one value more than we need. 757 758 my $x = []; 759 for (my $k = 0 ; $k < $nelm ; $k += 2) { 760 my $c1 = sqrt(-2 * log(CORE::rand)); 761 my $c2 = $twopi * CORE::rand; 762 push @$x, $c1 * cos($c2), $c1 * sin($c2); 763 } 764 pop @$x if @$x > $nelm; 765 766 $x = bless [ $x ], $class; 767 $x -> reshape($nrow, $ncol); 768} 769 770=pod 771 772=item clone() 773 774Clones a matrix and returns the clone. 775 776 $b = $a->clone; 777 778=cut 779 780sub clone { 781 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 782 my $x = shift; 783 my $class = ref $x; 784 785 croak +(caller(0))[3], " is an instance method, not a class method" 786 unless $class; 787 788 my $y = [ map [ @$_ ], @$x ]; 789 bless $y, $class; 790} 791 792=pod 793 794=item diagonal() 795 796A constructor method that creates a diagonal matrix from a single list or array 797of numbers. 798 799 $p = Math::Matrix->diagonal(1, 4, 4, 8); 800 $q = Math::Matrix->diagonal([1, 4, 4, 8]); 801 802The matrix is zero filled except for the diagonal members, which take the 803values of the vector. 804 805The method returns B<undef> in case of error. 806 807=cut 808 809# 810# Either class or object call, create a square matrix with the same 811# dimensions as the passed-in list or array. 812# 813sub diagonal { 814 my $that = shift; 815 my $class = ref($that) || $that; 816 my @diag = @_; 817 my $self = []; 818 819 # diagonal([2,3]) -> diagonal(2,3) 820 @diag = @{$diag[0]} if (ref $diag[0] eq "ARRAY"); 821 822 my $len = scalar @diag; 823 return undef if ($len == 0); 824 825 for my $idx (0..$len-1) { 826 my @r = (0) x $len; 827 $r[$idx] = $diag[$idx]; 828 push(@{$self}, [@r]); 829 } 830 bless $self, $class; 831} 832 833=pod 834 835=item tridiagonal() 836 837A constructor method that creates a matrix from vectors of numbers. 838 839 $p = Math::Matrix->tridiagonal([1, 4, 4, 8]); 840 $q = Math::Matrix->tridiagonal([1, 4, 4, 8], [9, 12, 15]); 841 $r = Math::Matrix->tridiagonal([1, 4, 4, 8], [9, 12, 15], [4, 3, 2]); 842 843In the first case, the main diagonal takes the values of the vector, while both 844of the upper and lower diagonals's values are all set to one. 845 846In the second case, the main diagonal takes the values of the first vector, 847while the upper and lower diagonals are each set to the values of the second 848vector. 849 850In the third case, the main diagonal takes the values of the first vector, 851while the upper diagonal is set to the values of the second vector, and the 852lower diagonal is set to the values of the third vector. 853 854The method returns B<undef> in case of error. 855 856=cut 857 858# 859# Either class or object call, create a square matrix with the same 860# dimensions as the passed-in list or array. 861# 862sub tridiagonal { 863 my $that = shift; 864 my $class = ref($that) || $that; 865 my(@up_d, @main_d, @low_d); 866 my $self = []; 867 868 # 869 # Handle the different ways the tridiagonal vectors could 870 # be passed in. 871 # 872 if (ref $_[0] eq "ARRAY") { 873 @main_d = @{$_[0]}; 874 875 if (ref $_[1] eq "ARRAY") { 876 @up_d = @{$_[1]}; 877 878 if (ref $_[2] eq "ARRAY") { 879 @low_d = @{$_[2]}; 880 } 881 } 882 } else { 883 @main_d = @_; 884 } 885 886 my $len = scalar @main_d; 887 return undef if ($len == 0); 888 889 # 890 # Default the upper and lower diagonals if no vector 891 # was passed in for them. 892 # 893 @up_d = (1) x ($len -1) if (scalar @up_d == 0); 894 @low_d = @up_d if (scalar @low_d == 0); 895 896 # 897 # First row... 898 # 899 my @arow = (0) x $len; 900 @arow[0..1] = ($main_d[0], $up_d[0]); 901 push (@{$self}, [@arow]); 902 903 # 904 # Bulk of the matrix... 905 # 906 for my $idx (1 .. $#main_d - 1) { 907 my @r = (0) x $len; 908 @r[$idx-1 .. $idx+1] = ($low_d[$idx-1], $main_d[$idx], $up_d[$idx]); 909 push (@{$self}, [@r]); 910 } 911 912 # 913 # Last row. 914 # 915 my @zrow = (0) x $len; 916 @zrow[$len-2..$len-1] = ($low_d[$#main_d -1], $main_d[$#main_d]); 917 push (@{$self}, [@zrow]); 918 919 bless $self, $class; 920} 921 922=pod 923 924=item blkdiag() 925 926Create block diagonal matrix. Returns a block diagonal matrix given a list of 927matrices. 928 929 $z = Math::Matrix -> blkdiag($x, $y, ...); 930 931=cut 932 933sub blkdiag { 934 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 935 #croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 936 my $class = shift; 937 938 my $y = []; 939 my $nrowy = 0; 940 my $ncoly = 0; 941 942 for my $i (0 .. $#_) { 943 my $x = $_[$i]; 944 945 $x = $class -> new($x) 946 unless defined(blessed($x)) && $x -> isa($class); 947 948 my ($nrowx, $ncolx) = $x -> size(); 949 950 # Upper right submatrix. 951 952 for my $i (0 .. $nrowy - 1) { 953 for my $j (0 .. $ncolx - 1) { 954 $y -> [$i][$ncoly + $j] = 0; 955 } 956 } 957 958 # Lower left submatrix. 959 960 for my $i (0 .. $nrowx - 1) { 961 for my $j (0 .. $ncoly - 1) { 962 $y -> [$nrowy + $i][$j] = 0; 963 } 964 } 965 966 # Lower right submatrix. 967 968 for my $i (0 .. $nrowx - 1) { 969 for my $j (0 .. $ncolx - 1) { 970 $y -> [$nrowy + $i][$ncoly + $j] = $x -> [$i][$j]; 971 } 972 } 973 974 $nrowy += $nrowx; 975 $ncoly += $ncolx; 976 } 977 978 bless $y, $class; 979} 980 981=pod 982 983=back 984 985=head2 Identify matrices 986 987=over 4 988 989=item is_empty() 990 991Returns 1 is the invocand is empty, i.e., it has no elements. 992 993 $bool = $x -> is_empty(); 994 995=cut 996 997sub is_empty { 998 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 999 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1000 my $x = shift; 1001 return $x -> nelm() == 0; 1002} 1003 1004=pod 1005 1006=item is_scalar() 1007 1008Returns 1 is the invocand is a scalar, i.e., it has one element. 1009 1010 $bool = $x -> is_scalar(); 1011 1012=cut 1013 1014sub is_scalar { 1015 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1016 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1017 my $x = shift; 1018 return $x -> nelm() == 1 ? 1 : 0; 1019} 1020 1021=pod 1022 1023=item is_vector() 1024 1025Returns 1 is the invocand is a vector, i.e., a row vector or a column vector. 1026 1027 $bool = $x -> is_vector(); 1028 1029=cut 1030 1031sub is_vector { 1032 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1033 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1034 my $x = shift; 1035 return $x -> is_col() || $x -> is_row() ? 1 : 0; 1036} 1037 1038=pod 1039 1040=item is_row() 1041 1042Returns 1 if the invocand has exactly one row, and 0 otherwise. 1043 1044 $bool = $x -> is_row(); 1045 1046=cut 1047 1048sub is_row { 1049 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1050 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1051 my $x = shift; 1052 return $x -> nrow() == 1 ? 1 : 0; 1053} 1054 1055=pod 1056 1057=item is_col() 1058 1059Returns 1 if the invocand has exactly one column, and 0 otherwise. 1060 1061 $bool = $x -> is_col(); 1062 1063=cut 1064 1065sub is_col { 1066 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1067 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1068 my $x = shift; 1069 return $x -> ncol() == 1 ? 1 : 0; 1070} 1071 1072=pod 1073 1074=item is_square() 1075 1076Returns 1 is the invocand is square, and 0 otherwise. 1077 1078 $bool = $x -> is_square(); 1079 1080=cut 1081 1082sub is_square { 1083 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1084 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1085 my $x = shift; 1086 my ($nrow, $ncol) = $x -> size(); 1087 return $nrow == $ncol ? 1 : 0; 1088} 1089 1090=pod 1091 1092=item is_symmetric() 1093 1094Returns 1 is the invocand is symmetric, and 0 otherwise. 1095 1096 $bool = $x -> is_symmetric(); 1097 1098An symmetric matrix satisfies x(i,j) = x(j,i) for all i and j, for example 1099 1100 [ 1 2 -3 ] 1101 [ 2 -4 5 ] 1102 [ -3 5 6 ] 1103 1104=cut 1105 1106sub is_symmetric { 1107 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1108 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1109 my $x = shift; 1110 1111 my ($nrow, $ncol) = $x -> size(); 1112 return 0 unless $nrow == $ncol; 1113 1114 for my $i (1 .. $nrow - 1) { 1115 for my $j (0 .. $i - 1) { 1116 return 0 unless $x -> [$i][$j] == $x -> [$j][$i]; 1117 } 1118 } 1119 1120 return 1; 1121} 1122 1123=pod 1124 1125=item is_antisymmetric() 1126 1127Returns 1 is the invocand is antisymmetric a.k.a. skew-symmetric, and 0 1128otherwise. 1129 1130 $bool = $x -> is_antisymmetric(); 1131 1132An antisymmetric matrix satisfies x(i,j) = -x(j,i) for all i and j, for 1133example 1134 1135 [ 0 2 -3 ] 1136 [ -2 0 4 ] 1137 [ 3 -4 0 ] 1138 1139=cut 1140 1141sub is_antisymmetric { 1142 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1143 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1144 my $x = shift; 1145 1146 my ($nrow, $ncol) = $x -> size(); 1147 return 0 unless $nrow == $ncol; 1148 1149 # Check the diagonal. 1150 1151 for my $i (0 .. $nrow - 1) { 1152 return 0 unless $x -> [$i][$i] == 0; 1153 } 1154 1155 # Check the off-diagonal. 1156 1157 for my $i (1 .. $nrow - 1) { 1158 for my $j (0 .. $i - 1) { 1159 return 0 unless $x -> [$i][$j] == -$x -> [$j][$i]; 1160 } 1161 } 1162 1163 return 1; 1164} 1165 1166=pod 1167 1168=item is_persymmetric() 1169 1170Returns 1 is the invocand is persymmetric, and 0 otherwise. 1171 1172 $bool = $x -> is_persymmetric(); 1173 1174A persymmetric matrix is a square matrix which is symmetric with respect to the 1175anti-diagonal, e.g.: 1176 1177 [ f h j k ] 1178 [ c g i j ] 1179 [ b d g h ] 1180 [ a b c f ] 1181 1182=cut 1183 1184sub is_persymmetric { 1185 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1186 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1187 my $x = shift; 1188 1189 $x -> fliplr() -> is_symmetric(); 1190} 1191 1192=pod 1193 1194=item is_hankel() 1195 1196Returns 1 is the invocand is a Hankel matric a.k.a. a catalecticant matrix, and 11970 otherwise. 1198 1199 $bool = $x -> is_hankel(); 1200 1201A Hankel matrix is a square matrix in which each ascending skew-diagonal from 1202left to right is constant, e.g.: 1203 1204 [ e f g h i ] 1205 [ d e f g h ] 1206 [ c d e f g ] 1207 [ b c d e f ] 1208 [ a b c d e ] 1209 1210=cut 1211 1212sub is_hankel { 1213 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1214 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1215 my $x = shift; 1216 1217 my ($nrow, $ncol) = $x -> size(); 1218 return 0 unless $nrow == $ncol; 1219 1220 # Check the lower triangular part. 1221 1222 for my $i (0 .. $nrow - 2) { 1223 my $first = $x -> [$i][0]; 1224 for my $k (1 .. $nrow - $i - 1) { 1225 return 0 unless $x -> [$i + $k][$k] == $first; 1226 } 1227 } 1228 1229 # Check the strictly upper triangular part. 1230 1231 for my $j (1 .. $ncol - 2) { 1232 my $first = $x -> [0][$j]; 1233 for my $k (1 .. $nrow - $j - 1) { 1234 return 0 unless $x -> [$k][$j + $k] == $first; 1235 } 1236 } 1237 1238 return 1; 1239} 1240 1241=pod 1242 1243=item is_zero() 1244 1245Returns 1 is the invocand is a zero matrix, and 0 otherwise. A zero matrix 1246contains no element whose value is different from zero. 1247 1248 $bool = $x -> is_zero(); 1249 1250=cut 1251 1252sub is_zero { 1253 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1254 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1255 my $x = shift; 1256 return $x -> is_constant(0); 1257} 1258 1259=pod 1260 1261=item is_one() 1262 1263Returns 1 is the invocand is a matrix of ones, and 0 otherwise. A matrix of 1264ones contains no element whose value is different from one. 1265 1266 $bool = $x -> is_one(); 1267 1268=cut 1269 1270sub is_one { 1271 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1272 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1273 my $x = shift; 1274 return $x -> is_constant(1); 1275} 1276 1277=pod 1278 1279=item is_constant() 1280 1281Returns 1 is the invocand is a constant matrix, and 0 otherwise. A constant 1282matrix is a matrix where no two elements have different values. 1283 1284 $bool = $x -> is_constant(); 1285 1286=cut 1287 1288sub is_constant { 1289 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1290 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 1291 my $x = shift; 1292 1293 my ($nrow, $ncol) = $x -> size(); 1294 1295 # An empty matrix contains no elements that are different from $c. 1296 1297 return 1 if $nrow * $ncol == 0; 1298 1299 my $c = @_ ? shift() : $x -> [0][0]; 1300 for my $i (0 .. $nrow - 1) { 1301 for my $j (0 .. $ncol - 1) { 1302 return 0 if $x -> [$i][$j] != $c; 1303 } 1304 } 1305 1306 return 1; 1307} 1308 1309=pod 1310 1311=item is_identity() 1312 1313Returns 1 is the invocand is an identity matrix, and 0 otherwise. An 1314identity matrix contains ones on the main diagonal and zeros elsewhere. 1315 1316 $bool = $x -> is_identity(); 1317 1318=cut 1319 1320sub is_identity { 1321 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1322 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1323 my $x = shift; 1324 1325 my ($nrow, $ncol) = $x -> size(); 1326 return 0 unless $nrow == $ncol; 1327 1328 for my $i (0 .. $nrow - 1) { 1329 for my $j (0 .. $ncol - 1) { 1330 return 0 if $x -> [$i][$j] != ($i == $j ? 1 : 0); 1331 } 1332 } 1333 1334 return 1; 1335} 1336 1337=pod 1338 1339=item is_exchg() 1340 1341Returns 1 is the invocand is an exchange matrix, and 0 otherwise. 1342 1343 $bool = $x -> is_exchg(); 1344 1345An exchange matrix contains ones on the main anti-diagonal and zeros elsewhere, 1346for example 1347 1348 [ 0 0 1 ] 1349 [ 0 1 0 ] 1350 [ 1 0 0 ] 1351 1352=cut 1353 1354sub is_exchg { 1355 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1356 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1357 my $x = shift; 1358 1359 my ($nrow, $ncol) = $x -> size(); 1360 return 0 unless $nrow == $ncol; 1361 1362 my $imax = $nrow - 1; 1363 for my $i (0 .. $nrow - 1) { 1364 for my $j (0 .. $ncol - 1) { 1365 return 0 if $x -> [$i][$j] != ($i + $j == $imax ? 1 : 0); 1366 } 1367 } 1368 1369 return 1; 1370} 1371 1372=pod 1373 1374=item is_bool() 1375 1376Returns 1 is the invocand is a boolean matrix, and 0 otherwise. 1377 1378 $bool = $x -> is_bool(); 1379 1380A boolean matrix is a matrix is a matrix whose entries are either 0 or 1, for 1381example 1382 1383 [ 0 1 1 ] 1384 [ 1 0 0 ] 1385 [ 0 1 0 ] 1386 1387=cut 1388 1389sub is_bool { 1390 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1391 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1392 my $x = shift; 1393 1394 my ($nrow, $ncol) = $x -> size(); 1395 1396 for my $i (0 .. $nrow - 1) { 1397 for my $j (0 .. $ncol - 1) { 1398 my $val = $x -> [$i][$j]; 1399 return 0 if $val != 0 && $val != 1; 1400 } 1401 } 1402 1403 return 1; 1404} 1405 1406=pod 1407 1408=item is_perm() 1409 1410Returns 1 is the invocand is an permutation matrix, and 0 otherwise. 1411 1412 $bool = $x -> is_perm(); 1413 1414A permutation matrix is a square matrix with exactly one 1 in each row and 1415column, and all other elements 0, for example 1416 1417 [ 0 1 0 ] 1418 [ 1 0 0 ] 1419 [ 0 0 1 ] 1420 1421=cut 1422 1423sub is_perm { 1424 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1425 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1426 my $x = shift; 1427 1428 my ($nrow, $ncol) = $x -> size(); 1429 return 0 unless $nrow == $ncol; 1430 1431 my $rowsum = [ (0) x $nrow ]; 1432 my $colsum = [ (0) x $ncol ]; 1433 1434 for my $i (0 .. $nrow - 1) { 1435 for my $j (0 .. $ncol - 1) { 1436 my $val = $x -> [$i][$j]; 1437 return 0 if $val != 0 && $val != 1; 1438 if ($val == 1) { 1439 return 0 if ++$rowsum -> [$i] > 1; 1440 return 0 if ++$colsum -> [$j] > 1; 1441 } 1442 } 1443 } 1444 1445 for my $i (0 .. $nrow - 1) { 1446 return 0 if $rowsum -> [$i] != 1; 1447 return 0 if $colsum -> [$i] != 1; 1448 } 1449 1450 return 1; 1451} 1452 1453=pod 1454 1455=item is_int() 1456 1457Returns 1 is the invocand is an integer matrix, i.e., a matrix of integers, and 14580 otherwise. 1459 1460 $bool = $x -> is_int(); 1461 1462=cut 1463 1464sub is_int { 1465 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1466 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1467 my $x = shift; 1468 1469 my ($nrow, $ncol) = $x -> size(); 1470 1471 for my $i (0 .. $nrow - 1) { 1472 for my $j (0 .. $ncol - 1) { 1473 return 0 unless $x -> [$i][$j] == int $x -> [$i][$j]; 1474 } 1475 } 1476 1477 return 1; 1478} 1479 1480=pod 1481 1482=item is_diag() 1483 1484Returns 1 is the invocand is diagonal, and 0 otherwise. 1485 1486 $bool = $x -> is_diag(); 1487 1488A diagonal matrix is a square matrix where all non-zero elements, if any, are on 1489the main diagonal. It has the following pattern, where only the elements marked 1490as C<x> can be non-zero, 1491 1492 [ x 0 0 0 0 ] 1493 [ 0 x 0 0 0 ] 1494 [ 0 0 x 0 0 ] 1495 [ 0 0 0 x 0 ] 1496 [ 0 0 0 0 x ] 1497 1498=cut 1499 1500sub is_diag { 1501 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1502 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1503 my $x = shift; 1504 $x -> is_band(0); 1505} 1506 1507=pod 1508 1509=item is_adiag() 1510 1511Returns 1 is the invocand is anti-diagonal, and 0 otherwise. 1512 1513 $bool = $x -> is_adiag(); 1514 1515A diagonal matrix is a square matrix where all non-zero elements, if any, are on 1516the main antidiagonal. It has the following pattern, where only the elements 1517marked as C<x> can be non-zero, 1518 1519 [ 0 0 0 0 x ] 1520 [ 0 0 0 x 0 ] 1521 [ 0 0 x 0 0 ] 1522 [ 0 x 0 0 0 ] 1523 [ x 0 0 0 0 ] 1524 1525=cut 1526 1527sub is_adiag { 1528 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1529 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1530 my $x = shift; 1531 $x -> is_aband(0); 1532} 1533 1534=pod 1535 1536=item is_tridiag() 1537 1538Returns 1 is the invocand is tridiagonal, and 0 otherwise. 1539 1540 $bool = $x -> is_tridiag(); 1541 1542A tridiagonal matrix is a square matrix with nonzero elements only on the 1543diagonal and slots horizontally or vertically adjacent the diagonal (i.e., along 1544the subdiagonal and superdiagonal). It has the following pattern, where only the 1545elements marked as C<x> can be non-zero, 1546 1547 [ x x 0 0 0 ] 1548 [ x x x 0 0 ] 1549 [ 0 x x x 0 ] 1550 [ 0 0 x x x ] 1551 [ 0 0 0 x x ] 1552 1553=cut 1554 1555sub is_tridiag { 1556 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1557 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1558 my $x = shift; 1559 $x -> is_band(1); 1560} 1561 1562=pod 1563 1564=item is_atridiag() 1565 1566Returns 1 is the invocand is anti-tridiagonal, and 0 otherwise. 1567 1568 $bool = $x -> is_tridiag(); 1569 1570A anti-tridiagonal matrix is a square matrix with nonzero elements only on the 1571anti-diagonal and slots horizontally or vertically adjacent the diagonal (i.e., 1572along the anti-subdiagonal and anti-superdiagonal). It has the following 1573pattern, where only the elements marked as C<x> can be non-zero, 1574 1575 [ 0 0 0 x x ] 1576 [ 0 0 x x x ] 1577 [ 0 x x x 0 ] 1578 [ x x x 0 0 ] 1579 [ x x 0 0 0 ] 1580 1581=cut 1582 1583sub is_atridiag { 1584 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1585 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1586 my $x = shift; 1587 $x -> is_aband(1); 1588} 1589 1590=pod 1591 1592=item is_pentadiag() 1593 1594Returns 1 is the invocand is pentadiagonal, and 0 otherwise. 1595 1596 $bool = $x -> is_pentadiag(); 1597 1598A pentadiagonal matrix is a square matrix with nonzero elements only on the 1599diagonal and the two diagonals above and below the main diagonal. It has the 1600following pattern, where only the elements marked as C<x> can be non-zero, 1601 1602 [ x x x 0 0 0 ] 1603 [ x x x x 0 0 ] 1604 [ x x x x x 0 ] 1605 [ 0 x x x x x ] 1606 [ 0 0 x x x x ] 1607 [ 0 0 0 x x x ] 1608 1609=cut 1610 1611sub is_pentadiag { 1612 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1613 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1614 my $x = shift; 1615 $x -> is_band(2); 1616} 1617 1618=pod 1619 1620=item is_apentadiag() 1621 1622Returns 1 is the invocand is anti-pentadiagonal, and 0 otherwise. 1623 1624 $bool = $x -> is_pentadiag(); 1625 1626A anti-pentadiagonal matrix is a square matrix with nonzero elements only on the 1627anti-diagonal and two anti-diagonals above and below the main anti-diagonal. It 1628has the following pattern, where only the elements marked as C<x> can be 1629non-zero, 1630 1631 [ 0 0 0 x x x ] 1632 [ 0 0 x x x x ] 1633 [ 0 x x x x x ] 1634 [ x x x x x 0 ] 1635 [ x x x x 0 0 ] 1636 [ x x x 0 0 0 ] 1637 1638=cut 1639 1640sub is_apentadiag { 1641 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1642 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1643 my $x = shift; 1644 $x -> is_aband(2); 1645} 1646 1647=pod 1648 1649=item is_heptadiag() 1650 1651Returns 1 is the invocand is heptadiagonal, and 0 otherwise. 1652 1653 $bool = $x -> is_heptadiag(); 1654 1655A heptadiagonal matrix is a square matrix with nonzero elements only on the 1656diagonal and the two diagonals above and below the main diagonal. It has the 1657following pattern, where only the elements marked as C<x> can be non-zero, 1658 1659 [ x x x x 0 0 ] 1660 [ x x x x x 0 ] 1661 [ x x x x x x ] 1662 [ x x x x x x ] 1663 [ 0 x x x x x ] 1664 [ 0 0 x x x x ] 1665 1666=cut 1667 1668sub is_heptadiag { 1669 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1670 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1671 my $x = shift; 1672 $x -> is_band(3); 1673} 1674 1675=pod 1676 1677=item is_aheptadiag() 1678 1679Returns 1 is the invocand is anti-heptadiagonal, and 0 otherwise. 1680 1681 $bool = $x -> is_heptadiag(); 1682 1683A anti-heptadiagonal matrix is a square matrix with nonzero elements only on the 1684anti-diagonal and two anti-diagonals above and below the main anti-diagonal. It 1685has the following pattern, where only the elements marked as C<x> can be 1686non-zero, 1687 1688 [ 0 0 x x x x ] 1689 [ 0 x x x x x ] 1690 [ x x x x x x ] 1691 [ x x x x x x ] 1692 [ x x x x x 0 ] 1693 [ x x x x 0 0 ] 1694 1695=cut 1696 1697sub is_aheptadiag { 1698 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1699 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1700 my $x = shift; 1701 $x -> is_aband(3); 1702} 1703 1704=pod 1705 1706=item is_band() 1707 1708Returns 1 is the invocand is a band matrix with a specified bandwidth, and 0 1709otherwise. 1710 1711 $bool = $x -> is_band($k); 1712 1713A band matrix is a square matrix with nonzero elements only on the diagonal and 1714on the C<$k> diagonals above and below the main diagonal. The bandwidth C<$k> 1715must be non-negative. 1716 1717 $bool = $x -> is_band(0); # is $x diagonal? 1718 $bool = $x -> is_band(1); # is $x tridiagonal? 1719 $bool = $x -> is_band(2); # is $x pentadiagonal? 1720 $bool = $x -> is_band(3); # is $x heptadiagonal? 1721 1722See also C<L</is_aband()>> and C<L</bandwidth()>>. 1723 1724=cut 1725 1726sub is_band { 1727 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 1728 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 1729 my $x = shift; 1730 my $class = ref $x; 1731 1732 my ($nrow, $ncol) = $x -> size(); 1733 return 0 unless $nrow == $ncol; # must be square 1734 1735 my $k = shift; # bandwidth 1736 croak "Bandwidth can not be undefined" unless defined $k; 1737 if (ref $k) { 1738 $k = $class -> new($k) 1739 unless defined(blessed($k)) && $k -> isa($class); 1740 croak "Bandwidth must be a scalar" unless $k -> is_scalar(); 1741 $k = $k -> [0][0]; 1742 } 1743 1744 return 0 if $nrow <= $k; # if the band doesn't fit inside 1745 return 1 if $nrow == $k + 1; # if the whole band fits exactly 1746 1747 for my $i (0 .. $nrow - $k - 2) { 1748 for my $j ($k + 1 + $i .. $ncol - 1) { 1749 return 0 if ($x -> [$i][$j] != 0 || 1750 $x -> [$j][$i] != 0); 1751 } 1752 } 1753 1754 return 1; 1755} 1756 1757=pod 1758 1759=item is_aband() 1760 1761Returns 1 is the invocand is "anti-banded" with a specified bandwidth, and 0 1762otherwise. 1763 1764 $bool = $x -> is_aband($k); 1765 1766Some examples 1767 1768 $bool = $x -> is_aband(0); # is $x anti-diagonal? 1769 $bool = $x -> is_aband(1); # is $x anti-tridiagonal? 1770 $bool = $x -> is_aband(2); # is $x anti-pentadiagonal? 1771 $bool = $x -> is_aband(3); # is $x anti-heptadiagonal? 1772 1773A band matrix is a square matrix with nonzero elements only on the diagonal and 1774on the C<$k> diagonals above and below the main diagonal. The bandwidth C<$k> 1775must be non-negative. 1776 1777A "anti-banded" matrix is a square matrix with nonzero elements only on the 1778anti-diagonal and C<$k> anti-diagonals above and below the main anti-diagonal. 1779 1780See also C<L</is_band()>> and C<L</bandwidth()>>. 1781 1782=cut 1783 1784sub is_aband { 1785 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 1786 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 1787 my $x = shift; 1788 my $class = ref $x; 1789 1790 my ($nrow, $ncol) = $x -> size(); 1791 return 0 unless $nrow == $ncol; # must be square 1792 1793 my $k = shift; # bandwidth 1794 croak "Bandwidth can not be undefined" unless defined $k; 1795 if (ref $k) { 1796 $k = $class -> new($k) 1797 unless defined(blessed($k)) && $k -> isa($class); 1798 croak "Bandwidth must be a scalar" unless $k -> is_scalar(); 1799 $k = $k -> [0][0]; 1800 } 1801 1802 return 0 if $nrow <= $k; # if the band doesn't fit inside 1803 return 1 if $nrow == $k + 1; # if the whole band fits exactly 1804 1805 # Check upper part. 1806 1807 for my $i (0 .. $nrow - $k - 2) { 1808 for my $j (0 .. $nrow - $k - 2 - $i) { 1809 return 0 if $x -> [$i][$j] != 0; 1810 } 1811 } 1812 1813 # Check lower part. 1814 1815 for my $i ($k + 1 .. $nrow - 1) { 1816 for my $j ($nrow - $i + $k .. $nrow - 1) { 1817 return 0 if $x -> [$i][$j] != 0; 1818 } 1819 } 1820 1821 return 1; 1822} 1823 1824=pod 1825 1826=item is_triu() 1827 1828Returns 1 is the invocand is upper triangular, and 0 otherwise. 1829 1830 $bool = $x -> is_triu(); 1831 1832An upper triangular matrix is a square matrix where all non-zero elements are on 1833or above the main diagonal. It has the following pattern, where only the 1834elements marked as C<x> can be non-zero. It has the following pattern, where 1835only the elements marked as C<x> can be non-zero, 1836 1837 [ x x x x ] 1838 [ 0 x x x ] 1839 [ 0 0 x x ] 1840 [ 0 0 0 x ] 1841 1842=cut 1843 1844sub is_triu { 1845 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1846 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1847 my $x = shift; 1848 1849 my $nrow = $x -> nrow(); 1850 my $ncol = $x -> ncol(); 1851 1852 return 0 unless $nrow == $ncol; 1853 1854 for my $i (1 .. $nrow - 1) { 1855 for my $j (0 .. $i - 1) { 1856 return 0 unless $x -> [$i][$j] == 0; 1857 } 1858 } 1859 1860 return 1; 1861} 1862 1863=pod 1864 1865=item is_striu() 1866 1867Returns 1 is the invocand is strictly upper triangular, and 0 otherwise. 1868 1869 $bool = $x -> is_striu(); 1870 1871A strictly upper triangular matrix is a square matrix where all non-zero 1872elements are strictly above the main diagonal. It has the following pattern, 1873where only the elements marked as C<x> can be non-zero, 1874 1875 [ 0 x x x ] 1876 [ 0 0 x x ] 1877 [ 0 0 0 x ] 1878 [ 0 0 0 0 ] 1879 1880=cut 1881 1882sub is_striu { 1883 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1884 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1885 my $x = shift; 1886 1887 my $nrow = $x -> nrow(); 1888 my $ncol = $x -> ncol(); 1889 1890 return 0 unless $nrow == $ncol; 1891 1892 for my $i (0 .. $nrow - 1) { 1893 for my $j (0 .. $i) { 1894 return 0 unless $x -> [$i][$j] == 0; 1895 } 1896 } 1897 1898 return 1; 1899} 1900 1901=pod 1902 1903=item is_tril() 1904 1905Returns 1 is the invocand is lower triangular, and 0 otherwise. 1906 1907 $bool = $x -> is_tril(); 1908 1909A lower triangular matrix is a square matrix where all non-zero elements are on 1910or below the main diagonal. It has the following pattern, where only the 1911elements marked as C<x> can be non-zero, 1912 1913 [ x 0 0 0 ] 1914 [ x x 0 0 ] 1915 [ x x x 0 ] 1916 [ x x x x ] 1917 1918=cut 1919 1920sub is_tril { 1921 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1922 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1923 my $x = shift; 1924 1925 my $nrow = $x -> nrow(); 1926 my $ncol = $x -> ncol(); 1927 1928 return 0 unless $nrow == $ncol; 1929 1930 for my $i (0 .. $nrow - 1) { 1931 for my $j ($i + 1 .. $ncol - 1) { 1932 return 0 unless $x -> [$i][$j] == 0; 1933 } 1934 } 1935 1936 return 1; 1937} 1938 1939=pod 1940 1941=item is_stril() 1942 1943Returns 1 is the invocand is strictly lower triangular, and 0 otherwise. 1944 1945 $bool = $x -> is_stril(); 1946 1947A strictly lower triangular matrix is a square matrix where all non-zero 1948elements are strictly below the main diagonal. It has the following pattern, 1949where only the elements marked as C<x> can be non-zero, 1950 1951 [ 0 0 0 0 ] 1952 [ x 0 0 0 ] 1953 [ x x 0 0 ] 1954 [ x x x 0 ] 1955 1956=cut 1957 1958sub is_stril { 1959 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1960 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1961 my $x = shift; 1962 1963 my $nrow = $x -> nrow(); 1964 my $ncol = $x -> ncol(); 1965 1966 return 0 unless $nrow == $ncol; 1967 1968 for my $i (0 .. $nrow - 1) { 1969 for my $j ($i .. $ncol - 1) { 1970 return 0 unless $x -> [$i][$j] == 0; 1971 } 1972 } 1973 1974 return 1; 1975} 1976 1977=pod 1978 1979=item is_atriu() 1980 1981Returns 1 is the invocand is upper anti-triangular, and 0 otherwise. 1982 1983 $bool = $x -> is_atriu(); 1984 1985An upper anti-triangular matrix is a square matrix where all non-zero elements 1986are on or above the main anti-diagonal. It has the following pattern, where only 1987the elements marked as C<x> can be non-zero, 1988 1989 [ x x x x ] 1990 [ x x x 0 ] 1991 [ x x 0 0 ] 1992 [ x 0 0 0 ] 1993 1994=cut 1995 1996sub is_atriu { 1997 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 1998 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 1999 my $x = shift; 2000 2001 my $nrow = $x -> nrow(); 2002 my $ncol = $x -> ncol(); 2003 2004 return 0 unless $nrow == $ncol; 2005 2006 for my $i (1 .. $nrow - 1) { 2007 for my $j ($ncol - $i .. $ncol - 1) { 2008 return 0 unless $x -> [$i][$j] == 0; 2009 } 2010 } 2011 2012 return 1; 2013} 2014 2015=pod 2016 2017=item is_satriu() 2018 2019Returns 1 is the invocand is strictly upper anti-triangular, and 0 otherwise. 2020 2021 $bool = $x -> is_satriu(); 2022 2023A strictly anti-triangular matrix is a square matrix where all non-zero elements 2024are strictly above the main diagonal. It has the following pattern, where only 2025the elements marked as C<x> can be non-zero, 2026 2027 [ x x x 0 ] 2028 [ x x 0 0 ] 2029 [ x 0 0 0 ] 2030 [ 0 0 0 0 ] 2031 2032=cut 2033 2034sub is_satriu { 2035 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 2036 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 2037 my $x = shift; 2038 2039 my $nrow = $x -> nrow(); 2040 my $ncol = $x -> ncol(); 2041 2042 return 0 unless $nrow == $ncol; 2043 2044 for my $i (0 .. $nrow - 1) { 2045 for my $j ($ncol - $i - 1 .. $ncol - 1) { 2046 return 0 unless $x -> [$i][$j] == 0; 2047 } 2048 } 2049 2050 return 1; 2051} 2052 2053=pod 2054 2055=item is_atril() 2056 2057Returns 1 is the invocand is lower anti-triangular, and 0 otherwise. 2058 2059 $bool = $x -> is_atril(); 2060 2061A lower anti-triangular matrix is a square matrix where all non-zero elements 2062are on or below the main anti-diagonal. It has the following pattern, where only 2063the elements marked as C<x> can be non-zero, 2064 2065 [ 0 0 0 x ] 2066 [ 0 0 x x ] 2067 [ 0 x x x ] 2068 [ x x x x ] 2069 2070=cut 2071 2072sub is_atril { 2073 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 2074 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 2075 my $x = shift; 2076 2077 my $nrow = $x -> nrow(); 2078 my $ncol = $x -> ncol(); 2079 2080 return 0 unless $nrow == $ncol; 2081 2082 for my $i (0 .. $nrow - 1) { 2083 for my $j (0 .. $ncol - $i - 2) { 2084 return 0 unless $x -> [$i][$j] == 0; 2085 } 2086 } 2087 2088 return 1; 2089} 2090 2091=pod 2092 2093=item is_satril() 2094 2095Returns 1 is the invocand is strictly lower anti-triangular, and 0 otherwise. 2096 2097 $bool = $x -> is_satril(); 2098 2099A strictly lower anti-triangular matrix is a square matrix where all non-zero 2100elements are strictly below the main anti-diagonal. It has the following 2101pattern, where only the elements marked as C<x> can be non-zero, 2102 2103 [ 0 0 0 0 ] 2104 [ 0 0 0 x ] 2105 [ 0 0 x x ] 2106 [ 0 x x x ] 2107 2108=cut 2109 2110sub is_satril { 2111 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 2112 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 2113 my $x = shift; 2114 2115 my $nrow = $x -> nrow(); 2116 my $ncol = $x -> ncol(); 2117 2118 return 0 unless $nrow == $ncol; 2119 2120 for my $i (0 .. $nrow - 1) { 2121 for my $j (0 .. $ncol - $i - 1) { 2122 return 0 unless $x -> [$i][$j] == 0; 2123 } 2124 } 2125 2126 return 1; 2127} 2128 2129=pod 2130 2131=back 2132 2133=head2 Identify elements 2134 2135This section contains methods for identifying and locating elements within an 2136array. See also C<L</Scalar comparison>>. 2137 2138=over 4 2139 2140=item find() 2141 2142Returns the location of each non-zero element. 2143 2144 $K = $x -> find(); # linear index 2145 ($I, $J) = $x -> find(); # subscripts 2146 2147For example, to find the linear index of each element that is greater than or 2148equal to 1, use 2149 2150 $K = $x -> sge(1) -> find(); 2151 2152=cut 2153 2154sub find { 2155 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 2156 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 2157 my $x = shift; 2158 2159 my ($m, $n) = $x -> size(); 2160 2161 my $I = []; 2162 my $J = []; 2163 for my $j (0 .. $n - 1) { 2164 for my $i (0 .. $m - 1) { 2165 next unless $x->[$i][$j]; 2166 push @$I, $i; 2167 push @$J, $j; 2168 } 2169 } 2170 2171 return $I, $J if wantarray; 2172 2173 my $K = [ map { $m * $J -> [$_] + $I -> [$_] } 0 .. $#$I ]; 2174 return $K; 2175} 2176 2177=pod 2178 2179=item is_finite() 2180 2181Returns a matrix of ones and zeros. The element is one if the corresponding 2182element in the invocand matrix is finite, and zero otherwise. 2183 2184 $y = $x -> is_finite(); 2185 2186=cut 2187 2188sub is_finite { 2189 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 2190 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 2191 my $x = shift; 2192 2193 require Math::Trig; 2194 my $pinf = Math::Trig::Inf(); # positiv infinity 2195 my $ninf = -$pinf; # negative infinity 2196 2197 bless [ map { [ 2198 map { 2199 $ninf < $_ && $_ < $pinf ? 1 : 0 2200 } @$_ 2201 ] } @$x ], ref $x; 2202} 2203 2204=pod 2205 2206=item is_inf() 2207 2208Returns a matrix of ones and zeros. The element is one if the corresponding 2209element in the invocand matrix is positive or negative infinity, and zero 2210otherwise. 2211 2212 $y = $x -> is_inf(); 2213 2214=cut 2215 2216sub is_inf { 2217 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 2218 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 2219 my $x = shift; 2220 2221 require Math::Trig; 2222 my $pinf = Math::Trig::Inf(); # positiv infinity 2223 my $ninf = -$pinf; # negative infinity 2224 2225 bless [ map { [ 2226 map { 2227 $_ == $pinf || $_ == $ninf ? 1 : 0; 2228 } @$_ 2229 ] } @$x ], ref $x; 2230} 2231 2232=pod 2233 2234=item is_nan() 2235 2236Returns a matrix of ones and zeros. The element is one if the corresponding 2237element in the invocand matrix is a NaN (Not-a-Number), and zero otherwise. 2238 2239 $y = $x -> is_nan(); 2240 2241=cut 2242 2243sub is_nan { 2244 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 2245 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 2246 my $x = shift; 2247 2248 bless [ map [ map { $_ != $_ ? 1 : 0 } @$_ ], @$x ], ref $x; 2249} 2250 2251=pod 2252 2253=item all() 2254 2255Tests whether all of the elements along various dimensions of a matrix are 2256non-zero. If the dimension argument is not given, the first non-singleton 2257dimension is used. 2258 2259 $y = $x -> all($dim); 2260 $y = $x -> all(); 2261 2262=cut 2263 2264sub all { 2265 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 2266 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 2267 my $x = shift; 2268 $x -> apply(\&_all, @_); 2269} 2270 2271=pod 2272 2273=item any() 2274 2275Tests whether any of the elements along various dimensions of a matrix are 2276non-zero. If the dimension argument is not given, the first non-singleton 2277dimension is used. 2278 2279 $y = $x -> any($dim); 2280 $y = $x -> any(); 2281 2282=cut 2283 2284sub any { 2285 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 2286 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 2287 my $x = shift; 2288 $x -> apply(\&_any, @_); 2289} 2290 2291=pod 2292 2293=item cumall() 2294 2295A cumulative variant of C<L</all()>>. If the dimension argument is not given, 2296the first non-singleton dimension is used. 2297 2298 $y = $x -> cumall($dim); 2299 $y = $x -> cumall(); 2300 2301=cut 2302 2303sub cumall { 2304 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 2305 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 2306 my $x = shift; 2307 $x -> apply(\&_cumall, @_); 2308} 2309 2310=pod 2311 2312=item cumany() 2313 2314A cumulative variant of C<L</all()>>. If the dimension argument is not given, 2315the first non-singleton dimension is used. 2316 2317 $y = $x -> cumany($dim); 2318 $y = $x -> cumany(); 2319 2320=cut 2321 2322sub cumany { 2323 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 2324 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 2325 my $x = shift; 2326 $x -> apply(\&_cumany, @_); 2327} 2328 2329=pod 2330 2331=back 2332 2333=head2 Basic properties 2334 2335=over 4 2336 2337=item size() 2338 2339You can determine the dimensions of a matrix by calling: 2340 2341 ($m, $n) = $a -> size; 2342 2343=cut 2344 2345sub size { 2346 my $self = shift; 2347 my $m = @{$self}; 2348 my $n = $m ? @{$self->[0]} : 0; 2349 ($m, $n); 2350} 2351 2352=pod 2353 2354=item nelm() 2355 2356Returns the number of elements in the matrix. 2357 2358 $n = $x -> nelm(); 2359 2360=cut 2361 2362sub nelm { 2363 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 2364 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 2365 my $x = shift; 2366 return @$x ? @$x * @{$x->[0]} : 0; 2367} 2368 2369=pod 2370 2371=item nrow() 2372 2373Returns the number of rows. 2374 2375 $m = $x -> nrow(); 2376 2377=cut 2378 2379sub nrow { 2380 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 2381 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 2382 my $x = shift; 2383 return scalar @$x; 2384} 2385 2386=pod 2387 2388=item ncol() 2389 2390Returns the number of columns. 2391 2392 $n = $x -> ncol(); 2393 2394=cut 2395 2396sub ncol { 2397 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 2398 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 2399 my $x = shift; 2400 return @$x ? scalar(@{$x->[0]}) : 0; 2401} 2402 2403=pod 2404 2405=item npag() 2406 2407Returns the number of pages. A non-matrix has one page. 2408 2409 $n = $x -> pag(); 2410 2411=cut 2412 2413sub npag { 2414 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 2415 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 2416 my $x = shift; 2417 return @$x ? 1 : 0; 2418} 2419 2420=pod 2421 2422=item ndim() 2423 2424Returns the number of dimensions. This is the number of dimensions along which 2425the length is different from one. 2426 2427 $n = $x -> ndim(); 2428 2429=cut 2430 2431sub ndim { 2432 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 2433 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 2434 my $x = shift; 2435 my ($nrow, $ncol) = $x -> size(); 2436 my $ndim = 0; 2437 ++$ndim if $nrow != 1; 2438 ++$ndim if $ncol != 1; 2439 return $ndim; 2440} 2441 2442=pod 2443 2444=item bandwidth() 2445 2446Returns the bandwidth of a matrix. In scalar context, returns the number of the 2447non-zero diagonal furthest away from the main diagonal. In list context, 2448separate values are returned for the lower and upper bandwidth. 2449 2450 $n = $x -> bandwidth(); 2451 ($l, $u) = $x -> bandwidth(); 2452 2453The bandwidth is a non-negative integer. If the bandwidth is 0, the matrix is 2454diagonal or zero. If the bandwidth is 1, the matrix is tridiagonal. If the 2455bandwidth is 2, the matrix is pentadiagonal etc. 2456 2457A matrix with the following pattern, where C<x> denotes a non-zero value, would 2458return 2 in scalar context, and (1,2) in list context. 2459 2460 [ x x x 0 0 0 ] 2461 [ x x x x 0 0 ] 2462 [ 0 x x x x 0 ] 2463 [ 0 0 x x x x ] 2464 [ 0 0 0 x x x ] 2465 [ 0 0 0 0 x x ] 2466 2467See also C<L</is_band()>> and C<L</is_aband()>>. 2468 2469=cut 2470 2471sub bandwidth { 2472 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 2473 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 2474 my $x = shift; 2475 2476 my ($nrow, $ncol) = $x -> size(); 2477 2478 my $upper = 0; 2479 my $lower = 0; 2480 2481 for my $i (0 .. $nrow - 1) { 2482 for my $j (0 .. $ncol - 1) { 2483 next if $x -> [$i][$j] == 0; 2484 my $dist = $j - $i; 2485 if ($dist > 0) { 2486 $upper = $dist if $dist > $upper; 2487 } else { 2488 $lower = $dist if $dist < $lower; 2489 } 2490 } 2491 } 2492 2493 $lower = -$lower; 2494 return $lower, $upper if wantarray; 2495 return $lower > $upper ? $lower : $upper; 2496} 2497 2498=pod 2499 2500=back 2501 2502=head2 Manipulate matrices 2503 2504These methods are for combining matrices, splitting matrices, extracing parts of 2505a matrix, inserting new parts into a matrix, deleting parts of a matrix etc. 2506There are also methods for shuffling elements around (relocating elements) 2507inside a matrix. 2508 2509These methods are not concerned with the values of the elements. 2510 2511=over 4 2512 2513=item catrow() 2514 2515Concatenate rows, i.e., concatenate matrices vertically. Any number of arguments 2516is allowed. All non-empty matrices must have the same number or columns. The 2517result is a new matrix. 2518 2519 $x = Math::Matrix -> new([1, 2], [4, 5]); # 2-by-2 matrix 2520 $y = Math::Matrix -> new([3, 6]); # 1-by-2 matrix 2521 $z = $x -> catrow($y); # 3-by-2 matrix 2522 2523=cut 2524 2525sub catrow { 2526 my $x = shift; 2527 my $class = ref $x; 2528 2529 my $ncol; 2530 my $z = bless [], $class; # initialize output 2531 2532 for my $y ($x, @_) { 2533 my $ncoly = $y -> ncol(); 2534 next if $ncoly == 0; # ignore empty $y 2535 2536 if (defined $ncol) { 2537 croak "All operands must have the same number of columns in ", 2538 (caller(0))[3] unless $ncoly == $ncol; 2539 } else { 2540 $ncol = $ncoly; 2541 } 2542 2543 push @$z, map [ @$_ ], @$y; 2544 } 2545 2546 return $z; 2547} 2548 2549=pod 2550 2551=item catcol() 2552 2553Concatenate columns, i.e., matrices horizontally. Any number of arguments is 2554allowed. All non-empty matrices must have the same number or rows. The result is 2555a new matrix. 2556 2557 $x = Math::Matrix -> new([1, 2], [4, 5]); # 2-by-2 matrix 2558 $y = Math::Matrix -> new([3], [6]); # 2-by-1 matrix 2559 $z = $x -> catcol($y); # 2-by-3 matrix 2560 2561=cut 2562 2563sub catcol { 2564 my $x = shift; 2565 my $class = ref $x; 2566 2567 my $nrow; 2568 my $z = bless [], $class; # initialize output 2569 2570 for my $y ($x, @_) { 2571 my $nrowy = $y -> nrow(); 2572 next if $nrowy == 0; # ignore empty $y 2573 2574 if (defined $nrow) { 2575 croak "All operands must have the same number of rows in ", 2576 (caller(0))[3] unless $nrowy == $nrow; 2577 } else { 2578 $nrow = $nrowy; 2579 } 2580 2581 for my $i (0 .. $nrow - 1) { 2582 push @{ $z -> [$i] }, @{ $y -> [$i] }; 2583 } 2584 } 2585 2586 return $z; 2587} 2588 2589=pod 2590 2591=item getrow() 2592 2593Get the specified row(s). Returns a new matrix with the specified rows. The 2594number of rows in the output is identical to the number of elements in the 2595input. 2596 2597 $y = $x -> getrow($i); # get one 2598 $y = $x -> getrow([$i0, $i1, $i2]); # get multiple 2599 2600=cut 2601 2602sub getrow { 2603 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 2604 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 2605 my $x = shift; 2606 my $class = ref $x; 2607 2608 my $idx = shift; 2609 croak "Row index can not be undefined" unless defined $idx; 2610 if (ref $idx) { 2611 $idx = __PACKAGE__ -> new($idx) 2612 unless defined(blessed($idx)) && $idx -> isa($class); 2613 $idx = $idx -> to_row(); 2614 $idx = $idx -> [0]; 2615 } else { 2616 $idx = [ $idx ]; 2617 } 2618 2619 my ($nrowx, $ncolx) = $x -> size(); 2620 2621 my $y = []; 2622 for my $iy (0 .. $#$idx) { 2623 my $ix = $idx -> [$iy]; 2624 croak "Row index value $ix too large for $nrowx-by-$ncolx matrix in ", 2625 (caller(0))[3] if $ix >= $nrowx; 2626 $y -> [$iy] = [ @{ $x -> [$ix] } ]; 2627 } 2628 2629 bless $y, $class; 2630} 2631 2632=pod 2633 2634=item getcol() 2635 2636Get the specified column(s). Returns a new matrix with the specified columns. 2637The number of columns in the output is identical to the number of elements in 2638the input. 2639 2640 $y = $x -> getcol($j); # get one 2641 $y = $x -> getcol([$j0, $j1, $j2]); # get multiple 2642 2643=cut 2644 2645sub getcol { 2646 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 2647 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 2648 my $x = shift; 2649 my $class = ref $x; 2650 2651 my $idx = shift; 2652 croak "Column index can not be undefined" unless defined $idx; 2653 if (ref $idx) { 2654 $idx = __PACKAGE__ -> new($idx) 2655 unless defined(blessed($idx)) && $idx -> isa($class); 2656 $idx = $idx -> to_row(); 2657 $idx = $idx -> [0]; 2658 } else { 2659 $idx = [ $idx ]; 2660 } 2661 2662 my ($nrowx, $ncolx) = $x -> size(); 2663 2664 my $y = []; 2665 for my $jy (0 .. $#$idx) { 2666 my $jx = $idx -> [$jy]; 2667 croak "Column index value $jx too large for $nrowx-by-$ncolx matrix in ", 2668 (caller(0))[3] if $jx >= $ncolx; 2669 for my $i (0 .. $nrowx - 1) { 2670 $y -> [$i][$jy] = $x -> [$i][$jx]; 2671 } 2672 } 2673 2674 bless $y, $class; 2675} 2676 2677=pod 2678 2679=item delrow() 2680 2681Delete row(s). Returns a new matrix identical to the invocand but with the 2682specified row(s) deleted. 2683 2684 $y = $x -> delrow($i); # delete one 2685 $y = $x -> delrow([$i0, $i1, $i2]); # delete multiple 2686 2687=cut 2688 2689sub delrow { 2690 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 2691 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 2692 my $x = shift; 2693 my $class = ref $x; 2694 2695 my $idxdel = shift; 2696 croak "Row index can not be undefined" unless defined $idxdel; 2697 if (ref $idxdel) { 2698 $idxdel = __PACKAGE__ -> new($idxdel) 2699 unless defined(blessed($idxdel)) && $idxdel -> isa($class); 2700 $idxdel = $idxdel -> to_row(); 2701 $idxdel = $idxdel -> [0]; 2702 } else { 2703 $idxdel = [ $idxdel ]; 2704 } 2705 2706 my $nrowx = $x -> nrow(); 2707 2708 # This should be made faster. 2709 2710 my $idxget = []; 2711 for my $i (0 .. $nrowx - 1) { 2712 my $seen = 0; 2713 for my $idx (@$idxdel) { 2714 if ($i == int $idx) { 2715 $seen = 1; 2716 last; 2717 } 2718 } 2719 push @$idxget, $i unless $seen; 2720 } 2721 2722 my $y = []; 2723 @$y = map [ @$_ ], @$x[ @$idxget ]; 2724 bless $y, $class; 2725} 2726 2727=pod 2728 2729=item delcol() 2730 2731Delete column(s). Returns a new matrix identical to the invocand but with the 2732specified column(s) deleted. 2733 2734 $y = $x -> delcol($j); # delete one 2735 $y = $x -> delcol([$j0, $j1, $j2]); # delete multiple 2736 2737=cut 2738 2739sub delcol { 2740 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 2741 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 2742 my $x = shift; 2743 my $class = ref $x; 2744 2745 my $idxdel = shift; 2746 croak "Column index can not be undefined" unless defined $idxdel; 2747 if (ref $idxdel) { 2748 $idxdel = __PACKAGE__ -> new($idxdel) 2749 unless defined(blessed($idxdel)) && $idxdel -> isa($class); 2750 $idxdel = $idxdel -> to_row(); 2751 $idxdel = $idxdel -> [0]; 2752 } else { 2753 $idxdel = [ $idxdel ]; 2754 } 2755 2756 my ($nrowx, $ncolx) = $x -> size(); 2757 2758 # This should be made faster. 2759 2760 my $idxget = []; 2761 for my $j (0 .. $ncolx - 1) { 2762 my $seen = 0; 2763 for my $idx (@$idxdel) { 2764 if ($j == int $idx) { 2765 $seen = 1; 2766 last; 2767 } 2768 } 2769 push @$idxget, $j unless $seen; 2770 } 2771 2772 my $y = []; 2773 if (@$idxget) { 2774 for my $row (@$x) { 2775 push @$y, [ @{$row}[ @$idxget ] ]; 2776 } 2777 } 2778 bless $y, $class; 2779} 2780 2781=pod 2782 2783=item concat() 2784 2785Concatenate two matrices horizontally. The matrices must have the same number of 2786rows. The result is a new matrix or B<undef> in case of error. 2787 2788 $x = Math::Matrix -> new([1, 2], [4, 5]); # 2-by-2 matrix 2789 $y = Math::Matrix -> new([3], [6]); # 2-by-1 matrix 2790 $z = $x -> concat($y); # 2-by-3 matrix 2791 2792=cut 2793 2794sub concat { 2795 my $self = shift; 2796 my $other = shift; 2797 my $result = $self->clone(); 2798 2799 return undef if scalar(@{$self}) != scalar(@{$other}); 2800 for my $i (0 .. $#{$self}) { 2801 push @{$result->[$i]}, @{$other->[$i]}; 2802 } 2803 $result; 2804} 2805 2806=pod 2807 2808=item splicerow() 2809 2810Row splicing. This is like Perl's built-in splice() function, except that it 2811works on the rows of a matrix. 2812 2813 $y = $x -> splicerow($offset); 2814 $y = $x -> splicerow($offset, $length); 2815 $y = $x -> splicerow($offset, $length, $a, $b, ...); 2816 2817The built-in splice() function modifies the first argument and returns the 2818removed elements, if any. However, since splicerow() does not modify the 2819invocand, it returns the modified version as the first output argument and the 2820removed part as a (possibly empty) second output argument. 2821 2822 $x = Math::Matrix -> new([[ 1, 2], 2823 [ 3, 4], 2824 [ 5, 6], 2825 [ 7, 8]]); 2826 $a = Math::Matrix -> new([[11, 12], 2827 [13, 14]]); 2828 ($y, $z) = $x -> splicerow(1, 2, $a); 2829 2830Gives C<$y> 2831 2832 [ 1 2 ] 2833 [ 11 12 ] 2834 [ 13 14 ] 2835 [ 7 8 ] 2836 2837and C<$z> 2838 2839 [ 3 4 ] 2840 [ 5 6 ] 2841 2842=cut 2843 2844sub splicerow { 2845 croak "Not enough input arguments" if @_ < 1; 2846 my $x = shift; 2847 my $class = ref $x; 2848 2849 my $offs = 0; 2850 my $len = $x -> nrow(); 2851 my $repl = $class -> new([]); 2852 2853 if (@_) { 2854 $offs = shift; 2855 croak "Offset can not be undefined" unless defined $offs; 2856 if (ref $offs) { 2857 $offs = $class -> new($offs) 2858 unless defined(blessed($offs)) && $offs -> isa($class); 2859 croak "Offset must be a scalar" unless $offs -> is_scalar(); 2860 $offs = $offs -> [0][0]; 2861 } 2862 2863 if (@_) { 2864 $len = shift; 2865 croak "Length can not be undefined" unless defined $len; 2866 if (ref $len) { 2867 $len = $class -> new($len) 2868 unless defined(blessed($len)) && $len -> isa($class); 2869 croak "length must be a scalar" unless $len -> is_scalar(); 2870 $len = $len -> [0][0]; 2871 } 2872 2873 if (@_) { 2874 $repl = $repl -> catrow(@_); 2875 } 2876 } 2877 } 2878 2879 my $y = $x -> clone(); 2880 my $z = $class -> new([]); 2881 2882 @$z = splice @$y, $offs, $len, @$repl; 2883 return wantarray ? ($y, $z) : $y; 2884} 2885 2886=pod 2887 2888=item splicecol() 2889 2890Column splicing. This is like Perl's built-in splice() function, except that it 2891works on the columns of a matrix. 2892 2893 $y = $x -> splicecol($offset); 2894 $y = $x -> splicecol($offset, $length); 2895 $y = $x -> splicecol($offset, $length, $a, $b, ...); 2896 2897The built-in splice() function modifies the first argument and returns the 2898removed elements, if any. However, since splicecol() does not modify the 2899invocand, it returns the modified version as the first output argument and the 2900removed part as a (possibly empty) second output argument. 2901 2902 $x = Math::Matrix -> new([[ 1, 3, 5, 7 ], 2903 [ 2, 4, 6, 8 ]]); 2904 $a = Math::Matrix -> new([[11, 13], 2905 [12, 14]]); 2906 ($y, $z) = $x -> splicerow(1, 2, $a); 2907 2908Gives C<$y> 2909 2910 [ 1 11 13 7 ] 2911 [ 2 12 14 8 ] 2912 2913and C<$z> 2914 2915 [ 3 5 ] 2916 [ 4 6 ] 2917 2918=cut 2919 2920sub splicecol { 2921 croak "Not enough input arguments" if @_ < 1; 2922 my $x = shift; 2923 my $class = ref $x; 2924 2925 my ($nrowx, $ncolx) = $x -> size(); 2926 2927 my $offs = 0; 2928 my $len = $ncolx; 2929 my $repl = $class -> new([]); 2930 2931 if (@_) { 2932 $offs = shift; 2933 croak "Offset can not be undefined" unless defined $offs; 2934 if (ref $offs) { 2935 $offs = $class -> new($offs) 2936 unless defined(blessed($offs)) && $offs -> isa($class); 2937 croak "Offset must be a scalar" unless $offs -> is_scalar(); 2938 $offs = $offs -> [0][0]; 2939 } 2940 2941 if (@_) { 2942 $len = shift; 2943 croak "Length can not be undefined" unless defined $len; 2944 if (ref $len) { 2945 $len = $class -> new($len) 2946 unless defined(blessed($len)) && $len -> isa($class); 2947 croak "length must be a scalar" unless $len -> is_scalar(); 2948 $len = $len -> [0][0]; 2949 } 2950 2951 if (@_) { 2952 $repl = $repl -> catcol(@_); 2953 } 2954 } 2955 } 2956 2957 my $y = $x -> clone(); 2958 my $z = $class -> new([]); 2959 2960 if ($offs > $len) { 2961 carp "splicecol() offset past end of array"; 2962 $offs = $len; 2963 } 2964 2965 # The case when we are not removing anything from the invocand matrix: If 2966 # the offset is identical to the number of columns in the invocand matrix, 2967 # just appending the replacement matrix to the invocand matrix. 2968 2969 if ($offs == $len) { 2970 unless ($repl -> is_empty()) { 2971 for my $i (0 .. $nrowx - 1) { 2972 push @{ $y -> [$i] }, @{ $repl -> [$i] }; 2973 } 2974 } 2975 } 2976 2977 # The case when we are removing everything from the invocand matrix: If the 2978 # offset is zero, and the length is identical to the number of columns in 2979 # the invocand matrix, replace the whole invocand matrix with the 2980 # replacement matrix. 2981 2982 elsif ($offs == 0 && $len == $ncolx) { 2983 @$z = @$y; 2984 @$y = @$repl; 2985 } 2986 2987 # The case when we are removing parts of the invocand matrix. 2988 2989 else { 2990 if ($repl -> is_empty()) { 2991 for my $i (0 .. $nrowx - 1) { 2992 @{ $z -> [$i] } = splice @{ $y -> [$i] }, $offs, $len; 2993 } 2994 } else { 2995 for my $i (0 .. $nrowx - 1) { 2996 @{ $z -> [$i] } = splice @{ $y -> [$i] }, $offs, $len, @{ $repl -> [$i] }; 2997 } 2998 } 2999 } 3000 3001 return wantarray ? ($y, $z) : $y; 3002} 3003 3004=pod 3005 3006=item swaprc() 3007 3008Swap rows and columns. This method does nothing but shuffle elements around. For 3009real numbers, swaprc() is identical to the transpose() method. 3010 3011A subclass implementing a matrix of complex numbers should provide a transpose() 3012method that also takes the complex conjugate of each elements. The swaprc() 3013method, on the other hand, should only shuffle elements around. 3014 3015=cut 3016 3017sub swaprc { 3018 my $x = shift; 3019 my $class = ref $x; 3020 3021 my $y = bless [], $class; 3022 my $ncolx = $x -> ncol(); 3023 return $y if $ncolx == 0; 3024 3025 for my $j (0 .. $ncolx - 1) { 3026 push @$y, [ map $_->[$j], @$x ]; 3027 } 3028 return $y; 3029} 3030 3031=pod 3032 3033=item flipud() 3034 3035Flip upside-down, i.e., flip along dimension 1. 3036 3037 $y = $x -> flipud(); 3038 3039=cut 3040 3041sub flipud { 3042 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 3043 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 3044 my $x = shift; 3045 my $class = ref $x; 3046 3047 my $y = [ reverse map [ @$_ ], @$x ]; 3048 bless $y, $class;; 3049} 3050 3051=pod 3052 3053=item fliplr() 3054 3055Flip left-to-right, i.e., flip along dimension 2. 3056 3057 $y = $x -> fliplr(); 3058 3059=cut 3060 3061sub fliplr { 3062 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 3063 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 3064 my $x = shift; 3065 my $class = ref $x; 3066 3067 my $y = [ map [ reverse @$_ ], @$x ]; 3068 bless $y, $class; 3069} 3070 3071=pod 3072 3073=item flip() 3074 3075Flip along various dimensions of a matrix. If the dimension argument is not 3076given, the first non-singleton dimension is used. 3077 3078 $y = $x -> flip($dim); 3079 $y = $x -> flip(); 3080 3081See also C<L</flipud()>> and C<L</fliplr()>>. 3082 3083=cut 3084 3085sub flip { 3086 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 3087 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 3088 my $x = shift; 3089 $x -> apply(sub { reverse @_ }, @_); 3090} 3091 3092=pod 3093 3094=item rot90() 3095 3096Rotate 90 degrees counterclockwise. 3097 3098 $y = $x -> rot90(); # rotate 90 degrees counterclockwise 3099 $y = $x -> rot90($n); # rotate 90*$n degrees counterclockwise 3100 3101=cut 3102 3103sub rot90 { 3104 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 3105 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 3106 my $x = shift; 3107 my $class = ref $x; 3108 3109 my $n = 1; 3110 if (@_) { 3111 $n = shift; 3112 if (ref $n) { 3113 $n = $class -> new($n) 3114 unless defined(blessed($n)) && $n -> isa($class); 3115 croak "Argument must be a scalar" unless $n -> is_scalar(); 3116 $n = $n -> [0][0]; 3117 } 3118 croak "Argument must be an integer" unless $n == int $n; 3119 } 3120 3121 my $y = []; 3122 3123 # Rotate 0 degrees, i.e., clone. 3124 3125 $n %= 4; 3126 if ($n == 0) { 3127 $y = [ map [ @$_ ], @$x ]; 3128 } 3129 3130 # Rotate 90 degrees. 3131 3132 elsif ($n == 1) { 3133 my ($nrowx, $ncolx) = $x -> size(); 3134 my $jmax = $ncolx - 1; 3135 for my $i (0 .. $nrowx - 1) { 3136 for my $j (0 .. $ncolx - 1) { 3137 $y -> [$jmax - $j][$i] = $x -> [$i][$j]; 3138 } 3139 } 3140 } 3141 3142 # Rotate 180 degrees. 3143 3144 elsif ($n == 2) { 3145 $y = [ map [ reverse @$_ ], reverse @$x ]; 3146 } 3147 3148 # Rotate 270 degrees. 3149 3150 elsif ($n == 3) { 3151 my ($nrowx, $ncolx) = $x -> size(); 3152 my $imax = $nrowx - 1; 3153 for my $i (0 .. $nrowx - 1) { 3154 for my $j (0 .. $ncolx - 1) { 3155 $y -> [$j][$imax - $i] = $x -> [$i][$j]; 3156 } 3157 } 3158 } 3159 3160 bless $y, $class; 3161} 3162 3163=pod 3164 3165=item rot180() 3166 3167Rotate 180 degrees. 3168 3169 $y = $x -> rot180(); 3170 3171=cut 3172 3173sub rot180 { 3174 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 3175 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 3176 my $x = shift; 3177 $x -> rot90(2); 3178} 3179 3180=pod 3181 3182=item rot270() 3183 3184Rotate 270 degrees counterclockwise, i.e., 90 degrees clockwise. 3185 3186 $y = $x -> rot270(); 3187 3188=cut 3189 3190sub rot270 { 3191 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 3192 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 3193 my $x = shift; 3194 $x -> rot90(3); 3195} 3196 3197=pod 3198 3199=item repelm() 3200 3201Repeat elements. 3202 3203 $x -> repelm($y); 3204 3205Repeats each element in $x the number of times specified in $y. 3206 3207If $x is the matrix 3208 3209 [ 4 5 6 ] 3210 [ 7 8 9 ] 3211 3212and $y is 3213 3214 [ 3 2 ] 3215 3216the returned matrix is 3217 3218 [ 4 4 5 5 6 6 ] 3219 [ 4 4 5 5 6 6 ] 3220 [ 4 4 5 5 6 6 ] 3221 [ 7 7 8 8 9 9 ] 3222 [ 7 7 8 8 9 9 ] 3223 [ 7 7 8 8 9 9 ] 3224 3225=cut 3226 3227sub repelm { 3228 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 3229 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 3230 my $x = shift; 3231 my $class = ref $x; 3232 3233 my $y = shift; 3234 $y = __PACKAGE__ -> new($y) 3235 unless defined(blessed($y)) && $y -> isa(__PACKAGE__); 3236 croak "Input argument must contain two elements" 3237 unless $y -> nelm() == 2; 3238 3239 my ($nrowx, $ncolx) = $x -> size(); 3240 3241 $y = $y -> to_col(); 3242 my $nrowrep = $y -> [0][0]; 3243 my $ncolrep = $y -> [1][0]; 3244 3245 my $z = []; 3246 for my $ix (0 .. $nrowx - 1) { 3247 for my $jx (0 .. $ncolx - 1) { 3248 for my $iy (0 .. $nrowrep - 1) { 3249 for my $jy (0 .. $ncolrep - 1) { 3250 my $iz = $ix * $nrowrep + $iy; 3251 my $jz = $jx * $ncolrep + $jy; 3252 $z -> [$iz][$jz] = $x -> [$ix][$jx]; 3253 } 3254 } 3255 } 3256 } 3257 3258 bless $z, $class; 3259} 3260 3261=pod 3262 3263=item repmat() 3264 3265Repeat elements. 3266 3267 $x -> repmat($y); 3268 3269Repeats the matrix $x the number of times specified in $y. 3270 3271If $x is the matrix 3272 3273 [ 4 5 6 ] 3274 [ 7 8 9 ] 3275 3276and $y is 3277 3278 [ 3 2 ] 3279 3280the returned matrix is 3281 3282 [ 4 5 6 4 5 6 ] 3283 [ 7 8 9 7 8 9 ] 3284 [ 4 5 6 4 5 6 ] 3285 [ 7 8 9 7 8 9 ] 3286 [ 4 5 6 4 5 6 ] 3287 [ 7 8 9 7 8 9 ] 3288 3289=cut 3290 3291sub repmat { 3292 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 3293 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 3294 my $x = shift; 3295 my $class = ref $x; 3296 3297 my $y = shift; 3298 $y = __PACKAGE__ -> new($y) 3299 unless defined(blessed($y)) && $y -> isa(__PACKAGE__); 3300 croak "Input argument must contain two elements" 3301 unless $y -> nelm() == 2; 3302 3303 my ($nrowx, $ncolx) = $x -> size(); 3304 3305 $y = $y -> to_col(); 3306 my $nrowrep = $y -> [0][0]; 3307 my $ncolrep = $y -> [1][0]; 3308 3309 my $z = []; 3310 for my $ix (0 .. $nrowx - 1) { 3311 for my $jx (0 .. $ncolx - 1) { 3312 for my $iy (0 .. $nrowrep - 1) { 3313 for my $jy (0 .. $ncolrep - 1) { 3314 my $iz = $iy * $nrowx + $ix; 3315 my $jz = $jy * $ncolx + $jx; 3316 $z -> [$iz][$jz] = $x -> [$ix][$jx]; 3317 } 3318 } 3319 } 3320 } 3321 3322 bless $z, $class; 3323} 3324 3325=pod 3326 3327=item reshape() 3328 3329Returns a reshaped copy of a matrix. The reshaping is done by creating a new 3330matrix and looping over the elements in column major order. The new matrix must 3331have the same number of elements as the invocand matrix. The following returns 3332an C<$m>-by-C<$n> matrix, 3333 3334 $y = $x -> reshape($m, $n); 3335 3336The code 3337 3338 $x = Math::Matrix -> new([[1, 3, 5, 7], [2, 4, 6, 8]]); 3339 $y = $x -> reshape(4, 2); 3340 3341creates the matrix $x 3342 3343 [ 1 3 5 7 ] 3344 [ 2 4 6 8 ] 3345 3346and returns a reshaped copy $y 3347 3348 [ 1 5 ] 3349 [ 2 6 ] 3350 [ 3 7 ] 3351 [ 4 8 ] 3352 3353=cut 3354 3355sub reshape { 3356 croak "Not enough arguments for ", (caller(0))[3] if @_ < 3; 3357 croak "Too many arguments for ", (caller(0))[3] if @_ > 3; 3358 my $x = shift; 3359 my $class = ref $x; 3360 3361 my ($nrowx, $ncolx) = $x -> size(); 3362 my $nelmx = $nrowx * $ncolx; 3363 3364 my ($nrowy, $ncoly) = @_; 3365 my $nelmy = $nrowy * $ncoly; 3366 3367 croak "when reshaping, the number of elements can not change in ", 3368 (caller(0))[3] unless $nelmx == $nelmy; 3369 3370 my $y = []; 3371 3372 # No reshaping; just clone. 3373 3374 if ($nrowx == $nrowy && $ncolx == $ncoly) { 3375 $y = [ map [ @$_ ], @$x ]; 3376 } 3377 3378 elsif ($nrowx == 1) { 3379 3380 # Reshape from a row vector to a column vector. 3381 3382 if ($ncoly == 1) { 3383 $y = [ map [ $_ ], @{ $x -> [0] } ]; 3384 } 3385 3386 # Reshape from a row vector to a matrix. 3387 3388 else { 3389 my $k = 0; 3390 for my $j (0 .. $ncoly - 1) { 3391 for my $i (0 .. $nrowy - 1) { 3392 $y -> [$i][$j] = $x -> [0][$k++]; 3393 } 3394 } 3395 } 3396 } 3397 3398 elsif ($ncolx == 1) { 3399 3400 # Reshape from a column vector to a row vector. 3401 3402 if ($nrowy == 1) { 3403 $y = [[ map { @$_ } @$x ]]; 3404 } 3405 3406 # Reshape from a column vector to a matrix. 3407 3408 else { 3409 my $k = 0; 3410 for my $j (0 .. $ncoly - 1) { 3411 for my $i (0 .. $nrowy - 1) { 3412 $y -> [$i][$j] = $x -> [$k++][0]; 3413 } 3414 } 3415 } 3416 } 3417 3418 # The invocand is a matrix. This code works in all cases, but is somewhat 3419 # slower than the specialized code above. 3420 3421 else { 3422 for my $k (0 .. $nelmx - 1) { 3423 my $ix = $k % $nrowx; 3424 my $jx = ($k - $ix) / $nrowx; 3425 my $iy = $k % $nrowy; 3426 my $jy = ($k - $iy) / $nrowy; 3427 $y -> [$iy][$jy] = $x -> [$ix][$jx]; 3428 } 3429 } 3430 3431 bless $y, $class; 3432} 3433 3434=pod 3435 3436=item to_row() 3437 3438Reshape to a row. 3439 3440 $x -> to_row(); 3441 3442This method reshapes the matrix into a single row. It is essentially the same 3443as, but faster than, 3444 3445 $x -> reshape(1, $x -> nelm()); 3446 3447=cut 3448 3449sub to_row { 3450 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 3451 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 3452 my $x = shift; 3453 my $class = ref $x; 3454 3455 my $y = bless [], $class; 3456 3457 my $ncolx = $x -> ncol(); 3458 return $y if $ncolx == 0; 3459 3460 for my $j (0 .. $ncolx - 1) { 3461 push @{ $y -> [0] }, map $_->[$j], @$x; 3462 } 3463 return $y; 3464} 3465 3466=pod 3467 3468=item to_col() 3469 3470Reshape to a column. 3471 3472 $y = $x -> to_col(); 3473 3474This method reshapes the matrix into a single column. It is essentially the same 3475as, but faster than, 3476 3477 $x -> reshape($x -> nelm(), 1); 3478 3479=cut 3480 3481sub to_col { 3482 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 3483 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 3484 my $x = shift; 3485 3486 my $class = ref $x; 3487 3488 my $y = bless [], $class; 3489 3490 my $ncolx = $x -> ncol(); 3491 return $y if $ncolx == 0; 3492 3493 for my $j (0 .. $ncolx - 1) { 3494 push @$y, map [ $_->[$j] ], @$x; 3495 } 3496 return $y; 3497} 3498 3499=pod 3500 3501=item to_permmat() 3502 3503Permutation vector to permutation matrix. Converts a vector of zero-based 3504permutation indices to a permutation matrix. 3505 3506 $P = $v -> to_permmat(); 3507 3508For example 3509 3510 $v = Math::Matrix -> new([[0, 3, 1, 4, 2]]); 3511 $m = $v -> to_permmat(); 3512 3513gives the permutation matrix C<$m> 3514 3515 [ 1 0 0 0 0 ] 3516 [ 0 0 0 1 0 ] 3517 [ 0 1 0 0 0 ] 3518 [ 0 0 0 0 1 ] 3519 [ 0 0 1 0 0 ] 3520 3521=cut 3522 3523sub to_permmat { 3524 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 3525 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 3526 my $v = shift; 3527 my $class = ref $v; 3528 3529 my $n = $v -> nelm(); 3530 my $P = $class -> zeros($n, $n); # initialize output 3531 return $P if $n == 0; # if emtpy $v 3532 3533 croak "Invocand must be a vector" unless $v -> is_vector(); 3534 $v = $v -> to_col(); 3535 3536 for my $i (0 .. $n - 1) { 3537 my $j = $v -> [$i][0]; 3538 croak "index out of range" unless 0 <= $j && $j < $n; 3539 $P -> [$i][$j] = 1; 3540 } 3541 3542 return $P; 3543} 3544 3545=pod 3546 3547=item to_permvec() 3548 3549Permutation matrix to permutation vector. Converts a permutation matrix to a 3550vector of zero-based permutation indices. 3551 3552 $v = $P -> to_permvec(); 3553 3554 $v = Math::Matrix -> new([[0, 3, 1, 4, 2]]); 3555 $m = $v -> to_permmat(); 3556 3557Gives the permutation matrix C<$m> 3558 3559 [ 1 0 0 0 0 ] 3560 [ 0 0 0 1 0 ] 3561 [ 0 1 0 0 0 ] 3562 [ 0 0 0 0 1 ] 3563 [ 0 0 1 0 0 ] 3564 3565See also C<L</to_permmat()>>. 3566 3567=cut 3568 3569sub to_permvec { 3570 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 3571 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 3572 my $P = shift; 3573 my $class = ref $P; 3574 3575 croak "Invocand matrix must be square" unless $P -> is_square(); 3576 my $n = $P -> nrow(); 3577 3578 my $v = $class -> zeros($n, 1); # initialize output 3579 3580 my $seen = [ (0) x $n ]; # keep track of the ones 3581 3582 for my $i (0 .. $n - 1) { 3583 my $k; 3584 for my $j (0 .. $n - 1) { 3585 next if $P -> [$i][$j] == 0; 3586 if ($P -> [$i][$j] == 1) { 3587 croak "invalid permutation matrix; more than one row has", 3588 " an element with value 1 in column $j" if $seen->[$j]++; 3589 $k = $j; 3590 next; 3591 } 3592 croak "invalid permutation matrix; element ($i,$j)", 3593 " is neither 0 nor 1"; 3594 } 3595 croak "invalid permutation matrix; row $i has no element with value 1" 3596 unless defined $k; 3597 $v->[$i][0] = $k; 3598 } 3599 3600 return $v; 3601} 3602 3603=pod 3604 3605=item triu() 3606 3607Upper triangular part. Extract the upper triangular part of a matrix and set all 3608other elements to zero. 3609 3610 $y = $x -> triu(); 3611 $y = $x -> triu($n); 3612 3613The optional second argument specifies how many diagonals above or below the 3614main diagonal should also be set to zero. The default value of C<$n> is zero 3615which includes the main diagonal. 3616 3617=cut 3618 3619sub triu { 3620 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 3621 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 3622 my $x = shift; 3623 my $class = ref $x; 3624 3625 my $n = 0; 3626 if (@_) { 3627 $n = shift; 3628 if (ref $n) { 3629 $n = $class -> new($n) 3630 unless defined(blessed($n)) && $n -> isa($class); 3631 croak "Argument must be a scalar" unless $n -> is_scalar(); 3632 $n = $n -> [0][0]; 3633 } 3634 croak "Argument must be an integer" unless $n == int $n; 3635 } 3636 3637 my ($nrowx, $ncolx) = $x -> size(); 3638 3639 my $y = []; 3640 for my $i (0 .. $nrowx - 1) { 3641 for my $j (0 .. $ncolx - 1) { 3642 $y -> [$i][$j] = $j - $i >= $n ? $x -> [$i][$j] : 0; 3643 } 3644 } 3645 3646 bless $y, $class; 3647} 3648 3649=pod 3650 3651=item tril() 3652 3653Lower triangular part. Extract the lower triangular part of a matrix and set all 3654other elements to zero. 3655 3656 $y = $x -> tril(); 3657 $y = $x -> tril($n); 3658 3659The optional second argument specifies how many diagonals above or below the 3660main diagonal should also be set to zero. The default value of C<$n> is zero 3661which includes the main diagonal. 3662 3663=cut 3664 3665sub tril { 3666 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 3667 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 3668 my $x = shift; 3669 my $class = ref $x; 3670 3671 my $n = 0; 3672 if (@_) { 3673 $n = shift; 3674 if (ref $n) { 3675 $n = $class -> new($n) 3676 unless defined(blessed($n)) && $n -> isa($class); 3677 croak "Argument must be a scalar" unless $n -> is_scalar(); 3678 $n = $n -> [0][0]; 3679 } 3680 croak "Argument must be an integer" unless $n == int $n; 3681 } 3682 3683 my ($nrowx, $ncolx) = $x -> size(); 3684 3685 my $y = []; 3686 for my $i (0 .. $nrowx - 1) { 3687 for my $j (0 .. $ncolx - 1) { 3688 $y -> [$i][$j] = $j - $i <= $n ? $x -> [$i][$j] : 0; 3689 } 3690 } 3691 3692 bless $y, $class; 3693} 3694 3695=pod 3696 3697=item slice() 3698 3699Extract columns: 3700 3701 a->slice(1,3,5); 3702 3703=cut 3704 3705sub slice { 3706 my $self = shift; 3707 my $class = ref($self); 3708 my $result = []; 3709 3710 for my $i (0 .. $#$self) { 3711 push @$result, [ @{$self->[$i]}[@_] ]; 3712 } 3713 3714 bless $result, $class; 3715} 3716 3717=pod 3718 3719=item diagonal_vector() 3720 3721Extract the diagonal as an array: 3722 3723 $diag = $a->diagonal_vector; 3724 3725=cut 3726 3727sub diagonal_vector { 3728 my $self = shift; 3729 my @diag; 3730 my $idx = 0; 3731 my($m, $n) = $self->size(); 3732 3733 croak "Not a square matrix" if $m != $n; 3734 3735 foreach my $r (@{$self}) { 3736 push @diag, $r->[$idx++]; 3737 } 3738 return \@diag; 3739} 3740 3741=pod 3742 3743=item tridiagonal_vector() 3744 3745Extract the diagonals that make up a tridiagonal matrix: 3746 3747 ($main_d, $upper_d, $lower_d) = $a->tridiagonal_vector; 3748 3749=cut 3750 3751sub tridiagonal_vector { 3752 my $self = shift; 3753 my(@main_d, @up_d, @low_d); 3754 my($m, $n) = $self->size(); 3755 my $idx = 0; 3756 3757 croak "Not a square matrix" if $m != $n; 3758 3759 foreach my $r (@{$self}) { 3760 push @low_d, $r->[$idx - 1] if ($idx > 0); 3761 push @main_d, $r->[$idx++]; 3762 push @up_d, $r->[$idx] if ($idx < $m); 3763 } 3764 return ([@main_d],[@up_d],[@low_d]); 3765} 3766 3767=pod 3768 3769=back 3770 3771=head2 Mathematical functions 3772 3773=head3 Addition 3774 3775=over 4 3776 3777=item add() 3778 3779Addition. If one operands is a scalar, it is treated like a constant matrix with 3780the same size as the other operand. Otherwise ordinary matrix addition is 3781performed. 3782 3783 $z = $x -> add($y); 3784 3785See also C<L</madd()>> and C<L</sadd()>>. 3786 3787=cut 3788 3789sub add { 3790 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 3791 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 3792 my $x = shift; 3793 my $class = ref $x; 3794 3795 my $y = shift; 3796 $y = $class -> new($y) unless defined(blessed($y)) && $y -> isa($class); 3797 3798 $x -> is_scalar() || $y -> is_scalar() ? $x -> sadd($y) : $x -> madd($y); 3799} 3800 3801=pod 3802 3803=item madd() 3804 3805Matrix addition. Add two matrices of the same dimensions. An error is thrown if 3806the matrices don't have the same size. 3807 3808 $z = $x -> madd($y); 3809 3810See also C<L</add()>> and C<L</sadd()>>. 3811 3812=cut 3813 3814sub madd { 3815 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 3816 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 3817 my $x = shift; 3818 my $class = ref $x; 3819 3820 my $y = shift; 3821 $y = $class -> new($y) unless defined(blessed($y)) && $y -> isa($class); 3822 3823 my ($nrowx, $ncolx) = $x -> size(); 3824 my ($nrowy, $ncoly) = $y -> size(); 3825 3826 croak "Can't add $nrowx-by-$ncolx matrix to $nrowy-by-$ncoly matrix" 3827 unless $nrowx == $nrowy && $ncolx == $ncoly; 3828 3829 my $z = []; 3830 for my $i (0 .. $nrowx - 1) { 3831 for my $j (0 .. $ncolx - 1) { 3832 $z->[$i][$j] = $x->[$i][$j] + $y->[$i][$j]; 3833 } 3834 } 3835 3836 bless $z, $class; 3837} 3838 3839=pod 3840 3841=item sadd() 3842 3843Scalar (element by element) addition with scalar expansion. This method places 3844no requirements on the size of the input matrices. 3845 3846 $z = $x -> sadd($y); 3847 3848See also C<L</add()>> and C<L</madd()>>. 3849 3850=cut 3851 3852sub sadd { 3853 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 3854 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 3855 my $x = shift; 3856 3857 my $sub = sub { $_[0] + $_[1] }; 3858 $x -> sapply($sub, @_); 3859} 3860 3861=pod 3862 3863=back 3864 3865=head3 Subtraction 3866 3867=over 4 3868 3869=item sub() 3870 3871Subtraction. If one operands is a scalar, it is treated as a constant matrix 3872with the same size as the other operand. Otherwise, ordinarly matrix subtraction 3873is performed. 3874 3875 $z = $x -> sub($y); 3876 3877See also C<L</msub()>> and C<L</ssub()>>. 3878 3879=cut 3880 3881sub sub { 3882 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 3883 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 3884 my $x = shift; 3885 my $class = ref $x; 3886 3887 my $y = shift; 3888 $y = $class -> new($y) unless defined(blessed($y)) && $y -> isa($class); 3889 3890 $x -> is_scalar() || $y -> is_scalar() ? $x -> ssub($y) : $x -> msub($y); 3891} 3892 3893=pod 3894 3895=item msub() 3896 3897Matrix subtraction. Subtract two matrices of the same size. An error is thrown 3898if the matrices don't have the same size. 3899 3900 $z = $x -> msub($y); 3901 3902See also C<L</sub()>> and C<L</ssub()>>. 3903 3904=cut 3905 3906sub msub { 3907 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 3908 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 3909 my $x = shift; 3910 my $class = ref $x; 3911 3912 my $y = shift; 3913 $y = $class -> new($y) unless defined(blessed($y)) && $y -> isa($class); 3914 3915 my ($nrowx, $ncolx) = $x -> size(); 3916 my ($nrowy, $ncoly) = $y -> size(); 3917 3918 croak "Can't subtract $nrowy-by-$ncoly matrix from $nrowx-by-$ncolx matrix" 3919 unless $nrowx == $nrowy && $ncolx == $ncoly; 3920 3921 my $z = []; 3922 for my $i (0 .. $nrowx - 1) { 3923 for my $j (0 .. $ncolx - 1) { 3924 $z->[$i][$j] = $x->[$i][$j] - $y->[$i][$j]; 3925 } 3926 } 3927 3928 bless $z, $class; 3929} 3930 3931=pod 3932 3933=item ssub() 3934 3935Scalar (element by element) subtraction with scalar expansion. This method 3936places no requirements on the size of the input matrices. 3937 3938 $z = $x -> ssub($y); 3939 3940See also C<L</sub()>> and C<L</msub()>>. 3941 3942=cut 3943 3944sub ssub { 3945 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 3946 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 3947 my $x = shift; 3948 3949 my $sub = sub { $_[0] - $_[1] }; 3950 $x -> sapply($sub, @_); 3951} 3952 3953=pod 3954 3955=item subtract() 3956 3957This is an alias for C<L</msub()>>. 3958 3959=cut 3960 3961sub subtract { 3962 my $x = shift; 3963 $x -> sub(@_); 3964} 3965 3966=pod 3967 3968=back 3969 3970=head3 Negation 3971 3972=over 4 3973 3974=item neg() 3975 3976Negation. Negate a matrix. 3977 3978 $y = $x -> neg(); 3979 3980It is effectively equivalent to 3981 3982 $y = $x -> map(sub { -$_ }); 3983 3984=cut 3985 3986sub neg { 3987 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 3988 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 3989 my $x = shift; 3990 bless [ map [ map -$_, @$_ ], @$x ], ref $x; 3991} 3992 3993=pod 3994 3995=item negative() 3996 3997This is an alias for C<L</neg()>>. 3998 3999=cut 4000 4001sub negative { 4002 my $x = shift; 4003 $x -> neg(@_); 4004} 4005 4006=pod 4007 4008=back 4009 4010=head3 Multiplication 4011 4012=over 4 4013 4014=item mul() 4015 4016Multiplication. If one operands is a scalar, it is treated as a constant matrix 4017with the same size as the other operand. Otherwise, ordinary matrix 4018multiplication is performed. 4019 4020 $z = $x -> mul($y); 4021 4022=cut 4023 4024sub mul { 4025 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 4026 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 4027 my $x = shift; 4028 my $class = ref $x; 4029 4030 my $y = shift; 4031 $y = $class -> new($y) unless defined(blessed($y)) && $y -> isa($class); 4032 4033 $x -> is_scalar() || $y -> is_scalar() ? $x -> smul($y) : $x -> mmul($y); 4034} 4035 4036=pod 4037 4038=item mmul() 4039 4040Matrix multiplication. An error is thrown if the sizes don't match; the number 4041of columns in the first operand must be equal to the number of rows in the 4042second operand. 4043 4044 $z = $x -> mmul($y); 4045 4046=cut 4047 4048sub mmul { 4049 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 4050 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 4051 my $x = shift; 4052 my $class = ref $x; 4053 4054 my $y = shift; 4055 $y = $class -> new($y) unless defined(blessed($y)) && $y -> isa($class); 4056 4057 my $mx = $x -> nrow(); 4058 my $nx = $x -> ncol(); 4059 4060 my $my = $y -> nrow(); 4061 my $ny = $y -> ncol(); 4062 4063 croak "Can't multiply $mx-by-$nx matrix with $my-by-$ny matrix" 4064 unless $nx == $my; 4065 4066 my $z = []; 4067 my $l = $nx - 1; # "inner length" 4068 for my $i (0 .. $mx - 1) { 4069 for my $j (0 .. $ny - 1) { 4070 $z -> [$i][$j] = _sum(map $x -> [$i][$_] * $y -> [$_][$j], 0 .. $l); 4071 } 4072 } 4073 4074 bless $z, $class; 4075} 4076 4077=pod 4078 4079=item smul() 4080 4081Scalar (element by element) multiplication with scalar expansion. This method 4082places no requirements on the size of the input matrices. 4083 4084 $z = $x -> smul($y); 4085 4086=cut 4087 4088sub smul { 4089 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 4090 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 4091 my $x = shift; 4092 4093 my $sub = sub { $_[0] * $_[1] }; 4094 $x -> sapply($sub, @_); 4095} 4096 4097=pod 4098 4099=item mmuladd() 4100 4101Matrix fused multiply and add. If C<$x> is a C<$p>-by-C<$q> matrix, then C<$y> 4102must be a C<$q>-by-C<$r> matrix and C<$z> must be a C<$p>-by-C<$r> matrix. An 4103error is thrown if the sizes don't match. 4104 4105 $w = $x -> mmuladd($y, $z); 4106 4107The fused multiply and add is equivalent to, but computed with higher accuracy 4108than 4109 4110 $w = $x -> mmul($y) -> madd($z); 4111 4112This method can be used to improve the solution of linear systems. 4113 4114=cut 4115 4116sub mmuladd { 4117 croak "Not enough arguments for ", (caller(0))[3] if @_ < 3; 4118 croak "Too many arguments for ", (caller(0))[3] if @_ > 3; 4119 my $x = shift; 4120 my $class = ref $x; 4121 4122 my ($mx, $nx) = $x -> size(); 4123 4124 my $y = shift; 4125 $y = $class -> new($y) unless defined(blessed($y)) && $y -> isa($class); 4126 my ($my, $ny) = $y -> size(); 4127 4128 croak "Can't multiply $mx-by-$nx matrix with $my-by-$ny matrix" 4129 unless $nx == $my; 4130 4131 my $z = shift; 4132 $z = $class -> new($z) unless defined(blessed($z)) && $z -> isa($class); 4133 my ($mz, $nz) = $z -> size(); 4134 4135 croak "Can't add $mz-by-$nz matrix to $mx-by-$ny matrix" 4136 unless $mz == $mx && $nz == $ny; 4137 4138 my $w = []; 4139 my $l = $nx - 1; # "inner length" 4140 for my $i (0 .. $mx - 1) { 4141 for my $j (0 .. $ny - 1) { 4142 $w -> [$i][$j] 4143 = _sum(map($x -> [$i][$_] * $y -> [$_][$j], 0 .. $l), 4144 $z -> [$i][$j]); 4145 } 4146 } 4147 4148 bless $w, $class; 4149} 4150 4151=pod 4152 4153=item kron() 4154 4155Kronecker tensor product. 4156 4157 $A -> kronprod($B); 4158 4159If C<$A> is an C<$m>-by-C<$n> matrix and C<$B> is a C<$p>-by-C<$q> matrix, then 4160C<< $A -> kron($B) >> is an C<$m>*C<$p>-by-C<$n>*C<$q> matrix formed by taking 4161all possible products between the elements of C<$A> and the elements of C<$B>. 4162 4163=cut 4164 4165sub kron { 4166 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 4167 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 4168 my $x = shift; 4169 my $class = ref $x; 4170 4171 my $y = shift; 4172 $y = $class -> new($y) unless defined(blessed($y)) && $y -> isa($class); 4173 4174 my ($nrowx, $ncolx) = $x -> size(); 4175 my ($nrowy, $ncoly) = $y -> size(); 4176 4177 my $z = bless [], $class; 4178 4179 for my $ix (0 .. $nrowx - 1) { 4180 for my $jx (0 .. $ncolx - 1) { 4181 for my $iy (0 .. $nrowy - 1) { 4182 for my $jy (0 .. $ncoly - 1) { 4183 my $iz = $ix * $nrowx + $iy; 4184 my $jz = $jx * $ncolx + $jy; 4185 $z -> [$iz][$jz] = $x -> [$ix][$jx] * $y -> [$iy][$jy]; 4186 } 4187 } 4188 } 4189 } 4190 4191 return $z; 4192} 4193 4194=pod 4195 4196=item multiply() 4197 4198This is an alias for C<L</mmul()>>. 4199 4200=cut 4201 4202sub multiply { 4203 my $x = shift; 4204 $x -> mmul(@_); 4205} 4206 4207=pod 4208 4209=item multiply_scalar() 4210 4211Multiplies a matrix and a scalar resulting in a matrix of the same dimensions 4212with each element scaled with the scalar. 4213 4214 $a->multiply_scalar(2); scale matrix by factor 2 4215 4216=cut 4217 4218sub multiply_scalar { 4219 my $self = shift; 4220 my $factor = shift; 4221 my $result = $self->new(); 4222 4223 my $last = $#{$self->[0]}; 4224 for my $i (0 .. $#{$self}) { 4225 for my $j (0 .. $last) { 4226 $result->[$i][$j] = $factor * $self->[$i][$j]; 4227 } 4228 } 4229 $result; 4230} 4231 4232=pod 4233 4234=back 4235 4236=head3 Powers 4237 4238=over 4 4239 4240=item pow() 4241 4242Power function. 4243 4244This is an alias for C<L</mpow()>>. 4245 4246See also C<L</spow()>>. 4247 4248=cut 4249 4250sub pow { 4251 my $x = shift; 4252 $x -> mpow(@_); 4253} 4254 4255=pod 4256 4257=item mpow() 4258 4259Matrix power. The second operand must be a non-negative integer. 4260 4261 $y = $x -> mpow($n); 4262 4263The following example 4264 4265 $x = Math::Matrix -> new([[0, -2],[1, 4]]); 4266 $y = 4; 4267 $z = $x -> pow($y); 4268 4269returns the matrix 4270 4271 [ -28 -96 ] 4272 [ 48 164 ] 4273 4274See also C<L</spow()>>. 4275 4276=cut 4277 4278sub mpow { 4279 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 4280 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 4281 my $x = shift; 4282 my $class = ref $x; 4283 4284 croak "Invocand matrix must be square in ", (caller(0))[3] 4285 unless $x -> is_square(); 4286 4287 my $n = shift; 4288 croak "Exponent can not be undefined" unless defined $n; 4289 if (ref $n) { 4290 $n = $class -> new($n) unless defined(blessed($n)) && $n -> isa($class); 4291 croak "Exponent must be a scalar in ", (caller(0))[3] 4292 unless $n -> is_scalar(); 4293 $n = $n -> [0][0]; 4294 } 4295 croak "Exponent must be an integer" unless $n == int $n; 4296 4297 return $class -> new([]) if $x -> is_empty(); 4298 4299 my ($nrowx, $ncolx) = $x -> size(); 4300 return $class -> id($nrowx, $ncolx) if $n == 0; 4301 return $x -> clone() if $n == 1; 4302 4303 my $neg = $n < 0; 4304 $n = -$n if $neg; 4305 4306 my $y = $class -> id($nrowx, $ncolx); 4307 my $tmp = $x; 4308 while (1) { 4309 my $rem = $n % 2; 4310 $y *= $tmp if $rem; 4311 $n = ($n - $rem) / 2; 4312 last if $n == 0; 4313 $tmp = $tmp * $tmp; 4314 } 4315 4316 $y = $y -> minv() if $neg; 4317 4318 return $y; 4319} 4320 4321=pod 4322 4323=item spow() 4324 4325Scalar (element by element) power function. This method doesn't require the 4326matrices to have the same size. 4327 4328 $z = $x -> spow($y); 4329 4330See also C<L</mpow()>>. 4331 4332=cut 4333 4334sub spow { 4335 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 4336 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 4337 my $x = shift; 4338 4339 my $sub = sub { $_[0] ** $_[1] }; 4340 $x -> sapply($sub, @_); 4341} 4342 4343=pod 4344 4345=back 4346 4347=head3 Inversion 4348 4349=over 4 4350 4351=item inv() 4352 4353This is an alias for C<L</minv()>>. 4354 4355=cut 4356 4357sub inv { 4358 my $x = shift; 4359 $x -> minv(); 4360} 4361 4362=pod 4363 4364=item invert() 4365 4366Invert a Matrix using C<solve>. 4367 4368=cut 4369 4370sub invert { 4371 my $M = shift; 4372 my ($m, $n) = $M->size; 4373 croak "Can't invert $m-by-$n matrix; matrix must be square" 4374 if $m != $n; 4375 my $I = $M->new_identity($n); 4376 ($M->concat($I))->solve; 4377} 4378 4379=pod 4380 4381=item minv() 4382 4383Matrix inverse. Invert a matrix. 4384 4385 $y = $x -> inv(); 4386 4387See the section L</IMPROVING THE SOLUTION OF LINEAR SYSTEMS> for a list of 4388additional parameters that can be used for trying to obtain a better solution 4389through iteration. 4390 4391=cut 4392 4393sub minv { 4394 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 4395 #croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 4396 my $x = shift; 4397 my $class = ref $x; 4398 4399 my $n = $x -> nrow(); 4400 return $class -> id($n) -> mldiv($x, @_); 4401} 4402 4403=pod 4404 4405=item sinv() 4406 4407Scalar (element by element) inverse. Invert each element in a matrix. 4408 4409 $y = $x -> sinv(); 4410 4411=cut 4412 4413sub sinv { 4414 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 4415 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 4416 my $x = shift; 4417 4418 bless [ map [ map 1/$_, @$_ ], @$x ], ref $x; 4419} 4420 4421=pod 4422 4423=item mldiv() 4424 4425Matrix left division. Returns the solution x of the linear system of equations 4426A*x = y, by computing A^(-1)*y. 4427 4428 $x = $y -> mldiv($A); 4429 4430This method also handles overdetermined and underdetermined systems. There are 4431three cases 4432 4433=over 4 4434 4435=item * 4436 4437If A is a square matrix, then 4438 4439 x = A\y = inv(A)*y 4440 4441so that A*x = y to within round-off accuracy. 4442 4443=item * 4444 4445If A is an M-by-N matrix where M > N, then A\y is computed as 4446 4447 A\y = (A'*A)\(A'*y) = inv(A'*A)*(A'*y) 4448 4449where A' denotes the transpose of A. The returned matrix is the least squares 4450solution to the linear system of equations A*x = y, if it exists. The matrix 4451A'*A must be non-singular. 4452 4453=item * 4454 4455If A is an where M < N, then A\y is computed as 4456 4457 A\y = A'*((A*A')\y) 4458 4459This solution is not unique. The matrix A*A' must be non-singular. 4460 4461=back 4462 4463See the section L</IMPROVING THE SOLUTION OF LINEAR SYSTEMS> for a list of 4464additional parameters that can be used for trying to obtain a better solution 4465through iteration. 4466 4467=cut 4468 4469sub mldiv { 4470 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 4471 #croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 4472 my $y = shift; 4473 my $class = ref $y; 4474 4475 my $A = shift; 4476 $A = $class -> new($A) unless defined(blessed($A)) && $A -> isa($class); 4477 4478 my ($m, $n) = $A -> size(); 4479 4480 if ($m > $n) { 4481 4482 # If A is an M-by-N matrix where M > N, i.e., an overdetermined system, 4483 # compute (A'*A)\(A'*y) by doing a one level deep recursion. 4484 4485 my $At = $A -> transpose(); 4486 return $At -> mmul($y) -> mldiv($At -> mmul($A), @_); 4487 4488 } elsif ($m < $n) { 4489 4490 # If A is an M-by-N matrix where M < N, i.e., and underdetermined 4491 # system, compute A'*((A*A')\y) by doing a one level deep recursion. 4492 # This solution is not unique. 4493 4494 my $At = $A -> transpose(); 4495 return $At -> mldiv($At -> mmul($A), @_); 4496 } 4497 4498 # If extra arguments are given ... 4499 4500 if (@_) { 4501 4502 require Config; 4503 my $max_iter = 20; 4504 my $rel_tol = ($Config::Config{uselongdouble} || 4505 $Config::Config{usequadmath}) ? 1e-19 : 1e-9; 4506 my $abs_tol = 0; 4507 my $debug; 4508 4509 while (@_) { 4510 my $param = shift; 4511 croak "parameter name can not be undefined" unless defined $param; 4512 4513 croak "missing value for parameter '$param'" unless @_; 4514 my $value = shift; 4515 4516 if ($param eq 'MaxIter') { 4517 croak "value for parameter 'MaxIter' can not be undefined" 4518 unless defined $value; 4519 croak "value for parameter 'MaxIter' must be a positive integer" 4520 unless $value > 0 && $value == int $value; 4521 $max_iter = $value; 4522 next; 4523 } 4524 4525 if ($param eq 'RelTol') { 4526 croak "value for parameter 'RelTol' can not be undefined" 4527 unless defined $value; 4528 croak "value for parameter 'RelTol' must be non-negative" 4529 unless $value >= 0; 4530 $rel_tol = $value; 4531 next; 4532 } 4533 4534 if ($param eq 'AbsTol') { 4535 croak "value for parameter 'AbsTol' can not be undefined" 4536 unless defined $value; 4537 croak "value for parameter 'AbsTol' must be non-negative" 4538 unless $value >= 0; 4539 $abs_tol = $value; 4540 next; 4541 } 4542 4543 if ($param eq 'Debug') { 4544 $debug = $value; 4545 next; 4546 } 4547 4548 croak "unknown parameter '$param'"; 4549 } 4550 4551 if ($debug) { 4552 printf "\n"; 4553 printf "max_iter = %24d\n", $max_iter; 4554 printf "rel_tol = %24.15e\n", $rel_tol; 4555 printf "abs_tol = %24.15e\n", $abs_tol; 4556 } 4557 4558 my $y_norm = _hypot(map { @$_ } @$y); 4559 4560 my $x = $y -> mldiv($A); 4561 4562 my $x_best; 4563 my $iter_best; 4564 my $abs_err_best; 4565 my $rel_err_best; 4566 4567 for (my $iter = 1 ; ; $iter++) { 4568 4569 # Compute the residuals. 4570 4571 my $r = $A -> mmuladd($x, -$y); 4572 4573 # Compute the errors. 4574 4575 my $r_norm = _hypot(map @$_, @$r); 4576 my $abs_err = $r_norm; 4577 my $rel_err = $y_norm == 0 ? $r_norm : $r_norm / $y_norm; 4578 4579 if ($debug) { 4580 printf "\n"; 4581 printf "iter = %24d\n", $iter; 4582 printf "r_norm = %24.15e\n", $r_norm; 4583 printf "y_norm = %24.15e\n", $y_norm; 4584 printf "abs_err = %24.15e\n", $abs_err; 4585 printf "rel_err = %24.15e\n", $rel_err; 4586 } 4587 4588 # See if this is the first round or we have an new all-time best. 4589 4590 if ($iter == 1 || 4591 $abs_err < $abs_err_best || 4592 $rel_err < $rel_err_best) 4593 { 4594 $x_best = $x; 4595 $iter_best = $iter; 4596 $abs_err_best = $abs_err; 4597 $rel_err_best = $rel_err; 4598 } 4599 4600 if ($abs_err_best <= $abs_tol || $rel_err_best <= $rel_tol) { 4601 last; 4602 } else { 4603 4604 # If we still haven't got the desired result, but have reached 4605 # the maximum number of iterations, display a warning. 4606 4607 if ($iter == $max_iter) { 4608 carp "mldiv() stopped because the maximum number of", 4609 " iterations (max. iter = $max_iter) was reached without", 4610 " converging to any of the desired tolerances (", 4611 "rel_tol = ", $rel_tol, ", ", 4612 "abs_tol = ", $abs_tol, ").", 4613 " The best iterate (iter. = ", $iter_best, ") has", 4614 " a relative residual of ", $rel_err_best, " and", 4615 " an absolute residual of ", $abs_err_best, "."; 4616 last; 4617 } 4618 } 4619 4620 # Compute delta $x. 4621 4622 my $d = $r -> mldiv($A); 4623 4624 # Compute the improved solution $x. 4625 4626 $x -= $d; 4627 } 4628 4629 return $x_best, $rel_err_best, $abs_err_best, $iter_best if wantarray; 4630 return $x_best; 4631 } 4632 4633 # If A is an M-by-M, compute A\y directly. 4634 4635 croak "mldiv(): sizes don't match" unless $y -> nrow() == $n; 4636 4637 # Create the augmented matrix. 4638 4639 my $x = $A -> catcol($y); 4640 4641 # Perform forward elimination. 4642 4643 my ($rowperm, $colperm); 4644 eval { ($x, $rowperm, $colperm) = $x -> felim_fp() }; 4645 croak "mldiv(): matrix is singular or close to singular" if $@; 4646 4647 # Perform backward substitution. 4648 4649 eval { $x = $x -> bsubs() }; 4650 croak "mldiv(): matrix is singular or close to singular" if $@; 4651 4652 # Remove left half to keep only the augmented matrix. 4653 4654 $x = $x -> splicecol(0, $n); 4655 4656 # Reordering the rows is only necessary when full (complete) pivoting is 4657 # used above. If partial pivoting is used, this reordeing could be skipped, 4658 # but it executes so fast that it causes no harm to do it anyway. 4659 4660 @$x[ @$colperm ] = @$x; 4661 4662 return $x; 4663} 4664 4665=pod 4666 4667=item sldiv() 4668 4669Scalar (left) division. 4670 4671 $x -> sldiv($y); 4672 4673For scalars, there is no difference between left and right division, so this is 4674just an alias for C<L</sdiv()>>. 4675 4676=cut 4677 4678sub sldiv { 4679 my $x = shift; 4680 $x -> sdiv(@_) 4681} 4682 4683=pod 4684 4685=item mrdiv() 4686 4687Matrix right division. Returns the solution x of the linear system of equations 4688x*A = y, by computing x = y/A = y*inv(A) = (A'\y')', where A' and y' denote the 4689transpose of A and y, respectively, and \ is matrix left division (see 4690C<L</mldiv()>>). 4691 4692 $x = $y -> mrdiv($A); 4693 4694See the section L</IMPROVING THE SOLUTION OF LINEAR SYSTEMS> for a list of 4695additional parameters that can be used for trying to obtain a better solution 4696through iteration. 4697 4698=cut 4699 4700sub mrdiv { 4701 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 4702 #croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 4703 my $y = shift; 4704 my $class = ref $y; 4705 4706 my $A = shift; 4707 $A = $class -> new($A) unless defined(blessed($A)) && $A -> isa($class); 4708 4709 $y -> transpose() -> mldiv($A -> transpose(), @_) -> transpose(); 4710} 4711 4712=pod 4713 4714=item srdiv() 4715 4716Scalar (right) division. 4717 4718 $x -> srdiv($y); 4719 4720For scalars, there is no difference between left and right division, so this is 4721just an alias for C<L</sdiv()>>. 4722 4723=cut 4724 4725sub srdiv { 4726 my $x = shift; 4727 $x -> sdiv(@_) 4728} 4729 4730=pod 4731 4732=item sdiv() 4733 4734Scalar division. Performs scalar (element by element) division. 4735 4736 $x -> sdiv($y); 4737 4738=cut 4739 4740sub sdiv { 4741 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 4742 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 4743 my $x = shift; 4744 4745 my $sub = sub { $_[0] / $_[1] }; 4746 $x -> sapply($sub, @_); 4747} 4748 4749=pod 4750 4751=item mpinv() 4752 4753Matrix pseudo-inverse, C<(A'*A)^(-1)*A'>, where "C<'>" is the transpose 4754operator. 4755 4756See the section L</IMPROVING THE SOLUTION OF LINEAR SYSTEMS> for a list of 4757additional parameters that can be used for trying to obtain a better solution 4758through iteration. 4759 4760=cut 4761 4762sub mpinv { 4763 my $A = shift; 4764 4765 my $At = $A -> transpose(); 4766 return $At -> mldiv($At -> mmul($A), @_); 4767} 4768 4769=pod 4770 4771=item pinv() 4772 4773This is an alias for C<L</mpinv()>>. 4774 4775=cut 4776 4777sub pinv { 4778 my $x = shift; 4779 $x -> mpinv(); 4780} 4781 4782=pod 4783 4784=item pinvert() 4785 4786This is an alias for C<L</mpinv()>>. 4787 4788=cut 4789 4790sub pinvert { 4791 my $x = shift; 4792 $x -> mpinv(); 4793} 4794 4795=pod 4796 4797=item solve() 4798 4799Solves a equation system given by the matrix. The number of colums must be 4800greater than the number of rows. If variables are dependent from each other, 4801the second and all further of the dependent coefficients are 0. This means the 4802method can handle such systems. The method returns a matrix containing the 4803solutions in its columns or B<undef> in case of error. 4804 4805=cut 4806 4807sub solve { 4808 my $self = shift; 4809 my $class = ref($self); 4810 4811 my $m = $self->clone(); 4812 my $mr = $#{$m}; 4813 my $mc = $#{$m->[0]}; 4814 my $f; 4815 my $try; 4816 4817 return undef if $mc <= $mr; 4818 ROW: for(my $i = 0; $i <= $mr; $i++) { 4819 $try=$i; 4820 # make diagonal element nonzero if possible 4821 while (abs($m->[$i]->[$i]) < $eps) { 4822 last ROW if $try++ > $mr; 4823 my $row = splice(@{$m},$i,1); 4824 push(@{$m}, $row); 4825 } 4826 4827 # normalize row 4828 $f = $m->[$i]->[$i]; 4829 for (my $k = 0; $k <= $mc; $k++) { 4830 $m->[$i]->[$k] /= $f; 4831 } 4832 # subtract multiple of designated row from other rows 4833 for (my $j = 0; $j <= $mr; $j++) { 4834 next if $i == $j; 4835 $f = $m->[$j]->[$i]; 4836 for (my $k = 0; $k <= $mc; $k++) { 4837 $m->[$j]->[$k] -= $m->[$i]->[$k] * $f; 4838 } 4839 } 4840 } 4841 4842 # Answer is in augmented column 4843 $class -> new([ @{ $m -> transpose }[$mr+1 .. $mc] ]) -> transpose; 4844} 4845 4846=pod 4847 4848=back 4849 4850=head3 Factorisation 4851 4852=over 4 4853 4854=item chol() 4855 4856Cholesky decomposition. 4857 4858 $L = $A -> chol(); 4859 4860Every symmetric, positive definite matrix A can be decomposed into a product of 4861a unique lower triangular matrix L and its transpose, so that A = L*L', where L' 4862denotes the transpose of L. L is called the Cholesky factor of A. 4863 4864=cut 4865 4866sub chol { 4867 my $x = shift; 4868 my $class = ref $x; 4869 4870 croak "Input matrix must be a symmetric" unless $x -> is_symmetric(); 4871 4872 my $y = [ map [ (0) x @$x ], @$x ]; # matrix of zeros 4873 for my $i (0 .. $#$x) { 4874 for my $j (0 .. $i) { 4875 my $z = $x->[$i][$j]; 4876 $z -= $y->[$i][$_] * $y->[$j][$_] for 0 .. $j; 4877 if ($i == $j) { 4878 croak "Matrix is not positive definite" if $z < 0; 4879 $y->[$i][$j] = sqrt($z); 4880 } else { 4881 croak "Matrix is not positive definite" if $y->[$j][$j] == 0; 4882 $y->[$i][$j] = $z / $y->[$j][$j]; 4883 } 4884 } 4885 } 4886 bless $y, $class; 4887} 4888 4889=pod 4890 4891=back 4892 4893=head3 Miscellaneous matrix functions 4894 4895=over 4 4896 4897=item transpose() 4898 4899Returns the transposed matrix. This is the matrix where colums and rows of the 4900argument matrix are swapped. 4901 4902A subclass implementing matrices of complex numbers should provide a 4903C<L</transpose()>> method that takes the complex conjugate of each element. 4904 4905=cut 4906 4907sub transpose { 4908 my $x = shift; 4909 my $class = ref $x; 4910 4911 my $y = bless [], $class; 4912 my $ncolx = $x -> ncol(); 4913 return $y if $ncolx == 0; 4914 4915 for my $j (0 .. $ncolx - 1) { 4916 push @$y, [ map $_->[$j], @$x ]; 4917 } 4918 return $y; 4919} 4920 4921=pod 4922 4923=item minormatrix() 4924 4925Minor matrix. The (i,j) minor matrix of a matrix is identical to the original 4926matrix except that row i and column j has been removed. 4927 4928 $y = $x -> minormatrix($i, $j); 4929 4930See also C<L</minor()>>. 4931 4932=cut 4933 4934sub minormatrix { 4935 croak "Not enough arguments for ", (caller(0))[3] if @_ < 3; 4936 croak "Too many arguments for ", (caller(0))[3] if @_ > 3; 4937 my $x = shift; 4938 my $class = ref $x; 4939 4940 my ($m, $n) = $x -> size(); 4941 4942 my $i = shift; 4943 croak "Row index value $i outside of $m-by-$n matrix" 4944 unless 0 <= $i && $i < $m; 4945 4946 my $j = shift; 4947 croak "Column index value $j outside of $m-by-$n matrix" 4948 unless 0 <= $j && $j < $n; 4949 4950 # We could just use the following, which is simpler, but also slower: 4951 # 4952 # $x -> delrow($i) -> delcol($j); 4953 4954 my @rowidx = 0 .. $m - 1; 4955 splice @rowidx, $i, 1; 4956 4957 my @colidx = 0 .. $n - 1; 4958 splice @colidx, $j, 1; 4959 4960 bless [ map [ @{$_}[@colidx] ], @{$x}[@rowidx] ], $class; 4961} 4962 4963=pod 4964 4965=item minor() 4966 4967Minor. The (i,j) minor of a matrix is the determinant of the (i,j) minor matrix. 4968 4969 $y = $x -> minor($i, $j); 4970 4971See also C<L</minormatrix()>>. 4972 4973=cut 4974 4975sub minor { 4976 croak "Not enough arguments for ", (caller(0))[3] if @_ < 3; 4977 croak "Too many arguments for ", (caller(0))[3] if @_ > 3; 4978 my $x = shift; 4979 4980 croak "Matrix must be square" unless $x -> is_square(); 4981 4982 $x -> minormatrix(@_) -> determinant(); 4983} 4984 4985=pod 4986 4987=item cofactormatrix() 4988 4989Cofactor matrix. Element (i,j) in the cofactor matrix is the (i,j) cofactor, 4990which is (-1)^(i+j) multiplied by the determinant of the (i,j) minor matrix. 4991 4992 $y = $x -> cofactormatrix(); 4993 4994=cut 4995 4996sub cofactormatrix { 4997 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 4998 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 4999 my $x = shift; 5000 5001 my ($m, $n) = $x -> size(); 5002 croak "matrix must be square" unless $m == $n; 5003 5004 my $y = []; 5005 for my $i (0 .. $m - 1) { 5006 for my $j (0 .. $n - 1) { 5007 $y -> [$i][$j] = (-1) ** ($i + $j) * $x -> minor($i, $j); 5008 } 5009 } 5010 5011 bless $y; 5012} 5013 5014=pod 5015 5016=item cofactor() 5017 5018Cofactor. The (i,j) cofactor of a matrix is (-1)**(i+j) times the (i,j) minor of 5019the matrix. 5020 5021 $y = $x -> cofactor($i, $j); 5022 5023=cut 5024 5025sub cofactor { 5026 croak "Not enough arguments for ", (caller(0))[3] if @_ < 3; 5027 croak "Too many arguments for ", (caller(0))[3] if @_ > 3; 5028 my $x = shift; 5029 5030 my ($m, $n) = $x -> size(); 5031 croak "matrix must be square" unless $m == $n; 5032 5033 my ($i, $j) = @_; 5034 (-1) ** ($i + $j) * $x -> minor($i, $j); 5035} 5036 5037=pod 5038 5039=item adjugate() 5040 5041Adjugate of a matrix. The adjugate, also called classical adjoint or adjunct, of 5042a square matrix is the transpose of the cofactor matrix. 5043 5044 $y = $x -> adjugate(); 5045 5046=cut 5047 5048sub adjugate { 5049 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 5050 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 5051 my $x = shift; 5052 5053 $x -> cofactormatrix() -> transpose(); 5054} 5055 5056=pod 5057 5058=item det() 5059 5060Determinant. Returns the determinant of a matrix. The matrix must be square. 5061 5062 $y = $x -> det(); 5063 5064The matrix is computed by forward elimination, which might cause round-off 5065errors. So for example, the determinant might be a non-integer even for an 5066integer matrix. 5067 5068=cut 5069 5070sub det { 5071 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 5072 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 5073 my $x = shift; 5074 my $class = ref $x; 5075 5076 my ($nrowx, $ncolx) = $x -> size(); 5077 croak "matrix must be square" unless $nrowx == $ncolx; 5078 5079 # Create the augmented matrix. 5080 5081 $x = $x -> catcol($class -> id($nrowx)); 5082 5083 # Perform forward elimination. 5084 5085 my ($iperm, $jperm, $iswap, $jswap); 5086 eval { ($x, $iperm, $jperm, $iswap, $jswap) = $x -> felim_fp() }; 5087 5088 # Compute the product of the elements on the diagonal. 5089 5090 my $det = 1; 5091 for (my $i = 0 ; $i < $nrowx ; ++$i) { 5092 last if ($det *= $x -> [$i][$i]) == 0; 5093 } 5094 5095 # Adjust the sign according to the number of inversions. 5096 5097 $det = ($iswap + $jswap) % 2 ? -$det : $det; 5098 5099 return $det; 5100} 5101 5102=pod 5103 5104=item determinant() 5105 5106This is an alias for C<L</det()>>. 5107 5108=cut 5109 5110sub determinant { 5111 my $x = shift; 5112 $x -> det(@_); 5113} 5114 5115=pod 5116 5117=item detr() 5118 5119Determinant. Returns the determinant of a matrix. The matrix must be square. 5120 5121 $y = $x -> determinant(); 5122 5123The determinant is computed by recursion, so it is generally much slower than 5124C<L</det()>>. 5125 5126=cut 5127 5128sub detr { 5129 my $x = shift; 5130 my $class = ref($x); 5131 my $imax = $#$x; 5132 my $jmax = $#{$x->[0]}; 5133 5134 return undef unless $imax == $jmax; # input must be a square matrix 5135 5136 # Matrix is 3 × 3 5137 5138 return 5139 $x -> [0][0] * ($x -> [1][1] * $x -> [2][2] - $x -> [1][2] * $x -> [2][1]) 5140 - $x -> [0][1] * ($x -> [1][0] * $x -> [2][2] - $x -> [1][2] * $x -> [2][0]) 5141 + $x -> [0][2] * ($x -> [1][0] * $x -> [2][1] - $x -> [1][1] * $x -> [2][0]) 5142 if $imax == 2; 5143 5144 # Matrix is 2 × 2 5145 5146 return $x -> [0][0] * $x -> [1][1] - $x -> [1][0] * $x -> [0][1] 5147 if $imax == 1; 5148 5149 # Matrix is 1 × 1 5150 5151 return $x -> [0][0] if $imax == 0; 5152 5153 # Matrix is N × N for N > 3. 5154 5155 my $det = 0; 5156 5157 # Create a matrix with column 0 removed. We only need to do this once. 5158 my $x0 = bless [ map [ @{$_}[1 .. $jmax] ], @$x ], $class; 5159 5160 for my $i (0 .. $imax) { 5161 5162 # Create a matrix with row $i and column 0 removed. 5163 my $x1 = bless [ map [ @$_ ], @{$x0}[ 0 .. $i-1, $i+1 .. $imax ] ], $class; 5164 5165 my $term = $x1 -> determinant(); 5166 $term *= $i % 2 ? -$x->[$i][0] : $x->[$i][0]; 5167 5168 $det += $term; 5169 } 5170 5171 return $det; 5172} 5173 5174=pod 5175 5176=back 5177 5178=head3 Elementwise mathematical functions 5179 5180These method work on each element of a matrix. 5181 5182=over 4 5183 5184=item int() 5185 5186Truncate to integer. Truncates each element to an integer. 5187 5188 $y = $x -> int(); 5189 5190This function is effectivly the same as 5191 5192 $y = $x -> map(sub { int }); 5193 5194=cut 5195 5196sub int { 5197 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 5198 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 5199 my $x = shift; 5200 5201 bless [ map [ map int($_), @$_ ], @$x ], ref $x; 5202} 5203 5204=pod 5205 5206=item floor() 5207 5208Round to negative infinity. Rounds each element to negative infinity. 5209 5210 $y = $x -> floor(); 5211 5212=cut 5213 5214sub floor { 5215 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 5216 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 5217 my $x = shift; 5218 5219 bless [ map { [ 5220 map { 5221 my $ix = CORE::int($_); 5222 ($ix <= $_) ? $ix : $ix - 1; 5223 } @$_ 5224 ] } @$x ], ref $x; 5225} 5226 5227=pod 5228 5229=item ceil() 5230 5231Round to positive infinity. Rounds each element to positive infinity. 5232 5233 $y = $x -> int(); 5234 5235=cut 5236 5237sub ceil { 5238 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 5239 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 5240 my $x = shift; 5241 5242 bless [ map { [ 5243 map { 5244 my $ix = CORE::int($_); 5245 ($ix >= $_) ? $ix : $ix + 1; 5246 } @$_ 5247 ] } @$x ], ref $x; 5248} 5249 5250=pod 5251 5252=item abs() 5253 5254Absolute value. The absolute value of each element. 5255 5256 $y = $x -> abs(); 5257 5258This is effectivly the same as 5259 5260 $y = $x -> map(sub { abs }); 5261 5262=cut 5263 5264sub abs { 5265 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 5266 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 5267 my $x = shift; 5268 5269 bless [ map [ map abs($_), @$_ ], @$x ], ref $x; 5270} 5271 5272=pod 5273 5274=item sign() 5275 5276Sign function. Apply the sign function to each element. 5277 5278 $y = $x -> sign(); 5279 5280This is effectivly the same as 5281 5282 $y = $x -> map(sub { $_ <=> 0 }); 5283 5284=cut 5285 5286sub sign { 5287 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 5288 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 5289 my $x = shift; 5290 5291 bless [ map [ map { $_ <=> 0 } @$_ ], @$x ], ref $x; 5292} 5293 5294=pod 5295 5296=back 5297 5298=head3 Columnwise or rowwise mathematical functions 5299 5300These method work along each column or row of a matrix. Some of these methods 5301return a matrix with the same size as the invocand matrix. Other methods 5302collapse the dimension, so that, e.g., if the method is applied to the first 5303dimension a I<p>-by-I<q> matrix becomes a 1-by-I<q> matrix, and if applied to 5304the second dimension, it becomes a I<p>-by-1 matrix. Others, like C<L</diff()>>, 5305reduces the length along the dimension by one, so a I<p>-by-I<q> matrix becomes 5306a (I<p>-1)-by-I<q> or a I<p>-by-(I<q>-1) matrix. 5307 5308=over 4 5309 5310=item sum() 5311 5312Sum of elements along various dimensions of a matrix. If the dimension argument 5313is not given, the first non-singleton dimension is used. 5314 5315 $y = $x -> sum($dim); 5316 $y = $x -> sum(); 5317 5318=cut 5319 5320sub sum { 5321 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 5322 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 5323 my $x = shift; 5324 $x -> apply(\&_sum, @_); 5325} 5326 5327=pod 5328 5329=item prod() 5330 5331Product of elements along various dimensions of a matrix. If the dimension 5332argument is not given, the first non-singleton dimension is used. 5333 5334 $y = $x -> prod($dim); 5335 $y = $x -> prod(); 5336 5337=cut 5338 5339sub prod { 5340 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 5341 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 5342 my $x = shift; 5343 $x -> apply(\&_prod, @_); 5344} 5345 5346=pod 5347 5348=item mean() 5349 5350Mean of elements along various dimensions of a matrix. If the dimension argument 5351is not given, the first non-singleton dimension is used. 5352 5353 $y = $x -> mean($dim); 5354 $y = $x -> mean(); 5355 5356=cut 5357 5358sub mean { 5359 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 5360 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 5361 my $x = shift; 5362 $x -> apply(\&_mean, @_); 5363} 5364 5365=pod 5366 5367=item hypot() 5368 5369Hypotenuse. Computes the square root of the sum of the square of each element 5370along various dimensions of a matrix. If the dimension argument is not given, 5371the first non-singleton dimension is used. 5372 5373 $y = $x -> hypot($dim); 5374 $y = $x -> hypot(); 5375 5376For example, 5377 5378 $x = Math::Matrix -> new([[3, 4], 5379 [5, 12]]); 5380 $y = $x -> hypot(2); 5381 5382returns the 2-by-1 matrix 5383 5384 [ 5 ] 5385 [ 13 ] 5386 5387=cut 5388 5389sub hypot { 5390 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 5391 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 5392 my $x = shift; 5393 $x -> apply(\&_hypot, @_); 5394} 5395 5396=pod 5397 5398=item min() 5399 5400Minimum of elements along various dimensions of a matrix. If the dimension 5401argument is not given, the first non-singleton dimension is used. 5402 5403 $y = $x -> min($dim); 5404 $y = $x -> min(); 5405 5406=cut 5407 5408sub min { 5409 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 5410 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 5411 my $x = shift; 5412 $x -> apply(\&_min, @_); 5413} 5414 5415=pod 5416 5417=item max() 5418 5419Maximum of elements along various dimensions of a matrix. If the dimension 5420argument is not given, the first non-singleton dimension is used. 5421 5422 $y = $x -> max($dim); 5423 $y = $x -> max(); 5424 5425=cut 5426 5427sub max { 5428 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 5429 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 5430 my $x = shift; 5431 $x -> apply(\&_max, @_); 5432} 5433 5434=pod 5435 5436=item median() 5437 5438Median of elements along various dimensions of a matrix. If the dimension 5439argument is not given, the first non-singleton dimension is used. 5440 5441 $y = $x -> median($dim); 5442 $y = $x -> median(); 5443 5444=cut 5445 5446sub median { 5447 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 5448 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 5449 my $x = shift; 5450 $x -> apply(\&_median, @_); 5451} 5452 5453=pod 5454 5455=item cumsum() 5456 5457Returns the cumulative sum along various dimensions of a matrix. If the 5458dimension argument is not given, the first non-singleton dimension is used. 5459 5460 $y = $x -> cumsum($dim); 5461 $y = $x -> cumsum(); 5462 5463=cut 5464 5465sub cumsum { 5466 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 5467 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 5468 my $x = shift; 5469 $x -> apply(\&_cumsum, @_); 5470} 5471 5472=pod 5473 5474=item cumprod() 5475 5476Returns the cumulative product along various dimensions of a matrix. If the 5477dimension argument is not given, the first non-singleton dimension is used. 5478 5479 $y = $x -> cumprod($dim); 5480 $y = $x -> cumprod(); 5481 5482=cut 5483 5484sub cumprod { 5485 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 5486 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 5487 my $x = shift; 5488 $x -> apply(\&_cumprod, @_); 5489} 5490 5491=pod 5492 5493=item cummean() 5494 5495Returns the cumulative mean along various dimensions of a matrix. If the 5496dimension argument is not given, the first non-singleton dimension is used. 5497 5498 $y = $x -> cummean($dim); 5499 $y = $x -> cummean(); 5500 5501=cut 5502 5503sub cummean { 5504 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 5505 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 5506 my $x = shift; 5507 $x -> apply(\&_cummean, @_); 5508} 5509 5510=pod 5511 5512=item diff() 5513 5514Returns the differences between adjacent elements. If the dimension argument is 5515not given, the first non-singleton dimension is used. 5516 5517 $y = $x -> diff($dim); 5518 $y = $x -> diff(); 5519 5520=cut 5521 5522sub diff { 5523 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 5524 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 5525 my $x = shift; 5526 $x -> apply(\&_diff, @_); 5527} 5528 5529=pod 5530 5531=item vecnorm() 5532 5533Return the C<$p>-norm of the elements of C<$x>. If the dimension argument is not 5534given, the first non-singleton dimension is used. 5535 5536 $y = $x -> vecnorm($p, $dim); 5537 $y = $x -> vecnorm($p); 5538 $y = $x -> vecnorm(); 5539 5540The C<$p>-norm of a vector is defined as the C<$p>th root of the sum of the 5541absolute values fo the elements raised to the C<$p>th power. 5542 5543=cut 5544 5545sub vecnorm { 5546 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 5547 croak "Too many arguments for ", (caller(0))[3] if @_ > 3; 5548 my $x = shift; 5549 my $class = ref $x; 5550 5551 my $p = 2; 5552 if (@_) { 5553 $p = shift; 5554 croak 'When the \$p argument is given, it can not be undefined' 5555 unless defined $p; 5556 if (ref $p) { 5557 $p = $class -> new($p) 5558 unless defined(blessed($p)) && $p -> isa($class); 5559 croak 'The $p argument must be a scalar' unless $p -> is_scalar(); 5560 $p = $p -> [0][0]; 5561 } 5562 } 5563 5564 my $sub = sub { _vecnorm($p, @_) }; 5565 $x -> apply($sub, @_); 5566} 5567 5568=pod 5569 5570=item apply() 5571 5572Applies a subroutine to each row or column of a matrix. If the dimension 5573argument is not given, the first non-singleton dimension is used. 5574 5575 $y = $x -> apply($sub, $dim); 5576 $y = $x -> apply($sub); 5577 5578The subroutine is passed a list with all elements in a single column or row. 5579 5580=cut 5581 5582sub apply { 5583 my $x = shift; 5584 my $class = ref $x; 5585 5586 my $sub = shift; 5587 5588 # Get the size of the input $x. 5589 5590 my ($nrowx, $ncolx) = $x -> size(); 5591 5592 # Get the dimension along which to apply the subroutine. 5593 5594 my $dim; 5595 if (@_) { 5596 $dim = shift; 5597 croak "Dimension can not be undefined" unless defined $dim; 5598 if (ref $dim) { 5599 $dim = $class -> new($dim) 5600 unless defined(blessed($dim)) && $dim -> isa($class); 5601 croak "Dimension must be a scalar" unless $dim -> is_scalar(); 5602 $dim = $dim -> [0][0]; 5603 croak "Dimension must be a positive integer" 5604 unless $dim > 0 && $dim == CORE::int($dim); 5605 } 5606 croak "Dimension must be 1 or 2" unless $dim == 1 || $dim == 2; 5607 } else { 5608 $dim = $nrowx > 1 ? 1 : 2; 5609 } 5610 5611 # Initialise output. 5612 5613 my $y = []; 5614 5615 # Work along the first dimension, i.e., each column. 5616 5617 my ($nrowy, $ncoly); 5618 if ($dim == 1) { 5619 $nrowy = 0; 5620 for my $j (0 .. $ncolx - 1) { 5621 my @col = $sub -> (map $_ -> [$j], @$x); 5622 if ($j == 0) { 5623 $nrowy = @col; 5624 } else { 5625 croak "The number of elements in each column must be the same" 5626 unless $nrowy == @col; 5627 } 5628 $y -> [$_][$j] = $col[$_] for 0 .. $#col; 5629 } 5630 $y = [] if $nrowy == 0; 5631 } 5632 5633 # Work along the second dimension, i.e., each row. 5634 5635 elsif ($dim == 2) { 5636 $ncoly = 0; 5637 for my $i (0 .. $nrowx - 1) { 5638 my @row = $sub -> (@{ $x -> [$i] }); 5639 if ($i == 0) { 5640 $ncoly = @row; 5641 } else { 5642 croak "The number of elements in each row must be the same" 5643 unless $ncoly == @row; 5644 } 5645 $y -> [$i] = [ @row ]; 5646 } 5647 $y = [] if $ncoly == 0; 5648 } 5649 5650 bless $y, $class; 5651} 5652 5653=pod 5654 5655=back 5656 5657=head2 Comparison 5658 5659=head3 Matrix comparison 5660 5661Methods matrix comparison. These methods return a scalar value. 5662 5663=over 4 5664 5665=item meq() 5666 5667Matrix equal to. Returns 1 if two matrices are identical and 0 otherwise. 5668 5669 $bool = $x -> meq($y); 5670 5671=cut 5672 5673sub meq { 5674 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 5675 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 5676 my $x = shift; 5677 my $class = ref $x; 5678 5679 my $y = shift; 5680 $y = $class -> new($y) 5681 unless defined(blessed($y)) && $y -> isa($class); 5682 5683 my ($nrowx, $ncolx) = $x -> size(); 5684 my ($nrowy, $ncoly) = $y -> size(); 5685 5686 # Quick exit if the sizes don't match. 5687 5688 return 0 unless $nrowx == $nrowy && $ncolx == $ncoly; 5689 5690 # Compare the elements. 5691 5692 for my $i (0 .. $nrowx - 1) { 5693 for my $j (0 .. $ncolx - 1) { 5694 return 0 if $x->[$i][$j] != $y->[$i][$j]; 5695 } 5696 } 5697 return 1; 5698} 5699 5700=pod 5701 5702=item mne() 5703 5704Matrix not equal to. Returns 1 if two matrices are different and 0 otherwise. 5705 5706 $bool = $x -> mne($y); 5707 5708=cut 5709 5710sub mne { 5711 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 5712 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 5713 my $x = shift; 5714 my $class = ref $x; 5715 5716 my $y = shift; 5717 $y = $class -> new($y) 5718 unless defined(blessed($y)) && $y -> isa($class); 5719 5720 my ($nrowx, $ncolx) = $x -> size(); 5721 my ($nrowy, $ncoly) = $y -> size(); 5722 5723 # Quick exit if the sizes don't match. 5724 5725 return 1 unless $nrowx == $nrowy && $ncolx == $ncoly; 5726 5727 # Compare the elements. 5728 5729 for my $i (0 .. $nrowx - 1) { 5730 for my $j (0 .. $ncolx - 1) { 5731 return 1 if $x->[$i][$j] != $y->[$i][$j]; 5732 } 5733 } 5734 return 0; 5735} 5736 5737=pod 5738 5739=item equal() 5740 5741Decide if two matrices are equal. The criterion is, that each pair of elements 5742differs less than $Math::Matrix::eps. 5743 5744 $bool = $x -> equal($y); 5745 5746=cut 5747 5748sub equal { 5749 my $A = shift; 5750 my $B = shift; 5751 5752 my $jmax = $#{$A->[0]}; 5753 for my $i (0 .. $#{$A}) { 5754 for my $j (0 .. $jmax) { 5755 return 0 if CORE::abs($A->[$i][$j] - $B->[$i][$j]) >= $eps; 5756 } 5757 } 5758 return 1; 5759} 5760 5761=pod 5762 5763=back 5764 5765=head3 Scalar comparison 5766 5767Each of these methods performs scalar (element by element) comparison and 5768returns a matrix of ones and zeros. Scalar expansion is performed if necessary. 5769 5770=over 4 5771 5772=item seq() 5773 5774Scalar equality. Performs scalar (element by element) comparison of two 5775matrices. 5776 5777 $bool = $x -> seq($y); 5778 5779=cut 5780 5781sub seq { 5782 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 5783 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 5784 my $x = shift; 5785 my $class = ref $x; 5786 5787 my $y = shift; 5788 $y = $class -> new($y) 5789 unless defined(blessed($y)) && $y -> isa($class); 5790 5791 $x -> sapply(sub { $_[0] == $_[1] ? 1 : 0 }, $y); 5792} 5793 5794=pod 5795 5796=item sne() 5797 5798Scalar (element by element) not equal to. Performs scalar (element by element) 5799comparison of two matrices. 5800 5801 $bool = $x -> sne($y); 5802 5803=cut 5804 5805sub sne { 5806 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 5807 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 5808 my $x = shift; 5809 my $class = ref $x; 5810 5811 my $y = shift; 5812 $y = $class -> new($y) 5813 unless defined(blessed($y)) && $y -> isa($class); 5814 5815 $x -> sapply(sub { $_[0] != $_[1] ? 1 : 0 }, $y); 5816} 5817 5818=pod 5819 5820=item slt() 5821 5822Scalar (element by element) less than. Performs scalar (element by element) 5823comparison of two matrices. 5824 5825 $bool = $x -> slt($y); 5826 5827=cut 5828 5829sub slt { 5830 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 5831 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 5832 my $x = shift; 5833 my $class = ref $x; 5834 5835 my $y = shift; 5836 $y = $class -> new($y) 5837 unless defined(blessed($y)) && $y -> isa($class); 5838 5839 $x -> sapply(sub { $_[0] < $_[1] ? 1 : 0 }, $y); 5840} 5841 5842=pod 5843 5844=item sle() 5845 5846Scalar (element by element) less than or equal to. Performs scalar 5847(element by element) comparison of two matrices. 5848 5849 $bool = $x -> sle($y); 5850 5851=cut 5852 5853sub sle { 5854 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 5855 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 5856 my $x = shift; 5857 my $class = ref $x; 5858 5859 my $y = shift; 5860 $y = $class -> new($y) 5861 unless defined(blessed($y)) && $y -> isa($class); 5862 5863 $x -> sapply(sub { $_[0] <= $_[1] ? 1 : 0 }, $y); 5864} 5865 5866=pod 5867 5868=item sgt() 5869 5870Scalar (element by element) greater than. Performs scalar (element by element) 5871comparison of two matrices. 5872 5873 $bool = $x -> sgt($y); 5874 5875=cut 5876 5877sub sgt { 5878 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 5879 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 5880 my $x = shift; 5881 my $class = ref $x; 5882 5883 my $y = shift; 5884 $y = $class -> new($y) 5885 unless defined(blessed($y)) && $y -> isa($class); 5886 5887 $x -> sapply(sub { $_[0] > $_[1] ? 1 : 0 }, $y); 5888} 5889 5890=pod 5891 5892=item sge() 5893 5894Scalar (element by element) greater than or equal to. Performs scalar 5895(element by element) comparison of two matrices. 5896 5897 $bool = $x -> sge($y); 5898 5899=cut 5900 5901sub sge { 5902 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 5903 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 5904 my $x = shift; 5905 my $class = ref $x; 5906 5907 my $y = shift; 5908 $y = $class -> new($y) 5909 unless defined(blessed($y)) && $y -> isa($class); 5910 5911 $x -> sapply(sub { $_[0] >= $_[1] ? 1 : 0 }, $y); 5912} 5913 5914=pod 5915 5916=item scmp() 5917 5918Scalar (element by element) comparison. Performs scalar (element by element) 5919comparison of two matrices. Each element in the output matrix is either -1, 0, 5920or 1 depending on whether the elements are less than, equal to, or greater than 5921each other. 5922 5923 $bool = $x -> scmp($y); 5924 5925=cut 5926 5927sub scmp { 5928 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 5929 croak "Too many arguments for ", (caller(0))[3] if @_ > 2; 5930 my $x = shift; 5931 my $class = ref $x; 5932 5933 my $y = shift; 5934 $y = $class -> new($y) 5935 unless defined(blessed($y)) && $y -> isa($class); 5936 5937 $x -> sapply(sub { $_[0] <=> $_[1] }, $y); 5938} 5939 5940=pod 5941 5942=back 5943 5944=head2 Vector functions 5945 5946=over 4 5947 5948=item dot_product() 5949 5950Compute the dot product of two vectors. The second operand does not have to be 5951an object. 5952 5953 # $x and $y are both objects 5954 $x = Math::Matrix -> new([1, 2, 3]); 5955 $y = Math::Matrix -> new([4, 5, 6]); 5956 $p = $x -> dot_product($y); # $p = 32 5957 5958 # Only $x is an object. 5959 $p = $x -> dot_product([4, 5, 6]); # $p = 32 5960 5961=cut 5962 5963sub dot_product { 5964 my $x = shift; 5965 my $class = ref $x; 5966 5967 my $y = shift; 5968 $y = $class -> new($y) 5969 unless defined(blessed($y)) && $y -> isa($class); 5970 5971 croak "First argument must be a vector" unless $x -> is_vector(); 5972 $x = $x -> to_row() unless $x -> is_row(); 5973 5974 croak "Second argument must be a vector" unless $x -> is_vector(); 5975 $y = $y -> to_col() unless $x -> is_col(); 5976 5977 croak "The two vectors must have the same length" 5978 unless $x -> nelm() == $y -> nelm(); 5979 5980 $x -> multiply($y) -> [0][0]; 5981} 5982 5983=pod 5984 5985=item outer_product() 5986 5987Compute the outer product of two vectors. The second operand does not have to be 5988an object. 5989 5990 # $x and $y are both objects 5991 $x = Math::Matrix -> new([1, 2, 3]); 5992 $y = Math::Matrix -> new([4, 5, 6, 7]); 5993 $p = $x -> outer_product($y); 5994 5995 # Only $x is an object. 5996 $p = $x -> outer_product([4, 5, 6, y]); 5997 5998=cut 5999 6000sub outer_product { 6001 my $x = shift; 6002 my $class = ref $x; 6003 6004 my $y = shift; 6005 $y = $class -> new($y) 6006 unless defined(blessed($y)) && $y -> isa($class); 6007 6008 croak "First argument must be a vector" unless $x -> is_vector(); 6009 $x = $x -> to_col() unless $x -> is_col(); 6010 6011 croak "Second argument must be a vector" unless $x -> is_vector(); 6012 $y = $y -> to_row() unless $x -> is_row(); 6013 6014 $x -> multiply($y); 6015} 6016 6017=pod 6018 6019=item absolute() 6020 6021Compute the absolute value (i.e., length) of a vector. 6022 6023 $v = Math::Matrix -> new([3, 4]); 6024 $a = $v -> absolute(); # $v = 5 6025 6026=cut 6027 6028sub absolute { 6029 my $x = shift; 6030 croak "Argument must be a vector" unless $x -> is_vector(); 6031 6032 _hypot(@{ $x -> to_row() -> [0] }); 6033} 6034 6035=pod 6036 6037=item normalize() 6038 6039Normalize a vector, i.e., scale a vector so its length becomes 1. 6040 6041 $v = Math::Matrix -> new([3, 4]); 6042 $u = $v -> normalize(); # $u = [ 0.6, 0.8 ] 6043 6044=cut 6045 6046sub normalize { 6047 my $vector = shift; 6048 my $length = $vector->absolute(); 6049 return undef 6050 unless $length; 6051 $vector->multiply_scalar(1 / $length); 6052} 6053 6054=pod 6055 6056=item cross_product() 6057 6058Compute the cross-product of vectors. 6059 6060 $x = Math::Matrix -> new([1,3,2], 6061 [5,4,2]); 6062 $p = $x -> cross_product(); # $p = [ -2, 8, -11 ] 6063 6064=cut 6065 6066sub cross_product { 6067 my $vectors = shift; 6068 my $class = ref($vectors); 6069 6070 my $dimensions = @{$vectors->[0]}; 6071 return undef 6072 unless $dimensions == @$vectors + 1; 6073 6074 my @axis; 6075 foreach my $column (0..$dimensions-1) { 6076 my $tmp = $vectors->slice(0..$column-1, 6077 $column+1..$dimensions-1); 6078 my $scalar = $tmp->determinant; 6079 $scalar *= ($column % 2) ? -1 : 1; 6080 push @axis, $scalar; 6081 } 6082 my $axis = $class->new(\@axis); 6083 $axis = $axis->multiply_scalar(($dimensions % 2) ? 1 : -1); 6084} 6085 6086=pod 6087 6088=back 6089 6090=head2 Conversion 6091 6092=over 4 6093 6094=item as_string() 6095 6096Creates a string representation of the matrix and returns it. 6097 6098 $x = Math::Matrix -> new([1, 2], [3, 4]); 6099 $s = $x -> as_string(); 6100 6101=cut 6102 6103sub as_string { 6104 my $self = shift; 6105 my $out = ""; 6106 for my $row (@{$self}) { 6107 for my $col (@{$row}) { 6108 $out = $out . sprintf "%10.5f ", $col; 6109 } 6110 $out = $out . sprintf "\n"; 6111 } 6112 $out; 6113} 6114 6115=pod 6116 6117=item as_array() 6118 6119Returns the matrix as an unblessed Perl array, i.e., and ordinary, unblessed 6120reference. 6121 6122 $y = $x -> as_array(); # ref($y) returns 'ARRAY' 6123 6124=cut 6125 6126sub as_array { 6127 my $x = shift; 6128 [ map [ @$_ ], @$x ]; 6129} 6130 6131=pod 6132 6133=back 6134 6135=head2 Matrix utilities 6136 6137=head3 Apply a subroutine to each element 6138 6139=over 4 6140 6141=item map() 6142 6143Call a subroutine for every element of a matrix, locally setting C<$_> to each 6144element and passing the matrix row and column indices as input arguments. 6145 6146 # square each element 6147 $y = $x -> map(sub { $_ ** 2 }); 6148 6149 # set strictly lower triangular part to zero 6150 $y = $x -> map(sub { $_[0] > $_[1] ? 0 : $_ })' 6151 6152=cut 6153 6154sub map { 6155 my $x = shift; 6156 my $class = ref $x; 6157 6158 my $sub = shift; 6159 croak "The first input argument must be a code reference" 6160 unless ref($sub) eq 'CODE'; 6161 6162 my $y = []; 6163 my ($nrow, $ncol) = $x -> size(); 6164 for my $i (0 .. $nrow - 1) { 6165 for my $j (0 .. $ncol - 1) { 6166 local $_ = $x -> [$i][$j]; 6167 $y -> [$i][$j] = $sub -> ($i, $j); 6168 } 6169 } 6170 6171 bless $y, $class; 6172} 6173 6174=pod 6175 6176=item sapply() 6177 6178Applies a subroutine to each element of a matrix, or each set of corresponding 6179elements if multiple matrices are given, and returns the result. The first 6180argument is the subroutine to apply. The following arguments, if any, are 6181additional matrices on which to apply the subroutine. 6182 6183 $w = $x -> sapply($sub); # single operand 6184 $w = $x -> sapply($sub, $y); # two operands 6185 $w = $x -> sapply($sub, $y, $z); # three operands 6186 6187Each matrix element, or corresponding set of elements, are passed to the 6188subroutine as input arguments. 6189 6190When used with a single operand, this method is similar to the C<L</map()>> 6191method, the syntax is different, since C<L</sapply()>> supports multiple 6192operands. 6193 6194See also C<L</map()>>. 6195 6196=over 4 6197 6198=item * 6199 6200The subroutine is run in scalar context. 6201 6202=item * 6203 6204No checks are done on the return value of the subroutine. 6205 6206=item * 6207 6208The number of rows in the output matrix equals the number of rows in the operand 6209with the largest number of rows. Ditto for columns. So if C<$x> is 5-by-2 6210matrix, and C<$y> is a 3-by-4 matrix, the result is a 5-by-4 matrix. 6211 6212=item * 6213 6214For each operand that has a number of rows smaller than the maximum value, the 6215rows are recyled. Ditto for columns. 6216 6217=item * 6218 6219Don't modify the variables $_[0], $_[1] etc. inside the subroutine. Otherwise, 6220there is a risk of modifying the operand matrices. 6221 6222=item * 6223 6224If the matrix elements are objects that are not cloned when the "=" (assignment) 6225operator is used, you might have to explicitly clone the objects used inside the 6226subroutine. Otherwise, the elements in the output matrix might be references to 6227objects in the operand matrices, rather than references to new objects. 6228 6229=back 6230 6231Some examples 6232 6233=over 4 6234 6235=item One operand 6236 6237With one operand, i.e., the invocand matrix, the subroutine is applied to each 6238element of the invocand matrix. The returned matrix has the same size as the 6239invocand. For example, multiplying the matrix C<$x> with the scalar C<$c> 6240 6241 $sub = sub { $c * $_[0] }; # subroutine to multiply by $c 6242 $z = $x -> sapply($sub); # multiply each element by $c 6243 6244=item Two operands 6245 6246When two operands are specfied, the subroutine is applied to each pair of 6247corresponding elements in the two operands. For example, adding two matrices can 6248be implemented as 6249 6250 $sub = sub { $_[0] * $_[1] }; 6251 $z = $x -> sapply($sub, $y); 6252 6253Note that if the matrices have different sizes, the rows and/or columns of the 6254smaller are recycled to match the size of the larger. If C<$x> is a 6255C<$p>-by-C<$q> matrix and C<$y> is a C<$r>-by-C<$s> matrix, then C<$z> is a 6256max(C<$p>,C<$r>)-by-max(C<$q>,C<$s>) matrix, and 6257 6258 $z -> [$i][$j] = $sub -> ($x -> [$i % $p][$j % $q], 6259 $y -> [$i % $r][$j % $s]); 6260 6261Because of this recycling, multiplying the matrix C<$x> with the scalar C<$c> 6262(see above) can also be implemented as 6263 6264 $sub = sub { $_[0] * $_[1] }; 6265 $z = $x -> sapply($sub, $c); 6266 6267Generating a matrix with all combinations of C<$x**$y> for C<$x> being 4, 5, and 62686 and C<$y> being 1, 2, 3, and 4 can be done with 6269 6270 $c = Math::Matrix -> new([[4], [5], [6]]); # 3-by-1 column 6271 $r = Math::Matrix -> new([[1, 2, 3, 4]]); # 1-by-4 row 6272 $x = $c -> sapply(sub { $_[0] ** $_[1] }, $r); # 3-by-4 matrix 6273 6274=item Multiple operands 6275 6276In general, the sapply() method can have any number of arguments. For example, 6277to compute the sum of the four matrices C<$x>, C<$y>, C<$z>, and C<$w>, 6278 6279 $sub = sub { 6280 $sum = 0; 6281 for $val (@_) { 6282 $sum += $val; 6283 }; 6284 return $sum; 6285 }; 6286 $sum = $x -> sapply($sub, $y, $z, $w); 6287 6288=back 6289 6290=cut 6291 6292sub sapply { 6293 croak "Not enough arguments for ", (caller(0))[3] if @_ < 2; 6294 my $x = shift; 6295 my $class = ref $x; 6296 6297 # Get the subroutine to apply on all the elements. 6298 6299 my $sub = shift; 6300 croak "input argument must be a reference to a subroutine" 6301 unless ref($sub) eq 'CODE'; 6302 6303 my $y = bless [], $class; 6304 6305 # For speed, treat a single matrix operand as a special case. 6306 6307 if (@_ == 0) { 6308 my ($nrowx, $ncolx) = $x -> size(); 6309 return $y if $nrowx * $ncolx == 0; # quick exit if $x is empty 6310 6311 for my $i (0 .. $nrowx - 1) { 6312 for my $j (0 .. $ncolx - 1) { 6313 $y -> [$i][$j] = $sub -> ($x -> [$i][$j]); 6314 } 6315 } 6316 6317 return $y; 6318 } 6319 6320 # Create some auxiliary arrays. 6321 6322 my @args = ($x, @_); # all matrices 6323 my @size = (); # size of each matrix 6324 my @nelm = (); # number of elements in each matrix 6325 6326 # Loop over the input arguments to perform some checks and get their 6327 # properties. Also get the size (number of rows and columns) of the output 6328 # matrix. 6329 6330 my $nrowy = 0; 6331 my $ncoly = 0; 6332 6333 for my $k (0 .. $#args) { 6334 6335 # Make sure the k'th argument is a matrix object. 6336 6337 $args[$k] = $class -> new($args[$k]) 6338 unless defined(blessed($args[$k])) && $args[$k] -> isa($class); 6339 6340 # Get the number of rows, columns, and elements in the k'th argument, 6341 # and save this information for later. 6342 6343 my ($nrowk, $ncolk) = $args[$k] -> size(); 6344 $size[$k] = [ $nrowk, $ncolk ]; 6345 $nelm[$k] = $nrowk * $ncolk; 6346 6347 # Update the size of the output matrix. 6348 6349 $nrowy = $nrowk if $nrowk > $nrowy; 6350 $ncoly = $ncolk if $ncolk > $ncoly; 6351 } 6352 6353 # We only accept empty matrices if all matrices are empty. 6354 6355 my $n_empty = grep { $_ == 0 } @nelm; 6356 return $y if $n_empty == @args; # quick exit if all are empty 6357 6358 # At ths point, we know that not all matrices are empty, but some might be 6359 # empty. We only continue if none are empty. 6360 6361 croak "Either all or none of the matrices must be empty in ", (caller(0))[3] 6362 unless $n_empty == 0; 6363 6364 # Loop over the subscripts into the output matrix. 6365 6366 for my $i (0 .. $nrowy - 1) { 6367 for my $j (0 .. $ncoly - 1) { 6368 6369 # Initialize the argument list for the subroutine call that will 6370 # give the value for element ($i,$j) in the output matrix. 6371 6372 my @elms = (); 6373 6374 # Loop over the matrices. 6375 6376 for my $k (0 .. $#args) { 6377 6378 # Get the number of rows and columns in the k'th matrix. 6379 6380 my $nrowk = $size[$k][0]; 6381 my $ncolk = $size[$k][1]; 6382 6383 # Compute the subscripts of the element to use in the k'th 6384 # matrix. 6385 6386 my $ik = $i % $nrowk; 6387 my $jk = $j % $ncolk; 6388 6389 # Get the element from the k'th matrix to use in this call. 6390 6391 $elms[$k] = $args[$k][$ik][$jk]; 6392 } 6393 6394 # Now we have the argument list for the subroutine call. 6395 6396 $y -> [$i][$j] = $sub -> (@elms); 6397 } 6398 } 6399 6400 return $y; 6401} 6402 6403=pod 6404 6405=back 6406 6407=head3 Forward elimination 6408 6409These methods take a matrix as input, performs forward elimination, and returns 6410a matrix where all elements below the main diagonal are zero. In list context, 6411four additional arguments are returned: an array with the row permutations, an 6412array with the column permutations, an integer with the number of row swaps and 6413an integer with the number of column swaps performed during elimination. 6414 6415The permutation vectors can be converted to permutation matrices with 6416C<L</to_permmat()>>. 6417 6418=over 6419 6420=item felim_np() 6421 6422Perform forward elimination with no pivoting. 6423 6424 $y = $x -> felim_np(); 6425 6426Forward elimination without pivoting may fail even when the matrix is 6427non-singular. 6428 6429This method is provided mostly for illustration purposes. 6430 6431=cut 6432 6433sub felim_np { 6434 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 6435 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 6436 my $x = shift; 6437 6438 $x = $x -> clone(); 6439 my $nrow = $x -> nrow(); 6440 my $ncol = $x -> ncol(); 6441 6442 my $imax = $nrow - 1; 6443 my $jmax = $ncol - 1; 6444 6445 my $iperm = [ 0 .. $imax ]; # row permutation vector 6446 my $jperm = [ 0 .. $imax ]; # column permutation vector 6447 my $iswap = 0; # number of row swaps 6448 my $jswap = 0; # number of column swaps 6449 6450 my $debug = 0; 6451 6452 printf "\nfelim_np(): before 0:\n\n%s\n", $x if $debug; 6453 6454 for (my $i = 0 ; $i <= $imax && $i <= $jmax ; ++$i) { 6455 6456 # The so far remaining unreduced submatrix starts at element ($i,$i). 6457 6458 # Skip this round, if all elements below (i,i) are zero. 6459 6460 my $saw_non_zero = 0; 6461 for (my $u = $i + 1 ; $u <= $imax ; ++$u) { 6462 if ($x->[$u][$i] != 0) { 6463 $saw_non_zero = 1; 6464 last; 6465 } 6466 } 6467 next unless $saw_non_zero; 6468 6469 # Since we don't use pivoting, element ($i,$i) must be non-zero. 6470 6471 if ($x->[$i][$i] == 0) { 6472 croak "No pivot element found for row $i"; 6473 } 6474 6475 # Subtract row $i from each row $u below $i. 6476 6477 for (my $u = $i + 1 ; $u <= $imax ; ++$u) { 6478 for (my $j = $jmax ; $j >= $i ; --$j) { 6479 $x->[$u][$j] -= ($x->[$i][$j] * $x->[$u][$i]) / $x->[$i][$i]; 6480 } 6481 6482 # In case of round-off errors. 6483 6484 $x->[$u][$i] *= 0; 6485 } 6486 6487 printf "\nfelim_np(): after %u:\n\n%s\n\n", $i, $x if $debug; 6488 } 6489 6490 return $x, $iperm, $jperm, $iswap, $jswap if wantarray; 6491 return $x; 6492} 6493 6494=pod 6495 6496=item felim_tp() 6497 6498Perform forward elimination with trivial pivoting, a variant of partial 6499pivoting. 6500 6501 $y = $x -> felim_tp(); 6502 6503If A is a p-by-q matrix, and the so far remaining unreduced submatrix starts at 6504element (i,i), the pivot element is the first element in column i that is 6505non-zero. 6506 6507This method is provided mostly for illustration purposes. 6508 6509=cut 6510 6511sub felim_tp { 6512 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 6513 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 6514 my $x = shift; 6515 6516 croak "felim_tp(): too many input arguments" if @_ > 0; 6517 6518 $x = $x -> clone(); 6519 my $nrow = $x -> nrow(); 6520 my $ncol = $x -> ncol(); 6521 6522 my $imax = $nrow - 1; 6523 my $jmax = $ncol - 1; 6524 6525 my $iperm = [ 0 .. $imax ]; # row permutation vector 6526 my $jperm = [ 0 .. $imax ]; # column permutation vector 6527 my $iswap = 0; # number of row swaps 6528 my $jswap = 0; # number of column swaps 6529 6530 my $debug = 0; 6531 6532 printf "\nfelim_tp(): before 0:\n\n%s\n", $x if $debug; 6533 6534 for (my $i = 0 ; $i <= $imax && $i <= $jmax ; ++$i) { 6535 6536 # The so far remaining unreduced submatrix starts at element ($i,$i). 6537 6538 # Skip this round, if all elements below (i,i) are zero. 6539 6540 my $saw_non_zero = 0; 6541 for (my $u = $i + 1 ; $u <= $imax ; ++$u) { 6542 if ($x->[$u][$i] != 0) { 6543 $saw_non_zero = 1; 6544 last; 6545 } 6546 } 6547 next unless $saw_non_zero; 6548 6549 # The pivot element is the first element in column $i (in the unreduced 6550 # submatrix) that is non-zero. 6551 6552 my $p; # index of pivot row 6553 6554 for (my $u = $i ; $u <= $imax ; ++$u) { 6555 if ($x->[$u][$i] != 0) { 6556 $p = $u; 6557 last; 6558 } 6559 } 6560 6561 printf "\nfelim_tp(): pivot element is (%u,%u)\n", $p, $i if $debug; 6562 6563 # Swap rows $i and $p. 6564 6565 if ($p != $i) { 6566 ($x->[$i], $x->[$p]) = ($x->[$p], $x->[$i]); 6567 ($iperm->[$i], $iperm->[$p]) = ($iperm->[$p], $iperm->[$i]); 6568 $iswap++; 6569 } 6570 6571 # Subtract row $i from all following rows. 6572 6573 for (my $u = $i + 1 ; $u <= $imax ; ++$u) { 6574 6575 for (my $j = $jmax ; $j >= $i ; --$j) { 6576 $x->[$u][$j] -= ($x->[$i][$j] * $x->[$u][$i]) / $x->[$i][$i]; 6577 } 6578 6579 # In case of round-off errors. 6580 6581 $x->[$u][$i] *= 0; 6582 } 6583 6584 printf "\nfelim_tp(): after %u:\n\n%s\n\n", $i, $x if $debug; 6585 } 6586 6587 return $x, $iperm, $jperm, $iswap, $jswap if wantarray; 6588 return $x; 6589} 6590 6591=pod 6592 6593=item felim_pp() 6594 6595Perform forward elimination with (unscaled) partial pivoting. 6596 6597 $y = $x -> felim_pp(); 6598 6599If A is a p-by-q matrix, and the so far remaining unreduced submatrix starts at 6600element (i,i), the pivot element is the element in column i that has the largest 6601absolute value. 6602 6603This method is provided mostly for illustration purposes. 6604 6605=cut 6606 6607sub felim_pp { 6608 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 6609 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 6610 my $x = shift; 6611 6612 croak "felim_pp(): too many input arguments" if @_ > 0; 6613 6614 $x = $x -> clone(); 6615 my $nrow = $x -> nrow(); 6616 my $ncol = $x -> ncol(); 6617 6618 my $imax = $nrow - 1; 6619 my $jmax = $ncol - 1; 6620 6621 my $iperm = [ 0 .. $imax ]; # row permutation vector 6622 my $jperm = [ 0 .. $imax ]; # column permutation vector 6623 my $iswap = 0; # number of row swaps 6624 my $jswap = 0; # number of column swaps 6625 6626 my $debug = 0; 6627 6628 printf "\nfelim_pp(): before 0:\n\n%s\n", $x if $debug; 6629 6630 for (my $i = 0 ; $i <= $imax && $i <= $jmax ; ++$i) { 6631 6632 # The so far remaining unreduced submatrix starts at element ($i,$i). 6633 6634 # Skip this round, if all elements below (i,i) are zero. 6635 6636 my $saw_non_zero = 0; 6637 for (my $u = $i + 1 ; $u <= $imax ; ++$u) { 6638 if ($x->[$u][$i] != 0) { 6639 $saw_non_zero = 1; 6640 last; 6641 } 6642 } 6643 next unless $saw_non_zero; 6644 6645 # The pivot element is the element in column $i (in the unreduced 6646 # submatrix) that has the largest absolute value. 6647 6648 my $p; # index of pivot row 6649 my $max_abs_val = 0; 6650 6651 for (my $u = $i ; $u <= $imax ; ++$u) { 6652 my $abs_val = CORE::abs($x->[$u][$i]); 6653 if ($abs_val > $max_abs_val) { 6654 $max_abs_val = $abs_val; 6655 $p = $u; 6656 } 6657 } 6658 6659 printf "\nfelim_pp(): pivot element is (%u,%u)\n", $p, $i if $debug; 6660 6661 # Swap rows $i and $p. 6662 6663 if ($p != $i) { 6664 ($x->[$p], $x->[$i]) = ($x->[$i], $x->[$p]); 6665 ($iperm->[$p], $iperm->[$i]) = ($iperm->[$i], $iperm->[$p]); 6666 $iswap++; 6667 } 6668 6669 # Subtract row $i from all following rows. 6670 6671 for (my $u = $i + 1 ; $u <= $imax ; ++$u) { 6672 6673 for (my $j = $jmax ; $j >= $i ; --$j) { 6674 $x->[$u][$j] -= ($x->[$i][$j] * $x->[$u][$i]) / $x->[$i][$i]; 6675 } 6676 6677 # In case of round-off errors. 6678 6679 $x->[$u][$i] *= 0; 6680 } 6681 6682 printf "\nfelim_pp(): after %u:\n\n%s\n\n", $i, $x if $debug; 6683 } 6684 6685 return $x, $iperm, $jperm, $iswap, $jswap if wantarray; 6686 return $x; 6687} 6688 6689=pod 6690 6691=item felim_sp() 6692 6693Perform forward elimination with scaled pivoting, a variant of partial pivoting. 6694 6695 $y = $x -> felim_sp(); 6696 6697If A is a p-by-q matrix, and the so far remaining unreduced submatrix starts at 6698element (i,i), the pivot element is the element in column i that has the largest 6699absolute value relative to the other elements on the same row. 6700 6701=cut 6702 6703sub felim_sp { 6704 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 6705 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 6706 my $x = shift; 6707 6708 croak "felim_sp(): too many input arguments" if @_ > 0; 6709 6710 $x = $x -> clone(); 6711 my $nrow = $x -> nrow(); 6712 my $ncol = $x -> ncol(); 6713 6714 my $imax = $nrow - 1; 6715 my $jmax = $ncol - 1; 6716 6717 my $iperm = [ 0 .. $imax ]; # row permutation vector 6718 my $jperm = [ 0 .. $imax ]; # column permutation vector 6719 my $iswap = 0; # number of row swaps 6720 my $jswap = 0; # number of column swaps 6721 6722 my $debug = 0; 6723 6724 printf "\nfelim_sp(): before 0:\n\n%s\n", $x if $debug; 6725 6726 for (my $i = 0 ; $i <= $imax && $i <= $jmax ; ++$i) { 6727 6728 # The so far remaining unreduced submatrix starts at element ($i,$i). 6729 6730 # Skip this round, if all elements below (i,i) are zero. 6731 6732 my $saw_non_zero = 0; 6733 for (my $u = $i + 1 ; $u <= $imax ; ++$u) { 6734 if ($x->[$u][$i] != 0) { 6735 $saw_non_zero = 1; 6736 last; 6737 } 6738 } 6739 next unless $saw_non_zero; 6740 6741 # The pivot element is the element in column $i (in the unreduced 6742 # submatrix) that has the largest absolute value relative to the other 6743 # elements on the same row. 6744 6745 my $p; 6746 my $max_abs_ratio = 0; 6747 6748 for (my $u = $i ; $u <= $imax ; ++$u) { 6749 6750 # Find the element with the largest absolute value in row $u. 6751 6752 my $max_abs_val = 0; 6753 for (my $v = $i ; $v <= $jmax ; ++$v) { 6754 my $abs_val = CORE::abs($x->[$u][$v]); 6755 $max_abs_val = $abs_val if $abs_val > $max_abs_val; 6756 } 6757 6758 next if $max_abs_val == 0; 6759 6760 # Find the ratio for this row and see if it the best so far. 6761 6762 my $abs_ratio = CORE::abs($x->[$u][$i]) / $max_abs_val; 6763 #croak "column ", $i + 1, " has only zeros" 6764 # if $ratio == 0; 6765 6766 if ($abs_ratio > $max_abs_ratio) { 6767 $max_abs_ratio = $abs_ratio; 6768 $p = $u; 6769 } 6770 6771 } 6772 6773 printf "\nfelim_sp(): pivot element is (%u,%u)\n", $p, $i if $debug; 6774 6775 # Swap rows $i and $p. 6776 6777 if ($p != $i) { 6778 ($x->[$p], $x->[$i]) = ($x->[$i], $x->[$p]); 6779 ($iperm->[$p], $iperm->[$i]) = ($iperm->[$i], $iperm->[$p]); 6780 $iswap++; 6781 } 6782 6783 # Subtract row $i from all following rows. 6784 6785 for (my $u = $i + 1 ; $u <= $imax ; ++$u) { 6786 6787 for (my $j = $jmax ; $j >= $i ; --$j) { 6788 $x->[$u][$j] -= ($x->[$i][$j] * $x->[$u][$i]) / $x->[$i][$i]; 6789 } 6790 6791 # In case of round-off errors. 6792 6793 $x->[$u][$i] *= 0; 6794 } 6795 6796 printf "\nfelim_sp(): after %u:\n\n%s\n\n", $i, $x if $debug; 6797 } 6798 6799 return $x, $iperm, $jperm, $iswap, $jswap if wantarray; 6800 return $x; 6801} 6802 6803=pod 6804 6805=item felim_fp() 6806 6807Performs forward elimination with full pivoting. 6808 6809 $y = $x -> felim_fp(); 6810 6811The elimination is done with full pivoting, also called complete pivoting or 6812total pivoting. If A is a p-by-q matrix, and the so far remaining unreduced 6813submatrix starts at element (i,i), the pivot element is the element in the whole 6814submatrix that has the largest absolute value. With full pivoting, both rows and 6815columns might be swapped. 6816 6817=cut 6818 6819sub felim_fp { 6820 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 6821 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 6822 my $x = shift; 6823 6824 croak "felim_fp(): too many input arguments" if @_ > 0; 6825 6826 $x = $x -> clone(); 6827 my $nrow = $x -> nrow(); 6828 my $ncol = $x -> ncol(); 6829 6830 my $imax = $nrow - 1; 6831 my $jmax = $ncol - 1; 6832 6833 my $iperm = [ 0 .. $imax ]; # row permutation vector 6834 my $jperm = [ 0 .. $imax ]; # column permutation vector 6835 my $iswap = 0; # number of row swaps 6836 my $jswap = 0; # number of column swaps 6837 6838 my $debug = 0; 6839 6840 printf "\nfelim_fp(): before 0:\n\n%s\n", $x if $debug; 6841 6842 for (my $i = 0 ; $i <= $imax && $i <= $jmax ; ++$i) { 6843 6844 # The so far remaining unreduced submatrix starts at element ($i,$i). 6845 # The pivot element is the element in the whole submatrix that has the 6846 # largest absolute value. 6847 6848 my $p; # index of pivot row 6849 my $q; # index of pivot column 6850 6851 # Loop over each row and column in the submatrix to find the element 6852 # with the largest absolute value. 6853 6854 my $max_abs_val = 0; 6855 for (my $u = $i ; $u <= $imax ; ++$u) { 6856 for (my $v = $i ; $v <= $imax && $v <= $jmax ; ++$v) { 6857 my $abs_val = CORE::abs($x->[$u][$v]); 6858 if ($abs_val > $max_abs_val) { 6859 $max_abs_val = $abs_val; 6860 $p = $u; 6861 $q = $v; 6862 } 6863 } 6864 } 6865 6866 # If we didn't find a pivot element, it means that the so far unreduced 6867 # submatrix contains zeros only, in which case we're done. 6868 6869 last unless defined $p; 6870 6871 printf "\nfelim_fp(): pivot element is (%u,%u)\n", $p, $q if $debug; 6872 6873 # Swap rows $i and $p. 6874 6875 if ($p != $i) { 6876 printf "\nfelim_fp(): swapping rows %u and %u\n", $p, $i if $debug; 6877 printf "\nfrom this:\n\n%s\n", $x if $debug; 6878 ($x->[$p], $x->[$i]) = ($x->[$i], $x->[$p]); 6879 printf "\nto this:\n\n%s\n", $x if $debug; 6880 ($iperm->[$p], $iperm->[$i]) = ($iperm->[$i], $iperm->[$p]); 6881 $iswap++; 6882 } 6883 6884 # Swap columns $i and $q. 6885 6886 if ($q != $i) { 6887 printf "\nfelim_fp(): swapping columns %u and %u\n", $q, $i if $debug; 6888 printf "\nfrom this:\n\n%s\n", $x if $debug; 6889 for (my $u = 0 ; $u <= $imax ; ++$u) { 6890 ($x->[$u][$q], $x->[$u][$i]) = ($x->[$u][$i], $x->[$u][$q]); 6891 } 6892 printf "\nto this:\n\n%s\n", $x if $debug; 6893 ($jperm->[$q], $jperm->[$i]) = ($jperm->[$i], $jperm->[$q]); 6894 $jswap++; 6895 } 6896 6897 # Subtract row $i from all following rows. 6898 6899 for (my $u = $i + 1 ; $u <= $imax ; ++$u) { 6900 6901 for (my $j = $jmax ; $j >= $i ; --$j) { 6902 $x->[$u][$j] -= ($x->[$i][$j] * $x->[$u][$i]) / $x->[$i][$i]; 6903 } 6904 6905 # In case of round-off errors. 6906 6907 $x->[$u][$i] *= 0; 6908 } 6909 6910 printf "\nfelim_fp(): after %u:\n\n%s\n\n", $i, $x if $debug; 6911 } 6912 6913 return $x, $iperm, $jperm, $iswap, $jswap if wantarray; 6914 return $x; 6915} 6916 6917=pod 6918 6919=back 6920 6921=head3 Back-substitution 6922 6923=over 4 6924 6925=item bsubs() 6926 6927Performs back-substitution. 6928 6929 $y = $x -> bsubs(); 6930 6931The leftmost square portion of the matrix must be upper triangular. 6932 6933=cut 6934 6935sub bsubs { 6936 croak "Not enough arguments for ", (caller(0))[3] if @_ < 1; 6937 croak "Too many arguments for ", (caller(0))[3] if @_ > 1; 6938 my $x = shift; 6939 6940 croak "bsubs(): too many input arguments" if @_ > 0; 6941 6942 my $nrow = $x -> nrow(); 6943 my $ncol = $x -> ncol(); 6944 6945 my $imax = $nrow - 1; 6946 my $jmax = $ncol - 1; 6947 6948 my $debug = 0; 6949 6950 printf "\nbsubs(): before 0:\n\n%s\n", $x if $debug; 6951 6952 for (my $i = 0 ; $i <= $imax ; ++$i) { 6953 6954 # Check the elements below ($i,$i). They should all be zero. 6955 6956 for (my $k = $i + 1 ; $k <= $imax ; ++$k) { 6957 croak "matrix is not upper triangular; element ($i,$i) is non-zero" 6958 unless $x->[$k][$i] == 0; 6959 } 6960 6961 # There is no rows above the first row to perform back-substitution on. 6962 6963 next if $i == 0; 6964 6965 # If the element on the diagonal is zero, we can't use it to perform 6966 # back-substitution. However, this is not a problem if all the elements 6967 # above ($i,$i) are zero. 6968 6969 if ($x->[$i][$i] == 0) { 6970 my $non_zero = 0; 6971 my $k; 6972 for ($k = 0 ; $k < $i ; ++$k) { 6973 if ($x->[$k][$i] != 0) { 6974 $non_zero++; 6975 last; 6976 } 6977 } 6978 if ($non_zero) { 6979 croak "bsubs(): back substitution failed; diagonal element", 6980 " ($i,$i) is zero, but ($k,$i) isn't"; 6981 next; 6982 } 6983 } 6984 6985 # Subtract row $i from each row $u above row $i. 6986 6987 for (my $u = $i - 1 ; $u >= 0 ; --$u) { 6988 6989 # From row $u subtract $c times of row $i. 6990 6991 my $c = $x->[$u][$i] / $x->[$i][$i]; 6992 6993 for (my $j = $jmax ; $j >= $i ; --$j) { 6994 $x->[$u][$j] -= $c * $x->[$i][$j]; 6995 } 6996 6997 # In case of round-off errors. (Will they ever happen?) 6998 6999 $x->[$u][$i] *= 0; 7000 } 7001 7002 printf "\nbsubs(): after %u:\n\n%s\n\n", $i, $x if $debug; 7003 } 7004 7005 # Normalise. 7006 7007 for (my $i = 0 ; $i <= $imax ; ++$i) { 7008 next if $x->[$i][$i] == 1; # row is already normalized 7009 next if $x->[$i][$i] == 0; # row can't be normalized 7010 for (my $j = $imax + 1 ; $j <= $jmax ; ++$j) { 7011 $x->[$i][$j] /= $x->[$i][$i]; 7012 } 7013 $x->[$i][$i] = 1; 7014 } 7015 7016 printf "\nbsubs(): after normalisation:\n\n%s\n\n", $x if $debug; 7017 7018 return $x; 7019} 7020 7021=pod 7022 7023=back 7024 7025=head2 Miscellaneous methods 7026 7027=over 4 7028 7029=item print() 7030 7031Prints the matrix on STDOUT. If the method has additional parameters, these are 7032printed before the matrix is printed. 7033 7034=cut 7035 7036sub print { 7037 my $self = shift; 7038 7039 print @_ if scalar(@_); 7040 print $self->as_string; 7041} 7042 7043=pod 7044 7045=item version() 7046 7047Returns a string contining the package name and version number. 7048 7049=cut 7050 7051sub version { 7052 return "Math::Matrix $VERSION"; 7053} 7054 7055# Internal utility methods. 7056 7057# Compute the sum of all elements using Neumaier's algorithm, an improvement 7058# over Kahan's algorithm. 7059# 7060# See 7061# https://en.wikipedia.org/wiki/Kahan_summation_algorithm#Further_enhancements 7062 7063sub _sum { 7064 my $sum = 0; 7065 my $c = 0; 7066 7067 for (@_) { 7068 my $t = $sum + $_; 7069 if (CORE::abs($sum) >= CORE::abs($_)) { 7070 $c += ($sum - $t) + $_; 7071 } else { 7072 $c += ($_ - $t) + $sum; 7073 } 7074 $sum = $t; 7075 } 7076 7077 return $sum + $c; 7078} 7079 7080# _prod LIST 7081# 7082 7083sub _prod { 7084 my $prod = 1; 7085 $prod *= $_ for @_; 7086 return $prod; 7087} 7088 7089# _mean LIST 7090# 7091# Method for finding the mean. 7092 7093sub _mean { 7094 return 0 unless @_; 7095 _sum(@_) / @_; 7096} 7097 7098# Method used to calculate the length of the hypotenuse of a right-angle 7099# triangle. It is designed to avoid errors arising due to limited-precision 7100# calculations performed on computers. E.g., with double-precision arithmetic: 7101# 7102# sqrt(3e200**2 + 4e200**2) # = Inf, due to overflow 7103# _hypot(3e200, 4e200) # = 5e200, which is correct 7104# 7105# sqrt(3e-200**2 + 4e-200**2) # = 0, due to underflow 7106# _hypot(3e-200, 4e-200) # = 5e-200, which is correct 7107# 7108# See https://en.wikipedia.org/wiki/Hypot 7109 7110sub _hypot { 7111 my @x = map { CORE::abs($_) } @_; 7112 7113 # Compute the maximum value. 7114 7115 my $max = _max(@x); 7116 return 0 if $max == 0; 7117 7118 # Scale and square the values. 7119 7120 for (@x) { 7121 $_ /= $max; 7122 $_ *= $_; 7123 } 7124 7125 $max * sqrt(_sum(@x)) 7126} 7127 7128# _sumsq LIST 7129# 7130# Sum of squared absolute values. 7131 7132sub _sumsq { 7133 _sum(map { $_ * $_ } map { CORE::abs($_) } @_); 7134} 7135 7136# _vecnorm P, LIST 7137# 7138# Vector P-norm. If the input is $x[0], $x[1], ..., then the output is 7139# 7140# (abs($x[0])**$p + abs($x[1])**$p + ...)**(1/$p) 7141 7142sub _vecnorm { 7143 my $p = shift; 7144 my @x = map { CORE::abs($_) } @_; 7145 7146 return _sum(@x) if $p == 1; 7147 7148 require Math::Trig; 7149 my $inf = Math::Trig::Inf(); 7150 7151 return _max(@x) if $p == $inf; 7152 7153 # Compute the maximum value. 7154 7155 my $max = 0; 7156 for (@x) { 7157 $max = $_ if $_ > $max; 7158 } 7159 7160 # Scale and apply power function. 7161 7162 for (@x) { 7163 $_ /= $max; 7164 $_ **= $p; 7165 } 7166 7167 $max * _sum(@x) ** (1/$p); 7168} 7169 7170# _min LIST 7171# 7172# Minimum value. 7173 7174sub _min { 7175 my $min = shift; 7176 for (@_) { 7177 $min = $_ if $_ < $min; 7178 } 7179 7180 return $min; 7181} 7182 7183# _max LIST 7184# 7185# Maximum value. 7186 7187sub _max { 7188 my $max = shift; 7189 for (@_) { 7190 $max = $_ if $_ > $max; 7191 } 7192 7193 return $max; 7194} 7195 7196# _median LIST 7197# 7198# Method for finding the median. 7199 7200sub _median { 7201 my @x = sort { $a <=> $b } @_; 7202 if (@x % 2) { 7203 $x[$#x / 2]; 7204 } else { 7205 ($x[@x / 2] + $x[@x / 2 - 1]) / 2; 7206 } 7207} 7208 7209# _any LIST 7210# 7211# Method that returns 1 if at least one value in LIST is non-zero and 0 7212# otherwise. 7213 7214sub _any { 7215 for (@_) { 7216 return 1 if $_ != 0; 7217 } 7218 return 0; 7219} 7220 7221# _all LIST 7222# 7223# Method that returns 1 if all values in LIST are non-zero and 0 otherwise. 7224 7225sub _all { 7226 for (@_) { 7227 return 0 if $_ == 0; 7228 } 7229 return 1; 7230} 7231 7232# _cumsum LIST 7233# 7234# Cumulative sum. If the input is $x[0], $x[1], ..., then output element $y[$i] 7235# is the sum of the elements $x[0], $x[1], ..., $x[$i]. 7236 7237sub _cumsum { 7238 my @sum = (); 7239 7240 my $sum = 0; 7241 my $c = 0; 7242 7243 for (@_) { 7244 my $t = $sum + $_; 7245 if (CORE::abs($sum) >= CORE::abs($_)) { 7246 $c += ($sum - $t) + $_; 7247 } else { 7248 $c += ($_ - $t) + $sum; 7249 } 7250 $sum = $t; 7251 push @sum, $sum + $c; 7252 } 7253 7254 return @sum; 7255} 7256 7257# _cumprod LIST 7258# 7259# Cumulative product. If the input is $x[0], $x[1], ..., then output element 7260# $y[$i] is the product of the elements $x[0], $x[1], ..., $x[$i]. 7261 7262sub _cumprod { 7263 my @prod = shift; 7264 push @prod, $prod[-1] * $_ for @_; 7265 return @prod; 7266} 7267 7268# _cummean LIST 7269# 7270# Cumulative mean. If the input is $x[0], $x[1], ..., then output element $y[$i] 7271# is the mean of the elements $x[0], $x[1], ..., $x[$i]. 7272 7273sub _cummean { 7274 my @mean = (); 7275 my $sum = 0; 7276 for my $i (0 .. $#_) { 7277 $sum += $_[$i]; 7278 push @mean, $sum / ($i + 1); 7279 } 7280 return @mean; 7281} 7282 7283# _cummean LIST 7284# 7285# Cumulative minimum. If the input is $x[0], $x[1], ..., then output element 7286# $y[$i] is the minimum of the elements $x[0], $x[1], ..., $x[$i]. 7287 7288sub _cummin { 7289 my @min = shift; 7290 for (@_) { 7291 push @min, $min[-1] < $_ ? $min[-1] : $_; 7292 } 7293 return @min; 7294} 7295 7296# _cummax LIST 7297# 7298# Cumulative maximum. If the input is $x[0], $x[1], ..., then output element 7299# $y[$i] is the maximum of the elements $x[0], $x[1], ..., $x[$i]. 7300 7301sub _cummax { 7302 my @max = shift; 7303 for (@_) { 7304 push @max, $max[-1] > $_ ? $max[-1] : $_; 7305 } 7306 return @max; 7307} 7308 7309# _cumany LIST 7310# 7311# Cumulative any. If the input is $x[0], $x[1], ..., then output element $y[$i] 7312# is 1 if at least one of the elements $x[0], $x[1], ..., $x[$i] is non-zero, 7313# and 0 otherwise. 7314 7315sub _cumany { 7316 my @any = (); 7317 for (@_) { 7318 if ($_ != 0) { 7319 push @any, (1) x (@_ - @any); 7320 last; 7321 } 7322 push @any, 0; 7323 } 7324 return @any; 7325} 7326 7327# _cumall LIST 7328# 7329# Cumulative all. If the input is $x[0], $x[1], ..., then output element $y[$i] 7330# is 1 if all of the elements $x[0], $x[1], ..., $x[$i] are non-zero, and 0 7331# otherwise. 7332 7333sub _cumall { 7334 my @all = (); 7335 for (@_) { 7336 if ($_ == 0) { 7337 push @all, (0) x (@_ - @all); 7338 last; 7339 } 7340 push @all, 1; 7341 } 7342 return @all; 7343} 7344 7345# _diff LIST 7346# 7347# Difference. If the input is $x[0], $x[1], ..., then output element $y[$i] = 7348# $x[$i+1] - $x[$i]. 7349 7350sub _diff { 7351 my @diff = (); 7352 for my $i (1 .. $#_) { 7353 push @diff, $_[$i] - $_[$i - 1]; 7354 } 7355 return @diff; 7356} 7357 7358=pod 7359 7360=back 7361 7362=head1 OVERLOADING 7363 7364The following operators are overloaded. 7365 7366=over 4 7367 7368=item C<+> and C<+=> 7369 7370Matrix or scalar addition. Unless one or both of the operands is a scalar, both 7371operands must have the same size. 7372 7373 $C = $A + $B; # assign $A + $B to $C 7374 $A += $B; # assign $A + $B to $A 7375 7376Note that 7377 7378=item C<-> and C<-=> 7379 7380Matrix or scalar subtraction. Unless one or both of the operands is a scalar, 7381both operands must have the same size. 7382 7383 $C = $A + $B; # assign $A - $B to $C 7384 $A += $B; # assign $A - $B to $A 7385 7386=item C<*> and C<*=> 7387 7388Matrix or scalar multiplication. Unless one or both of the operands is a scalar, 7389the number of columns in the first operand must be equal to the number of rows 7390in the second operand. 7391 7392 $C = $A * $B; # assign $A * $B to $C 7393 $A *= $B; # assign $A * $B to $A 7394 7395=item C<**> and C<**=> 7396 7397Matrix power. The second operand must be a scalar. 7398 7399 $C = $A * $B; # assign $A ** $B to $C 7400 $A *= $B; # assign $A ** $B to $A 7401 7402=item C<==> 7403 7404Equal to. 7405 7406 $A == $B; # is $A equal to $B? 7407 7408=item C<!=> 7409 7410Not equal to. 7411 7412 $A != $B; # is $A not equal to $B? 7413 7414=item C<neg> 7415 7416Negation. 7417 7418 $B = -$A; # $B is the negative of $A 7419 7420=item C<~> 7421 7422Transpose. 7423 7424 $B = ~$A; # $B is the transpose of $A 7425 7426=item C<abs> 7427 7428Absolute value. 7429 7430 $B = abs $A; # $B contains absolute values of $A 7431 7432=item C<int> 7433 7434Truncate to integer. 7435 7436 $B = int $A; # $B contains only integers 7437 7438=back 7439 7440=head1 IMPROVING THE SOLUTION OF LINEAR SYSTEMS 7441 7442The methods that do an explicit or implicit matrix left division accept some 7443additional parameters. If these parameters are specified, the matrix left 7444division is done repeatedly in an iterative way, which often gives a better 7445solution. 7446 7447=head2 Background 7448 7449The linear system of equations 7450 7451 $A * $x = $y 7452 7453can be solved for C<$x> with 7454 7455 $x = $y -> mldiv($A); 7456 7457Ideally C<$A * $x> should equal C<$y>, but due to numerical errors, this is not 7458always the case. The following illustrates how to improve the solution C<$x> 7459computed above: 7460 7461 $r = $A -> mmuladd($x, -$y); # compute the residual $A*$x-$y 7462 $d = $r -> mldiv($A); # compute the delta for $x 7463 $x -= $d; # improve the solution $x 7464 7465This procedure is repeated, and at each step, the absolute error 7466 7467 ||$A*$x - $y|| = ||$r|| 7468 7469and the relative error 7470 7471 ||$A*$x - $y|| / ||$y|| = ||$r|| / ||$y|| 7472 7473are computed and compared to the tolerances. Once one of the stopping criteria 7474is satisfied, the algorithm terminates. 7475 7476=head2 Stopping criteria 7477 7478The algorithm stops when at least one of the errors are within the specified 7479tolerances or the maximum number of iterations is reached. If the maximum number 7480of iterations is reached, but noen of the errors are within the tolerances, a 7481warning is displayed and the best solution so far is returned. 7482 7483=head2 Parameters 7484 7485=over 4 7486 7487=item MaxIter 7488 7489The maximum number of iterations to perform. The value must be a positive 7490integer. The default is 20. 7491 7492=item RelTol 7493 7494The limit for the relative error. The value must be a non-negative. The default 7495value is 1e-19 when perl is compiled with long doubles or quadruple precision, 7496and 1e-9 otherwise. 7497 7498=item AbsTol 7499 7500The limit for the absolute error. The value must be a non-negative. The default 7501value is 0. 7502 7503=item Debug 7504 7505If this parameter does not affect when the algorithm terminates, but when set to 7506non-zero, some information is displayed at each step. 7507 7508=back 7509 7510=head2 Example 7511 7512If 7513 7514 $A = [[ 8, -8, -5, 6, -1, 3 ], 7515 [ -7, -1, 5, -9, 5, 6 ], 7516 [ -7, 8, 9, -2, -4, 3 ], 7517 [ 3, -4, 5, 5, 3, 3 ], 7518 [ 9, 8, -3, -4, 1, 6 ], 7519 [ -8, 9, -1, 3, 5, 2 ]]; 7520 7521 $y = [[ 80, -13 ], 7522 [ -2, 104 ], 7523 [ -57, -27 ], 7524 [ 47, -28 ], 7525 [ 5, 77 ], 7526 [ 91, 133 ]]; 7527 7528the result of C<< $x = $y -> mldiv($A); >>, using double precision arithmetic, 7529is the approximate solution 7530 7531 $x = [[ -2.999999999999998, -5.000000000000000 ], 7532 [ -1.000000000000000, 3.000000000000001 ], 7533 [ -5.999999999999997, -8.999999999999996 ], 7534 [ 8.000000000000000, -2.000000000000003 ], 7535 [ 6.000000000000003, 9.000000000000002 ], 7536 [ 7.999999999999997, 8.999999999999995 ]]; 7537 7538The residual C<< $res = $A -> mmuladd($x, -$y); >> is 7539 7540 $res = [[ 1.24344978758018e-14, 1.77635683940025e-15 ], 7541 [ 8.88178419700125e-15, -5.32907051820075e-15 ], 7542 [ -1.24344978758018e-14, 1.77635683940025e-15 ], 7543 [ -7.10542735760100e-15, -4.08562073062058e-14 ], 7544 [ -1.77635683940025e-14, -3.81916720471054e-14 ], 7545 [ 1.24344978758018e-14, 8.43769498715119e-15 ]]; 7546 7547and the delta C<< $dx = $res -> mldiv($A); >> is 7548 7549 $dx = [[ -8.592098303124e-16, -2.86724066474914e-15 ], 7550 [ -7.92220125658508e-16, -2.99693950082398e-15 ], 7551 [ -2.22533360993874e-16, 3.03465504177947e-16 ], 7552 [ 6.47376093198353e-17, -1.12378127899388e-15 ], 7553 [ 6.35204502123966e-16, 2.40938179521241e-15 ], 7554 [ 1.55166908001001e-15, 2.08339859425849e-15 ]]; 7555 7556giving the improved, and in this case exact, solution C<< $x -= $dx; >>, 7557 7558 $x = [[ -3, -5 ], 7559 [ -1, 3 ], 7560 [ -6, -9 ], 7561 [ 8, -2 ], 7562 [ 6, 9 ], 7563 [ 8, 9 ]]; 7564 7565=head1 SUBCLASSING 7566 7567The methods should work fine with any kind of numerical objects, provided that 7568the assignment operator C<=> is overloaded, so that Perl knows how to create a 7569copy. 7570 7571You can check the behaviour of the assignment operator by assigning a value to a 7572new variable, modify the new variable, and check whether this also modifies the 7573original value. Here is an example: 7574 7575 $x = Some::Class -> new(0); # create object $x 7576 $y = $x; # create new variable $y 7577 $y++; # modify $y 7578 print "it's a clone\n" if $x != $y; # is $x modified? 7579 7580The subclass might need to implement some methods of its own. For instance, if 7581each element is a complex number, a transpose() method needs to be implemented 7582to take the complex conjugate of each value. An as_string() method might also be 7583useful for displaying the matrix in a format more suitable for the subclass. 7584 7585Here is an example showing Math::Matrix::Complex, a fully-working subclass of 7586Math::Matrix, where each element is a Math::Complex object. 7587 7588 use strict; 7589 use warnings; 7590 7591 package Math::Matrix::Complex; 7592 7593 use Math::Matrix; 7594 use Scalar::Util 'blessed'; 7595 use Math::Complex 1.57; # "=" didn't clone before 1.57 7596 7597 our @ISA = ('Math::Matrix'); 7598 7599 # We need a new() method to make sure every element is an object. 7600 7601 sub new { 7602 my $self = shift; 7603 my $x = $self -> SUPER::new(@_); 7604 7605 my $sub = sub { 7606 defined(blessed($_[0])) && $_[0] -> isa('Math::Complex') 7607 ? $_[0] 7608 : Math::Complex -> new($_[0]); 7609 }; 7610 7611 return $x -> sapply($sub); 7612 } 7613 7614 # We need a transpose() method, since the transpose of a matrix 7615 # with complex numbers also takes the conjugate of all elements. 7616 7617 sub transpose { 7618 my $x = shift; 7619 my $y = $x -> SUPER::transpose(@_); 7620 7621 return $y -> sapply(sub { ~$_[0] }); 7622 } 7623 7624 # We need an as_string() method, since our parent's methods 7625 # doesn't format complex numbers correctly. 7626 7627 sub as_string { 7628 my $self = shift; 7629 my $out = ""; 7630 for my $row (@$self) { 7631 for my $elm (@$row) { 7632 $out = $out . sprintf "%10s ", $elm; 7633 } 7634 $out = $out . sprintf "\n"; 7635 } 7636 $out; 7637 } 7638 7639 1; 7640 7641=head1 BUGS 7642 7643Please report any bugs or feature requests via 7644L<https://github.com/pjacklam/p5-Math-Matrix/issues>. 7645 7646Old bug reports and feature requests can be found at 7647L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Math-Matrix>. 7648 7649=head1 SUPPORT 7650 7651You can find documentation for this module with the perldoc command. 7652 7653 perldoc Math::Matrix 7654 7655You can also look for information at: 7656 7657=over 4 7658 7659=item * GitHub Source Repository 7660 7661L<https://github.com/pjacklam/p5-Math-Matrix> 7662 7663=item * MetaCPAN 7664 7665L<https://metacpan.org/release/Math-Matrix> 7666 7667=item * CPAN Ratings 7668 7669L<http://cpanratings.perl.org/d/Math-Matrix> 7670 7671=item * CPAN Testers PASS Matrix 7672 7673L<http://pass.cpantesters.org/distro/A/Math-Matrix.html> 7674 7675=item * CPAN Testers Reports 7676 7677L<http://www.cpantesters.org/distro/A/Math-Matrix.html> 7678 7679=item * CPAN Testers Matrix 7680 7681L<http://matrix.cpantesters.org/?dist=Math-Matrix> 7682 7683=back 7684 7685=head1 LICENSE AND COPYRIGHT 7686 7687Copyright (c) 2020-2021, Peter John Acklam 7688 7689Copyright (C) 2013, John M. Gamble <jgamble@ripco.com>, all rights reserved. 7690 7691Copyright (C) 2009, oshalla 7692https://rt.cpan.org/Public/Bug/Display.html?id=42919 7693 7694Copyright (C) 2002, Bill Denney <gte273i@prism.gatech.edu>, all rights 7695reserved. 7696 7697Copyright (C) 2001, Brian J. Watson <bjbrew@power.net>, all rights reserved. 7698 7699Copyright (C) 2001, Ulrich Pfeifer <pfeifer@wait.de>, all rights reserved. 7700Copyright (C) 1995, Universität Dortmund, all rights reserved. 7701 7702Copyright (C) 2001, Matthew Brett <matthew.brett@mrc-cbu.cam.ac.uk> 7703 7704This program is free software; you may redistribute it and/or modify it under 7705the same terms as Perl itself. 7706 7707=head1 AUTHORS 7708 7709Peter John Acklam E<lt>pjacklam@gmail.comE<gt> (2020-2021) 7710 7711Ulrich Pfeifer E<lt>pfeifer@ls6.informatik.uni-dortmund.deE<gt> (1995-2013) 7712 7713Brian J. Watson E<lt>bjbrew@power.netE<gt> 7714 7715Matthew Brett E<lt>matthew.brett@mrc-cbu.cam.ac.ukE<gt> 7716 7717=cut 7718 77191; 7720