/* cs_add: sparse matrix addition */
void mexFunction
(
int nargout,
mxArray *pargout [ ],
int nargin,
const mxArray *pargin [ ]
)
{
double alpha, beta ;
cs Amatrix, Bmatrix, *A, *B, *C, *D ;
if (nargout > 1 || nargin < 2 || nargin > 4)
{
mexErrMsgTxt ("Usage: C = cs_add(A,B,alpha,beta)") ;
}
A = cs_mex_get_sparse (&Amatrix, 0, 1, pargin [0]) ; /* get A */
B = cs_mex_get_sparse (&Bmatrix, 0, 1, pargin [1]) ; /* get B */
alpha = (nargin < 3) ? 1 : mxGetScalar (pargin [2]) ; /* get alpha */
beta = (nargin < 4) ? 1 : mxGetScalar (pargin [3]) ; /* get beta */
C = cs_add (A,B,alpha,beta) ; /* C = alpha*A + beta *B */
cs_dropzeros (C) ; /* drop zeros */
D = cs_transpose (C, 1) ; /* sort result via double transpose */
cs_spfree (C) ;
C = cs_transpose (D, 1) ;
cs_spfree (D) ;
pargout [0] = cs_mex_put_sparse (&C) ; /* return C */
}
/* cs_symperm: symmetric permutation of a symmetric sparse matrix. */
void mexFunction
(
int nargout,
mxArray *pargout [ ],
int nargin,
const mxArray *pargin [ ]
)
{
cs Amatrix, *A, *C, *D ;
csi ignore, n, *P, *Pinv ;
if (nargout > 1 || nargin != 2)
{
mexErrMsgTxt ("Usage: C = cs_symperm(A,p)") ;
}
A = cs_mex_get_sparse (&Amatrix, 1, 1, pargin [0]) ;
n = A->n ;
P = cs_mex_get_int (n, pargin [1], &ignore, 1) ; /* get P */
Pinv = cs_pinv (P, n) ; /* P=Pinv' */
C = cs_symperm (A, Pinv, 1) ; /* C = A(p,p) */
D = cs_transpose (C, 1) ; /* sort C */
cs_spfree (C) ;
C = cs_transpose (D, 1) ;
cs_spfree (D) ;
pargout [0] = cs_mex_put_sparse (&C) ; /* return C */
cs_free (P) ;
cs_free (Pinv) ;
}
/* cs_permute: permute a sparse matrix */
void mexFunction
(
int nargout,
mxArray *pargout [ ],
int nargin,
const mxArray *pargin [ ]
)
{
cs Amatrix, *A, *C, *D ;
int ignore, *P, *Q, *Pinv ;
if (nargout > 1 || nargin != 3)
{
mexErrMsgTxt ("Usage: C = cs_permute(A,p,q)") ;
}
A = cs_mex_get_sparse (&Amatrix, 0, 1, pargin [0]) ; /* get A */
P = cs_mex_get_int (A->m, pargin [1], &ignore, 1) ; /* get P */
Q = cs_mex_get_int (A->n, pargin [2], &ignore, 1) ; /* get Q */
Pinv = cs_pinv (P, A->m) ; /* P = Pinv' */
C = cs_permute (A, Pinv, Q, 1) ; /* C = A(p,q) */
D = cs_transpose (C, 1) ; /* sort C via double transpose */
cs_spfree (C) ;
C = cs_transpose (D, 1) ;
cs_spfree (D) ;
pargout [0] = cs_mex_put_sparse (&C) ; /* return C */
cs_free (Pinv) ;
cs_free (P) ;
cs_free (Q) ;
}
/* Modified version of Tim Davis's cs_lu_mex.c file for MATLAB */
void install_lu(SEXP Ap, int order, double tol, Rboolean err_sing)
{
// (order, tol) == (1, 1) by default, when called from R.
SEXP ans;
css *S;
csn *N;
int n, *p, *dims;
CSP A = AS_CSP__(Ap), D;
R_CheckStack();
n = A->n;
if (A->m != n)
error(_("LU decomposition applies only to square matrices"));
if (order) { /* not using natural order */
order = (tol == 1) ? 2 /* amd(S'*S) w/dense rows or I */
: 1; /* amd (A+A'), or natural */
}
S = cs_sqr(order, A, /*qr = */ 0); /* symbolic ordering */
N = cs_lu(A, S, tol); /* numeric factorization */
if (!N) {
if(err_sing)
error(_("cs_lu(A) failed: near-singular A (or out of memory)"));
else {
/* No warning: The useR should be careful :
* Put NA into "LU" factor */
set_factors(Ap, ScalarLogical(NA_LOGICAL), "LU");
return;
}
}
cs_dropzeros(N->L); /* drop zeros from L and sort it */
D = cs_transpose(N->L, 1);
cs_spfree(N->L);
N->L = cs_transpose(D, 1);
cs_spfree(D);
cs_dropzeros(N->U); /* drop zeros from U and sort it */
D = cs_transpose(N->U, 1);
cs_spfree(N->U);
N->U = cs_transpose(D, 1);
cs_spfree(D);
p = cs_pinv(N->pinv, n); /* p=pinv' */
ans = PROTECT(NEW_OBJECT(MAKE_CLASS("sparseLU")));
dims = INTEGER(ALLOC_SLOT(ans, Matrix_DimSym, INTSXP, 2));
dims[0] = n; dims[1] = n;
SET_SLOT(ans, install("L"),
Matrix_cs_to_SEXP(N->L, "dtCMatrix", 0));
SET_SLOT(ans, install("U"),
Matrix_cs_to_SEXP(N->U, "dtCMatrix", 0));
Memcpy(INTEGER(ALLOC_SLOT(ans, Matrix_pSym, /* "p" */
INTSXP, n)), p, n);
if (order)
Memcpy(INTEGER(ALLOC_SLOT(ans, install("q"),
INTSXP, n)), S->q, n);
cs_nfree(N);
cs_sfree(S);
cs_free(p);
UNPROTECT(1);
set_factors(Ap, ans, "LU");
}
cs* cs_sorted_multiply2(const cs* a, const cs* b)
{
cs* D = cs_multiply(a,b);
cs* E = cs_transpose(D,1);
cs_spfree(D);
cs* C = cs_transpose(E,1);
cs_spfree(E);
return C;
}
cs* cs_sorted_multiply(const cs* a, const cs* b)
{
cs* A = cs_transpose (a, 1) ;
cs* B = cs_transpose (b, 1) ;
cs* D = cs_multiply (B,A) ; /* D = B'*A' */
cs_spfree (A) ;
cs_spfree (B) ;
cs_dropzeros (D) ; /* drop zeros from D */
cs* C = cs_transpose (D, 1) ; /* C = D', so that C is sorted */
cs_spfree (D) ;
return C;
}
/* cs_lu: sparse LU factorization, with optional fill-reducing ordering */
void mexFunction
(
int nargout,
mxArray *pargout [ ],
int nargin,
const mxArray *pargin [ ]
)
{
css *S ;
csn *N ;
cs Amatrix, *A, *D ;
csi n, order, *p ;
double tol ;
if (nargout > 4 || nargin > 3 || nargin < 1)
{
mexErrMsgTxt ("Usage: [L,U,p,q] = cs_lu (A,tol)") ;
}
A = cs_mex_get_sparse (&Amatrix, 1, 1, pargin [0]) ; /* get A */
n = A->n ;
if (nargin == 2) /* determine tol and ordering */
{
tol = mxGetScalar (pargin [1]) ;
order = (nargout == 4) ? 1 : 0 ; /* amd (A+A'), or natural */
}
else
{
tol = 1 ;
order = (nargout == 4) ? 2 : 0 ; /* amd(S'*S) w/dense rows or I */
}
S = cs_sqr (order, A, 0) ; /* symbolic ordering, no QR bound */
N = cs_lu (A, S, tol) ; /* numeric factorization */
if (!N) mexErrMsgTxt ("cs_lu failed (singular, or out of memory)") ;
cs_dropzeros (N->L) ; /* drop zeros from L and sort it */
D = cs_transpose (N->L, 1) ;
cs_spfree (N->L) ;
N->L = cs_transpose (D, 1) ;
cs_spfree (D) ;
cs_dropzeros (N->U) ; /* drop zeros from U and sort it */
D = cs_transpose (N->U, 1) ;
cs_spfree (N->U) ;
N->U = cs_transpose (D, 1) ;
cs_spfree (D) ;
p = cs_pinv (N->pinv, n) ; /* p=pinv' */
pargout [0] = cs_mex_put_sparse (&(N->L)) ; /* return L */
pargout [1] = cs_mex_put_sparse (&(N->U)) ; /* return U */
pargout [2] = cs_mex_put_int (p, n, 1, 1) ; /* return p */
/* return Q */
if (nargout == 4) pargout [3] = cs_mex_put_int (S->q, n, 1, 0) ;
cs_nfree (N) ;
cs_sfree (S) ;
}
void mexFunction
(
int nargout,
mxArray *pargout [ ],
int nargin,
const mxArray *pargin [ ]
)
{
csi n, nel, s ;
cs *A, *AT ;
if (nargout > 1 || nargin != 3)
{
mexErrMsgTxt ("Usage: C = cs_frand(n,nel,s)") ;
}
n = mxGetScalar (pargin [0]) ;
nel = mxGetScalar (pargin [1]) ;
s = mxGetScalar (pargin [2]) ;
n = CS_MAX (1,n) ;
nel = CS_MAX (1,nel) ;
s = CS_MAX (1,s) ;
AT = cs_frand (n, nel, s) ;
A = cs_transpose (AT, 1) ;
cs_spfree (AT) ;
cs_dropzeros (A) ;
pargout [0] = cs_mex_put_sparse (&A) ;
}
/* breadth-first search for coarse decomposition (C0,C1,R1 or R0,R3,C3) */
static int cs_bfs (const cs *A, int n, int *wi, int *wj, int *queue,
const int *imatch, const int *jmatch, int mark)
{
int *Ap, *Ai, head = 0, tail = 0, j, i, p, j2 ;
cs *C ;
for (j = 0 ; j < n ; j++) /* place all unmatched nodes in queue */
{
if (imatch [j] >= 0) continue ; /* skip j if matched */
wj [j] = 0 ; /* j in set C0 (R0 if transpose) */
queue [tail++] = j ; /* place unmatched col j in queue */
}
if (tail == 0) return (1) ; /* quick return if no unmatched nodes */
C = (mark == 1) ? ((cs *) A) : cs_transpose (A, 0) ;
if (!C) return (0) ; /* bfs of C=A' to find R3,C3 from R0 */
Ap = C->p ; Ai = C->i ;
while (head < tail) /* while queue is not empty */
{
j = queue [head++] ; /* get the head of the queue */
for (p = Ap [j] ; p < Ap [j+1] ; p++)
{
i = Ai [p] ;
if (wi [i] >= 0) continue ; /* skip if i is marked */
wi [i] = mark ; /* i in set R1 (C3 if transpose) */
j2 = jmatch [i] ; /* traverse alternating path to j2 */
if (wj [j2] >= 0) continue ;/* skip j2 if it is marked */
wj [j2] = mark ; /* j2 in set C1 (R3 if transpose) */
queue [tail++] = j2 ; /* add j2 to queue */
}
}
if (mark != 1) cs_spfree (C) ; /* free A' if it was created */
return (1) ;
}
// Modified version of Tim Davis's cs_qr_mex.c file for MATLAB (in CSparse)
// Usage: [V,beta,p,R,q] = cs_qr(A) ;
SEXP dgCMatrix_QR(SEXP Ap, SEXP order)
{
CSP A = AS_CSP__(Ap), D;
int io = INTEGER(order)[0];
Rboolean verbose = (io < 0);
int m = A->m, n = A->n, ord = asLogical(order) ? 3 : 0, *p;
R_CheckStack();
if (m < n) error(_("A must have #{rows} >= #{columns}")) ;
SEXP ans = PROTECT(NEW_OBJECT(MAKE_CLASS("sparseQR")));
int *dims = INTEGER(ALLOC_SLOT(ans, Matrix_DimSym, INTSXP, 2));
dims[0] = m; dims[1] = n;
css *S = cs_sqr(ord, A, 1); /* symbolic QR ordering & analysis*/
if (!S) error(_("cs_sqr failed"));
if(verbose && S->m2 > m) // in ./cs.h , m2 := # of rows for QR, after adding fictitious rows
Rprintf("Symbolic QR(): Matrix structurally rank deficient (m2-m = %d)\n",
S->m2 - m);
csn *N = cs_qr(A, S); /* numeric QR factorization */
if (!N) error(_("cs_qr failed")) ;
cs_dropzeros(N->L); /* drop zeros from V and sort */
D = cs_transpose(N->L, 1); cs_spfree(N->L);
N->L = cs_transpose(D, 1); cs_spfree(D);
cs_dropzeros(N->U); /* drop zeros from R and sort */
D = cs_transpose(N->U, 1); cs_spfree(N->U) ;
N->U = cs_transpose(D, 1); cs_spfree(D);
m = N->L->m; /* m may be larger now */
// MM: m := S->m2 also counting the ficticious rows (Tim Davis, p.72, 74f)
p = cs_pinv(S->pinv, m); /* p = pinv' */
SET_SLOT(ans, install("V"),
Matrix_cs_to_SEXP(N->L, "dgCMatrix", 0));
Memcpy(REAL(ALLOC_SLOT(ans, install("beta"),
REALSXP, n)), N->B, n);
Memcpy(INTEGER(ALLOC_SLOT(ans, Matrix_pSym,
INTSXP, m)), p, m);
SET_SLOT(ans, install("R"),
Matrix_cs_to_SEXP(N->U, "dgCMatrix", 0));
if (ord)
Memcpy(INTEGER(ALLOC_SLOT(ans, install("q"),
INTSXP, n)), S->q, n);
else
ALLOC_SLOT(ans, install("q"), INTSXP, 0);
cs_nfree(N);
cs_sfree(S);
cs_free(p);
UNPROTECT(1);
return ans;
}
int *cs_counts(const cs *A, const int *parent, const int *post, int ata) {
int i, j, k, n, m, J, s, p, q, jleaf, *ATp, *ATi, *maxfirst, *prevleaf, *ancestor,
*head = NULL, *next = NULL, *colcount, *w, *first, *delta;
cs *AT;
if (!CS_CSC (A) || !parent || !post)
return (NULL); /* check inputs */
m = A->m;
n = A->n;
s = 4 * n + (ata ? (n + m + 1) : 0);
delta = colcount = (int *) cs_malloc(n, sizeof(int)); /* allocate result */
w = (int *) cs_malloc(s, sizeof(int)); /* get workspace */
AT = cs_transpose(A, 0); /* AT = A' */
if (!AT || !colcount || !w)
return (cs_idone(colcount, AT, w, 0));
ancestor = w;
maxfirst = w + n;
prevleaf = w + 2 * n;
first = w + 3 * n;
for (k = 0; k < s; k++)
w[k] = -1; /* clear workspace w [0..s-1] */
for (k = 0; k < n; k++) /* find first [j] */
{
j = post[k];
delta[j] = (first[j] == -1) ? 1 : 0; /* delta[j]=1 if j is a leaf */
for (; j != -1 && first[j] == -1; j = parent[j])
first[j] = k;
}
ATp = AT->p;
ATi = AT->i;
if (ata)
init_ata(AT, post, w, &head, &next);
for (i = 0; i < n; i++)
ancestor[i] = i; /* each node in its own set */
for (k = 0; k < n; k++) {
j = post[k]; /* j is the kth node in postordered etree */
if (parent[j] != -1)
delta[parent[j]]--; /* j is not a root */
for (J = HEAD (k,j); J != -1; J = NEXT (J)) /* J=j for LL'=A case */
{
for (p = ATp[J]; p < ATp[J + 1]; p++) {
i = ATi[p];
q = cs_leaf(i, j, first, maxfirst, prevleaf, ancestor, &jleaf);
if (jleaf >= 1)
delta[j]++; /* A(i,j) is in skeleton */
if (jleaf == 2)
delta[q]--; /* account for overlap in q */
}
}
if (parent[j] != -1)
ancestor[j] = parent[j];
}
for (j = 0; j < n; j++) /* sum up delta's of each child */
{
if (parent[j] != -1)
colcount[parent[j]] += colcount[j];
}
return (cs_idone(colcount, AT, w, 1)); /* success: free workspace */
}
/* C = A + triu(A,1)' */
static cs *make_sym (cs *A)
{
cs *AT, *C ;
AT = cs_transpose (A, 1) ; /* AT = A' */
cs_fkeep (AT, &dropdiag, NULL) ; /* drop diagonal entries from AT */
C = cs_add (A, AT, 1, 1) ; /* C = A+AT */
cs_spfree (AT) ;
return (C) ;
}
/* cs_qr: sparse QR factorization */
void mexFunction
(
int nargout,
mxArray *pargout [ ],
int nargin,
const mxArray *pargin [ ]
)
{
css *S ;
csn *N ;
cs Amatrix, *A, *D ;
csi m, n, order, *p ;
if (nargout > 5 || nargin != 1)
{
mexErrMsgTxt ("Usage: [V,beta,p,R,q] = cs_qr(A)") ;
}
A = cs_mex_get_sparse (&Amatrix, 0, 1, pargin [0]) ; /* get A */
m = A->m ;
n = A->n ;
if (m < n) mexErrMsgTxt ("A must have # rows >= # columns") ;
order = (nargout == 5) ? 3 : 0 ; /* determine ordering */
S = cs_sqr (order, A, 1) ; /* symbolic QR ordering & analysis*/
N = cs_qr (A, S) ; /* numeric QR factorization */
if (!N) mexErrMsgTxt ("qr failed") ;
cs_dropzeros (N->L) ; /* drop zeros from V and sort */
D = cs_transpose (N->L, 1) ;
cs_spfree (N->L) ;
N->L = cs_transpose (D, 1) ;
cs_spfree (D) ;
cs_dropzeros (N->U) ; /* drop zeros from R and sort */
D = cs_transpose (N->U, 1) ;
cs_spfree (N->U) ;
N->U = cs_transpose (D, 1) ;
cs_spfree (D) ;
m = N->L->m ; /* m may be larger now */
p = cs_pinv (S->pinv, m) ; /* p = pinv' */
pargout [0] = cs_mex_put_sparse (&(N->L)) ; /* return V */
cs_mex_put_double (n, N->B, &(pargout [1])) ; /* return beta */
pargout [2] = cs_mex_put_int (p, m, 1, 1) ; /* return p */
pargout [3] = cs_mex_put_sparse (&(N->U)) ; /* return R */
pargout [4] = cs_mex_put_int (S->q, n, 1, 0) ; /* return q */
cs_nfree (N) ;
cs_sfree (S) ;
}
/* Computes: y <- alpha A^T*x + beta y */
int mfiles_dgemv1(double alpha, const mxArray *A, const mxArray *x,
double beta, mxArray *y) {
size_t rA = mxGetM(A);
size_t cA = mxGetN(A);
size_t rx = mxGetM(x);
size_t cx = mxGetN(x);
size_t ry = mxGetM(y);
size_t cy = mxGetN(y);
if (mxIsSparse(x) || mxIsSparse(y)) {
mexErrMsgIdAndTxt("mfiles:BadType",
"Sparse vectors are not supported.");
}
if (mxIsComplex(A) || mxIsComplex(x) || mxIsComplex(y)) {
mexErrMsgIdAndTxt("mfiles:BadType",
"Complex data is not supported.");
}
if ((rA != rx) || (cA != ry) || (cx != 1) || (cy != 1)) {
mexErrMsgIdAndTxt("mfiles:BadDim",
"Dimensions of matrices do not match.");
}
if (mxIsSparse(A)) {
double *px = mxGetPr(x);
double *py = mxGetPr(y);
double *pz = mxCalloc(ry, sizeof (double));
cs *cs_A = cs_calloc(1, sizeof (cs));
mfiles_mx2cs(A, cs_A);
/* Transpose A */
cs *cs_AT = cs_transpose(cs_A, 1);
/* Compute z <- A^T*x */
cs_gaxpy(cs_AT, px, pz);
/* Compute y <- beta y */
cblas_dscal(ry, beta, py, 1);
/* Compute y <- alpha*z+y */
cblas_daxpy(ry, alpha, pz, 1, py, 1);
cs_free(cs_A); /* Check this cs_free and cs_spfree ? */
cs_spfree(cs_AT);
mxFree(pz);
} else {
double *pA = mxGetPr(A);
double *px = mxGetPr(x);
double *py = mxGetPr(y);
cblas_dgemv(CblasRowMajor, CblasTrans,
rA, cA, alpha, pA, rA, px, 1, beta, py, 1);
}
return EXIT_SUCCESS;
}
CSparseMatrix* NM_csc_trans(NumericsMatrix* A)
{
if(!NM_sparse(A)->trans_csc)
{
assert(A->matrix2);
A->matrix2->trans_csc = cs_transpose(NM_csc(A), 1); /* value = 1
* ->
* allocation */
}
return A->matrix2->trans_csc;
}
/* x=A\b where A can be rectangular; b overwritten with solution */
int cs_qrsol (int order, const cs *A, double *b)
{
double *x ;
css *S ;
csn *N ;
cs *AT = NULL ;
int k, m, n, ok ;
if (!CS_CSC (A) || !b) return (0) ; /* check inputs */
n = A->n ;
m = A->m ;
if (m >= n)
{
S = cs_sqr (order, A, 1) ; /* ordering and symbolic analysis */
N = cs_qr (A, S) ; /* numeric QR factorization */
x = cs_calloc (S ? S->m2 : 1, sizeof (double)) ; /* get workspace */
ok = (S && N && x) ;
if (ok)
{
cs_ipvec (S->pinv, b, x, m) ; /* x(0:m-1) = b(p(0:m-1) */
for (k = 0 ; k < n ; k++) /* apply Householder refl. to x */
{
cs_happly (N->L, k, N->B [k], x) ;
}
cs_usolve (N->U, x) ; /* x = R\x */
cs_ipvec (S->q, x, b, n) ; /* b(q(0:n-1)) = x(0:n-1) */
}
}
else
{
AT = cs_transpose (A, 1) ; /* Ax=b is underdetermined */
S = cs_sqr (order, AT, 1) ; /* ordering and symbolic analysis */
N = cs_qr (AT, S) ; /* numeric QR factorization of A' */
x = cs_calloc (S ? S->m2 : 1, sizeof (double)) ; /* get workspace */
ok = (AT && S && N && x) ;
if (ok)
{
cs_pvec (S->q, b, x, m) ; /* x(q(0:m-1)) = b(0:m-1) */
cs_utsolve (N->U, x) ; /* x = R'\x */
for (k = m-1 ; k >= 0 ; k--) /* apply Householder refl. to x */
{
cs_happly (N->L, k, N->B [k], x) ;
}
cs_pvec (S->pinv, x, b, n) ; /* b(0:n-1) = x(p(0:n-1)) */
}
}
cs_free (x) ;
cs_sfree (S) ;
cs_nfree (N) ;
cs_spfree (AT) ;
return (ok) ;
}
/* find a maximum transveral */
int *cs_maxtrans (const cs *A, int seed) /*[jmatch [0..m-1]; imatch [0..n-1]]*/
{
int i, j, k, n, m, p, n2 = 0, m2 = 0, *Ap, *jimatch, *w, *cheap, *js, *is,
*ps, *Ai, *Cp, *jmatch, *imatch, *q ;
cs *C ;
if (!CS_CSC (A)) return (NULL) ; /* check inputs */
n = A->n ; m = A->m ; Ap = A->p ; Ai = A->i ;
w = jimatch = cs_calloc (m+n, sizeof (int)) ; /* allocate result */
if (!jimatch) return (NULL) ;
for (k = 0, j = 0 ; j < n ; j++) /* count nonempty rows and columns */
{
n2 += (Ap [j] < Ap [j+1]) ;
for (p = Ap [j] ; p < Ap [j+1] ; p++)
{
w [Ai [p]] = 1 ;
k += (j == Ai [p]) ; /* count entries already on diagonal */
}
}
if (k == CS_MIN (m,n)) /* quick return if diagonal zero-free */
{
jmatch = jimatch ; imatch = jimatch + m ;
for (i = 0 ; i < k ; i++) jmatch [i] = i ;
for ( ; i < m ; i++) jmatch [i] = -1 ;
for (j = 0 ; j < k ; j++) imatch [j] = j ;
for ( ; j < n ; j++) imatch [j] = -1 ;
return (cs_idone (jimatch, NULL, NULL, 1)) ;
}
for (i = 0 ; i < m ; i++) m2 += w [i] ;
C = (m2 < n2) ? cs_transpose (A,0) : ((cs *) A) ; /* transpose if needed */
if (!C) return (cs_idone (jimatch, (m2 < n2) ? C : NULL, NULL, 0)) ;
n = C->n ; m = C->m ; Cp = C->p ;
jmatch = (m2 < n2) ? jimatch + n : jimatch ;
imatch = (m2 < n2) ? jimatch : jimatch + m ;
w = cs_malloc (5*n, sizeof (int)) ; /* get workspace */
if (!w) return (cs_idone (jimatch, (m2 < n2) ? C : NULL, w, 0)) ;
cheap = w + n ; js = w + 2*n ; is = w + 3*n ; ps = w + 4*n ;
for (j = 0 ; j < n ; j++) cheap [j] = Cp [j] ; /* for cheap assignment */
for (j = 0 ; j < n ; j++) w [j] = -1 ; /* all columns unflagged */
for (i = 0 ; i < m ; i++) jmatch [i] = -1 ; /* nothing matched yet */
q = cs_randperm (n, seed) ; /* q = random permutation */
for (k = 0 ; k < n ; k++) /* augment, starting at column q[k] */
{
cs_augment (q ? q [k]: k, C, jmatch, cheap, w, js, is, ps) ;
}
cs_free (q) ;
for (j = 0 ; j < n ; j++) imatch [j] = -1 ; /* find row match */
for (i = 0 ; i < m ; i++) if (jmatch [i] >= 0) imatch [jmatch [i]] = i ;
return (cs_idone (jimatch, (m2 < n2) ? C : NULL, w, 1)) ;
}
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 */
}
/* find the strongly connected components of a square matrix */
csd *cs_scc (cs *A) /* matrix A temporarily modified, then restored */
{
int n, i, k, b, nb = 0, top, *xi, *pstack, *p, *r, *Ap, *ATp, *rcopy, *Blk ;
cs *AT ;
csd *D ;
if (!CS_CSC (A)) return (NULL) ; /* check inputs */
n = A->n ; Ap = A->p ;
D = cs_dalloc (n, 0) ; /* allocate result */
AT = cs_transpose (A, 0) ; /* AT = A' */
xi = cs_malloc (2*n+1, sizeof (int)) ; /* get workspace */
if (!D || !AT || !xi) return (cs_ddone (D, AT, xi, 0)) ;
Blk = xi ; rcopy = pstack = xi + n ;
p = D->p ; r = D->r ; ATp = AT->p ;
top = n ;
for (i = 0 ; i < n ; i++) /* first dfs(A) to find finish times (xi) */
{
if (!CS_MARKED (Ap, i)) top = cs_dfs (i, A, top, xi, pstack, NULL) ;
}
for (i = 0 ; i < n ; i++) CS_MARK (Ap, i) ; /* restore A; unmark all nodes*/
top = n ;
nb = n ;
for (k = 0 ; k < n ; k++) /* dfs(A') to find strongly connnected comp */
{
i = xi [k] ; /* get i in reverse order of finish times */
if (CS_MARKED (ATp, i)) continue ; /* skip node i if already ordered */
r [nb--] = top ; /* node i is the start of a component in p */
top = cs_dfs (i, AT, top, p, pstack, NULL) ;
}
r [nb] = 0 ; /* first block starts at zero; shift r up */
for (k = nb ; k <= n ; k++) r [k-nb] = r [k] ;
D->nb = nb = n-nb ; /* nb = # of strongly connected components */
for (b = 0 ; b < nb ; b++) /* sort each block in natural order */
{
for (k = r [b] ; k < r [b+1] ; k++) Blk [p [k]] = b ;
}
for (b = 0 ; b <= nb ; b++) rcopy [b] = r [b] ;
for (i = 0 ; i < n ; i++) p [rcopy [Blk [i]]++] = i ;
return (cs_ddone (D, AT, xi, 1)) ;
}
void bi_conjugate_gradient_sparse(cs *A, double *b, double* x, int n, double itol){
int i,j,iter;
double rho,rho1,alpha,beta,omega;
double r[n], r_t[n];
double z[n], z_t[n];
double q[n], q_t[n], temp_q[n];
double p[n], p_t[n], temp_p[n];
double res[n]; //NA VGEI!
double precond[n];
//Initializations
memset(precond, 0, n*sizeof(double));
memset(r, 0, n*sizeof(double));
memset(r_t, 0, n*sizeof(double));
memset(z, 0, n*sizeof(double));
memset(z_t, 0, n*sizeof(double));
memset(q, 0, n*sizeof(double));
memset(q_t, 0, n*sizeof(double));
memset(temp_q, 0, n*sizeof(double));
memset(p, 0, n*sizeof(double));
memset(p_t, 0, n*sizeof(double));
memset(temp_p, 0, n*sizeof(double));
memset(res, 0, n*sizeof(double));
/* Preconditioner */
double max;
int pp;
for(j = 0; j < n; ++j){
for(pp = A->p[j], max = fabs(A->x[pp]); pp < A->p[j+1]; pp++)
if(fabs(A->x[pp]) > max) //vriskei to diagonio stoixeio
max = fabs(A->x[pp]);
precond[j] = 1/max;
}
cs *AT = cs_transpose (A, 1) ;
cblas_dcopy (n, x, 1, res, 1);
//r=b-Ax
cblas_dcopy (n, b, 1, r, 1);
memset(p, 0, n*sizeof(double));
cs_gaxpy (A, x, p);
for(i=0;i<n;i++){
r[i]=r[i]-p[i];
}
cblas_dcopy (n, r, 1, r_t, 1);
double r_norm = cblas_dnrm2 (n, r, 1);
double b_norm = cblas_dnrm2 (n, b, 1);
if(!b_norm)
b_norm = 1;
iter = 0;
while( r_norm/b_norm > itol && iter < n ){
iter++;
cblas_dcopy (n, r, 1, z, 1); //gia na min allaksei o r
cblas_dcopy (n, r_t, 1, z_t, 1); //gia na min allaksei o r_t
for(i=0;i<n;i++){
z[i]=precond[i]*z[i];
z_t[i]=precond[i]*z_t[i];
}
rho = cblas_ddot (n, z, 1, r_t, 1);
if (fpclassify(fabs(rho)) == FP_ZERO){
printf("RHO aborting Bi-CG due to EPS...\n");
exit(42);
}
if (iter == 1){
cblas_dcopy (n, z, 1, p, 1);
cblas_dcopy (n, z_t, 1, p_t, 1);
}
else{
//p = z + beta*p;
beta = rho/rho1;
cblas_dscal (n, beta, p, 1); //rescale p by beta
cblas_dscal (n, beta, p_t, 1); //rescale p_t by beta
cblas_daxpy (n, 1, z, 1, p, 1); //p = 1*z + p
cblas_daxpy (n, 1, z_t, 1, p_t, 1); //p_t = 1*z_t + p_t
}
rho1 = rho;
//q = Ap
//q_t = trans(A)*p_t
memset(q, 0, n*sizeof(double));
cs_gaxpy (A, p, q);
memset(q_t, 0, n*sizeof(double));
cs_gaxpy(AT, p_t, q_t);
omega = cblas_ddot (n, p_t, 1, q, 1);
if (fpclassify(fabs(omega)) == FP_ZERO){
printf("OMEGA aborting Bi-CG due to EPS...\n");
exit(42);
}
alpha = rho/omega;
//x = x + aplha*p;
cblas_dcopy (n, p, 1, temp_p, 1);
cblas_dscal (n, alpha, temp_p, 1);//rescale by aplha
cblas_daxpy (n, 1, temp_p, 1, res, 1);// sum x = 1*x + temp_p
//R = R - aplha*Q;
cblas_dcopy (n, q, 1, temp_q, 1);
cblas_dscal (n, -alpha, temp_q, 1);//rescale by -aplha
cblas_daxpy (n, 1, temp_q, 1, r, 1);// sum r = 1*r - temp_p
//~r=~r-alpha*~q
cblas_dcopy (n, q_t, 1, temp_q, 1);
cblas_dscal (n, -alpha, temp_q, 1);//rescale by -aplha
cblas_daxpy (n, 1, temp_q, 1, r_t, 1);// sum r = 1*r - temp_p
r_norm = cblas_dnrm2 (n, r, 1); //next step
}
cblas_dcopy (n, res, 1, x, 1);
cs_spfree(AT);
}
/* Cholesky update/downdate */
int demo3 (problem *Prob)
{
cs *A, *C, *W = NULL, *WW, *WT, *E = NULL, *W2 ;
int n, k, *Li, *Lp, *Wi, *Wp, p1, p2, *p = NULL, ok ;
double *b, *x, *resid, *y = NULL, *Lx, *Wx, s, t, t1 ;
css *S = NULL ;
csn *N = NULL ;
if (!Prob || !Prob->sym || Prob->A->n == 0) return (0) ;
A = Prob->A ; C = Prob->C ; b = Prob->b ; x = Prob->x ; resid = Prob->resid;
n = A->n ;
if (!Prob->sym || n == 0) return (1) ;
rhs (x, b, n) ; /* compute right-hand side */
printf ("\nchol then update/downdate ") ;
print_order (1) ;
y = cs_malloc (n, sizeof (double)) ;
t = tic () ;
S = cs_schol (1, C) ; /* symbolic Chol, amd(A+A') */
printf ("\nsymbolic chol time %8.2f\n", toc (t)) ;
t = tic () ;
N = cs_chol (C, S) ; /* numeric Cholesky */
printf ("numeric chol time %8.2f\n", toc (t)) ;
if (!S || !N || !y) return (done3 (0, S, N, y, W, E, p)) ;
t = tic () ;
cs_ipvec (S->pinv, b, y, n) ; /* y = P*b */
cs_lsolve (N->L, y) ; /* y = L\y */
cs_ltsolve (N->L, y) ; /* y = L'\y */
cs_pvec (S->pinv, y, x, n) ; /* x = P'*y */
printf ("solve chol time %8.2f\n", toc (t)) ;
printf ("original: ") ;
print_resid (1, C, x, b, resid) ; /* print residual */
k = n/2 ; /* construct W */
W = cs_spalloc (n, 1, n, 1, 0) ;
if (!W) return (done3 (0, S, N, y, W, E, p)) ;
Lp = N->L->p ; Li = N->L->i ; Lx = N->L->x ;
Wp = W->p ; Wi = W->i ; Wx = W->x ;
Wp [0] = 0 ;
p1 = Lp [k] ;
Wp [1] = Lp [k+1] - p1 ;
s = Lx [p1] ;
srand (1) ;
for ( ; p1 < Lp [k+1] ; p1++)
{
p2 = p1 - Lp [k] ;
Wi [p2] = Li [p1] ;
Wx [p2] = s * rand () / ((double) RAND_MAX) ;
}
t = tic () ;
ok = cs_updown (N->L, +1, W, S->parent) ; /* update: L*L'+W*W' */
t1 = toc (t) ;
printf ("update: time: %8.2f\n", t1) ;
if (!ok) return (done3 (0, S, N, y, W, E, p)) ;
t = tic () ;
cs_ipvec (S->pinv, b, y, n) ; /* y = P*b */
cs_lsolve (N->L, y) ; /* y = L\y */
cs_ltsolve (N->L, y) ; /* y = L'\y */
cs_pvec (S->pinv, y, x, n) ; /* x = P'*y */
t = toc (t) ;
p = cs_pinv (S->pinv, n) ;
W2 = cs_permute (W, p, NULL, 1) ; /* E = C + (P'W)*(P'W)' */
WT = cs_transpose (W2,1) ;
WW = cs_multiply (W2, WT) ;
cs_spfree (WT) ;
cs_spfree (W2) ;
E = cs_add (C, WW, 1, 1) ;
cs_spfree (WW) ;
if (!E || !p) return (done3 (0, S, N, y, W, E, p)) ;
printf ("update: time: %8.2f (incl solve) ", t1+t) ;
print_resid (1, E, x, b, resid) ; /* print residual */
cs_nfree (N) ; /* clear N */
t = tic () ;
N = cs_chol (E, S) ; /* numeric Cholesky */
if (!N) return (done3 (0, S, N, y, W, E, p)) ;
cs_ipvec (S->pinv, b, y, n) ; /* y = P*b */
cs_lsolve (N->L, y) ; /* y = L\y */
cs_ltsolve (N->L, y) ; /* y = L'\y */
cs_pvec (S->pinv, y, x, n) ; /* x = P'*y */
t = toc (t) ;
printf ("rechol: time: %8.2f (incl solve) ", t) ;
print_resid (1, E, x, b, resid) ; /* print residual */
t = tic () ;
ok = cs_updown (N->L, -1, W, S->parent) ; /* downdate: L*L'-W*W' */
t1 = toc (t) ;
if (!ok) return (done3 (0, S, N, y, W, E, p)) ;
printf ("downdate: time: %8.2f\n", t1) ;
t = tic () ;
cs_ipvec (S->pinv, b, y, n) ; /* y = P*b */
cs_lsolve (N->L, y) ; /* y = L\y */
cs_ltsolve (N->L, y) ; /* y = L'\y */
cs_pvec (S->pinv, y, x, n) ; /* x = P'*y */
t = toc (t) ;
printf ("downdate: time: %8.2f (incl solve) ", t1+t) ;
print_resid (1, C, x, b, resid) ; /* print residual */
return (done3 (1, S, N, y, W, E, p)) ;
}
/**
* @brief Main wrapper for fitting a trendfilter model.
* Takes as input either a sequence of lambda tuning parameters, or the number
* of desired lambda values. In the latter case the function will also calculate
* a lambda sequence. The user must supply allocated memory to store the output,
* with the function itself returning only @c void. For default values, and an
* example of how to call the function, see the function tf_admm_default.
*
* @param y a vector of responses
* @param x a vector of response locations; must be in increasing order
* @param w a vector of sample weights
* @param n the length of y, x, and w
* @param k degree of the trendfilter; i.e., k=1 linear
* @param family family code for the type of fit; family=0 for OLS
* @param max_iter maximum number of ADMM interations; ignored for k=0
* @param lam_flag 0/1 flag for whether lambda sequence needs to be estimated
* @param lambda either a sequence of lambda when lam_flag=0, or empty
* allocated space if lam_flag=1
* @param nlambda number of lambda values; need for both lam_flag=0 and 1
* @param lambda_min_ratio minimum ratio between min and max lambda; ignored for lam_flag=0
* @param beta allocated space of size n*nlambda to store the output coefficents
* @param obj allocated space of size max_iter*nlambda to store the objective
* @param iter allocated space of size nlambda to store the number of iterations
* @param status allocated space of size nlambda to store the status of each run
* @param rho tuning parameter for the ADMM algorithm
* @param obj_tol stopping criteria tolerance
* @param alpha_ls for family != 0, line search tuning parameter
* @param gamma_ls for family != 0, line search tuning parameter
* @param max_iter_ls for family != 0, max number of iterations in line search
* @param max_iter_newton for family != 0, max number of iterations in inner ADMM
* @param verbose 0/1 flag for printing progress
* @return void
* @see tf_admm_default
*/
void tf_admm (double * y, double * x, double * w, int n, int k, int family,
int max_iter, int lam_flag, double * lambda,
int nlambda, double lambda_min_ratio, double * beta,
double * obj, int * iter, int * status, double rho,
double obj_tol, double alpha_ls, double gamma_ls,
int max_iter_ls, int max_iter_newton, int verbose)
{
int i;
int j;
double max_lam;
double min_lam;
double * temp_n;
double * beta_max;
double * alpha;
double * u;
cs * D;
cs * Dt;
cs * Dk;
cs * Dkt;
cs * DktDk;
gqr * Dt_qr;
gqr * Dkt_qr;
beta_max = (double *) malloc(n * sizeof(double));
temp_n = (double *) malloc(n * sizeof(double));
alpha = (double *) malloc(n * sizeof(double)); /* we use extra buffer (n vs n-k) */
u = (double *) malloc(n * sizeof(double)); /* we use extra buffer (n vs n-k) */
/* Assume w does not have zeros */
for(i = 0; i < n; i++) temp_n[i] = 1/sqrt(w[i]);
D = tf_calc_dk(n, k+1, x);
Dk = tf_calc_dktil(n, k, x);
Dt = cs_transpose(D, 1);
diag_times_sparse(Dt, temp_n); /* Dt = W^{-1/2} Dt */
Dkt = cs_transpose(Dk, 1);
Dt_qr = glmgen_qr(Dt);
Dkt_qr = glmgen_qr(Dkt);
DktDk = cs_multiply(Dkt,Dk);
/* Determine the maximum lambda in the path, and initiate the path if needed
* using the input lambda_min_ratio and equally spaced log points.
*/
max_lam = tf_maxlam(n, y, Dt_qr, w);
if (!lam_flag)
{
min_lam = max_lam * lambda_min_ratio;
lambda[0] = max_lam;
for (i = 1; i < nlambda; i++)
lambda[i] = exp((log(max_lam) * (nlambda - i -1) + log(min_lam) * i) / (nlambda-1));
}
rho = rho * pow( (x[n-1] - x[0])/n, (double)k);
/* Initiate alpha and u for a warm start */
if (lambda[0] < max_lam * 1e-5)
{
for (i = 0; i < n - k; i++)
{
alpha[i] = 0;
u[i] = 0;
}
} else {
/* beta_max */
for (i = 0; i < n; i++) temp_n[i] = -sqrt(w[i]) * y[i];
glmgen_qrsol (Dt_qr, temp_n);
for (i = 0; i < n; i++) beta_max[i] = 0;
cs_gaxpy(Dt, temp_n, beta_max);
/* Dt has a W^{-1/2}, so in the next step divide by sqrt(w) instead of w. */
for (i = 0; i < n; i++) beta_max[i] = y[i] - beta_max[i]/sqrt(w[i]);
/* alpha_max */
tf_dxtil(x, n, k, beta_max, alpha);
/* u_max */
switch (family)
{
case FAMILY_GAUSSIAN:
for (i = 0; i < n; i++) u[i] = w[i] * (beta_max[i] - y[i]) / (rho * lambda[0]);
break;
case FAMILY_LOGISTIC:
for (i = 0; i < n; i++) {
u[i] = logi_b2(beta_max[i]) * w[i] * (beta_max[i] - y[i]) / (rho * lambda[0]);
}
break;
case FAMILY_POISSON:
for (i = 0; i < n; i++) {
u[i] = pois_b2(beta_max[i]) * w[i] *(beta_max[i] - y[i]) / (rho * lambda[0]);
}
break;
default:
for (i = 0; i < nlambda; i++) status[i] = 2;
return;
}
glmgen_qrsol (Dkt_qr, u);
}
/* Iterate lower level functions over all lambda values;
* the alpha and u vectors get used each time of subsequent
* warm starts
*/
for (i = 0; i < nlambda; i++)
{
/* warm start */
double * beta_init = (i == 0) ? beta_max : beta + (i-1)*n;
for(j = 0; j < n; j++) beta[i*n + j] = beta_init[j];
switch (family)
{
case FAMILY_GAUSSIAN:
tf_admm_gauss(y, x, w, n, k, max_iter, lambda[i], beta+i*n, alpha,
u, obj+i*max_iter, iter+i, rho * lambda[i], obj_tol,
DktDk, verbose);
break;
case FAMILY_LOGISTIC:
tf_admm_glm(y, x, w, n, k, max_iter, lambda[i], beta+i*n, alpha, u, obj+i*max_iter, iter+i,
rho * lambda[i], obj_tol, alpha_ls, gamma_ls, max_iter_ls, max_iter_newton,
DktDk, &logi_b, &logi_b1, &logi_b2, verbose);
break;
case FAMILY_POISSON:
tf_admm_glm(y, x, w, n, k, max_iter, lambda[i], beta+i*n, alpha, u, obj+i*max_iter, iter+i,
rho * lambda[i], obj_tol, alpha_ls, gamma_ls, max_iter_ls, max_iter_newton,
DktDk, &pois_b, &pois_b1, &pois_b2, verbose);
break;
}
/* If there any NaNs in beta: reset beta, alpha, u */
if(has_nan(beta + i * n, n))
{
for(j = 0; j < n; j++) beta[i*n + j] = 0;
for(j = 0; j < n-k; j++) { alpha[j] = 0; u[j] = 0; }
status[i] = 1;
printf("Numerical error in lambda[%d]=%f",i,lambda[i]);
}
}
cs_spfree(D);
cs_spfree(Dt);
cs_spfree(Dk);
cs_spfree(Dkt);
cs_spfree(DktDk);
glmgen_gqr_free(Dt_qr);
glmgen_gqr_free(Dkt_qr);
free(temp_n);
free(beta_max);
free(alpha);
free(u);
}
/**
* @brief Main wrapper for fitting a trendfilter model.
* Takes as input either a sequence of lambda tuning parameters, or the number
* of desired lambda values. In the latter case the function will also calculate
* a lambda sequence. The user must supply allocated memory to store the output,
* with the function itself returning only @c void. For default values, and an
* example of how to call the function, see the function tf_admm_default.
*
* @param x a vector of data locations; must be in increasing order
* @param y a vector of responses
* @param w a vector of sample weights
* @param n the length of x, y, and w
* @param k polynomial degree of the fitted trend; i.e., k=1 for linear
* @param family family code for the type of fit; family=0 for OLS
* @param max_iter maximum number of ADMM interations; ignored for k=0
* @param beta0 initialization value of beta for first lambda; ignored if NULL
* @param lam_flag 0/1 flag for whether lambda sequence needs to be estimated
* @param lambda either a sequence of lambda when lam_flag=0, or empty
* allocated space if lam_flag=1
* @param nlambda number of lambda values; need for both lam_flag=0 and 1
* @param lambda_min_ratio minimum ratio between min and max lambda; ignored for lam_flag=0
* @param df allocated space of nlambda to store the output df values
* @param beta allocated space of size n*nlambda to store the output coefficents
* @param obj allocated space of size max_iter*nlambda to store the objective
* @param iter allocated space of size nlambda to store the number of iterations
* @param status allocated space of size nlambda to store the status of each run
* @param rho tuning parameter for the ADMM algorithm
* @param obj_tol stopping criteria tolerance
* @param obj_tol_newton for family != 0, stopping criteria tolerance for prox Newton
* @param alpha_ls for family != 0, line search tuning parameter
* @param gamma_ls for family != 0, line search tuning parameter
* @param max_iter_ls for family != 0, max number of iterations in line search
* @param max_iter_newton for family != 0, max number of iterations in inner ADMM
* @param verbose 0/1 flag for printing progress
* @return void
* @see tf_admm_default
*/
void tf_admm ( double * x, double * y, double * w, int n, int k, int family,
int max_iter, double * beta0, int lam_flag, double * lambda,
int nlambda, double lambda_min_ratio, int tridiag, int * df,
double * beta, double * obj, int * iter, int * status,
double rho, double obj_tol, double obj_tol_newton, double alpha_ls, double gamma_ls,
int max_iter_ls, int max_iter_newton, int verbose)
{
int i;
int j;
int numDualVars;
double max_lam;
double min_lam;
double * temp_n;
double * beta_max;
double * alpha;
double * u;
double * A0;
double * A1;
double * v;
cs * D;
cs * Dt;
cs * Dk;
cs * Dkt;
cs * DktDk;
gqr * Dt_qr;
gqr * Dkt_qr;
beta_max = (double *) malloc(n * sizeof(double));
temp_n = (double *) malloc(n * sizeof(double));
v = (double *) malloc(n * sizeof(double));
numDualVars = tridiag ? k : 1;
/* we use extra buffer below (n vs n-k) */
alpha = (double *) malloc(n * numDualVars * sizeof(double));
u = (double *) malloc(n * numDualVars * sizeof(double));
/* Assume w does not have zeros */
for (i = 0; i < n; i++) temp_n[i] = 1/sqrt(w[i]);
D = tf_calc_dk(n, k+1, x);
Dk = tf_calc_dktil(n, k, x);
Dt = cs_transpose(D, 1);
diag_times_sparse(Dt, temp_n); /* Dt = W^{-1/2} Dt */
Dkt = cs_transpose(Dk, 1);
Dt_qr = glmgen_qr(Dt);
Dkt_qr = glmgen_qr(Dkt);
DktDk = cs_multiply(Dkt,Dk);
/* Determine the maximum lambda in the path */
max_lam = tf_maxlam(n, y, Dt_qr, w);
/* and if it is too small, return a trivial solution for Gaussian case */
if (family == FAMILY_GAUSSIAN) {
if (max_lam < 1e-12) {
for (i=0; i<nlambda; i++) {
for (j=0; j<n; j++) beta[i*n+j] = y[j];
obj[i*(max_iter+1)] = 0;
df[i] = n;
}
cs_spfree(D);
cs_spfree(Dt);
cs_spfree(Dk);
cs_spfree(Dkt);
cs_spfree(DktDk);
glmgen_gqr_free(Dt_qr);
glmgen_gqr_free(Dkt_qr);
free(temp_n);
free(beta_max);
free(alpha);
free(u);
return;
}
}
else {
max_lam += 1;
}
/* Initiate the path if needed using the input lambda_min_ratio and
* equally spaced points in log space. */
if (!lam_flag) seq_logspace(max_lam,lambda_min_ratio,nlambda,lambda);
/* Augmented Lagrangian parameter */
rho = rho * pow((x[n-1] - x[0])/(double)(n-1), (double)k);
/* Initiate alpha and u for a warm start */
if (lambda[0] < max_lam * 1e-5)
for (i = 0; i < n - k; i++) alpha[i] = u[i] = 0;
else {
/* beta_max */
if (beta0 == NULL)
calc_beta_max(y,w,n,Dt_qr,Dt,temp_n,beta_max);
else
memcpy(beta_max, beta0, n*sizeof(double));
/* Check if beta = weighted mean(y) is better than beta */
double yc = weighted_mean(y,w,n);
for (i = 0; i < n; i++) temp_n[i] = yc;
double obj1 = tf_obj(x,y,w,n,k,max_lam,family,beta_max,v);
double obj2 = tf_obj(x,y,w,n,k,max_lam,family,temp_n,v);
if(obj2 < obj1) memcpy(beta_max, temp_n, n*sizeof(double));
/* alpha_max */
if (tridiag && k>0)
{
tf_dx1(x, n, 1, beta_max, alpha + (n*k-n));
for (j=k-1; j >= 1; j--)
tf_dx1(x, n, k-j+1, alpha + (n*j), alpha + (n*j-n));
}
else if (k>0)
tf_dxtil(x, n, k, beta_max, alpha);
/* u_max */
if (tridiag)
for (j=0; j<k; j++) memset(u + (n*j), 0, (n-k+j) * sizeof(double));
else {
for (i = 0; i < n; i++)
u[i] = w[i] * (beta_max[i] - y[i]) / (rho * lambda[0]);
if(family == FAMILY_LOGISTIC)
for (i = 0; i < n; i++) u[i] *= logi_b2(beta_max[i]);
else if(family == FAMILY_POISSON)
for (i = 0; i < n; i++) u[i] *= pois_b2(beta_max[i]);
glmgen_qrsol (Dkt_qr, u);
// for (i = 0; i < n-k; i++) u[i] = 0;
}
}
if (tridiag && k>0)
{
/* Setup tridiagonal systems */
A0 = (double*) malloc(n*k*sizeof(double));
A1 = (double*) malloc(n*k*sizeof(double));
for (j=2; j <= k; j++)
{
form_tridiag(x, n, k-j+2, 1, 1, A0+(n*j-n), A1+(n*j-n));
}
}
/* Iterate lower level functions over all lambda values;
* the alpha and u vectors get used each time of subsequent
* warm starts */
for (i = 0; i < nlambda; i++)
{
/* warm start */
double *beta_init = (i == 0) ? beta_max : beta + (i-1)*n;
for(j = 0; j < n; j++) beta[i*n + j] = beta_init[j];
if (tridiag)
{
form_tridiag(x, n, 1, rho * lambda[i], 0, A0, A1);
for (j=0; j < n; j++) A0[j] = A0[j] + w[j];
}
switch (family) {
case FAMILY_GAUSSIAN:
if (tridiag)
tf_admm_gauss_tri(x, y, w, n, k, max_iter, lambda[i], df+i, beta+i*n,
alpha, u, obj+i*(1+max_iter), iter+i, rho * lambda[i],
obj_tol, A0, A1, verbose);
else
tf_admm_gauss(x, y, w, n, k, max_iter, lambda[i], df+i, beta+i*n,
alpha, u, obj+i*(1+max_iter), iter+i, rho * lambda[i],
obj_tol, DktDk, verbose);
break;
case FAMILY_LOGISTIC:
tf_admm_glm(x, y, w, n, k, max_iter, lambda[i], tridiag, df+i, beta+i*n,
alpha, u, obj+i*(1+max_iter_newton), iter+i, rho * lambda[i], obj_tol,
obj_tol_newton, alpha_ls, gamma_ls, max_iter_ls, max_iter_newton,
DktDk, A0, A1, &logi_b, &logi_b1, &logi_b2, verbose);
break;
case FAMILY_POISSON:
tf_admm_glm(x, y, w, n, k, max_iter, lambda[i], tridiag, df+i, beta+i*n,
alpha, u, obj+i*(1+max_iter_newton), iter+i, rho * lambda[i], obj_tol,
obj_tol_newton, alpha_ls, gamma_ls, max_iter_ls, max_iter_newton,
DktDk, A0, A1, &pois_b, &pois_b1, &pois_b2, verbose);
break;
default:
printf("Unknown family, stopping calculation.\n");
status[i] = 2;
}
/* If there any NaNs in beta: reset beta, alpha, u */
if (has_nan(beta + i*n, n))
{
double yc = weighted_mean(y,w,n);
switch(family) {
case FAMILY_POISSON:
yc = (yc > 0) ? log(yc) : -DBL_MAX;
break;
case FAMILY_LOGISTIC:
yc = (yc > 0) ? ( yc < 1 ? log(yc/(1-yc)) : DBL_MAX) : -DBL_MAX;
break;
default: break;
}
for (j = 0; j < n; j++) beta[i*n + j] = yc;
for (j = 0; j < n-k; j++) alpha[j] = 0;
for (j = 0; j < n; j++) u[j] = w[j] * (beta[i*n+j] - y[j]) / (rho * lambda[i]);
glmgen_qrsol (Dkt_qr, u);
if (tridiag) for (j = 0; j < n*k; j++) alpha[j] = u[j] = 0;
status[i] = 1;
}
}
cs_spfree(D);
cs_spfree(Dt);
cs_spfree(Dk);
cs_spfree(Dkt);
cs_spfree(DktDk);
glmgen_gqr_free(Dt_qr);
glmgen_gqr_free(Dkt_qr);
free(beta_max);
free(temp_n);
free(alpha);
free(u);
free(v);
if (tridiag && k>0)
{
free(A0);
free(A1);
}
}
/* Modified version of Tim Davis's cs_lu_mex.c file for MATLAB */
void install_lu(SEXP Ap, int order, double tol, Rboolean err_sing, Rboolean keep_dimnms)
{
// (order, tol) == (1, 1) by default, when called from R.
SEXP ans;
css *S;
csn *N;
int n, *p, *dims;
CSP A = AS_CSP__(Ap), D;
R_CheckStack();
n = A->n;
if (A->m != n)
error(_("LU decomposition applies only to square matrices"));
if (order) { /* not using natural order */
order = (tol == 1) ? 2 /* amd(S'*S) w/dense rows or I */
: 1; /* amd (A+A'), or natural */
}
S = cs_sqr(order, A, /*qr = */ 0); /* symbolic ordering */
N = cs_lu(A, S, tol); /* numeric factorization */
if (!N) {
if(err_sing)
error(_("cs_lu(A) failed: near-singular A (or out of memory)"));
else {
/* No warning: The useR should be careful :
* Put NA into "LU" factor */
set_factors(Ap, ScalarLogical(NA_LOGICAL), "LU");
return;
}
}
cs_dropzeros(N->L); /* drop zeros from L and sort it */
D = cs_transpose(N->L, 1);
cs_spfree(N->L);
N->L = cs_transpose(D, 1);
cs_spfree(D);
cs_dropzeros(N->U); /* drop zeros from U and sort it */
D = cs_transpose(N->U, 1);
cs_spfree(N->U);
N->U = cs_transpose(D, 1);
cs_spfree(D);
p = cs_pinv(N->pinv, n); /* p=pinv' */
ans = PROTECT(NEW_OBJECT(MAKE_CLASS("sparseLU")));
dims = INTEGER(ALLOC_SLOT(ans, Matrix_DimSym, INTSXP, 2));
dims[0] = n; dims[1] = n;
SEXP dn; Rboolean do_dn = FALSE;
if(keep_dimnms) {
dn = GET_SLOT(Ap, Matrix_DimNamesSym);
do_dn = !isNull(VECTOR_ELT(dn, 0));
if(do_dn) {
dn = PROTECT(duplicate(dn));
// permute rownames by p : rn <- rn[ p ] :
SEXP rn = PROTECT(duplicate(VECTOR_ELT(dn, 0)));
for(int i=0; i < n; i++)
SET_STRING_ELT(VECTOR_ELT(dn, 0), i, STRING_ELT(rn, p[i]));
UNPROTECT(1); // rn
SET_VECTOR_ELT(dn, 1, R_NilValue); // colnames(.) := NULL
}
}
SET_SLOT(ans, install("L"),
Matrix_cs_to_SEXP(N->L, "dtCMatrix", 0, do_dn ? dn : R_NilValue));
if(keep_dimnms) {
if(do_dn) {
UNPROTECT(1); // dn
dn = GET_SLOT(Ap, Matrix_DimNamesSym);
}
do_dn = !isNull(VECTOR_ELT(dn, 1));
if(do_dn) {
dn = PROTECT(duplicate(dn));
if(order) { // permute colnames by S->q : cn <- cn[ S->q ] :
SEXP cn = PROTECT(duplicate(VECTOR_ELT(dn, 1)));
for(int j=0; j < n; j++)
SET_STRING_ELT(VECTOR_ELT(dn, 1), j, STRING_ELT(cn, S->q[j]));
UNPROTECT(1); // cn
}
SET_VECTOR_ELT(dn, 0, R_NilValue); // rownames(.) := NULL
}
}
SET_SLOT(ans, install("U"),
Matrix_cs_to_SEXP(N->U, "dtCMatrix", 0, do_dn ? dn : R_NilValue));
if(do_dn) UNPROTECT(1); // dn
Memcpy(INTEGER(ALLOC_SLOT(ans, Matrix_pSym, /* "p" */
INTSXP, n)), p, n);
if (order)
Memcpy(INTEGER(ALLOC_SLOT(ans, install("q"),
INTSXP, n)), S->q, n);
cs_nfree(N);
cs_sfree(S);
cs_free(p);
UNPROTECT(1);
set_factors(Ap, ans, "LU");
}
int main ( void )
{
cs *A;
cs *AT;
cs *C;
cs *D;
cs *Eye;
int i;
int m;
cs *T;
printf ( "\n" );
printf ( "CS_DEMO1:\n" );
printf ( " Demonstration of the CSPARSE package.\n" );
/*
Load the triplet matrix T from standard input.
*/
T = cs_load ( stdin );
/*
Print T.
*/
printf ( "T:\n" );
cs_print ( T, 0 );
/*
A = compressed-column form of T.
*/
A = cs_triplet ( T );
printf ( "A:\n" );
cs_print ( A, 0 );
/*
Clear T.
*/
cs_spfree ( T );
/*
AT = A'.
*/
AT = cs_transpose ( A, 1 );
printf ( "AT:\n" );
cs_print ( AT, 0 );
/*
M = number of rows of A.
*/
m = A->m;
/*
Create triplet identity matrix.
*/
T = cs_spalloc ( m, m, m, 1, 1 );
for ( i = 0; i < m; i++ )
{
cs_entry ( T, i, i, 1 );
}
/*
Eye = speye ( m )
*/
Eye = cs_triplet ( T );
cs_spfree ( T );
/*
Compute C = A * A'.
*/
C = cs_multiply ( A, AT );
/*
Compute D = C + Eye * norm (C,1).
*/
D = cs_add ( C, Eye, 1, cs_norm ( C ) );
printf ( "D:\n" );
cs_print ( D, 0 );
/*
Clear A, AT, C, D, Eye,
*/
cs_spfree ( A );
cs_spfree ( AT );
cs_spfree ( C );
cs_spfree ( D );
cs_spfree ( Eye );
/*
Terminate.
*/
printf ( "\n" );
printf ( "CS_DEMO1:\n" );
printf ( " Normal end of execution.\n" );
return ( 0 );
}
static int cs_fact_init_umfpack( cs_fact_t *umfd, const cs *A )
{
#ifdef USE_UMFPACK
int ret;
void *symbolic;
cs *T;
/* Create matrix and sort. */
/* Non-symmetric case. */
if (0) {
T = cs_transpose( A, 1 );
umfd->A = cs_transpose( T, 1 );
cs_spfree( T );
}
/* Symmetric case. */
else {
umfd->A = cs_transpose( A, 1 );
}
cs_dupl( umfd->A );
/* Generate symbolic. */
ret = umfpack_di_symbolic( umfd->n, umfd->n, umfd->A->p, umfd->A->i, umfd->A->x, &symbolic, NULL, NULL );
if (ret < UMFPACK_OK)
goto err_sym;
/* Generate numeric. */
ret = umfpack_di_numeric( umfd->A->p, umfd->A->i, umfd->A->x, symbolic, &umfd->numeric, NULL, NULL );
if (ret < UMFPACK_OK)
goto err_num;
else if (ret > UMFPACK_OK) {
switch (ret) {
case UMFPACK_WARNING_singular_matrix:
fprintf( stderr, "UMFPACK: Matrix is singular.\n" );
break;
case UMFPACK_WARNING_determinant_underflow:
fprintf( stderr, "UMFPACK: Determinant underflow.\n" );
break;
case UMFPACK_WARNING_determinant_overflow:
fprintf( stderr, "UMFPACK: Determinant overflow.\n" );
break;
}
}
/* Clean up symbolic. */
umfpack_di_free_symbolic( &symbolic );
/* Allocate buffers. */
umfd->wi = malloc( umfd->n * sizeof(int) );
if (umfd->wi == NULL)
goto err_wi;
umfd->w = malloc( umfd->n*5 * sizeof(double) ); /* We consider iteration refinement. */
if (umfd->w == NULL)
goto err_w;
umfd->x = calloc( umfd->n, sizeof(double) );
if (umfd->x == NULL)
goto err_x;
umfd->type = CS_FACT_UMFPACK;
return 0;
err_x:
free( umfd->w );
err_w:
free( umfd->wi );
err_wi:
umfpack_di_free_numeric( &umfd->numeric );
err_num:
umfpack_di_free_symbolic( &symbolic );
err_sym:
cs_spfree( umfd->A );
return -1;
#else /* USE_UMFPACK */
(void) umfd;
(void) A;
return -1;
#endif /* USE_UMFPACK */
}
/* p = amd(A+A') if symmetric is true, or amd(A'A) otherwise */
CS_INT *cs_amd (CS_INT order, const cs *A) /* order 0:natural, 1:Chol, 2:LU, 3:QR */
{
cs *C, *A2, *AT ;
CS_INT *Cp, *Ci, *last, *W, *len, *nv, *next, *P, *head, *elen, *degree, *w,
*hhead, *ATp, *ATi, d, dk, dext, lemax = 0, e, elenk, eln, i, j, k, k1,
k2, k3, jlast, ln, dense, nzmax, mindeg = 0, nvi, nvj, nvk, mark, wnvi,
ok, cnz, nel = 0, p, p1, p2, p3, p4, pj, pk, pk1, pk2, pn, q, n, m, t ;
unsigned CS_INT h ;
/* --- Construct matrix C ----------------------------------------------- */
if (!CS_CSC (A) || order <= 0 || order > 3) return (NULL) ; /* check */
AT = cs_transpose (A, 0) ; /* compute A' */
if (!AT) return (NULL) ;
m = A->m ; n = A->n ;
dense = CS_MAX (16, 10 * sqrt ((double) n)) ; /* find dense threshold */
dense = CS_MIN (n-2, dense) ;
if (order == 1 && n == m)
{
C = cs_add (A, AT, 0, 0) ; /* C = A+A' */
}
else if (order == 2)
{
ATp = AT->p ; /* drop dense columns from AT */
ATi = AT->i ;
for (p2 = 0, j = 0 ; j < m ; j++)
{
p = ATp [j] ; /* column j of AT starts here */
ATp [j] = p2 ; /* new column j starts here */
if (ATp [j+1] - p > dense) continue ; /* skip dense col j */
for ( ; p < ATp [j+1] ; p++) ATi [p2++] = ATi [p] ;
}
ATp [m] = p2 ; /* finalize AT */
A2 = cs_transpose (AT, 0) ; /* A2 = AT' */
C = A2 ? cs_multiply (AT, A2) : NULL ; /* C=A'*A with no dense rows */
cs_spfree (A2) ;
}
else
{
C = cs_multiply (AT, A) ; /* C=A'*A */
}
cs_spfree (AT) ;
if (!C) return (NULL) ;
cs_fkeep (C, &cs_diag, NULL) ; /* drop diagonal entries */
Cp = C->p ;
cnz = Cp [n] ;
P = cs_malloc (n+1, sizeof (CS_INT)) ; /* allocate result */
W = cs_malloc (8*(n+1), sizeof (CS_INT)) ; /* get workspace */
t = cnz + cnz/5 + 2*n ; /* add elbow room to C */
if (!P || !W || !cs_sprealloc (C, t)) return (cs_idone (P, C, W, 0)) ;
len = W ; nv = W + (n+1) ; next = W + 2*(n+1) ;
head = W + 3*(n+1) ; elen = W + 4*(n+1) ; degree = W + 5*(n+1) ;
w = W + 6*(n+1) ; hhead = W + 7*(n+1) ;
last = P ; /* use P as workspace for last */
/* --- Initialize quotient graph ---------------------------------------- */
for (k = 0 ; k < n ; k++) len [k] = Cp [k+1] - Cp [k] ;
len [n] = 0 ;
nzmax = C->nzmax ;
Ci = C->i ;
for (i = 0 ; i <= n ; i++)
{
head [i] = -1 ; /* degree list i is empty */
last [i] = -1 ;
next [i] = -1 ;
hhead [i] = -1 ; /* hash list i is empty */
nv [i] = 1 ; /* node i is just one node */
w [i] = 1 ; /* node i is alive */
elen [i] = 0 ; /* Ek of node i is empty */
degree [i] = len [i] ; /* degree of node i */
}
mark = cs_wclear (0, 0, w, n) ; /* clear w */
elen [n] = -2 ; /* n is a dead element */
Cp [n] = -1 ; /* n is a root of assembly tree */
w [n] = 0 ; /* n is a dead element */
/* --- Initialize degree lists ------------------------------------------ */
for (i = 0 ; i < n ; i++)
{
d = degree [i] ;
if (d == 0) /* node i is empty */
{
elen [i] = -2 ; /* element i is dead */
nel++ ;
Cp [i] = -1 ; /* i is a root of assembly tree */
w [i] = 0 ;
}
else if (d > dense) /* node i is dense */
{
nv [i] = 0 ; /* absorb i into element n */
elen [i] = -1 ; /* node i is dead */
nel++ ;
Cp [i] = CS_FLIP (n) ;
nv [n]++ ;
}
else
{
if (head [d] != -1) last [head [d]] = i ;
next [i] = head [d] ; /* put node i in degree list d */
head [d] = i ;
}
}
while (nel < n) /* while (selecting pivots) do */
{
/* --- Select node of minimum approximate degree -------------------- */
for (k = -1 ; mindeg < n && (k = head [mindeg]) == -1 ; mindeg++) ;
if (next [k] != -1) last [next [k]] = -1 ;
head [mindeg] = next [k] ; /* remove k from degree list */
elenk = elen [k] ; /* elenk = |Ek| */
nvk = nv [k] ; /* # of nodes k represents */
nel += nvk ; /* nv[k] nodes of A eliminated */
/* --- Garbage collection ------------------------------------------- */
if (elenk > 0 && cnz + mindeg >= nzmax)
{
for (j = 0 ; j < n ; j++)
{
if ((p = Cp [j]) >= 0) /* j is a live node or element */
{
Cp [j] = Ci [p] ; /* save first entry of object */
Ci [p] = CS_FLIP (j) ; /* first entry is now CS_FLIP(j) */
}
}
for (q = 0, p = 0 ; p < cnz ; ) /* scan all of memory */
{
if ((j = CS_FLIP (Ci [p++])) >= 0) /* found object j */
{
Ci [q] = Cp [j] ; /* restore first entry of object */
Cp [j] = q++ ; /* new pointer to object j */
for (k3 = 0 ; k3 < len [j]-1 ; k3++) Ci [q++] = Ci [p++] ;
}
}
cnz = q ; /* Ci [cnz...nzmax-1] now free */
}
/* --- Construct new element ---------------------------------------- */
dk = 0 ;
nv [k] = -nvk ; /* flag k as in Lk */
p = Cp [k] ;
pk1 = (elenk == 0) ? p : cnz ; /* do in place if elen[k] == 0 */
pk2 = pk1 ;
for (k1 = 1 ; k1 <= elenk + 1 ; k1++)
{
if (k1 > elenk)
{
e = k ; /* search the nodes in k */
pj = p ; /* list of nodes starts at Ci[pj]*/
ln = len [k] - elenk ; /* length of list of nodes in k */
}
else
{
e = Ci [p++] ; /* search the nodes in e */
pj = Cp [e] ;
ln = len [e] ; /* length of list of nodes in e */
}
for (k2 = 1 ; k2 <= ln ; k2++)
{
i = Ci [pj++] ;
if ((nvi = nv [i]) <= 0) continue ; /* node i dead, or seen */
dk += nvi ; /* degree[Lk] += size of node i */
nv [i] = -nvi ; /* negate nv[i] to denote i in Lk*/
Ci [pk2++] = i ; /* place i in Lk */
if (next [i] != -1) last [next [i]] = last [i] ;
if (last [i] != -1) /* remove i from degree list */
{
next [last [i]] = next [i] ;
}
else
{
head [degree [i]] = next [i] ;
}
}
if (e != k)
{
Cp [e] = CS_FLIP (k) ; /* absorb e into k */
w [e] = 0 ; /* e is now a dead element */
}
}
if (elenk != 0) cnz = pk2 ; /* Ci [cnz...nzmax] is free */
degree [k] = dk ; /* external degree of k - |Lk\i| */
Cp [k] = pk1 ; /* element k is in Ci[pk1..pk2-1] */
len [k] = pk2 - pk1 ;
elen [k] = -2 ; /* k is now an element */
/* --- Find set differences ----------------------------------------- */
mark = cs_wclear (mark, lemax, w, n) ; /* clear w if necessary */
for (pk = pk1 ; pk < pk2 ; pk++) /* scan 1: find |Le\Lk| */
{
i = Ci [pk] ;
if ((eln = elen [i]) <= 0) continue ;/* skip if elen[i] empty */
nvi = -nv [i] ; /* nv [i] was negated */
wnvi = mark - nvi ;
for (p = Cp [i] ; p <= Cp [i] + eln - 1 ; p++) /* scan Ei */
{
e = Ci [p] ;
if (w [e] >= mark)
{
w [e] -= nvi ; /* decrement |Le\Lk| */
}
else if (w [e] != 0) /* ensure e is a live element */
{
w [e] = degree [e] + wnvi ; /* 1st time e seen in scan 1 */
}
}
}
/* --- Degree update ------------------------------------------------ */
for (pk = pk1 ; pk < pk2 ; pk++) /* scan2: degree update */
{
i = Ci [pk] ; /* consider node i in Lk */
p1 = Cp [i] ;
p2 = p1 + elen [i] - 1 ;
pn = p1 ;
for (h = 0, d = 0, p = p1 ; p <= p2 ; p++) /* scan Ei */
{
e = Ci [p] ;
if (w [e] != 0) /* e is an unabsorbed element */
{
dext = w [e] - mark ; /* dext = |Le\Lk| */
if (dext > 0)
{
d += dext ; /* sum up the set differences */
Ci [pn++] = e ; /* keep e in Ei */
h += e ; /* compute the hash of node i */
}
else
{
Cp [e] = CS_FLIP (k) ; /* aggressive absorb. e->k */
w [e] = 0 ; /* e is a dead element */
}
}
}
elen [i] = pn - p1 + 1 ; /* elen[i] = |Ei| */
p3 = pn ;
p4 = p1 + len [i] ;
for (p = p2 + 1 ; p < p4 ; p++) /* prune edges in Ai */
{
j = Ci [p] ;
if ((nvj = nv [j]) <= 0) continue ; /* node j dead or in Lk */
d += nvj ; /* degree(i) += |j| */
Ci [pn++] = j ; /* place j in node list of i */
h += j ; /* compute hash for node i */
}
if (d == 0) /* check for mass elimination */
{
Cp [i] = CS_FLIP (k) ; /* absorb i into k */
nvi = -nv [i] ;
dk -= nvi ; /* |Lk| -= |i| */
nvk += nvi ; /* |k| += nv[i] */
nel += nvi ;
nv [i] = 0 ;
elen [i] = -1 ; /* node i is dead */
}
else
{
degree [i] = CS_MIN (degree [i], d) ; /* update degree(i) */
Ci [pn] = Ci [p3] ; /* move first node to end */
Ci [p3] = Ci [p1] ; /* move 1st el. to end of Ei */
Ci [p1] = k ; /* add k as 1st element in of Ei */
len [i] = pn - p1 + 1 ; /* new len of adj. list of node i */
h %= n ; /* finalize hash of i */
next [i] = hhead [h] ; /* place i in hash bucket */
hhead [h] = i ;
last [i] = h ; /* save hash of i in last[i] */
}
} /* scan2 is done */
degree [k] = dk ; /* finalize |Lk| */
lemax = CS_MAX (lemax, dk) ;
mark = cs_wclear (mark+lemax, lemax, w, n) ; /* clear w */
/* --- Supernode detection ------------------------------------------ */
for (pk = pk1 ; pk < pk2 ; pk++)
{
i = Ci [pk] ;
if (nv [i] >= 0) continue ; /* skip if i is dead */
h = last [i] ; /* scan hash bucket of node i */
i = hhead [h] ;
hhead [h] = -1 ; /* hash bucket will be empty */
for ( ; i != -1 && next [i] != -1 ; i = next [i], mark++)
{
ln = len [i] ;
eln = elen [i] ;
for (p = Cp [i]+1 ; p <= Cp [i] + ln-1 ; p++) w [Ci [p]] = mark;
jlast = i ;
for (j = next [i] ; j != -1 ; ) /* compare i with all j */
{
ok = (len [j] == ln) && (elen [j] == eln) ;
for (p = Cp [j] + 1 ; ok && p <= Cp [j] + ln - 1 ; p++)
{
if (w [Ci [p]] != mark) ok = 0 ; /* compare i and j*/
}
if (ok) /* i and j are identical */
{
Cp [j] = CS_FLIP (i) ; /* absorb j into i */
nv [i] += nv [j] ;
nv [j] = 0 ;
elen [j] = -1 ; /* node j is dead */
j = next [j] ; /* delete j from hash bucket */
next [jlast] = j ;
}
else
{
jlast = j ; /* j and i are different */
j = next [j] ;
}
}
}
}
/* --- Finalize new element------------------------------------------ */
for (p = pk1, pk = pk1 ; pk < pk2 ; pk++) /* finalize Lk */
{
i = Ci [pk] ;
if ((nvi = -nv [i]) <= 0) continue ;/* skip if i is dead */
nv [i] = nvi ; /* restore nv[i] */
d = degree [i] + dk - nvi ; /* compute external degree(i) */
d = CS_MIN (d, n - nel - nvi) ;
if (head [d] != -1) last [head [d]] = i ;
next [i] = head [d] ; /* put i back in degree list */
last [i] = -1 ;
head [d] = i ;
mindeg = CS_MIN (mindeg, d) ; /* find new minimum degree */
degree [i] = d ;
Ci [p++] = i ; /* place i in Lk */
}
nv [k] = nvk ; /* # nodes absorbed into k */
if ((len [k] = p-pk1) == 0) /* length of adj list of element k*/
{
Cp [k] = -1 ; /* k is a root of the tree */
w [k] = 0 ; /* k is now a dead element */
}
if (elenk != 0) cnz = p ; /* free unused space in Lk */
}
/* --- Postordering ----------------------------------------------------- */
for (i = 0 ; i < n ; i++) Cp [i] = CS_FLIP (Cp [i]) ;/* fix assembly tree */
for (j = 0 ; j <= n ; j++) head [j] = -1 ;
for (j = n ; j >= 0 ; j--) /* place unordered nodes in lists */
{
if (nv [j] > 0) continue ; /* skip if j is an element */
next [j] = head [Cp [j]] ; /* place j in list of its parent */
head [Cp [j]] = j ;
}
for (e = n ; e >= 0 ; e--) /* place elements in lists */
{
if (nv [e] <= 0) continue ; /* skip unless e is an element */
if (Cp [e] != -1)
{
next [e] = head [Cp [e]] ; /* place e in list of its parent */
head [Cp [e]] = e ;
}
}
for (k = 0, i = 0 ; i <= n ; i++) /* postorder the assembly tree */
{
if (Cp [i] == -1) k = cs_tdfs (i, k, head, next, P, w) ;
}
return (cs_idone (P, C, W, 1)) ;
}
int
main (int argc, char **argv)
{
feenableexcept(FE_INVALID |
FE_DIVBYZERO |
FE_OVERFLOW |
FE_UNDERFLOW);
struct arguments arguments;
/* Default values. */
arguments.silent = 0;
arguments.verbose = 0;
// file paths
arguments.test_file = NULL;
arguments.train_file = NULL;
arguments.test_predict_file= NULL;
arguments.train_pairs = NULL;
// fm default parameters
arguments.k = 8;
arguments.n_iter = 50;
arguments.init_var = 0.01;
arguments.step_size = 0.01;
arguments.l2_reg = 1;
arguments.l2_reg_w = 0;
arguments.l2_reg_V = 0;
arguments.solver = "mcmc";
arguments.task = "regression";
arguments.rng_seed = time(NULL);
int arg_count = 2;
arguments.arg_count = &arg_count;
/* Parse our arguments; every option seen by parse_opt will
be reflected in arguments. */
argp_parse (&argp, argc, argv, 0, 0, &arguments);
ffm_param param = {.n_iter = arguments.n_iter,
.init_sigma = arguments.init_var,
.k = arguments.k,
.stepsize = arguments.step_size,
.rng_seed = arguments.rng_seed};
// parse solver
if (strcmp(arguments.solver,"mcmc") == 0)
param.SOLVER = SOLVER_MCMC;
else if(strcmp(arguments.solver,"als") == 0)
param.SOLVER = SOLVER_ALS;
else if(strcmp(arguments.solver,"sgd") == 0)
param.SOLVER = SOLVER_SGD;
else assert(0 && "unknown solver");
// parse task
if (strcmp(arguments.task,"regression") == 0)
param.TASK = TASK_REGRESSION;
else if(strcmp(arguments.task,"classification") == 0)
param.TASK = TASK_CLASSIFICATION;
else if(strcmp(arguments.task,"ranking") == 0)
param.TASK = TASK_RANKING;
else assert(0 && "unknown task");
printf ("TRAIN_FILE = %s\nTEST_FILE = %s\n"
"VERBOSE = %s\nSILENT = %s\n",
arguments.args[0], arguments.args[1],
arguments.verbose ? "yes" : "no",
arguments.silent ? "yes" : "no");
printf ("task=%s", arguments.task);
printf (", init-var=%f", param.init_sigma);
printf (", n-iter=%i", param.n_iter);
if (param.TASK == TASK_RANKING)
printf (", step-size=%f", param.stepsize);
printf (", solver=%s", arguments.solver);
printf (", k=%i", param.k);
// default if no l2_reg_w specified
param.init_lambda_w = arguments.l2_reg;
param.init_lambda_V = arguments.l2_reg;
if (arguments.l2_reg_w != 0.0)
param.init_lambda_w = arguments.l2_reg_w;
if (arguments.l2_reg_V != 0.0)
param.init_lambda_V = arguments.l2_reg_V;
if (strcmp(arguments.solver,"mcmc") != 0)
{
printf (", l2-reg-w=%f", param.init_lambda_w);
if (arguments.k > 0)
printf (", l2-reg-V=%f", param.init_lambda_V);
printf("\n");
}
printf("\nload data\n");
fm_data train_data = read_svm_light_file(arguments.args[0]);
fm_data test_data = read_svm_light_file(arguments.args[1]);
int n_features = train_data.X->n;
ffm_vector *y_test_predict = ffm_vector_calloc(test_data.y->size);
ffm_coef *coef = alloc_fm_coef(n_features, arguments.k, false);
printf("fit model\n");
if (param.TASK == TASK_RANKING)
{
assert(arguments.train_pairs != NULL && "Ranking requires the option '--train-pairs'");
ffm_matrix * train_pairs = ffm_matrix_from_file(arguments.train_pairs);
cs *X_t = cs_transpose (train_data.X, 1);
cs_spfree(train_data.X);
train_data.X = X_t;
ffm_fit_sgd_bpr(coef, train_data.X, train_pairs, param);
//printf("c%", arguments.train_pairs);
}
else
sparse_fit(coef, train_data.X, test_data.X, train_data.y, y_test_predict,
param);
// the predictions are calculated during the training phase for mcmc
if (param.SOLVER != SOLVER_MCMC){
sparse_predict(coef, test_data.X, y_test_predict);
if (param.TASK == TASK_CLASSIFICATION)
ffm_vector_normal_cdf(y_test_predict);
}
// save predictions
if (arguments.test_predict_file){
FILE *f = fopen(arguments.test_predict_file, "w");
for (int i=0; i< y_test_predict->size; i++)
fprintf(f, "%f\n", y_test_predict->data[i]);
fclose(f);
}
if (param.TASK == TASK_REGRESSION)
printf("\nr2 score: %f \n", ffm_r2_score(test_data.y, y_test_predict));
if (param.TASK == TASK_CLASSIFICATION)
printf("\nacc score: %f \n", ffm_vector_accuracy(test_data.y, y_test_predict));
/*
printf("calculate kendall tau\n");
if (param.TASK == TASK_RANKING)
{
ffm_vector * true_order = ffm_vector_get_order(test_data.y);
ffm_vector * pred_order = ffm_vector_get_order(y_test_predict);
double kendall_tau = \
ffm_vector_kendall_tau(true_order, pred_order);
printf("\nkendall tau: %f \n", kendall_tau);
}
*/
exit (0);
}
void test_sparse_als_zero_order_only(TestFixture_T *pFix, gconstpointer pg) {
int n_features = pFix->X->n;
int k = 0;
ffm_param param = {.n_iter = 1,
.warm_start = true,
.ignore_w = true,
.init_sigma = 0.1,
.SOLVER = SOLVER_ALS,
.TASK = TASK_REGRESSION};
ffm_coef *coef = alloc_fm_coef(n_features, k, true);
param.init_lambda_w = 0;
sparse_fit(coef, pFix->X, NULL, pFix->y, NULL, param);
// g_assert_cmpfloat(4466.666666, ==, coef->w_0);
g_assert_cmpfloat(fabs(4466.666666 - coef->w_0), <, 1e-6);
free_ffm_coef(coef);
}
void test_sparse_als_first_order_only(TestFixture_T *pFix, gconstpointer pg) {
int n_features = pFix->X->n;
int k = 0;
ffm_param param = {.n_iter = 1,
.warm_start = true,
.ignore_w_0 = true,
.init_sigma = 0.1,
.SOLVER = SOLVER_ALS,
.TASK = TASK_REGRESSION};
ffm_coef *coef = alloc_fm_coef(n_features, k, false);
coef->w_0 = 0;
param.init_lambda_w = 0;
ffm_vector_set(coef->w, 0, 10);
ffm_vector_set(coef->w, 1, 20);
sparse_fit(coef, pFix->X, NULL, pFix->y, NULL, param);
// hand calculated results 1660.57142857 -11.87755102
g_assert_cmpfloat(fabs(1660.57142857 - ffm_vector_get(coef->w, 0)), <, 1e-8);
g_assert_cmpfloat(fabs(-11.87755102 - ffm_vector_get(coef->w, 1)), <, 1e-8);
free_ffm_coef(coef);
}
void test_sparse_als_second_order_only(TestFixture_T *pFix, gconstpointer pg) {
int n_features = pFix->X->n;
int k = 1;
ffm_param param = {.n_iter = 1,
.warm_start = true,
.ignore_w_0 = true,
.ignore_w = true,
.init_sigma = 0.1,
.SOLVER = SOLVER_ALS,
.TASK = TASK_REGRESSION};
ffm_coef *coef = alloc_fm_coef(n_features, k, false);
coef->w_0 = 0;
param.init_lambda_w = 0;
param.init_lambda_V = 0;
ffm_matrix_set(coef->V, 0, 0, 300);
ffm_matrix_set(coef->V, 0, 1, 400);
sparse_fit(coef, pFix->X, NULL, pFix->y, NULL, param);
// hand calculated results 0.79866412 400.
g_assert_cmpfloat(fabs(0.79866412 - ffm_matrix_get(coef->V, 0, 0)), <, 1e-8);
g_assert_cmpfloat(fabs(400 - ffm_matrix_get(coef->V, 0, 1)), <, 1e-8);
free_ffm_coef(coef);
}
void test_sparse_als_all_interactions(TestFixture_T *pFix, gconstpointer pg) {
int n_features = pFix->X->n;
int k = 1;
ffm_param param = {.n_iter = 1,
.warm_start = true,
.ignore_w_0 = false,
.ignore_w = false,
.init_sigma = 0.1,
.SOLVER = SOLVER_ALS,
.TASK = TASK_REGRESSION};
ffm_coef *coef = alloc_fm_coef(n_features, k, false);
coef->w_0 = 0;
ffm_vector_set(coef->w, 0, 10);
ffm_vector_set(coef->w, 1, 20);
ffm_matrix_set(coef->V, 0, 0, 300);
ffm_matrix_set(coef->V, 0, 1, 400);
sparse_fit(coef, pFix->X, NULL, pFix->y, NULL, param);
// hand calculated results checked with libfm
g_assert_cmpfloat(fabs(-1755643.33333 - coef->w_0), <, 1e-5);
g_assert_cmpfloat(fabs(-191459.71428571 - ffm_vector_get(coef->w, 0)), <,
1e-6);
g_assert_cmpfloat(fabs(30791.91836735 - ffm_vector_get(coef->w, 1)), <, 1e-6);
g_assert_cmpfloat(fabs(253.89744249 - ffm_matrix_get(coef->V, 0, 0)), <,
1e-6);
g_assert_cmpfloat(fabs(400 - ffm_matrix_get(coef->V, 0, 1)), <, 1e-6);
param.n_iter = 99;
sparse_fit(coef, pFix->X, NULL, pFix->y, NULL, param);
g_assert_cmpfloat(fabs(210911.940403 - coef->w_0), <, 1e-7);
g_assert_cmpfloat(fabs(-322970.68313639 - ffm_vector_get(coef->w, 0)), <,
1e-6);
g_assert_cmpfloat(fabs(51927.60978978 - ffm_vector_get(coef->w, 1)), <, 1e-6);
g_assert_cmpfloat(fabs(94.76612018 - ffm_matrix_get(coef->V, 0, 0)), <, 1e-6);
g_assert_cmpfloat(fabs(400 - ffm_matrix_get(coef->V, 0, 1)), <, 1e-6);
free_ffm_coef(coef);
}
void test_sparse_als_first_order_interactions(TestFixture_T *pFix,
gconstpointer pg) {
ffm_vector *y_pred = ffm_vector_calloc(5);
int n_features = pFix->X->n;
int k = 0;
ffm_coef *coef = alloc_fm_coef(n_features, k, false);
ffm_param param = {.n_iter = 500,
.init_sigma = 0.1,
.SOLVER = SOLVER_ALS,
.TASK = TASK_REGRESSION};
sparse_fit(coef, pFix->X, NULL, pFix->y, NULL, param);
sparse_predict(coef, pFix->X, y_pred);
/* reference values from sklearn LinearRegression
y_pred: [ 321.05084746 346.6779661 -40.15254237 321.05084746
790.37288136]
coef: [ 69.6779661 152.16949153]
mse: 3134.91525424 */
g_assert_cmpfloat(fabs(321.05084746 - ffm_vector_get(y_pred, 0)), <, 1e-6);
g_assert_cmpfloat(fabs(346.6779661 - ffm_vector_get(y_pred, 1)), <, 1e-6);
g_assert_cmpfloat(fabs(-40.15254237 - ffm_vector_get(y_pred, 2)), <, 1e-6);
g_assert_cmpfloat(fabs(321.05084746 - ffm_vector_get(y_pred, 3)), <, 1e-6);
g_assert_cmpfloat(fabs(790.37288136 - ffm_vector_get(y_pred, 4)), <, 1e-6);
ffm_vector_free(y_pred);
free_ffm_coef(coef);
}
void test_sparse_als_second_interactions(TestFixture_T *pFix,
gconstpointer pg) {
ffm_vector *y_pred = ffm_vector_calloc(5);
int n_features = pFix->X->n;
int k = 2;
ffm_coef *coef = alloc_fm_coef(n_features, k, false);
ffm_param param = {.n_iter = 1000, .init_sigma = 0.1, .SOLVER = SOLVER_ALS};
sparse_fit(coef, pFix->X, NULL, pFix->y, NULL, param);
sparse_predict(coef, pFix->X, y_pred);
/* reference values from sklearn LinearRegression
y_pred: [ 298. 266. 29. 298. 848.]
coeff: [ 9. 2. 40.]
mse: 4.53374139449e-27 */
g_assert_cmpfloat(fabs(298 - ffm_vector_get(y_pred, 0)), <, 1e-4);
g_assert_cmpfloat(fabs(266 - ffm_vector_get(y_pred, 1)), <, 1e-4);
g_assert_cmpfloat(fabs(29 - ffm_vector_get(y_pred, 2)), <, 1e-3);
g_assert_cmpfloat(fabs(298 - ffm_vector_get(y_pred, 3)), <, 1e-4);
g_assert_cmpfloat(fabs(848.0 - ffm_vector_get(y_pred, 4)), <, 1e-4);
ffm_vector_free(y_pred);
free_ffm_coef(coef);
}
void test_sparse_mcmc_second_interactions(TestFixture_T *pFix,
gconstpointer pg) {
int n_features = pFix->X->n;
int n_samples = pFix->X->m;
int k = 2;
ffm_coef *coef = alloc_fm_coef(n_features, k, false);
ffm_vector *y_pred = ffm_vector_calloc(n_samples);
ffm_param param = {.n_iter = 100,
.init_sigma = 0.1,
.SOLVER = SOLVER_MCMC,
.TASK = TASK_REGRESSION,
.rng_seed = 1234};
sparse_fit(coef, pFix->X, pFix->X, pFix->y, y_pred, param);
g_assert_cmpfloat(ffm_r2_score(pFix->y, y_pred), >, .98);
ffm_vector_free(y_pred);
free_ffm_coef(coef);
}
void test_sparse_mcmc_second_interactions_classification(TestFixture_T *pFix,
gconstpointer pg) {
int n_features = pFix->X->n;
int n_samples = pFix->X->m;
int k = 2;
ffm_vector_make_labels(pFix->y);
ffm_coef *coef = alloc_fm_coef(n_features, k, false);
ffm_vector *y_pred = ffm_vector_calloc(n_samples);
ffm_param param = {.n_iter = 10,
.init_sigma = 0.1,
.SOLVER = SOLVER_MCMC,
.TASK = TASK_CLASSIFICATION};
sparse_fit(coef, pFix->X, pFix->X, pFix->y, y_pred, param);
g_assert_cmpfloat(ffm_vector_accuracy(pFix->y, y_pred), >=, .98);
ffm_vector_free(y_pred);
free_ffm_coef(coef);
}
void test_train_test_of_different_size(TestFixture_T *pFix, gconstpointer pg) {
int n_features = pFix->X->n;
int k = 2;
int n_samples_short = 3;
int m = n_samples_short;
int n = n_features;
cs *X = cs_spalloc(m, n, m * n, 1, 1); /* create triplet identity matrix */
cs_entry(X, 0, 0, 6);
cs_entry(X, 0, 1, 1);
cs_entry(X, 1, 0, 2);
cs_entry(X, 1, 1, 3);
cs_entry(X, 2, 0, 3);
cs *X_csc = cs_compress(X); /* A = compressed-column form of T */
cs *X_t = cs_transpose(X_csc, 1);
cs_spfree(X);
ffm_vector *y = ffm_vector_calloc(n_samples_short);
// y [ 298 266 29 298 848 ]
y->data[0] = 298;
y->data[1] = 266;
y->data[2] = 29;
ffm_coef *coef = alloc_fm_coef(n_features, k, false);
ffm_vector *y_pred = ffm_vector_calloc(n_samples_short);
ffm_param param = {.n_iter = 20, .init_sigma = 0.01};
// test: train > test
param.SOLVER = SOLVER_ALS;
sparse_fit(coef, pFix->X, NULL, pFix->y, NULL, param);
sparse_predict(coef, X_csc, y_pred);
param.TASK = TASK_CLASSIFICATION;
sparse_fit(coef, pFix->X, NULL, pFix->y, NULL, param);
sparse_predict(coef, X_csc, y_pred);
param.SOLVER = SOLVER_MCMC;
param.TASK = TASK_CLASSIFICATION;
sparse_fit(coef, pFix->X, X_csc, pFix->y, y_pred, param);
param.TASK = TASK_REGRESSION;
sparse_fit(coef, pFix->X, X_csc, pFix->y, y_pred, param);
// test: train < test
param.SOLVER = SOLVER_MCMC;
param.TASK = TASK_CLASSIFICATION;
sparse_fit(coef, X_csc, pFix->X, y_pred, pFix->y, param);
param.TASK = TASK_REGRESSION;
sparse_fit(coef, X_csc, pFix->X, y_pred, pFix->y, param);
param.SOLVER = SOLVER_ALS;
sparse_fit(coef, X_csc, NULL, y_pred, NULL, param);
sparse_predict(coef, pFix->X, pFix->y);
param.TASK = TASK_CLASSIFICATION;
sparse_fit(coef, X_csc, NULL, y_pred, NULL, param);
sparse_predict(coef, pFix->X, pFix->y);
ffm_vector_free(y_pred);
free_ffm_coef(coef);
cs_spfree(X_t);
cs_spfree(X_csc);
}
void test_sparse_als_generated_data(void) {
int n_features = 10;
int n_samples = 100;
int k = 2;
TestFixture_T *data = makeTestFixture(124, n_samples, n_features, k);
ffm_vector *y_pred = ffm_vector_calloc(n_samples);
ffm_coef *coef = alloc_fm_coef(n_features, k, false);
ffm_param param = {.n_iter = 50, .init_sigma = 0.01, .SOLVER = SOLVER_ALS};
param.init_lambda_w = 23.5;
param.init_lambda_V = 23.5;
sparse_fit(coef, data->X, NULL, data->y, NULL, param);
sparse_predict(coef, data->X, y_pred);
g_assert_cmpfloat(ffm_r2_score(data->y, y_pred), >, 0.85);
ffm_vector_free(y_pred);
free_ffm_coef(coef);
TestFixtureDestructor(data, NULL);
}
void test_hyerparameter_sampling(void) {
ffm_rng *rng = ffm_rng_seed(12345);
int n_features = 20;
int n_samples = 150;
int k = 1; // don't just change k, the rank is hard coded in the test
// (ffm_vector_get(coef->lambda_V, 0);)
int n_replication = 40;
int n_draws = 1000;
ffm_vector *alpha_rep = ffm_vector_calloc(n_replication);
ffm_vector *lambda_w_rep = ffm_vector_calloc(n_replication);
ffm_vector *lambda_V_rep = ffm_vector_calloc(n_replication);
ffm_vector *mu_w_rep = ffm_vector_calloc(n_replication);
ffm_vector *mu_V_rep = ffm_vector_calloc(n_replication);
ffm_vector *err = ffm_vector_alloc(n_samples);
for (int j = 0; j < n_replication; j++) {
TestFixture_T *data = makeTestFixture(124, n_samples, n_features, k);
ffm_coef *coef = data->coef;
sparse_predict(coef, data->X, err);
ffm_vector_scale(err, -1);
ffm_vector_add(err, data->y);
// make sure that distribution is converged bevore selecting
// reference / init values
for (int l = 0; l < 50; l++) sample_hyper_parameter(coef, err, rng);
double alpha_init = coef->alpha;
double lambda_w_init = coef->lambda_w;
double lambda_V_init = ffm_vector_get(coef->lambda_V, 0);
double mu_w_init = coef->mu_w;
double mu_V_init = ffm_vector_get(coef->mu_V, 0);
double alpha_count = 0;
double lambda_w_count = 0, lambda_V_count = 0;
double mu_w_count = 0, mu_V_count = 0;
for (int l = 0; l < n_draws; l++) {
sample_hyper_parameter(coef, err, rng);
if (alpha_init > coef->alpha) alpha_count++;
if (lambda_w_init > coef->lambda_w) lambda_w_count++;
if (lambda_V_init > ffm_vector_get(coef->lambda_V, 0)) lambda_V_count++;
if (mu_w_init > coef->mu_w) mu_w_count++;
if (mu_V_init > ffm_vector_get(coef->mu_V, 0)) mu_V_count++;
}
ffm_vector_set(alpha_rep, j, alpha_count / (n_draws + 1));
ffm_vector_set(lambda_w_rep, j, lambda_w_count / (n_draws + 1));
ffm_vector_set(lambda_V_rep, j, lambda_V_count / (n_draws + 1));
ffm_vector_set(mu_w_rep, j, mu_w_count / (n_draws + 1));
ffm_vector_set(mu_V_rep, j, mu_V_count / (n_draws + 1));
TestFixtureDestructor(data, NULL);
}
double chi_alpha = 0;
for (int i = 0; i < n_replication; i++)
chi_alpha +=
ffm_pow_2(gsl_cdf_ugaussian_Qinv(ffm_vector_get(alpha_rep, i)));
g_assert_cmpfloat(gsl_ran_chisq_pdf(chi_alpha, n_replication), <, .05);
double chi_lambda_w = 0;
for (int i = 0; i < n_replication; i++)
chi_lambda_w +=
ffm_pow_2(gsl_cdf_ugaussian_Qinv(ffm_vector_get(lambda_w_rep, i)));
g_assert_cmpfloat(gsl_ran_chisq_pdf(chi_lambda_w, n_replication), <, .05);
double chi_lambda_V = 0;
for (int i = 0; i < n_replication; i++)
chi_lambda_V +=
ffm_pow_2(gsl_cdf_ugaussian_Qinv(ffm_vector_get(lambda_V_rep, i)));
g_assert_cmpfloat(gsl_ran_chisq_pdf(chi_lambda_V, n_replication), <, .05);
double chi_mu_w = 0;
for (int i = 0; i < n_replication; i++)
chi_mu_w += ffm_pow_2(gsl_cdf_ugaussian_Qinv(ffm_vector_get(mu_w_rep, i)));
g_assert_cmpfloat(gsl_ran_chisq_pdf(chi_mu_w, n_replication), <, .05);
double chi_mu_V = 0;
for (int i = 0; i < n_replication; i++)
chi_mu_V += ffm_pow_2(gsl_cdf_ugaussian_Qinv(ffm_vector_get(mu_V_rep, i)));
g_assert_cmpfloat(gsl_ran_chisq_pdf(chi_mu_V, n_replication), <, .05);
ffm_vector_free_all(alpha_rep, lambda_w_rep, lambda_V_rep, mu_w_rep, mu_V_rep,
err);
ffm_rng_free(rng);
}
/* calculate merit function for a local problem */
double fclib_merit_local (struct fclib_local *problem, enum fclib_merit merit, struct fclib_solution *solution)
{
struct fclib_matrix * W = problem->W;
struct fclib_matrix * V = problem->V;
struct fclib_matrix * R = problem->R;
double *mu = problem->mu;
double *q = problem->q;
double *s = problem->s;
int d = problem->spacedim;
if (d !=3 )
{
printf("fclib_merit_local for space dimension = %i not yet implemented\n",d);
return 0;
}
double *v = solution->v;
double *r = solution->r;
double *u = solution->u;
double *l = solution->l;
double error_l, error;
double * tmp;
error=0.0;
error_l=0.0;
int i, ic, ic3;
if (merit == MERIT_1)
{
/* cs M_cs; */
/* fclib_matrix_to_cssparse(W, &M_cs); */
/* cs V_cs; */
/* fclib_matrix_to_cssparse(V, &V_cs); */
/* cs R_cs; */
/* fclib_matrix_to_cssparse(R, &R_cs); */
int n_e =0;
if (R) n_e = R->n;
/* compute V^T {r} + R \lambda + s */
if (n_e >0)
{
cs * VT = cs_transpose((cs *)V, 0) ;
tmp = (double *)malloc(n_e*sizeof(double));
for (i =0; i <n_e; i++) tmp[i] = s[i] ;
cs_gaxpy(VT, r, tmp);
cs_gaxpy((cs *)R, l, tmp);
error_l += dnrm2(tmp,n_e)/(1.0 + dnrm2(s,n_e) );
free(tmp);
}
/* compute \hat u = W {r} + V\lambda + q */
tmp = (double *)malloc(W->n*sizeof(double));
for (i =0; i <W->n; i++) tmp[i] = q[i] ;
cs_gaxpy((cs*)V, l, tmp);
cs_gaxpy((cs*)W, r, tmp);
/* Compute natural map */
int nc = W->n/3;
for (ic = 0, ic3 = 0 ; ic < nc ; ic++, ic3 += 3)
{
FrictionContact3D_unitary_compute_and_add_error(r + ic3, tmp + ic3, mu[ic], &error);
}
free(tmp);
error = sqrt(error)/(1.0 + sqrt(dnrm2(q,W->n)) )+error_l;
/* printf("error_l = %12.8e", error_l); */
/* printf("norm of u = %12.8e\n", dnrm2(u,W->n)); */
/* printf("norm of r = %12.8e\n", dnrm2(r,W->n)); */
/* printf("error = %12.8e\n", error); */
return error;
}
return 0; /* TODO */
}
