/* C = A*B */
cs *cs_multiply (const cs *A, const cs *B)
{
CS_INT p, j, nz = 0, anz, *Cp, *Ci, *Bp, m, n, bnz, *w, values, *Bi ;
CS_ENTRY *x, *Bx, *Cx ;
cs *C ;
if (!CS_CSC (A) || !CS_CSC (B)) return (NULL) ; /* check inputs */
if (A->n != B->m) return (NULL) ;
m = A->m ; anz = A->p [A->n] ;
n = B->n ; Bp = B->p ; Bi = B->i ; Bx = B->x ; bnz = Bp [n] ;
w = cs_calloc (m, sizeof (CS_INT)) ; /* get workspace */
values = (A->x != NULL) && (Bx != NULL) ;
x = values ? cs_malloc (m, sizeof (CS_ENTRY)) : NULL ; /* get workspace */
C = cs_spalloc (m, n, anz + bnz, values, 0) ; /* allocate result */
if (!C || !w || (values && !x)) return (cs_done (C, w, x, 0)) ;
Cp = C->p ;
for (j = 0 ; j < n ; j++)
{
if (nz + m > C->nzmax && !cs_sprealloc (C, 2*(C->nzmax)+m))
{
return (cs_done (C, w, x, 0)) ; /* out of memory */
}
Ci = C->i ; Cx = C->x ; /* C->i and C->x may be reallocated */
Cp [j] = nz ; /* column j of C starts here */
for (p = Bp [j] ; p < Bp [j+1] ; p++)
{
nz = cs_scatter (A, Bi [p], Bx ? Bx [p] : 1, w, x, j+1, C, nz) ;
}
if (values) for (p = Cp [j] ; p < nz ; p++) Cx [p] = x [Ci [p]] ;
}
Cp [n] = nz ; /* finalize the last column of C */
cs_sprealloc (C, 0) ; /* remove extra space from C */
return (cs_done (C, w, x, 1)) ; /* success; free workspace, return C */
}
/* C = alpha*A + beta*B */
cs *cs_add (const cs *A, const cs *B, double alpha, double beta)
{
int p, j, nz = 0, anz, *Cp, *Ci, *Bp, m, n, bnz, *w, values ;
double *x, *Bx, *Cx ;
cs *C ;
if (!CS_CSC (A) || !CS_CSC (B)) return (NULL) ; /* check inputs */
if (A->m != B->m || A->n != B->n) return (NULL) ;
m = A->m ; anz = A->p [A->n] ;
n = B->n ; Bp = B->p ; Bx = B->x ; bnz = Bp [n] ;
w = cs_calloc (m, sizeof (int)) ; /* get workspace */
values = (A->x != NULL) && (Bx != NULL) ;
x = values ? cs_malloc (m, sizeof (double)) : NULL ; /* get workspace */
C = cs_spalloc (m, n, anz + bnz, values, 0) ; /* allocate result*/
if (!C || !w || (values && !x)) return (cs_done (C, w, x, 0)) ;
Cp = C->p ; Ci = C->i ; Cx = C->x ;
for (j = 0 ; j < n ; j++)
{
Cp [j] = nz ; /* column j of C starts here */
nz = cs_scatter (A, j, alpha, w, x, j+1, C, nz) ; /* alpha*A(:,j)*/
nz = cs_scatter (B, j, beta, w, x, j+1, C, nz) ; /* beta*B(:,j) */
if (values) for (p = Cp [j] ; p < nz ; p++) Cx [p] = x [Ci [p]] ;
}
Cp [n] = nz ; /* finalize the last column of C */
cs_sprealloc (C, 0) ; /* remove extra space from C */
return (cs_done (C, w, x, 1)) ; /* success; free workspace, return C */
}
cs *cs_transpose(const cs *A, int values) {
int p, q, j, *Cp, *Ci, n, m, *Ap, *Ai, *w;
double *Cx, *Ax;
cs *C;
if (!CS_CSC (A))
return (NULL); /* check inputs */
m = A->m;
n = A->n;
Ap = A->p;
Ai = A->i;
Ax = A->x;
C = cs_spalloc(n, m, Ap[n], values && Ax, 0); /* allocate result */
w = (int *) cs_calloc(m, sizeof(int)); /* get workspace */
if (!C || !w)
return (cs_done(C, w, NULL, 0)); /* out of memory */
Cp = C->p;
Ci = C->i;
Cx = C->x;
for (p = 0; p < Ap[n]; p++)
w[Ai[p]]++; /* row counts */
cs_cumsum(Cp, w, m); /* row pointers */
for (j = 0; j < n; j++) {
for (p = Ap[j]; p < Ap[j + 1]; p++) {
Ci[q = w[Ai[p]]++] = j; /* place A(i,j) as entry C(j,i) */
if (Cx)
Cx[q] = Ax[p];
}
}
return (cs_done(C, w, NULL, 1)); /* success; free w and return C */
}
cs *cs_compress(const cs *T) {
int m, n, nz, p, k, *Cp, *Ci, *w, *Ti, *Tj;
double *Cx, *Tx;
cs *C;
if (!CS_TRIPLET (T))
return (NULL); /* check inputs */
m = T->m;
n = T->n;
Ti = T->i;
Tj = T->p;
Tx = T->x;
nz = T->nz;
C = cs_spalloc(m, n, nz, Tx != NULL, 0); /* allocate result */
w = (int *) cs_calloc(n, sizeof(int)); /* get workspace */
if (!C || !w)
return (cs_done(C, w, NULL, 0)); /* out of memory */
Cp = C->p;
Ci = C->i;
Cx = C->x;
for (k = 0; k < nz; k++)
w[Tj[k]]++; /* column counts */
cs_cumsum(Cp, w, n); /* column pointers */
for (k = 0; k < nz; k++) {
Ci[p = w[Tj[k]]++] = Ti[k]; /* A(i,j) is the pth entry in C */
if (Cx)
Cx[p] = Tx[k];
}
return (cs_done(C, w, NULL, 1)); /* success; free w and return C */
}
/* C = compressed-column form of a triplet matrix T */
cs *SCS(cs_compress)(const cs *T) {
scs_int m, n, nz, p, k, *Cp, *Ci, *w, *Ti, *Tj;
scs_float *Cx, *Tx;
cs *C;
m = T->m;
n = T->n;
Ti = T->i;
Tj = T->p;
Tx = T->x;
nz = T->nz;
C = SCS(cs_spalloc)(m, n, nz, Tx != SCS_NULL, 0); /* allocate result */
w = (scs_int *)scs_calloc(n, sizeof(scs_int)); /* get workspace */
if (!C || !w) {
return (cs_done(C, w, SCS_NULL, 0));
} /* out of memory */
Cp = C->p;
Ci = C->i;
Cx = C->x;
for (k = 0; k < nz; k++) w[Tj[k]]++; /* column counts */
SCS(cs_cumsum)(Cp, w, n); /* column pointers */
for (k = 0; k < nz; k++) {
Ci[p = w[Tj[k]]++] = Ti[k]; /* A(i,j) is the pth entry in C */
if (Cx) {
Cx[p] = Tx[k];
}
}
return (cs_done(C, w, SCS_NULL, 1)); /* success; free w and return C */
}
cs *cs_rR(const cs *A, double nu, double nuR, const css *As, const cs *Roldinv, double Roldldet, const cs *pG){
cs *Rnew, *Rnewinv, *Ainv;
double Rnewldet, MH;
int dimG = A->n;
int cnt = 0;
int i, j;
Rnewinv = cs_spalloc (dimG, dimG, dimG*dimG, 1, 0);
for (i = 0 ; i < dimG; i++){
Rnewinv->p[i] = i*dimG;
for (j = 0 ; j < dimG; j++){
Rnewinv->i[cnt] = j;
Rnewinv->x[cnt] = 0.0;
A->x[i*dimG+j] -= pG->x[i*dimG+j];
cnt++;
}
}
Rnewinv->p[dimG] = dimG*dimG;
cs_cov2cor(A);
Ainv = cs_inv(A);
Rnew = cs_rinvwishart(Ainv, nu, As);
cs_cov2cor(Rnew);
Rnewldet = log(cs_invR(Rnew, Rnewinv));
/*****************************************************/
/* From Eq A.4 in Liu and Daniels (2006) */
/* using \pi_{1} = Eq 6 in Barnard (2000) */
/* using \pi_{2} = Eq 3.4 in Liu and Daniels (2006) */
/*****************************************************/
MH = Roldldet-Rnewldet;
for (i = 0 ; i < dimG; i++){
MH += log(Roldinv->x[i*dimG+i]);
MH -= log(Rnewinv->x[i*dimG+i]);
}
MH *= 0.5*nuR;
if(MH<log(runif(0.0,1.0)) || Rnewldet<log(Dtol)){
Rnewldet = cs_invR(Roldinv, Rnew); // save old R
}
for (i = 0 ; i < dimG; i++){
for (j = 0 ; j < dimG; j++){
Rnew->x[i*dimG+j] *= sqrt((pG->x[i*dimG+i])*(pG->x[j*dimG+j]));
}
}
cs_spfree(Rnewinv);
cs_spfree(Ainv);
return (cs_done (Rnew, NULL, NULL, 1)) ; /* success; free workspace, return C */
}
cs *SCS(cs_symperm)(const cs *A, const scs_int *pinv, scs_int values) {
scs_int i, j, p, q, i2, j2, n, *Ap, *Ai, *Cp, *Ci, *w;
scs_float *Cx, *Ax;
cs *C;
n = A->n;
Ap = A->p;
Ai = A->i;
Ax = A->x;
C = SCS(cs_spalloc)(n, n, Ap[n], values && (Ax != SCS_NULL),
0); /* alloc result*/
w = (scs_int *)scs_calloc(n, sizeof(scs_int)); /* get workspace */
if (!C || !w) {
return (cs_done(C, w, SCS_NULL, 0));
} /* out of memory */
Cp = C->p;
Ci = C->i;
Cx = C->x;
for (j = 0; j < n; j++) /* count entries in each column of C */
{
j2 = pinv ? pinv[j] : j; /* column j of A is column j2 of C */
for (p = Ap[j]; p < Ap[j + 1]; p++) {
i = Ai[p];
if (i > j) {
continue;
} /* skip lower triangular part of A */
i2 = pinv ? pinv[i] : i; /* row i of A is row i2 of C */
w[MAX(i2, j2)]++; /* column count of C */
}
}
SCS(cs_cumsum)(Cp, w, n); /* compute column pointers of C */
for (j = 0; j < n; j++) {
j2 = pinv ? pinv[j] : j; /* column j of A is column j2 of C */
for (p = Ap[j]; p < Ap[j + 1]; p++) {
i = Ai[p];
if (i > j) {
continue;
} /* skip lower triangular part of A*/
i2 = pinv ? pinv[i] : i; /* row i of A is row i2 of C */
Ci[q = w[MAX(i2, j2)]++] = MIN(i2, j2);
if (Cx) {
Cx[q] = Ax[p];
}
}
}
return (cs_done(C, w, SCS_NULL, 1)); /* success; free workspace, return C */
}
cs *cs_rinvwishart(const cs *A, double nu, const css *As){
int m, i, j, cnt;
cs *T, *IW, *C, *W, *tC;
csn *U;
m = A->n;
T = cs_spalloc (m, m, m*(m+1)/2, 1, 0) ;
if (!T ) return (cs_done (T, NULL, NULL, 0));
double df = nu;
cnt = 0;
for(i = 0; i<m; i++){
T->p[i] = cnt;
T->i[cnt] = i;
T->x[cnt] = sqrt(rchisq(df));
cnt++;
for(j = i+1; j<m; j++){
T->i[cnt] = j;
T->x[cnt] = rnorm(0.0,1.0);
cnt++;
}
df--;
}
T->p[m] = m*(m+1)/2;
U = cs_chol(A, As);
if(U==NULL){
PutRNGstate();
error("ill-conditioned cross-product: can't form Cholesky factor\n");
}
C = cs_multiply(U->L,T); // t(T)%*%chol(A)
tC = cs_transpose(C, TRUE); // t(CI)
W = cs_multiply(C,tC);
IW = cs_inv(W); // crossprod(t(CI))
cs_spfree(T);
cs_nfree(U);
cs_spfree(C);
cs_spfree(tC);
cs_spfree(W);
return (cs_done (IW, NULL, NULL, 1)) ; /* success; free workspace, return C */
}
cs *cs_symperm(const cs *A, const int *pinv, int values) {
int i, j, p, q, i2, j2, n, *Ap, *Ai, *Cp, *Ci, *w;
double *Cx, *Ax;
cs *C;
if (!CS_CSC (A))
return (NULL); /* check inputs */
n = A->n;
Ap = A->p;
Ai = A->i;
Ax = A->x;
C = cs_spalloc(n, n, Ap[n], values && (Ax != NULL), 0); /* alloc result*/
w = (int *) cs_calloc(n, sizeof(int)); /* get workspace */
if (!C || !w)
return (cs_done(C, w, NULL, 0)); /* out of memory */
Cp = C->p;
Ci = C->i;
Cx = C->x;
for (j = 0; j < n; j++) /* count entries in each column of C */
{
j2 = pinv ? pinv[j] : j; /* column j of A is column j2 of C */
for (p = Ap[j]; p < Ap[j + 1]; p++) {
i = Ai[p];
if (i > j)
continue; /* skip lower triangular part of A */
i2 = pinv ? pinv[i] : i; /* row i of A is row i2 of C */
w[CS_MAX (i2, j2)]++; /* column count of C */
}
}
cs_cumsum(Cp, w, n); /* compute column pointers of C */
for (j = 0; j < n; j++) {
j2 = pinv ? pinv[j] : j; /* column j of A is column j2 of C */
for (p = Ap[j]; p < Ap[j + 1]; p++) {
i = Ai[p];
if (i > j)
continue; /* skip lower triangular part of A*/
i2 = pinv ? pinv[i] : i; /* row i of A is row i2 of C */
Ci[q = w[CS_MAX (i2, j2)]++] = CS_MIN (i2, j2);
if (Cx)
Cx[q] = Ax[p];
}
}
return (cs_done(C, w, NULL, 1)); /* success; free workspace, return C */
}
cs *cs_permute (const cs *A, const int *pinv, const int *q, int values)
{
int t, j, k, nz = 0, m, n, *Ap, *Ai, *Cp, *Ci ;
double *Cx, *Ax ;
cs *C ;
if (!CS_CSC (A)) return (NULL) ; /* check inputs */
m = A->m ; n = A->n ; Ap = A->p ; Ai = A->i ; Ax = A->x ;
C = cs_spalloc (m, n, Ap [n], values && Ax != NULL, 0) ; /* alloc result */
if (!C) return (cs_done (C, NULL, NULL, 0)) ; /* out of memory */
Cp = C->p ; Ci = C->i ; Cx = C->x ;
for (k = 0 ; k < n ; k++)
{
Cp [k] = nz ; /* column k of C is column q[k] of A */
j = q ? (q [k]) : k ;
for (t = Ap [j] ; t < Ap [j+1] ; t++)
{
if (Cx) Cx [nz] = Ax [t] ; /* row i of A is row pinv[i] of C */
Ci [nz++] = pinv ? (pinv [Ai [t]]) : Ai [t] ;
}
}
Cp [n] = nz ; /* finalize the last column of C */
return (cs_done (C, NULL, NULL, 1)) ;
}
cs *cs_inv(const cs *C){
int n, i, icol,irow,j,k,l,ll;
double big,dum,pivinv,temp, det, CN;
CN = cs_norm(C);
cs *A;
n = C->n;
det=1.0;
int indxc[n],
indxr[n],
ipiv[n];
A = cs_spalloc (n, n, n*n, 1, 0);
if (!A ) return (cs_done (A, NULL, NULL, 0));
for(i = 0; i<(n*n); i++){
A->i[i] = C->i[i];
A->x[i] = C->x[i];
}
for(i = 0; i<=n; i++){
A->p[i] = C->p[i];
}
for (j=0;j<n;j++) ipiv[j]=0;
for (i=0;i<n;i++) {
big=0.0;
for (j=0;j<n;j++)
if (ipiv[j] != 1)
for (k=0;k<n;k++) {
if (ipiv[k] == 0) {
if (fabs(A->x[A->i[j]+A->p[k]]) >= big) {
big=fabs(A->x[A->i[j]+A->p[k]]);
irow=j;
icol=k;
}
} else if (ipiv[k] > 1) error("Singular G/R structure: use proper priors\n");// //exit(1);
}
++(ipiv[icol]);
if (irow != icol) {
for (l=0;l<n;l++){
temp = A->x[A->i[irow]+A->p[l]];
A->x[A->i[irow]+A->p[l]] = A->x[A->i[icol]+A->p[l]];
A->x[A->i[icol]+A->p[l]]= temp;
}
}
indxr[i]=irow;
indxc[i]=icol;
det *= A->x[A->i[icol]+A->p[icol]];
pivinv = 1.0/(A->x[A->i[icol]+A->p[icol]]);
A->x[A->i[icol]+A->p[icol]]=1.0;
for (l=0;l<n;l++) A->x[A->i[icol]+A->p[l]] *= pivinv;
for (ll=0;ll<n;ll++)
if (ll != icol) {
dum=A->x[A->i[ll]+A->p[icol]];
A->x[A->i[ll]+A->p[icol]]=0.0;
for (l=0;l<n;l++) A->x[A->i[ll]+A->p[l]] -= A->x[A->i[icol]+A->p[l]]*dum;
}
}
for (l=(n-1);l>=0;l--) {
if (indxr[l] != indxc[l]){
for (k=0;k<n;k++){
temp = A->x[A->i[k]+A->p[indxr[l]]];
A->x[A->i[k]+A->p[indxr[l]]] = A->x[A->i[k]+A->p[indxc[l]]];
A->x[A->i[k]+A->p[indxc[l]]] = temp;
}
}
}
CN *= cs_norm(A);
if(1.0/fabs(CN) < DBL_EPSILON){
if(n==1){
A->x[0] = 1.0/DBL_EPSILON;
}else{
PutRNGstate();
error("ill-conditioned G/R structure (CN = %f): use proper priors if you haven't or rescale data if you have\n", CN);
}
}
return (cs_done (A, NULL, NULL, 1)) ; /* success; free workspace, return C */
}