void
gslu_rand_gaussian_matrix (const gsl_rng *r, gsl_matrix *A,
const gsl_vector *mu, const gsl_matrix *Sigma, const gsl_matrix *L)
{
assert (A->size1 == mu->size && (Sigma || L));
for (size_t i=0; i<A->size1; i++)
for (size_t j=0; j<A->size2; j++)
gsl_matrix_set (A, i, j, gsl_ran_gaussian_ziggurat (r, 1.0));
if (L) {
assert (L->size1 == L->size2 && L->size1 == mu->size);
gsl_blas_dtrmm (CblasLeft, CblasLower, CblasNoTrans, CblasNonUnit, 1.0, L, A);
}
else {
assert (Sigma->size1 == Sigma->size2 && Sigma->size1 == mu->size);
gsl_matrix *_L = gsl_matrix_alloc (Sigma->size1, Sigma->size2);
gsl_matrix_memcpy (_L, Sigma);
gsl_linalg_cholesky_decomp (_L);
gsl_blas_dtrmm (CblasLeft, CblasLower, CblasNoTrans, CblasNonUnit, 1.0, _L, A);
gsl_matrix_free (_L);
}
for (size_t j=0; j<A->size2; j++) {
gsl_vector_view a = gsl_matrix_column (A, j);
gsl_vector_add (&a.vector, mu);
}
}
//Wishart distribution random number generator
int ran_wishart(const gsl_rng *r, const double nu,
const gsl_matrix *V, gsl_matrix *X)
{
const int k = V->size1;
int i, j;
gsl_matrix *A = gsl_matrix_calloc(k, k);
gsl_matrix *L = gsl_matrix_alloc(k, k);
for(i=0; i<k; i++)
{
gsl_matrix_set(A, i, i, sqrt(gsl_ran_chisq(r, (nu-i))));
for (j=0; j<i; j++){
gsl_matrix_set(A, i, j, gsl_ran_gaussian(r, 1));
}
}
gsl_matrix_memcpy(L, V);
gsl_linalg_cholesky_decomp(L);
gsl_blas_dtrmm(CblasLeft, CblasLower, CblasNoTrans, CblasNonUnit, 1.0, L, A);
gsl_blas_dgemm(CblasNoTrans, CblasTrans, 1.0, A, A, 0.0, X);
gsl_matrix_free(A);
gsl_matrix_free(L);
return 0;
}
int rwishart(const gsl_rng *r, const unsigned int n, const unsigned int dof, const gsl_matrix *scale, gsl_matrix *result)
{
unsigned int k,l;
gsl_matrix *work = gsl_matrix_calloc(n,n);
for(k=0; k<n; k++){
gsl_matrix_set( work, k, k, sqrt( gsl_ran_chisq( r, (dof-k) ) ) );
for(l=0; l<k; l++)
gsl_matrix_set( work, k, l, gsl_ran_ugaussian(r) );
}
gsl_matrix_memcpy(result,scale);
gsl_linalg_cholesky_decomp(result);
gsl_blas_dtrmm(CblasLeft,CblasLower,CblasNoTrans,CblasNonUnit,1.0,result,work);
gsl_blas_dsyrk(CblasUpper,CblasNoTrans,1.0,work,0.0,result);
return 0;
}
void GenerateRandMVnorm(gsl_rng * r, const size_t numSamples, const double * mu, const gsl_matrix *sigChol, const size_t NumParam, gsl_matrix * returnSamples)
{
// generate standard normal random samples
for(size_t i = 0; i < numSamples; i++)
for(size_t j = 0; j < NumParam; j++)
gsl_matrix_set(returnSamples, i, j, gsl_ran_gaussian(r, 1.0));
gsl_blas_dtrmm(CblasRight, CblasLower, CblasTrans, CblasNonUnit, 1.0, sigChol, returnSamples); // matrix multiplcation stdNormSamples %*% sigChol, for upper triangular matrix
// add mu to each row
gsl_vector_const_view vecMu = gsl_vector_const_view_array(mu, NumParam);
#pragma omp parallel for
for(size_t i = 0; i < numSamples; i++){
gsl_vector_view tmpRow = gsl_matrix_row(returnSamples, i);
gsl_vector_add(&tmpRow.vector, &vecMu.vector);
}
return;
}
static VALUE rb_gsl_blas_dtrmm(VALUE obj, VALUE s, VALUE u, VALUE ta,
VALUE d, VALUE a, VALUE aa, VALUE bb)
{
gsl_matrix *A = NULL, *B = NULL;
double alpha;
CBLAS_SIDE_t Side;
CBLAS_UPLO_t Uplo;
CBLAS_TRANSPOSE_t TransA;
CBLAS_DIAG_t Diag;
CHECK_FIXNUM(s); CHECK_FIXNUM(u); CHECK_FIXNUM(ta); CHECK_FIXNUM(d);
Need_Float(a);
CHECK_MATRIX(aa); CHECK_MATRIX(bb);
Side = FIX2INT(s);
Uplo = FIX2INT(u);
TransA = FIX2INT(ta);
Diag = FIX2INT(d);
alpha = NUM2DBL(a);
Data_Get_Struct(aa, gsl_matrix, A);
Data_Get_Struct(bb, gsl_matrix, B);
gsl_blas_dtrmm(Side, Uplo, TransA, Diag, alpha, A, B);
return bb;
}
static VALUE rb_gsl_blas_dtrmm2(VALUE obj, VALUE s, VALUE u, VALUE ta,
VALUE d, VALUE a, VALUE aa, VALUE bb)
{
gsl_matrix *A = NULL, *B = NULL, *Bnew = NULL;
double alpha;
CBLAS_SIDE_t Side;
CBLAS_UPLO_t Uplo;
CBLAS_TRANSPOSE_t TransA;
CBLAS_DIAG_t Diag;
CHECK_FIXNUM(s); CHECK_FIXNUM(u); CHECK_FIXNUM(ta); CHECK_FIXNUM(d);
Need_Float(a);
CHECK_MATRIX(aa); CHECK_MATRIX(bb);
Side = FIX2INT(s);
Uplo = FIX2INT(u);
TransA = FIX2INT(ta);
Diag = FIX2INT(d);
alpha = NUM2DBL(a);
Data_Get_Struct(aa, gsl_matrix, A);
Data_Get_Struct(bb, gsl_matrix, B);
Bnew = gsl_matrix_alloc(B->size1, B->size2);
gsl_matrix_memcpy(Bnew, B);
gsl_blas_dtrmm(Side, Uplo, TransA, Diag, alpha, A, Bnew);
return Data_Wrap_Struct(cgsl_matrix, 0, gsl_matrix_free, Bnew);
}
static int
my_main (int argc, char **argv)
{
setlocale (LC_ALL, "");
scm_dynwind_begin (0);
CBLAS_SIDE_t Side = side_func (argv[1]);
CBLAS_UPLO_t Uplo = uplo_func (argv[2]);
CBLAS_TRANSPOSE_t TransA = trans_func (argv[3]);
CBLAS_DIAG_t Diag = diag_func (argv[4]);
int m = atoi (argv[5]);
int n = atoi (argv[6]);
mpq_t alpha;
mpq_init (alpha);
scm_dynwind_mpq_clear (alpha);
mpq_set_str (alpha, argv[7], 0);
mpq_canonicalize (alpha);
int k = (Side == CblasLeft) ? m : n;
mpq_t A[k][k];
mpq_matrix_init (k, k, A);
scm_dynwind_mpq_matrix_clear (k, k, A);
mpq_t B[m][n];
mpq_matrix_init (m, n, B);
scm_dynwind_mpq_matrix_clear (m, n, B);
double A1[k][k];
double B1[m][n];
gsl_matrix_view mA1 = gsl_matrix_view_array (&A1[0][0], k, k);
gsl_matrix_view mB1 = gsl_matrix_view_array (&B1[0][0], m, n);
unsigned int i_argv = 8;
for (unsigned int i = 0; i < k; i++)
for (unsigned int j = 0; j < k; j++)
{
mpq_set_str (A[i][j], argv[i_argv], 0);
mpq_canonicalize (A[i][j]);
A1[i][j] = mpq_get_d (A[i][j]);
i_argv++;
}
for (unsigned int i = 0; i < m; i++)
for (unsigned int j = 0; j < n; j++)
{
mpq_set_str (B[i][j], argv[i_argv], 0);
mpq_canonicalize (B[i][j]);
B1[i][j] = mpq_get_d (B[i][j]);
i_argv++;
}
mpq_matrix_trmm (Side, Uplo, TransA, Diag, m, n, alpha, A, B);
gsl_blas_dtrmm (Side, Uplo, TransA, Diag, mpq_get_d (alpha), &mA1.matrix,
&mB1.matrix);
int exit_status = 0;
// Check that we get the same results as gsl_blas_dtrmm.
for (unsigned int i = 0; i < m; i++)
for (unsigned int j = 0; j < n; j++)
{
gmp_printf ("B[%u][%u] = %lf\t%Qd\n", i, j, B1[i][j], B[i][j]);
if (10000 * DBL_EPSILON < fabs (mpq_get_d (B[i][j]) - B1[i][j]))
exit_status = 1;
}
scm_dynwind_end ();
return exit_status;
}
/**
* C++ version of gsl_blas_dtrmm().
* @param Side Side to apply operation to
* @param Uplo Upper or lower triangular
* @param TransA Transpose type
* @param Diag Diagonal type
* @param alpha A constant
* @param A A matrix
* @param B Another matrix
* @return Error code on failure
*/
int dtrmm( CBLAS_SIDE_t Side, CBLAS_UPLO_t Uplo, CBLAS_TRANSPOSE_t TransA,
CBLAS_DIAG_t Diag, double alpha, matrix const& A, matrix& B ){
return gsl_blas_dtrmm( Side, Uplo, TransA, Diag, alpha, A.get(), B.get() ); }
// Wald Test used in both summary and anova (polymophism)
int GlmTest::GeeWald(glm *Alt, gsl_matrix *LL, gsl_vector *teststat)
{
gsl_set_error_handler_off();
unsigned int i, j, l;
double alpha, result, sum=0;
unsigned int nP = Alt->nParams;
unsigned int nDF = LL->size1;
unsigned int nVars=tm->nVars, nRows=tm->nRows;
int status;
gsl_vector *LBeta = gsl_vector_alloc(nVars*nDF);
gsl_vector_set_zero(LBeta);
gsl_matrix *w1jX1=gsl_matrix_alloc(nRows, nP);
gsl_matrix *XwX=gsl_matrix_alloc(nP, nP);
gsl_matrix *Rl2 = gsl_matrix_alloc(nDF, nP);
gsl_matrix *IinvN = gsl_matrix_alloc(nDF, nDF);
gsl_matrix *IinvRl = gsl_matrix_alloc(nVars*nDF, nVars*nDF);
gsl_vector *tmp = gsl_vector_alloc(nVars*nDF);
gsl_vector_view tmp2, wj, LBj, bj; //, dj;
gsl_matrix_view Rl;
gsl_matrix_set_zero(IinvRl);
GrpMat *Z = (GrpMat*)malloc(nVars*sizeof(GrpMat));
for (j=0; j<nVars; j++){
Z[j].matrix = gsl_matrix_alloc(nP, nRows);
// w1jX1 = W^1/2 * X
wj=gsl_matrix_column(Alt->wHalf, j);
for (i=0; i<nP; i++)
gsl_matrix_set_col (w1jX1, i, &wj.vector);
gsl_matrix_mul_elements (w1jX1, Alt->Xref);
// LBeta = L*Beta
LBj=gsl_vector_subvector(LBeta, j*nDF, nDF);
bj=gsl_matrix_column(Alt->Beta, j);
gsl_blas_dgemv(CblasNoTrans,1,LL,&bj.vector,0,&LBj.vector);
// Z = (X^T W X)^-1 * X^T W^1/2.
gsl_matrix_set_identity(XwX);
gsl_blas_dsyrk (CblasLower,CblasTrans,1.0,w1jX1,0.0,XwX);
status=gsl_linalg_cholesky_decomp (XwX);
if (status==GSL_EDOM) {
if (tm->warning==TRUE)
printf("Warning:singular matrix in wald test. An eps*I is added to the singular matrix.\n");
gsl_matrix_set_identity(XwX);
gsl_blas_dsyrk(CblasLower,CblasTrans,1.0,w1jX1,eps,XwX);
gsl_linalg_cholesky_decomp(XwX);
}
gsl_linalg_cholesky_invert(XwX);
gsl_blas_dgemm(CblasNoTrans,CblasTrans,1.0,XwX,w1jX1,0.0, Z[j].matrix);
gsl_matrix_memcpy(Rl2, LL);
gsl_blas_dtrmm (CblasRight,CblasLower,CblasNoTrans,CblasNonUnit,1.0,XwX,Rl2); // L*(X'WX)^-1
gsl_blas_dgemm (CblasNoTrans, CblasTrans, 1.0, Rl2, LL, 0.0, IinvN); // L*(X^T*W*X)^-1*L^T
if ( (tm->punit!=NONE) || (tm->corr==IDENTITY) ) {
status=gsl_linalg_cholesky_decomp (IinvN);
if (status==GSL_EDOM) {
if (tm->warning==TRUE)
printf("Warning:singular IinvN in wald test.\n");
}
tmp2=gsl_vector_subvector(tmp, 0, nDF);
gsl_linalg_cholesky_solve (IinvN, &LBj.vector, &tmp2.vector);
gsl_blas_ddot (&LBj.vector, &tmp2.vector, &result);
gsl_vector_set(teststat, j+1, sqrt(result));
sum = sum + result;
}
if (tm->corr!=IDENTITY) {
// IinvRl=L*vSandRl*L^T
for (l=0; l<=j; l++) {
Rl=gsl_matrix_submatrix(IinvRl,j*nDF,l*nDF,nDF,nDF);
alpha = gsl_matrix_get(Rlambda, j, l);
// borrow XwX space to store vSandRl
gsl_blas_dgemm(CblasNoTrans,CblasTrans,alpha,Z[j].matrix,Z[l].matrix, 0.0, XwX);
// Rl2 = L*vSandRl*L^T
gsl_blas_dgemm(CblasNoTrans,CblasNoTrans,1.0,LL,XwX,0.0,Rl2);
gsl_blas_dgemm(CblasNoTrans,CblasTrans,1.0,Rl2,LL,0.0,&Rl.matrix);
} // end l
} // end if (tm->corr)
} // end for j=1:nVars
if ( tm->corr==IDENTITY )
gsl_vector_set(teststat, 0, sqrt(sum));
else {
status=gsl_linalg_cholesky_decomp (IinvRl);
if (status==GSL_EDOM) {
if (tm->warning==TRUE)
printf("Warning:singular matrix in multivariate wald test.\n");
}
gsl_linalg_cholesky_solve (IinvRl, LBeta, tmp);
gsl_blas_ddot (LBeta, tmp, &result);
gsl_vector_set(teststat, 0, sqrt(result));
}
// free memory
for (j=0; j<nVars; j++)
gsl_matrix_free(Z[j].matrix);
free(Z);
gsl_vector_free(LBeta);
gsl_matrix_free(w1jX1);
gsl_matrix_free(XwX);
gsl_matrix_free(Rl2);
gsl_matrix_free(IinvN);
gsl_matrix_free(IinvRl);
gsl_vector_free(tmp);
return SUCCESS;
}
void HLayeredBlWStructure::VkB( gsl_matrix *X, long k,
const gsl_matrix *B ) const {
gsl_matrix_memcpy(X, B);
gsl_blas_dtrmm(CblasLeft, CblasLower, (k > 0 ? CblasNoTrans : CblasTrans),
CblasNonUnit, 1.0, getWk(abs(k)), X);
}
int main() {
int ret;
int i, j;
gsl_vector* tau;
gsl_matrix *A;
gsl_matrix *Q, *R, *RTR;
gsl_matrix_view Rtop;
int M = 4;
int N = 3;
/*
gsl_matrix A;
double data[9];
memset(&A, 0, sizeof(gsl_matrix));
A.size1 = 3;
A.size2 = 3;
A.tda = 3;
A.data = data;
gsl_matrix_set(&A, 0, 0, 34.0);
gsl_matrix_set(&A, 0, 1, 4.0);
gsl_matrix_set(&A, 0, 2, 14.0);
gsl_matrix_set(&A, 1, 0, 1.0);
gsl_matrix_set(&A, 1, 1, 8.0);
gsl_matrix_set(&A, 1, 2, 3.0);
gsl_matrix_set(&A, 2, 0, 7.0);
gsl_matrix_set(&A, 2, 1, 1.0);
gsl_matrix_set(&A, 2, 2, 8.0);
*/
A = gsl_matrix_alloc(M, N);
for (i=0; i<M; i++)
for (j=0; j<N; j++)
gsl_matrix_set(A, i, j, (double)rand()/(double)RAND_MAX);
for (i=0; i<A->size1; i++) {
printf((i==0) ? "A = (" : " (");
for (j=0; j<A->size2; j++) {
printf(" %12.5g ", gsl_matrix_get(A, i, j));
}
printf(")\n");
}
printf("\n");
tau = gsl_vector_alloc(N);
ret = gsl_linalg_QR_decomp(A, tau);
Q = gsl_matrix_alloc(M, M);
R = gsl_matrix_alloc(M, N);
ret = gsl_linalg_QR_unpack(A, tau, Q, R);
for (i=0; i<Q->size1; i++) {
printf((i==0) ? "Q = (" : " (");
for (j=0; j<Q->size2; j++) {
printf(" %12.5g ", gsl_matrix_get(Q, i, j));
}
printf(")\n");
}
printf("\n");
for (i=0; i<R->size1; i++) {
printf((i==0) ? "R = (" : " (");
for (j=0; j<R->size2; j++) {
printf(" %12.5g ", gsl_matrix_get(R, i, j));
}
printf(")\n");
}
printf("\n");
Rtop = gsl_matrix_submatrix(R, 0, 0, N, N);
RTR = gsl_matrix_alloc(N, N);
gsl_matrix_memcpy(RTR, &(Rtop.matrix));
ret = gsl_blas_dtrmm(CblasLeft, CblasUpper, CblasTrans, CblasNonUnit,
1.0, RTR, RTR);
//(Rtop.matrix), &(Rtop.matrix));
for (i=0; i<RTR->size1; i++) {
printf((i==0) ? "RTR = (" : " (");
for (j=0; j<RTR->size2; j++) {
printf(" %12.5g ", gsl_matrix_get(RTR, i, j));
}
printf(")\n");
}
printf("\n");
gsl_matrix_free(RTR);
gsl_matrix_free(Q);
gsl_matrix_free(R);
gsl_vector_free(tau);
gsl_matrix_free(A);
return 0;
}
