gsl_vector* linear_ols_beta(gsl_vector *v_y, gsl_matrix *m_X){
size_t i_k = m_X->size2;
gsl_vector *v_XTy = gsl_vector_alloc(i_k);
gsl_vector *v_betahat = gsl_vector_alloc(i_k);
gsl_matrix *m_XTX = gsl_matrix_alloc(i_k,i_k);
gsl_matrix *m_invXTX = gsl_matrix_alloc(i_k,i_k);
gsl_vector_set_all(v_XTy,0);
gsl_vector_set_all(v_betahat,0);
gsl_matrix_set_all(m_XTX,0);
olsg(v_y,m_X,v_XTy,m_XTX);
gsl_linalg_cholesky_decomp (m_XTX);
gsl_matrix_set_identity(m_invXTX);
gsl_blas_dtrsm (CblasLeft, CblasLower,CblasNoTrans,CblasNonUnit,1.0,m_XTX,m_invXTX);
gsl_blas_dtrsm (CblasLeft, CblasLower,CblasTrans,CblasNonUnit,1.0,m_XTX,m_invXTX);
gsl_vector_set_all(v_betahat,0.0);
gsl_blas_dsymv (CblasLower,1.0,m_invXTX,v_XTy,0.0,v_betahat);
gsl_vector_free(v_XTy);
gsl_matrix_free(m_XTX);
gsl_matrix_free(m_invXTX);
return v_betahat;
}
/* V = tau*XTX + T0, M = V^{-1}*(tau*XTy + T0*b0) */
void linear_gibbs_beta(const gsl_matrix *XTX, const gsl_vector *XTy,
const gsl_vector *b0, const double s2,
const gsl_matrix *T0, gsl_vector *draw)
{
size_t k=XTy->size;
double tau=1./s2;
gsl_matrix *V=gsl_matrix_alloc(k,k);
gsl_matrix *VI=gsl_matrix_alloc(k,k);
gsl_vector *tmp=gsl_vector_alloc(k);
gsl_vector *M=gsl_vector_alloc(k);
/* compute V = tau*XTX + T0 */
gsl_matrix_memcpy(V,XTX);
gsl_matrix_scale(V,tau);
gsl_matrix_add(V,T0);
/* compute V inverse = VI */
gsl_linalg_cholesky_decomp (V);
gsl_matrix_set_identity(VI);
gsl_blas_dtrsm (CblasLeft, CblasLower,CblasNoTrans,CblasNonUnit,1.0,V,VI);
gsl_blas_dtrsm (CblasLeft, CblasLower,CblasTrans,CblasNonUnit,1.0,V,VI);
/* form T0*b0 + tau*XTy */
gsl_vector_memcpy(tmp,XTy);
gsl_blas_dsymv (CblasLower,1.0,T0,b0,tau,tmp);
/* form V^{-1}*( T0*b0 + tau*XTy ) */
gsl_vector_set_all(M,0.0);
gsl_blas_dsymv (CblasLower,1.0,VI,tmp,0.0,M);
ran_mvn(M,VI,draw);
gsl_matrix_free(V);
gsl_matrix_free(VI);
gsl_vector_free(tmp);
gsl_vector_free(M);
}
static void
_ncm_data_gauss_cov_inv_cov_UH (NcmData *data, NcmMSet *mset, NcmMatrix *H)
{
NcmDataGaussCov *gauss = NCM_DATA_GAUSS_COV (data);
NcmDataGaussCovClass *gauss_cov_class = NCM_DATA_GAUSS_COV_GET_CLASS (gauss);
gboolean cov_update = FALSE;
gint ret;
if (gauss_cov_class->cov_func != NULL)
cov_update = gauss_cov_class->cov_func (gauss, mset, gauss->cov);
if (cov_update || !gauss->prepared_LLT)
_ncm_data_gauss_cov_prepare_LLT (data);
ret = gsl_blas_dtrsm (CblasRight, CblasUpper, CblasNoTrans, CblasNonUnit,
1.0, ncm_matrix_gsl (gauss->LLT), ncm_matrix_gsl (H));
NCM_TEST_GSL_RESULT ("_ncm_data_gauss_cov_inv_cov_UH", ret);
}
static VALUE rb_gsl_blas_dtrsm(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_dtrsm(Side, Uplo, TransA, Diag, alpha, A, B);
return bb;
}
static VALUE rb_gsl_blas_dtrsm2(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_dtrsm(Side, Uplo, TransA, Diag, alpha, A, Bnew);
return Data_Wrap_Struct(cgsl_matrix, 0, gsl_matrix_free, Bnew);
}
/**
* C++ version of gsl_blas_dtrsm().
* @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 dtrsm( 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_dtrsm( Side, Uplo, TransA, Diag, alpha, A.get(), B.get() ); }
int lseShurComplement(gsl_matrix * A, gsl_matrix * C,
gsl_vector * b, gsl_vector * d,
gsl_vector * x, gsl_vector * lambda, double * sigma)
{
int i;
double xi;
gsl_vector *c0, *S, *tau;
gsl_matrix *CT, *U;
gsl_permutation *perm;
gsl_vector_view row, cp;
gsl_matrix_view R;
if (A->size2 != C->size2) return -1;
if (A->size2 != x->size) return -1;
if (A->size1 < A->size2) return -1;
if (b != NULL && A->size1 != b->size) return -1;
if (C->size1 != d->size) return -1;
if (C->size1 != lambda->size) return -1;
c0 = gsl_vector_alloc(x->size);
gsl_matrix_get_row(c0, C, 0);
/* Cholesky factorization of A^T A = R^T R via QRPT decomposition */
perm = gsl_permutation_alloc(x->size);
tau = gsl_vector_alloc(x->size);
gsl_linalg_QRPT_decomp(A, tau, perm, &i, x);
/* cp = R^{-T} P A^T b = Q^T b */
if (b != NULL) {
gsl_linalg_QR_QTvec(A, tau, b);
cp = gsl_vector_subvector(b, 0, x->size);
}
gsl_vector_free(tau);
/* C P -> C */
R = gsl_matrix_submatrix(A, 0, 0, A->size2, A->size2);
for (i = 0; i < C->size1; ++i) {
row = gsl_matrix_row(C, i);
gsl_permute_vector(perm, &row.vector);
}
/* Compute C inv(R) -> C */
gsl_blas_dtrsm(CblasRight, CblasUpper, CblasNoTrans, CblasNonUnit, 1.0,
&R.matrix, C);
/* The Schur complement D = C C^T,
Compute SVD of D = U S^2 U^T by SVD of C^T = V S U^T */
CT = gsl_matrix_alloc(C->size2, C->size1);
gsl_matrix_transpose_memcpy(CT, C);
U = gsl_matrix_alloc(CT->size2, CT->size2);
S = gsl_vector_alloc(CT->size2);
gsl_linalg_SV_decomp(CT, U, S, lambda);
/* Right hand side of the Shur complement system
d - C (A^T A)^-1 A^T b = d - C cp -> d
(with C P R^-1 -> C and R^-T P^T A^T b -> cp) */
if (b != NULL) {
gsl_blas_dgemv(CblasNoTrans, -1.0, C, &cp.vector, 1.0, d);
}
/* Calculate S U^T lambda, where -lambda is the Lagrange multiplier */
gsl_blas_dgemv(CblasTrans, 1.0, U, d, 0.0, lambda);
gsl_vector_div(lambda, S);
/* Calculate sigma = || A x ||_2 = || x ||_2 (before inv(R) x -> x) */
*sigma = gsl_blas_dnrm2(lambda);
/* Compute inv(R)^T C^T lambda = C^T lambda (with C inv(R) ->C) */
gsl_blas_dgemv(CblasNoTrans, 1.0, CT, lambda, 0.0, x);
/* x = inv(A^T A) C^T lambda = inv(R) [inv(R)^T C^T lambda] */
if (R.matrix.data[R.matrix.size1 * R.matrix.size2 - 1] != 0.0) {
gsl_blas_dtrsv(CblasUpper, CblasNoTrans, CblasNonUnit, &R.matrix, x);
}
else { /* Special case when A is singular */
gsl_vector_set_basis(x, x->size - 1);
*sigma = 0.0;
}
/* Permute back, 1-step iterative refinement on first constraint */
gsl_permute_vector_inverse(perm, x);
gsl_blas_ddot(x, c0, &xi);
gsl_vector_scale(x, d->data[0] / xi);
/* get the real lambda from S U^T lambda previously stored in lambda */
gsl_vector_div(lambda, S);
gsl_vector_memcpy(S, lambda);
gsl_blas_dgemv(CblasNoTrans, 1.0, U, S, 0.0, lambda);
gsl_vector_free(c0);
gsl_vector_free(S);
gsl_matrix_free(U);
gsl_matrix_free(CT);
gsl_permutation_free(perm);
return 0;
}
//[E,z] = (n, n_class, pi, K);
void mexFunction(int nlhs, mxArray* plhs[], int nrhs, const mxArray* prhs[])
{
double sigma_noise = 5.0e-7; // works for s=0, but this gives different results from the octave code
double *pi;
double *Kmx;
int c, i, j, n, n_class;
double *tmp, z = 0;
/* Check for proper number of arguments. */
if(nrhs!=4) {
mexErrMsgTxt("mex_laplace_subroutine: requires exactly four input arguments.");
} else if(nlhs>2) {
mexErrMsgTxt("mex_laplace_subroutine: requires at most two output arguments.");
} else if (nlhs <= 0) {
mexErrMsgTxt("mex_laplace_subroutine: requires at least one output argument.");
}
tmp = mxGetPr(prhs[0]);
n = (int) (tmp[0]);
tmp = mxGetPr(prhs[1]);
n_class = (int) (tmp[0]);
pi = mxGetPr(prhs[2]);
Kmx = mxGetPr(prhs[3]);
gsl_matrix *K = gsl_matrix_alloc(n*n_class, n*n_class);
K->data = Kmx;
// K, at least K(:,:,1), is confirmed correct
gsl_matrix* Ip = gsl_matrix_alloc(n, n);
gsl_matrix_set_identity(Ip);
gsl_matrix_scale(Ip, 1+sigma_noise);
// this should probably be restructured, after I get this working
double *E_val;
plhs[0] = mxCreateDoubleMatrix(n, n*n_class, mxREAL);
E_val = mxGetPr(plhs[0]);
//#pragma omp parallel for
for (c = 0; c < n_class; c++) {
gsl_matrix *sqrtDc = gsl_matrix_calloc(n, n);
gsl_matrix *L = gsl_matrix_alloc(n, n);
gsl_matrix *L1 = gsl_matrix_alloc(n, n);
_gsl_matrix_const_view Kcv = gsl_matrix_const_submatrix(K, c*n, c*n, n, n);
gsl_matrix *Kc = gsl_matrix_alloc(n, n);
Kc = &Kcv.matrix;
gsl_matrix *Ec = gsl_matrix_alloc(n, n);
for (i = 0; i < n; i++) {
gsl_matrix_set(sqrtDc, i, i, sqrt(pi[i + c * n]));
}
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, Kc, sqrtDc, 0.0, L1); // L1 = K[:,:,c]) * sqrtDc
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, sqrtDc, L1, 0.0, L); // L = sqrtDc * (K(:,:,c) * sqrtDc);
// NTS: is the above equivalent to:
// Lc := (pi_c pi_c') .* Kc
// ?
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, Ip, Ip, 1.0, L); // L = (1 + sigma_noise)*eye(n) + sqrtDc * K(:,:,c) * sqrtDc;
// rewrite that one, god - mult to do add? that's just absurd
gsl_linalg_cholesky_decomp(L); // L = chol((1 + sigma_noise)*eye(n) + sqrtDc * K(:,:,c) * sqrtDc)';
// this gives L as being doubled triangular! LL' != RHS
// if it throws GSL_EDOM, that means L wasn't pos def, apparently
for (i = 0; i < n; i++) {
z += log(gsl_matrix_get(L, i, i)); // this apparently works. huzzah
}
for (i = 0; i < n; i++) {
for (j=0;j<n;j++) {
gsl_matrix_set(L1, i, j, gsl_matrix_get(sqrtDc,i,j));
}
}
// L1 = sqrtDc
gsl_blas_dtrsm(CblasLeft, CblasLower, CblasNoTrans, CblasNonUnit, 1.0, L, L1); // L1 = L \ sqrtDc
gsl_blas_dtrsm(CblasLeft, CblasLower, CblasTrans, CblasNonUnit, 1.0, L, L1); // L1 = L' \ (L \ sqrtDc)
// sqrtDc and L are sym, so these should be invariant trans or no trans, provided exactly one is
gsl_blas_dgemm(CblasNoTrans, CblasNoTrans, 1.0, sqrtDc, L1, 0.0, Ec); // Ec = sqrtDc * ( L' \ (L \ sqrtDc) );
/*catch
disp('alg3.3s chol is failing again');
matrix [L, U] = lu((1 + sigma_noise)*eye(n) + sqrtDc * K(:,:,c) * sqrtDc);
E(:,:,c) = ((sqrtDc / U) / L) * sqrtDc;
end*/
for (j=0;j<n;j++) {
for (i=0;i<n;i++) {
E_val[c*n*n+j*n+i] = gsl_matrix_get(Ec, i, j);
}
}
/*
if (!c) {
printf("Ec1:\n");
for (i = 0; i < n; i++) {
for (j = 0; j < n; j++) {
printf("%g ", gsl_matrix_get(Ec, i, j));
}
printf("\n");
}
printf("E1:\n");
for (i = 0; i < n; i++) {
for (j = 0; j < n; j++) {
printf("%g ", gsl_matrix_get(E, i, j));
}
printf("\n");
}
}*/
}
if (nlhs >= 2) {
plhs[1] = mxCreateDoubleMatrix(1, 1, mxREAL);
double *z_val = mxGetPr(plhs[1]);
z_val[0] = z;
}
}
int
gsl_eigen_gensymmv (gsl_matrix * A, gsl_matrix * B, gsl_vector * eval,
gsl_matrix * evec, gsl_eigen_gensymmv_workspace * w)
{
const size_t N = A->size1;
/* check matrix and vector sizes */
if (N != A->size2)
{
GSL_ERROR ("matrix must be square to compute eigenvalues", GSL_ENOTSQR);
}
else if ((N != B->size1) || (N != B->size2))
{
GSL_ERROR ("B matrix dimensions must match A", GSL_EBADLEN);
}
else if (eval->size != N)
{
GSL_ERROR ("eigenvalue vector must match matrix size", GSL_EBADLEN);
}
else if (evec->size1 != evec->size2)
{
GSL_ERROR ("eigenvector matrix must be square", GSL_ENOTSQR);
}
else if (evec->size1 != N)
{
GSL_ERROR ("eigenvector matrix has wrong size", GSL_EBADLEN);
}
else if (w->size != N)
{
GSL_ERROR ("matrix size does not match workspace", GSL_EBADLEN);
}
else
{
int s;
/* compute Cholesky factorization of B */
s = gsl_linalg_cholesky_decomp(B);
if (s != GSL_SUCCESS)
return s; /* B is not positive definite */
/* transform to standard symmetric eigenvalue problem */
gsl_eigen_gensymm_standardize(A, B);
/* compute eigenvalues and eigenvectors */
s = gsl_eigen_symmv(A, eval, evec, w->symmv_workspace_p);
if (s != GSL_SUCCESS)
return s;
/* backtransform eigenvectors: evec -> L^{-T} evec */
gsl_blas_dtrsm(CblasLeft,
CblasLower,
CblasTrans,
CblasNonUnit,
1.0,
B,
evec);
/* the blas call destroyed the normalization - renormalize */
gensymmv_normalize_eigenvectors(evec);
return GSL_SUCCESS;
}
} /* gsl_eigen_gensymmv() */
static void
linreg_fit_qr (const gsl_matrix *cov, linreg *l)
{
double intcpt_coef = 0.0;
double intercept_variance = 0.0;
gsl_matrix *xtx;
gsl_matrix *q;
gsl_matrix *r;
gsl_vector *xty;
gsl_vector *tau;
gsl_vector *params;
double tmp = 0.0;
size_t i;
size_t j;
xtx = gsl_matrix_alloc (cov->size1 - 1, cov->size2 - 1);
xty = gsl_vector_alloc (cov->size1 - 1);
tau = gsl_vector_alloc (cov->size1 - 1);
params = gsl_vector_alloc (cov->size1 - 1);
for (i = 0; i < xtx->size1; i++)
{
gsl_vector_set (xty, i, gsl_matrix_get (cov, cov->size2 - 1, i));
for (j = 0; j < xtx->size2; j++)
{
gsl_matrix_set (xtx, i, j, gsl_matrix_get (cov, i, j));
}
}
gsl_linalg_QR_decomp (xtx, tau);
q = gsl_matrix_alloc (xtx->size1, xtx->size2);
r = gsl_matrix_alloc (xtx->size1, xtx->size2);
gsl_linalg_QR_unpack (xtx, tau, q, r);
gsl_linalg_QR_solve (xtx, tau, xty, params);
for (i = 0; i < params->size; i++)
{
l->coeff[i] = gsl_vector_get (params, i);
}
l->sst = gsl_matrix_get (cov, cov->size1 - 1, cov->size2 - 1);
l->ssm = 0.0;
for (i = 0; i < l->n_indeps; i++)
{
l->ssm += gsl_vector_get (xty, i) * l->coeff[i];
}
l->sse = l->sst - l->ssm;
gsl_blas_dtrsm (CblasLeft, CblasLower, CblasNoTrans, CblasNonUnit, linreg_mse (l),
r, q);
/* Copy the lower triangle into the upper triangle. */
for (i = 0; i < q->size1; i++)
{
gsl_matrix_set (l->cov, i + 1, i + 1, gsl_matrix_get (q, i, i));
for (j = i + 1; j < q->size2; j++)
{
intercept_variance -= 2.0 * gsl_matrix_get (q, i, j) *
linreg_get_indep_variable_mean (l, i) *
linreg_get_indep_variable_mean (l, j);
gsl_matrix_set (q, i, j, gsl_matrix_get (q, j, i));
}
}
l->intercept = linreg_get_depvar_mean (l);
tmp = 0.0;
for (i = 0; i < l->n_indeps; i++)
{
tmp = linreg_get_indep_variable_mean (l, i);
l->intercept -= l->coeff[i] * tmp;
intercept_variance += tmp * tmp * gsl_matrix_get (q, i, i);
}
/* Covariances related to the intercept. */
intercept_variance += linreg_mse (l) / linreg_n_obs (l);
gsl_matrix_set (l->cov, 0, 0, intercept_variance);
for (i = 0; i < q->size1; i++)
{
for (j = 0; j < q->size2; j++)
{
intcpt_coef -= gsl_matrix_get (q, i, j)
* linreg_get_indep_variable_mean (l, j);
}
gsl_matrix_set (l->cov, 0, i + 1, intcpt_coef);
gsl_matrix_set (l->cov, i + 1, 0, intcpt_coef);
intcpt_coef = 0.0;
}
gsl_matrix_free (q);
gsl_matrix_free (r);
gsl_vector_free (xty);
gsl_vector_free (tau);
gsl_matrix_free (xtx);
gsl_vector_free (params);
}
