.packageName <- "matrixcalc"
commutation.matrix <- function( m, n )
{
###
### this function returns a square matrix with p = m * n rows and columns
###
### Parameters
### m = integer rows
### n = integer columns
###
    if ( m <= 0 )
        stop( "argument m is not positive" )
    if ( m != trunc( m ) )
        stop( "argument m is not an integer" )
    if ( n <= 0 )
        stop( "argument n is not positive" )
    if ( n != trunc( n ) )
        stop( "argument b is not an integer" )
    p <- m * n
    C <- matrix( 0, nrow=p, ncol=p )
    r <- 0
    for ( i in 1:m ) {
        c <- i
        for ( j in 1:n ) {
            r <- r + 1
            C[r,c] <- 1
            c <- c + m
        }
    }
    return( C )
}
duplication.matrix <- function( n )
{
###
### this function returns a matrix sith n * n rows and n * (n + 1 ) / 2
### columns that transforms vech( A ) to vec( A ) where A is a symmetric n by n matrix
###
### Parameter
### n = the order of the matrix
###
    if ( n <= 0 )
        stop( "argument n is not positive" )
    if ( n != trunc( n ) )
        stop( "argument n is not an integer" )
    A <- matrix( 0, nrow=n, ncol=n )
    for ( i in 1:n )
        for ( j in 1:n )
            A[i,j] <- i + j
    vechA <- vech( A )
    vecA <- vec( A )
    p <- n * n
    q <- n * ( n + 1 ) / 2
    D <- matrix( 0, nrow=p, ncol=q )
    for ( i in 1:p ) {
        value.set <- FALSE
        for ( j in 1:q ) {
            if ( !value.set ) {
                D[i,j] <- as.numeric( vecA[i,1] == vechA[j,1] )
                if ( D[i,j] == 1 )
                    value.set <- TRUE
            }    
        }
    }  
    return( D )
}
elimination.matrix <- function( n )
{
###
### this function returns a matrix sith n * n comuns and n * (n + 1 ) / 2
### rows that transforms vec( A ) to vech( A ) where A is a symmetric n by n matrix
###
### Parameter
### n = the order of the matrix
###
    if ( n <= 0 )
        stop( "argument n is not positive" )
    if ( n != trunc( n ) )
        stop( "argument n is not an integer" )
    A <- matrix( 0, nrow=n, ncol=n )
    for ( i in 1:n )
        for ( j in 1:n )
            A[i,j] <- i + j
    vechA <- vech( A )
    vecA <- vec( A )
    q <- n * n
    p <- n * ( n + 1 ) / 2
    D <- matrix( 0, nrow=p, ncol=q )
    for ( i in 1:p ) {
        value.set <- FALSE
        for ( j in 1:q ) {
            if ( !value.set ) {
                D[i,j] <- as.numeric( vecA[j,1] == vechA[i,1] )
                if ( D[i,j] == 1 )
                    value.set <- TRUE
            }    
        }
    }  
    return( D )
}
frobenius.prod <- function( x, y )
{
###
### this function calculates the Frobenius inner product product of two matrices x and y.
### the matrices must the same row and column order
###
### Parameters
### x = a numeric matrix object
### y = a numeric matrix object
###
    return( sum( hadamard.prod(x, y) ) )
}
hadamard.prod <- function( x, y )
{
###
### this function calculates the Hadamard product of two matrices x and y.
### the matrices must the same row and column order
###
### Parameters
### x = a numeric matrix object
### y = a numeric matrix object
###
    if ( !is.numeric.matrix( x ) )
        stop( "argument x is not a numeric matrix" )
    if ( !is.numeric.matrix( y ) )
        stop( "argument y is not a numeric matrix" )
    if ( nrow( x ) != nrow( y ) )
        stop( "argumentx x and y do not have the same row order" )
    if ( ncol( x ) != ncol( y ) )
        stop( "arguments x and y do not have the same column order" )
    return( x * y )
}
hilbert.matrix <- function(n) 
{   
###
### this function returns an n by n Hilbert matrix
###
### Parameter
### n = the row (column) dimension of the matrix
###
    if ( n <= 0 )
        stop( "argument n is not positive" )
    if ( n != trunc( n ) )
        stop( "argument n is not an integer" )
    i <- 1:n
    X <- 1 / outer(i - 1, i, "+")
    return( X  )
}
inverse <- function( x )
{
###
### this function returns the inverse of a square matrix
###
### Parameters
### x = a square numeric matrix
###
    if ( !is.square.matrix( x ) )
        stop( "argument x is not a square matrix" )
    return( solve( x ) )
}
is.numeric.matrix <- function( x )
{
###
### this function determines if the argument is a matrix object with numerical values
###
### Parameter
### x = an R object
###
    if ( !is.matrix( x ) )
        return( FALSE )
    if ( !is.numeric( x ) )
        return( FALSE )
    return( TRUE )
}
is.positive.definite <- function( x, tol, method = c("eigen","chol" ) )
{
###
### this function determines if the given matrix is positive definite
###
### parameters
### x = a square numeric matrix object
###
    if ( !is.square.matrix( x ) )
        stop( "argument x is not a square matrix" )
    method <- match.arg(method)
    if (method == "eigen") {
        eval <- eigen(x, only.values = TRUE)$values
        if( missing(tol) ) {
            tol <- max(dim(x)) * max( abs(eval) ) *.Machine$double.eps
        }
        if (sum(eval > tol) == length(eval)) {
            return(TRUE)
        } else {
            return(FALSE)
        }
    } 
    else if (method == "chol") {
        val = try(chol(x), silent = TRUE)
        if (class(val) == "try-error") {
            return(FALSE)
        }
        else {
            return(TRUE)  
        }  
    }
}
is.square.matrix <- function( x )
{
###
### determines if the given matrix is a square matrix
###
### arguments
### x = a matrix object
###
    if ( !is.matrix( x ) )
        stop( "argument x is not a matrix" )
    return( nrow(x) == ncol(x) )
}
is.symmetric.matrix <- function( x )
{
###
### this function determines if the matrix is symmetric
###
### argument
### x = a numeric matrix object
###
    if ( !is.numeric.matrix( x ) )
        stop( "argument x is not a numeric matrix" )
    if ( !is.square.matrix( x ) )
        stop( "argument x is not a square numeric matrix" )
    return( sum( x == t(x) ) == ( nrow(x) ^ 2 ) )
}
lower.triangle <- function( x )
{
###
### this function returns the lower triangular matrix portion of matrix x
###
### Parameters
### x = a numeric matrix
###
    if ( !is.square.matrix( x ) )
        stop( "argument x is not a square numeric matrix" )
    y <- x
    y[row(x) < col(y)] <- 0
    return( y )
}
matrix.rank <- function ( x, method=c("qr", "chol" ) )
{
###
### this function returns the rank of a square matrix based on the selected method
###
### Parameter
### x = a square numeric matrix
### method = a character string that defines the method
###
    if ( !is.square.matrix( x ) )
        stop( "argument x is not a square matrix" )
    method = method[1]
    if (method == "chol") {
        ans = attr(chol(x, pivot = TRUE), "rank") 
    } else {
        ans = qr(x)$rank 
    }
    
    # Return Value:
    return( ans  )
}
matrix.trace <- function( x )
{
###
### this function returns the trace of the given square matrix
###
### parameters
### x = a numeric square matrix object
###
    if ( !is.square.matrix( x ) )
        stop( "argument x is not a square matrix" )
    return( sum( diag( x ) ) )
}
pascal.matrix <- function( n )
{
###
### this function returns an n by n Pascal matrix
###
### Parameter
### n = the row( column ) dimension of the matrix
###
    if ( n <= 0 )
        stop( "argument n is not positive" )
    if ( n != trunc( n ) )
        stop( "argument n is not an integer" )
    nm1 = n-1
    n.over.r <- function(n, r) { prod(1:n) / (prod(1:(n-r)) * prod(1:r) ) }
    X <- rep(1, nm1)
    for ( i in 1:nm1 )
        for ( j in 1:nm1 )
            X <- c(X, n.over.r(i+j, j))
    X <- cbind(rep(1, nm1+1), matrix(X, byrow = TRUE, ncol = nm1))
    return( X  )
}
set.submatrix <- function( x, y, row, col )
{
###
### Returns a matrix where y has been inserted into x at the given row and column
###
### Arguments
### x = a matrix object
### y = a matrix object
### row = an integer row number
### col = an integer column number
###
    if ( !is.numeric.matrix( x ) )
        stop( "argument x is not a numeric matrix" )
    if ( !is.numeric.matrix( y ) )
        stop( "argument y is not a numeric matrix" )
    if ( row <= 0 )
        stop( "argument row is not positive" )
    if ( row != trunc( row ) )
        stop( "argument row is not an integer" )
    if ( col <= 0 )
        stop( "argument col is not positive" )
    if ( col != trunc( col ) )
        stop( "argument col is not an integer" )
    row.range <- row:(row+nrow(y)-1)
    col.range <- col:(col+ncol(y)-1)
    x.row.range <- 1:nrow(x)
    x.col.range <- 1:ncol(x)
    if ( sum( row.range %in% x.row.range ) != length(row.range) )
        stop( "row range not inside row of argument x" )
    if ( sum( col.range %in% x.col.range ) != length(col.range) )
        stop( "col range not inside the column of argument x" )
    z <- x
    z[row.range,col.range] <- y
    return( z )
}
shift.down <- function( A, rows = 1, fill = 0 )
{
###
### this function returns a matrix that has been shifted down m rows
### filling the previous rows with the given fill value
###
### Arguments
### A = a numerical matrix
### rows = number of rows to be shifed downwards
### fill = a numeric value to be used to fill the rows
###
    if ( !is.numeric.matrix( A ) )
        stop( "Argument A is not a numeric matrix" )
    if ( rows < 0 )
        stop( "Argument rows is not positive" )
    if ( rows != trunc( rows ) )
        stop( "Arguments rows is not an integer" )
    if ( !is.numeric( fill ) )
        stop( "Argument fill is not numeric" )
    if ( rows > 0 )
        return( shift.down( rbind( rep( fill, ncol(A) ), A[1:nrow(A)-1,] ),
                rows - 1, fill ) )
    return( A )    
}
shift.left <- function( A, cols = 1, fill = 0 )
{
###
### this function returns a matrix that has been shifted left m cols
### filling the subsequent columns with the given fill value
###
### Arguments
### A = a numerical matrix
### cols = number of cols to be shifed to the left
### fill = a numeric value to be used to fill the cols
###
    if ( !is.numeric.matrix( A ) )
        stop( "Argument A is not a numeric matrix" )
    if ( cols != trunc( cols ) )
        stop( "Arguments cols is not an integer" )
    if ( cols < 0 )
        stop( "Argument cols is not positive" )
    if ( !is.numeric( fill ) )
        stop( "Argument fill is not numeric" )
    if ( cols > 0 )
        return( shift.left( cbind( A[,2:ncol(A)], rep( fill, nrow(A) ) ),
                cols - 1, fill ) )
    return( A )    
}
shift.right <- function( A, cols = 1, fill = 0 )
{
###
### this function returns a matrix that has been shifted to the right m columns
### filling the previous columns with the given fill value
###
### Arguments
### A = a numerical matrix
### cols = number of cols to be shifed to the right
### fill = a numeric value to be used to fill the cols
###
    if ( !is.numeric.matrix( A ) )
        stop( "Argument A is not a numeric matrix" )
    if ( cols < 0 )
        stop( "Argument cols is not positive" )
    if ( cols != trunc( cols ) )
        stop( "Arguments cols is not an integer" )
    if ( !is.numeric( fill ) )
        stop( "Argument fill is not numeric" )
    if ( cols > 0 )
        return( shift.right( cbind( rep( fill, nrow(A) ), A[,1:ncol(A)-1] ),
                cols - 1, fill ) )
    return( A )    
}
shift.up <- function( A, rows = 1, fill = 0 )
{
###
### this function returns a matrix that has been shifted up m rows
### filling the previous rows with the given fill value
###
### Arguments
### A = a numerical matrix
### rows = number of rows to be shifed upwards
### fill = a numeric value to be used to fill the rows
###
    if ( !is.numeric.matrix( A ) )
        stop( "Argument A is not a numeric matrix" )
    if ( rows != trunc( rows ) )
        stop( "Arguments rows is not an integer" )
    if ( rows < 0 )
        stop( "Argument rows is not positive" )
    if ( !is.numeric( fill ) )
        stop( "Argument fill is not numeric" )
    if ( rows > 0 )
        return( shift.up( rbind( A[2:nrow(A),], rep( fill, ncol(A) ) ),
                rows - 1, fill ) )
    return( A )    
}
upper.triangle <- function( x )
{
###
### this function returns the lower triangular matrix portion of matrix x
###
### Parameters
### x = a numeric matrix
###
    if ( !is.square.matrix( x ) )
        stop( "argument x is not a square numeric matrix" )
    y <- x
    y[row(x) > col(y)] <- 0
    return( y )
}
vandermonde.matrix <- function( alpha, n )
{
###
### this function returns an m by n matrix of the powers of the alpha vector
###
### Parameters
### alpha = an m dimensional vector
### n = an integer
###
    if ( !is.vector( alpha ) )
        stop( "argument alpha is not a vector" )
    if ( !is.numeric( alpha ) )
        stop( "argument n is not a numeric vector" )
    m <- length( alpha )
    V <- matrix( 0, nrow=m, ncol=n )
    V[,1] <- rep( 1, m )
    j <- 2
    while ( j <= n ) {
       x <- alpha ^ ( j - 1 )
       V[,j] <- x
       j <- j + 1
   }
   return( V )
}
vec <- function( x )
{
###
### this function returns a column vector that is a stack of the columns of x
###
### Parameters
### x = a numeric matrix
###
    if ( !is.numeric.matrix( x ) )
        stop( "argument x is not a numeric matrix" )
    return( t( t( as.vector( x ) ) ) )
}
vech <- function( x )
{
###
### returns a stack of the lower triangular matrix as a matrix with 1 column
###
### Parameters
### x = a numeric matrix square matrix
###
    if ( !is.square.matrix( x ) )
        stop( "argument x is not a square numeric matrix" )
    return( t( t( x[!upper.tri(x)] ) ) )
}
